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 d081ec12b8bac8797006311bf6e55f3fb2f14909..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 assocs biassocs combinators continuations
-generalizations kernel literals locals math math.bitwise
-sequences 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,14 +103,30 @@ 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 ) 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 )
-    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) ;
 
@@ -116,9 +142,11 @@ 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 -- )
+    clear-fp-exception-flags
     fp-traps :> orig
     exceptions set-fp-traps
     quot [ orig set-fp-traps ] [ ] cleanup ; inline