Fix test failures caused when no support for non-standard fp traps.

This is the case on macOS.

diff --git a/src/microcode/floenv.c b/src/microcode/floenv.c
index 2afb54be6af49486cc03f1a0077e01fa3c4092ae..2cc3b69ad083f7b032102b171c26a1113fe2bf73 100644 (file)
--- a/src/microcode/floenv.c
+++ b/src/microcode/floenv.c
@@ -540,3 +540,23 @@ DEFINE_PRIMITIVE ("TRAP-FLOAT-EXCEPTIONS", Prim_trap_float_exceptions, 1, 1, 0)
   PRIMITIVE_RETURN (UNSPECIFIC);
 #endif
 }
+
+DEFINE_PRIMITIVE ("HAVE-FLOAT-ENVIRONMENT?", Prim_have_float_environment, 0, 0, 0)
+{
+  PRIMITIVE_HEADER (0);
+#ifdef HAVE_FENV_H
+  PRIMITIVE_RETURN (SHARP_T);
+#else
+  PRIMITIVE_RETURN (SHARP_F);
+#endif
+}
+
+DEFINE_PRIMITIVE ("HAVE-FLOAT-TRAP-ENABLE/DISABLE?", Prim_have_float_trap_enable_disable, 0, 0, 0)
+{
+  PRIMITIVE_HEADER (0);
+#if ((defined (HAVE_FEENABLEEXCEPT)) && (defined (HAVE_FEDISABLEEXCEPT)))
+  PRIMITIVE_RETURN (SHARP_T);
+#else
+  PRIMITIVE_RETURN (SHARP_F);
+#endif
+}

