cleaner type inference

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index badfa4cb7169cdba1163b9ef7e16e67461ddf939..e0810084a195c4e74d0f9adc6653e4be1fefb78a 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -34,8 +34,8 @@
 \r
 + listener/plugin:\r
 \r
+- stream server can hang because of exception handler limitations\r
 - listener should be multithreaded\r
-- fully socket based communication\r
 - compile all, infer all commands\r
 - type something -- no completions -- hit another key -- not inserted\r
 - faster completion\r
@@ -55,18 +55,15 @@
 - cat, reverse-cat primitives\r
 - first-class hashtables\r
 - add a socket timeout\r
-- do transfer-word in fixup\r
 \r
 + misc:\r
 \r
-- stream server can hang because of exception handler limitations\r
 - each-with map-with\r
 - step: print NEXT word to execute, not word that JUST executed\r
 - perhaps /i should work with all numbers\r
 - unit test weirdness: 2 lines appears at end\r
 - jedit ==> jedit-word, jedit takes a file name\r
 - nicer way to combine two paths\r
-- ditch object paths\r
 - browser responder for word links in HTTPd\r
 - worddef props\r
 - prettyprint: when unparse called due to recursion, write a link\r

diff --git a/library/generic/generic.factor b/library/generic/generic.factor
index e4077dedd97563db25313b3241322959d6c51277..ed57fda472f696ed6ecc0e9cf75dab19c3839b45 100644 (file)
--- a/library/generic/generic.factor
+++ b/library/generic/generic.factor
@@ -130,9 +130,6 @@ USE: math-internals
     dup init-methods
     dup <vtable> define-generic ;
 
-PREDICATE: compound generic ( word -- ? )
-    "combination" word-property ;
-
 : single-combination ( obj vtable -- )
     >r dup type r> dispatch ; inline
 

