From: Taylor R Campbell <campbell@mumble.net>
Date: Thu, 29 Nov 2018 03:05:53 +0000 (+0000)
Subject: Floating-point total ordering.
X-Git-Tag: mit-scheme-pucked-10.1.7~3^2~122
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d33f594b36db180618392b50338cd06716d41c1d;p=mit-scheme.git

Floating-point total ordering.

- (flo:total< x y) is true if x < y in the total ordering on
  floating-point values defined in IEEE 754-2008 Sec. 5.10, i.e. this
  is the totalOrder function of IEEE 754-2008 Sec. 5.7.2.
- (flo:total-order x y) is -1 if x < y, 0 if x = y, +1 if x > y in the
  total ordering -- the three-way comparison version of total<.
- (flo:total-mag< x y) = (flo:total< (flo:abs x) (flo:abs y))
- (flo:total-order-mag x y)
  = (flo:total-order (flo:abs x) (flo:abs y))

While here, tweak release notes on flonum stuff.
---

diff --git a/src/relnotes/flonum b/src/relnotes/flonum
index b74dc3afc..cd953f323 100644
--- a/src/relnotes/flonum
+++ b/src/relnotes/flonum
@@ -59,23 +59,32 @@ New flonum-related definitions:
 . (flo:subnormal? x) is true if x is subnormal; false if zero, normal,
   infinite, or NaN
 - (flo:safe-zero? x) is true if x is zero; false if subnormal, normal,
-  infinite, or NaN.  flo:zero? may raise an exception; flo:safe-zero?
-  never does.
+  infinite, or NaN.  flo:zero? raises an invalid-operation exception on
+  NaN; flo:safe-zero? never does even on signalling NaN.
 - (flo:safe-negative? x) returns true if x has negative sign, false if
   x has positive sign.  Note that (flo:negative? 0.) and (flo:negative?
   -0.) both return false, while (flo:safe-negative? -0.) returns true.
-  Also, flo:negative? may raise a invalid-operation exception if an
-  input is NaN, while flo:safe-negative?  does not.
+  Also, flo:negative? raises invalid-operation exception on NaN, while
+  flo:safe-negative? never does even on signalling NaN.
 - (flo:safe< x y), (flo:safe<= x y), (flo:safe> x y), (flo:safe>= x y),
   (flo:safe= x y), (flo:safe<> x y), (flo:unordered? x y) perform
-  unordered floating-point comparisons and never raise exceptions.
+  unordered floating-point comparisons and, unlike flo:< &c., do not
+  raise invalid-operation exceptions on quiet NaNs.  (However, they do
+  raise invalid-operation exceptions on signalling NaNs.)
+- (flo:<> x y) returns true if x is less or greater than y, false if
+  equal or unordered, and raises invalid-operation exceptions on any
+  NaNs.
 - (flo:compare x y) and (flo:safe-compare x y) return a four-way
   comparison of two floating-point numbers: negative if x < y, zero if
   x = y, positive if x > y, and #f if one or both arguments is NaN.
-  flo:compare may raise an invalid-operation exception;
-  flo:safe-compare never does.
-- (flo:<> x y) returns true if x is less or greater than y, false if
-  equal or unordered.  May raise an invalid-operation exception.
+  flo:compare raises invalid-operation exceptions on any NaN;
+  flo:safe-compare raises invalid-operations exceptions only on
+  signalling NaNs.
+- (flo:total< x y) is true if x < y in the total ordering defined in
+  IEEE 754-2008 Sec. 5.10; (flo:total-order x y) is a three-way
+  comparison, -1 if x < y, 0 if x = y, +1 if x > y.
+- (flo:total-mag< x y) = (flo:total< (flo:abs x) (flo:abs y))
+- (flo:total-order-mag x y) = (flo:total-order (flo:abs x) (flo:abs y))
 - (flo:min-mag x y) and (flo:max-mag x y) return the number of lesser
   or greater magnitude, as in minNumMag and maxNumMag of IEEE 754-2008.
 - (flo:make-nan negative? quiet? payload) returns a NaN with the
