>From b2d9e082b5740d6f722533d4ce30f3fbda955a9b Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 28 Jan 2011 23:42:01 -0500 Subject: [PATCH] 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. --- NEWS | 4 ++ module/rnrs/base.scm | 19 +++++---- test-suite/tests/r6rs-base.test | 89 ++++++++++++++++++++++++++++++++++++++- 3 files changed, 103 insertions(+), 9 deletions(-) diff --git a/NEWS b/NEWS index 5651b17..f45795e 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 c7579c3..04a7e23 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 a3603a1..1509b04 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)))) + -- 1.5.6.5