stack-checker.row-polymorphism: modify check-variables to enforce non-polymorphic...

diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor
index d8ba12a3171abe5c0c1b75d67a91f15c70dfcba8..76879a39503dec8682ee20bea8f586ccbe33eac7 100644 (file)
--- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor
+++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor
@@ -30,13 +30,14 @@ IN: stack-checker.row-polymorphism
     meta-d length inner-d - :> out
     in "x" <array> out "x" <array> terminated? get <terminated-effect> ; inline
 
-:: check-variable ( actual-count declared-count variable vars -- difference )
+:: check-variable ( actual-count declared-count variable vars -- difference ? )
     actual-count declared-count -
     variable [
         variable vars at* nip
         [ variable vars at -     ]
         [ variable vars set-at 0 ] if
-    ] [ drop 0 ] if ;
+        t
+    ] [ dup zero? ] if ;
 
 : adjust-variable ( diff var vars -- )
     pick 0 >=
@@ -46,10 +47,10 @@ IN: stack-checker.row-polymorphism
 :: check-variables ( vars declared actual -- ? )
     actual terminated?>> [ t ] [
         actual declared [ in>>  length ] bi@ declared in-var>>
-            [ vars check-variable ] keep :> ( in-diff in-var ) 
+            [ vars check-variable ] keep :> ( in-diff in-ok? in-var ) 
         actual declared [ out>> length ] bi@ declared out-var>>
-            [ vars check-variable ] keep :> ( out-diff out-var )
-        { [ in-var not ] [ out-var not ] [ in-diff out-diff = ] } 0||
+            [ vars check-variable ] keep :> ( out-diff out-ok? out-var )
+        { [ in-ok? ] [ out-ok? ] [ in-diff out-diff = ] } 0&&
         dup [
             in-var  [ in-diff  swap vars adjust-variable ] when*
             out-var [ out-diff swap vars adjust-variable ] when*

diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor
index 8aa2c0c8a26931810a7be106fd4b65074c73b507..e537a530d20e7d20027d124c57e46d9141ee19f2 100644 (file)
--- a/basis/stack-checker/stack-checker-tests.factor
+++ b/basis/stack-checker/stack-checker-tests.factor
@@ -429,6 +429,12 @@ DEFER: eee'
 
 { 1 1 } [ [ 1 +       ] [ "oops" throw ] if* ] must-infer-as
 
+: strict-each ( seq quot: ( x -- ) -- )
+    each ; inline
+
+{ 1 0 } [ [ drop ] strict-each ] must-infer-as
+[ [ [ append ] strict-each ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
 ! ensure that polymorphic checking works on recursive combinators
 FROM: splitting.private => split, ;
 { 2 0 } [ [ member? ] curry split, ] must-infer-as