Teach Scheme about the floating-point subnormal-operand exception.

diff --git a/src/microcode/floenv.c b/src/microcode/floenv.c
index 4a85433146e628f69b2274794791fbb07401e3c5..8d29ad106491af33ccbe83e3deb357cb7903bdde 100644 (file)
--- a/src/microcode/floenv.c
+++ b/src/microcode/floenv.c
@@ -392,6 +392,15 @@ DEFINE_PRIMITIVE ("FLOAT-INEXACT-RESULT-EXCEPTION", Prim_float_inexact_result_ex
 #else
     UNIMPLEMENTED_FLOAT_EXCEPTIONS_PRIMITIVE ()
 #endif
+
+/* The subnormal operand exception is nonstandard but appears on x86.  */
+
+DEFINE_PRIMITIVE ("FLOAT-SUBNORMAL-OPERAND-EXCEPTION", Prim_float_subnormal_operand_exception, 0, 0, 0)
+#ifdef FE_DENORMAL
+    FLOAT_EXCEPTIONS_PRIMITIVE (FE_DENORMAL)
+#else
+    UNIMPLEMENTED_FLOAT_EXCEPTIONS_PRIMITIVE ()
+#endif
 \f
 DEFINE_PRIMITIVE ("FLOAT-EXCEPTIONS", Prim_float_exceptions, 0, 0, 0)
     FLOAT_EXCEPTIONS_PRIMITIVE (FE_ALL_EXCEPT)

diff --git a/src/runtime/floenv.scm b/src/runtime/floenv.scm
index 6c7bb0febe500da26bd51ca30ccd3b3f68684f11..f3985562db0c0e1db2383194e3aedfc11af01d4c 100644 (file)
--- a/src/runtime/floenv.scm
+++ b/src/runtime/floenv.scm
@@ -239,6 +239,7 @@ USA.
   (flo:exception:underflow float-underflow-exception 0)
   (flo:exception:overflow float-overflow-exception 0)
   (flo:exception:inexact-result float-inexact-result-exception 0)
+  (flo:exception:subnormal-operand float-subnormal-operand-exception 0)
   (flo:test-exceptions test-float-exceptions 1)
   (flo:save-exception-flags save-float-exception-flags 1)
   (flo:test-exception-flags test-float-exception-flags 2)
@@ -301,7 +302,8 @@ USA.
        (n 'invalid-operation (flo:exception:invalid-operation)
           (n 'overflow (flo:exception:overflow)
              (n 'underflow (flo:exception:underflow)
-                '()))))))
+                (n 'subnormal-operand (flo:exception:subnormal-operand)
+                   '())))))))
 
 (define (flo:names->exceptions names)
   (define (name->exceptions name)
@@ -311,6 +313,7 @@ USA.
       ((invalid-operation) (flo:exception:invalid-operation))
       ((overflow) (flo:exception:overflow))
       ((underflow) (flo:exception:underflow))
+      ((subnormal-operand) (flo:exception:subnormal-operand))
       (else (error:bad-range-argument names 'flo:names->exceptions))))
   (guarantee list-of-unique-symbols? names 'flo:names->exceptions)
   (reduce fix:or 0 (map name->exceptions names)))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e0cdfa61bb270010b00580b0db9893af7a2f1909..934c6fe6d26c494aec7554897f9421db08fbdd09 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -425,6 +425,7 @@ USA.
          flo:exception:inexact-result
          flo:exception:invalid-operation
          flo:exception:overflow
+         flo:exception:subnormal-operand
          flo:exception:underflow
          flo:exceptions->names
          flo:have-environment?

diff --git a/tests/runtime/test-floenv.scm b/tests/runtime/test-floenv.scm
index 9fc9cc0f8b7420003601f2421d6c4bef5f2cc340..68e179dc9917642b55e7c30e5718f2df59729529 100644 (file)
--- a/tests/runtime/test-floenv.scm
+++ b/tests/runtime/test-floenv.scm
@@ -292,6 +292,21 @@ USA.
       ;; (Note that if underflow is trapped, then the machine traps
       ;; whether or not the result is exact.  Go figure.)
       (flo:* (no-op .5000001) (flo:shift (no-op 1.) -1022)))))
+
+(if (not (zero? (flo:exception:subnormal-operand)))
+    (begin
+      (define-fpe-descriptor 'SUBNORMAL-OPERAND #t
+        flo:exception:subnormal-operand
+        ;; XXX Should have its own condition type, but this requires OS
+        ;; support for the siginfo code.
+        condition-type:inexact-floating-point-result)
+      (define-fpe-elicitor 'SUBNORMAL-OPERAND 'RAISE
+        (lambda ()
+          (flo:raise-exceptions! (flo:exception:subnormal-operand))))
+      (define-fpe-elicitor 'SUBNORMAL-OPERAND 'USE-A-SUBNORMAL-OPERAND
+        (let ((x (no-op flo:smallest-positive-subnormal)))
+          (lambda ()
+            (flo:+ x flo:smallest-positive-subnormal))))))
 \f
 (define (for-each-trappable-exception receiver)
   (for-each-exception