diff --git a/basis/math/floats/env/env-tests.factor b/basis/math/floats/env/env-tests.factor index 231eba919c..a0ffa0713c 100644 --- a/basis/math/floats/env/env-tests.factor +++ b/basis/math/floats/env/env-tests.factor @@ -1,5 +1,5 @@ USING: kernel math math.floats.env math.floats.env.private -math.functions math.libm sets sequences tools.test ; +math.functions math.libm sequences tools.test ; IN: math.floats.env.tests : set-default-fp-env ( -- ) @@ -10,12 +10,12 @@ set-default-fp-env [ t ] [ [ 1.0 0.0 / drop ] collect-fp-exceptions - { +fp-zero-divide+ } set= + +fp-zero-divide+ swap member? ] unit-test [ t ] [ [ 1.0 3.0 / drop ] collect-fp-exceptions - { +fp-inexact+ } set= + +fp-inexact+ swap member? ] unit-test [ t ] [ @@ -28,9 +28,24 @@ set-default-fp-env +fp-underflow+ swap member? ] unit-test +[ t ] [ + [ 2.0 100,000.0 ^ drop ] collect-fp-exceptions + +fp-overflow+ swap member? +] unit-test + +[ t ] [ + [ 2.0 -100,000.0 ^ drop ] collect-fp-exceptions + +fp-underflow+ swap member? +] unit-test + [ t ] [ [ 0.0 0.0 /f drop ] collect-fp-exceptions - { +fp-invalid-operation+ } set= + +fp-invalid-operation+ swap member? +] unit-test + +[ t ] [ + [ -1.0 fsqrt drop ] collect-fp-exceptions + +fp-invalid-operation+ swap member? ] unit-test [ diff --git a/basis/math/floats/env/env.factor b/basis/math/floats/env/env.factor index d081ec12b8..6a8110c4c1 100644 --- a/basis/math/floats/env/env.factor +++ b/basis/math/floats/env/env.factor @@ -1,7 +1,7 @@ ! (c)Joe Groff bsd license -USING: alien.syntax assocs biassocs combinators continuations +USING: alien.syntax arrays assocs biassocs combinators continuations generalizations kernel literals locals math math.bitwise -sequences system vocabs.loader ; +sequences sets system vocabs.loader ; IN: math.floats.env SINGLETONS: @@ -95,8 +95,10 @@ GENERIC# (set-denormal-mode) 1 ( fp-env mode -- fp-env ) PRIVATE> -: fp-exception-flags ( -- exceptions ) fp-env-register (get-exception-flags) ; -: set-fp-exception-flags ( exceptions -- ) [ (set-exception-flags) ] curry change-fp-env-registers ; +: fp-exception-flags ( -- exceptions ) + (fp-env-registers) [ (get-exception-flags) ] [ union ] map-reduce >array ; inline +: set-fp-exception-flags ( exceptions -- ) + [ (set-exception-flags) ] curry change-fp-env-registers ; inline : clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline : collect-fp-exceptions ( quot -- exceptions ) @@ -116,7 +118,8 @@ PRIVATE> mode set-rounding-mode quot [ orig set-rounding-mode ] [ ] cleanup ; inline -: fp-traps ( -- exceptions ) fp-env-register (get-fp-traps) ; +: fp-traps ( -- exceptions ) + (fp-env-registers) [ (get-fp-traps) ] [ union ] map-reduce >array ; inline :: with-fp-traps ( exceptions quot -- ) fp-traps :> orig