[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-58-gb98d5a5

[Julian Graham]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=b98d5a5a7607b905afa54fd2768210232fa08e16

The branch, master has been updated
       via  b98d5a5a7607b905afa54fd2768210232fa08e16 (commit)
      from  eeb48bc27e27976acec41dc0e59e7aaab2b886cd (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit b98d5a5a7607b905afa54fd2768210232fa08e16
Author: Julian Graham <address@hidden>
Date:   Wed Nov 17 00:59:45 2010 -0500

    Add exports for missing functions from `(rnrs base)'.
    
    * module/rnrs.scm (boolean=?): New export.
      Fix typo in export of`integer-valued?'.
    * module/rnrs/base.scm: Add exports for `exact' and `inexact'.
      (boolean=?, symbol=?, infinite?, finite?, exact-integer-sqrt,
      integer-valued?, rational-valued?, real-valued?): New functions.
    * test-suite/tests/r6rs-base.test (boolean=?, symbol=?, infinite?,
      finite?, exact-integer-sqrt, integer-valued?, rational-valued?,
      real-valued?): New test prefixes and tests.

-----------------------------------------------------------------------

Summary of changes:
 module/rnrs.scm                 |   16 ++++++------
 module/rnrs/base.scm            |   45 ++++++++++++++++++++++++++++++--
 test-suite/tests/r6rs-base.test |   54 +++++++++++++++++++++++++++++++++++++++
 3 files changed, 104 insertions(+), 11 deletions(-)

diff --git a/module/rnrs.scm b/module/rnrs.scm
index c329aeb..c6f5db1 100644
--- a/module/rnrs.scm
+++ b/module/rnrs.scm
@@ -52,18 +52,18 @@
 
          boolean? symbol? char? vector? null? pair? number? string? procedure?
          define define-syntax syntax-rules lambda let let* let-values
-         let*-values letrec letrec* begin quote lambda if set! cond case or 
and not
-         eqv? equal? eq? + - * / max min abs numerator denominator gcd lcm 
-         floor ceiling truncate round rationalize real-part imag-part 
+         let*-values letrec letrec* begin quote lambda if set! cond case or 
+          and not eqv? equal? eq? + - * / max min abs numerator denominator gcd
+          lcm floor ceiling truncate round rationalize real-part imag-part 
          make-rectangular angle div mod div-and-mod div0 mod0 div0-and-mod0
          expt exact-integer-sqrt sqrt exp log sin cos tan asin acos atan 
          make-polar magnitude angle complex? real? rational? integer? exact? 
-         inexact? real-valued? rational-valued? integer-values? zero? 
+         inexact? real-valued? rational-valued? integer-valued? zero? 
          positive? negative? odd? even? nan? finite? infinite? exact inexact =
-         < > <= >= number->string string->number cons car cdr caar cadr cdar 
-         cddr caaar caadr cadar cdaar caddr cdadr cddar cdddr caaaar caaadr 
-         caadar cadaar cdaaar cddaar cdadar cdaadr cadadr caaddr caddar cadddr
-         cdaddr cddadr cdddar cddddr list? list length append reverse 
+         < > <= >= number->string string->number boolean=? cons car cdr caar 
+          cadr cdar cddr caaar caadr cadar cdaar caddr cdadr cddar cdddr caaaar
+          caaadr caadar cadaar cdaaar cddaar cdadar cdaadr cadadr caaddr caddar
+          cadddr cdaddr cddadr cdddar cddddr list? list length append reverse 
          list-tail list-ref map for-each symbol->string string->symbol symbol=?
          char->integer integer->char char=? char<? char>? char<=? char>=?
          make-string string string-length string-ref string=? string<? string>?
diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index 74fce31..6320420 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -37,13 +37,15 @@
          make-polar magnitude angle
         
          complex? real? rational? integer? exact? inexact? real-valued?
-         rational-valued? integer-values? zero? positive? negative? odd? even?
+         rational-valued? integer-valued? zero? positive? negative? odd? even?
          nan? finite? infinite?
 
          exact inexact = < > <= >= 
 
          number->string string->number
 
+          boolean=?
+
          cons car cdr caar cadr cdar cddr caaar caadr cadar cdaar caddr cdadr 
          cddar cdddr caaaar caaadr caadar cadaar cdaaar cddaar cdadar cdaadr 
          cadadr caaddr caddar cadddr cdaddr cddadr cdddar cddddr
@@ -71,8 +73,45 @@
          let-syntax letrec-syntax
 
          syntax-rules identifier-syntax)
- (import (rename (guile) (quotient div) (modulo mod))
-        (srfi srfi-11))
+  (import (rename (guile) 
+                  (quotient div) 
+                  (modulo mod)
+                  (exact->inexact inexact)
+                  (inexact->exact exact))
+          (srfi srfi-11))
+
+ (define (boolean=? . bools)
+   (define (boolean=?-internal lst last)
+     (or (null? lst)
+         (let ((bool (car lst))) 
+           (and (eqv? bool last) (boolean=?-internal (cdr lst) bool)))))
+   (or (null? bools)
+       (let ((bool (car bools)))
+         (and (boolean? bool) (boolean=?-internal (cdr bools) bool)))))
+
+ (define (symbol=? . syms)
+   (define (symbol=?-internal lst last)
+     (or (null? lst)
+         (let ((sym (car lst))) 
+           (and (eq? sym last) (symbol=?-internal (cdr lst) sym)))))
+   (or (null? syms)
+       (let ((sym (car syms)))
+         (and (symbol? sym) (symbol=?-internal (cdr syms) sym)))))
+
+ (define (infinite? x) (or (eqv? x +inf.0) (eqv? x -inf.0)))
+ (define (finite? x) (not (infinite? x)))
+
+ (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 (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 05d5802..a3603a1 100644
--- a/test-suite/tests/r6rs-base.test
+++ b/test-suite/tests/r6rs-base.test
@@ -21,6 +21,60 @@
   :use-module ((rnrs base) :version (6))
   :use-module (test-suite lib))
 
+(with-test-prefix "boolean=?"
+  (pass-if "boolean=? null" (boolean=?))
+  (pass-if "boolean=? unary" (boolean=? #f))
+  (pass-if "boolean=? many" 
+    (and (boolean=? #t #t #t) 
+        (boolean=? #f #f #f) 
+        (not (boolean=? #t #f #t))))
+  (pass-if "boolean=? mixed type" (not (boolean=? #t #t 'foo))))
+
+(with-test-prefix "symbol=?"
+  (pass-if "symbol=? null" (symbol=?))
+  (pass-if "symbol=? unary" (symbol=? 'a))
+  (pass-if "symbol=? many" 
+    (and (symbol=? 'a 'a 'a) 
+        (symbol=? 'foo 'foo 'foo) 
+        (not (symbol=? 'a 'foo 'a))))
+  (pass-if "symbol=? mixed type" (not (symbol=? 'a 'a 123))))
+
+(with-test-prefix "infinite?"
+  (pass-if "infinite? true on infinities"
+    (and (infinite? +inf.0) (infinite? -inf.0)))
+  (pass-if "infinite? false on non-infities"
+    (and (not (infinite? 123)) (not (infinite? +nan.0)))))
+
+(with-test-prefix "finite?"
+  (pass-if "finite? false on infinities"
+    (and (not (finite? +inf.0)) (not (finite? -inf.0))))
+  (pass-if "finite? true on non-infinities"
+    (and (finite? 123) (finite? 123.0))))
+
+(with-test-prefix "exact-integer-sqrt"
+  (pass-if "exact-integer-sqrt simple"
+    (let-values (((s e) (exact-integer-sqrt 5)))
+      (and (eqv? s 2) (eqv? e 1)))))
+
+(with-test-prefix "integer-valued?"
+  (pass-if "true on integers"
+    (and (integer-valued? 3) (integer-valued? 3.0) (integer-valued? 3.0+0.0i)))
+  (pass-if "false on rationals" (not (integer-valued? 3.1)))
+  (pass-if "false on reals" (not (integer-valued? +nan.0))))
+
+(with-test-prefix "rational-valued?"
+  (pass-if "true on integers" (rational-valued? 3))
+  (pass-if "true on rationals" 
+    (and (rational-valued? 3.1) (rational-valued? 3.1+0.0i)))
+  (pass-if "false on reals" 
+    (or (not (rational-valued? +nan.0))
+        (throw 'unresolved))))
+
+(with-test-prefix "real-valued?"
+  (pass-if "true on integers" (real-valued? 3))
+  (pass-if "true on rationals" (real-valued? 3.1))
+  (pass-if "true on reals" (real-valued? +nan.0)))
+
 (with-test-prefix "vector-for-each"
   (pass-if "vector-for-each simple"
     (let ((sum 0))


hooks/post-receive
-- 
GNU Guile