work on inferencer, and vector-2map combinator

diff --git a/library/platform/native/stack.factor b/library/platform/native/stack.factor
index d4a38db9a3c3f5a4e19879ee5953fc27569baf18..e5ad4978ed8fcd36c7fd523cdf62758e336c4cd7 100644 (file)
--- a/library/platform/native/stack.factor
+++ b/library/platform/native/stack.factor
@@ -37,6 +37,7 @@ USE: vectors
 : dupd ( x y -- x x y ) >r dup r> ;
 : swapd ( x y z -- y x z ) >r swap r> ;
 : transp ( x y z -- z y x ) swap rot ;
+: 2swap ( x y z t -- z t x y ) rot >r rot r> ;
 
 : clear ( -- )
     #! Clear the datastack. For interactive use only; invoking

diff --git a/library/platform/native/vectors.factor b/library/platform/native/vectors.factor
index 25c3d352c55b0141a44f2523562c8ba37c616286..cc4d795d80e4d4f25085d9d87d1679fd4a06b2b8 100644 (file)
--- a/library/platform/native/vectors.factor
+++ b/library/platform/native/vectors.factor
@@ -32,9 +32,6 @@ USE: lists
 USE: math
 USE: stack
 
-: 2vector-nth ( n vec vec -- obj obj )
-    >r over >r vector-nth r> r> vector-nth ;
-
 : ?vector= ( n vec vec -- ? )
     #! Reached end?
     drop vector-length = ;

diff --git a/library/test/inference.factor b/library/test/inference.factor
index a2a7db205542b5b945cbbfef8f462945b4018e71..da02f4a6c25bb1a06ceb0832602f5c0ee50f24c0 100644 (file)
--- a/library/test/inference.factor
+++ b/library/test/inference.factor
@@ -5,9 +5,17 @@ USE: math
 USE: stack
 USE: combinators
 USE: vectors
+USE: kernel
 
 [ 6 ] [ 6 gensym-vector vector-length ] unit-test
 
+[ t ] [
+    { 1 2 } { 1 2 3 } 
+    unify-lengths swap vector-length swap vector-length =
+] unit-test
+
+[ [ sq ] ] [ [ sq ] [ sq ] unify-result ] unit-test
+
 [ [ 0 | 2 ] ] [ [ 2 "Hello" ] infer ] unit-test
 [ [ 1 | 2 ] ] [ [ dup ] infer ] unit-test
 
@@ -41,3 +49,11 @@ USE: vectors
 
 [ [ 1 | 0 ] ] [ [ [ drop ] when* ] infer ] unit-test
 [ [ 1 | 1 ] ] [ [ [ { { [ ] } } ] unless* ] infer ] unit-test
+
+[ [ 0 | 1 ] ] [
+    [ [ 2 2 fixnum+ ] dup [ ] when call ] infer
+] unit-test
+
+[
+    [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] ifte call
+] unit-test-fails

diff --git a/library/test/vectors.factor b/library/test/vectors.factor
index 44cf2a02b84f3c4a4e782a40233f758ffd2a3543..1b635eb90689ca6c3179166e0eedde18128822cc 100644 (file)
--- a/library/test/vectors.factor
+++ b/library/test/vectors.factor
@@ -35,3 +35,11 @@ USE: vectors
 
 [ { 1 2 3 4 5 6 } ]
 [ { 1 2 3 } vector-clone dup { 4 5 6 } vector-append ] unit-test
+
+[ { 6 8 10 12 } ]
+[ { 1 2 3 4 } { 5 6 7 8 } [ + ] vector-2map ]
+unit-test
+
+[ { [ 1 | 5 ] [ 2 | 6 ] [ 3 | 7 ] [ 4 | 8 ] } ]
+[ { 1 2 3 4 } { 5 6 7 8 } vector-zip ]
+unit-test

diff --git a/library/tools/inference.factor b/library/tools/inference.factor
index 0af50d9c0018b4f2e891334dc602f39b0b6493fd..e8310ba6a8c0202d969df5838d79b3fd19a921dc 100644 (file)
--- a/library/tools/inference.factor
+++ b/library/tools/inference.factor
@@ -53,19 +53,19 @@ SYMBOL: r-in
 
 : inputs ( count stack -- stack )
     #! Add this many inputs to the given stack.
-    >r dup d-in +@ gensym-vector dup r> vector-append ;
+    >r gensym-vector dup r> vector-append ;
 
-: ensure ( count stack -- stack )
+: ensure ( count stack -- count stack )
     #! Ensure stack has this many elements.
     2dup vector-length > [
-        [ vector-length - ] keep inputs
+        [ vector-length - dup ] keep inputs
     ] [
-        nip
+        >r drop 0 r>
     ] ifte ;
 
 : ensure-d ( count -- )
     #! Ensure count of unknown results are on the stack.
-    meta-d get ensure meta-d set ;
+    meta-d get ensure meta-d set  d-in +@ ;
 
 : consume-d ( count -- )
     #! Remove count of elements.
