diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor index 4dd5502046..0afc61047d 100644 --- a/core/effects/effects-tests.factor +++ b/core/effects/effects-tests.factor @@ -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 } unparse ] unit-test [ "(( a b -- c d ))" ] [ { "a" "b" } { "c" "d" } unparse ] unit-test [ "(( -- c d ))" ] [ { } { "c" "d" } unparse ] unit-test diff --git a/core/effects/effects.factor b/core/effects/effects.factor index c049f16f4a..216f50dd8e 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -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 ]