This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=ad922d065c5f8b01c4ace3ee34d26300409e44fa The branch, stable-2.0 has been updated via ad922d065c5f8b01c4ace3ee34d26300409e44fa (commit) from 85b32d43e63bd2939ce3706f44a50f153ba01a46 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit ad922d065c5f8b01c4ace3ee34d26300409e44fa Author: Mark H Weaver <[email protected]> Date: Tue Jul 16 04:43:07 2013 -0400 Flonum operations always return flonums. Fixes <http://bugs.gnu.org/14871>. Reported by Göran Weinholt <[email protected]>. * 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. ----------------------------------------------------------------------- Summary of changes: module/rnrs/arithmetic/flonums.scm | 39 ++++++++++++++++-------- test-suite/tests/r6rs-arithmetic-flonums.test | 27 ++++++++++++----- 2 files changed, 45 insertions(+), 21 deletions(-) diff --git a/module/rnrs/arithmetic/flonums.scm b/module/rnrs/arithmetic/flonums.scm index be59295..fd04a4a 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 diff --git a/test-suite/tests/r6rs-arithmetic-flonums.test b/test-suite/tests/r6rs-arithmetic-flonums.test index 0be504f..3df00b2 100644 --- a/test-suite/tests/r6rs-arithmetic-flonums.test +++ b/test-suite/tests/r6rs-arithmetic-flonums.test @@ -256,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))) @@ -285,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" @@ -306,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))) hooks/post-receive -- GNU Guile
