From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 4 Nov 2017 05:06:05 +0000 (-0700)
Subject: Fix test failures caused when no support for non-standard fp traps.
X-Git-Tag: mit-scheme-pucked-9.2.12~14^2~7
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=34ecd0262f87c7ccb4ee0e4db86cdc77e4d1d4e3;p=mit-scheme.git

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 2afb54be6..2cc3b69ad 100644
--- 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 fc9c98eb8..1c23fa385 100644
--- 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 2717decbb..33edb59a1 100644
--- 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 e6189b6db..4557444be 100644
--- 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 c063cf3d6..32fe2b497 100644
--- 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)))))