From e293966618b8ba533a4eb60761be187be1fd3a4e Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 9 Sep 2011 18:08:27 -0700
Subject: [PATCH] stack-checker.row-polymorphism: check stack effects correctly
 when a one-sided polymorphic declared effect is matched to a shallow subtype,
 for example, ( x -- ..a ) to ( -- ); fixes #88

---
 .../row-polymorphism/row-polymorphism.factor  | 27 +++++++++++++++++++
 .../stack-checker/stack-checker-tests.factor  | 27 +++++++++++++++++++
 2 files changed, 54 insertions(+)

diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor
index 38b25bf3f8..491b581609 100644
--- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor
+++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor
@@ -42,7 +42,34 @@ IN: stack-checker.row-polymorphism
         out-var [ out-diff swap vars adjust-variable ] when*
     ] when ;
 
+! 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 ]
+            [ actual out>> length declared out>> length < ]
+        } 0&& ] [ declared out>> length actual out>> length - ] }
+        { [ {
+            [ declared in-var>> not ]
+            [ declared out-var>> ]
+            [ actual in>> length declared in>> length < ]
+        } 0&& ] [ declared in>> length actual in>> length - ] }
+        [ f ]
+    } cond ;
+
+: (balance-by) ( effect n -- effect' )
+    "x" <array> swap
+    [ in>> append ]
+    [ out>> append ]
+    [ nip terminated?>> ] 2tri <terminated-effect> ;
+
+: balance-actual ( declared actual -- declared actual' )
+    2dup (balance-actual-depth) [ (balance-by) ] when* ;
+
 : (check-variables) ( vars declared actual -- ? )
+    balance-actual
     [ [ in>>  ] [ in-var>>  ] check-variable ]
     [ [ out>> ] [ out-var>> ] check-variable ]
     [ 2drop ] 3tri unify-variables ;
diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor
index 417b7fbed0..c340b45e80 100644
--- a/basis/stack-checker/stack-checker-tests.factor
+++ b/basis/stack-checker/stack-checker-tests.factor
@@ -501,3 +501,30 @@ USING: alien.c-types alien ;
     void { } cdecl [ recursive-callback-2 drop ] alien-callback ; inline recursive
 
 [ recursive-callback-2 ] must-infer
+
+! test one-sided row polymorphism
+
+: poly-output ( x a: ( x -- ..a ) -- ..a ) call ; inline
+
+[ [ ] poly-output ] must-infer
+[ [ f f f ] poly-output ] must-infer
+
+: poly-input ( ..a a: ( ..a -- x ) -- x ) call ; inline
+
+[ [ ] poly-input ] must-infer
+[ [ drop drop drop ] poly-input ] must-infer
+
+: poly-output-input ( x a: ( x -- ..a ) b: ( ..a -- y ) -- y ) [ call ] bi@ ; inline
+
+[ [ ] [ ] poly-output-input ] must-infer
+[ [ f f f ] [ drop drop drop ] poly-output-input ] must-infer
+[ [ [ f f ] [ drop drop drop ] poly-output-input ] infer ] [ unbalanced-branches-error? ] must-fail-with
+[ [ [ f f f ] [ drop drop ] poly-output-input ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
+: poly-input-output ( ..a a: ( ..a -- x ) b: ( x -- ..b ) -- ..b ) [ call ] bi@ ; inline
+
+[ [ ] [ ] poly-input-output ] must-infer
+[ [ drop drop drop ] [ f f f ] poly-input-output ] must-infer
+[ [ drop drop ] [ f f f ] poly-input-output ] must-infer
+[ [ drop drop drop ] [ f f ] poly-input-output ] must-infer
+