mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 05:30:21 +02:00
Code Activity

Fix min' and max' handling of NaNs, infinities, and signed zeroes

Browse source 
* libguile/numbers.c (scm_min, scm_max): Properly order the real
  infinities and NaNs, per R6RS, and also take care to handle signed
  zeroes properly.  Note that this ordering is different than that of
  `<', `>', `<=', and `>=', which return #f if any argument is a real
  NaN, and consider the real zeroes to be equal.  The relevant real
  infinity (-inf.0 for min, +inf.0 for max) beats everything, including
  NaNs, and NaNs beat everything else.  Previously these were handled
  improperly in some cases, e.g.:
  (min 1/2 +nan.0) now returns +nan.0 (previously returned 0.5),
  (max 1/2 +nan.0) now returns +nan.0 (previously returned 0.5),
  (min -inf.0 +nan.0) now returns -inf.0 (previously returned +nan.0),
  (max +inf.0 +nan.0) now returns +inf.0 (previously returned +nan.0),
  (min -0.0  0.0) now returns -0.0 (previously returned  0.0),
  (max  0.0 -0.0) now returns  0.0 (previously returned -0.0),
  (max  0   -0.0) now returns  0.0 (previously returned -0.0),
  (max -0.0  0  ) now returns  0.0 (previously returned -0.0).

* test-suite/tests/numbers.test (min, max): Add many more test cases
  relating to NaNs, infinities, and signed zeroes.  Change most existing
  test cases to use `eqv?' instead of `=', in order to check exactness.
This commit is contained in:
Mark H Weaver 2011-02-02 01:02:49 -05:00 • committed by Andy Wingo
parent 09cb3ae237
commit 2e2743113a
2 changed files with 237 additions and 74 deletions
Download patch file Download diff file Expand all files Collapse all files

93
libguile/numbers.c
View file

