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 06e68d3e3575278e73f72f85be600befd446f92c..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
+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
@@ -163,6 +167,18 @@ IN: compiler.tree.propagation.tests
 
 [ 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
@@ -171,6 +187,10 @@ IN: compiler.tree.propagation.tests
 
 [ 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
@@ -246,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
@@ -253,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
@@ -260,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
@@ -268,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
@@ -276,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 {
@@ -299,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
@@ -311,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 [
@@ -693,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
@@ -818,3 +889,8 @@ M: tuple-with-read-only-slot clone
 
 ! 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