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

db4
Joe Groff 2009-09-09 23:37:48 -05:00
parent 3d49cc5a0d
commit 61851fcd7a
2 changed files with 27 additions and 9 deletions

View File

@ -1,5 +1,5 @@
USING: kernel math math.floats.env math.floats.env.private 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 IN: math.floats.env.tests
: set-default-fp-env ( -- ) : set-default-fp-env ( -- )
@ -10,12 +10,12 @@ set-default-fp-env
[ t ] [ [ t ] [
[ 1.0 0.0 / drop ] collect-fp-exceptions [ 1.0 0.0 / drop ] collect-fp-exceptions
{ +fp-zero-divide+ } set= +fp-zero-divide+ swap member?
] unit-test ] unit-test
[ t ] [ [ t ] [
[ 1.0 3.0 / drop ] collect-fp-exceptions [ 1.0 3.0 / drop ] collect-fp-exceptions
{ +fp-inexact+ } set= +fp-inexact+ swap member?
] unit-test ] unit-test
[ t ] [ [ t ] [
@ -28,9 +28,24 @@ set-default-fp-env
+fp-underflow+ swap member? +fp-underflow+ swap member?
] unit-test ] 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 ] [ [ t ] [
[ 0.0 0.0 /f drop ] collect-fp-exceptions [ 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 ] unit-test
[ [

View File

@ -1,7 +1,7 @@
! (c)Joe Groff bsd license ! (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 generalizations kernel literals locals math math.bitwise
sequences system vocabs.loader ; sequences sets system vocabs.loader ;
IN: math.floats.env IN: math.floats.env
SINGLETONS: SINGLETONS:
@ -95,8 +95,10 @@ GENERIC# (set-denormal-mode) 1 ( fp-env mode -- fp-env )
PRIVATE> PRIVATE>
: fp-exception-flags ( -- exceptions ) fp-env-register (get-exception-flags) ; : fp-exception-flags ( -- exceptions )
: set-fp-exception-flags ( exceptions -- ) [ (set-exception-flags) ] curry change-fp-env-registers ; (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 : clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline
: collect-fp-exceptions ( quot -- exceptions ) : collect-fp-exceptions ( quot -- exceptions )
@ -116,7 +118,8 @@ PRIVATE>
mode set-rounding-mode mode set-rounding-mode
quot [ orig set-rounding-mode ] [ ] cleanup ; inline 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 -- ) :: with-fp-traps ( exceptions quot -- )
fp-traps :> orig fp-traps :> orig