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 ( -- )
[ 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 ] [
+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
[
! (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:
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 )
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