From e705470d4295f77646671fc26c44d764448d1845 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 6 Sep 2009 08:50:54 -0500
Subject: [PATCH] make public words for querying current rounding mode,
 denormal mode, and trap set

---
 basis/math/floats/env/env-docs.factor | 27 ++++++++++---
 basis/math/floats/env/env.factor      | 57 ++++++++++++++-------------
 2 files changed, 51 insertions(+), 33 deletions(-)

diff --git a/basis/math/floats/env/env-docs.factor b/basis/math/floats/env/env-docs.factor
index 773c5f6d87..979b816715 100644
--- a/basis/math/floats/env/env-docs.factor
+++ b/basis/math/floats/env/env-docs.factor
@@ -68,19 +68,31 @@ HELP: collect-fp-exceptions
 { $values { "quot" quotation } { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
 { $description "Clears the floating-point exception flags and then calls " { $snippet "quot" } ", returning the set of floating-point exceptions raised during its execution and placing them on the datastack on " { $snippet "quot" } "'s completion." } ;
 
-{ fp-exception fp-exception-flags set-fp-exception-flags clear-fp-exception-flags collect-fp-exceptions } related-words
+{ fp-exception-flags set-fp-exception-flags clear-fp-exception-flags collect-fp-exceptions } related-words
+
+HELP: denormal-mode
+{ $values { "mode" fp-denormal-mode } }
+{ $description "Returns the current floating-point denormal mode." } ;
 
 HELP: with-denormal-mode
 { $values { "mode" fp-denormal-mode } { "quot" quotation } }
 { $description "Sets the floating-point denormal mode to " { $snippet "mode" } " for the dynamic extent of " { $snippet "quot" } ", restoring the denormal mode to its original value on " { $snippet "quot" } "'s completion." } ;
 
-{ fp-denormal-mode with-denormal-mode } related-words
+{ denormal-mode with-denormal-mode } related-words
+
+HELP: rounding-mode
+{ $values { "mode" fp-rounding-mode } }
+{ $description "Returns the current floating-point rounding mode." } ;
 
 HELP: with-rounding-mode
 { $values { "mode" fp-rounding-mode } { "quot" quotation } }
 { $description "Sets the floating-point rounding mode to " { $snippet "mode" } " for the dynamic extent of " { $snippet "quot" } ", restoring the rounding mode to its original value on " { $snippet "quot" } "'s completion." } ;
 
-{ fp-rounding-mode with-rounding-mode } related-words
+{ rounding-mode with-rounding-mode } related-words
+
+HELP: fp-traps
+{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $description "Returns the set of floating point exceptions with processor traps currently set." } ;
 
 HELP: with-fp-traps
 { $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } { "quot" quotation } }
@@ -90,7 +102,7 @@ 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." } ;
 
-{ with-fp-traps without-fp-traps } related-words
+{ fp-traps with-fp-traps without-fp-traps } related-words
 
 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."
@@ -100,11 +112,14 @@ $nl
 { $subsection set-fp-exception-flags }
 { $subsection clear-fp-exception-flags }
 { $subsection collect-fp-exceptions }
-"Controlling processor traps for floating-point exceptions:"
+"Querying and controlling processor traps for floating-point exceptions:"
+{ $subsection fp-traps }
 { $subsection with-fp-traps }
 { $subsection without-fp-traps }
-"Controlling the rounding mode and treatment of denormals:"
+"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 x86, the above words only modify the SSE unit's state (in particular, the MXCSR register); the x87 unit is ignored by Factor and unaffected by " { $snippet "math.float.env" } ". On PowerPC, the above words only modify the scalar FPU's state (in FPSCR); the AltiVec state is currently not exposed." } ;
diff --git a/basis/math/floats/env/env.factor b/basis/math/floats/env/env.factor
index 9dfa8bf1e4..c1639db8c4 100644
--- a/basis/math/floats/env/env.factor
+++ b/basis/math/floats/env/env.factor
@@ -47,9 +47,9 @@ FUNCTION: void set_fp_control_register ( uint reg ) ;
 
 HOOK: exception-flag-bits    cpu ( -- bits )
 HOOK: exception-flag>bit     cpu ( -- assoc )
-HOOK: exception-enable-bits  cpu ( -- bits )
-HOOK: exception-enable>bit   cpu ( -- assoc )
-HOOK: >exception-enable      cpu ( mask -- enable )
+HOOK: fp-traps-bits  cpu ( -- bits )
+HOOK: fp-traps>bit   cpu ( -- assoc )
+HOOK: >fp-traps      cpu ( mask -- enable )
 HOOK: rounding-mode-bits     cpu ( -- bits )
 HOOK: rounding-mode>bit      cpu ( -- assoc )
 HOOK: denormal-mode-bits     cpu ( -- bits )
@@ -64,8 +64,8 @@ M: x86 exception-flag>bit
         { +fp-inexact+           HEX: 20 }
     } ;
 
-M: x86 exception-enable-bits HEX: 1f80 ;
-M: x86 exception-enable>bit
+M: x86 fp-traps-bits HEX: 1f80 ;
+M: x86 fp-traps>bit
     H{
         { +fp-invalid-operation+ HEX: 0080 }
         { +fp-overflow+          HEX: 0400 }
@@ -74,7 +74,7 @@ M: x86 exception-enable>bit
         { +fp-inexact+           HEX: 1000 }
     } ;
 
