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.

diff --git a/NEWS b/NEWS
index 5651b17..f45795e 100644 (file)
--- 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 c7579c3..04a7e23 100644 (file)
--- 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 a3603a1..1509b04 100644 (file)
--- 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))))
+