From 26ff757de498cc7795689109d776c75f1e371a6b Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 11 Mar 2010 00:53:40 -0800
Subject: [PATCH 1/2] carve the tough, gamey steak of
 stack-checker.polymorphism into chewable morsels

---
 .../row-polymorphism/row-polymorphism.factor  | 61 +++++++++----------
 1 file changed, 30 insertions(+), 31 deletions(-)

diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor
index 29ee63bf33..ef47dfe285 100644
--- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor
+++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor
@@ -10,27 +10,21 @@ stack-checker.values
 stack-checker.visitor ;
 IN: stack-checker.row-polymorphism
 
-:: with-inner-d ( quot -- inner-d )
-    inner-d-index get :> old-inner-d-index
-    meta-d length inner-d-index set
-    quot call
-    inner-d-index get :> new-inner-d-index
-    old-inner-d-index new-inner-d-index min inner-d-index set
-    new-inner-d-index ; inline
+: with-inner-d ( quot -- inner-d )
+    inner-d-index get
+    [ meta-d length inner-d-index set call ] dip
+    inner-d-index get [ min inner-d-index set ] keep ; inline
 
-:: with-effect-here ( quot -- effect )
-    input-count get :> old-input-count
-    meta-d length :> old-meta-d-length
+:: (effect-here) ( inner-d old-meta-d-length old-input-count -- effect )
+    old-meta-d-length inner-d - input-count get old-input-count - +
+    meta-d length inner-d -
+    [ "x" <array> ] bi@ terminated? get <terminated-effect> ; inline
 
-    quot with-inner-d :> inner-d
-        
-    input-count get :> new-input-count
-    old-meta-d-length inner-d -
-    new-input-count old-input-count - + :> in
-    meta-d length inner-d - :> out
-    in "x" <array> out "x" <array> terminated? get <terminated-effect> ; inline
+: with-effect-here ( quot -- effect )
+    meta-d length input-count get
+    [ with-inner-d ] 2dip (effect-here) ; 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
@@ -44,20 +38,25 @@ IN: stack-checker.row-polymorphism
     [ at+ ]
     [ 3drop ] if ; inline
 
-:: check-variables ( vars declared actual -- ? )
-    actual terminated?>> [ t ] [
-        actual declared [ in>>  length ] bi@ declared 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-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*
-        ] when
+:: check-variable ( vars declared actual slot var-slot -- diff ok? var )
+    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? ] [ in-diff out-diff = ] } 0&&
+    dup [
+        in-var  [ in-diff  swap vars adjust-variable ] when*
+        out-var [ out-diff swap vars adjust-variable ] when*
+    ] when ;
+
+: check-variables ( vars declared actual -- ? )
+    dup terminated?>> [ 3drop t ] [
+        [ [ in>>  ] [ in-var>>  ] check-variable ]
+        [ [ out>> ] [ out-var>> ] check-variable ]
+        [ 2drop ] 3tri unify-variables
     ] if ;
 
-: complex-unbalanced-branches-error ( known -- * )
+: combinator-unbalanced-branches-error ( known -- * )
     [ word>> ] [
         branches>> <reversed>
         [ [ known>callable ] { } map-as ]
@@ -68,5 +67,5 @@ IN: stack-checker.row-polymorphism
 : check-declared-effect ( known effect -- )
     [ >>actual ] keep
     2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables
-    [ 2drop ] [ drop complex-unbalanced-branches-error ] if ;
+    [ 2drop ] [ drop combinator-unbalanced-branches-error ] if ;
 

From d001c1f3752be26e14593412dfeb59a0a628c27a Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 11 Mar 2010 01:03:40 -0800
Subject: [PATCH 2/2] carve up effects.parser too

---
 core/effects/parser/parser.factor | 41 ++++++++++++++++++-------------
 1 file changed, 24 insertions(+), 17 deletions(-)

diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor
index e806f1befc..2748df4bc8 100644
--- a/core/effects/parser/parser.factor
+++ b/core/effects/parser/parser.factor
@@ -13,28 +13,35 @@ ERROR: stack-effect-omits-dashes ;
 
 SYMBOL: effect-var
 
-: parse-var ( first? var name -- var )
+<PRIVATE
+: end-token? ( end token -- token ? ) [ nip ] [ = ] 2bi ; inline
+: effect-opener? ( token -- token ? ) dup { f "(" "((" "--" } member? ; inline
+: effect-closer? ( token -- token ? ) dup { ")" "))" } member? ; inline
+: effect-variable? ( token -- token' ? ) ".." ?head ; inline
+
+: parse-effect-var ( first? var name -- var )
     nip
     [ ":" ?tail [ effect-variable-can't-have-type ] when ] curry
     [ invalid-effect-variable ] if ;
 
+: parse-effect-value ( token -- value )
+    ":" ?tail [
+        scan {
+            { [ dup "(" = ] [ drop ")" parse-effect ] }
+            { [ dup f = ] [ ")" unexpected-eof ] }
+            [ parse-word dup class? [ bad-effect ] unless ]
+        } cond 2array
+    ] when ;
+PRIVATE>
+
 : parse-effect-token ( first? var end -- var more? )
-    scan [ nip ] [ = ] 2bi [ drop nip f ] [
-        dup { f "(" "((" "--" } member? [ bad-effect ] [
-            dup { ")" "))" } member? [ stack-effect-omits-dashes ] [
-                ".." ?head [ parse-var t ] [
-                    [ drop ] 2dip
-                    ":" ?tail [
-                        scan {
-                            { [ dup "(" = ] [ drop ")" parse-effect ] }
-                            { [ dup f = ] [ ")" unexpected-eof ] }
-                            [ parse-word dup class? [ bad-effect ] unless ]
-                        } cond 2array
-                    ] when , t
-                ] if
-            ] if
-        ] if
-    ] if ;
+    scan {
+        { [ end-token? ] [ drop nip f ] }
+        { [ effect-opener? ] [ bad-effect ] }
+        { [ effect-closer? ] [ stack-effect-omits-dashes ] }
+        { [ effect-variable? ] [ parse-effect-var t ] }
+        [ [ drop ] 2dip parse-effect-value , t ]
+    } cond ;
 
 : parse-effect-tokens ( end -- var tokens )
     [