take the union of the x87 and sse exception flags when reporting fp-exception-flags. add back the unit tests i took out since this should fix the problem
parent
3d49cc5a0d
commit
61851fcd7a
|
@ -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
|
||||
|
||||
[
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue