From d33f594b36db180618392b50338cd06716d41c1d Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Thu, 29 Nov 2018 03:05:53 +0000 Subject: [PATCH] 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. --- src/relnotes/flonum | 27 ++++++--- src/runtime/primitive-arithmetic.scm | 83 +++++++++++++++++++++++++++- src/runtime/runtime.pkg | 4 ++ tests/runtime/test-flonum.scm | 47 ++++++++++++++++ 4 files changed, 151 insertions(+), 10 deletions(-) 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)))))))) -- 2.25.1