diff --git a/basis/compiler/tree/propagation/info/info-tests.factor b/basis/compiler/tree/propagation/info/info-tests.factor index 72c08dbf1c..826131ab61 100644 --- a/basis/compiler/tree/propagation/info/info-tests.factor +++ b/basis/compiler/tree/propagation/info/info-tests.factor @@ -74,3 +74,13 @@ TUPLE: test-tuple { x read-only } ; [ t ] [ null-info 3 value-info<= ] unit-test + +[ t t ] [ + f + fixnum 0 40 [a,b] + value-info-union + \ f class-not + value-info-intersect + [ class>> fixnum class= ] + [ interval>> 0 40 [a,b] = ] bi +] unit-test diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index a2dec12279..98baba3e97 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs classes classes.algebra classes.tuple -classes.tuple.private kernel accessors math math.intervals -namespaces sequences words combinators byte-arrays strings -arrays layouts cpu.architecture compiler.tree.propagation.copy ; +classes.tuple.private kernel accessors math math.intervals namespaces +sequences words combinators combinators.short-circuit byte-arrays +strings arrays layouts cpu.architecture compiler.tree.propagation.copy + ; IN: compiler.tree.propagation.info : false-class? ( class -- ? ) \ f class<= ; @@ -69,7 +70,7 @@ DEFER: UNION: fixed-length array byte-array string ; : init-literal-info ( info -- info ) - [-inf,inf] >>interval + empty-interval >>interval dup literal>> class >>class dup literal>> { { [ dup real? ] [ [a,a] >>interval ] } @@ -78,11 +79,17 @@ UNION: fixed-length array byte-array string ; [ drop ] } cond ; inline +: empty-set? ( info -- ? ) + { + [ class>> null-class? ] + [ [ class>> real class<= ] [ interval>> empty-interval eq? ] bi and ] + } 1|| ; + : init-value-info ( info -- info ) dup literal?>> [ init-literal-info ] [ - dup [ class>> null-class? ] [ interval>> empty-interval eq? ] bi or [ + dup empty-set? [ null >>class empty-interval >>interval ] [ diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index f5ea64bc0a..a2955ca699 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -173,7 +173,8 @@ generic-comparison-ops [ [ object-info ] [ f ] if ; : info-intervals-intersect? ( info1 info2 -- ? ) - [ interval>> ] bi@ intervals-intersect? ; + 2dup [ class>> real class<= ] both? + [ [ interval>> ] bi@ intervals-intersect? ] [ 2drop t ] if ; { number= bignum= float= } [ [ diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index e5cade415a..46d98c28b6 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -155,6 +155,8 @@ IN: compiler.tree.propagation.tests [ V{ t } ] [ [ 40 rem 0 >= ] final-literals ] unit-test +[ V{ t } ] [ [ abs 40 mod 0 >= ] final-literals ] unit-test + [ V{ string } ] [ [ dup string? not [ "Oops" throw ] [ ] if ] final-classes ] unit-test @@ -638,6 +640,10 @@ MIXIN: empty-mixin [ { integer } declare 127 bitand ] final-info first interval>> ] unit-test +[ V{ t } ] [ + [ [ 123 bitand ] [ drop f ] if dup [ 0 >= ] [ not ] if ] final-literals +] unit-test + [ V{ bignum } ] [ [ { bignum } declare dup 1- bitxor ] final-classes ] unit-test diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 0c2540eb8b..e216b35d51 100755 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -269,22 +269,6 @@ TUPLE: interval { from read-only } { to read-only } ; [ (interval-abs) points>interval ] } cond ; -: interval-mod ( i1 i2 -- i3 ) - { - { [ over empty-interval eq? ] [ drop ] } - { [ dup empty-interval eq? ] [ nip ] } - { [ dup full-interval eq? ] [ nip ] } - [ nip interval-abs to>> first [ neg ] keep (a,b) ] - } cond ; - -: interval-rem ( i1 i2 -- i3 ) - { - { [ over empty-interval eq? ] [ drop ] } - { [ dup empty-interval eq? ] [ nip ] } - { [ dup full-interval eq? ] [ nip ] } - [ nip interval-abs to>> first 0 swap [a,b) ] - } cond ; - : interval-recip ( i1 -- i2 ) 1 [a,a] swap interval/ ; : interval-2/ ( i1 -- i2 ) -1 [a,a] interval-shift ; @@ -335,6 +319,23 @@ SYMBOL: incomparable : interval>= ( i1 i2 -- ? ) swap interval<= ; +: interval-mod ( i1 i2 -- i3 ) + { + { [ over empty-interval eq? ] [ swap ] } + { [ dup empty-interval eq? ] [ ] } + { [ dup full-interval eq? ] [ ] } + [ interval-abs to>> first [ neg ] keep (a,b) ] + } cond + swap 0 [a,a] interval>= t eq? [ [0,inf] interval-intersect ] when ; + +: interval-rem ( i1 i2 -- i3 ) + { + { [ over empty-interval eq? ] [ drop ] } + { [ dup empty-interval eq? ] [ nip ] } + { [ dup full-interval eq? ] [ nip ] } + [ nip interval-abs to>> first 0 swap [a,b) ] + } cond ; + : interval-bitand-pos ( i1 i2 -- ? ) [ to>> first ] bi@ min 0 swap [a,b] ;