@@ -76,6 +76,10 @@ SYMBOL: r-in
     [ gensym push-d ] times ;
 
 : standard-effect ( word [ in | out ] -- )
+    #! If a word does not have special inference behavior, we
+    #! either execute the word in the meta interpreter (if it is
+    #! side-effect-free and all parameters are literal), or
+    #! simply apply its stack effect to the meta-interpreter.
     over "meta-infer" word-property [
         drop host-word
     ] [
@@ -118,35 +122,61 @@ DEFER: (infer)
     d-in get meta-d get vector-length cons ;
 
 : (infer) ( quot -- )
+    #! Recursive calls to this word are made for nested
+    #! quotations.
     [ dup word? [ apply-word ] [ push-d ] ifte ] each ;
 
 : infer ( quot -- [ in | out ] )
     #! Stack effect of a quotation.
     [ init-inference (infer)  effect ] with-scope ;
 
-: infer-branch ( quot -- [ in-d |  datastack ] )
+: infer-branch ( quot -- [ in-d | datastack ] )
+    #! Infer the quotation's effect, restoring the meta
+    #! interpreter state afterwards.
     [
         copy-interpreter (infer)
         d-in get  meta-d get cons
     ] with-scope ;
 
 : difference ( [ in | stack ] -- diff )
+    #! Stack height difference of infer-branch return value.
     uncons vector-length - ;
 
 : balanced? ( [ in | stack ] [ in | stack ] -- ? )
+    #! Check if two stack effects preserve stack height.
     difference swap difference = ;
 
+: max-vector-length ( vector vector -- length )
+    swap vector-length swap vector-length max ;
+
+: unify-lengths ( stack stack -- stack stack )
+    #! If one vector is shorter, pad it with unknown results at
+    #! the bottom.
+    2dup max-vector-length
+    tuck swap ensure nip >r swap ensure nip r> ;
+
+: unify-result ( obj obj -- obj )
+    #! Replace values with unknown result if they differ,
+    #! otherwise retain them.
+    2dup = [ drop ] [ 2drop gensym ] ifte ;
+
 : unify-stacks ( stack stack -- stack )
-    swap vector-length swap vector-length max gensym-vector ;
+    #! Replace differing literals in stacks with unknown
+    #! results.
+    unify-lengths [ unify-result ] vector-2map ;
 
 : unify ( [ in | stack ] [ in | stack ] -- )
+    #! Unify meta-interpreter state from two branches.
     2dup balanced? [
-        2dup 2car max d-in set 2cdr unify-stacks meta-d set
+        2dup
+        2car max d-in set
+        2cdr unify-stacks meta-d set
     ] [
         "Unbalanced ifte branches" throw
     ] ifte ;
 
 : infer-ifte ( -- )
+    #! Infer effects for both branches, unify.
     pop-d pop-d pop-d  drop ( condition )
     >r infer-branch r> infer-branch unify ;
 

diff --git a/library/vector-combinators.factor b/library/vector-combinators.factor
index 6f6e6ef90fb4a11b33f0e122ac28805f1d93603a..16d882f25bca9f58aff1adb82e01fa7d9a5d893d 100644 (file)
--- a/library/vector-combinators.factor
+++ b/library/vector-combinators.factor
@@ -28,6 +28,7 @@
 IN: vectors
 USE: combinators
 USE: kernel
+USE: lists
 USE: logic
 USE: math
 USE: stack
@@ -57,3 +58,26 @@ USE: stack
 : vector-append ( v1 v2 -- )
     #! Destructively append v2 to v1.
     [ over vector-push ] vector-each drop ;
+
+: vector-collect ( n quot -- accum )
+    #! Execute the quotation n times, passing the loop counter
+    #! the quotation, and collect results in a new vector.
+    over <vector> rot [
+        -rot 2dup >r >r slip vector-push r> r>
+    ] times* nip ;
+
+: vector-zip ( v1 v2 -- v )
+    #! Make a new vector with each pair of elements from the
+    #! first two in a pair.
+    over vector-length [
+        pick pick 2vector-nth cons
+    ] vector-collect nip nip ;
+
+: vector-2map ( v1 v2 quot -- v )
+    #! Apply a quotation with stack effect ( obj obj -- obj ) to
+    #! each pair of elements from v1 and v2, collecting them
+    #! into a new list. Behavior is undefined if vector lengths
+    #! differ.
+    -rot vector-zip [
+        swap dup >r >r uncons r> call r> swap
+    ] vector-map nip ;

diff --git a/library/vectors.factor b/library/vectors.factor
index 076e0b7f630a0b284864766ba551a4196ed79d95..2c49839947d461d24e6d80fbe614b53dc559d5ec 100644 (file)
--- a/library/vectors.factor
+++ b/library/vectors.factor
@@ -31,6 +31,9 @@ USE: lists
 USE: math
 USE: stack
 
+: 2vector-nth ( n vec vec -- obj obj )
+    >r over >r vector-nth r> r> vector-nth ;
+
 : empty-vector ( len -- vec )
     #! Creates a vector with 'len' elements set to f. Unlike
     #! <vector>, which gives an empty vector with a certain