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

Improve handling of signed zeroes

Browse source 
* libguile/numbers.c (scm_abs): (abs -0.0) now returns 0.0.  Previously
  it returned -0.0.  Also move the REALP case above the BIGP case,
  and consider it SCM_LIKELY to be REALP if not INUMP.
  (scm_difference): (- 0 0.0) now returns -0.0.  Previously it returned
  0.0.  Also make sure that (- 0 0.0+0.0i) will return -0.0-0.0i.

* test-suite/tests/numbers.test (abs, -): Add test cases, and change
  some tests to use `eqv?' instead of `=', in order to test exactness
  and distinguish signed zeroes.
This commit is contained in:
Mark H Weaver 2011-02-02 03:14:13 -05:00 • committed by Andy Wingo
parent 8deddc948d
commit 9b9ef10cf0
2 changed files with 103 additions and 23 deletions
Download patch file Download diff file Expand all files Collapse all files

49
libguile/numbers.c
View file

@ -745,6 +745,18 @@ SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0,
else
return scm_i_inum2big (-xx);
}
else if (SCM_LIKELY (SCM_REALP (x)))
{
double xx = SCM_REAL_VALUE (x);
/* If x is a NaN then xx<0 is false so we return x unchanged */
if (xx < 0.0)
return scm_from_double (-xx);
/* Handle signed zeroes properly */
else if (SCM_UNLIKELY (xx == 0.0))
return flo0;
else
return x;
}
else if (SCM_BIGP (x))
{
const int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
@ -753,15 +765,6 @@ SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0,
else
return x;
}
else if (SCM_REALP (x))
{
/* note that if x is a NaN then xx<0 is false so we return x unchanged */
double xx = SCM_REAL_VALUE (x);
if (xx < 0.0)
return scm_from_double (-xx);
else
return x;
}
else if (SCM_FRACTIONP (x))
{
if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x))))
@ -5758,13 +5761,35 @@ scm_difference (SCM x, SCM y)
else if (SCM_REALP (y))
{
scm_t_inum xx = SCM_I_INUM (x);
return scm_from_double (xx - SCM_REAL_VALUE (y));
/*
* We need to handle x == exact 0
* specially because R6RS states that:
* (- 0.0) ==> -0.0 and
* (- 0.0 0.0) ==> 0.0
* and the scheme compiler changes
* (- 0.0) into (- 0 0.0)
* So we need to treat (- 0 0.0) like (- 0.0).
* At the C level, (-x) is different than (0.0 - x).
* (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
*/
if (xx == 0)
return scm_from_double (- SCM_REAL_VALUE (y));
else
return scm_from_double (xx - SCM_REAL_VALUE (y));
}
else if (SCM_COMPLEXP (y))
{
scm_t_inum xx = SCM_I_INUM (x);
return scm_c_make_rectangular (xx - SCM_COMPLEX_REAL (y),
- SCM_COMPLEX_IMAG (y));
/* We need to handle x == exact 0 specially.
See the comment above (for SCM_REALP (y)) */
if (xx == 0)
return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y),
- SCM_COMPLEX_IMAG (y));
else
return scm_c_make_rectangular (xx - SCM_COMPLEX_REAL (y),
- SCM_COMPLEX_IMAG (y));
}
else if (SCM_FRACTIONP (y))
/* a - b/c = (ac - b) / c */

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

