From 53bc658226a4f2df6fa1a00d4edf513c4d744275 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 6 Mar 2008 18:56:31 +0000
Subject: [PATCH] r6rs tests and repairs

svn: r8905
---
 collects/rnrs/arithmetic/fixnums-6.ss        |  12 +-
 collects/rnrs/arithmetic/flonums-6.ss        |  52 +++++-
 collects/rnrs/base-6.ss                      |  25 +--
 collects/rnrs/bytevectors-6.ss               |  53 +++++-
 collects/rnrs/conditions-6.ss                |  11 +-
 collects/rnrs/enums-6.ss                     |  91 ++++++----
 collects/rnrs/io/ports-6.ss                  |   4 +-
 collects/rnrs/io/simple-6.ss                 |   2 +-
 collects/scribblings/reference/numbers.scrbl |  21 +--
 collects/tests/info.ss                       |   1 +
 collects/tests/r6rs/arithmetic/bitwise.ss    |  25 +++
 collects/tests/r6rs/arithmetic/fixnums.ss    |  20 +++
 collects/tests/r6rs/arithmetic/flonums.ss    |  74 +++++++++
 collects/tests/r6rs/bytevectors.ss           | 109 ++++++++++++
 collects/tests/r6rs/conditions.ss            | 124 ++++++++++++++
 collects/tests/r6rs/control.ss               |  43 +++++
 collects/tests/r6rs/enums.ss                 |  63 +++++++
 collects/tests/r6rs/exceptions.ss            |  74 +++++++++
 collects/tests/r6rs/hashtables.ss            |  31 ++++
 collects/tests/r6rs/io/ports.ss              |  15 ++
 collects/tests/r6rs/lists.ss                 | 109 ++++++++++++
 collects/tests/r6rs/records/procedural.ss    | 166 +++++++++++++++++++
 collects/tests/r6rs/records/syntactic.ss     | 114 +++++++++++++
 collects/tests/r6rs/run.ss                   |  36 +++-
 collects/tests/r6rs/sorting.ss               |  19 +++
 collects/tests/r6rs/syntax-case.ss           | 105 ++++++++++++
 collects/tests/r6rs/unicode.ss               |  85 ++++++++++
 src/mzscheme/src/number.c                    |   4 +-
 28 files changed, 1409 insertions(+), 79 deletions(-)
 create mode 100644 collects/tests/r6rs/arithmetic/bitwise.ss
 create mode 100644 collects/tests/r6rs/arithmetic/fixnums.ss
 create mode 100644 collects/tests/r6rs/arithmetic/flonums.ss
 create mode 100644 collects/tests/r6rs/bytevectors.ss
 create mode 100644 collects/tests/r6rs/conditions.ss
 create mode 100644 collects/tests/r6rs/control.ss
 create mode 100644 collects/tests/r6rs/enums.ss
 create mode 100644 collects/tests/r6rs/exceptions.ss
 create mode 100644 collects/tests/r6rs/hashtables.ss
 create mode 100644 collects/tests/r6rs/io/ports.ss
 create mode 100644 collects/tests/r6rs/lists.ss
 create mode 100644 collects/tests/r6rs/records/procedural.ss
 create mode 100644 collects/tests/r6rs/records/syntactic.ss
 create mode 100644 collects/tests/r6rs/sorting.ss
 create mode 100644 collects/tests/r6rs/syntax-case.ss
 create mode 100644 collects/tests/r6rs/unicode.ss

diff --git a/collects/rnrs/arithmetic/fixnums-6.ss b/collects/rnrs/arithmetic/fixnums-6.ss
index 155c7ccaf9..d0d0c3837e 100644
--- a/collects/rnrs/arithmetic/fixnums-6.ss
+++ b/collects/rnrs/arithmetic/fixnums-6.ss
@@ -10,8 +10,16 @@
 (provide fixnum?
          fixnum-width
          least-fixnum
-         greatest-fixnum)
-;; Many other provides from macros below
+         greatest-fixnum
+         fxbit-set?
+         fxcopy-bit
+         fxcopy-bit-field
+         fxarithmetic-shift
+         fxarithmetic-shift-left
+         fxarithmetic-shift-right
+         fxrotate-bit-field
+         fxreverse-bit-field)
+         ;; Many other provides from macros below
 
 (define 64-bit? (fixnum? (expt 2 33)))
 
diff --git a/collects/rnrs/arithmetic/flonums-6.ss b/collects/rnrs/arithmetic/flonums-6.ss
index a972028e00..cad637ce10 100644
--- a/collects/rnrs/arithmetic/flonums-6.ss
+++ b/collects/rnrs/arithmetic/flonums-6.ss
@@ -13,6 +13,9 @@
 
 (provide (rename-out [inexact-real? flonum?])
          real->flonum
+         flnumerator
+         fldenominator
+         fllog flsqrt flexpt
          &no-infinities make-no-infinities-violation no-infinities-violation?
          &no-nans make-no-nans-violation no-nans-violation?
          fixnum->flonum)
@@ -53,15 +56,40 @@
 (define-fl div0 fldiv0 (a b) nocheck)
 (define-fl mod0 flmod0 (a b) nocheck)
 
