make effect variables part of effect syntax, stored out of band in effect tuple

diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor
index eba11de26c5404cc8b682c7dece16ac4168d216e..4b029fccf20510aacbed1602ef872146f52ac87b 100644 (file)
--- a/basis/compiler/tree/propagation/call-effect/call-effect.factor
+++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor
@@ -48,7 +48,7 @@ M: +unknown+ curry-effect ;
 M: effect curry-effect
     [ in>> length ] [ out>> length ] [ terminated?>> ] tri
     pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
-    [ [ "x" <array> ] bi@ ] dip effect boa ;
+    [ [ "x" <array> ] bi@ ] dip <terminated-effect> ;
 
 M: curry cached-effect
     quot>> cached-effect curry-effect ;

diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor b/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor
index c00935b58bdeb1a1cb56728897be2c8b1fd1721c..3c129e9e0c73c9f2a9fb7abf52b087f8064ada75 100644 (file)
--- a/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor
+++ b/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor
@@ -8,12 +8,6 @@ stack-checker.state
 stack-checker.values ;
 IN: stack-checker.row-polymorphism.tests
 
-[ 3 f   ] [ (( a b c -- d )) in-effect-variable ] unit-test
-[ 0 f   ] [ (( -- d )) in-effect-variable ] unit-test
-[ 2 "a" ] [ (( ..a b c -- d )) in-effect-variable ] unit-test
-[ (( a ..b c -- d )) in-effect-variable ] [ invalid-effect-variable? ] must-fail-with
-[ (( ..a: integer b c -- d )) in-effect-variable ] [ effect-variable-can't-have-type? ] must-fail-with
-
 : checked-each ( ..a seq quot: ( ..a x -- ..a ) -- ..a )
     curry call ; inline
 

diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor
index caaf89fbaca8fd10d1fb9efd22ffea5485edfccf..a01d0caaf97ff51d82d3dd423fe8856c307f00ff 100644 (file)
--- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor
+++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor
@@ -14,30 +14,6 @@ SYMBOLS: current-effect-variables current-effect current-meta-d ;
 : quotation-effect? ( in -- ? )
     dup pair? [ second effect? ] [ drop f ] if ;
 
-: (effect-variable) ( effect in -- effect variable/f )
-    dup pair?
-    [ first ".." head? [ effect-variable-can't-have-type ] [ f ] if ]
-    [ ".." ?head [ drop f ] unless ] if ;
-
-: validate-effect-variables ( effect ins/outs -- )
-    [ (effect-variable) ] any? [ invalid-effect-variable ] [ drop ] if ;
-
-: effect-variable ( effect ins/outs -- count variable/f )
-    [ drop 0 f ] [
-        unclip
-        [ [ validate-effect-variables ] [ length ] bi ]
-        [ (effect-variable) ] bi*
-        [ 1 + f ] unless*
-    ] if-empty ;
-PRIVATE>
-
-: in-effect-variable ( effect -- count variable/f )
-    dup in>> effect-variable ;
-: out-effect-variable ( effect -- count variable/f )
-    dup out>> effect-variable ;
-
-<PRIVATE
-
 SYMBOL: (unknown)
 
 GENERIC: >error-quot ( known -- quot )
@@ -77,8 +53,8 @@ M: curried >error-quot
     [ 2drop ] if ; inline
 
 :: (check-input) ( declared actual -- )
-    actual in>>  length  declared in-effect-variable  [ check-variable ] keep :> ( in-diff in-var ) 
-    actual out>> length  declared out-effect-variable [ check-variable ] keep :> ( out-diff out-var )
+    actual in>>  length  declared in-var>>  [ check-variable ] keep :> ( in-diff in-var ) 
+    actual out>> length  declared out-var>> [ check-variable ] keep :> ( out-diff out-var )
     { [ in-var not ] [ out-var not ] [ in-diff out-diff = ] } 0||
     [
         in-var  [ in-diff  swap adjust-variable ] when*

diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor
index f0b595ebe5c2ebfa4f54be0a36f65fa7312ad223..69eb590d4862f3a1789349db8e543caf67cf1ce5 100644 (file)
--- a/basis/stack-checker/state/state.factor
+++ b/basis/stack-checker/state/state.factor
@@ -40,7 +40,7 @@ SYMBOL: literals
 : current-effect ( -- effect )
     input-count get "x" <array>
     meta-d length "x" <array>
-    terminated? get effect boa ;
+    terminated? get <terminated-effect> ;
 
 : init-inference ( -- )
     terminated? off

diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor
index ffc0c9780b27daeeb35dca386d6fa3112607bd32..af4675d6f20405647e893515412e23f820ef5cd1 100644 (file)
--- a/core/effects/effects-tests.factor
+++ b/core/effects/effects-tests.factor
@@ -1,4 +1,4 @@
-USING: effects kernel tools.test prettyprint accessors
+USING: effects effects.parser eval kernel tools.test prettyprint accessors
 quotations sequences ;
 IN: effects.tests
 
@@ -27,3 +27,18 @@ IN: effects.tests
 
 [ { object object } ] [ (( a b -- )) effect-in-types ] unit-test
 [ { object sequence } ] [ (( a b: sequence -- )) effect-in-types ] unit-test
+
+[ f   ] [ (( a b c -- d )) in-var>> ] unit-test
+[ f   ] [ (( -- d )) in-var>> ] unit-test
+[ "a" ] [ (( ..a b c -- d )) in-var>> ] unit-test
+[ { "b" "c" } ] [ (( ..a b c -- d )) in>> ] unit-test
+
+[ f   ] [ (( ..a b c -- e )) out-var>> ] unit-test
+[ "d" ] [ (( ..a b c -- ..d e )) out-var>> ] unit-test
+[ { "e" } ] [ (( ..a b c -- ..d e )) out>> ] unit-test
+
+[ "(( a ..b c -- d ))" eval( -- effect ) ]
+[ error>> invalid-effect-variable? ] must-fail-with
+
+[ "(( ..a: integer b c -- d ))" eval( -- effect ) ]
+[ error>> effect-variable-can't-have-type? ] must-fail-with

diff --git a/core/effects/effects.factor b/core/effects/effects.factor
index fea50d298146bdd977a27643669487c7739af8bf..c049f16f4a2b7db0b6fd2a8bac1f959347d0b128 100644 (file)
--- a/core/effects/effects.factor
+++ b/core/effects/effects.factor
@@ -8,11 +8,21 @@ IN: effects
 TUPLE: effect
 { in array read-only }
 { out array read-only }
-{ terminated? read-only } ;
+{ terminated? read-only }
+{ in-var read-only }
+{ out-var read-only } ;
+
+: ?terminated ( out -- out terminated? )
+    dup { "*" } = [ drop { } t ] [ f ] if ;
 
 : <effect> ( in out -- effect )
-    dup { "*" } = [ drop { } t ] [ f ] if
-    effect boa ;
+    ?terminated f f effect boa ;
+
+: <terminated-effect> ( in out terminated? -- effect )
+    f f effect boa ; inline
+
+: <variable-effect> ( in-var in out-var out -- effect )
+    swap [ rot ] dip [ ?terminated ] 2dip effect boa ;
 
 : effect-height ( effect -- n )
     [ out>> length ] [ in>> length ] bi - ; inline
@@ -42,13 +52,19 @@ M: pair effect>string first2 [ effect>string ] bi@ ": " glue ;
 : stack-picture ( seq -- string )
     [ [ effect>string % CHAR: \s , ] each ] "" make ;
 
+: var-picture ( var -- string )
+    [ ".." " " surround ]
+    [ "" ] if* ;
+
 M: effect effect>string ( effect -- string )
     [
         "( " %
-        [ in>> stack-picture % "-- " % ]
-        [ out>> stack-picture % ]
-        [ terminated?>> [ "* " % ] when ]
-        tri
+        dup in-var>> var-picture %
+        dup in>> stack-picture % "-- " %
+        dup out-var>> var-picture %
+        dup out>> stack-picture %
+        dup terminated?>> [ "* " % ] when
+        drop
         ")" %
     ] "" make ;
 
@@ -87,7 +103,7 @@ M: effect clone
     shuffle-mapping swap nths ;
 
 : add-effect-input ( effect -- effect' )
-    [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri effect boa ;
+    [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri <terminated-effect> ;
 
 : compose-effects ( effect1 effect2 -- effect' )
     over terminated?>> [
@@ -97,5 +113,5 @@ M: effect clone
         [ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
         [ nip terminated?>> ] 2tri
         [ [ "x" <array> ] bi@ ] dip
-        effect boa
+        <terminated-effect>
     ] if ; inline

diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor
index 842d4f6447776e0e7b8eefe97b7285dc1ca993ca..e806f1befc96e100ea80d856c5636eac06baf730 100644 (file)
--- a/core/effects/parser/parser.factor
+++ b/core/effects/parser/parser.factor
@@ -1,34 +1,49 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: lexer sets sequences kernel splitting effects
-combinators arrays vocabs.parser classes parser ;
+combinators arrays make vocabs.parser classes parser ;
 IN: effects.parser
 
 DEFER: parse-effect
 
 ERROR: bad-effect ;
-
-: parse-effect-token ( end -- token/f )
-    scan [ nip ] [ = ] 2bi [ drop f ] [
-        dup { f "(" "((" } member? [ bad-effect ] [
-            ":" ?tail [
-                scan {
-                    { [ dup "(" = ] [ drop ")" parse-effect ] }
-                    { [ dup f = ] [ ")" unexpected-eof ] }
-                    [ parse-word dup class? [ bad-effect ] unless ]
-                } cond 2array
-            ] when
+ERROR: invalid-effect-variable ;
+ERROR: effect-variable-can't-have-type ;
+ERROR: stack-effect-omits-dashes ;
+
+SYMBOL: effect-var
+
+: parse-var ( first? var name -- var )
+    nip
+    [ ":" ?tail [ effect-variable-can't-have-type ] when ] curry
+    [ invalid-effect-variable ] if ;
+
+: 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 ;
 
-: parse-effect-tokens ( end -- tokens )
-    [ parse-effect-token dup ] curry [ ] produce nip ;
-
-ERROR: stack-effect-omits-dashes tokens ;
+: parse-effect-tokens ( end -- var tokens )
+    [
+        [ t f ] dip [ parse-effect-token [ f ] 2dip ] curry [ ] while nip
+    ] { } make ;
 
 : parse-effect ( end -- effect )
-    parse-effect-tokens { "--" } split1 dup
-    [ <effect> ] [ drop stack-effect-omits-dashes ] if ;
+    [ "--" parse-effect-tokens ] dip parse-effect-tokens
+    <variable-effect> ;
 
 : complete-effect ( -- effect )
     "(" expect ")" parse-effect ;