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.

diff --git a/src/runtime/primitive-arithmetic.scm b/src/runtime/primitive-arithmetic.scm
index 42eff46dce3501f40a3d5a63504c756aee61175c..f0527d1d27c1f38ebc05b28b1968182eeb6393c5 100644 (file)
--- 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))))
 \f
 ;;;; Exact integers
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 052695e9f72a5feb56bccf382008fc1a1c2556bf..d8d735f3679873107f1b2a2373e52ccc07cceae2 100644 (file)
--- 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 888287cb6dc485819cc0e1e0b7f4dd25e3f910d3..92352595f68759f7b336b492c273273e62bb20ba 100644 (file)
--- 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 953cfcb68f30f7a0d6fce1f4bfd3d47a82f34d90..3ff6e1f5ccb0b7883ee6c2ab2aee530ac729d45f 100644 (file)
--- 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))))))))