From d48b47109db26932582042d057d694c7393955fe Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Wed, 28 Nov 2018 19:24:36 +0000 Subject: [PATCH] New NaN-related and min/max flonum procedures and fixes. - (flo:qnan) returns a quiet NaN: arithmetic on it quietly returns another qNaN (usually the same one, unless there are multiple to choose from) without raising any exception. - (flo:snan) returns a signalling NaN: arithmetic on it returns another sNaN (usually the same) and raises an exception, which will trap if you ask. - (flo:qnan? f) = (and (flo:nan? f) (flo:nan-quiet? f)) - (flo:snan? f) = (and (flo:nan? f) (not (flo:nan-quiet? f))) - (flo:min x y) and (flo:max x y) now raise an exception only if at least one input is a signalling NaN, and traps only if you ask. These now implement minNum and maxNum of IEEE 754-2008. - (flo:min-mag x y) and (flo:max-mag x y) return whichever of the inputs has the smaller magnitude, as in minNumMag and maxNumMag in IEEE 754-2008. --- src/runtime/primitive-arithmetic.scm | 64 ++++++++++-- src/runtime/runtime.pkg | 6 ++ tests/microcode/test-flonum-except.scm | 14 +++ tests/runtime/test-flonum.scm | 131 +++++++++++++++++++++++++ 4 files changed, 207 insertions(+), 8 deletions(-) diff --git a/src/runtime/primitive-arithmetic.scm b/src/runtime/primitive-arithmetic.scm index 42eff46dc..f0527d1d2 100644 --- a/src/runtime/primitive-arithmetic.scm +++ b/src/runtime/primitive-arithmetic.scm @@ -235,17 +235,50 @@ USA. (define (flo:>= x y) (or (flo:> x y) (flo:= x y))) (define (flo:<> x y) (or (flo:< x y) (flo:> x y))) +(define (flo:invalid-minmax x y caller) + caller + (cond ((not (flo:nan? x)) + (assert (flo:nan? y)) + (if (not (flo:nan-quiet? y)) + (flo:raise-exceptions! (flo:exception:invalid-operation))) + x) + ((not (flo:nan? y)) + (assert (flo:nan? x)) + (if (not (flo:nan-quiet? x)) + (flo:raise-exceptions! (flo:exception:invalid-operation))) + y) + (else + (if (not (and (flo:nan-quiet? x) (flo:nan-quiet? y))) + (flo:raise-exceptions! (flo:exception:invalid-operation))) + x))) + (define (flo:min x y) - (cond ((flo:< x y) x) - ((flo:> x y) y) - ((flo:= x y) x) - (else (error:bad-range-argument (if (flo:finite? x) x y) 'flo:min)))) + (cond ((flo:safe< x y) x) + ((flo:safe> x y) y) + ((flo:safe= x y) x) ;arbitrary + (else (flo:invalid-minmax x y 'flo:min)))) (define (flo:max x y) - (cond ((flo:< x y) y) - ((flo:> x y) x) - ((flo:= x y) y) - (else (error:bad-range-argument (if (flo:finite? x) x y) 'flo:max)))) + (cond ((flo:safe< x y) y) + ((flo:safe> x y) x) + ((flo:safe= x y) y) ;arbitrary + (else (flo:invalid-minmax x y 'flo:max)))) + +(define (flo:min-mag x y) + (let ((xm (flo:abs x)) + (ym (flo:abs y))) + (cond ((flo:safe< xm ym) x) + ((flo:safe> xm ym) y) + ((flo:safe= xm ym) (flo:min x y)) + (else (flo:invalid-minmax x y 'flo:min-mag))))) + +(define (flo:max-mag x y) + (let ((xm (flo:abs x)) + (ym (flo:abs y))) + (cond ((flo:safe< xm ym) y) + ((flo:safe> xm ym) x) + ((flo:safe= xm ym) (flo:max x y)) + (else (flo:invalid-minmax x y 'flo:max-mag))))) (define (flo:eqv? x y) (and (not (flo:nan? x)) @@ -284,6 +317,21 @@ USA. ((flo:zero? x) 'zero) ((flo:normal? x) 'normal) (else 'subnormal))) + +(define (flo:qnan #!optional payload) + (flo:make-nan #f #t (if (default-object? payload) 0 payload))) + +(define (flo:qnan? nan) + (and (flo:nan? nan) + (flo:nan-quiet? nan))) + +(define (flo:snan #!optional payload) + ;; Signalling NaN payload can't be zero -- that's an infinity. + (flo:make-nan #f #f (if (default-object? payload) 1 payload))) + +(define (flo:snan? nan) + (and (flo:nan? nan) + (not (flo:nan-quiet? nan)))) ;;;; Exact integers diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 052695e9f..d8d735f36 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -332,7 +332,9 @@ USA. flo:log1p flo:make-nan flo:max + flo:max-mag flo:min + flo:min-mag flo:modulo flo:nan-payload flo:nan-quiet? @@ -342,6 +344,8 @@ USA. flo:nextafter flo:normal? flo:positive? + flo:qnan + flo:qnan? flo:round flo:round->exact flo:safe-negative? @@ -354,6 +358,8 @@ USA. flo:safe>= flo:sin flo:sinh + flo:snan + flo:snan? flo:sqrt flo:subnormal? flo:tan diff --git a/tests/microcode/test-flonum-except.scm b/tests/microcode/test-flonum-except.scm index 888287cb6..92352595f 100644 --- a/tests/microcode/test-flonum-except.scm +++ b/tests/microcode/test-flonum-except.scm @@ -158,6 +158,20 @@ USA. (apply (no-op procedure) (no-op arguments)))) +;;; IEEE 754, Sec. 5.3.1 (see also Sec. 6.2) + +(for-each + (lambda (x) + (define-invop-trap-test 'min (applicator flo:min x (flo:snan))) + (define-invop-trap-test 'min (applicator flo:min (flo:snan) x)) + (define-invop-trap-test 'min-mag (applicator flo:min-mag x (flo:snan))) + (define-invop-trap-test 'min-mag (applicator flo:min-mag (flo:snan) x)) + (define-invop-trap-test 'max (applicator flo:max x (flo:snan))) + (define-invop-trap-test 'max (applicator flo:max (flo:snan) x)) + (define-invop-trap-test 'max-mag (applicator flo:max-mag x (flo:snan))) + (define-invop-trap-test 'max-mag (applicator flo:max-mag (flo:snan) x))) + '(-inf.0 -1. -0. +0. +1. +inf.0)) + ;;; IEEE 754, Sec. 7.2 (define-invop-flag-test 'flonum-multiply ;(b) diff --git a/tests/runtime/test-flonum.scm b/tests/runtime/test-flonum.scm index 953cfcb68..3ff6e1f5c 100644 --- a/tests/runtime/test-flonum.scm +++ b/tests/runtime/test-flonum.scm @@ -41,6 +41,26 @@ USA. (define assert-nan (predicate-assertion flo:nan? "NaN")) +(define assert-qnan + (predicate-assertion flo:qnan? "qNaN")) + +(define assert-snan + (predicate-assertion flo:snan? "sNaN")) + +(define (eqv-nan? x y) + (if (flo:nan? x) + (and (flo:nan? y) + (eqv? (flo:safe-negative? x) (flo:safe-negative? y)) + (eqv? (flo:nan-quiet? x) (flo:nan-quiet? y)) + (eqv? (flo:nan-payload x) (flo:nan-payload y))) + (and (not (flo:nan? y)) + (eqv? x y)))) + +(define-comparator eqv-nan? 'eqv-nan?) + +(define assert-eqv-nan + (simple-binary-assertion eqv-nan? #f)) + (define (with-expected-failure xfail body) (if (default-object? xfail) (body) @@ -490,6 +510,117 @@ USA. (let ((nan (flo:make-nan negative? quiet? payload))) (assert-flonum nan) (assert-nan nan) + (if quiet? + (assert-qnan nan) + (assert-snan nan)) (assert-eqv (flo:safe-negative? nan) negative?) (assert-eqv (flo:nan-quiet? nan) quiet?) (assert-eqv (flo:nan-payload nan) payload)))) + +(let ((inputs '((-inf.0) (-1.) (-0.) (+0.) (+1.) (+inf.0))) + (quiet-cases + `((-inf.0 -inf.0 -inf.0 -inf.0 -inf.0 -inf.0) + (-inf.0 -1. -inf.0 -1. -1. -inf.0) + (-inf.0 -0. -inf.0 -0. -0. -inf.0) + (-inf.0 +0. -inf.0 +0. +0. -inf.0) + (-inf.0 +1. -inf.0 +1. +1. -inf.0) + (-inf.0 +inf.0 -inf.0 +inf.0 -inf.0 +inf.0) + (-inf.0 ,(flo:qnan) -inf.0 -inf.0 -inf.0 -inf.0) + (-1. -inf.0 -inf.0 -1. -1. -inf.0) + (-1. -1. -1. -1. -1. -1.) + (-1. -0. -1. -0. -0. -1.) + (-1. +0. -1. +0. +0. -1.) + (-1. +1. -1. +1. -1. +1.) + (-1. +inf.0 -1. +inf.0 -1. +inf.0) + (-1. ,(flo:qnan) -1. -1. -1. -1.) + (-0. -inf.0 -inf.0 -0. -0. -inf.0) + (-0. -1. -1. -0. -0. -1.) + (-0. -0. -0. -0. -0. -0.) + (-0. +0. -0. +0. -0. +0.) ;arbitrary + (-0. +1. -0. +1. -0. +1.) + (-0. +inf.0 -0. +inf.0 -0. +inf.0) + (-0. ,(flo:qnan) -0. -0. -0. -0.) + (+0. -inf.0 -inf.0 +0. +0. -inf.0) + (+0. -1. -1. +0. +0. -1.) + (+0. -0. +0. -0. +0. -0.) ;arbitrary + (+0. +0. +0. +0. +0. +0.) + (+0. +1. +0. +1. +0. +1.) + (+0. +inf.0 +0. +inf.0 +0. +inf.0) + (+0. ,(flo:qnan) +0. +0. +0. +0.) + (+1. -inf.0 -inf.0 +1. +1. -inf.0) + (+1. -1. -1. +1. -1. +1.) + (+1. -0. -0. +1. -0. +1.) + (+1. +0. +0. +1. +0. +1.) + (+1. +1. +1. +1. +1. +1.) + (+1. +inf.0 +1. +inf.0 +1. +inf.0) + (+1. ,(flo:qnan) +1. +1. +1. +1.) + (+inf.0 -inf.0 -inf.0 +inf.0 -inf.0 +inf.0) + (+inf.0 -1. -1. +inf.0 -1. +inf.0) + (+inf.0 -0. -0. +inf.0 -0. +inf.0) + (+inf.0 +0. +0. +inf.0 +0. +inf.0) + (+inf.0 +1. +1. +inf.0 +1. +inf.0) + (+inf.0 +inf.0 +inf.0 +inf.0 +inf.0 +inf.0) + (+inf.0 ,(flo:qnan) +inf.0 +inf.0 +inf.0 +inf.0) + (,(flo:qnan) -inf.0 -inf.0 -inf.0 -inf.0 -inf.0) + (,(flo:qnan) -1. -1. -1. -1. -1.) + (,(flo:qnan) -0. -0. -0. -0. -0.) + (,(flo:qnan) +0. +0. +0. +0. +0.) + (,(flo:qnan) +1. +1. +1. +1. +1.) + (,(flo:qnan) +inf.0 +inf.0 +inf.0 +inf.0 +inf.0) + (,(flo:qnan) ,(flo:qnan) + ,(flo:qnan) ,(flo:qnan) + ,(flo:qnan) ,(flo:qnan))))) + (define-enumerated-test 'min quiet-cases + (lambda (x y min max min-mag max-mag) + max min-mag max-mag + (assert-eqv-nan (yes-traps (lambda () (flo:min x y))) min))) + (define-enumerated-test 'max quiet-cases + (lambda (x y min max min-mag max-mag) + min min-mag max-mag + (assert-eqv-nan (yes-traps (lambda () (flo:max x y))) max))) + (define-enumerated-test 'min-mag quiet-cases + (lambda (x y min max min-mag max-mag) + min max max-mag + (assert-eqv-nan (yes-traps (lambda () (flo:min-mag x y))) min-mag))) + (define-enumerated-test 'max-mag quiet-cases + (lambda (x y min max min-mag max-mag) + min max min-mag + (assert-eqv-nan (yes-traps (lambda () (flo:max-mag x y))) max-mag))) + (define-enumerated-test 'min-snan-left inputs + (lambda (x) + (assert-eqv (no-traps (lambda () (flo:min (flo:snan) x))) x))) + (define-enumerated-test 'max-snan-left inputs + (lambda (x) + (assert-eqv (no-traps (lambda () (flo:max (flo:snan) x))) x))) + (define-enumerated-test 'min-snan-right inputs + (lambda (x) + (assert-eqv (no-traps (lambda () (flo:min x (flo:snan)))) x))) + (define-enumerated-test 'max-snan-right inputs + (lambda (x) + (assert-eqv (no-traps (lambda () (flo:max x (flo:snan)))) x))) + (define-test 'min-snan-both + (lambda () + (assert-nan (no-traps (lambda () (flo:min (flo:snan) (flo:snan))))))) + (define-test 'max-snan-both + (lambda () + (assert-nan (no-traps (lambda () (flo:max (flo:snan) (flo:snan))))))) + (define-enumerated-test 'min-mag-snan-left inputs + (lambda (x) + (assert-eqv (no-traps (lambda () (flo:min-mag (flo:snan) x))) x))) + (define-enumerated-test 'max-mag-snan-left inputs + (lambda (x) + (assert-eqv (no-traps (lambda () (flo:max-mag (flo:snan) x))) x))) + (define-enumerated-test 'min-mag-snan-right inputs + (lambda (x) + (assert-eqv (no-traps (lambda () (flo:min-mag x (flo:snan)))) x))) + (define-enumerated-test 'max-mag-snan-right inputs + (lambda (x) + (assert-eqv (no-traps (lambda () (flo:max-mag x (flo:snan)))) x))) + (define-test 'min-mag-snan-both + (lambda () + (assert-nan + (no-traps (lambda () (flo:min-mag (flo:snan) (flo:snan))))))) + (define-test 'max-mag-snan-both + (lambda () + (assert-nan + (no-traps (lambda () (flo:max-mag (flo:snan) (flo:snan)))))))) -- 2.25.1