use radix literals

[factor.git] / basis / math / floats / env / env.factor

diff --git a/basis/math/floats/env/env.factor b/basis/math/floats/env/env.factor
index 0b1267eb328e479d7e7da0b2a0d841524f1f9ef0..318589687161a77e585321e9a1481830bba07996 100644 (file)
--- a/basis/math/floats/env/env.factor
+++ b/basis/math/floats/env/env.factor
@@ -1,7 +1,8 @@
 ! (c)Joe Groff bsd license
-USING: alien.syntax arrays assocs biassocs combinators continuations
-generalizations kernel literals locals math math.bitwise
-sequences sets system vocabs.loader ;
+USING: alien.syntax arrays assocs biassocs combinators
+combinators.short-circuit continuations generalizations kernel
+literals locals math math.bitwise sequences sets system
+vocabs ;
 IN: math.floats.env
 
 SINGLETONS:
@@ -102,6 +103,15 @@ GENERIC# (set-denormal-mode) 1 ( fp-env mode -- fp-env )
         } spread
     ] 4 ncurry change-fp-env-registers ;
 
+CONSTANT: vm-error-exception-flag>bit
+    H{
+        { +fp-invalid-operation+ 0x01 }
+        { +fp-overflow+          0x02 }
+        { +fp-underflow+         0x04 }
+        { +fp-zero-divide+       0x08 }
+        { +fp-inexact+           0x10 }
+    }
+
 PRIVATE>
 
 : fp-exception-flags ( -- exceptions )
@@ -113,6 +123,11 @@ PRIVATE>
 : collect-fp-exceptions ( quot -- exceptions )
     [ clear-fp-exception-flags ] dip call fp-exception-flags ; inline
 
+: vm-error>exception-flags ( error -- exceptions )
+    third vm-error-exception-flag>bit mask> ;
+: vm-error-exception-flag? ( error flag -- ? )
+    vm-error>exception-flags member? ;
+
 : denormal-mode ( -- mode ) fp-env-register (get-denormal-mode) ;
 
 :: with-denormal-mode ( mode quot -- )
@@ -131,6 +146,7 @@ PRIVATE>
     (fp-env-registers) [ (get-fp-traps) ] [ union ] map-reduce >array ; inline
 
 :: with-fp-traps ( exceptions quot -- )
+    clear-fp-exception-flags
     fp-traps :> orig
     exceptions set-fp-traps
     quot [ orig set-fp-traps ] [ ] cleanup ; inline