diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor index eba11de26c..4b029fccf2 100644 --- 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" ] bi@ ] dip effect boa ; + [ [ "x" ] bi@ ] dip ; 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 c00935b58b..3c129e9e0c 100644 --- 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 caaf89fbac..a01d0caaf9 100644 --- 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 ; - -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 f0b595ebe5..69eb590d48 100644 --- 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" meta-d length "x" - terminated? get effect boa ; + terminated? get ; : init-inference ( -- ) terminated? off diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor index ffc0c9780b..af4675d6f2 100644 --- 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 fea50d2981..c049f16f4a 100644 --- 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 ; : ( in out -- effect ) - dup { "*" } = [ drop { } t ] [ f ] if - effect boa ; + ?terminated f f effect boa ; + +: ( in out terminated? -- effect ) + f f effect boa ; inline + +: ( 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 ; : 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" ] bi@ ] dip - effect boa + ] if ; inline diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index 842d4f6447..e806f1befc 100644 --- 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 ; +ERROR: invalid-effect-variable ; +ERROR: effect-variable-can't-have-type ; +ERROR: stack-effect-omits-dashes ; -: 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 +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 - [ ] [ drop stack-effect-omits-dashes ] if ; + [ "--" parse-effect-tokens ] dip parse-effect-tokens + ; : complete-effect ( -- effect ) "(" expect ")" parse-effect ;