summaryrefslogtreecommitdiff
path: root/module/rnrs
diff options
context:
space:
mode:
authorMark H Weaver <mhw@netris.org>2013-07-16 06:49:20 -0400
committerMark H Weaver <mhw@netris.org>2013-07-16 06:49:20 -0400
commit902a4e779da1193ff9097c23b40fbd44ab2df6a3 (patch)
tree991c7ea394a603ce84725b6effdb2821b3c38c31 /module/rnrs
parent3c2fe0ac03c1d9a2cf0cf595fb13ce0f73f21563 (diff)
parent3bbca1f7237c0e9d9419eaea8f274c9cd7314f04 (diff)
downloadguile-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.scm57
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