compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
specialized-arrays.double system sorting math.libm
-math.intervals ;
+math.intervals quotations effects ;
IN: compiler.tree.propagation.tests
[ V{ } ] [ [ ] final-classes ] unit-test
[ float ] [ [ { float float } declare mod ] final-math-class ] unit-test
-[ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test
+[ V{ fixnum } ] [ [ 255 bitand ] final-classes ] unit-test
-[ V{ integer } ] [
+[ V{ fixnum } ] [
[ [ 255 bitand ] [ 65535 bitand ] bi + ] final-classes
] unit-test
] final-literals
] unit-test
+[ V{ t } ] [ [ 40 mod 40 < ] final-literals ] unit-test
+
+[ V{ f } ] [ [ 40 mod 0 >= ] final-literals ] unit-test
+
+[ 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
{ fixnum byte-array } declare
[ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe
[ [ 298 * ] dip 100 * - ] dip 208 * - 128 + -8 shift
- 255 min 0 max
+ 0 255 clamp
] final-classes
] unit-test
] unit-test
[ V{ 1.5 } ] [
- [ /f 1.5 min 1.5 max ] final-literals
+ [ /f 1.5 1.5 clamp ] final-literals
] unit-test
[ V{ 1.5 } ] [
] unit-test
[ V{ fixnum } ] [
- [ >fixnum dup 100 < [ 1+ ] [ "Oops" throw ] if ] final-classes
+ [ >fixnum dup 100 < [ 1 + ] [ "Oops" throw ] if ] final-classes
] unit-test
[ V{ -1 } ] [
- [ 0 dup 100 < not [ 1+ ] [ 1- ] if ] final-literals
+ [ 0 dup 100 < not [ 1 + ] [ 1 - ] if ] final-literals
] unit-test
[ V{ 2 } ] [
[ { fixnum } declare dup 10 eq? [ "A" throw ] unless ] final-literals
] unit-test
+[ V{ 3 } ] [ [ [ { 1 2 3 } ] [ { 4 5 6 } ] if length ] final-literals ] unit-test
+
+[ V{ 3 } ] [ [ [ B{ 1 2 3 } ] [ B{ 4 5 6 } ] if length ] final-literals ] unit-test
+
+[ V{ 3 } ] [ [ [ "yay" ] [ "hah" ] if length ] final-literals ] unit-test
+
+[ V{ 3 } ] [ [ 3 <byte-array> length ] final-literals ] unit-test
+
+[ V{ 3 } ] [ [ 3 f <string> length ] final-literals ] unit-test
+
! Slot propagation
TUPLE: prop-test-tuple { x integer } ;
] unit-test
[ V{ complex } ] [
- [ <complex> ] final-classes
+ [ complex boa ] final-classes
] unit-test
[ V{ complex } ] [
[ V{ complex } ] [
[
{ float float object } declare
- [ "Oops" throw ] [ <complex> ] if
+ [ "Oops" throw ] [ complex boa ] if
] final-classes
] unit-test
] unit-test
: recursive-test-4 ( i n -- )
- 2dup < [ [ 1+ ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive
+ 2dup < [ [ 1 + ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive
[ ] [ [ recursive-test-4 ] final-info drop ] unit-test
[ V{ integer } ] [ [ { fixnum } declare recursive-test-6 ] final-classes ] unit-test
: recursive-test-7 ( a -- b )
- dup 10 < [ 1+ recursive-test-7 ] when ; inline recursive
+ dup 10 < [ 1 + recursive-test-7 ] when ; inline recursive
[ V{ fixnum } ] [ [ 0 recursive-test-7 ] final-classes ] unit-test
[ V{ float } ] [
[
- [ { float float } declare <complex> ]
+ [ { float float } declare complex boa ]
[ 2drop C{ 0.0 0.0 } ]
if real-part
] final-classes
[ { 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
+ [ { bignum } declare dup 1 - bitxor ] final-classes
] unit-test
[ V{ bignum integer } ] [
[ { bignum integer } declare [ shift ] keep ] final-classes
] unit-test
+[ V{ fixnum } ] [ [ >fixnum 15 bitand 1 swap shift ] final-classes ] unit-test
+
+[ V{ fixnum } ] [ [ 15 bitand 1 swap shift ] final-classes ] unit-test
+
[ V{ fixnum } ] [
[ { fixnum } declare log2 ] final-classes
] unit-test
TUPLE: littledan-1 { a read-only } ;
-: (littledan-1-test) ( a -- ) a>> 1+ littledan-1 boa (littledan-1-test) ; inline recursive
+: (littledan-1-test) ( a -- ) a>> 1 + littledan-1 boa (littledan-1-test) ; inline recursive
: littledan-1-test ( -- ) 0 littledan-1 boa (littledan-1-test) ; inline
[ ] [ [ littledan-2-test ] final-classes drop ] unit-test
: (littledan-3-test) ( x -- )
- length 1+ f <array> (littledan-3-test) ; inline recursive
+ length 1 + f <array> (littledan-3-test) ; inline recursive
: littledan-3-test ( -- )
0 f <array> (littledan-3-test) ; inline
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
-[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
+[ V{ 1 } ] [ [ { } length 1 + f <array> length ] final-literals ] unit-test
+
+! generalize-counter is not tight enough
+[ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times ] final-classes ] unit-test
+
+[ V{ fixnum } ] [ [ 0 10 [ 1 + >fixnum ] times 0 + ] final-classes ] unit-test
+
+! Coercions need to update intervals
+[ V{ f } ] [ [ 1 2 ? 100 shift >fixnum 1 = ] final-literals ] unit-test
+
+[ V{ t } ] [ [ >fixnum 1 + >fixnum most-positive-fixnum <= ] final-literals ] unit-test
+
+[ V{ t } ] [ [ >fixnum 1 + >fixnum most-negative-fixnum >= ] final-literals ] unit-test
+
+[ V{ f } ] [ [ >fixnum 1 + >fixnum most-negative-fixnum > ] final-literals ] unit-test
+
+! Mutable tuples with circularity should not cause problems
+TUPLE: circle me ;
+
+[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
+
+! Joe found an oversight
+[ V{ integer } ] [ [ >integer ] final-classes ] unit-test
+
+TUPLE: foo bar ;
+
+[ t ] [ [ foo new ] { new } inlined? ] unit-test
+
+GENERIC: whatever ( x -- y )
+M: number whatever drop foo ;
+
+[ t ] [ [ 1 whatever new ] { new } inlined? ] unit-test
+
+: that-thing ( -- class ) foo ;
+
+[ f ] [ [ that-thing new ] { new } inlined? ] unit-test
+
+GENERIC: whatever2 ( x -- y )
+M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ;
+M: f whatever2 ;
+
+[ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
+[ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test
+
+[ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test
+[ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test
+
+[ t ] [ [ { 1 2 3 } memq? ] { memq? } inlined? ] unit-test
+[ f ] [ [ { 1 2 3 } swap memq? ] { memq? } inlined? ] unit-test
+
+[ t ] [ [ V{ } clone ] { clone (clone) } inlined? ] unit-test
+[ f ] [ [ { } clone ] { clone (clone) } inlined? ] unit-test
+
+[ f ] [ [ instance? ] { instance? } inlined? ] unit-test
+[ f ] [ [ 5 instance? ] { instance? } inlined? ] unit-test
+[ t ] [ [ array instance? ] { instance? } inlined? ] unit-test
+
+[ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test
+[ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test