summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/rnrs.scm16
-rw-r--r--module/rnrs/base.scm45
-rw-r--r--test-suite/tests/r6rs-base.test54
3 files changed, 104 insertions, 11 deletions
diff --git a/module/rnrs.scm b/module/rnrs.scm
index c329aeb07..c6f5db116 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 74fce31dc..63204208e 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 05d5802b9..a3603a14e 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))