diff options
author | Mark H Weaver <mhw@netris.org> | 2013-07-16 04:43:07 -0400 |
---|---|---|
committer | Mark H Weaver <mhw@netris.org> | 2013-07-16 04:43:07 -0400 |
commit | ad922d065c5f8b01c4ace3ee34d26300409e44fa (patch) | |
tree | 77966124c9f5c5eaec6af0c7b5faee4a90f8803f /module/rnrs | |
parent | 85b32d43e63bd2939ce3706f44a50f153ba01a46 (diff) | |
download | guile-ad922d065c5f8b01c4ace3ee34d26300409e44fa.tar.gz |
Flonum operations always return flonums.
Fixes <http://bugs.gnu.org/14871>.
Reported by Göran Weinholt <goran@weinholt.se>.
* module/rnrs/arithmetic/flonums.scm (ensure-flonum): New procedure.
(fllog): Rewrite using case-lambda. Handle negative zeroes. Use
'ensure-flonum'.
(flatan): Rewrite using case-lambda.
(flasin, flacos, flsqrt, flexpt): Use 'ensure-flonum'.
* test-suite/tests/r6rs-arithmetic-flonums.test
(fllog, flasin, flacos, flsqrt, flexpt): Add tests.
Diffstat (limited to 'module/rnrs')
-rw-r--r-- | module/rnrs/arithmetic/flonums.scm | 39 |
1 files changed, 26 insertions, 13 deletions
diff --git a/module/rnrs/arithmetic/flonums.scm b/module/rnrs/arithmetic/flonums.scm index be59295a7..fd04a4a0e 100644 --- a/module/rnrs/arithmetic/flonums.scm +++ b/module/rnrs/arithmetic/flonums.scm @@ -61,6 +61,7 @@ (only (guile) inf?) (rnrs arithmetic fixnums (6)) (rnrs base (6)) + (rnrs control (6)) (rnrs conditions (6)) (rnrs exceptions (6)) (rnrs lists (6)) @@ -73,6 +74,11 @@ (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)) @@ -167,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 |