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 /module/rnrs | |
parent | 3c2fe0ac03c1d9a2cf0cf595fb13ce0f73f21563 (diff) | |
parent | 3bbca1f7237c0e9d9419eaea8f274c9cd7314f04 (diff) | |
download | guile-902a4e779da1193ff9097c23b40fbd44ab2df6a3.tar.gz |
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
libguile/numbers.c
Diffstat (limited to 'module/rnrs')
-rw-r--r-- | module/rnrs/arithmetic/flonums.scm | 57 |
1 files changed, 34 insertions, 23 deletions
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 |