-M: x86 >exception-enable bitnot ;
+M: x86 >fp-traps bitnot ;
 
 M: x86 rounding-mode-bits HEX: 6000 ;
 M: x86 rounding-mode>bit
@@ -97,8 +97,8 @@ M: ppc exception-flag>bit
         { +fp-inexact+           HEX: 0200,0000 }
     } ;
 
-M: ppc exception-enable-bits HEX: f80 ;
-M: ppc exception-enable>bit
+M: ppc fp-traps-bits HEX: f80 ;
+M: ppc fp-traps>bit
     H{
         { +fp-invalid-operation+ HEX: 8000 }
         { +fp-overflow+          HEX: 4000 }
@@ -107,7 +107,7 @@ M: ppc exception-enable>bit
         { +fp-inexact+           HEX: 0800 }
     } ;
 
-M: ppc >exception-enable ;
+M: ppc >fp-traps ;
 
 M: ppc rounding-mode-bits HEX: 3 ;
 M: ppc rounding-mode>bit
@@ -135,10 +135,10 @@ M: ppc denormal-mode-bits HEX: 4 ;
 : (set-exception-flags) ( register exceptions -- register' )
     exception-flag>bit >mask exception-flag-bits remask ; inline
 
-: (get-exception-enable) ( register -- exceptions )
-    >exception-enable exception-enable>bit mask> ; inline
-: (set-exception-enable) ( register exceptions -- register' )
-    exception-enable>bit >mask >exception-enable exception-enable-bits remask ; inline
+: (get-fp-traps) ( register -- exceptions )
+    >fp-traps fp-traps>bit mask> ; inline
+: (set-fp-traps) ( register exceptions -- register' )
+    fp-traps>bit >mask >fp-traps fp-traps-bits remask ; inline
 
 : (get-rounding-mode) ( register -- mode )
     rounding-mode-bits mask rounding-mode>bit value-at ; inline
@@ -156,26 +156,23 @@ M: ppc denormal-mode-bits HEX: 4 ;
 : change-control-register ( quot -- )
     get_fp_control_register swap call set_fp_control_register ; inline
 
-: get-exception-enable ( -- exceptions ) get_fp_control_register (get-exception-enable) ;
-: set-exception-enable ( exceptions -- ) [ (set-exception-enable) ] curry change-control-register ;
-: get-rounding-mode ( -- rounding-mode ) get_fp_control_register (get-rounding-mode) ;
+: set-fp-traps ( exceptions -- ) [ (set-fp-traps) ] curry change-control-register ;
 : set-rounding-mode ( exceptions -- ) [ (set-rounding-mode) ] curry change-control-register ;
-: get-denormal-mode ( -- ? ) get_fp_control_register (get-denormal-mode) ;
-: set-denormal-mode ( ? -- ) [ (set-denormal-mode) ] curry change-control-register ;
+: set-denormal-mode ( mode -- ) [ (set-denormal-mode) ] curry change-control-register ;
 
-: get-fp-env ( -- exception-flags exception-enable rounding-mode denormals? )
+: get-fp-env ( -- exception-flags fp-traps rounding-mode denormals? )
     get_fp_control_register {
         [ (get-exception-flags) ]
-        [ (get-exception-enable) ]
+        [ (get-fp-traps) ]
         [ (get-rounding-mode) ]
         [ (get-denormal-mode) ]
     } cleave ;
 
-: set-fp-env ( exception-flags exception-enable rounding-mode denormal-mode -- )
+: set-fp-env ( exception-flags fp-traps rounding-mode denormal-mode -- )
     [
         {
             [ [ (set-exception-flags) ] when* ]
-            [ [ (set-exception-enable) ] when* ]
+            [ [ (set-fp-traps) ] when* ]
             [ [ (set-rounding-mode) ] when* ]
             [ [ (set-denormal-mode) ] when* ]
         } spread
@@ -190,20 +187,26 @@ PRIVATE>
 : collect-fp-exceptions ( quot -- exceptions )
     clear-fp-exception-flags call fp-exception-flags ; inline
 
+: denormal-mode ( -- mode ) get_fp_control_register (get-denormal-mode) ;
+
 :: with-denormal-mode ( mode quot -- )
-    get-denormal-mode :> orig
+    denormal-mode :> orig
     mode set-denormal-mode
     quot [ orig set-denormal-mode ] [ ] cleanup ; inline
 
+: rounding-mode ( -- mode ) get_fp_control_register (get-rounding-mode) ;
+
 :: with-rounding-mode ( mode quot -- )
-    get-rounding-mode :> orig
+    rounding-mode :> orig
     mode set-rounding-mode
     quot [ orig set-rounding-mode ] [ ] cleanup ; inline
 
+: fp-traps ( -- exceptions ) get_fp_control_register (get-fp-traps) ;
+
 :: with-fp-traps ( exceptions quot -- )
-    get-exception-enable :> orig
-    exceptions set-exception-enable
-    quot [ orig set-exception-enable ] [ ] cleanup ; inline
+    fp-traps :> orig
+    exceptions set-fp-traps
+    quot [ orig set-fp-traps ] [ ] cleanup ; inline
 
 : without-fp-traps ( quot -- )
     { } swap with-fp-traps ; inline