diff --git a/src/runtime/primitive-arithmetic.scm b/src/runtime/primitive-arithmetic.scm
index f0527d1d2..24ac07106 100644
--- a/src/runtime/primitive-arithmetic.scm
+++ b/src/runtime/primitive-arithmetic.scm
@@ -235,6 +235,87 @@ 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:total-order x y)
+  (if (or (flo:nan? x) (flo:nan? y))
+      ;; Must handle NaNs first and carefully to avoid exception on
+      ;; signalling NaN.
+      (cond ((not (flo:nan? y))
+             (assert (flo:nan? x))
+             (if (flo:safe-negative? x) -1 +1))
+            ((not (flo:nan? x))
+             (assert (flo:nan? y))
+             (if (flo:safe-negative? y) +1 -1))
+            (else
+             (assert (flo:nan? x))
+             (assert (flo:nan? y))
+             (let ((x- (flo:safe-negative? x))
+                   (xq (flo:nan-quiet? x))
+                   (xp (flo:nan-payload x))
+                   (y- (flo:safe-negative? y))
+                   (yq (flo:nan-quiet? y))
+                   (yp (flo:nan-payload y)))
+               (cond ((not (eq? x- y-)) (if x- -1 +1))
+                     ((not (eq? xq yq)) (if x- (if xq -1 +1) (if xq +1 -1)))
+                     ((not (int:= xp yp)) (if (int:< xp yp) -1 +1))
+                     (else 0)))))
+      ;; Neither one is NaN, so no need for the safety gloves.
+      (cond ((flo:< x y) -1)
+            ((flo:> x y) +1)
+            ;; From here on, they are numerically equal.
+            ((not (flo:zero? x))
+             (assert (not (flo:zero? y)))
+             0)
+            (else
+	     ;; -0. < +0.
+             (assert (flo:zero? y))
+             (if (flo:safe-negative? x)
+                 (if (flo:safe-negative? y) 0 -1)
+                 (if (flo:safe-negative? y) +1 0))))))
+
+(define (flo:total-order-mag x y)
+  (flo:total-order (flo:abs x) (flo:abs y)))
+
+(define (flo:total< x y)
+  (if (or (flo:nan? x) (flo:nan? y))
+      ;; Must handle NaNs first and carefully to avoid exception on
+      ;; signalling NaN.
+      (cond ((not (flo:nan? y))
+	     (assert (flo:nan? x))
+	     (flo:safe-negative? x))
+	    ((not (flo:nan? x))
+	     (assert (flo:nan? y))
+	     (not (flo:safe-negative? y)))
+	    (else
+	     (assert (flo:nan? x))
+	     (assert (flo:nan? y))
+	     (let ((x- (flo:safe-negative? x))
+		   (xq (flo:nan-quiet? x))
+		   (xp (flo:nan-payload x))
+		   (y- (flo:safe-negative? y))
+		   (yq (flo:nan-quiet? y))
+		   (yp (flo:nan-payload y)))
+	       (cond ((not (eq? x- y-)) (and x- (not y-)))
+		     ((not (eq? xq yq))
+		      (if x-
+			  (and xq (not yq))
+			  (and (not xq) yq)))
+		     (else (int:< xp yp))))))
+      ;; Neither one is NaN, so no need for the safety gloves.
+      (cond ((flo:< x y) #t)
+	    ((flo:> x y) #f)
+            ;; From here on, they are numerically equal.
+	    ((not (flo:zero? x))
+	     (assert (not (flo:zero? y)))
+	     #f)
+	    (else
+	     ;; -0. < +0.
+	     (assert (flo:zero? y))
+	     (and (flo:safe-negative? x)
+		  (not (flo:safe-negative? y)))))))
+
+(define (flo:total-mag< x y)
+  (flo:total< (flo:abs x) (flo:abs y)))
+
 (define (flo:invalid-minmax x y caller)
   caller
   (cond ((not (flo:nan? x))
@@ -287,7 +368,7 @@ USA.
        (or (not (flo:zero? x))
 	   (eq? (flo:safe-negative? x)
 		(flo:safe-negative? y)))))
-
+
 ;;; Measure the distance from x to the next floating-point number of
 ;;; the same sign as x and larger in magnitude.  For +/-0, this yields
 ;;; the smallest subnormal.  For +/-inf, this yields +inf.  For NaN
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index d8d735f36..0bbd55342 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -364,6 +364,10 @@ USA.
 	  flo:subnormal?
 	  flo:tan
 	  flo:tanh
+	  flo:total-mag<
+	  flo:total-order
+	  flo:total-order-mag
+	  flo:total<
 	  flo:truncate
 	  flo:truncate->exact
 	  flo:ulp
diff --git a/tests/runtime/test-flonum.scm b/tests/runtime/test-flonum.scm
index 5777efc97..1c103bbd6 100644
--- a/tests/runtime/test-flonum.scm
+++ b/tests/runtime/test-flonum.scm
@@ -803,3 +803,50 @@ USA.
                 (assert-nan y)
                 (assert-eqv (flo:nan-quiet? x) (flo:nan-quiet? y))
                 (assert-eqv (flo:nan-payload x) (flo:nan-payload y)))))))))
+
+(let ((cases
+       (vector (flo:make-nan #t #t 0)
+               (flo:make-nan #t #t 1)
+               (flo:make-nan #t #t 2)
+               (flo:make-nan #t #t (- (expt 2 51) 1))
+               (flo:make-nan #t #f 1)
+               (flo:make-nan #t #f 2)
+               (flo:make-nan #t #f (- (expt 2 51) 1))
+               -inf.0
+               -1.
+               (- flo:smallest-positive-normal)
+               (no-traps (lambda () (- flo:smallest-positive-subnormal)))
+               -0.
+               +0.
+               flo:smallest-positive-subnormal
+               flo:smallest-positive-normal
+               +1.
+               +inf.0
+               (flo:make-nan #f #f 1)
+               (flo:make-nan #f #f 2)
+               (flo:make-nan #f #f (- (expt 2 51) 1))
+               (flo:make-nan #f #t 0)
+               (flo:make-nan #f #t 1)
+               (flo:make-nan #f #t 2)
+               (flo:make-nan #f #t (- (expt 2 51) 1)))))
+  ((lambda (f)
+     (for-each (lambda (i)
+                 (for-each (lambda (j)
+                             (let ((x (vector-ref cases i))
+                                   (y (vector-ref cases j)))
+                               (define-test (symbol 'total-order/ x '/ y)
+                                 (lambda ()
+                                   (f i j x y)))))
+                           (iota (vector-length cases))))
+               (iota (vector-length cases))))
+   (lambda (i j x y)
+     (yes-traps
+      (lambda ()
+        (if (< i j)
+            (assert-true (flo:total< x y))
+            (assert-false (flo:total< x y)))
+        (assert-eqv (flo:total-order x y)
+                    (cond ((< i j) -1) ((< j i) +1) (else 0)))
+        (assert-eqv (flo:total-mag< x y) (flo:total< (flo:abs x) (flo:abs y)))
+        (assert-eqv (flo:total-order-mag x y)
+                    (flo:total-order (flo:abs x) (flo:abs y))))))))