Fix stack-checker bug

unfinished/compiler/tree/propagation/propagation-tests.factor

@@ -276,6 +276,14 @@ IN: compiler.tree.propagation.tests
     ] final-literals
 ] unit-test
 
+[ V{ 27 } ] [
+    [
+        dup number? over sequence? and [
+            dup 10 < over 8 <= not and [ 3 * ] [ "A" throw ] if
+        ] [ "B" throw ] if
+    ] final-literals
+] unit-test
+
 [ V{ string string } ] [
     [
         2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop

unfinished/stack-checker/branches/branches.factor

@@ -6,18 +6,24 @@ stack-checker.backend stack-checker.errors stack-checker.visitor
 ;
 IN: stack-checker.branches
 
-: balanced? ( seq -- ? )
+: balanced? ( pairs -- ? )
     [ second ] filter [ first2 length - ] map all-equal? ;
 
-: phi-inputs ( seq -- newseq )
-    dup empty? [
-        dup [ length ] map supremum
-        '[ , f pad-left ] map flip
-    ] unless ;
+: unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
+    dup [ [ - f <repetition> ] dip append ] [ 3drop f ] if ;
+
+: phi-inputs ( max-d-in pairs -- newseq )
+    dup empty? [ nip ] [
+        swap '[ , _ first2 unify-inputs ] map
+        dup [ length ] map supremum '[ , f pad-left ] map
+        flip
+    ] if ;
 
 : unify-values ( values -- phi-out )
-    dup sift [ known ] map dup all-eq?
-    [ nip first make-known ] [ 2drop <value> ] if ;
+    sift dup empty? [ drop <value> ] [
+        [ known ] map dup all-eq?
+        [ first make-known ] [ drop <value> ] if
+    ] if ;
 
 : phi-outputs ( phi-in -- stack )
     [ unify-values ] map ;
@@ -26,8 +32,8 @@ SYMBOL: quotations
 
 : unify-branches ( ins stacks -- in phi-in phi-out )
     zip dup empty? [ drop 0 { } { } ] [
-        dup balanced?
-        [ [ keys supremum ] [ values phi-inputs dup phi-outputs ] bi ]
+        [ keys supremum ] [ ] [ balanced? ] tri
+        [ dupd phi-inputs dup phi-outputs ]
         [ quotations get unbalanced-branches-error ]
         if
     ] if ;
@@ -72,7 +78,7 @@ SYMBOL: quotations
 
 : infer-if ( -- )
     2 consume-d
-    dup [ known [ curry? ] [ composed? ] bi or ] contains? [
+    dup [ known [ curried? ] [ composed? ] bi or ] contains? [
         output-d
         [ rot [ drop call ] [ nip call ] if ]
         recursive-state get infer-quot

unfinished/stack-checker/stack-checker-tests.factor

@@ -9,6 +9,16 @@ threads.private io.streams.string io.timeouts io.thread
 sequences.private destructors combinators ;
 IN: stack-checker.tests
 
+: short-effect ( effect -- pair )
+    [ in>> length ] [ out>> length ] bi 2array ;
+
+: must-infer-as ( effect quot -- )
+    >r 1quotation r> [ infer short-effect ] curry unit-test ;
+
+: must-infer ( word/quot -- )
+    dup word? [ 1quotation ] when
+    [ infer drop ] curry [ ] swap unit-test ;
+
 \ infer. must-infer
 
 { 0 2 } [ 2 "Hello" ] must-infer-as
@@ -560,3 +570,6 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ;
 : bad-recursion-6 ( quot: ( -- ) -- )
     dup bad-recursion-6 call ; inline recursive
 [ [ [ drop f ] bad-recursion-6 ] infer ] must-fail
+
+{ 3 0 } [ [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as
+{ 2 0 } [ drop f f [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as