diff --git a/src/runtime/floenv.scm b/src/runtime/floenv.scm
index fc9c98eb8b9db1c37cf326c3da13983e40a482d6..1c23fa3853d3deb33caf98c24c76f427c71bb65e 100644 (file)
--- a/src/runtime/floenv.scm
+++ b/src/runtime/floenv.scm
@@ -228,6 +228,8 @@ USA.
 ;;;; Floating-point exceptions and trapping
 
 (define-primitives
+  (flo:have-environment? have-float-environment? 0)
+  (flo:have-trap-enable/disable? have-float-trap-enable/disable? 0)
   (flo:supported-exceptions float-exceptions 0)
   (flo:exception:divide-by-zero float-divide-by-zero-exception 0)
   (flo:exception:invalid-operation float-invalid-operation-exception 0)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 2717decbbadda27956376209c67b5b35938de90b..33edb59a11ea77ddf556bafae10fb40a6cbb45f5 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -326,6 +326,8 @@ USA.
          flo:exception:overflow
          flo:exception:underflow
          flo:exceptions->names
+         flo:have-environment?
+         flo:have-trap-enable/disable?
          flo:ignoring-exception-traps
          flo:names->exceptions
          flo:preserving-environment

diff --git a/tests/runtime/test-arith.scm b/tests/runtime/test-arith.scm
index e6189b6db786e9f1af517a09b4177b539975943e..4557444be9f92bd81a212117f33c8a3ebb23f873 100644 (file)
--- a/tests/runtime/test-arith.scm
+++ b/tests/runtime/test-arith.scm
@@ -35,21 +35,6 @@ USA.
 (define (zero)
   (identity-procedure 0.))
 
-(define (nan)
-  (flo:with-exceptions-untrapped (flo:exception:invalid-operation)
-    (lambda ()
-      (flo:/ (zero) (zero)))))
-
-(define (inf+)
-  (flo:with-exceptions-untrapped (flo:exception:divide-by-zero)
-    (lambda ()
-      (flo:/ +1. (zero)))))
-
-(define (inf-)
-  (flo:with-exceptions-untrapped (flo:exception:divide-by-zero)
-    (lambda ()
-      (flo:/ -1. (zero)))))
-
 (define (assert-nan object)
   (assert-true (flo:flonum? object))
   (assert-false (flo:= object object)))
@@ -81,61 +66,78 @@ USA.
 
 (define-enumerated^2-test 'ZEROS-ARE-EQUAL (vector -0. 0 +0.) =)
 
-(define-enumerated^2-test* 'ORDER-WITH-INFINITIES
-  (vector (inf-) -2. -1 -0.5 0 +0.5 +1 +2. (inf+))
-  (lambda (i vi j vj)
-    (if (< i j)
-        (assert-true (< vi vj))
-        (assert-false (< vi vj)))))
-
-(let ((elements (vector (inf-) -2. -1 -0. 0 +0. +1 +2. (inf+))))
-  (define-enumerated-test '!NAN<X elements
-    (lambda (v) (assert-false (< (nan) v))))
-  (define-enumerated-test '!X<NAN elements
-    (lambda (v) (assert-false (< v (nan))))))
-
-(let ((elements (vector -2. -1 -0. 0 +0. +1 +2.)))
-
-  (define-enumerated-test 'MIN-INF-/X elements
-    (lambda (v) (assert-= (min (inf-) v) (inf-))))
-  (define-enumerated-test 'MIN-INF+/X elements
-    (lambda (v) (assert-= (min (inf+) v) v)))
-  (define-enumerated-test 'MIN-X/INF- elements
-    (lambda (v) (assert-= (min v (inf-)) (inf-))))
-  (define-enumerated-test 'MIN-X/INF+ elements
-    (lambda (v) (assert-= (min v (inf+)) v)))
-
-  (define-enumerated-test 'MAX-INF-/X elements
-    (lambda (v) (assert-= (max (inf-) v) v)))
-  (define-enumerated-test 'MAX-INF+/X elements
-    (lambda (v) (assert-= (max (inf+) v) (inf+))))
-  (define-enumerated-test 'MAX-X/INF- elements
-    (lambda (v) (assert-= (max v (inf-)) v)))
-  (define-enumerated-test 'MAX-X/INF+ elements
-    (lambda (v) (assert-= (max v (inf+)) (inf+)))))
-
-(let ((elements (vector (inf-) -2. -1 -0. 0 +0. +1 +2. (inf+))))
-  (define-enumerated-test 'MIN-NAN/X elements
-    (lambda (v) (assert-= (min (nan) v) v)))
-  (define-enumerated-test 'MIN-X/NAN elements
-    (lambda (v) (assert-= (min v (nan)) v)))
-  (define-enumerated-test 'MAX-NAN/X elements
-    (lambda (v) (assert-= (max (nan) v) v)))
-  (define-enumerated-test 'MAX-X/NAN elements
-    (lambda (v) (assert-= (max v (nan)) v))))
-
-(define-enumerated-test 'NAN*X
-  (vector (inf-) -2. -1 -0. 0 +0. +1 +2. (inf+))
-  (lambda (v) (assert-nan (* (nan) v))))
-
-(define-enumerated-test 'X*NAN
-  (vector (inf-) -2. -1 -0. 0 +0. +1 +2. (inf+))
-  (lambda (v) (assert-nan (* v (nan)))))
-
-(define-enumerated-test 'NAN/X
-  (vector (inf-) -2. -1 -0. 0 +0. +1 +2. (inf+))
-  (lambda (v) (assert-nan (/ (nan) v))))
-
-(define-enumerated-test 'X/NAN
-  (vector (inf-) -2. -1 -0. 0 +0. +1 +2. (inf+))
-  (lambda (v) (assert-nan (/ v (nan)))))
\ No newline at end of file
+(if (flo:have-trap-enable/disable?)
+    (let ()
+
+      (define (nan)
+       (flo:with-exceptions-untrapped (flo:exception:invalid-operation)
+         (lambda ()
+           (flo:/ (zero) (zero)))))
+
+      (define (inf+)
+       (flo:with-exceptions-untrapped (flo:exception:divide-by-zero)
+         (lambda ()
+           (flo:/ +1. (zero)))))
+
+      (define (inf-)
+       (flo:with-exceptions-untrapped (flo:exception:divide-by-zero)
+         (lambda ()
+           (flo:/ -1. (zero)))))
+
+      (define-enumerated^2-test* 'ORDER-WITH-INFINITIES
+       (vector (inf-) -2. -1 -0.5 0 +0.5 +1 +2. (inf+))
+       (lambda (i vi j vj)
+         (if (< i j)
+             (assert-true (< vi vj))
+             (assert-false (< vi vj)))))
+
+      (let ((elements (vector (inf-) -2. -1 -0. 0 +0. +1 +2. (inf+))))
+       (define-enumerated-test '!NAN<X elements
+         (lambda (v) (assert-false (< (nan) v))))
+       (define-enumerated-test '!X<NAN elements
+         (lambda (v) (assert-false (< v (nan))))))
+      (let ((elements (vector -2. -1 -0. 0 +0. +1 +2.)))
+
+       (define-enumerated-test 'MIN-INF-/X elements
+         (lambda (v) (assert-= (min (inf-) v) (inf-))))
+       (define-enumerated-test 'MIN-INF+/X elements
+         (lambda (v) (assert-= (min (inf+) v) v)))
+       (define-enumerated-test 'MIN-X/INF- elements
+         (lambda (v) (assert-= (min v (inf-)) (inf-))))
+       (define-enumerated-test 'MIN-X/INF+ elements
+         (lambda (v) (assert-= (min v (inf+)) v)))
+
+       (define-enumerated-test 'MAX-INF-/X elements
+         (lambda (v) (assert-= (max (inf-) v) v)))
+       (define-enumerated-test 'MAX-INF+/X elements
+         (lambda (v) (assert-= (max (inf+) v) (inf+))))
+       (define-enumerated-test 'MAX-X/INF- elements
+         (lambda (v) (assert-= (max v (inf-)) v)))
+       (define-enumerated-test 'MAX-X/INF+ elements
+         (lambda (v) (assert-= (max v (inf+)) (inf+)))))
+
+      (let ((elements (vector (inf-) -2. -1 -0. 0 +0. +1 +2. (inf+))))
+       (define-enumerated-test 'MIN-NAN/X elements
+         (lambda (v) (assert-= (min (nan) v) v)))
+       (define-enumerated-test 'MIN-X/NAN elements
+         (lambda (v) (assert-= (min v (nan)) v)))
+       (define-enumerated-test 'MAX-NAN/X elements
+         (lambda (v) (assert-= (max (nan) v) v)))
+       (define-enumerated-test 'MAX-X/NAN elements
+         (lambda (v) (assert-= (max v (nan)) v))))
+
+      (define-enumerated-test 'NAN*X
+       (vector (inf-) -2. -1 -0. 0 +0. +1 +2. (inf+))
+       (lambda (v) (assert-nan (* (nan) v))))
+
+      (define-enumerated-test 'X*NAN
+       (vector (inf-) -2. -1 -0. 0 +0. +1 +2. (inf+))
+       (lambda (v) (assert-nan (* v (nan)))))
+
+      (define-enumerated-test 'NAN/X
+       (vector (inf-) -2. -1 -0. 0 +0. +1 +2. (inf+))
+       (lambda (v) (assert-nan (/ (nan) v))))
+
+      (define-enumerated-test 'X/NAN
+       (vector (inf-) -2. -1 -0. 0 +0. +1 +2. (inf+))
+       (lambda (v) (assert-nan (/ v (nan)))))))
\ No newline at end of file

diff --git a/tests/runtime/test-floenv.scm b/tests/runtime/test-floenv.scm
index c063cf3d6978f4f40980fee1f63ca9b8b088af0b..32fe2b497e4d097cfe6c83e9a9c50f2b5c3217a5 100644 (file)
--- a/tests/runtime/test-floenv.scm
+++ b/tests/runtime/test-floenv.scm
@@ -135,7 +135,7 @@ USA.
 (define (for-each-trappable-exception receiver)
   (for-each-exception
    (lambda (name exception condition-type trappable? elicitors)
-     (if trappable?
+     (if (and trappable? (flo:have-trap-enable/disable?))
         (receiver name exception condition-type elicitors)))))
 
 (define (for-each-exception-elicitor receiver)
@@ -224,7 +224,8 @@ USA.
 (define (for-each-trappable-exception receiver)
   (for-each-exception
    (lambda (name exception condition-type trappable? elicitors)
-     (if trappable? (receiver name exception condition-type elicitors)))))
+     (if (and trappable? (flo:have-trap-enable/disable?))
+        (receiver name exception condition-type elicitors)))))
 
 (for-each-exception
  (lambda (name exception condition-type trappable? elicitors)
@@ -271,22 +272,24 @@ USA.
     (flo:trapped-exceptions)))
 
 (define (define-set-trapped-exceptions-test name to-trap)
-  (define-test (symbol 'FLO:SET-TRAPPED-EXCEPTIONS! ': name)
-    (lambda ()
-      (let ((exceptions (to-trap))
-           (trapped (flo:trapped-exceptions)))
-        (flo:preserving-environment
-         (lambda ()
-          (assert-eqv (flo:set-trapped-exceptions! exceptions) trapped)
-          (assert-eqv (flo:trapped-exceptions) exceptions)))))))
+  (if (flo:have-trap-enable/disable?)
+      (define-test (symbol 'FLO:SET-TRAPPED-EXCEPTIONS! ': name)
+       (lambda ()
+         (let ((exceptions (to-trap))
+               (trapped (flo:trapped-exceptions)))
+           (flo:preserving-environment
+            (lambda ()
+              (assert-eqv (flo:set-trapped-exceptions! exceptions) trapped)
+              (assert-eqv (flo:trapped-exceptions) exceptions))))))))
 
 (define (define-with-trapped-exceptions-test name to-trap)
-  (define-test (symbol 'FLO:WITH-TRAPPED-EXCEPTIONS ': name)
-    (lambda ()
-      (let ((exceptions (to-trap)))
-       (flo:with-trapped-exceptions exceptions
-         (lambda ()
-           (assert-eqv (flo:trapped-exceptions) exceptions)))))))
+  (if (flo:have-trap-enable/disable?)
+      (define-test (symbol 'FLO:WITH-TRAPPED-EXCEPTIONS ': name)
+       (lambda ()
+         (let ((exceptions (to-trap)))
+           (flo:with-trapped-exceptions exceptions
+             (lambda ()
+               (assert-eqv (flo:trapped-exceptions) exceptions))))))))
 
 (define-set-trapped-exceptions-test 'ALL (lambda () 0))
 (define-set-trapped-exceptions-test 'NONE flo:trappable-exceptions)
@@ -448,6 +451,8 @@ USA.
   (lambda ()
     (assert-eqv (flo:rounding-mode) (flo:default-rounding-mode))))
 
-(define-default-environment-test 'TRAPPED-EXCEPTIONS
-  (lambda ()
-    (assert-eqv (flo:trapped-exceptions) (flo:default-trapped-exceptions))))
+(if (flo:have-trap-enable/disable?)
+    (define-default-environment-test 'TRAPPED-EXCEPTIONS
+      (lambda ()
+       (assert-eqv (flo:trapped-exceptions)
+                   (flo:default-trapped-exceptions)))))