-(define-fl numerator flnumerator (a) nocheck)
-(define-fl denominator fldenominator (a) nocheck)
+(define (flnumerator c)
+  (if (inexact-real? c)
+      (if (and (rational? c)
+               (not (equal? c -0.0)))
+          (numerator c)
+          c)
+      (raise-type-error 'flnumerator "flonum" c)))
+
+(define (fldenominator c)
+  (if (inexact-real? c)
+      (if (rational? c)
+          (denominator c)
+          1.0)
+      (raise-type-error 'fldenominator "flonum" c)))
+
 (define-fl floor flfloor (a) nocheck)
 (define-fl ceiling flceiling (a) nocheck)
 (define-fl truncate fltruncate (a) nocheck)
 (define-fl round flround (a) nocheck)
 
 (define-fl exp flexp (a) nocheck)
-(define-fl log fllog [(a) (a b)] nocheck)
+
+(define fllog
+  (case-lambda
+   [(v) 
+    (unless (inexact-real? v)
+      (raise-type-error 'fllog "flonum" v))
+    (let ([v (log v)])
+      (if (inexact-real? v)
+          v
+          +nan.0))]
+   [(v1 v2)
+    (/ (fllog v1) (fllog v2))]))
+
 (define-fl sin flsin (a) nocheck)
 (define-fl cos flcos (a) nocheck)
 (define-fl tan fltan (a) nocheck)
@@ -69,9 +97,23 @@
 (define-fl acos flacos (a) nocheck)
 (define-fl atan flatan [(a) (a b)] nocheck)
 
-(define-fl sqrt flsqrt (a) nocheck)
+(define (flsqrt v)
+  (unless (inexact-real? v)
+    (raise-type-error 'flsqrt "flonum" v))
+  (let ([v (sqrt v)])
+    (if (inexact-real? v)
+        v
+        +nan.0)))
 
-(define-fl expt flexpt (a b) nocheck)
+(define (flexpt a b)
+  (unless (inexact-real? a)
+    (raise-type-error 'flexpt "flonum" a))
+  (unless (inexact-real? b)
+    (raise-type-error 'flexpt "flonum" b))
+  (let ([v (expt a b)])
+    (if (inexact-real? v)
+        v
+        +nan.0)))
 
 (define-condition-type &no-infinities
   &implementation-restriction
diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss
index e5397a88b5..e202adf7f2 100644
--- a/collects/rnrs/base-6.ss
+++ b/collects/rnrs/base-6.ss
@@ -455,17 +455,20 @@
    [else (datum->syntax stx r stx)]))
 
 (define-for-syntax (wrap-as-needed v)
-  (if (and (procedure? v)
-           (procedure-arity-includes? v 1))
-      (procedure-reduce-arity
-       (case-lambda 
-        [(stx) (if (syntax? stx)
-                   (let ([r (v stx)])
-                     (wrap r stx))
-                   (v stx))]
-        [args (apply v args)])
-       (procedure-arity v))
-      v))
+  (cond
+   [(and (procedure? v)
+         (procedure-arity-includes? v 1))
+    (procedure-reduce-arity
+     (case-lambda 
+      [(stx) (if (syntax? stx)
+                 (let ([r (v stx)])
+                   (wrap r stx))
+                 (v stx))]
+      [args (apply v args)])
+     (procedure-arity v))]
+   [(set!-transformer? v)
+    (make-set!-transformer (wrap-as-needed (set!-transformer-procedure v)))]
+   [else v]))
 
 ;; ----------------------------------------
 
diff --git a/collects/rnrs/bytevectors-6.ss b/collects/rnrs/bytevectors-6.ss
index 19558b1d75..0f0a50c6be 100644
--- a/collects/rnrs/bytevectors-6.ss
+++ b/collects/rnrs/bytevectors-6.ss
@@ -8,17 +8,17 @@
          (rename-out [bytes? bytevector?]
                      [bytes-length bytevector-length]
                      [bytes=? bytevector=?]
-                     [bytes-copy! bytevector-copy!]
                      [bytes-copy bytevector-copy]
                      [bytes-ref bytevector-u8-ref]
                      [bytes-set! bytevector-u8-set!])
+         bytevector-copy!
          bytevector->u8-list
          u8-list->bytevector
          make-bytevector 
          bytevector-fill!
          bytevector-s8-ref
          bytevector-s8-set!
-         
+
          bytevector-u16-ref
          bytevector-s16-ref
          bytevector-u16-native-ref
@@ -51,6 +51,11 @@
          bytevector-uint-set!
          bytevector-sint-set!
 
+         bytevector->uint-list
+         bytevector->sint-list
+         uint-list->bytevector
+         sint-list->bytevector
+
          string->utf8
          string->utf16
          string->utf32
@@ -65,6 +70,9 @@
       (endianness big)
       (endianness little)))
 
+(define (bytevector-copy! src src-start target target-start k)
+  (bytes-copy! target target-start src src-start (+ src-start k)))
+
 (define (bytevector->u8-list bv)
   (list->mlist (bytes->list bv)))
 
@@ -96,8 +104,8 @@
         (- v 256)
         v)))
 
-(define (bytevector-s8-set! bytes k)
-  (bytes-set! bytes (convert-fill 'bytevector-s8-set! k)))
+(define (bytevector-s8-set! bytes k v)
+  (bytes-set! bytes k (convert-fill 'bytevector-s8-set! v)))
 
 (define (check-endian endianness)
   (unless (or (eq? endianness 'little)
@@ -236,6 +244,43 @@
                    n)])
     (bytevector-int-set! 'bytevector-uint-set! bstr k pos-n n endianness size (* size (sub1 8)))))
 
+(define (bytevector->int-list who ref bv endianness size)
+  (unless (bytes? bv)
+    (raise-type-error who "bytevector" bv))
+  (check-endian endianness)
+  (unless (exact-positive-integer? size)
+    (raise-type-error who "exact positive integer" size))
+  (unless (zero? (modulo (bytes-length bv) size))
+    (raise-mismatch-error who "bytevector length is not a mulitple of given size: " size))
+  (list->mlist
+   (for/list ([k (in-range 0 (bytes-length bv) size)])
+     (ref bv k endianness size))))
+
+(define (bytevector->uint-list bv endianness size)
+  (bytevector->int-list 'bytevector->uint-list bytevector-uint-ref bv endianness size))
+
+(define (bytevector->sint-list bv endianness size)
+  (bytevector->int-list 'bytevector->sint-list bytevector-sint-ref bv endianness size))
+
+(define (int-list->bytevector who signed? set l endianness size)
+  (unless (list? l)
+    (raise-type-error who "list" l))
+  (check-endian endianness)
+  (unless (exact-positive-integer? size)
+    (raise-type-error who "exact positive integer" size))
+  (let* ([len (length l)]
+         [bv (make-bytes (* size len))])
+    (for ([v (in-list l)]
+          [k (in-naturals)])
+      (set l k v endianness size))
+    bv))
+
+(define (uint-list->bytevector l endianness size)
+  (int-list->bytevector 'uint-list->bytevector #f bytevector-uint-set! l endianness size))
+
+(define (sint-list->bytevector l endianness size)
+  (int-list->bytevector 'sint-list->bytevector #f bytevector-sint-set! l endianness size))
+
 ;; ----------------------------------------
 
 (define (string->utf8 str)
diff --git a/collects/rnrs/conditions-6.ss b/collects/rnrs/conditions-6.ss
index 8019dc5d8a..a25ed3ac02 100644
--- a/collects/rnrs/conditions-6.ss
+++ b/collects/rnrs/conditions-6.ss
@@ -3,6 +3,7 @@
 (require rnrs/records/syntactic-6
          rnrs/records/procedural-6
          r6rs/private/conds
+         scheme/mpair
          (for-syntax scheme/base))
 
 (provide &condition
@@ -45,7 +46,7 @@
             conds)
   (let ([conditions
          (apply append
-                (map simple-conditions conds))])
+                (map simple-conditions/list conds))])
     ((if (ormap serious-condition? conditions)
          make-compound-condition:fail
          make-compound-condition)
@@ -65,7 +66,7 @@
   (let ([pred (record-predicate rtd)])
     (lambda (v)
       (and (condition? v)
-           (ormap pred (simple-conditions v))))))
+           (ormap pred (simple-conditions/list v))))))
 
 (define (condition-accessor rtd proc)
   (let ([pred (record-predicate rtd)])
@@ -75,12 +76,12 @@
     (lambda (v)
       (let ([v (ormap (lambda (x) 
                         (and (pred x) x))
-                      (simple-conditions v))])
+                      (simple-conditions/list v))])
         (if v
             (proc v)
             (raise-type-error 'a-condition-accessor "specific kind of condition" v))))))
 
-(define (simple-conditions c)
+(define (simple-conditions/list c)
   (cond
    [(&condition? c) (list c)]
    [(compound-condition? c)
@@ -138,6 +139,8 @@
                            "condition"
                            c)]))
 
+(define (simple-conditions c)
+  (list->mlist (simple-conditions/list c)))
 
 (define-syntax (define-condition-type stx)
   (syntax-case stx ()
diff --git a/collects/rnrs/enums-6.ss b/collects/rnrs/enums-6.ss
index 7d91cad521..4d518cebb6 100644
--- a/collects/rnrs/enums-6.ss
+++ b/collects/rnrs/enums-6.ss
@@ -8,6 +8,7 @@
          enum-set-universe
          enum-set-indexer
          enum-set-constructor
+         enum-set->list
          enum-set-member?
          enum-set-subset?
          enum-set=?
@@ -18,7 +19,8 @@
          enum-set-projection
          define-enumeration)
 
-(define-struct enum-set (val ht))
+(define-struct universe (ht syms))
+(define-struct enum-set (val uni))
 
 (define (make-enumeration-universe enum)
   (let ([bad (lambda ()
@@ -30,50 +32,55 @@
   (let ([enum (mlist->list enum)])
     (unless (andmap symbol? enum) (bad))
     (let ([ht (make-hash-table)])
-      (for ([s (in-list enum)])
-        (unless (hash-table-get ht s #f)
-          (hash-table-put! ht s (arithmetic-shift 1 (hash-table-count ht)))))
-      ht))))
+      (make-universe
+       ht
+       (for/list ([s (in-list enum)]
+                  #:when (not (hash-table-get ht s #f)))
+         (hash-table-put! ht s (arithmetic-shift 1 (hash-table-count ht)))
+         s))))))
 
 (define (make-enumeration enum)
-  (let ([ht (make-enumeration-universe enum)])
-    (make-enum-set (sub1 (arithmetic-shift 1 (hash-table-count ht)))
-                   ht)))
+  (let ([uni (make-enumeration-universe enum)])
+    (make-enum-set (sub1 (arithmetic-shift 1 (hash-table-count (universe-ht uni))))
+                   uni)))
 
 (define (enum-set-universe enum)
   (unless (enum-set? enum)
     (raise-type-error 'enum-set-universe
                       "enumeration set"
                       enum))
-  (let ([ht (enum-set-ht enum)])
-    (make-enum-set (sub1 (arithmetic-shift 1 (hash-table-count ht))) ht)))
+  (let ([uni (enum-set-uni enum)])
+    (make-enum-set (sub1 (arithmetic-shift 1 (hash-table-count 
+                                              (universe-ht uni))))
+                   uni)))
 
 (define (enum-set-indexer enum)
   (unless (enum-set? enum)
     (raise-type-error 'enum-set-indexer
                       "enumeration set"
                       enum))
-  (let ([ht (enum-set-ht enum)])
+  (let ([ht (universe-ht (enum-set-uni enum))])
     (lambda (sym)
       (let ([v (hash-table-get ht sym #f)])
         (if v
             (bitwise-first-bit-set v)
-            (error 'generated-enum-set-indexer
-                   (if (symbol? sym)
-                       "symbol not in universe: ~e"
-                       "not a symbol: ~e")
-                   sym))))))
+            (if (symbol? sym)
+                #f
+                (error 'generated-enum-set-indexer
+                       "not a symbol: ~e"
+                       sym)))))))
 
 (define (enum-set-constructor enum)
   (unless (enum-set? enum)
     (raise-type-error 'enum-set-constructor
                       "enumeration set"
                       enum))
-  (let ([ht (enum-set-ht enum)])
+  (let* ([uni (enum-set-uni enum)]
+         [ht (universe-ht uni)])
     (lambda (orig-syms)
       (let loop ([syms orig-syms][val 0])
         (cond
-         [(null? syms) (make-enum-set val ht)]
+         [(null? syms) (make-enum-set val uni)]
          [(not (mpair? syms))
           (raise-type-error 'make-enum-set
                             "list of symbols"
@@ -88,6 +95,18 @@
                      "not a symbol: ~e")
                  (mcar syms))])))))
 
+(define (enum-set->list enum)
+  (unless (enum-set? enum)
+    (raise-type-error 'enum-set->list
+                      "enumeration set"
+                      enum))
+  (let ([v (enum-set-val enum)])
+    (list->mlist
+     (for/list ([sym (in-list (universe-syms (enum-set-uni enum)))]
+                [i (in-naturals)]
+                #:when (not (zero? (bitwise-and (arithmetic-shift 1 i) v))))
+       sym))))
+
 (define (enum-set-member? sym enum)
   (unless (symbol? sym)
     (raise-type-error 'enum-set-member?
@@ -97,7 +116,7 @@
     (raise-type-error 'enum-set-member?
                       "enumeration set"
                       enum))
-  (let ([v (hash-table-get (enum-set-ht enum) sym #f)])
+  (let ([v (hash-table-get (universe-ht (enum-set-uni enum)) sym #f)])
     (and v
          (not (zero? (bitwise-and v (enum-set-val enum)))))))
 
@@ -112,15 +131,15 @@
 
 (define (enum-set-subset? enum1 enum2)
   (check-2-enums 'enum-set-subset? enum1 enum2)
-  (if (eq? (enum-set-ht enum1) (enum-set-ht enum2))
+  (if (eq? (enum-set-uni enum1) (enum-set-uni enum2))
       (= (enum-set-val enum1) 
          (bitwise-and (enum-set-val enum1) (enum-set-val enum2)))
-      (let ([ht2 (enum-set-ht enum2)]
+      (let ([ht2 (universe-ht (enum-set-uni enum2))]
             [v1 (enum-set-val enum1)]
             [v2 (enum-set-val enum2)])
         (for/fold ([sub? #t])
             (#:when sub?
-                    [(key1 val1) (in-hash-table (enum-set-ht enum1))])
+                    [(key1 val1) (in-hash-table (universe-ht (enum-set-uni enum1)))])
           (or (zero? (bitwise-and v1 val1))
               (let ([val2 (hash-table-get ht2 key1 #f)])
                 (and val2
@@ -128,15 +147,15 @@
 
 (define (enum-set=? enum1 enum2)
   (check-2-enums 'enum-set=? enum1 enum2)
-  (if (eq? (enum-set-ht enum1) (enum-set-ht enum2))
+  (if (eq? (enum-set-uni enum1) (enum-set-uni enum2))
       (= (enum-set-val enum1) (enum-set-val enum2))
       (and (enum-set-subset? enum1 enum2)
            (enum-set-subset? enum2 enum1))))
 
 (define (check-2-enums/same who enum1 enum2)
   (check-2-enums who enum1 enum2)
-  (unless (eq? (enum-set-ht enum1)
-               (enum-set-ht enum2))
+  (unless (eq? (enum-set-uni enum1)
+               (enum-set-uni enum2))
     (error who
            "enumeration sets are not the same enumeration type: ~e ~e"
            enum1 enum2)))
@@ -145,20 +164,20 @@
   (check-2-enums/same 'enum-set-union enum1 enum2)
   (make-enum-set (bitwise-ior (enum-set-val enum1)
                               (enum-set-val enum2))
-                 (enum-set-ht enum1)))
+                 (enum-set-uni enum1)))
 
 (define (enum-set-intersection enum1 enum2)
   (check-2-enums/same 'enum-set-intersection enum1 enum2)
   (make-enum-set (bitwise-and (enum-set-val enum1)
                               (enum-set-val enum2))
-                 (enum-set-ht enum1)))
+                 (enum-set-uni enum1)))
 
 (define (enum-set-difference enum1 enum2)
   (check-2-enums/same 'enum-set-intersection enum1 enum2)
   (make-enum-set (- (enum-set-val enum1)
                     (bitwise-and (enum-set-val enum1)
                                  (enum-set-val enum2)))
-                 (enum-set-ht enum1)))
+                 (enum-set-uni enum1)))
 
 (define (enum-set-complement enum1)
   (unless (enum-set? enum1)
@@ -167,25 +186,27 @@
                       enum1))
   (make-enum-set (bitwise-xor (sub1 (arithmetic-shift 
                                      1 
-                                     (hash-table-count (enum-set-ht enum1))))
+                                     (hash-table-count 
+                                      (universe-ht (enum-set-uni enum1)))))
                               (enum-set-val enum1))
-                 (enum-set-ht enum1)))
+                 (enum-set-uni enum1)))
 
 (define (enum-set-projection enum1 enum2)
   (check-2-enums 'enum-set-projection enum1 enum2)
-  (let ([ht2 (enum-set-ht enum2)]
-        [v1 (enum-set-val enum1)]
-        [v2 (enum-set-val enum2)])
+  (let* ([uni2 (enum-set-uni enum2)]
+         [ht2 (universe-ht uni2)]
+         [v1 (enum-set-val enum1)]
+         [v2 (enum-set-val enum2)])
     (make-enum-set
      (for/fold ([val 0])
-         ([(key1 val1) (in-hash-table (enum-set-ht enum1))])
+         ([(key1 val1) (in-hash-table (universe-ht (enum-set-uni enum1)))])
        (if (zero? (bitwise-and v1 val1))
            val
            (let ([val2 (hash-table-get ht2 key1 #f)])
              (if val2
                  (bitwise-ior val val2)
                  val))))
-     ht2)))
+     uni2)))
   
 (define-syntax (define-enumeration stx)
   (syntax-case stx ()
diff --git a/collects/rnrs/io/ports-6.ss b/collects/rnrs/io/ports-6.ss
index c78d5baef0..484683196c 100644
--- a/collects/rnrs/io/ports-6.ss
+++ b/collects/rnrs/io/ports-6.ss
@@ -24,7 +24,7 @@
          native-transcoder
          ;bytevector->string
          ;string->bytevector
-         (rename-out [eof eof-object])
+         eof-object
          eof-object?
          port?
          port-transcoder
@@ -139,6 +139,8 @@
 (define (native-transcoder)
   utf8-transcoder)
 
+(define (eof-object) eof)
+
 ;; ----------------------------------------
 
 (define (make-disconnectable-input-port port)
diff --git a/collects/rnrs/io/simple-6.ss b/collects/rnrs/io/simple-6.ss
index a84e0e798a..6a9f4199e2 100644
--- a/collects/rnrs/io/simple-6.ss
+++ b/collects/rnrs/io/simple-6.ss
@@ -2,7 +2,7 @@
 
 (require (prefix-in r6rs: rnrs/io/ports-6))
 
-(provide (rename-out [eof eof-object])
+(provide (rename-out [r6rs:eof-object eof-object])
          eof-object?
          (rename-out [r6rs:call-with-input-file call-with-input-file]
                      [r6rs:call-with-output-file call-with-output-file])
diff --git a/collects/scribblings/reference/numbers.scrbl b/collects/scribblings/reference/numbers.scrbl
index dcafc0483d..5625732754 100644
--- a/collects/scribblings/reference/numbers.scrbl
+++ b/collects/scribblings/reference/numbers.scrbl
@@ -331,25 +331,20 @@ otherwise.}
 @examples[(truncate 17/4) (truncate -17/4) (truncate 2.5) (truncate -2.5)]}
 
 
-@defproc[(numerator [x real?]) (or/c integer? (one-of/c +nan.0))]{
- Coreces @scheme[x] to an exact number, finds the numerator of the number
+@defproc[(numerator [q rational?]) integer?]{
+ Coreces @scheme[q] to an exact number, finds the numerator of the number
  expressed in its simplest fractional form, and returns this number
- coerced to the exactness of @scheme[x]. An exception is when @scheme[x] is
- @scheme[+inf.0], @scheme[-inf.0], and @scheme[+nan.0], in which case
- @scheme[x] is returned.
+ coerced to the exactness of @scheme[q].
 
-@examples[(numerator 5) (numerator 34/8) (numerator 2.3) (numerator +inf.0)]}
+@examples[(numerator 5) (numerator 34/8) (numerator 2.3)]}
 
 
-@defproc[(denominator [x real?]) (or/c integer? (one-of/c +nan.0))]{
- Coreces @scheme[x] to an exact number, finds the numerator of the number
+@defproc[(denominator [q rational?]) integer?]{
+ Coreces @scheme[q] to an exact number, finds the numerator of the number
  expressed in its simplest fractional form, and returns this number
- coerced to the exactness of @scheme[x]. Exceptions are when @scheme[x] is
- @scheme[+inf.0] or @scheme[-inf.0], in which case @scheme[1.0] is
- returned, or when @scheme[x] is @scheme[+nan.0], in which case
- @scheme[+nan.0] is returned.
+ coerced to the exactness of @scheme[q].
 
-@examples[(denominator 5) (denominator 34/8) (denominator 2.3) (denominator +inf.0)]}
+@examples[(denominator 5) (denominator 34/8) (denominator 2.3)]}
 
 
 @defproc[(rationalize [x real?][tolerance real?]) real?]{
diff --git a/collects/tests/info.ss b/collects/tests/info.ss
index 0b161a0f89..390121744b 100644
--- a/collects/tests/info.ss
+++ b/collects/tests/info.ss
@@ -14,6 +14,7 @@
     "plai"
     "plot"
     "profj"
+    "r6rs"
     "srfi"
     "srpersist"
     "stepper"
diff --git a/collects/tests/r6rs/arithmetic/bitwise.ss b/collects/tests/r6rs/arithmetic/bitwise.ss
new file mode 100644
index 0000000000..28f2f32bea
--- /dev/null
+++ b/collects/tests/r6rs/arithmetic/bitwise.ss
@@ -0,0 +1,25 @@
+#!r6rs
+
+(library (tests r6rs arithmetic bitwise)
+  (export run-arithmetic-bitwise-tests)
+  (import (rnrs)
+          (tests r6rs test))
+
+  (define (run-arithmetic-bitwise-tests)
+
+    (test (bitwise-first-bit-set 0)         -1)
+    (test (bitwise-first-bit-set 1)         0)
+    (test (bitwise-first-bit-set -4)        2)
+    
+    (test (bitwise-arithmetic-shift -6 -1) -3)
+    (test (bitwise-arithmetic-shift -5 -1) -3)
+    (test (bitwise-arithmetic-shift -4 -1) -2)
+    (test (bitwise-arithmetic-shift -3 -1) -2)
+    (test (bitwise-arithmetic-shift -2 -1) -1)
+    (test (bitwise-arithmetic-shift -1 -1) -1)
+    
+    (test (bitwise-reverse-bit-field #b1010010 1 4)    88) ; #b1011000
+          
+    ;;
+    ))
+
diff --git a/collects/tests/r6rs/arithmetic/fixnums.ss b/collects/tests/r6rs/arithmetic/fixnums.ss
new file mode 100644
index 0000000000..5c06c8dae1
--- /dev/null
+++ b/collects/tests/r6rs/arithmetic/fixnums.ss
@@ -0,0 +1,20 @@
+#!r6rs
+
+(library (tests r6rs arithmetic fixnums)
+  (export run-arithmetic-fixnums-tests)
+  (import (rnrs)
+          (tests r6rs test))
+
+  (define (run-arithmetic-fixnums-tests)
+
+    (test/exn (fx- (least-fixnum)) &implementation-restriction)
+
+    (test (fxfirst-bit-set 0)         -1)
+    (test (fxfirst-bit-set 1)         0)
+    (test (fxfirst-bit-set -4)        2)
+
+    (test (fxreverse-bit-field #b1010010 1 4)     88) ; #b1011000
+
+    ;;
+    ))
+
diff --git a/collects/tests/r6rs/arithmetic/flonums.ss b/collects/tests/r6rs/arithmetic/flonums.ss
new file mode 100644
index 0000000000..4bbd951a1f
--- /dev/null
+++ b/collects/tests/r6rs/arithmetic/flonums.ss
@@ -0,0 +1,74 @@
+#!r6rs
+
+(library (tests r6rs arithmetic flonums)
+  (export run-arithmetic-flonums-tests)
+  (import (rnrs)
+          (tests r6rs test))
+
+  (define (try-flonums proc)
+    (proc 0.0)
+    (proc 1.0)
+    (proc -1.0)
+    (proc +inf.0)
+    (proc -inf.0)
+    (proc +nan.0))
+
+  (define (run-arithmetic-flonums-tests)
+
+    (test (fl=? +inf.0 +inf.0)            #t)
+    (test (fl=? -inf.0 +inf.0)            #f)
+    (test (fl=? -inf.0 -inf.0)            #t)
+    (test (fl=? 0.0 -0.0)                 #t)
+    (test (fl<? 0.0 -0.0)                 #f)
+    (try-flonums
+     (lambda (fl)
+       (test (fl=? +nan.0 fl)                #f)
+       (test (fl<? +nan.0 fl)                #f)))
+    
+    (test (flnegative? -0.0)   #f)
+    (test (flfinite? +inf.0)   #f)
+    (test (flfinite? 5.0)      #t)
+    (test (flinfinite? 5.0)    #f)
+    (test (flinfinite? +inf.0) #t)
+    
+    (test (fl+ +inf.0 -inf.0)       +nan.0)
+    (try-flonums 
+     (lambda (fl)
+       (test (fl+ +nan.0 fl)           +nan.0)
+       (test (fl* +nan.0 fl)           +nan.0)))
+
+    (test (fl- +inf.0 +inf.0)       +nan.0)
+    
+    (test (fl/ 1.0 0.0)  +inf.0)
+    (test (fl/ -1.0 0.0) -inf.0)
+    (test (fl/ 0.0 0.0)  +nan.0)
+
+    (test (flnumerator +inf.0)            +inf.0)
+    (test (flnumerator -inf.0)            -inf.0)
+    (test (fldenominator +inf.0)          1.0)
+    (test (fldenominator -inf.0)          1.0)
+    
+    ; (test (flnumerator 0.75)              3.0) ; probably
+    ; (test (fldenominator 0.75)            4.0) ; probably
+
+    (test (flnumerator -0.0)             -0.0)
+    
+    (test (flfloor +inf.0)                        +inf.0)
+    (test (flceiling -inf.0)                      -inf.0)
+    (test (fltruncate +nan.0)                     +nan.0)
+    
+    (test (flexp +inf.0)                +inf.0)
+    (test (flexp -inf.0)                0.0)
+    (test (fllog +inf.0)                +inf.0)
+    (test (fllog 0.0)                   -inf.0)
+    (test/unspec (fllog -0.0)) ; if -0.0 is distinguished
+    (test (fllog -inf.0)                +nan.0)
+    (test/approx (flatan -inf.0)               -1.5707963267948965)
+    (test/approx (flatan +inf.0)               1.5707963267948965)
+
+    (test (flsqrt +inf.0)                +inf.0)
+    (test (flsqrt -0.0)                  -0.0)
+    
+    ;;
+    ))
+
diff --git a/collects/tests/r6rs/bytevectors.ss b/collects/tests/r6rs/bytevectors.ss
new file mode 100644
index 0000000000..ed0be369e2
--- /dev/null
+++ b/collects/tests/r6rs/bytevectors.ss
@@ -0,0 +1,109 @@
+#!r6rs
+
+(library (tests r6rs bytevectors)
+  (export run-bytevectors-tests)
+  (import (rnrs)
+          (tests r6rs test))
+
+  (define (run-bytevectors-tests)
+    
+    (test (let ((b (u8-list->bytevector '(1 2 3 4 5 6 7 8))))
+            (bytevector-copy! b 0 b 3 4)
+            (bytevector->u8-list b)) 
+          '(1 2 3 1 2 3 4 8))
+
+    (test (let ((b1 (make-bytevector 16 -127))
+                (b2 (make-bytevector 16 255)))
+            (list
+             (bytevector-s8-ref b1 0)
+             (bytevector-u8-ref b1 0)
+             (bytevector-s8-ref b2 0)
+             (bytevector-u8-ref b2 0)))
+          '(-127 129 -1 255))
+
+    (test (let ((b (make-bytevector 16 -127)))
+            
+            (bytevector-s8-set! b 0 -126)
+            (bytevector-u8-set! b 1 246)
+            
+            (list
+             (bytevector-s8-ref b 0)
+             (bytevector-u8-ref b 0)
+             (bytevector-s8-ref b 1)
+             (bytevector-u8-ref b 1)))
+          '(-126 130 -10 246))
+
+    (let ([b (make-bytevector 16 -127)])
+      (test/unspec
+       (bytevector-uint-set! b 0 (- (expt 2 128) 3)
+                             (endianness little) 16))
+       
+      (test (bytevector-uint-ref b 0 (endianness little) 16)
+            #xfffffffffffffffffffffffffffffffd)
+
+      (test (bytevector-sint-ref b 0 (endianness little) 16)
+            -3)
+
+      (test (bytevector->u8-list b)
+            '(253 255 255 255 255 255 255 255
+                  255 255 255 255 255 255 255 255))
+
+      (test/unspec (bytevector-uint-set! b 0 (- (expt 2 128) 3)
+                                         (endianness big) 16))
+      (test (bytevector-uint-ref b 0 (endianness big) 16)
+            #xfffffffffffffffffffffffffffffffd)
+
+      (test (bytevector-sint-ref b 0 (endianness big) 16) -3)
+
+      (test (bytevector->u8-list b) 
+            '(255 255 255 255 255 255 255 255
+                  255 255 255 255 255 255 255 253))
+
+      (test
+       (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
+         (bytevector->sint-list b (endianness little) 2)) 
+       '(513 -253 513 513))
+
+      (test (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
+              (bytevector->uint-list b (endianness little) 2)) 
+            '(513 65283 513 513)))
+
+    (let ([b (u8-list->bytevector
+              '(255 255 255 255 255 255 255 255
+                    255 255 255 255 255 255 255 253))])
+      
+      (test (bytevector-u16-ref b 14 (endianness little)) 65023)
+      (test (bytevector-s16-ref b 14 (endianness little)) -513)
+      (test (bytevector-u16-ref b 14 (endianness big)) 65533)
+      (test (bytevector-s16-ref b 14 (endianness big)) -3)
+
+      (test/unspec (bytevector-u16-set! b 0 12345 (endianness little)))
+      (test (bytevector-u16-ref b 0 (endianness little)) 12345)
+      
+      (test/unspec (bytevector-u16-native-set! b 0 12345))
+      (test (bytevector-u16-native-ref b 0) 12345)
+
+      (test/unspec (bytevector-u16-ref b 0 (endianness little))))
+
+    (let ([b (u8-list->bytevector
+              '(255 255 255 255 255 255 255 255
+                    255 255 255 255 255 255 255 253))])
+
+      (test (bytevector-u32-ref b 12 (endianness little)) 4261412863)
+      (test (bytevector-s32-ref b 12 (endianness little)) -33554433)
+      (test (bytevector-u32-ref b 12 (endianness big)) 4294967293)
+      (test (bytevector-s32-ref b 12 (endianness big)) -3))
+
+    (let ([b (u8-list->bytevector
+              '(255 255 255 255 255 255 255 255
+                    255 255 255 255 255 255 255 253))])
+      (test (bytevector-u64-ref b 8 (endianness little)) 18302628885633695743)
+      (test (bytevector-s64-ref b 8 (endianness little)) -144115188075855873)
+      (test (bytevector-u64-ref b 8 (endianness big)) 18446744073709551613)
+      (test (bytevector-s64-ref b 8 (endianness big)) -3))
+
+    ;;
+    ))
+
+
+
diff --git a/collects/tests/r6rs/conditions.ss b/collects/tests/r6rs/conditions.ss
new file mode 100644
index 0000000000..e5bf3478dc
--- /dev/null
+++ b/collects/tests/r6rs/conditions.ss
@@ -0,0 +1,124 @@
+#!r6rs
+
+(library (tests r6rs conditions)
+  (export run-conditions-tests)
+  (import (rnrs)
+          (tests r6rs test))
+
+  ;; ----------------------------------------
+
+  (define-record-type (&cond1 make-cond1 real-cond1?)
+    (parent &condition)
+    (fields
+     (immutable x real-cond1-x)))
+  
+  (define cond1?
+    (condition-predicate
+     (record-type-descriptor &cond1)))
+  (define cond1-x
+    (condition-accessor
+     (record-type-descriptor &cond1)
+     real-cond1-x))
+  
+  (define foo (make-cond1 'foo))
+  
+  (define-record-type (&cond2 make-cond2 real-cond2?)
+    (parent &condition)
+    (fields
+     (immutable y real-cond2-y)))
+
+  (define cond2?
+    (condition-predicate
+     (record-type-descriptor &cond2)))
+  (define cond2-y
+    (condition-accessor
+     (record-type-descriptor &cond2)
+     real-cond2-y))
+
+  (define bar (make-cond2 'bar))
+
+  (define-condition-type &c &condition
+    make-c c?
+    (x c-x))
+
+  (define-condition-type &c1 &c
+    make-c1 c1?
+    (a c1-a))
+
+  (define-condition-type &c2 &c
+    make-c2 c2?
+    (b c2-b))
+
+  (define v1 (make-c1 "V1" "a1"))
+
+  (define v2 (make-c2 "V2" "b2"))
+
+  (define v3 (condition
+              (make-c1 "V3/1" "a3")
+              (make-c2 "V3/2" "b3")))
+
+  (define v4 (condition v1 v2))
+
+  (define v5 (condition v2 v3))
+
+  ;; ----------------------------------------
+
+  (define (run-conditions-tests)
+
+    (test (condition? foo) #t)
+    (test (cond1? foo) #t)
+    (test (cond1-x foo) 'foo)
+
+    (test (condition? (condition foo bar)) #t)
+    (test (cond1? (condition foo bar)) #t)
+    (test (cond2? (condition foo bar)) #t)
+    (test (cond1? (condition foo)) #t)
+    (test/unspec (real-cond1? (condition foo)))
+    (test (real-cond1? (condition foo bar)) #f)
+    (test (cond1-x (condition foo bar)) 'foo)
+    (test (cond2-y (condition foo bar)) 'bar)
+                
+    (test (simple-conditions (condition foo bar))
+          (list foo bar))
+
+    (test (simple-conditions
+           (condition foo (condition bar)))
+          (list foo bar))
+    
+    (test (c? v1)        #t)
+    (test (c1? v1)       #t)
+    (test (c2? v1)       #f)
+    (test (c-x v1)       "V1")
+    (test (c1-a v1)      "a1")
+
+    (test (c? v2)        #t)
+    (test (c1? v2)       #f)
+    (test (c2? v2)       #t)
+    (test (c-x v2)       "V2")
+    (test (c2-b v2)      "b2")
+
+    (test (c? v3)        #t)
+    (test (c1? v3)       #t)
+    (test (c2? v3)       #t)
+    (test (c-x v3)       "V3/1")
+    (test (c1-a v3)      "a3")
+    (test (c2-b v3)      "b3")
+
+    (test (c? v4)        #t)
+    (test (c1? v4)       #t)
+    (test (c2? v4)       #t)
+    (test (c-x v4)       "V1")
+    (test (c1-a v4)      "a1")
+    (test (c2-b v4)      "b2")
+
+    (test (c? v5)        #t)
+    (test (c1? v5)       #t)
+    (test (c2? v5)       #t)
+    (test (c-x v5)       "V2")
+    (test (c1-a v5)      "a3")
+    (test (c2-b v5)      "b2")
+
+    
+    ;;
+    ))
+
diff --git a/collects/tests/r6rs/control.ss b/collects/tests/r6rs/control.ss
new file mode 100644
index 0000000000..9f4212d470
--- /dev/null
+++ b/collects/tests/r6rs/control.ss
@@ -0,0 +1,43 @@
+#!r6rs
+
+(library (tests r6rs control)
+  (export run-control-tests)
+  (import (rnrs)
+          (tests r6rs test))
+
+  (define (run-control-tests)
+
+    (test (when (> 3 2) 'greater) 'greater)
+    (test/unspec (when (< 3 2) 'greater))
+    (test/unspec (unless (> 3 2) 'less))
+    (test (unless (< 3 2) 'less) 'less)
+
+    (test (do ((vec (make-vector 5))
+               (i 0 (+ i 1)))
+              ((= i 5) vec)
+            (vector-set! vec i i))
+          '#(0 1 2 3 4))
+
+    (test (let ((x '(1 3 5 7 9)))
+            (do ((x x (cdr x))
+                 (sum 0 (+ sum (car x))))
+                ((null? x) sum)))
+          25)
+
+    (let ([foo
+           (case-lambda 
+            (() 'zero)
+            ((x) (list 'one x))
+            ((x y) (list 'two x y))
+            ((a b c d . e) (list 'four a b c d e))
+            (rest (list 'rest rest)))])
+
+      (test (foo) 'zero)
+      (test (foo 1) '(one 1))
+      (test (foo 1 2) '(two 1 2))
+      (test (foo 1 2 3) '(rest (1 2 3)))
+      (test (foo 1 2 3 4) '(four 1 2 3 4 ())))
+      
+    ;;
+    ))
+
diff --git a/collects/tests/r6rs/enums.ss b/collects/tests/r6rs/enums.ss
new file mode 100644
index 0000000000..65943f05ef
--- /dev/null
+++ b/collects/tests/r6rs/enums.ss
@@ -0,0 +1,63 @@
+#!r6rs
+
+(library (tests r6rs enums)
+  (export run-enums-tests)
+  (import (rnrs)
+          (tests r6rs test))
+
+  ;; ----------------------------------------
+
+  (define-enumeration color
+    (black white purple maroon)
+    color-set)
+  
+  ;; ----------------------------------------
+
+  (define (run-enums-tests)
+    
+    (test (let* ((e (make-enumeration '(red green blue)))
+                 (i (enum-set-indexer e)))
+            (list (i 'red) (i 'green) (i 'blue) (i 'yellow)))
+          '(0 1 2 #f))
+
+    (test (let* ((e (make-enumeration '(red green blue)))
+                 (c (enum-set-constructor e)))
+            (enum-set->list (c '(blue red)))) 
+          '(red blue))
+
+    (test (let* ((e (make-enumeration '(red green blue)))
+                 (c (enum-set-constructor e)))
+            (list (enum-set->list
+                   (enum-set-union (c '(blue)) (c '(red))))
+                  (enum-set->list
+                   (enum-set-intersection (c '(red green))
+                                          (c '(red blue))))
+                  (enum-set->list
+                   (enum-set-difference (c '(red green))
+                                        (c '(red blue))))))
+          '((red blue) (red) (green)))
+
+    (test (let* ((e (make-enumeration '(red green blue)))
+                 (c (enum-set-constructor e)))
+            (enum-set->list
+             (enum-set-complement (c '(red)))))
+          '(green blue))
+
+    (test (let ((e1 (make-enumeration
+                     '(red green blue black)))
+                (e2 (make-enumeration
+                     '(red black white))))
+            (enum-set->list
+             (enum-set-projection e1 e2)))
+          '(red black))
+
+    (test (color black)                      'black)
+    ; (test/exn (color purpel) &syntax) ; not a runtime exception
+    (test (enum-set->list (color-set))       '())
+    (test (enum-set->list
+           (color-set maroon white)) 
+          '(white maroon))
+
+    ;;
+    ))
+
diff --git a/collects/tests/r6rs/exceptions.ss b/collects/tests/r6rs/exceptions.ss
new file mode 100644
index 0000000000..7067c27d20
--- /dev/null
+++ b/collects/tests/r6rs/exceptions.ss
@@ -0,0 +1,74 @@
+#!r6rs
+
+(library (tests r6rs exceptions)
+  (export run-exceptions-tests)
+  (import (rnrs)
+          (tests r6rs test))
+
+  (define (run-exceptions-tests)
+
+    (test/output
+     (guard (con
+             ((error? con)
+              (if (message-condition? con)
+                  (display (condition-message con))
+                  (display "an error has occurred"))
+              'error)
+             ((violation? con)
+              (if (message-condition? con)
+                  (display (condition-message con))
+                  (display "the program has a bug"))
+              'violation))
+            (raise
+             (condition
+              (make-error)
+              (make-message-condition "I am an error"))))
+     'error
+     "I am an error")
+
+    (test/exn
+     (guard (con
+             ((error? con)
+              (if (message-condition? con)
+                  (display (condition-message con))
+                  (display "an error has occurred"))
+              'error))
+            (raise
+             (condition
+              (make-violation)
+              (make-message-condition "I am an error"))))
+     &violation)
+
+    (test/output
+     (guard (con
+             ((error? con)
+              (display "error opening file")
+              #f))
+            (call-with-input-file "foo-must-not-exist.scm" read))
+     #f
+     "error opening file")
+
+    (test/output
+     (with-exception-handler
+      (lambda (con)
+        (cond
+         ((not (warning? con))
+          (raise con))
+         ((message-condition? con)
+          (display (condition-message con)))
+         (else
+          (display "a warning has been issued")))
+        42)
+      (lambda ()
+        (+ (raise-continuable
+            (condition
+             (make-warning)
+             (make-message-condition
+              "should be a number")))
+           23)))
+     65
+     "should be a number")
+      
+    ;;
+    ))
+
diff --git a/collects/tests/r6rs/hashtables.ss b/collects/tests/r6rs/hashtables.ss
new file mode 100644
index 0000000000..a26fc4e7b3
--- /dev/null
+++ b/collects/tests/r6rs/hashtables.ss
@@ -0,0 +1,31 @@
+#!r6rs
+
+(library (tests r6rs hashtables)
+  (export run-hashtables-tests)
+  (import (rnrs)
+          (tests r6rs test))
+
+  (define (run-hashtables-tests)
+
+    (let-values ([(kv vv)
+                  (let ((h (make-eqv-hashtable)))
+                    (hashtable-set! h 1 'one)
+                    (hashtable-set! h 2 'two)
+                    (hashtable-set! h 3 'three)
+                    (hashtable-entries h))])
+      (test (or (equal? (cons kv vv)
+                        '(#(1 2 3)  . #(one two three)))
+                (equal? (cons kv vv)
+                        '(#(1 3 2)  . #(one three two)))
+                (equal? (cons kv vv)
+                        '(#(2 1 3)  . #(two one three)))
+                (equal? (cons kv vv)
+                        '(#(2 3 1)  . #(two three one)))
+                (equal? (cons kv vv)
+                        '(#(3 1 2)  . #(three one two)))
+                (equal? (cons kv vv)
+                        '(#(3 2 1)  . #(three two one))))
+            #t))
+    ;;
+    ))
+
diff --git a/collects/tests/r6rs/io/ports.ss b/collects/tests/r6rs/io/ports.ss
new file mode 100644
index 0000000000..0fdc5341b8
--- /dev/null
+++ b/collects/tests/r6rs/io/ports.ss
@@ -0,0 +1,15 @@
+#!r6rs
+
+(library (tests r6rs io ports)
+  (export run-io-ports-tests)
+  (import (rnrs)
+          (tests r6rs test))
+
+  (define (run-io-ports-tests)
+
+    (test (eqv? (eof-object) (eof-object)) #t)
+    (test (eq? (eof-object) (eof-object)) #t)
+
+    ;;
+    ))
+
diff --git a/collects/tests/r6rs/lists.ss b/collects/tests/r6rs/lists.ss
new file mode 100644
index 0000000000..24a8b6f309
--- /dev/null
+++ b/collects/tests/r6rs/lists.ss
@@ -0,0 +1,109 @@
+#!r6rs
+
+(library (tests r6rs lists)
+  (export run-lists-tests)
+  (import (rnrs)
+          (tests r6rs test))
+
+  (define (run-lists-tests)
+
+    (test (find even? '(3 1 4 1 5 9)) 4)
+    (test (find even? '(3 1 5 1 5 9)) #f)
+    
+    (test (for-all even? '(3 1 4 1 5 9)) #f)
+    (test (for-all even? '(3 1 4 1 5 9 . 2)) #f)
+    (test (for-all even? '(2 4 14)) #t)
+    (test/exn (for-all even? '(2 4 14 . 9)) &assertion)
+    (test (for-all (lambda (n) (and (even? n) n))
+                   '(2 4 14)) 
+          14)
+    (test (for-all < '(1 2 3) '(2 3 4)) #t)
+    (test (for-all < '(1 2 4) '(2 3 4)) #f)
+    
+    (test (exists even? '(3 1 4 1 5 9)) #t)
+    (test (exists even? '(3 1 1 5 9)) #f)
+    (test/exn (exists even? '(3 1 1 5 9 . 2)) &assertion)
+    (test (exists (lambda (n) (and (even? n) n)) '(2 1 4 14)) 2)
+    (test (exists < '(1 2 4) '(2 3 4)) #t)
+    (test (exists > '(1 2 3) '(2 3 4)) #f)
+
+    (test (filter even? '(3 1 4 1 5 9 2 6)) '(4 2 6))
+
+    (test/values (partition even? '(3 1 4 1 5 9 2 6)) '(4 2 6) '(3 1 1 5 9))
+
+    (test (fold-left + 0 '(1 2 3 4 5)) 15)
+
+    (test (fold-left (lambda (a e) (cons e a)) '()
+                     '(1 2 3 4 5)) 
+          '(5 4 3 2 1))
+
+    (test (fold-left (lambda (count x)
+                       (if (odd? x) (+ count 1) count))
+                     0
+                     '(3 1 4 1 5 9 2 6 5 3)) 
+          7)
+    (test (fold-left (lambda (max-len s)
+                       (max max-len (string-length s)))
+                     0
+                     '("longest" "long" "longer")) 
+          7)
+
+    (test (fold-left cons '(q) '(a b c)) '((((q) . a) . b) . c))
+    
+    (test (fold-left + 0 '(1 2 3) '(4 5 6)) 21)
+    
+    (test (fold-right + 0 '(1 2 3 4 5)) 15)
+    
+    (test (fold-right cons '() '(1 2 3 4 5)) '(1 2 3 4 5))
+    
+    (test (fold-right (lambda (x l)
+                        (if (odd? x) (cons x l) l))
+                      '()
+                      '(3 1 4 1 5 9 2 6 5))
+          '(3 1 1 5 9 5))
+
+    (test (fold-right cons '(q) '(a b c)) '(a b c q))
+
+    (test (fold-right + 0 '(1 2 3) '(4 5 6)) 21)
+    
+    (test (remp even? '(3 1 4 1 5 9 2 6 5)) '(3 1 1 5 9 5))
+
+    (test (remove 1 '(3 1 4 1 5 9 2 6 5)) '(3 4 5 9 2 6 5))
+    
+    (test (remv 1 '(3 1 4 1 5 9 2 6 5)) '(3 4 5 9 2 6 5))
+    
+    (test (remq 'foo '(bar foo baz)) '(bar baz))
+    
+    (test (memp even? '(3 1 4 1 5 9 2 6 5)) '(4 1 5 9 2 6 5))
+    
+    (test (memq 'a '(a b c))               '(a b c))
+    (test (memq 'b '(a b c))               '(b c))
+    (test (memq 'a '(b c d))               #f)
+    (test (memq (list 'a) '(b (a) c))      #f)
+    (test (member (list 'a) '(b (a) c))   '((a) c))
+    (test/unspec (memq 101 '(100 101 102)))
+    (test (memv 101 '(100 101 102)) '(101 102))
+
+    (let ([d '((3 a) (1 b) (4 c))])
+      (test (assp even? d) '(4 c))
+      (test (assp odd? d) '(3 a)))
+
+    (let ([e '((a 1) (b 2) (c 3))])
+      (test (assq 'a e)      '(a 1))
+      (test (assq 'b e)      '(b 2))
+      (test (assq 'd e)      #f))
+
+
+    (test (assq (list 'a) '(((a)) ((b)) ((c))))
+          #f)
+    (test (assoc (list 'a) '(((a)) ((b)) ((c))))   
+          '((a)))
+    (test/unspec (assq 5 '((2 3) (5 7) (11 13))))
+    (test (assv 5 '((2 3) (5 7) (11 13))) '(5 7))
+
+    (test (cons* 1 2 '(3 4 5)) '(1 2 3 4 5))
+    (test (cons* 1 2 3) '(1 2 . 3))
+    (test (cons* 1) 1)
+
+    ;;
+    ))
diff --git a/collects/tests/r6rs/records/procedural.ss b/collects/tests/r6rs/records/procedural.ss
new file mode 100644
index 0000000000..b1e68c3e55
--- /dev/null
+++ b/collects/tests/r6rs/records/procedural.ss
@@ -0,0 +1,166 @@
+#!r6rs
+
+(library (tests r6rs records procedural)
+  (export run-records-procedural-tests)
+  (import (rnrs)
+          (tests r6rs test))
+
+  ;; ----------------------------------------
+
+  (define rtd1
+    (make-record-type-descriptor
+     'rtd1 #f #f #f #f
+     '#((immutable x1) (immutable x2))))
+  
+  (define rtd2
+    (make-record-type-descriptor
+     'rtd2 rtd1 #f #f #f
+     '#((immutable x3) (immutable x4))))
+  
+  (define rtd3
+    (make-record-type-descriptor
+     'rtd3 rtd2 #f #f #f
+     '#((immutable x5) (immutable x6))))
+  
+  (define protocol1
+    (lambda (p)
+      (lambda (a b c)
+        (p (+ a b) (+ b c)))))
+  
+  (define protocol2
+    (lambda (n)
+      (lambda (a b c d e f)
+        (let ((p (n a b c)))
+          (p (+ d e) (+ e f))))))
+  
+  (define protocol3
+    (lambda (n)
+      (lambda (a b c d e f g h i)
+        (let ((p (n a b c d e f)))
+          (p (+ g h) (+ h i))))))
+  
+  (define cd1
+    (make-record-constructor-descriptor
+     rtd1 #f protocol1))
+  
+  (define cd2
+    (make-record-constructor-descriptor
+     rtd2 cd1 protocol2))
+  
+  (define cd3
+    (make-record-constructor-descriptor
+     rtd3 cd2 protocol3))
+  
+  (define make-rtd1 (record-constructor cd1))
+  
+  (define make-rtd2 (record-constructor cd2))
+  
+  (define make-rtd3 (record-constructor cd3))
+  
+  
+  (define :point
+    (make-record-type-descriptor
+     'point #f
+     #f #f #f 
+     '#((mutable x) (mutable y))))
+
+  (define :point-cd
+    (make-record-constructor-descriptor :point #f #f))
+  
+  (define make-point (record-constructor :point-cd))
+  
+  (define point? (record-predicate :point))
+  (define point-x (record-accessor :point 0))
+  (define point-y (record-accessor :point 1))
+  (define point-x-set! (record-mutator :point 0))
+  (define point-y-set! (record-mutator :point 1))
+  
+  (define p1 (make-point 1 2))
+
+  (define :point2
+    (make-record-type-descriptor
+     'point2 :point 
+     #f #f #f '#((mutable x) (mutable y))))
+  
+  (define make-point2
+    (record-constructor
+     (make-record-constructor-descriptor :point2
+                                         #f #f)))
+  (define point2? (record-predicate :point2))
+  (define point2-xx (record-accessor :point2 0))
+  (define point2-yy (record-accessor :point2 1))
+
+  (define p2 (make-point2 1 2 3 4))
+
+  (define :point-cd/abs
+    (make-record-constructor-descriptor
+     :point #f
+     (lambda (new)
+       (lambda (x y)
+         (new (abs x) (abs y))))))
+  
+  (define make-point/abs
+    (record-constructor :point-cd/abs))
+  
+  (define :cpoint
+    (make-record-type-descriptor
+     'cpoint :point
+     #f #f #f
+     '#((mutable rgb))))
+  
+  (define make-cpoint
+    (record-constructor
+     (make-record-constructor-descriptor
+      :cpoint :point-cd
+      (lambda (p)
+        (lambda (x y c)
+          ((p x y) (color->rgb c)))))))
+
+  (define make-cpoint/abs
+    (record-constructor
+     (make-record-constructor-descriptor
+      :cpoint :point-cd/abs
+      (lambda (p)
+        (lambda (x y c)
+          ((p x y) (color->rgb c)))))))
+  
+  (define cpoint-rgb
+    (record-accessor :cpoint 0))
+  
+  (define (color->rgb c)
+    (cons 'rgb c))
+  
+  ;; ----------------------------------------
+
+  (define (run-records-procedural-tests)
+
+    (let ([r (make-rtd3 1 2 3 4 5 6 7 8 9)])
+      (test ((record-accessor rtd1 0) r) 3)
+      (test ((record-accessor rtd1 1) r) 5)
+      (test ((record-accessor rtd2 0) r) 9)
+      (test ((record-accessor rtd2 1) r) 11)
+      (test ((record-accessor rtd3 0) r) 15)
+      (test ((record-accessor rtd3 1) r) 17))
+    
+    (test (point? p1) #t)
+    (test (point-x p1) 1)
+    (test (point-y p1) 2)
+    (test/unspec (point-x-set! p1 5))
+    (test (point-x p1) 5)
+    
+    (test (point? p2) #t)
+    (test (point-x p2) 1)
+    (test (point-y p2) 2)
+    (test (point2-xx p2) 3)
+    (test (point2-yy p2) 4)
+    
+    (test (point-x (make-point/abs -1 -2)) 1)
+    (test (point-y (make-point/abs -1 -2)) 2)
+    
+    (test (cpoint-rgb (make-cpoint -1 -3 'red)) '(rgb . red))
+    (test (point-x (make-cpoint -1 -3 'red)) -1)
+    (test (point-x (make-cpoint/abs -1 -3 'red)) 1)
+    
+    ;;
+    ))
+
diff --git a/collects/tests/r6rs/records/syntactic.ss b/collects/tests/r6rs/records/syntactic.ss
new file mode 100644
index 0000000000..8b4ff694eb
--- /dev/null
+++ b/collects/tests/r6rs/records/syntactic.ss
@@ -0,0 +1,114 @@
+#!r6rs
+
+(library (tests r6rs records syntactic)
+  (export run-records-syntactic-tests)
+  (import (rnrs)
+          (tests r6rs test))
+
+  ;; ----------------------------------------
+
+  (define-record-type (point make-point point?)
+    (fields (immutable x point-x)
+            (mutable y point-y set-point-y!))
+    (nongenerative
+     point-4893d957-e00b-11d9-817f-00111175eb9e))
+  
+  (define-record-type (cpoint make-cpoint cpoint?)
+    (parent point)
+    (protocol
+     (lambda (n)
+       (lambda (x y c) 
+         ((n x y) (color->rgb c)))))
+    (fields
+     (mutable rgb cpoint-rgb cpoint-rgb-set!)))
+  
+  (define (color->rgb c)
+    (cons 'rgb c))
+  
+  (define p1 (make-point 1 2))
+  (define p2 (make-cpoint 3 4 'red))
+
+  (define-record-type (ex1 make-ex1 ex1?)
+    (protocol (lambda (p) (lambda a (p a))))
+    (fields (immutable f ex1-f)))
+  
+  (define ex1-i1 (make-ex1 1 2 3))
+
+  (define-record-type (ex2 make-ex2 ex2?)
+    (protocol
+     (lambda (p) (lambda (a . b) (p a b))))
+    (fields (immutable a ex2-a)
+            (immutable b ex2-b)))
+  
+  (define ex2-i1 (make-ex2 1 2 3))
+
+  (define-record-type (unit-vector
+                       make-unit-vector
+                       unit-vector?)
+    (protocol
+     (lambda (p)
+       (lambda (x y z)
+         (let ((length 
+                (sqrt (+ (* x x)
+                         (* y y)
+                         (* z z)))))
+           (p (/ x length)
+              (/ y length)
+              (/ z length))))))
+    (fields (immutable x unit-vector-x)
+            (immutable y unit-vector-y)
+            (immutable z unit-vector-z)))
+  
+  (define *ex3-instance* #f)
+  
+  (define-record-type ex3
+    (parent cpoint)
+    (protocol
+     (lambda (n)
+       (lambda (x y t)
+         (let ((r ((n x y 'red) t)))
+           (set! *ex3-instance* r)
+           r))))
+    (fields 
+     (mutable thickness))
+    (sealed #t) (opaque #t))
+  
+  (define ex3-i1 (make-ex3 1 2 17))
+  
+  ;; ----------------------------------------
+
+  (define (run-records-syntactic-tests)
+    (test (point? p1) #t)
+    (test (point? p2) #t)
+    (test (point? (vector)) #f)
+    (test (point? (cons 'a 'b)) #f)
+    (test (cpoint? p1) #f)
+    (test (cpoint? p2) #t)
+    (test (point-x p1) 1)
+    (test (point-y p1) 2)
+    (test (point-x p2) 3)
+    (test (point-y p2) 4)
+    (test (cpoint-rgb p2) '(rgb . red))
+
+    (test/unspec (set-point-y! p1 17))
+    (test (point-y p1) 17)
+
+    (test (record-rtd p1) (record-type-descriptor point))
+    
+    (test (ex1-f ex1-i1) '(1 2 3))
+
+    (test (ex2-a ex2-i1) 1)
+    (test (ex2-b ex2-i1) '(2 3))
+
+    (test (ex3? ex3-i1) #t)
+    (test (cpoint-rgb ex3-i1) '(rgb . red))
+    (test (ex3-thickness ex3-i1) 17)
+    (test/unspec (ex3-thickness-set! ex3-i1 18))
+    (test (ex3-thickness ex3-i1) 18)
+    (test *ex3-instance* ex3-i1)
+
+    (test (record? ex3-i1) #f)
+      
+    ;;
+    ))
+
diff --git a/collects/tests/r6rs/run.ss b/collects/tests/r6rs/run.ss
index 8794175999..6a5007edaf 100644
--- a/collects/tests/r6rs/run.ss
+++ b/collects/tests/r6rs/run.ss
@@ -2,8 +2,42 @@
 
 (import (rnrs)
         (tests r6rs test)
-        (tests r6rs base))
+        (tests r6rs base)
+        (tests r6rs unicode)
+        (tests r6rs bytevectors)
+        (tests r6rs lists)
+        (tests r6rs sorting)
+        (tests r6rs control)
+        (tests r6rs records syntactic)
+        (tests r6rs records procedural)
+        (tests r6rs exceptions)
+        (tests r6rs conditions)
+        (tests r6rs io ports)
+        (tests r6rs arithmetic fixnums)
+        (tests r6rs arithmetic flonums)
+        (tests r6rs arithmetic bitwise)
+        (tests r6rs syntax-case)
+        (tests r6rs hashtables)
+        (tests r6rs enums))
 
 (run-base-tests)
+
+(run-unicode-tests)
+(run-bytevectors-tests)
+(run-lists-tests)
+(run-sorting-tests)
+(run-control-tests)
+(run-records-syntactic-tests)
+(run-records-procedural-tests)
+(run-exceptions-tests)
+(run-conditions-tests)
+(run-io-ports-tests)
+(run-arithmetic-fixnums-tests)
+(run-arithmetic-flonums-tests)
+(run-arithmetic-bitwise-tests)
+(run-syntax-case-tests)
+(run-hashtables-tests)
+(run-enums-tests)
+
 (report-test-results)
 
diff --git a/collects/tests/r6rs/sorting.ss b/collects/tests/r6rs/sorting.ss
new file mode 100644
index 0000000000..e5fdc0db1d
--- /dev/null
+++ b/collects/tests/r6rs/sorting.ss
@@ -0,0 +1,19 @@
+#!r6rs
+
+(library (tests r6rs sorting)
+  (export run-sorting-tests)
+  (import (rnrs)
+          (tests r6rs test))
+
+  (define (run-sorting-tests)
+
+    (test (list-sort < '(3 5 2 1)) '(1 2 3 5))
+    (test (vector-sort < '#(3 5 2 1)) '#(1 2 3 5))
+
+    (let ([v (vector 3 5 2 1)])
+      (test/unspec (vector-sort! < v))
+      (test v '#(1 2 3 5)))
+
+    ;;
+    ))
+
diff --git a/collects/tests/r6rs/syntax-case.ss b/collects/tests/r6rs/syntax-case.ss
new file mode 100644
index 0000000000..64bb4442c6
--- /dev/null
+++ b/collects/tests/r6rs/syntax-case.ss
@@ -0,0 +1,105 @@
+#!r6rs
+
+(library (tests r6rs syntax-case)
+  (export run-syntax-case-tests)
+  (import (for (rnrs) run expand)
+          (tests r6rs test))
+
+  ;; ----------------------------------------
+  
+  (define p (cons 4 5))
+  (define-syntax p.car
+    (lambda (x)
+      (syntax-case x ()
+        [(_ . rest) #'((car p) . rest)]
+        [_  #'(car p)])))
+
+  ;; Different frmo the report to avoid set-car!
+  (define p2 (cons 4 5))
+  (define-syntax p2.car
+    (make-variable-transformer
+     (lambda (x)
+       (syntax-case x (set!)
+         [(set! _ e) #'(set! p2 (cons e (cdr p2)))]
+         [(_ . rest) #'((car p2) . rest)]
+         [_  #'(car p2)]))))
+  
+  (define-syntax rec
+    (lambda (x)
+      (syntax-case x ()
+        [(_ x e)
+         (identifier? #'x)
+         #'(letrec ([x e]) x)])))
+
+  (define-syntax loop
+    (lambda (x)
+      (syntax-case x ()
+        [(k e ...)
+         (with-syntax
+             ([break (datum->syntax #'k 'break)])
+           #'(call-with-current-continuation
+              (lambda (break)
+                (let f () e ... (f)))))])))
+
+  ;; ----------------------------------------
+  
+  (define (run-syntax-case-tests)
+
+    (test p.car 4)
+    ;; (test/exn (set! p.car 15) &syntax) ; not a runtime exception
+
+    (set! p2.car 15)
+    (test p2.car 15)
+    (test p2 '(15 . 5))
+    
+    (test (map (rec fact
+                    (lambda (n)
+                      (if (= n 0)                 
+                          1
+                          (* n (fact (- n 1))))))
+               '(1 2 3 4 5))
+          '(1 2 6 24 120))
+    
+    ; (test/exn (rec 5 (lambda (x) x)) &syntax) ; not a runtime exception
+    
+    (test
+     (let ([fred 17])
+       (define-syntax a
+         (lambda (x)
+           (syntax-case x ()
+             [(_ id) #'(b id fred)])))
+       (define-syntax b
+         (lambda (x)
+           (syntax-case x ()
+             [(_ id1 id2)
+              #`(list
+                   #,(free-identifier=? #'id1 #'id2)
+                   #,(bound-identifier=? #'id1 #'id2))])))
+       (a fred)) 
+     '(#t #f))
+
+    ; (test/exn (let ([a 3] [a 4]) (+ a a)) &syntax)
+
+    (test (let-syntax
+              ([dolet (lambda (x)
+                        (syntax-case x ()
+                          [(_ b)
+                           #'(let ([a 3] [b 4]) (+ a b))]))])
+            (dolet a)) 
+          7)
+
+    #;
+    (test/exn (let ([else #f])
+                (case 0 [else (write "oops")])) 
+              &syntax)
+
+    (test (let ((n 3) (ls '()))
+            (loop
+             (if (= n 0) (break ls))
+             (set! ls (cons 'a ls))
+             (set! n (- n 1)))) 
+          '(a a a))
+    
+    ;;
+    ))
+
diff --git a/collects/tests/r6rs/unicode.ss b/collects/tests/r6rs/unicode.ss
new file mode 100644
index 0000000000..af42ce5550
--- /dev/null
+++ b/collects/tests/r6rs/unicode.ss
@@ -0,0 +1,85 @@
+#!r6rs
+
+(library (tests r6rs unicode)
+  (export run-unicode-tests)
+  (import (rnrs)
+          (tests r6rs test))
+
+  (define (run-unicode-tests)
+
+    (test (char-upcase #\i) #\I)
+    (test (char-downcase #\i) #\i)
+    (test (char-titlecase #\i) #\I)
+    (test (char-foldcase #\i) #\i)
+    
+    (test (char-upcase #\xDF) #\xDF)
+    (test (char-downcase #\xDF) #\xDF)
+    (test (char-titlecase #\xDF) #\xDF)
+    (test (char-foldcase #\xDF) #\xDF)
+    
+    (test (char-upcase #\x3A3) #\x3A3)
+    (test (char-downcase #\x3A3) #\x3C3)
+    (test (char-titlecase #\x3A3) #\x3A3)
+    (test (char-foldcase #\x3A3) #\x3C3)
+
+    (test (char-upcase #\x3C2) #\x3A3)
+    (test (char-downcase #\x3C2) #\x3C2)
+    (test (char-titlecase #\x3C2) #\x3A3)
+    (test (char-foldcase #\x3C2) #\x3C3)
+
+    (test (char-ci<? #\z #\Z) #f)
+    (test (char-ci=? #\z #\Z) #t)
+    (test (char-ci=? #\x3C2 #\x3C3) #t)
+
+    (test (char-alphabetic? #\a) #t)
+    (test (char-numeric? #\1) #t)
+    (test (char-whitespace? #\space) #t)
+    (test (char-whitespace? #\x00A0) #t)
+    (test (char-upper-case? #\x3A3) #t)
+    (test (char-lower-case? #\x3C3) #t)
+    (test (char-lower-case? #\x00AA) #t)
+    (test (char-title-case? #\I) #f)
+    (test (char-title-case? #\x01C5) #t)
+
+    (test (char-general-category #\a) 'Ll)
+    (test (char-general-category #\space) 'Zs)
+    (test (char-general-category #\x10FFFF) 'Cn)
+
+    (test (string-upcase "Hi") "HI")
+    (test (string-downcase "Hi") "hi")
+    (test (string-foldcase "Hi") "hi")
+
+    (test (string-upcase "Stra\xDF;e") "STRASSE")
+    (test (string-downcase "Stra\xDF;e") "stra\xDF;e")
+    (test (string-foldcase "Stra\xDF;e") "strasse")
+    (test (string-downcase "STRASSE")  "strasse")
+    
+    (test (string-downcase "\x3A3;") "\x3C3;")
+
+    (test (string-upcase "\x39E;\x391;\x39F;\x3A3;") "\x39E;\x391;\x39F;\x3A3;")
+    (test (string-downcase "\x39E;\x391;\x39F;\x3A3;") "\x3BE;\x3B1;\x3BF;\x3C2;")
+    (test (string-downcase "\x39E;\x391;\x39F;\x3A3;\x3A3;") "\x3BE;\x3B1;\x3BF;\x3C3;\x3C2;")
+    (test (string-downcase "\x39E;\x391;\x39F;\x3A3; \x3A3;") "\x3BE;\x3B1;\x3BF;\x3C2; \x3C3;")
+    (test (string-foldcase "\x39E;\x391;\x39F;\x3A3;") "\x3BE;\x3B1;\x3BF;\x3C3;")
+    (test (string-upcase "\x3BE;\x3B1;\x3BF;\x3C3;") "\x39E;\x391;\x39F;\x3A3;") 
+    (test (string-upcase "\x3BE;\x3B1;\x3BF;\x3C2;") "\x39E;\x391;\x39F;\x3A3;") 
+
+    (test (string-titlecase "kNock KNoCK") "Knock Knock")
+    (test (string-titlecase "who's there?") "Who's There?")
+    (test (string-titlecase "r6rs") "R6Rs")
+    (test (string-titlecase "R6RS") "R6Rs")
+
+    (test (string-ci<? "z" "Z") #f)
+    (test (string-ci=? "z" "Z") #t)
+    (test (string-ci=? "Stra\xDF;e" "Strasse") #t)
+    (test (string-ci=? "Stra\xDF;e" "STRASSE") #t)
+    (test (string-ci=? "\x39E;\x391;\x39F;\x3A3;" "\x3BE;\x3B1;\x3BF;\x3C2;") #t)
+    (test (string-ci=? "\x39E;\x391;\x39F;\x3A3;" "\x3BE;\x3B1;\x3BF;\x3C3;") #t)
+
+    (test (string-normalize-nfd "\xE9;") "\x65;\x301;")
+    (test (string-normalize-nfc "\xE9;") "\xE9;")
+    (test (string-normalize-nfd "\x65;\x301;") "\x65;\x301;")
+    (test (string-normalize-nfc "\x65;\x301;") "\xE9;")
+
+    ;;
+    ))
diff --git a/src/mzscheme/src/number.c b/src/mzscheme/src/number.c
index cde7b59b2e..17ab4787f3 100644
--- a/src/mzscheme/src/number.c
+++ b/src/mzscheme/src/number.c
@@ -1348,7 +1348,7 @@ static Scheme_Object *get_frac(char *name, int low_p,
     if (MZ_IS_NAN(d)
         || MZ_IS_POS_INFINITY(d)
         || MZ_IS_NEG_INFINITY(d)) {
-      scheme_wrong_type(name, REAL_NUMBER_STR, 0, argc, argv);
+      scheme_wrong_type(name, "rational number", 0, argc, argv);
       ESCAPED_BEFORE_HERE;
     }
     
@@ -1368,7 +1368,7 @@ static Scheme_Object *get_frac(char *name, int low_p,
     else
       n = scheme_rational_numerator(n);
   } else {
-    scheme_wrong_type(name, REAL_NUMBER_STR, 0, argc, argv);
+    scheme_wrong_type(name, "rational number", 0, argc, argv);
     ESCAPED_BEFORE_HERE;   
   }