inference fix

TODO.FACTOR.txt

@@ -1,5 +1,4 @@
 - FUNCTION: not updating crossref correctly
-- UI word wrap: sometimes a space appears at the front
 - need line and paragraph spacing
 - update HTML stream
 - help cross-referencing
@@ -7,13 +6,6 @@
 - if cell is rebound, and we allocate c objects, bang
 - runtime primitives like fopen: check for null input
 - -with combinators are awkward
-- cleanups:
-  alien/compiler
-  inference/shuffle
-  inference-words inline-block
-  io/buffer - use aliens not integers
-  alien/malloc - use aliens not integers
-  ui/line-editor - don't use variables
 - amd64 to do:
   - alien calls
   - port ffi to win64
@@ -40,10 +32,7 @@
 - stream server can hang because of exception handler limitations
 - better i/o scheduler
 - if two tasks write to a unix stream, the buffer can overflow
-- inference bug
-
 - font problem: http://iarc1.ece.utexas.edu/~erg/font-bug.JPG
-
 - implement 3.3 floor  4.7 ceiling  4.5 truncate
 
 ALL TESTS BELOW FAIL ON x86 linux 32bit

library/alien/aliens.factor

@@ -38,7 +38,3 @@ M: alien = ( obj obj -- ? )
 
 : library-abi ( library -- abi )
     library "abi" swap ?hash [ "cdecl" ] unless* ;
-
-: DLL" skip-blank parse-string dlopen swons ; parsing
-
-: ALIEN: scan-word <alien> swons ; parsing

library/alien/syntax.factor

@@ -4,6 +4,10 @@ IN: !syntax
 USING: alien compiler kernel lists math namespaces parser
 sequences syntax words ;
 
+: DLL" skip-blank parse-string dlopen swons ; parsing
+
+: ALIEN: scan-word <alien> swons ; parsing
+
 ! usage of 'LIBRARY:' and 'FUNCTION:' :
 !
 !     LIBRARY: gl

library/inference/words.factor

@@ -25,7 +25,7 @@ strings vectors words ;
     " was already attempted, and failed" append3
     inference-error ;
 
-TUPLE: rstate label quot base-case? ;
+TUPLE: rstate label base-case? ;
 
 : nest-node ( -- dataflow current )
     dataflow-graph get  dataflow-graph off
@@ -37,8 +37,7 @@ TUPLE: rstate label quot base-case? ;
     r> current-node set ;
 
 : with-recursive-state ( word label base-case quot -- )
-    >r >r over word-def r> <rstate> cons
+    >r <rstate> cons recursive-state [ cons ] change r>
-    recursive-state [ cons ] change r>
     nest-node 2slip unnest-node ; inline
 
 : inline-block ( word base-case -- node-block variables )
@@ -109,8 +108,10 @@ M: #call-label collect-recursion* ( label node -- )
     #! control flow by throwing an exception or restoring a
     #! continuation.
     [
-        recursive-state get init-inference over >r inline-block
+        dup inferring-base-case set
-        nip [ terminated? get effect ] bind r>
+        recursive-state get init-inference
+        over >r inline-block nip
+        [ terminated? get effect ] bind r>
     ] with-scope over consume/produce over [ terminate ] when ;
 
 GENERIC: apply-word
@@ -119,12 +120,18 @@ M: object apply-word ( word -- )
     #! A primitive with an unknown stack effect.
     no-effect ;
 
+: save-effect ( word terminates effect -- )
+    inferring-base-case get [
+        3drop
+    ] [
+        >r dupd "terminates" set-word-prop r>
+        "infer-effect" set-word-prop
+    ] if ;
+
 M: compound apply-word ( word -- )
     #! Infer a compound word's stack effect.
     [
-        dup dup f infer-compound
+        dup f infer-compound save-effect
-        >r "terminates" set-word-prop r>
-        "infer-effect" set-word-prop
     ] [
         swap t "no-effect" set-word-prop rethrow
     ] recover ;

library/test/collections/sequences.factor

@@ -134,12 +134,12 @@ unit-test
     sorter-seq >array nip
 ] unit-test
 
-[ [ ] ] [ [ ] number-sort ] unit-test
+[ [ ] ] [ [ ] natural-sort ] unit-test
 
 [ t ] [
     100 [
         drop
-        1000 [ drop 1000 random-int ] map number-sort [ <= ] monotonic?
+        100 [ drop 20 random-int [ drop 1000 random-int ] map ] map natural-sort [ <=> 0 <= ] monotonic?
     ] all?
 ] unit-test
 

library/test/math/integer.factor

@@ -55,7 +55,7 @@ USING: kernel math namespaces prettyprint test ;
 ] unit-test
 
 : verify-gcd ( x y )
-    2dup gcd ( a d )
+    2dup swap gcd ( a d )
     >r rot * swap rem r> = ; 
 
 [ t ] [ 123 124 verify-gcd ] unit-test