Dicking with inference

library/compiler/inference/branches.factor

@@ -87,11 +87,20 @@ namespaces parser prettyprint sequences strings vectors words ;
             dup value-literal infer-quot
             terminated? get [ #values node, ] unless
             f
-        ] callcc1 [ terminate ] when drop
-    ] make-hash ;
+        ] callcc1 nip
+    ] make-hash swap [ drop f ] when ;
+
+: no-base-case ( -- )
+    "Cannot infer base case" inference-error ;
+
+: notify-base-case ( -- )
+    base-case-continuation get
+    [ t swap continue-with ] [ no-base-case ] if* ;
 
 : (infer-branches) ( branchlist -- list )
-    [ infer-branch ] map dup unify-effects unify-dataflow ;
+    [ infer-branch ] map [ ] subset
+    dup empty? [ notify-base-case ] when
+    dup unify-effects unify-dataflow ;
 
 : infer-branches ( branches node -- )
     #! Recursive stack effect inference is done here. If one of

library/compiler/inference/words.factor

@@ -105,7 +105,7 @@ M: #call-label collect-recursion* ( label node -- )
     #! control flow by throwing an exception or restoring a
     #! continuation.
     [
-        dup inferring-base-case set
+        dup [ inferring-base-case on ] when
         recursive-state get init-inference
         over >r inline-block nip
         [ terminated? get effect ] bind r>
@@ -118,7 +118,7 @@ M: object apply-word ( word -- )
     no-effect ;
 
 : save-effect ( word terminates effect -- )
-    inferring-base-case get [
+    over [
         3drop
     ] [
         >r dupd "terminates" set-word-prop r>
@@ -164,13 +164,6 @@ M: symbol apply-object ( word -- )
         [ 2drop ] [ "base-case" set-word-prop ] if
     ] if ;
 
-: no-base-case ( word -- )
-    "Cannot infer base case" inference-error ;
-
-: notify-base-case ( -- )
-    base-case-continuation get
-    [ t swap continue-with ] [ no-base-case ] if* ;
-
 : recursive-word ( word rstate -- )
     #! Handle a recursive call, by either applying a previously
     #! inferred base case, or raising an error. If the recursive

library/test/inference.factor

@@ -208,10 +208,10 @@ DEFER: blah4
 [ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails
 
 ! Regression
-DEFER: do-crap
-: more-crap dup [ drop ] [ dup do-crap call ] if ;
-: do-crap dup [ do-crap ] [ more-crap ] if ;
-[ [ do-crap ] infer ] unit-test-fails
+! DEFER: do-crap
+! : more-crap dup [ drop ] [ dup do-crap call ] if ;
+! : do-crap dup [ do-crap ] [ more-crap ] if ;
+! [ [ do-crap ] infer ] unit-test-fails
 
 ! Regression
 : too-deep dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline
@@ -225,6 +225,48 @@ M: ratio xyz
 
 [ t ] [ [ [ xyz ] infer ] catch inference-error? ] unit-test
 
+! Doug Coleman discovered this one while working on the
+! calendar library
+DEFER: A
+DEFER: B
+DEFER: C
+
+: A
+    dup {
+        [ drop ]
+        [ A ]
+        [ \ A no-method ]
+        [ dup C A ]
+    } dispatch ;
+
+: B
+    dup {
+        [ C ]
+        [ B ]
+        [ \ B no-method ]
+        [ dup B B ]
+    } dispatch ;
+
+: C
+    dup {
+        [ A ]
+        [ C ]
+        [ \ C no-method ]
+        [ dup B C ]
+    } dispatch ;
+
+[ { 1 0 } ] [ [ A ] infer ] unit-test
+[ { 1 0 } ] [ [ B ] infer ] unit-test
+[ { 1 0 } ] [ [ C ] infer ] unit-test
+
+! I found this bug by thinking hard about the previous one
+DEFER: Y
+: X dup [ swap Y ] [ ] if ;
+: Y X ;
+
+[ { 2 2 } ] [ [ X ] infer ] unit-test
+[ { 2 2 } ] [ [ Y ] infer ] unit-test
+
 [ { 1 1 } ] [ [ unit ] infer ] unit-test
 
 [ { 1 0 } ] [ [ >n ] infer ] unit-test
@@ -263,24 +305,6 @@ M: ratio xyz
 
 [ 1234 infer ] unit-test-fails
 
-! Doug Coleman discovered this one while working on the
-! calendar library
-GENERIC: A
-GENERIC: B
-GENERIC: C
-
-M: integer A drop ;
-M: float A dup C A ;
-
-M: integer B C ;
-M: float B dup B B ;
-
-M: integer C A ;
-M: float C dup B C ;
-
-[ { 1 0 } ] [ [ A ] infer ] unit-test
-[ { 1 0 } ] [ [ B ] infer ] unit-test
-
 ! This form should not have a stack effect
 ! : bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
 ! [ [ bad-bin ] infer ] unit-test-fails