Merge branch 'master' of git://factorcode.org/git/factor into constraints

[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 108afad2960ce254cbd5d47d5675aab97c9e8823..b436b21329f84fc4e02accee8f3f76343fd849cc 100644 (file)
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -8,8 +8,10 @@ math.functions math.private strings layouts
 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 ;
+specialized-arrays system sorting math.libm
+math.intervals quotations effects alien ;
+FROM: math => float ;
+SPECIALIZED-ARRAY: double
 IN: compiler.tree.propagation.tests
 
 [ V{ } ] [ [ ] final-classes ] unit-test
@@ -30,6 +32,8 @@ IN: compiler.tree.propagation.tests
 
 [ V{ 69 } ] [ [ [ 69 ] [ 69 ] if ] final-literals ] unit-test
 
+[ V{ integer } ] [ [ bitnot ] final-classes ] unit-test
+
 [ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test
 
 ! Test type propagation for math ops
@@ -82,11 +86,13 @@ IN: compiler.tree.propagation.tests
 
 [ bignum ] [ [ { bignum bignum } declare bitxor ] final-math-class ] unit-test
 
+[ bignum ] [ [ { integer } declare 123 >bignum bitand ] final-math-class ] 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
 
@@ -149,6 +155,46 @@ 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
+
+[ t ] [ [ abs ] final-info first interval>> [0,inf] = ] unit-test
+
+[ t ] [ [ absq ] final-info first interval>> [0,inf] = ] unit-test
+
+[ t ] [ [ { fixnum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test
+
+[ t ] [ [ { fixnum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test
+
+[ V{ integer } ] [ [ { fixnum } declare abs ] final-classes ] unit-test
+
+[ V{ integer } ] [ [ { fixnum } declare absq ] final-classes ] unit-test
+
+[ t ] [ [ { bignum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test
+
+[ t ] [ [ { bignum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test
+
+[ t ] [ [ { float } declare abs ] final-info first interval>> [0,inf] = ] unit-test
+
+[ t ] [ [ { float } declare absq ] final-info first interval>> [0,inf] = ] unit-test
+
+[ t ] [ [ { complex } declare abs ] final-info first interval>> [0,inf] = ] unit-test
+
+[ t ] [ [ { complex } declare absq ] final-info first interval>> [0,inf] = ] unit-test
+
+[ t ] [ [ { float float } declare rect> C{ 0.0 0.0 } + absq ] final-info first interval>> [0,inf] = ] unit-test
+
+[ V{ float } ] [ [ { float float } declare rect> C{ 0.0 0.0 } + absq ] final-classes ] unit-test
+
+[ t ] [ [ [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test
+
+[ t ] [ [ { double-array double-array } declare [ - absq ] [ + ] 2map-reduce ] final-info first interval>> [0,inf] = ] unit-test
+
 [ V{ string } ] [
     [ dup string? not [ "Oops" throw ] [ ] if ] final-classes
 ] unit-test
@@ -220,6 +266,13 @@ IN: compiler.tree.propagation.tests
     ] final-literals
 ] unit-test
 
+[ V{ 1.5 } ] [
+    [
+        /f
+        dup 1.5 u<= [ dup 1.5 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
+    ] final-literals
+] unit-test
+
 [ V{ 1.5 } ] [
     [
         /f
@@ -227,6 +280,13 @@ IN: compiler.tree.propagation.tests
     ] final-literals
 ] unit-test
 
+[ V{ 1.5 } ] [
+    [
+        /f
+        dup 1.5 u<= [ dup 10 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
+    ] final-literals
+] unit-test
+
 [ V{ f } ] [
     [
         /f
@@ -234,6 +294,13 @@ IN: compiler.tree.propagation.tests
     ] final-literals
 ] unit-test
 
+[ V{ f } ] [
+    [
+        /f
+        dup 0.0 u<= [ dup 0.0 u>= [ drop 0.0 ] unless ] [ drop 0.0 ] if
+    ] final-literals
+] unit-test
+
 [ V{ fixnum } ] [
     [ 0 dup 10 > [ 100 * ] when ] final-classes
 ] unit-test
@@ -242,6 +309,14 @@ IN: compiler.tree.propagation.tests
     [ 0 dup 10 > [ drop "foo" ] when ] final-classes
 ] unit-test
 
+[ V{ fixnum } ] [
+    [ 0 dup 10 u> [ 100 * ] when ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ 0 dup 10 u> [ drop "foo" ] when ] final-classes
+] unit-test
+
 [ V{ fixnum } ] [
     [ { fixnum } declare 3 3 - + ] final-classes
 ] unit-test
@@ -250,6 +325,10 @@ IN: compiler.tree.propagation.tests
     [ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals
 ] unit-test
 
+[ V{ t } ] [
+    [ dup 10 u< [ 3 * 30 u< ] [ drop t ] if ] final-literals
+] unit-test
+
 [ V{ "d" } ] [
     [
         3 {
@@ -270,11 +349,19 @@ 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{ fixnum } ] [
+    [ >fixnum dup 100 u< [ 1 + ] [ "Oops" throw ] if ] final-classes
+] unit-test
+
+[ V{ -1 } ] [
+    [ 0 dup 100 < not [ 1 + ] [ 1 - ] if ] final-literals
 ] unit-test
 
 [ V{ -1 } ] [
-    [ 0 dup 100 < not [ 1+ ] [ 1- ] if ] final-literals
+    [ 0 dup 100 u< not [ 1 + ] [ 1 - ] if ] final-literals
 ] unit-test
 
 [ V{ 2 } ] [
@@ -285,12 +372,22 @@ IN: compiler.tree.propagation.tests
     [ 0 * 10 < ] final-classes
 ] unit-test
 
+[ V{ object } ] [
+    [ 0 * 10 u< ] final-classes
+] unit-test
+
 [ V{ 27 } ] [
     [
         123 bitand dup 10 < over 8 > and [ 3 * ] [ "B" throw ] if
     ] final-literals
 ] unit-test
 
+[ V{ 27 } ] [
+    [
+        123 bitand dup 10 u< over 8 u> and [ 3 * ] [ "B" throw ] if
+    ] final-literals
+] unit-test
+
 [ V{ 27 } ] [
     [
         dup number? over sequence? and [
@@ -436,6 +533,13 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
     ] final-classes
 ] unit-test
 
+[ V{ f { } } ] [
+    [
+        T{ mixed-mutable-immutable f 3 { } }
+        [ x>> ] [ y>> ] bi
+    ] final-literals
+] unit-test
+
 ! Recursive propagation
 : recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive
 
@@ -464,7 +568,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
 
@@ -479,7 +583,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
 
@@ -494,8 +598,8 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
 ] unit-test
 
 GENERIC: iterate ( obj -- next-obj ? )
-M: fixnum iterate f ;
-M: array iterate first t ;
+M: fixnum iterate f ; inline
+M: array iterate first t ; inline
 
 : dead-loop ( obj -- final-obj )
     iterate [ dead-loop ] when ; inline recursive
@@ -559,7 +663,7 @@ M: array iterate first t ;
 ] unit-test
 
 GENERIC: bad-generic ( a -- b )
-M: fixnum bad-generic 1 fixnum+fast ;
+M: fixnum bad-generic 1 fixnum+fast ; inline
 : bad-behavior ( -- b ) 4 bad-generic ; inline recursive
 
 [ V{ fixnum } ] [ [ bad-behavior ] final-classes ] unit-test
@@ -632,14 +736,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
@@ -652,24 +764,24 @@ MIXIN: empty-mixin
     [ { word object } declare equal? ] final-classes
 ] unit-test
 
-! [ V{ string } ] [
-!     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
-! ] unit-test
+[ V{ string } ] [
+    [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
+] unit-test
 
-! [ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
+[ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
 
-! [ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
+[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
 
-! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
+[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
 
-! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
+[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
 
 ! generalize-counter-interval wasn't being called in all the right places.
 ! bug found by littledan
 
 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
 
@@ -686,7 +798,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
@@ -695,7 +807,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 ;
@@ -710,10 +836,61 @@ TUPLE: foo bar ;
 [ t ] [ [ foo new ] { new } inlined? ] unit-test
 
 GENERIC: whatever ( x -- y )
-M: number whatever drop foo ;
+M: number whatever drop foo ; inline
 
 [ 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 } } ; inline
+M: f whatever2 ; inline
+
+[ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
+[ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test
+
+SYMBOL: not-an-assoc
+
+[ f ] [ [ not-an-assoc at ] { at* } 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
+
+! Type function for 'clone' had a subtle issue
+TUPLE: tuple-with-read-only-slot { x read-only } ;
+
+M: tuple-with-read-only-slot clone
+    x>> clone tuple-with-read-only-slot boa ; inline
+
+[ V{ object } ] [
+    [ { 1 2 3 } dup tuple-with-read-only-slot boa clone x>> eq? ] final-classes
+] unit-test
+
+! alien-cell outputs a simple-alien or f
+[ t ] [
+    [ { byte-array fixnum } declare alien-cell dup [ "OOPS" throw ] unless ] final-classes
+    first simple-alien class=
+] unit-test
+
+! Don't crash if bad literal inputs are passed to unsafe words
+[ f ] [ [ { } 1 fixnum+fast ] final-info first literal?>> ] unit-test
+
+! Converting /i to shift
+[ t ] [ [ >fixnum dup 0 >= [ 16 /i ] when ] { /i fixnum/i fixnum/i-fast } inlined? ] unit-test
+[ f ] [ [ >fixnum dup 0 >= [ 16 /i ] when ] { fixnum-shift-fast } inlined? ] unit-test
+[ f ] [ [ >float dup 0 >= [ 16 /i ] when ] { /i float/f } inlined? ] unit-test