diff --git a/basis/math/floats/env/env-docs.factor b/basis/math/floats/env/env-docs.factor index ef580b9040..0fc781713c 100644 --- a/basis/math/floats/env/env-docs.factor +++ b/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 } -{ $notes "On PowerPC, the above words only modify the scalar FPU's state (in FPSCR); the AltiVec unit is currently unaffected." } ; +{ $subsection with-denormal-mode } ; ABOUT: "math.floats.env" diff --git a/basis/math/floats/env/env.factor b/basis/math/floats/env/env.factor index 0b1267eb32..04fbc4f26c 100644 --- 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.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