summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMark H Weaver <mhw@netris.org>2011-01-28 23:42:01 -0500
committerAndy Wingo <wingo@pobox.com>2011-01-30 13:08:53 +0100
commit8f2339c436ce4b9c606246cb341f2a5f35c1de26 (patch)
tree6a75b3b3c497bf722e8cc5169b8117792cd3aa03
parentc960e55600962c45be7e623859eddca3fad87783 (diff)
downloadguile-8f2339c436ce4b9c606246cb341f2a5f35c1de26.tar.gz
Implement R6RS `real-valued?', `rational-valued?', `integer-valued?'
* module/rnrs/base.scm (real-valued?, rational-valued?, integer-valued?): Implement in compliance with R6RS. * test-suite/tests/r6rs-base.test: Add test cases for `real-valued?', `rational-valued?', and `integer-valued?'. * NEWS: Add NEWS entries.
-rw-r--r--NEWS4
-rw-r--r--module/rnrs/base.scm19
-rw-r--r--test-suite/tests/r6rs-base.test89
3 files changed, 103 insertions, 9 deletions
diff --git a/NEWS b/NEWS
index 5651b17ed..f45795ed8 100644
--- a/NEWS
+++ b/NEWS
@@ -76,6 +76,10 @@ by scheme, despite their name).
throws exceptions for non-numbers. (Note that NaNs _are_ considered
numbers by scheme, despite their name).
+**** `real-valued?', `rational-valued?' and `integer-valued?' changes
+
+These predicates are now implemented in accordance with R6RS.
+
** New reader option: `hungry-eol-escapes'
Guile's string syntax is more compatible with R6RS when the
diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index c7579c32e..04a7e23a8 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -102,14 +102,17 @@
(define (exact-integer-sqrt x)
(let* ((s (exact (floor (sqrt x)))) (e (- x (* s s)))) (values s e)))
- ;; These definitions should be revisited, since the behavior of Guile's
- ;; implementations of `integer?', `rational?', and `real?' (exported from this
- ;; library) is not entirely consistent with R6RS's requirements for those
- ;; functions.
-
- (define integer-valued? integer?)
- (define rational-valued? rational?)
- (define real-valued? real?)
+ (define (real-valued? x)
+ (and (complex? x)
+ (zero? (imag-part x))))
+
+ (define (rational-valued? x)
+ (and (real-valued? x)
+ (rational? (real-part x))))
+
+ (define (integer-valued? x)
+ (and (rational-valued? x)
+ (= x (floor (real-part x)))))
(define (vector-for-each proc . vecs)
(apply for-each (cons proc (map vector->list vecs))))
diff --git a/test-suite/tests/r6rs-base.test b/test-suite/tests/r6rs-base.test
index a3603a14e..1509b04ed 100644
--- a/test-suite/tests/r6rs-base.test
+++ b/test-suite/tests/r6rs-base.test
@@ -1,6 +1,6 @@
;;; r6rs-base.test --- Test suite for R6RS (rnrs base)
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -85,3 +85,90 @@
(pass-if "vector-map simple"
(equal? '#(3 2 1) (vector-map (lambda (x) (- 4 x)) '#(1 2 3)))))
+(with-test-prefix "real-valued?"
+ (pass-if (real-valued? +nan.0))
+ (pass-if (real-valued? +nan.0+0i))
+ (pass-if (real-valued? +nan.0+0.0i))
+ (pass-if (real-valued? +inf.0))
+ (pass-if (real-valued? -inf.0))
+ (pass-if (real-valued? +inf.0+0.0i))
+ (pass-if (real-valued? -inf.0-0.0i))
+ (pass-if (real-valued? 3))
+ (pass-if (real-valued? -2.5))
+ (pass-if (real-valued? -2.5+0i))
+ (pass-if (real-valued? -2.5+0.0i))
+ (pass-if (real-valued? -2.5-0i))
+ (pass-if (real-valued? #e1e10))
+ (pass-if (real-valued? 1e200))
+ (pass-if (real-valued? 1e200+0.0i))
+ (pass-if (real-valued? 6/10))
+ (pass-if (real-valued? 6/10+0.0i))
+ (pass-if (real-valued? 6/10+0i))
+ (pass-if (real-valued? 6/3))
+ (pass-if (not (real-valued? 3+i)))
+ (pass-if (not (real-valued? -2.5+0.01i)))
+ (pass-if (not (real-valued? +nan.0+0.01i)))
+ (pass-if (not (real-valued? +nan.0+nan.0i)))
+ (pass-if (not (real-valued? +inf.0-0.01i)))
+ (pass-if (not (real-valued? +0.01i)))
+ (pass-if (not (real-valued? -inf.0i))))
+
+(with-test-prefix "rational-valued?"
+ (pass-if (not (rational-valued? +nan.0)))
+ (pass-if (not (rational-valued? +nan.0+0i)))
+ (pass-if (not (rational-valued? +nan.0+0.0i)))
+ (pass-if (not (rational-valued? +inf.0)))
+ (pass-if (not (rational-valued? -inf.0)))
+ (pass-if (not (rational-valued? +inf.0+0.0i)))
+ (pass-if (not (rational-valued? -inf.0-0.0i)))
+ (pass-if (rational-valued? 3))
+ (pass-if (rational-valued? -2.5))
+ (pass-if (rational-valued? -2.5+0i))
+ (pass-if (rational-valued? -2.5+0.0i))
+ (pass-if (rational-valued? -2.5-0i))
+ (pass-if (rational-valued? #e1e10))
+ (pass-if (rational-valued? 1e200))
+ (pass-if (rational-valued? 1e200+0.0i))
+ (pass-if (rational-valued? 6/10))
+ (pass-if (rational-valued? 6/10+0.0i))
+ (pass-if (rational-valued? 6/10+0i))
+ (pass-if (rational-valued? 6/3))
+ (pass-if (not (rational-valued? 3+i)))
+ (pass-if (not (rational-valued? -2.5+0.01i)))
+ (pass-if (not (rational-valued? +nan.0+0.01i)))
+ (pass-if (not (rational-valued? +nan.0+nan.0i)))
+ (pass-if (not (rational-valued? +inf.0-0.01i)))
+ (pass-if (not (rational-valued? +0.01i)))
+ (pass-if (not (rational-valued? -inf.0i))))
+
+(with-test-prefix "integer-valued?"
+ (pass-if (not (integer-valued? +nan.0)))
+ (pass-if (not (integer-valued? +nan.0+0i)))
+ (pass-if (not (integer-valued? +nan.0+0.0i)))
+ (pass-if (not (integer-valued? +inf.0)))
+ (pass-if (not (integer-valued? -inf.0)))
+ (pass-if (not (integer-valued? +inf.0+0.0i)))
+ (pass-if (not (integer-valued? -inf.0-0.0i)))
+ (pass-if (integer-valued? 3))
+ (pass-if (integer-valued? 3.0))
+ (pass-if (integer-valued? 3+0i))
+ (pass-if (integer-valued? 3+0.0i))
+ (pass-if (integer-valued? 8/4))
+ (pass-if (integer-valued? #e1e10))
+ (pass-if (integer-valued? 1e200))
+ (pass-if (integer-valued? 1e200+0.0i))
+ (pass-if (not (integer-valued? -2.5)))
+ (pass-if (not (integer-valued? -2.5+0i)))
+ (pass-if (not (integer-valued? -2.5+0.0i)))
+ (pass-if (not (integer-valued? -2.5-0i)))
+ (pass-if (not (integer-valued? 6/10)))
+ (pass-if (not (integer-valued? 6/10+0.0i)))
+ (pass-if (not (integer-valued? 6/10+0i)))
+ (pass-if (not (integer-valued? 3+i)))
+ (pass-if (not (integer-valued? -2.5+0.01i)))
+ (pass-if (not (integer-valued? +nan.0+0.01i)))
+ (pass-if (not (integer-valued? +nan.0+nan.0i)))
+ (pass-if (not (integer-valued? +inf.0-0.01i)))
+ (pass-if (not (integer-valued? +0.01i)))
+ (pass-if (not (integer-valued? -inf.0i))))
+