mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Handle products with exact 0 differently

Browse source 
* 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.
This commit is contained in:
Mark H Weaver 2011-02-01 06:30:29 -05:00 • committed by Andy Wingo
parent 55a8b70819
commit 5e7918077a
3 changed files with 163 additions and 32 deletions
Download patch file Download diff file Expand all files Collapse all files

10
NEWS
View file

@ -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

56
libguile/numbers.c
View file

@ -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));

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

@ -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)))