>From 0515f466960fd80f58a5a90b8bfdb530706b982a Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 2 Feb 2011 03:14:13 -0500 Subject: [PATCH] Improve handling of signed zeroes * 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. --- libguile/numbers.c | 49 +++++++++++++++++++------ test-suite/tests/numbers.test | 77 +++++++++++++++++++++++++++++++++++------ 2 files changed, 103 insertions(+), 23 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 090fb75..9a7848a 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -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 */ diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 28db652..5a8b31b 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -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))) -- 1.5.6.5