[ t ] [
null-info 3 <literal-info> value-info<=
] unit-test
+
+[ t t ] [
+ f <literal-info>
+ fixnum 0 40 [a,b] <class/interval-info>
+ value-info-union
+ \ f class-not <class-info>
+ value-info-intersect
+ [ class>> fixnum class= ]
+ [ interval>> 0 40 [a,b] = ] bi
+] unit-test
! 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<= ;
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 ] }
[ 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
] [
[ object-info ] [ f <literal-info> ] 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= } [
[
[ 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
[ { 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
[ (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 ;
: 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] ;