stack-checker: calling 'dispatch' with unbalanced branches generated an error message that erroneously talked about 'if'

basis/stack-checker/branches/branches.factor

@@ -1,9 +1,10 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays effects fry vectors sequences assocs math math.order accessors kernel
 combinators quotations namespaces grouping locals stack-checker.state
 stack-checker.backend stack-checker.errors stack-checker.visitor
 stack-checker.values stack-checker.recursive-state ;
+FROM: sequences.private => dispatch ;
 IN: stack-checker.branches
 
 : balanced? ( pairs -- ? )
@@ -43,10 +44,9 @@ SYMBOLS: +bottom+ +top+ ;
 : phi-outputs ( phi-in -- stack )
     flip [ unify-values ] map ;
 
-SYMBOL: quotations
+SYMBOLS: combinator quotations ;
 
-: simple-unbalanced-branches-error ( branches quots -- * )
+: simple-unbalanced-branches-error ( word quots branches -- * )
-    [ \ if ] 2dip swap
     [ length [ (( ..a -- ..b )) ] replicate ]
     [ [ length [ "x" <array> ] bi@ <effect> ] { } assoc>map ] bi
     unbalanced-branches-error ;
@@ -54,9 +54,10 @@ SYMBOL: quotations
 : unify-branches ( ins stacks -- in phi-in phi-out )
     zip [ 0 { } { } ] [
         [ keys supremum ] [ ] [ balanced? ] tri
-        [ dupd phi-inputs dup phi-outputs ]
+        [ dupd phi-inputs dup phi-outputs ] [
-        [ quotations get simple-unbalanced-branches-error ]
+            [ combinator get quotations get ] dip
-        if
+            simple-unbalanced-branches-error
+        ] if
     ] if-empty ;
 
 : branch-variable ( seq symbol -- seq )
@@ -125,13 +126,13 @@ M: curried curried/composed? drop t ;
 M: composed curried/composed? drop t ;
 M: declared-effect curried/composed? known>> curried/composed? ;
 
-:: declare-if-effects ( -- )
+: declare-if-effects ( -- )
-    H{ } clone :> variables
+    H{ } clone V{ } clone
-    V{ } clone :> branches
+    [ [ \ if (( ..a -- ..b )) ] 2dip 0 declare-effect-d ]
-    \ if (( ..a -- ..b )) variables branches 0 declare-effect-d
+    [ [ \ if (( ..a -- ..b )) ] 2dip 1 declare-effect-d ] 2bi ;
-    \ if (( ..a -- ..b )) variables branches 1 declare-effect-d ;
 
 : infer-if ( -- )
+    \ if combinator set
     2 literals-available? [
         (infer-if)
     ] [
@@ -148,5 +149,6 @@ M: declared-effect curried/composed? known>> curried/composed? ;
     ] if ;
 
 : infer-dispatch ( -- )
+    \ dispatch combinator set
     pop-literal nip infer-branches
     [ #dispatch, ] dip compute-phi-function ;

basis/stack-checker/row-polymorphism/row-polymorphism.factor

@@ -24,7 +24,7 @@ IN: stack-checker.row-polymorphism
     [ with-inner-d ] 2dip (effect-here) ; inline
 
 : (diff-variable) ( diff variable vars -- diff' )
-    [ at* nip ] [ '[ _ _ at - ] ] [ '[ _ _ set-at 0 ] ] 2tri if ;
+    [ key? ] [ '[ _ _ at - ] ] [ '[ _ _ set-at 0 ] ] 2tri if ;
 
 : (check-variable) ( actual-count declared-count variable vars -- diff ? )
     [ - ] 2dip dupd '[ _ _ (diff-variable) t ] [ dup 0 <= ] if ;
@@ -63,4 +63,3 @@ IN: stack-checker.row-polymorphism
     [ >>actual ] keep
     2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables
     [ 2drop ] [ drop combinator-unbalanced-branches-error ] if ;
-

basis/stack-checker/stack-checker-tests.factor

@@ -252,6 +252,11 @@ DEFER: blah4
 ! A typo
 { 1 0 } [ { [ ] } dispatch ] must-infer-as
 
+! Make sure the error is correct
+[
+    [ { [ drop ] [ dup ] } dispatch ] infer
+] [ word>> \ dispatch eq? ] must-fail-with
+
 DEFER: inline-recursive-2
 : inline-recursive-1 ( -- ) inline-recursive-2 ;
 : inline-recursive-2 ( -- ) inline-recursive-1 ;