vm-error>exception-flags word to extract exception flag information from a trap exception

basis/math/floats/env/env-docs.factor

@@ -1,5 +1,5 @@
 ! (c)Joe Groff bsd license
-USING: help help.markup help.syntax quotations ;
+USING: help help.markup help.syntax kernel quotations ;
 IN: math.floats.env
 
 HELP: fp-exception
@@ -97,13 +97,21 @@ HELP: fp-traps
 
 HELP: with-fp-traps
 { $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } { "quot" quotation } }
-{ $description "Replaces the floating-point exception mask to enable processor traps to be raised for the set of exception conditions specified in " { $snippet "exceptions" } " for the dynamic extent of " { $snippet "quot" } ", restoring the original exception mask on " { $snippet "quot" } "'s completion." } ;
+{ $description "Clears the floating-point exception flags and replaces the exception mask, enabling processor traps for the set of exception conditions specified in " { $snippet "exceptions" } " for the dynamic extent of " { $snippet "quot" } ". The original exception mask is restored on " { $snippet "quot" } "'s completion." } ;
 
 HELP: without-fp-traps
 { $values { "quot" quotation } }
 { $description "Disables all floating-pointer processor traps for the dynamic extent of " { $snippet "quot" } ", restoring the original exception mask on " { $snippet "quot" } "'s completion." } ;
 
-{ fp-traps with-fp-traps without-fp-traps } related-words
+{ fp-traps with-fp-traps without-fp-traps vm-error>exception-flags vm-error-exception-flag? } related-words
+
+HELP: vm-error>exception-flags
+{ $values { "error" "a floating-point error object from the Factor VM" } { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $description "When a floating-point trap is raised, the Factor VM reports the trap by throwing a Factor exception containing the exception flags at the time the trap was raised. This word extracts the exception flag information from " { $snippet "error" } " and converts it into a sequence of " { $link fp-exception } "s." } ;
+
+HELP: vm-error-exception-flag?
+{ $values { "error" "a floating-point error object from the Factor VM" } { "flag" fp-exception } { "?" boolean } }
+{ $description "When a floating-point trap is raised, the Factor VM reports the trap by throwing a Factor exception containing the exception flags at the time the trap was raised. This word returns a boolean indicating whether the exception " { $snippet "flag" } " was raised at the time " { $snippet "error" } " was thrown." } ;
 
 ARTICLE: "math.floats.env" "Controlling the floating-point environment"
 "The " { $vocab-link "math.floats.env" } " vocabulary contains words for querying and controlling the floating-point environment."
@@ -117,11 +125,13 @@ $nl
 { $subsection fp-traps }
 { $subsection with-fp-traps }
 { $subsection without-fp-traps }
+"Getting the floating-point exception state from errors raised by enabled traps:"
+{ $subsection vm-error>exception-flags }
+{ $subsection vm-error-exception-flag? }
 "Querying and controlling the rounding mode and treatment of denormals:"
 { $subsection rounding-mode }
 { $subsection with-rounding-mode }
 { $subsection denormal-mode }
-{ $subsection with-denormal-mode }
+{ $subsection with-denormal-mode } ;
-{ $notes "On PowerPC, the above words only modify the scalar FPU's state (in FPSCR); the AltiVec unit is currently unaffected." } ;
 
 ABOUT: "math.floats.env"

basis/math/floats/env/env.factor

@@ -1,7 +1,8 @@
 ! (c)Joe Groff bsd license
-USING: alien.syntax arrays assocs biassocs combinators continuations
+USING: alien.syntax arrays assocs biassocs combinators
-generalizations kernel literals locals math math.bitwise
+combinators.short-circuit continuations generalizations kernel
-sequences sets system vocabs.loader ;
+literals locals math math.bitwise sequences sets system
+vocabs.loader ;
 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+ HEX: 01 }
+        { +fp-overflow+          HEX: 02 }
+        { +fp-underflow+         HEX: 04 }
+        { +fp-zero-divide+       HEX: 08 }
+        { +fp-inexact+           HEX: 10 }
+    }
+
 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