: 2cons ( car1 car2 cdr1 cdr2 -- cons1 cons2 )
rot swons >r cons r> ;
+: zip ( list list -- list )
+ #! Make a new list containing pairs of corresponding
+ #! elements from the two given lists.
+ dup [
+ 2uncons zip >r cons r> cons
+ ] [
+ 2drop [ ]
+ ] ifte ;
+
: unzip ( assoc -- keys values )
#! Split an association list into two lists of keys and
#! values.
#! Either the word is not recursive, or it is recursive
#! and the base case throws an error.
[
- [ terminator-quot? not ] subset dup length 1 > [
+ unzip drop [ terminator-quot? not ] subset dup length 1 > [
infer-base-cases unify-effects
effect dual-recursive-state get set-base
] [
] with-scope ;
: (infer-branches) ( branchlist -- list )
- dup infer-base-case [
+ dup infer-base-case unzip drop [
dup t infer-branch swap terminator-quot? [
[ meta-d off meta-r off d-in off ] extend
] when
dataflow-drop, pop-d
dataflow-drop, pop-d swap 2list
>r 1 meta-d get vector-tail* #ifte r>
- pop-d drop ( condition )
+ pop-d [
+ dup \ t cons ,
+ \ f cons ,
+ ] make-list zip ( condition )
infer-branches ;
\ ifte [ infer-ifte ] "infer" set-word-property
#! Infer effects for all branches, unify.
[ object vector ] ensure-d
dataflow-drop, pop-d vtable>list
+ [ f cons ] map
>r 1 meta-d get vector-tail* #dispatch r>
pop-d drop ( n )
infer-branches ;
: intersection ( list list -- list )
#! Make a list of elements that occur in both lists.
[ over contains? ] subset nip ;
-
-: zip ( list list -- list )
- #! Make a new list containing pairs of corresponding
- #! elements from the two given lists.
- dup [
- 2uncons zip >r cons r> cons
- ] [
- 2drop [ ]
- ] ifte ;