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 1c9b27dfbcf662d2aee71ec4e2ef66449eeb6178..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 effects ;
+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
@@ -56,9 +60,9 @@ IN: compiler.tree.propagation.tests
 
 [ float ] [ [ { float real } declare + ] final-math-class ] unit-test
 
-! [ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test
+[ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test
 
-! [ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test
+[ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test
 
 [ number ] [ [ { complex complex } declare + ] final-math-class ] unit-test
 
@@ -82,6 +86,8 @@ 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{ fixnum } ] [ [ 255 bitand ] final-classes ] unit-test
@@ -157,6 +163,38 @@ IN: compiler.tree.propagation.tests
 
 [ 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
@@ -228,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
@@ -235,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
@@ -242,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
@@ -250,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
@@ -258,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 {
@@ -281,10 +352,18 @@ IN: compiler.tree.propagation.tests
     [ >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 u< not [ 1 + ] [ 1 - ] if ] final-literals
+] unit-test
+
 [ V{ 2 } ] [
     [ [ 1 ] [ 1 ] if 1 + ] final-literals
 ] unit-test
@@ -293,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 [
@@ -675,17 +764,17 @@ 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
@@ -762,6 +851,10 @@ 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
 
@@ -777,3 +870,27 @@ M: f whatever2 ; inline
 
 [ 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