diff --git a/library/generic/predicate.factor b/library/generic/predicate.factor
index ae07db14680dfd8ea0b72c4a781c8f2f0448e973..4137bc7c1d74ecb7d18e87face5b25db46b2e466 100644 (file)
--- a/library/generic/predicate.factor
+++ b/library/generic/predicate.factor
@@ -87,3 +87,6 @@ predicate [
     dup predicate-word
     [ dupd unit "predicate" set-word-property ] keep
     [ define-predicate ] [ ] ; parsing
+
+PREDICATE: compound generic ( word -- ? )
+    "combination" word-property ;

diff --git a/library/inference/branches.factor b/library/inference/branches.factor
index 9421beda241489c5d7711f13e494bbd3cc196493..87efa1eebfc97a58f5ee3ac5dcac9f681252a108 100644 (file)
--- a/library/inference/branches.factor
+++ b/library/inference/branches.factor
@@ -109,23 +109,10 @@ USE: prettyprint
 
 SYMBOL: cloned
 
-: assq* ( key alist -- [ key | value ] )
-    #! Looks up the key in an alist. Push the key/value pair.
-    #! Most of the time you want to use assq not assq*.
-    dup [
-        2dup car car eq? [ nip car ] [ cdr assq* ] ifte
-    ] [
-        2drop f
-    ] ifte ;
-
-: assq ( key alist -- value )
-    #! Looks up the key in an alist.
-    assq* dup [ cdr ] when ;
-
 : deep-clone ( vector -- vector )
     #! Clone a vector if it hasn't already been cloned in this
     #! with-deep-clone scope.
-    dup cloned get assq dup [
+    dup cloned get assoc dup [
         nip
     ] [
         drop vector-clone [ dup cloned [ acons ] change ] keep
@@ -144,106 +131,43 @@ SYMBOL: cloned
     d-in [ deep-clone-vector ] change
     dataflow-graph off ;
 
+: terminator? ( obj -- ? )
+    dup word? [ "terminator" word-property ] [ drop f ] ifte ;
+
+: handle-terminator ( quot -- )
+    [ terminator? ] some? [
+        meta-d off meta-r off d-in off
+    ] when ;
+
 : infer-branch ( value -- namespace )
     <namespace> [
         uncons [ unswons set-value-class ] when*
         dup value-recursion recursive-state set
         copy-inference
-        literal-value infer-quot
+        literal-value dup infer-quot
         #values values-node
+        handle-terminator
     ] extend ;
 
-: terminator? ( obj -- ? )
-    dup word? [ "terminator" word-property ] [ drop f ] ifte ;
-
-: terminator-quot? ( [ quot | type-prop ] -- ? )
-    car literal-value [ terminator? ] some? ;
-
-: dual-branch ( branch branchlist -- rstate )
-    #! Return a recursive state for a branch other than the
-    #! given one in the list.
-    [ over eq? not ] subset nip car car value-recursion ;
-
-! FIXME this is really bad
-: old-effect ( [ in-types out-types ] -- [ in | out ] )
-    uncons car length >r length r> cons ;
-
-: foo>effect ( [ in-types out-types ] -- [ in | out ] )
-    [ effect old-effect ] bind ;
-
-: raise ( [ in | out ] -- [ in | out ] )
-    uncons 2dup min tuck - >r - r> cons ;
-
-: effect>foo ( [ in | out ] -- [ intypes outtypes ] )
-    <namespace> [
-        uncons
-        [ drop object <computed> ] vector-project meta-d set
-        [ drop object <computed> ] vector-project d-in set
-        { } meta-r set
-    ] extend ;
-
-: decompose ( first second -- solution )
-    #! Return a stack effect such that first*solution = second.
-    2dup 2car
-    2dup > [ "No solution to decomposition" throw ] when
-    swap - -rot 2cdr >r + r> cons raise effect>foo ;
-
-: set-base ( effect rstate -- )
-    #! Set the base case of the current word.
-    dup [
-        car cdr [
-            entry-effect get old-effect dup [ 0 | 0 ] = [
-                drop
-            ] [
-                swap foo>effect decompose
-            ] ifte
-            base-case cons@
-        ] bind
-    ] [
-        2drop
-    ] ifte ;
-
-: recursive-branch ( branch branchlist -- )
-    [
-        dupd dual-branch >r infer-branch r> set-base
-    ] [
-        [ 2drop ] when
-    ] catch ;
-
-: no-base-case ( word -- )
-    word-name " does not have a base case." cat2 throw ;
-
-: get-base ( word rstate -- effect )
-    [ base-case get ] bind dup [
-        nip [ unify-effects effect ] with-scope
-    ] [
-        drop no-base-case
-    ] ifte ;
-
-: infer-base-case ( branchlist -- )
-    [
-        inferring-base-case on
-
-        dup [
-            2dup terminator-quot? [
-                2drop
-            ] [
-                recursive-branch
-            ] ifte
-        ] each drop
-    ] with-scope ;
-
 : (infer-branches) ( branchlist -- list )
     #! The branchlist is a list of pairs:
     #! [ value | typeprop ]
     #! value is either a literal or computed instance; typeprop
     #! is a pair [ value | class ] indicating a type propagation
     #! for the given branch.
-    dup infer-base-case [
-        dup infer-branch swap terminator-quot? [
-            [ meta-d off meta-r off d-in off ] extend
-        ] when
-    ] map ;
+    [
+        [
+            inferring-base-case get [
+                [
+                    infer-branch ,
+                ] [
+                    [ drop ] when
+                ] catch
+            ] [
+                infer-branch ,
+            ] ifte
+        ] each
+    ] make-list ;
 
 : unify-dataflow ( inputs instruction effectlist -- )
     [ [ get-dataflow ] bind ] map

diff --git a/library/inference/inference.factor b/library/inference/inference.factor
index 7353d3afd6da4c0cdde93cd6c4b343a349738423..162005fbe89dfa2f8adafeaab1ad4cf3b87da607 100644 (file)
--- a/library/inference/inference.factor
+++ b/library/inference/inference.factor
@@ -53,15 +53,8 @@ SYMBOL: inferring-base-case
 ! inputs.
 SYMBOL: d-in
 
-! Recursive state. Alist maps words to hashmaps...
+! Recursive state. An alist, mapping words to labels.
 SYMBOL: recursive-state
-! ... with keys:
-SYMBOL: base-case
-SYMBOL: entry-effect
-! When a call to a combinator is compiled, recursion cannot
-! simply jump to the definition of the combinator. Instead, it
-! makes a local jump to this label.
-SYMBOL: recursive-label
 
 ! A value has the following slots:
 GENERIC: literal-value ( value -- obj )
@@ -140,16 +133,12 @@ M: literal set-value-class ( class value -- )
     d-in get [ value-class ] vector-map vector>list
     meta-d get [ value-class ] vector-map vector>list 2list ;
 
-: <recursive-state> ( -- state )
-    <namespace> [
-        base-case off  effect entry-effect set
-    ] extend ;
-
 : init-inference ( recursive-state -- )
     init-interpreter
     0 <vector> d-in set
     recursive-state set
-    dataflow-graph off ;
+    dataflow-graph off
+    inferring-base-case off ;
 
 DEFER: apply-word
 

diff --git a/library/inference/words.factor b/library/inference/words.factor
index 3b5bad573d49bc44947f6a66c46e7da19dbb44d3..fdcd3c3119dec1f260e9510592301bf5d466ea02 100644 (file)
--- a/library/inference/words.factor
+++ b/library/inference/words.factor
@@ -56,7 +56,7 @@ USE: prettyprint
 : produce-d ( typelist -- )
     [ <computed> push-d ] each ;
 
-: (consume/produce) ( param op effect -- )
+: (consume/produce) ( param op effect )
     [ unswons consume-d car produce-d ] with-dataflow ;
 
 : consume/produce ( word [ in-types out-types ] -- )
@@ -83,7 +83,6 @@ USE: prettyprint
     #! its dataflow contribution to a new block node in the IR.
     over [
         >r
-        <recursive-state> [ recursive-label set ] extend
         dupd cons
         recursive-state cons@
         r> call
@@ -120,31 +119,49 @@ M: symbol (apply-word) ( word -- )
     #! Push word we're currently inferring effect of.
     recursive-state get car car ;
 
-: check-recursion ( -- )
+: check-recursion ( word -- )
     #! If at the location of the recursive call, we're taking
     #! more items from the stack than producing, we have a
-    #! diverging recursion.
-    d-in get vector-length
-    meta-d get vector-length > [
-        current-word word-name " diverges." cat2 throw
+    #! diverging recursion. Note that this check is not done for
+    #! mutually-recursive words. Generally they should be
+    #! avoided.
+    recursive-state get car = [
+        d-in get vector-length
+        meta-d get vector-length > [
+            current-word word-name " diverges." cat2 throw
+        ] when
     ] when ;
 
-: recursive-word ( word state -- )
+: base-case ( word -- effect )
+    [
+        inferring-base-case on
+        copy-inference
+        inline-compound
+        inferring-base-case off
+    ] with-scope ;
+
+: decompose ( x y -- effect )
+    #! Return a stack effect such that x*effect = y.
+    2unlist >r swap 2unlist swap length tail append
+    ! workaround
+    [ drop object ] map
+    r> 2list ;
+
+: recursive-word ( word label -- )
     #! Handle a recursive call, by either applying a previously
     #! inferred base case, or raising an error. If the recursive
     #! call is to a local block, emit a label call node.
-    [ get-base ] 2keep [ recursive-label get ] bind
-    dup [
-        ( word effect label )
-        nip #call-label
+    inferring-base-case get [
+        drop word-name " does not have a base case." cat2 throw
     ] [
-        drop #call
-    ] ifte rot (consume/produce) ;
+        2dup [ drop #call-label ] [ nip #call ] ifte
+        rot base-case effect swap decompose (consume/produce)
+    ] ifte ;
 
 : apply-word ( word -- )
     #! Apply the word's stack effect to the inferencer state.
     dup recursive-state get assoc [
-        check-recursion recursive-word
+        dup check-recursion recursive-word
     ] [
         dup "infer-effect" word-property [
             apply-effect
@@ -165,11 +182,8 @@ M: symbol (apply-word) ( word -- )
 \ call [ infer-call ] "infer" set-word-property
 
 ! These are due to bugs and will be removed
-\ - [ [ number number ] [ number ] ] "infer-effect" set-word-property
 \ * [ [ number number ] [ number ] ] "infer-effect" set-word-property
-\ / [ [ number number ] [ number ] ] "infer-effect" set-word-property
 \ gcd [ [ number number ] [ number ] ] "infer-effect" set-word-property
-\ hashcode [ [ object ] [ integer ] ] "infer-effect" set-word-property
 
 \ undefined-method t "terminator" set-word-property
 \ not-a-number t "terminator" set-word-property

diff --git a/library/lists.factor b/library/lists.factor
index e05f288cd9cc83a1bac313f92dccb796c15c4ba1..0f62920bb6a3f799737830b15e8416a00d4e4a4c 100644 (file)
--- a/library/lists.factor
+++ b/library/lists.factor
@@ -33,6 +33,9 @@ USE: math
 : 2list ( a b -- [ a b ] )
     unit cons ;
 
+: 2unlist ( [ a b ] -- a b )
+    uncons car ;
+
 : 3list ( a b c -- [ a b c ] )
     2list cons ;
 
@@ -164,7 +167,7 @@ M: cons = ( obj cons -- ? )
     ] ifte ;
 
 : cons-hashcode ( cons count -- hash )
-    dup 0 = [
+    dup 0 number= [
         2drop 0
     ] [
         over cons? [

diff --git a/library/math/complex.factor b/library/math/complex.factor
index 2e606f88252a1096e4d8db166c9fe10650141d86..21fe06539e89ecb9cc7f8b2154138f3657b1b141 100644 (file)
--- a/library/math/complex.factor
+++ b/library/math/complex.factor
@@ -45,7 +45,7 @@ M: complex imaginary 1 slot ;
 
 : rect> ( xr xi -- x )
     over real? over real? and [
-        dup 0 = [ drop ] [ (rect>) ] ifte
+        dup 0 number= [ drop ] [ (rect>) ] ifte
     ] [
         "Complex number must have real components" throw drop
     ] ifte ; inline

diff --git a/library/math/integer.factor b/library/math/integer.factor
index 182388351ef0e4d7e686228bbba2f7a18f4fb56d..182a11775ef277073e85e4221cddb9553d6de552 100644 (file)
--- a/library/math/integer.factor
+++ b/library/math/integer.factor
@@ -33,23 +33,22 @@ USE: generic
 USE: kernel
 USE: math
 
-: reduce ( x y -- x' y' )
-    dup 0 < [ swap neg swap neg ] when
-    2dup gcd tuck /i >r /i r> ; inline
-
 : fraction> ( a b -- a/b )
-    dup 0 = [
-        "Division by zero" throw drop
+    dup 1 number= [
+        drop
     ] [
-        dup 1 = [
-            drop
-        ] [
-            (fraction>)
-        ] ifte
+        (fraction>)
     ] ifte ; inline
 
 : integer/ ( x y -- x/y )
-    reduce fraction> ; inline
+    dup 0 number= [
+        "Division by zero" throw drop
+    ] [
+        dup 0 < [
+            swap neg swap neg
+        ] when
+        2dup gcd tuck /i >r /i r> fraction>
+    ] ifte ;
 
 M: fixnum number= fixnum= ;
 M: fixnum < fixnum< ;

diff --git a/library/math/math.factor b/library/math/math.factor
index 6750d42facec7d6ab0debf4765329987f87490e6..d784356444bee083ab09702d1e742878b247d21e 100644 (file)
--- a/library/math/math.factor
+++ b/library/math/math.factor
@@ -106,11 +106,11 @@ GENERIC: abs ( z -- |z| )
 M: real abs dup 0 < [ neg ] when ;
 
 : (gcd) ( x y -- z )
-    dup 0 = [ drop ] [ tuck mod (gcd) ] ifte ;
+    dup 0 number= [ drop ] [ tuck mod (gcd) ] ifte ;
 
 : gcd ( x y -- z )
     #! Greatest common divisor.
     abs swap abs 2dup < [ swap ] when (gcd) ;
 
 : align ( offset width -- offset )
-    2dup mod dup 0 = [ 2drop ] [ - + ] ifte ;
+    2dup mod dup 0 number= [ 2drop ] [ - + ] ifte ;

diff --git a/library/syntax/see.factor b/library/syntax/see.factor
index 953f5bea4ef6c34fb24b33787f9f6fc4788e90b0..32f288980cd91f597aafbe3116ebc706a896ce21 100644 (file)
--- a/library/syntax/see.factor
+++ b/library/syntax/see.factor
@@ -113,8 +113,8 @@ M: compound see ( word -- )
 
 : see-method ( indent word class method -- indent )
     >r >r >r prettyprint-M:
-    r> prettyprint-1 " " write
-    r> prettyprint-1 " " write
+    r> r> prettyprint-1 " " write
+    prettyprint-1 " " write
     dup prettyprint-newline
     r> prettyprint-list
     prettyprint-;

diff --git a/library/test/inference.factor b/library/test/inference.factor
index 13b9c2ab54517b513ce9fb51f19f0e06c5bbc78f..3c88df9f672a1d1fd62253fd60f7cb0fe50627d2 100644 (file)
--- a/library/test/inference.factor
+++ b/library/test/inference.factor
@@ -11,6 +11,20 @@ USE: kernel
 USE: math-internals
 USE: generic
 
+[ [ [ object object ] f ] ]
+[ [ [ object ] [ object object ] ] [ [ object ] f ] decompose ]
+unit-test
+
+[ [ [ fixnum fixnum ] f ] ]
+[
+    [ [ rational rational ] [ rational fixnum ] ]
+    [ [ object ] f ] decompose
+]
+unit-test
+
+: old-effect ( [ in-types out-types ] -- [ in | out ] )
+    uncons car length >r length r> cons ;
+
 [
     [ 1 | 2 ]
     [ 2 | 1 ]
@@ -100,10 +114,10 @@ USE: generic
 
 ! Not sure how to fix this one
 
-! : funny-recursion
-!     dup [ funny-recursion 1 ] [ 2 ] ifte drop ;
-! 
-! [ [ 1 | 1 ] ] [ [ funny-recursion ] infer old-effect ] unit-test
+: funny-recursion
+    dup [ funny-recursion 1 ] [ 2 ] ifte drop ;
+
+[ [ 1 | 1 ] ] [ [ funny-recursion ] infer old-effect ] unit-test
 
 ! Simple combinators
 [ [ 1 | 2 ] ] [ [ [ car ] keep cdr ] infer old-effect ] unit-test

diff --git a/library/vectors.factor b/library/vectors.factor
index aec6b8404239adec96c11810ca17ab5707e6ae32..93e9e7d7d054275a5f35004b3f73a1186ad3bb94 100644 (file)
--- a/library/vectors.factor
+++ b/library/vectors.factor
@@ -151,7 +151,7 @@ M: vector = ( obj vec -- ? )
     ] [
         over vector? [
             2dup vector-length= [
-                swap vector>list swap vector>list =
+                swap stack>list swap stack>list =
             ] [
                 2drop f
             ] ifte