From d4c1abe9bfd5397602f4d2c00ffd66a8ff133b01 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 1 Feb 2011 06:30:29 -0500 Subject: [PATCH] Handle products with exact 0 differently * 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 exact. An inexact zero is returned if and only if the other arguments are all finite but not all exact. If an infinite or NaN value is present, a NaN value is returned. Previously, any product containing an exact 0 yielded an exact 0, regardless of the other arguments. A note on the rationale for (* 0 0.0) returning 0.0 and not exact 0: The exactness propagation rules allow us to return an exact result in the presence of inexact arguments only if the values of the inexact arguments do not affect the result. In this case, the value of the inexact argument _does_ affect the result, because an infinite or NaN value causes the result to be a NaN. A note on the rationale for (* 0 +inf.0) being a NaN and not exact 0: The R6RS requires that (/ 0 0.0) return a NaN value, and that (/ 0.0) return +inf.0. We would like (/ x y) to be the same as (* x (/ y)), and in particular, for (/ 0 0.0) to be the same as (* 0 (/ 0.0)), which reduces to (* 0 +inf.0). Therefore (* 0 +inf.0) should return a NaN. * test-suite/tests/numbers.test: Add many multiplication tests. * NEWS: Add NEWS entry. --- NEWS | 10 +++ libguile/numbers.c | 56 +++++++++++------ test-suite/tests/numbers.test | 129 +++++++++++++++++++++++++++++++++++++---- 3 files changed, 163 insertions(+), 32 deletions(-) diff --git a/NEWS b/NEWS index 3769b81..63df7db 100644 --- a/NEWS +++ b/NEWS @@ -130,6 +130,16 @@ 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 exact. An inexact zero is returned if and only if the other +arguments are all finite but not all exact. If an infinite or NaN +value is present, a NaN value is returned. Previously, any product +containing an exact 0 yielded an exact 0, regardless of the other +arguments. + *** `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 d4380dd..9ba340f 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -5900,22 +5900,43 @@ 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 1: + /* exact1 is the universal multiplicative identity */ + return y; + break; + case 0: + /* exact0 times a fixnum is exact0: optimize this case */ + if (SCM_LIKELY (SCM_I_INUMP (y))) + return SCM_INUM0; + /* if the other argument is inexact, the result is inexact, + and we must do the multiplication in order to handle + infinities and NaNs properly. */ + else if (SCM_REALP (y)) + return scm_from_double (0.0 * SCM_REAL_VALUE (y)); + else if (SCM_COMPLEXP (y)) + return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y), + 0.0 * SCM_COMPLEX_IMAG (y)); + /* we've already handled inexact numbers, + so y must be exact, and we return exact0 */ + else if (SCM_NUMP (y)) + return SCM_INUM0; + else + SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); + break; + case -1: /* - * The following case (x = -1) is important for more than - * just optimization. It handles the case of negating + * This case is important for more than just optimization. + * It handles the case of negating * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum), * which is a bignum that must be changed back into a fixnum. * Failure to do so will cause the following to return #f: * (= most-negative-fixnum (* -1 (- most-negative-fixnum))) */ - case -1: return scm_difference(y, SCM_UNDEFINED); break; } @@ -5957,7 +5978,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)) { @@ -5990,12 +6011,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); @@ -6015,13 +6034,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 75d3790..96fb6d9 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -2745,6 +2745,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 (* 0 -1.0 ))) + (pass-if (eqv? 0.0 (* 0 1.0 ))) + (pass-if (eqv? -0.0 (* -1.0 0 ))) + (pass-if (eqv? 0.0 (* 1.0 0 ))) + (pass-if (eqv? 0 (* 0 1/2 ))) + (pass-if (eqv? 0 (* 1/2 0 ))) + (pass-if (eqv? 0.0+0.0i (* 0 1+i ))) + (pass-if (eqv? 0.0+0.0i (* 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" @@ -2752,13 +2861,13 @@ (with-test-prefix "inum * flonum" - (pass-if "0 * 1.0 = 0" - (eqv? 0 (* 0 1.0)))) + (pass-if "0 * 1.0 = 0.0" + (eqv? 0.0 (* 0 1.0)))) (with-test-prefix "inum * complex" - (pass-if "0 * 1+1i = 0" - (eqv? 0 (* 0 1+1i)))) + (pass-if "0 * 1+1i = 0.0+0.0i" + (eqv? 0.0+0.0i (* 0 1+1i)))) (with-test-prefix "inum * frac" @@ -2771,16 +2880,12 @@ (eqv? 0 (* (ash 1 256) 0)))) (with-test-prefix "flonum * inum" - - ;; in guile 1.6.8 and 1.8.1 and earlier this returned inexact 0.0 - (pass-if "1.0 * 0 = 0" - (eqv? 0 (* 1.0 0)))) + (pass-if "1.0 * 0 = 0.0" + (eqv? 0.0 (* 1.0 0)))) (with-test-prefix "complex * inum" - - ;; in guile 1.6.8 and 1.8.1 and earlier this returned inexact 0.0 - (pass-if "1+1i * 0 = 0" - (eqv? 0 (* 1+1i 0)))) + (pass-if "1+1i * 0 = 0.0+0.0i" + (eqv? 0.0+0.0i (* 1+1i 0)))) (pass-if "complex * bignum" (let ((big (ash 1 90))) -- 1.5.6.5