@ -498,6 +498,14 @@ scm_i_fraction2double (SCM z)
SCM_FRACTION_DENOMINATOR (z)));
}
static int
double_is_non_negative_zero (double x)
{
static double zero = 0.0;
return !memcmp (&x, &zero, sizeof(double));
}
SCM_PRIMITIVE_GENERIC (scm_exact_p, "exact?", 1, 0, 0,
(SCM x),
"Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
@ -5148,9 +5156,19 @@ scm_max (SCM x, SCM y)
}
else if (SCM_REALP (y))
{
double z = xx;
/* if y==NaN then ">" is false and we return NaN */
return (z > SCM_REAL_VALUE (y)) ? scm_from_double (z) : y;
double xxd = xx;
double yyd = SCM_REAL_VALUE (y);
if (xxd > yyd)
return scm_from_double (xxd);
/* If y is a NaN, then "==" is false and we return the NaN */
else if (SCM_LIKELY (!(xxd == yyd)))
return y;
/* Handle signed zeroes properly */
else if (xx == 0)
return flo0;
else
return y;
}
else if (SCM_FRACTIONP (y))
{
@ -5194,9 +5212,20 @@ scm_max (SCM x, SCM y)
{
if (SCM_I_INUMP (y))
{
double z = SCM_I_INUM (y);
/* if x==NaN then "<" is false and we return NaN */
return (SCM_REAL_VALUE (x) < z) ? scm_from_double (z) : x;
scm_t_inum yy = SCM_I_INUM (y);
double xxd = SCM_REAL_VALUE (x);
double yyd = yy;
if (yyd > xxd)
return scm_from_double (yyd);
/* If x is a NaN, then "==" is false and we return the NaN */
else if (SCM_LIKELY (!(xxd == yyd)))
return x;
/* Handle signed zeroes properly */
else if (yy == 0)
return flo0;
else
return x;
}
else if (SCM_BIGP (y))
{
@ -5205,12 +5234,25 @@ scm_max (SCM x, SCM y)
}
else if (SCM_REALP (y))
{
/* if x==NaN then our explicit check means we return NaN
if y==NaN then ">" is false and we return NaN
calling isnan is unavoidable, since it's the only way to know
which of x or y causes any compares to be false */
double xx = SCM_REAL_VALUE (x);
return (isnan (xx) || xx > SCM_REAL_VALUE (y)) ? x : y;
double yy = SCM_REAL_VALUE (y);
/* For purposes of max: +inf.0 > nan > everything else, per R6RS */
if (xx > yy)
return x;
else if (SCM_LIKELY (xx < yy))
return y;
/* If neither (xx > yy) nor (xx < yy), then
either they're equal or one is a NaN */
else if (SCM_UNLIKELY (isnan (xx)))
return (isinf (yy) == 1) ? y : x;
else if (SCM_UNLIKELY (isnan (yy)))
return (isinf (xx) == 1) ? x : y;
/* xx == yy, but handle signed zeroes properly */
else if (double_is_non_negative_zero (yy))
return y;
else
return x;
}
else if (SCM_FRACTIONP (y))
{
@ -5234,7 +5276,8 @@ scm_max (SCM x, SCM y)
else if (SCM_REALP (y))
{
double xx = scm_i_fraction2double (x);
return (xx < SCM_REAL_VALUE (y)) ? y : scm_from_double (xx);
/* if y==NaN then ">" is false, so we return the NaN y */
return (xx > SCM_REAL_VALUE (y)) ? scm_from_double (xx) : y;
}
else if (SCM_FRACTIONP (y))
{
@ -5351,12 +5394,25 @@ scm_min (SCM x, SCM y)
}
else if (SCM_REALP (y))
{
/* if x==NaN then our explicit check means we return NaN
if y==NaN then "<" is false and we return NaN
calling isnan is unavoidable, since it's the only way to know
which of x or y causes any compares to be false */
double xx = SCM_REAL_VALUE (x);
return (isnan (xx) || xx < SCM_REAL_VALUE (y)) ? x : y;
double yy = SCM_REAL_VALUE (y);
/* For purposes of min: -inf.0 < nan < everything else, per R6RS */
if (xx < yy)
return x;
else if (SCM_LIKELY (xx > yy))
return y;
/* If neither (xx < yy) nor (xx > yy), then
either they're equal or one is a NaN */
else if (SCM_UNLIKELY (isnan (xx)))
return (isinf (yy) == -1) ? y : x;
else if (SCM_UNLIKELY (isnan (yy)))
return (isinf (xx) == -1) ? x : y;
/* xx == yy, but handle signed zeroes properly */
else if (double_is_non_negative_zero (xx))
return y;
else
return x;
}
else if (SCM_FRACTIONP (y))
{
@ -5380,7 +5436,8 @@ scm_min (SCM x, SCM y)
else if (SCM_REALP (y))
{
double xx = scm_i_fraction2double (x);
return (SCM_REAL_VALUE (y) < xx) ? y : scm_from_double (xx);
/* if y==NaN then "<" is false, so we return the NaN y */
return (xx < SCM_REAL_VALUE (y)) ? scm_from_double (xx) : y;
}
else if (SCM_FRACTIONP (y))
{

218
test-suite/tests/numbers.test
View file

@ -2471,26 +2471,79 @@
(big*5 (* fixnum-max 5)))
(with-test-prefix "inum / frac"
(pass-if (= 3 (max 3 5/2)))
(pass-if (= 5/2 (max 2 5/2))))
(pass-if (eqv? 3 (max 3 5/2)))
(pass-if (eqv? 5/2 (max 2 5/2))))
(with-test-prefix "frac / inum"
(pass-if (= 3 (max 5/2 3)))
(pass-if (= 5/2 (max 5/2 2))))
(pass-if (eqv? 3 (max 5/2 3)))
(pass-if (eqv? 5/2 (max 5/2 2))))
(with-test-prefix "inum / real"
(pass-if (real-nan? (max 123 +nan.0))))
(with-test-prefix "infinities and NaNs"
;; +inf.0 beats everything else, including NaNs
(pass-if (eqv? +inf.0 (max +inf.0 123 )))
(pass-if (eqv? +inf.0 (max 123 +inf.0 )))
(pass-if (eqv? +inf.0 (max +inf.0 -123.3 )))
(pass-if (eqv? +inf.0 (max -123.3 +inf.0 )))
(pass-if (eqv? +inf.0 (max +inf.0 -7/2 )))
(pass-if (eqv? +inf.0 (max -7/2 +inf.0 )))
(pass-if (eqv? +inf.0 (max +inf.0 -1e20 )))
(pass-if (eqv? +inf.0 (max -1e20 +inf.0 )))
(pass-if (eqv? +inf.0 (max +inf.0 (- big*2))))
(pass-if (eqv? +inf.0 (max (- big*2) +inf.0 )))
(pass-if (eqv? +inf.0 (max +inf.0 +inf.0 )))
(pass-if (eqv? +inf.0 (max +inf.0 +inf.0 )))
(pass-if (eqv? +inf.0 (max +inf.0 +nan.0 )))
(pass-if (eqv? +inf.0 (max +nan.0 +inf.0 )))
(pass-if (eqv? +inf.0 (max +inf.0 +inf.0 )))
(with-test-prefix "real / inum"
(pass-if (real-nan? (max +nan.0 123))))
;; NaNs beat everything except +inf.0
(pass-if (real-nan? (max +nan.0 123 )))
(pass-if (real-nan? (max 123 +nan.0 )))
(pass-if (real-nan? (max +nan.0 123.3 )))
(pass-if (real-nan? (max 123.3 +nan.0 )))
(pass-if (real-nan? (max +nan.0 -7/2 )))
(pass-if (real-nan? (max -7/2 +nan.0 )))
(pass-if (real-nan? (max +nan.0 -1e20 )))
(pass-if (real-nan? (max -1e20 +nan.0 )))
(pass-if (real-nan? (max +nan.0 (- big*2))))
(pass-if (real-nan? (max (- big*2) +nan.0 )))
(pass-if (real-nan? (max +nan.0 -inf.0 )))
(pass-if (real-nan? (max -inf.0 +nan.0 )))
(pass-if (real-nan? (max +nan.0 +nan.0 )))
;; -inf.0 always loses, except against itself
(pass-if (eqv? -inf.0 (max -inf.0 -inf.0 )))
(pass-if (eqv? -123.0 (max -inf.0 -123 )))
(pass-if (eqv? -123.0 (max -123 -inf.0 )))
(pass-if (eqv? -123.3 (max -inf.0 -123.3 )))
(pass-if (eqv? -123.3 (max -123.3 -inf.0 )))
(pass-if (eqv? -3.5 (max -inf.0 -7/2 )))
(pass-if (eqv? -3.5 (max -7/2 -inf.0 )))
(pass-if (eqv? -1.0e20 (max -inf.0 -1e20 )))
(pass-if (eqv? -1.0e20 (max -1e20 -inf.0 )))
(pass-if (eqv? (exact->inexact (- big*2))
(max -inf.0 (- big*2))))
(pass-if (eqv? (exact->inexact (- big*2))
(max (- big*2) -inf.0 ))))
(with-test-prefix "signed zeroes"
(pass-if (eqv? 0.0 (max 0.0 0.0)))
(pass-if (eqv? 0.0 (max 0.0 -0.0)))
(pass-if (eqv? 0.0 (max -0.0 0.0)))
(pass-if (eqv? -0.0 (max -0.0 -0.0)))
(pass-if (eqv? 0.0 (max -0.0 0 )))
(pass-if (eqv? 0.0 (max 0.0 0 )))
(pass-if (eqv? 0.0 (max 0 -0.0)))
(pass-if (eqv? 0.0 (max 0 0.0)))
(pass-if (eqv? 0 (min 0 0 ))))
(with-test-prefix "big / frac"
(pass-if (= big*2 (max big*2 5/2)))
(pass-if (= 5/2 (max (- big*2) 5/2))))
(pass-if (eqv? big*2 (max big*2 5/2)))
(pass-if (eqv? 5/2 (max (- big*2) 5/2))))
(with-test-prefix "frac / big"
(pass-if (= big*2 (max 5/2 big*2)))
(pass-if (= 5/2 (max 5/2 (- big*2)))))
(pass-if (eqv? big*2 (max 5/2 big*2)))
(pass-if (eqv? 5/2 (max 5/2 (- big*2)))))
(with-test-prefix "big / real"
(pass-if (real-nan? (max big*5 +nan.0)))
@ -2507,29 +2560,29 @@
(pass-if (eqv? 1.0 (max 1.0 (- big*5)))))
(with-test-prefix "frac / frac"
(pass-if (= 2/3 (max 1/2 2/3)))
(pass-if (= 2/3 (max 2/3 1/2)))
(pass-if (= -1/2 (max -1/2 -2/3)))
(pass-if (= -1/2 (max -2/3 -1/2))))
(pass-if (eqv? 2/3 (max 1/2 2/3)))
(pass-if (eqv? 2/3 (max 2/3 1/2)))
(pass-if (eqv? -1/2 (max -1/2 -2/3)))
(pass-if (eqv? -1/2 (max -2/3 -1/2))))
(with-test-prefix "real / real"
(pass-if (real-nan? (max 123.0 +nan.0)))
(pass-if (real-nan? (max +nan.0 123.0)))
(pass-if (real-nan? (max +nan.0 +nan.0)))
(pass-if (= 456.0 (max 123.0 456.0)))
(pass-if (= 456.0 (max 456.0 123.0)))))
(pass-if (eqv? 456.0 (max 123.0 456.0)))
(pass-if (eqv? 456.0 (max 456.0 123.0)))))
;; in gmp prior to 4.2, mpz_cmp_d ended up treating Inf as 2^1024, make
;; sure we've avoided that
(for-each (lambda (b)
(pass-if (list b +inf.0)
(= +inf.0 (max b +inf.0)))
(eqv? +inf.0 (max b +inf.0)))
(pass-if (list +inf.0 b)
(= +inf.0 (max b +inf.0)))
(eqv? +inf.0 (max b +inf.0)))
(pass-if (list b -inf.0)
(= (exact->inexact b) (max b -inf.0)))
(eqv? (exact->inexact b) (max b -inf.0)))
(pass-if (list -inf.0 b)
(= (exact->inexact b) (max b -inf.0))))
(eqv? (exact->inexact b) (max b -inf.0))))
(list (1- (ash 1 1024))
(ash 1 1024)
(1+ (ash 1 1024))
@ -2579,43 +2632,96 @@
(big*5 (* fixnum-max 5)))
(pass-if (documented? min))
(pass-if (= 1 (min 7 3 1 5)))
(pass-if (= 1 (min 1 7 3 5)))
(pass-if (= 1 (min 7 3 5 1)))
(pass-if (= -7 (min 2 3 4 -2 5 -7 1 -1 4 2)))
(pass-if (= -7 (min -7 2 3 4 -2 5 1 -1 4 2)))
(pass-if (= -7 (min 2 3 4 -2 5 1 -1 4 2 -7)))
(pass-if (= big*2 (min big*3 big*5 big*2 big*4)))
(pass-if (= big*2 (min big*2 big*3 big*5 big*4)))
(pass-if (= big*2 (min big*3 big*5 big*4 big*2)))
(pass-if (eqv? 1 (min 7 3 1 5)))
(pass-if (eqv? 1 (min 1 7 3 5)))
(pass-if (eqv? 1 (min 7 3 5 1)))
(pass-if (eqv? -7 (min 2 3 4 -2 5 -7 1 -1 4 2)))
(pass-if (eqv? -7 (min -7 2 3 4 -2 5 1 -1 4 2)))
(pass-if (eqv? -7 (min 2 3 4 -2 5 1 -1 4 2 -7)))
(pass-if (eqv? big*2 (min big*3 big*5 big*2 big*4)))
(pass-if (eqv? big*2 (min big*2 big*3 big*5 big*4)))
(pass-if (eqv? big*2 (min big*3 big*5 big*4 big*2)))
(pass-if
(= (- fixnum-min 1) (min 2 4 (- fixnum-min 1) 3 (* 2 fixnum-max))))
(eqv? (- fixnum-min 1) (min 2 4 (- fixnum-min 1) 3 (* 2 fixnum-max))))
(pass-if
(= (- fixnum-min 1) (min (- fixnum-min 1) 2 4 3 (* 2 fixnum-max))))
(eqv? (- fixnum-min 1) (min (- fixnum-min 1) 2 4 3 (* 2 fixnum-max))))
(pass-if
(= (- fixnum-min 1) (min 2 4 3 (* 2 fixnum-max) (- fixnum-min 1))))
(eqv? (- fixnum-min 1) (min 2 4 3 (* 2 fixnum-max) (- fixnum-min 1))))
(with-test-prefix "inum / frac"
(pass-if (= 5/2 (min 3 5/2)))
(pass-if (= 2 (min 2 5/2))))
(pass-if (eqv? 5/2 (min 3 5/2)))
(pass-if (eqv? 2 (min 2 5/2))))
(with-test-prefix "frac / inum"
(pass-if (= 5/2 (min 5/2 3)))
(pass-if (= 2 (min 5/2 2))))
(pass-if (eqv? 5/2 (min 5/2 3)))
(pass-if (eqv? 2 (min 5/2 2))))
(with-test-prefix "inum / real"
(pass-if (real-nan? (min 123 +nan.0))))
(with-test-prefix "infinities and NaNs"
;; -inf.0 beats everything else, including NaNs
(pass-if (eqv? -inf.0 (min -inf.0 123 )))
(pass-if (eqv? -inf.0 (min 123 -inf.0 )))
(pass-if (eqv? -inf.0 (min -inf.0 -123.3 )))
(pass-if (eqv? -inf.0 (min -123.3 -inf.0 )))
(pass-if (eqv? -inf.0 (min -inf.0 -7/2 )))
(pass-if (eqv? -inf.0 (min -7/2 -inf.0 )))
(pass-if (eqv? -inf.0 (min -inf.0 -1e20 )))
(pass-if (eqv? -inf.0 (min -1e20 -inf.0 )))
(pass-if (eqv? -inf.0 (min -inf.0 (- big*2))))
(pass-if (eqv? -inf.0 (min (- big*2) -inf.0 )))
(pass-if (eqv? -inf.0 (min -inf.0 +inf.0 )))
(pass-if (eqv? -inf.0 (min +inf.0 -inf.0 )))
(pass-if (eqv? -inf.0 (min -inf.0 +nan.0 )))
(pass-if (eqv? -inf.0 (min +nan.0 -inf.0 )))
(pass-if (eqv? -inf.0 (min -inf.0 -inf.0 )))
(with-test-prefix "real / inum"
(pass-if (real-nan? (min +nan.0 123))))
;; NaNs beat everything except -inf.0
(pass-if (real-nan? (min +nan.0 123 )))
(pass-if (real-nan? (min 123 +nan.0 )))
(pass-if (real-nan? (min +nan.0 123.3 )))
(pass-if (real-nan? (min 123.3 +nan.0 )))
(pass-if (real-nan? (min +nan.0 -7/2 )))
(pass-if (real-nan? (min -7/2 +nan.0 )))
(pass-if (real-nan? (min +nan.0 -1e20 )))
(pass-if (real-nan? (min -1e20 +nan.0 )))
(pass-if (real-nan? (min +nan.0 (- big*2))))
(pass-if (real-nan? (min (- big*2) +nan.0 )))
(pass-if (real-nan? (min +nan.0 +inf.0 )))
(pass-if (real-nan? (min +inf.0 +nan.0 )))
(pass-if (real-nan? (min +nan.0 +nan.0 )))
;; +inf.0 always loses, except against itself
(pass-if (eqv? +inf.0 (min +inf.0 +inf.0 )))
(pass-if (eqv? -123.0 (min +inf.0 -123 )))
(pass-if (eqv? -123.0 (min -123 +inf.0 )))
(pass-if (eqv? -123.3 (min +inf.0 -123.3 )))
(pass-if (eqv? -123.3 (min -123.3 +inf.0 )))
(pass-if (eqv? -3.5 (min +inf.0 -7/2 )))
(pass-if (eqv? -3.5 (min -7/2 +inf.0 )))
(pass-if (eqv? -1.0e20 (min +inf.0 -1e20 )))
(pass-if (eqv? -1.0e20 (min -1e20 +inf.0 )))
(pass-if (eqv? (exact->inexact (- big*2))
(min +inf.0 (- big*2))))
(pass-if (eqv? (exact->inexact (- big*2))
(min (- big*2) +inf.0 ))))
(with-test-prefix "signed zeroes"
(pass-if (eqv? 0.0 (min 0.0 0.0)))
(pass-if (eqv? -0.0 (min 0.0 -0.0)))
(pass-if (eqv? -0.0 (min -0.0 0.0)))
(pass-if (eqv? -0.0 (min -0.0 -0.0)))
(pass-if (eqv? -0.0 (min -0.0 0 )))
(pass-if (eqv? 0.0 (min 0.0 0 )))
(pass-if (eqv? -0.0 (min 0 -0.0)))
(pass-if (eqv? 0.0 (min 0 0.0)))
(pass-if (eqv? 0 (min 0 0 ))))
(with-test-prefix "big / frac"
(pass-if (= 5/2 (min big*2 5/2)))
(pass-if (= (- big*2) (min (- big*2) 5/2))))
(pass-if (eqv? 5/2 (min big*2 5/2)))
(pass-if (eqv? (- big*2) (min (- big*2) 5/2))))
(with-test-prefix "frac / big"
(pass-if (= 5/2 (min 5/2 big*2)))
(pass-if (= (- big*2) (min 5/2 (- big*2)))))
(pass-if (eqv? 5/2 (min 5/2 big*2)))
(pass-if (eqv? (- big*2) (min 5/2 (- big*2)))))
(with-test-prefix "big / real"
(pass-if (real-nan? (min big*5 +nan.0)))
@ -2632,30 +2738,30 @@
(pass-if (eqv? (exact->inexact (- big*5)) (min 1.0 (- big*5)))))
(with-test-prefix "frac / frac"
(pass-if (= 1/2 (min 1/2 2/3)))
(pass-if (= 1/2 (min 2/3 1/2)))
(pass-if (= -2/3 (min -1/2 -2/3)))
(pass-if (= -2/3 (min -2/3 -1/2))))
(pass-if (eqv? 1/2 (min 1/2 2/3)))
(pass-if (eqv? 1/2 (min 2/3 1/2)))
(pass-if (eqv? -2/3 (min -1/2 -2/3)))
(pass-if (eqv? -2/3 (min -2/3 -1/2))))
(with-test-prefix "real / real"
(pass-if (real-nan? (min 123.0 +nan.0)))
(pass-if (real-nan? (min +nan.0 123.0)))
(pass-if (real-nan? (min +nan.0 +nan.0)))
(pass-if (= 123.0 (min 123.0 456.0)))
(pass-if (= 123.0 (min 456.0 123.0)))))
(pass-if (eqv? 123.0 (min 123.0 456.0)))
(pass-if (eqv? 123.0 (min 456.0 123.0)))))
;; in gmp prior to 4.2, mpz_cmp_d ended up treating Inf as 2^1024, make
;; sure we've avoided that
(for-each (lambda (b)
(pass-if (list b +inf.0)
(= (exact->inexact b) (min b +inf.0)))
(eqv? (exact->inexact b) (min b +inf.0)))
(pass-if (list +inf.0 b)
(= (exact->inexact b) (min b +inf.0)))
(eqv? (exact->inexact b) (min b +inf.0)))
(pass-if (list b -inf.0)
(= -inf.0 (min b -inf.0)))
(eqv? -inf.0 (min b -inf.0)))
(pass-if (list -inf.0 b)
(= -inf.0 (min b -inf.0))))
(eqv? -inf.0 (min b -inf.0))))
(list (1- (ash 1 1024))
(ash 1 1024)
(1+ (ash 1 1024))