From: Taylor R Campbell <campbell@mumble.net>
Date: Sat, 1 Dec 2018 22:41:56 +0000 (+0000)
Subject: Teach Scheme about the floating-point subnormal-operand exception.
X-Git-Tag: mit-scheme-pucked-10.1.7~3^2~71
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=dc223395fd0eba296e1d014f0817bc0a9e10238e;p=mit-scheme.git

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

diff --git a/src/microcode/floenv.c b/src/microcode/floenv.c
index 4a8543314..8d29ad106 100644
--- 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
 
 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 6c7bb0feb..f3985562d 100644
--- 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 e0cdfa61b..934c6fe6d 100644
--- 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 9fc9cc0f8..68e179dc9 100644
--- 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))))))
 
 (define (for-each-trappable-exception receiver)
   (for-each-exception