diff options
author | Mark H Weaver <mhw@netris.org> | 2013-07-16 06:49:20 -0400 |
---|---|---|
committer | Mark H Weaver <mhw@netris.org> | 2013-07-16 06:49:20 -0400 |
commit | 902a4e779da1193ff9097c23b40fbd44ab2df6a3 (patch) | |
tree | 991c7ea394a603ce84725b6effdb2821b3c38c31 | |
parent | 3c2fe0ac03c1d9a2cf0cf595fb13ce0f73f21563 (diff) | |
parent | 3bbca1f7237c0e9d9419eaea8f274c9cd7314f04 (diff) | |
download | guile-902a4e779da1193ff9097c23b40fbd44ab2df6a3.tar.gz |
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
libguile/numbers.c
-rw-r--r-- | libguile/numbers.c | 80 | ||||
-rw-r--r-- | module/rnrs/arithmetic/flonums.scm | 57 | ||||
-rw-r--r-- | test-suite/tests/numbers.test | 78 | ||||
-rw-r--r-- | test-suite/tests/r6rs-arithmetic-flonums.test | 43 |
4 files changed, 186 insertions, 72 deletions
diff --git a/libguile/numbers.c b/libguile/numbers.c index 9857e182d..3c0d76505 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -4144,6 +4144,8 @@ scm_gcd (SCM x, SCM y) SCM_SWAP (x, y); goto big_inum; } + else if (SCM_REALP (y) && scm_is_integer (y)) + goto handle_inexacts; else return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd); } @@ -4174,6 +4176,20 @@ scm_gcd (SCM x, SCM y) scm_remember_upto_here_2 (x, y); return scm_i_normbig (result); } + else if (SCM_REALP (y) && scm_is_integer (y)) + goto handle_inexacts; + else + SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd); + } + else if (SCM_REALP (x) && scm_is_integer (x)) + { + if (SCM_I_INUMP (y) || SCM_BIGP (y) + || (SCM_REALP (y) && scm_is_integer (y))) + { + handle_inexacts: + return scm_exact_to_inexact (scm_gcd (scm_inexact_to_exact (x), + scm_inexact_to_exact (y))); + } else return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd); } @@ -4202,22 +4218,12 @@ SCM_PRIMITIVE_GENERIC (scm_i_lcm, "lcm", 0, 2, 1, SCM scm_lcm (SCM n1, SCM n2) { - if (SCM_UNBNDP (n2)) - { - if (SCM_UNBNDP (n1)) - return SCM_I_MAKINUM (1L); - n2 = SCM_I_MAKINUM (1L); - } - - if (SCM_UNLIKELY (!(SCM_I_INUMP (n1) || SCM_BIGP (n1)))) - return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG1, s_lcm); - - if (SCM_UNLIKELY (!(SCM_I_INUMP (n2) || SCM_BIGP (n2)))) - return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm); + if (SCM_UNLIKELY (SCM_UNBNDP (n2))) + return SCM_UNBNDP (n1) ? SCM_INUM1 : scm_abs (n1); - if (SCM_I_INUMP (n1)) + if (SCM_LIKELY (SCM_I_INUMP (n1))) { - if (SCM_I_INUMP (n2)) + if (SCM_LIKELY (SCM_I_INUMP (n2))) { SCM d = scm_gcd (n1, n2); if (scm_is_eq (d, SCM_INUM0)) @@ -4225,7 +4231,7 @@ scm_lcm (SCM n1, SCM n2) else return scm_abs (scm_product (n1, scm_quotient (n2, d))); } - else + else if (SCM_LIKELY (SCM_BIGP (n2))) { /* inum n1, big n2 */ inumbig: @@ -4239,8 +4245,12 @@ scm_lcm (SCM n1, SCM n2) return result; } } + else if (SCM_REALP (n2) && scm_is_integer (n2)) + goto handle_inexacts; + else + return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm); } - else + else if (SCM_LIKELY (SCM_BIGP (n1))) { /* big n1 */ if (SCM_I_INUMP (n2)) @@ -4248,7 +4258,7 @@ scm_lcm (SCM n1, SCM n2) SCM_SWAP (n1, n2); goto inumbig; } - else + else if (SCM_LIKELY (SCM_BIGP (n2))) { SCM result = scm_i_mkbig (); mpz_lcm(SCM_I_BIG_MPZ (result), @@ -4258,7 +4268,25 @@ scm_lcm (SCM n1, SCM n2) /* shouldn't need to normalize b/c lcm of 2 bigs should be big */ return result; } + else if (SCM_REALP (n2) && scm_is_integer (n2)) + goto handle_inexacts; + else + return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm); } + else if (SCM_REALP (n1) && scm_is_integer (n1)) + { + if (SCM_I_INUMP (n2) || SCM_BIGP (n2) + || (SCM_REALP (n2) && scm_is_integer (n2))) + { + handle_inexacts: + return scm_exact_to_inexact (scm_lcm (scm_inexact_to_exact (n1), + scm_inexact_to_exact (n2))); + } + else + return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm); + } + else + return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG1, s_lcm); } /* Emulating 2's complement bignums with sign magnitude arithmetic: @@ -7230,17 +7258,16 @@ scm_max (SCM x, SCM y) double xx = SCM_REAL_VALUE (x); double yy = SCM_REAL_VALUE (y); - /* For purposes of max: +inf.0 > nan > everything else, per R6RS */ + /* For purposes of max: nan > +inf.0 > everything else, + per the R6RS errata */ if (xx > yy) return x; else if (SCM_LIKELY (xx < yy)) return y; /* If neither (xx > yy) nor (xx < yy), then either they're equal or one is a NaN */ - else if (SCM_UNLIKELY (isnan (xx))) - return DOUBLE_IS_POSITIVE_INFINITY (yy) ? y : x; - else if (SCM_UNLIKELY (isnan (yy))) - return DOUBLE_IS_POSITIVE_INFINITY (xx) ? x : y; + else if (SCM_UNLIKELY (xx != yy)) + return (xx != xx) ? x : y; /* Return the NaN */ /* xx == yy, but handle signed zeroes properly */ else if (double_is_non_negative_zero (yy)) return y; @@ -7390,17 +7417,16 @@ scm_min (SCM x, SCM y) double xx = SCM_REAL_VALUE (x); double yy = SCM_REAL_VALUE (y); - /* For purposes of min: -inf.0 < nan < everything else, per R6RS */ + /* For purposes of min: nan < -inf.0 < everything else, + per the R6RS errata */ if (xx < yy) return x; else if (SCM_LIKELY (xx > yy)) return y; /* If neither (xx < yy) nor (xx > yy), then either they're equal or one is a NaN */ - else if (SCM_UNLIKELY (isnan (xx))) - return DOUBLE_IS_NEGATIVE_INFINITY (yy) ? y : x; - else if (SCM_UNLIKELY (isnan (yy))) - return DOUBLE_IS_NEGATIVE_INFINITY (xx) ? x : y; + else if (SCM_UNLIKELY (xx != yy)) + return (xx != xx) ? x : y; /* Return the NaN */ /* xx == yy, but handle signed zeroes properly */ else if (double_is_non_negative_zero (xx)) return y; diff --git a/module/rnrs/arithmetic/flonums.scm b/module/rnrs/arithmetic/flonums.scm index b65c294b5..fd04a4a0e 100644 --- a/module/rnrs/arithmetic/flonums.scm +++ b/module/rnrs/arithmetic/flonums.scm @@ -61,18 +61,24 @@ (only (guile) inf?) (rnrs arithmetic fixnums (6)) (rnrs base (6)) + (rnrs control (6)) (rnrs conditions (6)) (rnrs exceptions (6)) (rnrs lists (6)) (rnrs r5rs (6))) - (define (flonum? obj) (and (number? obj) (inexact? obj))) + (define (flonum? obj) (and (real? obj) (inexact? obj))) (define (assert-flonum . args) (or (for-all flonum? args) (raise (make-assertion-violation)))) (define (assert-iflonum . args) (or (for-all (lambda (i) (and (flonum? i) (integer? i))) args) (raise (make-assertion-violation)))) + (define (ensure-flonum z) + (cond ((real? z) z) + ((zero? (imag-part z)) (real-part z)) + (else +nan.0))) + (define (real->flonum x) (or (real? x) (raise (make-assertion-violation))) (exact->inexact x)) @@ -89,7 +95,7 @@ (define (flnegative? fl) (assert-flonum fl) (negative? fl)) (define (flodd? ifl) (assert-iflonum ifl) (odd? ifl)) (define (fleven? ifl) (assert-iflonum ifl) (even? ifl)) - (define (flfinite? fl) (assert-flonum fl) (not (inf? fl))) + (define (flfinite? fl) (assert-flonum fl) (not (or (inf? fl) (nan? fl)))) (define (flinfinite? fl) (assert-flonum fl) (inf? fl)) (define (flnan? fl) (assert-flonum fl) (nan? fl)) @@ -103,15 +109,13 @@ (apply assert-flonum flargs) (apply min flargs))) - (define (fl+ fl1 . args) - (let ((flargs (cons fl1 args))) - (apply assert-flonum flargs) - (apply + flargs))) + (define (fl+ . args) + (apply assert-flonum args) + (if (null? args) 0.0 (apply + args))) - (define (fl* fl1 . args) - (let ((flargs (cons fl1 args))) - (apply assert-flonum flargs) - (apply * flargs))) + (define (fl* . args) + (apply assert-flonum args) + (if (null? args) 1.0 (apply * args))) (define (fl- fl1 . args) (let ((flargs (cons fl1 args))) @@ -169,23 +173,30 @@ (define (flround fl) (assert-flonum fl) (round fl)) (define (flexp fl) (assert-flonum fl) (exp fl)) - (define* (fllog fl #:optional fl2) - (assert-flonum fl) - (cond ((fl=? fl -inf.0) +nan.0) - (fl2 (begin (assert-flonum fl2) (/ (log fl) (log fl2)))) - (else (log fl)))) + (define fllog + (case-lambda + ((fl) + (assert-flonum fl) + ;; add 0.0 to fl, to change -0.0 to 0.0, + ;; so that (fllog -0.0) will be -inf.0, not -inf.0+pi*i. + (ensure-flonum (log (+ fl 0.0)))) + ((fl fl2) + (assert-flonum fl fl2) + (ensure-flonum (/ (log (+ fl 0.0)) + (log (+ fl2 0.0))))))) (define (flsin fl) (assert-flonum fl) (sin fl)) (define (flcos fl) (assert-flonum fl) (cos fl)) (define (fltan fl) (assert-flonum fl) (tan fl)) - (define (flasin fl) (assert-flonum fl) (asin fl)) - (define (flacos fl) (assert-flonum fl) (acos fl)) - (define* (flatan fl #:optional fl2) - (assert-flonum fl) - (if fl2 (begin (assert-flonum fl2) (atan fl fl2)) (atan fl))) - - (define (flsqrt fl) (assert-flonum fl) (sqrt fl)) - (define (flexpt fl1 fl2) (assert-flonum fl1 fl2) (expt fl1 fl2)) + (define (flasin fl) (assert-flonum fl) (ensure-flonum (asin fl))) + (define (flacos fl) (assert-flonum fl) (ensure-flonum (acos fl))) + (define flatan + (case-lambda + ((fl) (assert-flonum fl) (atan fl)) + ((fl fl2) (assert-flonum fl fl2) (atan fl fl2)))) + + (define (flsqrt fl) (assert-flonum fl) (ensure-flonum (sqrt fl))) + (define (flexpt fl1 fl2) (assert-flonum fl1 fl2) (ensure-flonum (expt fl1 fl2))) (define-condition-type &no-infinities &implementation-restriction diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index ab0880d0a..a36d49394 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1322,6 +1322,32 @@ (pass-if "n = fixnum-min - 1" (eqv? (- (- fixnum-min 1)) (gcd (- fixnum-min 1) (- fixnum-min 1))))) + (with-test-prefix "flonum arguments" + + (pass-if-equal "flonum" + 15.0 + (gcd -15.0)) + + (pass-if-equal "flonum/flonum" + 3.0 + (gcd 6.0 -15.0)) + + (pass-if-equal "flonum/fixnum" + 3.0 + (gcd 6.0 -15)) + + (pass-if-equal "fixnum/flonum" + 3.0 + (gcd -6 15.0)) + + (pass-if-equal "flonum/bignum" + 2.0 + (gcd -6.0 (expt 2 fixnum-bit))) + + (pass-if-equal "bignum/flonum" + 3.0 + (gcd (- (expt 3 fixnum-bit)) 6.0))) + ;; Are wrong type arguments detected correctly? ) @@ -1334,8 +1360,40 @@ ;; FIXME: more tests? ;; (some of these are already in r4rs.test) (pass-if (documented? lcm)) - (pass-if (= (lcm) 1)) - (pass-if (= (lcm 32 -36) 288)) + (pass-if-equal 1 (lcm)) + (pass-if-equal 15 (lcm -15)) + (pass-if-equal 288 (lcm 32 -36)) + + (with-test-prefix "flonum arguments" + + (pass-if-equal "flonum" + 15.0 + (lcm -15.0)) + + (pass-if-equal "flonum/flonum" + 30.0 + (lcm 6.0 -15.0)) + + (pass-if-equal "flonum/fixnum" + 30.0 + (lcm 6.0 -15)) + + (pass-if-equal "fixnum/flonum" + 30.0 + (lcm -6 15.0)) + + (pass-if "flonum/bignum" + (let ((want (* 3.0 (expt 2 fixnum-bit))) + (got (lcm -6.0 (expt 2 fixnum-bit)))) + (and (inexact? got) + (test-eqv? 1.0 (/ want got))))) + + (pass-if "bignum/flonum" + (let ((want (* 2.0 (expt 3 fixnum-bit))) + (got (lcm (- (expt 3 fixnum-bit)) 6.0))) + (and (inexact? got) + (test-eqv? 1.0 (/ want got)))))) + (let ((big-n 115792089237316195423570985008687907853269984665640564039457584007913129639936) ; 2 ^ 256 (lcm-of-big-n-and-11 1273712981610478149659280835095566986385969831322046204434033424087044426039296)) (pass-if (= lcm-of-big-n-and-11 (lcm big-n 11))) @@ -2690,7 +2748,7 @@ (pass-if (eqv? 5/2 (max 5/2 2)))) (with-test-prefix "infinities and NaNs" - ;; +inf.0 beats everything else, including NaNs + ;; +inf.0 beats everything except NaNs (pass-if (eqv? +inf.0 (max +inf.0 123 ))) (pass-if (eqv? +inf.0 (max 123 +inf.0 ))) (pass-if (eqv? +inf.0 (max +inf.0 -123.3 ))) @@ -2703,11 +2761,9 @@ (pass-if (eqv? +inf.0 (max (- big*2) +inf.0 ))) (pass-if (eqv? +inf.0 (max +inf.0 +inf.0 ))) (pass-if (eqv? +inf.0 (max +inf.0 +inf.0 ))) - (pass-if (eqv? +inf.0 (max +inf.0 +nan.0 ))) - (pass-if (eqv? +inf.0 (max +nan.0 +inf.0 ))) (pass-if (eqv? +inf.0 (max +inf.0 +inf.0 ))) - ;; NaNs beat everything except +inf.0 + ;; NaNs beat everything (pass-if (real-nan? (max +nan.0 123 ))) (pass-if (real-nan? (max 123 +nan.0 ))) (pass-if (real-nan? (max +nan.0 123.3 ))) @@ -2721,6 +2777,8 @@ (pass-if (real-nan? (max +nan.0 -inf.0 ))) (pass-if (real-nan? (max -inf.0 +nan.0 ))) (pass-if (real-nan? (max +nan.0 +nan.0 ))) + (pass-if (real-nan? (max +inf.0 +nan.0 ))) + (pass-if (real-nan? (max +nan.0 +inf.0 ))) ;; -inf.0 always loses, except against itself (pass-if (eqv? -inf.0 (max -inf.0 -inf.0 ))) @@ -2868,7 +2926,7 @@ (pass-if (eqv? 2 (min 5/2 2)))) (with-test-prefix "infinities and NaNs" - ;; -inf.0 beats everything else, including NaNs + ;; -inf.0 beats everything except NaNs (pass-if (eqv? -inf.0 (min -inf.0 123 ))) (pass-if (eqv? -inf.0 (min 123 -inf.0 ))) (pass-if (eqv? -inf.0 (min -inf.0 -123.3 ))) @@ -2881,11 +2939,9 @@ (pass-if (eqv? -inf.0 (min (- big*2) -inf.0 ))) (pass-if (eqv? -inf.0 (min -inf.0 +inf.0 ))) (pass-if (eqv? -inf.0 (min +inf.0 -inf.0 ))) - (pass-if (eqv? -inf.0 (min -inf.0 +nan.0 ))) - (pass-if (eqv? -inf.0 (min +nan.0 -inf.0 ))) (pass-if (eqv? -inf.0 (min -inf.0 -inf.0 ))) - ;; NaNs beat everything except -inf.0 + ;; NaNs beat everything (pass-if (real-nan? (min +nan.0 123 ))) (pass-if (real-nan? (min 123 +nan.0 ))) (pass-if (real-nan? (min +nan.0 123.3 ))) @@ -2899,6 +2955,8 @@ (pass-if (real-nan? (min +nan.0 +inf.0 ))) (pass-if (real-nan? (min +inf.0 +nan.0 ))) (pass-if (real-nan? (min +nan.0 +nan.0 ))) + (pass-if (real-nan? (min -inf.0 +nan.0 ))) + (pass-if (real-nan? (min +nan.0 -inf.0 ))) ;; +inf.0 always loses, except against itself (pass-if (eqv? +inf.0 (min +inf.0 +inf.0 ))) diff --git a/test-suite/tests/r6rs-arithmetic-flonums.test b/test-suite/tests/r6rs-arithmetic-flonums.test index af9dbbf45..3df00b247 100644 --- a/test-suite/tests/r6rs-arithmetic-flonums.test +++ b/test-suite/tests/r6rs-arithmetic-flonums.test @@ -30,7 +30,10 @@ (pass-if "flonum? is #t on flonum" (flonum? 1.5)) - (pass-if "flonum? is #f on non-flonum" + (pass-if "flonum? is #f on complex" + (not (flonum? 1.5+0.0i))) + + (pass-if "flonum? is #f on exact integer" (not (flonum? 3)))) (with-test-prefix "real->flonum" @@ -139,7 +142,10 @@ (flfinite? 2.0)) (pass-if "flfinite? is #f on infinities" - (and (not (flfinite? +inf.0)) (not (flfinite? -inf.0))))) + (and (not (flfinite? +inf.0)) (not (flfinite? -inf.0)))) + + (pass-if "flfinite? is #f on NaNs" + (not (flfinite? +nan.0)))) (with-test-prefix "flinfinite?" (pass-if "flinfinite? is #t on infinities" @@ -162,10 +168,12 @@ (pass-if "simple" (fl=? (flmin -1.0 0.0 2.0) -1.0))) (with-test-prefix "fl+" - (pass-if "simple" (fl=? (fl+ 2.141 1.0 0.1) 3.241))) + (pass-if "simple" (fl=? (fl+ 2.141 1.0 0.1) 3.241)) + (pass-if "zero args" (fl=? (fl+) 0.0))) (with-test-prefix "fl*" - (pass-if "simple" (fl=? (fl* 1.0 2.0 3.0 1.5) 9.0))) + (pass-if "simple" (fl=? (fl* 1.0 2.0 3.0 1.5) 9.0)) + (pass-if "zero args" (fl=? (fl*) 1.0))) (with-test-prefix "fl-" (pass-if "unary fl- negates argument" (fl=? (fl- 2.0) -2.0)) @@ -248,14 +256,18 @@ (with-test-prefix "fllog" (pass-if "unary fllog returns natural log" - (let ((l (fllog 2.718281828459045))) - (and (fl<=? 0.9 l) (fl>=? 1.1 l)))) + (reasonably-close? (fllog 2.718281828459045) 1.0)) (pass-if "infinities" (and (fl=? (fllog +inf.0) +inf.0) (flnan? (fllog -inf.0)))) - (pass-if "zeroes" (fl=? (fllog 0.0) -inf.0)) + (pass-if "negative argument" + (flnan? (fllog -1.0))) + + (pass-if "zero" (fl=? (fllog 0.0) -inf.0)) + (pass-if "negative zero" (fl=? (fllog -0.0) -inf.0)) + (pass-if "negative zero with base" (fl=? (fllog -0.0 0.5) +inf.0)) (pass-if "binary fllog returns log in specified base" (fl=? (fllog 8.0 2.0) 3.0))) @@ -277,12 +289,16 @@ (with-test-prefix "flasin" (pass-if "simple" (and (reasonably-close? (flasin 1.0) (/ fake-pi 2)) - (reasonably-close? (flasin 0.5) (/ fake-pi 6))))) + (reasonably-close? (flasin 0.5) (/ fake-pi 6)))) + (pass-if "out of range" + (flnan? (flasin 2.0)))) (with-test-prefix "flacos" (pass-if "simple" (and (fl=? (flacos 1.0) 0.0) - (reasonably-close? (flacos 0.5) (/ fake-pi 3))))) + (reasonably-close? (flacos 0.5) (/ fake-pi 3)))) + (pass-if "out of range" + (flnan? (flacos 2.0)))) (with-test-prefix "flatan" (pass-if "unary flatan" @@ -298,12 +314,15 @@ (with-test-prefix "flsqrt" (pass-if "simple" (fl=? (flsqrt 4.0) 2.0)) - + (pass-if "negative" (flnan? (flsqrt -1.0))) (pass-if "infinity" (fl=? (flsqrt +inf.0) +inf.0)) - (pass-if "negative zero" (fl=? (flsqrt -0.0) -0.0))) -(with-test-prefix "flexpt" (pass-if "simple" (fl=? (flexpt 2.0 3.0) 8.0))) +(with-test-prefix "flexpt" + (pass-if "simple" (fl=? (flexpt 2.0 3.0) 8.0)) + (pass-if "negative squared" (fl=? (flexpt -2.0 2.0) 4.0)) + (pass-if "negative cubed" (fl=? (flexpt -2.0 3.0) -8.0)) + (pass-if "negative to non-integer power" (flnan? (flexpt -2.0 2.5)))) (with-test-prefix "fixnum->flonum" (pass-if "simple" (fl=? (fixnum->flonum 100) 100.0))) |