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

make effect<= work with univariable stack effects, deny all bivariable stack effects

db4
Joe Groff 2010-03-11 01:37:33 -08:00
parent 8b1b7b20d5
commit c35dd7c2ef
2 changed files with 14 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -10,6 +10,13 @@ IN: effects.tests
[ 2 ] [ (( a b -- c )) in>> length ] unit-test
[ 1 ] [ (( a b -- c )) out>> length ] unit-test
[ t ] [ (( a b -- c )) (( ... a b -- ... c )) effect<= ] unit-test
[ t ] [ (( b -- )) (( ... a b -- ... c )) effect<= ] unit-test
[ f ] [ (( ... a b -- ... c )) (( a b -- c )) effect<= ] unit-test
[ f ] [ (( ... b -- ... )) (( a b -- c )) effect<= ] unit-test
[ f ] [ (( a b -- c )) (( ... a b -- c )) effect<= ] unit-test
[ f ] [ (( a b -- c )) (( ..x a b -- ..y c )) effect<= ] unit-test
[ "(( object -- object ))" ] [ { f } { f } <effect> unparse ] unit-test
[ "(( a b -- c d ))" ] [ { "a" "b" } { "c" "d" } <effect> unparse ] unit-test
[ "(( -- c d ))" ] [ { } { "c" "d" } <effect> unparse ] unit-test

7
core/effects/effects.factor
View File

@ -27,10 +27,17 @@ TUPLE: effect
: effect-height ( effect -- n )
[ out>> length ] [ in>> length ] bi - ; inline
: variable-effect? ( effect -- ? )
[ in-var>> ] [ out-var>> ] bi or ;
: bivariable-effect? ( effect -- ? )
[ in-var>> ] [ out-var>> ] bi = not ;
: effect<= ( effect1 effect2 -- ? )
{
{ [ over terminated?>> ] [ t ] }
{ [ dup terminated?>> ] [ f ] }
{ [ 2dup [ bivariable-effect? ] either? ] [ f ] }
{ [ 2dup [ variable-effect? ] [ variable-effect? not ] bi* and ] [ f ] }
{ [ 2dup [ in>> length ] bi@ > ] [ f ] }
{ [ 2dup [ effect-height ] bi@ = not ] [ f ] }
[ t ]