@ -423,17 +423,23 @@
(with-test-prefix "abs"
(pass-if (documented? abs))
(pass-if (zero? (abs 0)))
(pass-if (= 1 (abs 1)))
(pass-if (= 1 (abs -1)))
(pass-if (= (+ fixnum-max 1) (abs (+ fixnum-max 1))))
(pass-if (= (+ (- fixnum-min) 1) (abs (- fixnum-min 1))))
(pass-if (= 0.0 (abs 0.0)))
(pass-if (= 1.0 (abs 1.0)))
(pass-if (= 1.0 (abs -1.0)))
(pass-if (real-nan? (abs +nan.0)))
(pass-if (= +inf.0 (abs +inf.0)))
(pass-if (= +inf.0 (abs -inf.0))))
(pass-if (eqv? 0 (abs 0)))
(pass-if (eqv? 1 (abs 1)))
(pass-if (eqv? 1 (abs -1)))
(with-test-prefix "double-negation of fixnum-min"
(pass-if (eqv? fixnum-min (- (abs fixnum-min)))))
(pass-if (eqv? (+ fixnum-max 1) (abs (+ fixnum-max 1))))
(pass-if (eqv? (+ (- fixnum-min) 1) (abs (- fixnum-min 1))))
(pass-if (eqv? 0.0 (abs 0.0)))
(pass-if (eqv? 0.0 (abs -0.0)))
(pass-if (eqv? 1.0 (abs 1.0)))
(pass-if (eqv? 1.0 (abs -1.0)))
(pass-if (real-nan? (abs +nan.0)))
(pass-if (eqv? +inf.0 (abs +inf.0)))
(pass-if (eqv? +inf.0 (abs -inf.0))))
;;;
;;; quotient
@ -2814,6 +2820,55 @@
(pass-if "binary double-negation of fixnum-min: equal?"
(equal? fixnum-min (- 0 (- 0 fixnum-min))))
(pass-if "signed zeroes"
(and (eqv? +0.0 (- -0.0))
(eqv? -0.0 (- +0.0))
(eqv? 0.0 (- 0.0 0.0))
(eqv? 0.0 (- 0.0 -0.0))
(eqv? 0.0 (- -0.0 -0.0))
(eqv? -0.0 (- -0.0 0.0))))
(pass-if "exactness propagation"
(and (eqv? 3 (- 8 5))
(eqv? 3.0 (- 8 5.0))
(eqv? 3.0 (- 8.0 5))
(eqv? 3.0 (- 8.0 5.0))
(eqv? -1/6 (- 1/3 1/2))
(eqv? -4.5 (- 1/2 5.0))
(eqv? 2.75 (- 3.0 1/4))))
(pass-if "infinities"
(and (eqv? +inf.0 (- +inf.0 -inf.0))
(eqv? -inf.0 (- -inf.0 +inf.0))
(real-nan? (- +inf.0 +inf.0))
(real-nan? (- -inf.0 -inf.0))))
(pass-if "NaNs"
(and (real-nan? (- +nan.0 +nan.0))
(real-nan? (- 0 +nan.0))
(real-nan? (- +nan.0 0))
(real-nan? (- 1 +nan.0))
(real-nan? (- +nan.0 1))
(real-nan? (- -1 +nan.0))
(real-nan? (- +nan.0 -1))
(real-nan? (- -7/2 +nan.0))
(real-nan? (- +nan.0 -7/2))
(real-nan? (- 1e20 +nan.0))
(real-nan? (- +nan.0 1e20))
(real-nan? (- +inf.0 +nan.0))
(real-nan? (- +nan.0 +inf.0))
(real-nan? (- -inf.0 +nan.0))
(real-nan? (- +nan.0 -inf.0))
(real-nan? (- (* fixnum-max 2) +nan.0))
(real-nan? (- +nan.0 (* fixnum-max 2)))))
(pass-if "(eqv? fixnum-min (- (- fixnum-min)))"
(eqv? fixnum-min (- (- fixnum-min))))
(pass-if "(eqv? fixnum-min (- 0 (- 0 fixnum-min)))"
(eqv? fixnum-min (- 0 (- 0 fixnum-min))))
(pass-if "(eqv? fixnum-num (apply - (list (apply - (list fixnum-min)))))"
(eqv? fixnum-min (apply - (list (apply - (list fixnum-min))))))
(pass-if "-inum - +bignum"
(= #x-100000000000000000000000000000001
(- -1 #x100000000000000000000000000000000)))