From 34ecd0262f87c7ccb4ee0e4db86cdc77e4d1d4e3 Mon Sep 17 00:00:00 2001 From: Chris Hanson <org/chris-hanson/cph> Date: Fri, 3 Nov 2017 22:06:05 -0700 Subject: [PATCH] Fix test failures caused when no support for non-standard fp traps. This is the case on macOS. --- src/microcode/floenv.c | 20 +++++ src/runtime/floenv.scm | 2 + src/runtime/runtime.pkg | 2 + tests/runtime/test-arith.scm | 148 +++++++++++++++++----------------- tests/runtime/test-floenv.scm | 43 +++++----- 5 files changed, 123 insertions(+), 92 deletions(-) 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))))) -- 2.25.1