stack-checker: stop early with compiler error. easier for debbuging.

basis/bootstrap/compiler/compiler.factor

@@ -5,7 +5,7 @@ classes.tuple.private compiler.units hashtables
 hashtables.private io kernel libc math math.parser memory
 namespaces namespaces.private quotations quotations.private
 sbufs sequences sequences.private splitting system vectors
-vocabs vocabs.loader words ;
+vocabs vocabs.loader words stack-checker.row-polymorphism ;
 FROM: compiler => enable-optimizer ;
 IN: bootstrap.compiler
 
@@ -63,6 +63,11 @@ gc
 
     "." write flush
 
+    {
+        unify-variables
+        (balance-actual-depth)
+    } compile-unoptimized
+
     {
         bitand bitor bitxor bitnot
     } compile-unoptimized

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

@@ -33,11 +33,9 @@ IN: stack-checker.row-polymorphism
     actual declared [ slot call length ] bi@ declared var-slot call
     [ vars (check-variable) ] keep ; inline
 
+
 :: unify-variables ( in-diff in-ok? in-var out-diff out-ok? out-var vars -- ? )
-    in-ok?
-    out-ok? and
-    in-diff out-diff = and
-    dup [
+    { [ in-ok? ] [ out-ok? ] [ in-diff out-diff = ] }  0 n&&  dup [
         in-var  [ in-diff  swap vars adjust-variable ] when*
         out-var [ out-diff swap vars adjust-variable ] when*
     ] when ;
@@ -45,19 +43,19 @@ IN: stack-checker.row-polymorphism
 ! A bit of a hack. If the declared effect is one-sided monomorphic and the actual effect is a
 ! shallow subtype of the root effect, adjust it here
 :: (balance-actual-depth) ( declared actual -- depth/f )
-    declared in-var>>
-    declared out-var>> not and
-    actual out>> length declared out>> length < and [
-        declared out>> length actual out>> length -
-    ] [
-        declared in-var>> not
-        declared out-var>> and
-        actual in>> length declared in>> length < and [
-            declared in>> length actual in>> length -
-        ] [
-            f
-        ] if
-    ] if ;
+    {
+        { [ {
+            [ declared in-var>> ]
+            [ declared out-var>> not ]
+            [ actual out>> length declared out>> length < ]
+        } 0 n&& ] [ declared out>> length actual out>> length - ] }
+        { [ {
+            [ declared in-var>> not ]
+            [ declared out-var>> ]
+            [ actual in>> length declared in>> length < ]
+        } 0 n&& ] [ declared in>> length actual in>> length - ] }
+        [ f ]
+    } cond ;
 
 : (balance-by) ( effect n -- effect' )
     "x" <array> swap