From: Taylor R Campbell <campbell@mumble.net>
Date: Wed, 28 Nov 2018 19:24:36 +0000 (+0000)
Subject: New NaN-related and min/max flonum procedures and fixes.
X-Git-Tag: mit-scheme-pucked-10.1.7~3^2~135
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d48b47109db26932582042d057d694c7393955fe;p=mit-scheme.git

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 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))))))))