>From 6f8853937fb85f09505d14c1e682e5ec4d5f1bef Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 26 Jan 2011 16:01:21 -0500 Subject: [PATCH] Exact 0 times infinity or a NaN yields a NaN * libguile/numbers.c (scm_product): Handle exact 0 differently. A product containing an exact 0 now returns an exact 0 if and only if the other arguments are all finite, otherwise a NaN is returned. * test-suite/tests/numbers.test: Add many multiplication tests. * NEWS: Add NEWS entry. --- NEWS | 6 ++ libguile/numbers.c | 41 +++++++++------ test-suite/tests/numbers.test | 109 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 139 insertions(+), 17 deletions(-) diff --git a/NEWS b/NEWS index b8ffca0..9c1f32f 100644 --- a/NEWS +++ b/NEWS @@ -27,6 +27,12 @@ Previously, `(equal? +nan.0 +nan.0)' returned #f, although both returned #t. R5RS requires that `equal?' behave like `eqv?' when comparing numbers. +*** Change in handling products `*' involving exact 0 + +scm_product `*' now handles exact 0 differently. A product containing +an exact 0 now returns an exact 0 if and only if the other arguments +are all finite, otherwise a NaN value is returned. + *** `expt' and `integer-expt' changes when the base is 0 While `(expt 0 0)' is still 1, and `(expt 0 N)' for N > 0 is still diff --git a/libguile/numbers.c b/libguile/numbers.c index fb680a2..9ff8e41 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4710,13 +4710,25 @@ scm_product (SCM x, SCM y) { scm_t_inum xx; - intbig: + xinum: xx = SCM_I_INUM (x); switch (xx) { - case 0: return x; break; - case 1: return y; break; + case 0: + /* exact0 times any finite number is exact0 */ + if (SCM_LIKELY (SCM_I_INUMP (y))) /* optimize this case */ + return x; + else if (SCM_LIKELY (scm_is_true (scm_finite_p (y)))) + return x; + else + return scm_make_rectangular + (scm_is_true (scm_finite_p (scm_real_part (y))) ? x : scm_nan(), + scm_is_true (scm_finite_p (scm_imag_part (y))) ? x : scm_nan()); + break; + case 1: + return y; + break; /* * The following case (x = -1) is important for more than * just optimization. It handles the case of negating @@ -4767,7 +4779,7 @@ scm_product (SCM x, SCM y) if (SCM_I_INUMP (y)) { SCM_SWAP (x, y); - goto intbig; + goto xinum; } else if (SCM_BIGP (y)) { @@ -4800,12 +4812,10 @@ scm_product (SCM x, SCM y) else if (SCM_REALP (x)) { if (SCM_I_INUMP (y)) - { - /* inexact*exact0 => exact 0, per R5RS "Exactness" section */ - if (scm_is_eq (y, SCM_INUM0)) - return y; - return scm_from_double (SCM_I_INUM (y) * SCM_REAL_VALUE (x)); - } + { + SCM_SWAP (x, y); + goto xinum; + } else if (SCM_BIGP (y)) { double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x); @@ -4825,13 +4835,10 @@ scm_product (SCM x, SCM y) else if (SCM_COMPLEXP (x)) { if (SCM_I_INUMP (y)) - { - /* inexact*exact0 => exact 0, per R5RS "Exactness" section */ - if (scm_is_eq (y, SCM_INUM0)) - return y; - return scm_c_make_rectangular (SCM_I_INUM (y) * SCM_COMPLEX_REAL (x), - SCM_I_INUM (y) * SCM_COMPLEX_IMAG (x)); - } + { + SCM_SWAP (x, y); + goto xinum; + } else if (SCM_BIGP (y)) { double z = mpz_get_d (SCM_I_BIG_MPZ (y)); diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 195c8fd..e812658 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -2749,6 +2749,115 @@ (pass-if (eqv? fixnum-min (* (* fixnum-min -1) -1))) (pass-if (equal? fixnum-min (* (* fixnum-min -1) -1)))) + (with-test-prefix "exactness propagation" + (pass-if (eqv? 0 (* 0 -1.0 ))) + (pass-if (eqv? 0 (* 0 1.0 ))) + (pass-if (eqv? 0 (* -1.0 0 ))) + (pass-if (eqv? 0 (* 1.0 0 ))) + (pass-if (eqv? 0 (* 0 1/2 ))) + (pass-if (eqv? 0 (* 1/2 0 ))) + (pass-if (eqv? 0 (* 0 1+i ))) + (pass-if (eqv? 0 (* 1+i 0 ))) + (pass-if (eqv? -1.0 (* 1 -1.0 ))) + (pass-if (eqv? 1.0 (* 1 1.0 ))) + (pass-if (eqv? -1.0 (* -1.0 1 ))) + (pass-if (eqv? 1.0 (* 1.0 1 ))) + (pass-if (eqv? 1/2 (* 1 1/2 ))) + (pass-if (eqv? 1/2 (* 1/2 1 ))) + (pass-if (eqv? 1+i (* 1 1+i ))) + (pass-if (eqv? 1+i (* 1+i 1 )))) + + (with-test-prefix "propagation of NaNs" + (pass-if (real-nan? (* +nan.0 +nan.0))) + (pass-if (real-nan? (* +nan.0 1 ))) + (pass-if (real-nan? (* +nan.0 -1 ))) + (pass-if (real-nan? (* +nan.0 -7/2 ))) + (pass-if (real-nan? (* +nan.0 1e20 ))) + (pass-if (real-nan? (* 1 +nan.0))) + (pass-if (real-nan? (* -1 +nan.0))) + (pass-if (real-nan? (* -7/2 +nan.0))) + (pass-if (real-nan? (* 1e20 +nan.0))) + (pass-if (real-nan? (* +inf.0 +nan.0))) + (pass-if (real-nan? (* +nan.0 +inf.0))) + (pass-if (real-nan? (* -inf.0 +nan.0))) + (pass-if (real-nan? (* +nan.0 -inf.0))) + (pass-if (real-nan? (* (* fixnum-max 2) +nan.0))) + (pass-if (real-nan? (* +nan.0 (* fixnum-max 2)))) + + (pass-if (real-nan? (* 0 +nan.0 ))) + (pass-if (real-nan? (* +nan.0 0 ))) + (pass-if (real-nan? (* 0 +nan.0+i))) + (pass-if (real-nan? (* +nan.0+i 0 ))) + + (pass-if (imaginary-nan? (* 0 +nan.0i ))) + (pass-if (imaginary-nan? (* +nan.0i 0 ))) + (pass-if (imaginary-nan? (* 0 1+nan.0i ))) + (pass-if (imaginary-nan? (* 1+nan.0i 0 ))) + + (pass-if (complex-nan? (* 0 +nan.0+nan.0i ))) + (pass-if (complex-nan? (* +nan.0+nan.0i 0 )))) + + (with-test-prefix "infinities" + (pass-if (eqv? +inf.0 (* +inf.0 5 ))) + (pass-if (eqv? -inf.0 (* +inf.0 -5 ))) + (pass-if (eqv? +inf.0 (* +inf.0 73.1))) + (pass-if (eqv? -inf.0 (* +inf.0 -9.2))) + (pass-if (eqv? +inf.0 (* +inf.0 5/2))) + (pass-if (eqv? -inf.0 (* +inf.0 -5/2))) + (pass-if (eqv? -inf.0 (* -5 +inf.0))) + (pass-if (eqv? +inf.0 (* 73.1 +inf.0))) + (pass-if (eqv? -inf.0 (* -9.2 +inf.0))) + (pass-if (eqv? +inf.0 (* 5/2 +inf.0))) + (pass-if (eqv? -inf.0 (* -5/2 +inf.0))) + + (pass-if (eqv? -inf.0 (* -inf.0 5 ))) + (pass-if (eqv? +inf.0 (* -inf.0 -5 ))) + (pass-if (eqv? -inf.0 (* -inf.0 73.1))) + (pass-if (eqv? +inf.0 (* -inf.0 -9.2))) + (pass-if (eqv? -inf.0 (* -inf.0 5/2))) + (pass-if (eqv? +inf.0 (* -inf.0 -5/2))) + (pass-if (eqv? +inf.0 (* -5 -inf.0))) + (pass-if (eqv? -inf.0 (* 73.1 -inf.0))) + (pass-if (eqv? +inf.0 (* -9.2 -inf.0))) + (pass-if (eqv? -inf.0 (* 5/2 -inf.0))) + (pass-if (eqv? +inf.0 (* -5/2 -inf.0))) + + (pass-if (real-nan? (* 0.0 +inf.0))) + (pass-if (real-nan? (* -0.0 +inf.0))) + (pass-if (real-nan? (* +inf.0 0.0))) + (pass-if (real-nan? (* +inf.0 -0.0))) + + (pass-if (real-nan? (* 0.0 -inf.0))) + (pass-if (real-nan? (* -0.0 -inf.0))) + (pass-if (real-nan? (* -inf.0 0.0))) + (pass-if (real-nan? (* -inf.0 -0.0))) + + (pass-if (real-nan? (* 0 +inf.0 ))) + (pass-if (real-nan? (* +inf.0 0 ))) + (pass-if (real-nan? (* 0 +inf.0+i))) + (pass-if (real-nan? (* +inf.0+i 0 ))) + + (pass-if (real-nan? (* 0 -inf.0 ))) + (pass-if (real-nan? (* -inf.0 0 ))) + (pass-if (real-nan? (* 0 -inf.0+i))) + (pass-if (real-nan? (* -inf.0+i 0 ))) + + (pass-if (imaginary-nan? (* 0 +inf.0i ))) + (pass-if (imaginary-nan? (* +inf.0i 0 ))) + (pass-if (imaginary-nan? (* 0 1+inf.0i ))) + (pass-if (imaginary-nan? (* 1+inf.0i 0 ))) + + (pass-if (imaginary-nan? (* 0 -inf.0i ))) + (pass-if (imaginary-nan? (* -inf.0i 0 ))) + (pass-if (imaginary-nan? (* 0 1-inf.0i ))) + (pass-if (imaginary-nan? (* 1-inf.0i 0 ))) + + (pass-if (complex-nan? (* 0 +inf.0+inf.0i ))) + (pass-if (complex-nan? (* +inf.0+inf.0i 0 ))) + + (pass-if (complex-nan? (* 0 +inf.0-inf.0i ))) + (pass-if (complex-nan? (* -inf.0+inf.0i 0 )))) + (with-test-prefix "inum * bignum" (pass-if "0 * 2^256 = 0" -- 1.5.6.5