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

diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor
index 72618db4569740d4d583d83e9c1dc30bae19fa2d..20fcff84409f6261e724ab91ceede9e04e9275b9 100644 (file)
--- a/basis/compiler/tests/optimizer.factor
+++ b/basis/compiler/tests/optimizer.factor
@@ -391,6 +391,17 @@ DEFER: loop-bbb
 
 [ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
 
+! Interval inference issue
+[ f ] [
+    10 70
+    [
+        dup 70 >=
+        [ dup 700 <= [ swap 1024 rem rem ] [ 2drop 70 ] if ]
+        [ 2drop 70 ] if
+        70 >=
+    ] compile-call
+] unit-test
+
 ! Modular arithmetic bug
 : modular-arithmetic-bug ( a -- b ) >integer 256 mod ;
 

diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor
index dbf014bda8070da0ff5bbf8972edefb56443dd9b..760338a7c3b4300c41049c129fbf53f7e6c8156a 100644 (file)
--- a/basis/math/intervals/intervals-tests.factor
+++ b/basis/math/intervals/intervals-tests.factor
@@ -1,6 +1,6 @@
 USING: math.intervals kernel sequences words math math.order
 arrays prettyprint tools.test random vocabs combinators
-accessors math.constants ;
+accessors math.constants fry ;
 IN: math.intervals.tests
 
 [ empty-interval ] [ 2 2 (a,b) ] unit-test
@@ -246,7 +246,7 @@ IN: math.intervals.tests
         } case
     ] if ;
 
-: random-unary-op ( -- pair )
+: unary-ops ( -- alist )
     {
         { bitnot interval-bitnot }
         { abs interval-abs }
@@ -257,11 +257,10 @@ IN: math.intervals.tests
     }
     "math.ratios.private" vocab [
         { recip interval-recip } suffix
-    ] when
-    random ;
+    ] when ;
 
-: unary-test ( -- ? )
-    random-interval random-unary-op ! 2dup . .
+: unary-test ( op -- ? )
+    [ random-interval ] dip
     0 pick interval-contains? over first \ recip eq? and [
         2drop t
     ] [
@@ -269,9 +268,11 @@ IN: math.intervals.tests
         second execute( a -- b ) interval-contains?
     ] if ;
 
-[ t ] [ 80000 iota [ drop unary-test ] all? ] unit-test
+unary-ops [
+    [ [ t ] ] dip '[ 8000 iota [ drop _ unary-test ] all? ] unit-test
+] each
 
-: random-binary-op ( -- pair )
+: binary-ops ( -- alist )
     {
         { + interval+ }
         { - interval- }
@@ -282,17 +283,15 @@ IN: math.intervals.tests
         { bitand interval-bitand }
         { bitor interval-bitor }
         { bitxor interval-bitxor }
-        ! { shift interval-shift }
         { min interval-min }
         { max interval-max }
     }
     "math.ratios.private" vocab [
         { / interval/ } suffix
-    ] when
-    random ;
+    ] when ;
 
-: binary-test ( -- ? )
-    random-interval random-interval random-binary-op ! 3dup . . .
+: binary-test ( op -- ? )
+    [ random-interval random-interval ] dip
     0 pick interval-contains? over first { / /i mod rem } member? and [
         3drop t
     ] [
@@ -300,22 +299,26 @@ IN: math.intervals.tests
         second execute( a b -- c ) interval-contains?
     ] if ;
 
-[ t ] [ 80000 iota [ drop binary-test ] all? ] unit-test
+binary-ops [
+    [ [ t ] ] dip '[ 8000 iota [ drop _ binary-test ] all? ] unit-test
+] each
 
-: random-comparison ( -- pair )
+: comparison-ops ( -- alist )
     {
         { < interval< }
         { <= interval<= }
         { > interval> }
         { >= interval>= }
-    } random ;
+    } ;
 
-: comparison-test ( -- ? )
-    random-interval random-interval random-comparison
+: comparison-test ( op -- ? )
+    [ random-interval random-interval ] dip
     [ [ [ random-element ] bi@ ] dip first execute( a b -- ? ) ] 3keep
     second execute( a b -- ? ) dup incomparable eq? [ 2drop t ] [ = ] if ;
 
-[ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test
+comparison-ops [
+    [ [ t ] ] dip '[ 8000 iota [ drop _ comparison-test ] all? ] unit-test
+] each
 
 [ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test
 
@@ -335,18 +338,19 @@ IN: math.intervals.tests
 : random-interval-or-empty ( -- obj )
     10 random 0 = [ empty-interval ] [ random-interval ] if ;
 
-: random-commutative-op ( -- op )
+: commutative-ops ( -- seq )
     {
         interval+ interval*
         interval-bitor interval-bitand interval-bitxor
         interval-max interval-min
-    } random ;
-
-[ t ] [
-    80000 iota [
-        drop
-        random-interval-or-empty random-interval-or-empty
-        random-commutative-op
-        [ execute ] [ swapd execute ] 3bi =
-    ] all?
-] unit-test
+    } ;
+
+commutative-ops [
+    [ [ t ] ] dip '[
+        8000 iota [
+            drop
+            random-interval-or-empty random-interval-or-empty _
+            [ execute ] [ swapd execute ] 3bi =
+        ] all?
+    ] unit-test
+] each

diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor
index 8b07394596700ea30b3b35c10f0a3a12668edfd2..3c339406763b203f7f64eaff6f2a161c546b03a1 100755 (executable)
--- a/basis/math/intervals/intervals.factor
+++ b/basis/math/intervals/intervals.factor
@@ -340,8 +340,8 @@ SYMBOL: incomparable
     {
         { [ over empty-interval eq? ] [ drop ] }
         { [ dup empty-interval eq? ] [ nip ] }
-        { [ dup full-interval eq? ] [ nip ] }
-        [ (rem-range) 2dup interval-subset? [ drop ] [ nip ] if ]
+        { [ dup full-interval eq? ] [ 2drop [0,inf] ] }
+        [ nip (rem-range) ]
     } cond ;
 
 : interval->fixnum ( i1 -- i2 )