From: Taylor R Campbell Date: Thu, 8 Nov 2018 07:40:13 +0000 (+0000) Subject: Add tests for floating-point exceptions. X-Git-Tag: mit-scheme-pucked-10.1.2~16^2~116^2~16 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=82357de714aa03a17c5da49309d13215843b5961;p=mit-scheme.git Add tests for floating-point exceptions. --- diff --git a/tests/check.scm b/tests/check.scm index bdcef4073..d9f78abd8 100644 --- 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 index 000000000..3b50532e2 --- /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)) + +(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