Add tests for floating-point exceptions.

diff --git a/tests/check.scm b/tests/check.scm
index bdcef40737eaa1a7bce4a34d31285dc564bdd7e6..d9f78abd8876b11118d05953d82c26bf27729b20 100644 (file)
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -46,6 +46,7 @@ USA.
     "microcode/test-flonum-casts"
     "microcode/test-flonum-casts.scm"
     "microcode/test-flonum-casts.com"
+    "microcode/test-flonum-except"
     "microcode/test-keccak"
     "microcode/test-lookup"
     "runtime/test-arith"

diff --git a/tests/microcode/test-flonum-except.scm b/tests/microcode/test-flonum-except.scm
new file mode 100644 (file)
index 0000000..3b50532
--- /dev/null
+++ b/tests/microcode/test-flonum-except.scm
@@ -0,0 +1,249 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Tests of flonum exceptions
+
+(declare (usual-integrations))
+\f
+(define (no-op x)
+  x)
+
+(define (flo:subnormal? x)
+  (flo:< (flo:abs x) (flo:ldexp 1. flo:normal-exponent-min-base-2)))
+
+(define assert-flonum
+  (predicate-assertion flo:flonum? "object"))
+
+(define (assert-nan object)
+  (assert-flonum object)
+  ((predicate-assertion flo:nan? "NaN") object))
+
+(define (assert-inf object)
+  (assert-flonum object)
+  ((predicate-assertion flo:infinite? "infinity") object))
+
+(define (assert-subnormal object)
+  (assert-flonum object)
+  ((predicate-assertion flo:subnormal? "subnormal") object))
+
+(define assert-nonzero
+  (predicate-assertion (lambda (x) (not (zero? x))) "nonzero"))
+
+(define assert-nothing
+  (predicate-assertion (lambda (x) x #t) "nothing"))
+
+(define (with-failure-expected xfail? procedure)
+  (case xfail?
+    ((xfail) (expect-failure procedure))
+    ((xerror) (assert-error procedure))
+    (else (procedure))))
+
+(define (define-exception-flag-test name excname exception assertion procedure
+         #!optional xfail?)
+  (define-test (symbol name '/ excname '/ 'flag)
+    (lambda ()
+      (flo:preserving-environment
+       (lambda ()
+        (flo:clear-exceptions! (flo:supported-exceptions))
+        (flo:with-exceptions-untrapped (flo:supported-exceptions)
+          (lambda ()
+            (with-failure-expected xfail?
+              (lambda ()
+                (assertion (procedure))
+                (assert-nonzero (flo:test-exceptions exception)))))))))))
+
+(define (define-exception-trap-test name excname exception condition-type
+         procedure #!optional xfail?)
+  (define-test (symbol name '/ excname '/ 'trap)
+    (lambda ()
+      (flo:preserving-environment
+       (lambda ()
+        (with-failure-expected xfail?
+          (lambda ()
+            (assert-error
+             (lambda ()
+               (flo:with-exceptions-untrapped (flo:supported-exceptions)
+                 (lambda ()
+                   (flo:with-exceptions-trapped exception procedure))))
+             (list condition-type)))))))))
+
+(define (define-invop-flag-test name procedure #!optional xfail?)
+  (define-exception-flag-test name 'invalid-operation
+    (flo:exception:invalid-operation)
+    assert-nan procedure xfail?))
+
+(define (define-invop-trap-test name procedure #!optional xfail?)
+  (define-exception-trap-test name 'invalid-operation
+    (flo:exception:invalid-operation)
+    condition-type:invalid-floating-point-operation
+    procedure xfail?))
+
+(define (define-divbyzero-flag-test name procedure #!optional xfail?)
+  (define-exception-flag-test name 'divide-by-zero
+    (flo:exception:divide-by-zero)
+    assert-inf procedure xfail?))
+
+(define (define-divbyzero-trap-test name procedure #!optional xfail?)
+  (define-exception-trap-test name 'divide-by-zero
+    (flo:exception:divide-by-zero)
+    condition-type:floating-point-divide-by-zero
+    procedure xfail?))
+
+(define (define-overflow-flag-test name procedure #!optional xfail?)
+  (define-exception-flag-test name 'overflow
+    (flo:exception:overflow)
+    assert-inf procedure xfail?))
+
+(define (define-overflow-trap-test name procedure #!optional xfail?)
+  (define-exception-trap-test name 'overflow
+    (flo:exception:overflow)
+    condition-type:floating-point-overflow
+    procedure xfail?))
+
+(define (define-underflow-flag-test name procedure #!optional xfail?)
+  (define-exception-flag-test name 'underflow
+    (flo:exception:underflow)
+    assert-subnormal procedure xfail?))
+
+(define (define-underflow-trap-test name procedure #!optional xfail?)
+  (define-exception-trap-test name 'underflow
+    (flo:exception:underflow)
+    condition-type:floating-point-underflow
+    procedure xfail?))
+
+(define (define-inexact-flag-test name procedure #!optional xfail?)
+  (define-exception-flag-test name 'inexact-result
+    (flo:exception:inexact-result)
+    assert-nothing procedure xfail?))
+
+(define (applicator procedure . arguments)
+  (lambda ()
+    (apply (no-op procedure)
+          (no-op arguments))))
+
+;;; IEEE 754, Sec. 7.2
+
+(define-invop-flag-test 'flonum-multiply ;(b)
+  (applicator flo:* 0. (flo:+inf.0)))
+(define-invop-flag-test 'flonum-multiply ;(b)
+  (applicator flo:* (flo:+inf.0) 0.))
+(define-invop-trap-test 'flonum-multiply ;(b)
+  (applicator flo:* 0. (flo:+inf.0)))
+(define-invop-trap-test 'flonum-multiply ;(b)
+  (applicator flo:* (flo:+inf.0) 0.))
+;; XXX fma (c)
+(define-invop-flag-test 'flonum-add+-inf       ;(d)
+  (applicator flo:+ (flo:+inf.0) (flo:-inf.0)))
+(define-invop-flag-test 'flonum-add-+inf       ;(d)
+  (applicator flo:+ (flo:-inf.0) (flo:+inf.0)))
+(define-invop-trap-test 'flonum-add+-inf       ;(d)
+  (applicator flo:+ (flo:+inf.0) (flo:-inf.0)))
+(define-invop-trap-test 'flonum-add-+inf       ;(d)
+  (applicator flo:+ (flo:-inf.0) (flo:+inf.0)))
+(define-invop-flag-test 'flonum-sub++inf       ;(d)
+  (applicator flo:- (flo:+inf.0) (flo:+inf.0)))
+(define-invop-flag-test 'flonum-sub--inf       ;(d)
+  (applicator flo:- (flo:-inf.0) (flo:-inf.0)))
+(define-invop-trap-test 'flonum-sub++inf       ;(d)
+  (applicator flo:- (flo:+inf.0) (flo:+inf.0)))
+(define-invop-trap-test 'flonum-sub--inf       ;(d)
+  (applicator flo:- (flo:-inf.0) (flo:-inf.0)))
+(define-invop-flag-test 'flonum-divide (applicator flo:/ 0. 0.)) ;(e)
+(define-invop-trap-test 'flonum-divide (applicator flo:/ 0. 0.)) ;(e)
+;; XXX remainder ;(f)
+(define-invop-flag-test 'flonum-sqrt (applicator flo:sqrt -1.))        ;(g)
+(define-invop-trap-test 'flonum-sqrt (applicator flo:sqrt -1.))        ;(g)
+
+;;; IEEE 754-2008, Sec. 7.3
+
+;; XXX Check sign of infinity.
+(define-divbyzero-flag-test 'flonum-divide (applicator flo:/ 1. 0.))
+(define-divbyzero-trap-test 'flonum-divide (applicator flo:/ 1. 0.))
+(define-divbyzero-flag-test 'flonum-log (applicator flo:log 0.))
+(define-divbyzero-trap-test 'flonum-log (applicator flo:log 0.))
+
+;;; IEEE 754-2008, Sec. 7.4
+
+;; XXX Check rounding modes.
+(define-overflow-flag-test 'flonum-multiply
+  (applicator flo:* 2. (flo:ldexp 1. flo:normal-exponent-max-base-2)))
+(define-overflow-trap-test 'flonum-multiply
+  (applicator flo:* 2. (flo:ldexp 1. flo:normal-exponent-max-base-2)))
+
+;;; IEEE 754-2008, Sec. 7.5
+
+(define-underflow-flag-test 'flonum-multiply
+  (applicator flo:* .50000001 (flo:ldexp 1. flo:normal-exponent-min-base-2)))
+(define-underflow-trap-test 'flonum-multiply
+  (applicator flo:* .50000001 (flo:ldexp 1. flo:normal-exponent-min-base-2)))
+
+;;; IEEE 754-2008, Sec. 7.6
+
+(define-inexact-flag-test 'flonum-multiply
+  (applicator flo:* .50000001 (flo:ldexp 1. flo:normal-exponent-min-base-2)))
+
+;;; Miscellaneous inexact results
+
+(define-inexact-flag-test 'flonum-add-1+ulp1/2
+  (applicator flo:+ 1. (/ flo:ulp-of-one 2)))
+(define-inexact-flag-test 'flonum-exp (applicator flo:exp -800.))
+
+;;; IEEE 754-2008, Sec. 9.2, Table 9.1
+
+(define-overflow-flag-test 'flonum-exp (applicator flo:exp 800.))
+(define-overflow-trap-test 'flonum-exp (applicator flo:exp 800.))
+(define-underflow-flag-test 'flonum-exp (applicator flo:exp -800.))
+(define-underflow-trap-test 'flonum-exp (applicator flo:exp -800.))
+;; XXX expm1, exp2, exp2m1, exp10, exp10m1
+
+;; divide by zero covered above
+(define-invop-flag-test 'flonum-log (applicator flo:log -1.))
+(define-invop-trap-test 'flonum-log (applicator flo:log -1.))
+;; XXX log1p, log21p, log101p
+
+;; XXX hypot, rsqrt, compound, rootn, pown, pow, powr
+
+(define-invop-flag-test 'flonum-sin (applicator flo:sin (flo:+inf.0)))
+(define-invop-trap-test 'flonum-sin (applicator flo:sin (flo:+inf.0)))
+;; XXX Not clear how to make tan underflow reliably.
+(define-invop-flag-test 'flonum-cos (applicator flo:cos (flo:+inf.0)))
+(define-invop-trap-test 'flonum-cos (applicator flo:cos (flo:+inf.0)))
+(define-invop-flag-test 'flonum-tan (applicator flo:tan (flo:+inf.0)))
+(define-invop-trap-test 'flonum-tan (applicator flo:tan (flo:+inf.0)))
+;; XXX Not clear how to make tan underflow reliably.
+
+;; XXX sinpi, cospi
+
+;; XXX atanpi, atan2pi
+
+(define-invop-flag-test 'flonum-asin (applicator flo:asin 2.) 'xerror)
+(define-invop-trap-test 'flonum-asin (applicator flo:asin 2.) 'xerror)
+;; XXX Not clear how to make asin underflow reliably.
+(define-invop-flag-test 'flonum-acos (applicator flo:acos 2.) 'xerror)
+(define-invop-trap-test 'flonum-acos (applicator flo:acos 2.) 'xerror)
+;; XXX Not clear how to make atan underflow reliably.
+
+;; XXX sinh, cosh, tanh, asinh, acosh, atanh