factor: trim using lists

[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..d019d1ee0e379c640303cc581589e6d4dedf21b2 100644 (file)
--- a/basis/math/floats/env/env.factor
+++ b/basis/math/floats/env/env.factor
@@ -1,7 +1,7 @@
-! (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 ;
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators continuations generalizations
+kernel math math.bitwise sequences sets system vocabs ;
 IN: math.floats.env
 
 SINGLETONS:
@@ -54,7 +54,7 @@ HOOK: (fp-env-registers) cpu ( -- registers )
 : fp-env-register ( -- register ) (fp-env-registers) first ;
 
 :: mask> ( bits assoc -- symbols )
-    assoc [| k v | bits v mask zero? not ] assoc-filter keys ;
+    assoc [| k v | bits v mask zero? ] assoc-reject keys ;
 : >mask ( symbols assoc -- bits )
     over empty?
     [ 2drop 0 ]
@@ -66,16 +66,16 @@ HOOK: (fp-env-registers) cpu ( -- registers )
 GENERIC: (set-fp-env-register) ( fp-env -- )
 
 GENERIC: (get-exception-flags) ( fp-env -- exceptions )
-GENERIC# (set-exception-flags) 1 ( fp-env exceptions -- fp-env )
+GENERIC#: (set-exception-flags) 1 ( fp-env exceptions -- fp-env )
 
 GENERIC: (get-fp-traps) ( fp-env -- exceptions )
-GENERIC# (set-fp-traps) 1 ( fp-env exceptions -- fp-env )
+GENERIC#: (set-fp-traps) 1 ( fp-env exceptions -- fp-env )
 
 GENERIC: (get-rounding-mode) ( fp-env -- mode )
-GENERIC# (set-rounding-mode) 1 ( fp-env mode -- fp-env )
+GENERIC#: (set-rounding-mode) 1 ( fp-env mode -- fp-env )
 
 GENERIC: (get-denormal-mode) ( fp-env -- mode )
-GENERIC# (set-denormal-mode) 1 ( fp-env mode -- fp-env )
+GENERIC#: (set-denormal-mode) 1 ( fp-env mode -- fp-env )
 
 : change-fp-env-registers ( quot -- )
     (fp-env-registers) swap [ (set-fp-env-register) ] compose each ; inline
@@ -102,6 +102,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,34 +122,39 @@ 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 -- )
     denormal-mode :> orig
     mode set-denormal-mode
-    quot [ orig set-denormal-mode ] [ ] cleanup ; inline
+    quot [ orig set-denormal-mode ] finally ; inline
 
 : rounding-mode ( -- mode ) fp-env-register (get-rounding-mode) ;
 
 :: with-rounding-mode ( mode quot -- )
     rounding-mode :> orig
     mode set-rounding-mode
-    quot [ orig set-rounding-mode ] [ ] cleanup ; inline
+    quot [ orig set-rounding-mode ] finally ; inline
 
 : 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
+    quot [ orig set-fp-traps ] finally ; inline
 
 : without-fp-traps ( quot -- )
     { } swap with-fp-traps ; inline
 
-<< {
+{
     { [ cpu x86? ] [ "math.floats.env.x86" require ] }
     { [ cpu ppc? ] [ "math.floats.env.ppc" require ] }
     [ "CPU architecture unsupported by math.floats.env" throw ]
-} cond >>
-
+} cond