steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Joe Groff 2010-03-05 13:30:10 -08:00
parent 85f30987e2
commit a3033e885a
7 changed files with 77 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/compiler/tree/propagation/call-effect/call-effect.factor
View File

@ -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 ;

6
basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor
View File

@ -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

28
basis/stack-checker/row-polymorphism/row-polymorphism.factor
View File

@ -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*

2
basis/stack-checker/state/state.factor
View File

@ -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

17
core/effects/effects-tests.factor
View File

@ -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

34
core/effects/effects.factor
View File

@ -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

37
core/effects/parser/parser.factor
View File

@ -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 ] [
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
] 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 ;