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 6a8110c4c1f91c51f727005274d588c23e70c50e..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:
@@ -18,6 +19,15 @@ UNION: fp-exception
     +fp-zero-divide+
     +fp-inexact+ ;
 
+CONSTANT: all-fp-exceptions
+    {
+        +fp-invalid-operation+
+        +fp-overflow+
+        +fp-underflow+
+        +fp-zero-divide+
+        +fp-inexact+
+    }
+
 SINGLETONS:
     +round-nearest+
     +round-down+
@@ -93,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 )
@@ -102,7 +121,12 @@ PRIVATE>
 : clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline
 
 : collect-fp-exceptions ( quot -- exceptions )
-    clear-fp-exception-flags call fp-exception-flags ; inline
+    [ 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) ;
 
@@ -122,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