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

diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor
index 4dd5502046db6764bf839a973399a5a2437fb98d..0afc61047dfb0c32d336aef9b4f57e9a6982da52 100644 (file)
--- 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 } <effect> unparse ] unit-test
 [ "(( a b -- c d ))" ] [ { "a" "b" } { "c" "d" } <effect> unparse ] unit-test
 [ "(( -- c d ))" ] [ { } { "c" "d" } <effect> unparse ] unit-test

diff --git a/core/effects/effects.factor b/core/effects/effects.factor
index c049f16f4a2b7db0b6fd2a8bac1f959347d0b128..216f50dd8e6ccd4f76788e18d31e3cb086bbe016 100644 (file)
--- 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 ]