Delete empty unit tests files, remove 1- and 1+, reorder IN: lines in a lot of places...

[factor.git] / basis / compiler / tree / propagation / propagation-tests.factor

diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 9cb0e412918f37f201e8fc47f89b5cc3458e8d00..eb9591c40cc96751b4824ed0891032d01769a1bd 100644 (file)
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker
 slots.private words hashtables classes assocs locals
 specialized-arrays.double system sorting math.libm
-math.intervals quotations ;
+math.intervals quotations effects ;
 IN: compiler.tree.propagation.tests
 
 [ V{ } ] [ [ ] final-classes ] unit-test
@@ -84,9 +84,9 @@ IN: compiler.tree.propagation.tests
 
 [ 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
 
@@ -149,6 +149,14 @@ IN: compiler.tree.propagation.tests
     ] 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
@@ -270,11 +278,11 @@ IN: compiler.tree.propagation.tests
 ] 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 } ] [
@@ -331,6 +339,16 @@ cell-bits 32 = [
     [ { 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 } ;
 
@@ -454,7 +472,7 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
 ] 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
 
@@ -469,7 +487,7 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
 [ 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
 
@@ -622,14 +640,22 @@ 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
+    [ { 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
@@ -659,7 +685,7 @@ MIXIN: empty-mixin
 
 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
 
@@ -676,7 +702,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
 [ ] [ [ 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
@@ -685,7 +711,21 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
 
 [ 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 ;
@@ -694,3 +734,39 @@ TUPLE: circle me ;
 
 ! 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