diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 72618db456..20fcff8440 100644 --- 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 dbf014bda8..760338a7c3 100644 --- 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 8b07394596..3c33940676 100755 --- 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 )