From 8ffe707b7693f7fb433a0ae2eab757ee2e96860a Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 29 Feb 2008 02:37:00 +0000
Subject: [PATCH] more r6rs work

svn: r8825
---
 collects/r6rs/main.ss                         |  49 ++++---
 collects/r6rs/private/io-conds.ss             |   2 +-
 collects/r6rs/private/num-inline.ss           |  88 ++++++++++++
 collects/rnrs/arithmetic/bitwise-6.ss         |  55 +++++++-
 collects/rnrs/arithmetic/fixnums-6.ss         | 128 +++++++-----------
 collects/rnrs/arithmetic/flonums-6.ss         | 102 ++++++++++++++
 collects/rnrs/base-6.ss                       |   2 +-
 collects/rnrs/bytevectors-6.ss                |  26 ++--
 collects/rnrs/io/ports-6.ss                   |  16 ++-
 collects/rnrs/main-6.ss                       |  33 +++++
 collects/rnrs/main.ss                         |   7 +
 collects/rnrs/mutable-strings-6.ss            |   3 +
 collects/rnrs/r5rs-6.ss                       |  15 ++
 collects/scheme/mpair.ss                      |  34 +++--
 .../scribblings/reference/stx-trans.scrbl     |  12 +-
 15 files changed, 438 insertions(+), 134 deletions(-)
 create mode 100644 collects/r6rs/private/num-inline.ss
 create mode 100644 collects/rnrs/arithmetic/flonums-6.ss
 create mode 100644 collects/rnrs/main-6.ss
 create mode 100644 collects/rnrs/main.ss
 create mode 100644 collects/rnrs/mutable-strings-6.ss
 create mode 100644 collects/rnrs/r5rs-6.ss

diff --git a/collects/r6rs/main.ss b/collects/r6rs/main.ss
index 34b821fda6..4918113b63 100644
--- a/collects/r6rs/main.ss
+++ b/collects/r6rs/main.ss
@@ -297,33 +297,34 @@ FIXME:
                              (syntax-case* im (for) symbolic-identifier=?
                                [(for base-im level ...)
                                 (let* ([levels
-                                        (map (lambda (level)
-                                               (syntax-case* level (run expand meta) symbolic-identifier=?
-                                                 [run #'0]
-                                                 [expand #'1]
-                                                 [(meta 0) #'0]
-                                                 [(meta n) #'n]
-                                                 [_
-                                                  (raise-syntax-error
-                                                   #f
-                                                   "bad `for' level"
-                                                   orig
-                                                   level)]))
-                                             (syntax->list #'(level ...)))])
+                                        (cons
+                                         #f
+                                         (map (lambda (level)
+                                                (syntax-case* level (run expand meta) symbolic-identifier=?
+                                                  [run #'0]
+                                                  [expand #'1]
+                                                  [(meta 0) #'0]
+                                                  [(meta n) #'n]
+                                                  [_
+                                                   (raise-syntax-error
+                                                    #f
+                                                    "bad `for' level"
+                                                    orig
+                                                    level)]))
+                                              (syntax->list #'(level ...))))])
                                   (with-syntax ([is (parse-import-set orig #'base-im)])
-                                    (if (null? levels)
-                                        #'()
-                                        (with-syntax ([(level ...) levels]
-                                                      [prelims (datum->syntax orig
-                                                                              'r6rs/private/prelims)])
-                                          #`((for-meta level is prelims) ...)))))]
+                                    (with-syntax ([(level ...) levels]
+                                                  [prelims (datum->syntax orig
+                                                                          'r6rs/private/prelims)])
+                                      #`((for-meta level is prelims) ...))))]
                                [(for . _)
                                 (raise-syntax-error
                                  #f
                                  "bad `for' import form"
                                  orig
                                  im)]
-                               [_ (list (parse-import-set orig im))]))
+                               [_ (let ([m (parse-import-set orig im)])
+                                    (list m `(for-label ,m)))]))
                            (syntax->list #'(im ...)))]
                      [prelims (datum->syntax orig
                                              'r6rs/private/prelims)])
@@ -402,7 +403,13 @@ FIXME:
           (apply
            append
            (map (lambda (local-id ext-id)
-                  (let* ([l (hash-table-get table (syntax-e local-id) null)]
+                  (let* ([l (hash-table-get table (syntax-e local-id)
+                                            (lambda ()
+                                              (raise-syntax-error
+                                               #f
+                                               "no binding for exported identifier"
+                                               #'orig
+                                               local-id)))]
                          [l (filter (lambda (e)
                                       (free-identifier=? (car e) local-id (cdr e)))
                                     l)])
diff --git a/collects/r6rs/private/io-conds.ss b/collects/r6rs/private/io-conds.ss
index 181ca7d32f..a534049a30 100644
--- a/collects/r6rs/private/io-conds.ss
+++ b/collects/r6rs/private/io-conds.ss
@@ -1,7 +1,7 @@
 #!r6rs
 
 (library (r6rs private io-conds)
-  (export &i/o make-i/o-error i/o-error
+  (export &i/o make-i/o-error i/o-error?
           &i/o-read make-i/o-read-error i/o-read-error?
           &i/o-write make-i/o-write-error i/o-write-error?
           &i/o-invalid-position make-i/o-invalid-position-error i/o-invalid-position-error? i/o-error-position
diff --git a/collects/r6rs/private/num-inline.ss b/collects/r6rs/private/num-inline.ss
new file mode 100644
index 0000000000..c1b1c7b1fd
--- /dev/null
+++ b/collects/r6rs/private/num-inline.ss
@@ -0,0 +1,88 @@
+#lang scheme/base
+
+(require (for-syntax scheme/base
+                     r6rs/private/inline-rules))
+
+(provide define-inliner
+         nocheck
+         implementation-restriction)
+
+(define-syntax-rule (nocheck v . _)
+  v)
+
+(define (implementation-restriction who what)
+  (raise
+   (make-exn:fail:unsupported
+    (format "~a: result is out of range: ~e" who what)
+    (current-continuation-marks))))
+
+(define-syntax-rule (define-inliner define-fx numtype? numtype-str)
+  (...
+   (begin
+     (define-syntax define-an-fx
+       (syntax-rules ()
+         [(_ orig fx check-result ([(arg ...) (tmp ...)] ...) . rest)
+          (begin
+            (provide fx)
+            (define fx-proc
+              (let ([fx (case-lambda 
+                         [(arg ...)
+                          (unless (numtype? arg)
+                            (raise-type-error 'fx numtype-str arg))
+                          ...
+                          (let ([r (orig arg ...)])
+                            (check-result r (implementation-restriction 'fx r)))]
+                         ...
+                         . rest)])
+                fx))
+            (define-syntax fx
+              (inline-rules
+               fx-proc
+               [(_ arg ...)
+                (let ([tmp arg] ...)
+                  (if (and (numtype? tmp) ...)
+                      (let ([v (orig tmp ...)])
+                        (check-result v (fx-proc tmp ...)))
+                      (fx-proc tmp ...)))]
+               ...)))]))
+
+     (define-syntax define-an-fx+rest
+       (syntax-rules ()
+         [(_ orig fx check clauses)
+          (define-an-fx orig fx check clauses
+            [args (for-each (lambda (arg)
+                              (unless (numtype? arg)
+                                (raise-type-error 'fx numtype-str arg)))
+                            args)
+                  (let ([r (apply orig args)])
+                    (check r (implementation-restriction 'fx r))
+                    r)])]))
+
+
+     (define-syntax define-fx
+       (syntax-rules (...)
+         [(_ orig fx [(a) (b c)] check)
+          (define-an-fx orig fx check
+            ([(a) (t1)]
+             [(b c) (t1 t2)]))]
+         [(_ orig fx [(a) (b c (... ...))] check)
+          (define-an-fx+rest orig fx check
+            ([(a) (t1)]
+             [(b c) (t1 t2)]))]
+         [(_ orig fx (a b c (... ...)) check)
+          (define-an-fx+rest orig fx check
+            ([(a b) (t1 t2)]))]
+         [(_ orig fx (a b (... ...)) check)
+          (define-an-fx+rest orig fx check
+            ([(a) (t1)]
+             [(a b) (t1 t2)]
+             [(a b c) (t1 t2 t3)]))]
+         [(_ orig fx (a) check)
+          (define-an-fx+rest orig fx check
+            ([(a) (t1)]))]
+         [(_ orig fx (a b) check)
+          (define-an-fx orig fx check
+            ([(a b) (t1 t2)]))]
+         [(_ orig fx (a b c) check)
+          (define-an-fx orig fx check
+            ([(a b c) (t1 t2 t3)]))])))))
diff --git a/collects/rnrs/arithmetic/bitwise-6.ss b/collects/rnrs/arithmetic/bitwise-6.ss
index 4c45015ad1..2fc08d9f4a 100644
--- a/collects/rnrs/arithmetic/bitwise-6.ss
+++ b/collects/rnrs/arithmetic/bitwise-6.ss
@@ -8,10 +8,14 @@
          (rename-out [integer-length bitwise-length])
          bitwise-first-bit-set
          bitwise-bit-set?
+         bitwise-copy-bit
+         bitwise-bit-field
          (rename-out [arithmetic-shift bitwise-arithmetic-shift])
          bitwise-arithmetic-shift-left
          bitwise-arithmetic-shift-right
-         bitwise-copy-bit)
+         bitwise-copy-bit-field
+         bitwise-rotate-bit-field
+         bitwise-reverse-bit-field)
 
 
 (define (bitwise-if a b c)
@@ -36,9 +40,13 @@
             pos))))
 
 (define (bitwise-bit-set? b n)
+  (unless (exact-nonnegative-integer? n)
+    (raise-type-error 'bitwise-bit-set? "exact nonnegative integer" n))
   (eq? 1 (bitwise-and (arithmetic-shift b (- n)) 1)))
 
 (define (bitwise-copy-bit b n bit)
+  (unless (exact-nonnegative-integer? n)
+    (raise-type-error 'bitwise-copy-bit "exact nonnegative integer" n))
   (unless (or (eq? bit 1)
               (eq? bit 0))
     (raise-type-error 'bitwise-copy-bit "0 or 1" bit))
@@ -47,10 +55,22 @@
       (bitwise-xor b (arithmetic-shift 1 n))))
 
 (define (bitwise-bit-field b start end)
+  (unless (exact-nonnegative-integer? start)
+    (raise-type-error 'bitwise-bit-field "exact nonnegative integer" start))
+  (unless (exact-nonnegative-integer? end)
+    (raise-type-error 'bitwise-bit-field "exact nonnegative integer" end))
+  (unless (start . <= . end)
+    (error 'bitwise-bit-field "ending position ~e is not as big a starting position ~e" start end))
   (bitwise-and (arithmetic-shift b (- start))
                (sub1 (arithmetic-shift 1 (- end start)))))
 
 (define (bitwise-copy-bit-field to start end from)
+  (unless (exact-nonnegative-integer? start)
+    (raise-type-error 'bitwise-copy-bit-field "exact nonnegative integer" start))
+  (unless (exact-nonnegative-integer? end)
+    (raise-type-error 'bitwise-copy-bit-field "exact nonnegative integer" end))
+  (unless (start . <= . end)
+    (error 'bitwise-copy-bit-field "ending position ~e is not as big a starting position ~e" start end))
   (let* ([mask1 (arithmetic-shift -1 start)]
          [mask2 (bitwise-not (arithmetic-shift -1 end))]
          [mask (bitwise-and mask1 mask2)])
@@ -63,3 +83,36 @@
 (define (bitwise-arithmetic-shift-right v s)
   (arithmetic-shift v (- s)))
 
+(define (bitwise-rotate-bit-field n start end count)
+  (unless (exact-nonnegative-integer? start)
+    (raise-type-error 'bitwise-rotate-bit-field "exact nonnegative integer" start))
+  (unless (exact-nonnegative-integer? end)
+    (raise-type-error 'bitwise-rotate-bit-field "exact nonnegative integer" end))
+  (unless (start . <= . end)
+    (error 'bitwise-rotate-bit-field "ending position ~e is not as big a starting position ~e" start end))
+  (unless (exact-nonnegative-integer? count)
+    (raise-type-error 'bitwise-rotate-bit-field "exact nonnegative integer" count))
+  (let* ([width (- end start)]
+         [count (modulo count width)]
+         [field0 (bitwise-bit-field n start end)]
+         [field1 (arithmetic-shift field0 count)]
+         [field2 (arithmetic-shift field0 (- count width))]
+         [field (bitwise-ior field1 field2)])
+    (bitwise-copy-bit-field n start end field)))
+
+(define (bitwise-reverse-bit-field n start end)
+  (unless (exact-nonnegative-integer? start)
+    (raise-type-error 'bitwise-rotate-bit-field "exact nonnegative integer" start))
+  (unless (exact-nonnegative-integer? end)
+    (raise-type-error 'bitwise-rotate-bit-field "exact nonnegative integer" end))
+  (unless (start . <= . end)
+    (error 'bitwise-rotate-bit-field "ending position ~e is not as big a starting position ~e" start end))
+  (let ([field (bitwise-bit-field n start end)]
+        [width (- end start)])
+    (let loop ([old field][new 0][width width])
+      (cond
+       [(zero? width) (bitwise-copy-bit-field n start end new)]
+       [else (loop (arithmetic-shift old -1)
+                   (bitwise-ior (arithmetic-shift new 1)
+                                (bitwise-and old 1))
+                   (sub1 width))]))))
diff --git a/collects/rnrs/arithmetic/fixnums-6.ss b/collects/rnrs/arithmetic/fixnums-6.ss
index d46ec40dbd..01be1e2cef 100644
--- a/collects/rnrs/arithmetic/fixnums-6.ss
+++ b/collects/rnrs/arithmetic/fixnums-6.ss
@@ -3,10 +3,8 @@
 (require (only-in rnrs/base-6
                   div-and-mod div mod
                   div0-and-mod0 div0 mod0)
-         (only-in rnrs/arithmetic/bitwise-6
-                  bitwise-if
-                  bitwise-first-bit-set
-                  bitwise-copy-bit)
+         rnrs/arithmetic/bitwise-6
+         r6rs/private/num-inline
          (for-syntax r6rs/private/inline-rules))
 
 (provide fixnum?
@@ -30,82 +28,12 @@
             (and (exact-integer? v)
                  (<= -1073741824 v 1073741823)))]))
 
-(define (implementation-restriction who what)
-  (error 'who "implementation restriction: ~e" what))
-
-(define-syntax define-an-fx
-  (syntax-rules ()
-    [(_ orig fx check-result ([(arg ...) (tmp ...)] ...) . rest)
-     (begin
-       (provide fx)
-       (define fx-proc
-         (let ([fx (case-lambda 
-                    [(arg ...)
-                     (unless (fixnum? arg)
-                       (raise-type-error 'fx "fixnum" arg))
-                     ...
-                     (let ([r (orig arg ...)])
-                       (unless (fixnum? r)
-                         (implementation-restriction 'fx r))
-                       r)]
-                    ...
-                    . rest)])
-           fx))
-       (define-syntax fx
-         (inline-rules
-          fx-proc
-          [(_ arg ...)
-           (let ([tmp arg] ...)
-             (if (and (fixnum? tmp) ...)
-                 (let ([v (orig tmp ...)])
-                   (check-result v (fx-proc tmp ...)))
-                 (fx-proc tmp ...)))]
-          ...)))]))
-
-(define-syntax-rule (check v (fx-proc tmp ...))
+(define-syntax-rule (check v alt)
   (if (fixnum? v)
       v
-      (fx-proc tmp ...)))
+      alt))
 
-(define-syntax-rule (nocheck v . _)
-  v)
-
-(define-syntax define-an-fx+rest
-  (syntax-rules ()
-    [(_ orig fx check clauses)
-     (define-an-fx orig fx check clauses
-       [args (for-each (lambda (arg)
-                         (unless (fixnum? args)
-                           (raise-type-error 'fx "fixnum" arg)))
-                       args)
-             (let ([r (apply orig args)])
-               (unless (fixnum? r)
-                 (implementation-restriction 'fx r))
-               r)])]))
-
-
-(define-syntax define-fx
-  (syntax-rules (...)
-    [(_ orig fx [(a) (b c)] check)
-     (define-an-fx orig fx check
-       ([(a) (t1)]
-        [(b c) (t1 t2)]))]
-    [(_ orig fx (a b c (... ...)) check)
-     (define-an-fx+rest orig fx check
-       ([(a b) (t1 t2)]))]
-    [(_ orig fx (a b (... ...)) check)
-     (define-an-fx+rest orig fx check
-       ([(a) (t1)]
-        [(a b) (t1 t2)]))]
-    [(_ orig fx (a) check)
-     (define-an-fx+rest orig fx check
-       ([(a) (t1)]))]
-    [(_ orig fx (a b) check)
-     (define-an-fx orig fx check
-       ([(a b) (t1 t2)]))]
-    [(_ orig fx (a b c) check)
-     (define-an-fx orig fx check
-       ([(a b c) (t1 t2 t3)]))]))
+(define-inliner define-fx fixnum? "fixnum")
 
 (define-fx = fx=? (a b c ...) nocheck)
 (define-fx > fx>? (a b c ...) nocheck)
@@ -155,15 +83,37 @@
 (define-fx bitwise-and fxand (a b ...) nocheck)
 (define-fx bitwise-ior fxior (a b ...) nocheck)
 (define-fx bitwise-xor fxxor (a b ...) nocheck)
-(define-fx bitwise-first-bit-set fxfirst-bit-set (a) nocheck)
-(define-fx bitwise-copy-bit fxcopy-bit (a) nocheck)
 
 (define-syntax-rule (fixnum-bitwise-if a b c)
   (bitwise-ior (bitwise-and a b)
                (bitwise-and (bitwise-not a) c)))
 (define-fx fixnum-bitwise-if fxif (a b c) nocheck)
 
+(define-fx bitwise-length fxlength (a) nocheck)
+(define-fx bitwise-first-bit-set fxfirst-bit-set (a) nocheck)
 
+(define (fxbit-set? n bit)
+  (unless (fixnum? n)
+    (raise-type-error 'fxbit-set? "fixnum" n))
+  (bitwise-bit-set? n bit))
+
+(define (fxcopy-bit n pos bit)
+  (unless (fixnum? n)
+    (raise-type-error 'fxcopy-bit "fixnum" n))
+  (unless (and (exact-nonnegative-integer? pos)
+               (< pos (fixnum-width)))
+    (raise-type-error 'fxcopy-bit "exact integer in [0, 30]" pos))
+  (bitwise-copy-bit n pos bit))
+
+(define (fxcopy-bit-field n start end m)
+  (unless (fixnum? n)
+    (raise-type-error 'fxrotate-bit-field "fixnum" n))
+  (unless (and (exact-nonnegative-integer? end)
+               (< end (fixnum-width)))
+    (raise-type-error 'fxrotate-bit-field "exact integer in [0, 30]" end))
+  (unless (fixnum? m)
+    (raise-type-error 'fxrotate-bit-field "fixnum" m))
+  (bitwise-bit-field n start end m))
 
 (define-syntax-rule (define-shifter fxarithmetic-shift r6rs:fxarithmetic-shift
                       lower-bound bounds adjust)
@@ -198,3 +148,23 @@
   0 "exact integer in [0, 30]" values)
 (define-shifter fxarithmetic-shift-right r6rs:fxarithmetic-shift-right
   0 "exact integer in [0, 30]" -)
+
+
+(define (fxrotate-bit-field n start end count)
+  (unless (fixnum? n)
+    (raise-type-error 'fxrotate-bit-field "fixnum" n))
+  (unless (and (exact-nonnegative-integer? end)
+               (< end (fixnum-width)))
+    (raise-type-error 'fxrotate-bit-field "exact integer in [0, 30]" end))
+  (unless (and (exact-nonnegative-integer? count)
+               (< count (fixnum-width)))
+    (raise-type-error 'fxrotate-bit-field "exact integer in [0, 30]" count))
+  (bitwise-rotate-bit-field n start end count))
+
+(define (fxreverse-bit-field n start end)
+  (unless (fixnum? n)
+    (raise-type-error 'fxrotate-bit-field "fixnum" n))
+  (unless (and (exact-nonnegative-integer? end)
+               (< end (fixnum-width)))
+    (raise-type-error 'fxrotate-bit-field "exact integer in [0, 30]" end))
+  (bitwise-reverse-bit-field n start end))
diff --git a/collects/rnrs/arithmetic/flonums-6.ss b/collects/rnrs/arithmetic/flonums-6.ss
new file mode 100644
index 0000000000..497ec4afb1
--- /dev/null
+++ b/collects/rnrs/arithmetic/flonums-6.ss
@@ -0,0 +1,102 @@
+#lang scheme/base
+
+(require (only-in rnrs/base-6
+                  div-and-mod div mod
+                  div0-and-mod0 div0 mod0
+                  [integer? r6rs:integer?]
+                  finite? infinite? nan?)
+         (only-in rnrs/arithmetic/fixnums-6
+                  fixnum?)
+         rnrs/conditions-6
+         r6rs/private/num-inline
+         (for-syntax r6rs/private/inline-rules))
+
+(provide flonum?
+         real->flonum
+         &no-infinities make-no-infinities-violation no-infinities-violation?
+         &no-nans make-no-nans-violation no-nans-violation?
+         fixnum->flonum)
+;; More provided via macros
+
+(define (r6rs:flonum? v)
+  (and (real? v) (inexact? v)))
+
+(define-syntax flonum?
+  (inline-rules
+   r6rs:flonum?
+   [(_ a) (let ([v a])
+            (and (real? v) (inexact? v)))]))
+
+(define-inliner define-fl flonum? "flonum")
+
+(define-fl = fl=? (a b c ...) nocheck)
+(define-fl > fl>? (a b c ...) nocheck)
+(define-fl < fl<? (a b c ...) nocheck)
+(define-fl <= fl<=? (a b c ...) nocheck)
+(define-fl >= fl>=? (a b c ...) nocheck)
+
+(define-fl integer? flinteger? (a) nocheck)
+(define-fl zero? flzero? (a) nocheck)
+(define-fl positive? flpositive? (a) nocheck)
+(define-fl negative? flnegative? (a) nocheck)
+(define-fl odd? flodd? (a) nocheck)
+(define-fl even? fleven? (a) nocheck)
+(define-fl finite? flfinite? (a) nocheck)
+(define-fl infinite? flinfinite? (a) nocheck)
+(define-fl nan? flnan? (a) nocheck)
+
+(define-fl max flmax (a b ...) nocheck)
+(define-fl max flmin (a b ...) nocheck)
+
+(define-fl + fl+ (a b ...) nocheck)
+(define-fl * fl* (a b ...) nocheck)
+(define-fl - fl- [(a) (a b ...)] nocheck)
+(define-fl / fl/ [(a) (a b ...)] nocheck)
+
+(define-fl abs flabs (a) nocheck)
+
+(define-fl div-and-mod fldiv-and-mod (a b) nocheck)
+(define-fl div fldiv (a b) nocheck)
+(define-fl mod flmod (a b) nocheck)
+(define-fl div0-and-mod0 fldiv0-and-mod0 (a b) nocheck)
+(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-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-fl sin flsin (a) nocheck)
+(define-fl cos flcos (a) nocheck)
+(define-fl tan fltan (a) nocheck)
+(define-fl asin flasin (a) nocheck)
+(define-fl acos flacos (a) nocheck)
+(define-fl atan flatan [(a) (a b)] nocheck)
+
+(define-fl sqrt flsqrt (a) nocheck)
+
+(define-fl expt flexpt (a b) nocheck)
+
+(define-condition-type &no-infinities
+  &implementation-restriction
+  make-no-infinities-violation
+  no-infinities-violation?)
+
+(define-condition-type &no-nans
+  &implementation-restriction
+  make-no-nans-violation no-nans-violation?)
+
+(define (real->flonum r)
+  (unless (real? r)
+    (raise-type-error 'real->flonum "real" r))
+  (exact->inexact r))
+
+(define (fixnum->flonum fx)
+  (unless (fixnum? fx)
+    (raise-type-error 'fixnum->flonum "fixnum" fx)
+    (exact->inexact fx)))
diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss
index 800c6ff7aa..a76ec471d1 100644
--- a/collects/rnrs/base-6.ss
+++ b/collects/rnrs/base-6.ss
@@ -252,7 +252,7 @@
 
 (define (r6rs:string->number s [radix 10])
   (and (regexp-match? rx:number s)
-       (string->number (regexp-replace* #rx"|[0-9]+" s "") radix)))
+       (string->number (regexp-replace* #rx"[|][0-9]+" s "") radix)))
 
 (define-syntax-rule (make-mapper what for for-each in-val val-length val->list)
   (case-lambda
diff --git a/collects/rnrs/bytevectors-6.ss b/collects/rnrs/bytevectors-6.ss
index 7bfd684bfd..b79f9726ad 100644
--- a/collects/rnrs/bytevectors-6.ss
+++ b/collects/rnrs/bytevectors-6.ss
@@ -309,7 +309,7 @@
                       (values #t 2)]
                      [(and (eq? #xFF (bytes-ref bstr 0))
                            (eq? #xFE (bytes-ref bstr 1)))
-                      (values #t 1)]
+                      (values #f 2)]
                      [else (values (eq? endianness 'big) 0)])]
                    [else (values (eq? endianness 'big) 0)])])
       (list->string
@@ -325,7 +325,7 @@
              (let ([a (if big? a b)]
                    [b (if big? b a)])
                (cond
-                [(= (bitwise-and a #xD8) #xD8)
+                [(= (bitwise-and a #xFC) #xD8)
                  (if (len . < . (+ pos 4))
                      ;; decoding error
                      (cons #\uFFFD (loop (+ pos 2)))
@@ -335,7 +335,7 @@
                        (let ([c (if big? c d)]
                              [d (if big? d c)])
                          (cond
-                          [(= (bitwise-and c #xDC) #xDC)
+                          [(= (bitwise-and c #xFC) #xDC)
                            ;; A valid surrogate
                            (let ([v (+ #x10000
                                        (bitwise-ior
@@ -347,7 +347,7 @@
                           [else
                            ;; Invalid surrogate.
                            (cons #\uFFFD (loop (+ pos 2)))]))))]
-                [(= (bitwise-and a #xDC) #xDC)
+                [(= (bitwise-and a #xFC) #xDC)
                  ;; invalid surrogate code
                  (cons #\uFFFD (loop (+ pos 2)))]
                 [else
@@ -365,16 +365,18 @@
                   (cond
                    [skip-bom?
                     (values (eq? endianness 'big) 0)]
-                   [(and (len . >= . 4)
-                         (eq? #x00 (bytes-ref bstr 0))
-                         (eq? #x00 (bytes-ref bstr 1)))
+                   [(len . >= . 4)
                     (cond
-                     [(and (eq? #xFE (bytes-ref bstr 2))
+                     [(and (eq? #x00 (bytes-ref bstr 0))
+                           (eq? #x00 (bytes-ref bstr 1))
+                           (eq? #xFE (bytes-ref bstr 2))
                            (eq? #xFF (bytes-ref bstr 3)))
-                      (values #t 2)]
-                     [(and (eq? #xFF (bytes-ref bstr 2))
-                           (eq? #xFE (bytes-ref bstr 3)))
-                      (values #t 1)]
+                      (values #t 4)]
+                     [(and (eq? #xFF (bytes-ref bstr 0))
+                           (eq? #xFE (bytes-ref bstr 1))
+                           (eq? #x00 (bytes-ref bstr 2))
+                           (eq? #x00 (bytes-ref bstr 3)))
+                      (values #f 4)]
                      [else (values (eq? endianness 'big) 0)])]
                    [else (values (eq? endianness 'big) 0)])])
       (list->string
diff --git a/collects/rnrs/io/ports-6.ss b/collects/rnrs/io/ports-6.ss
index 7341ab721d..2ea80b653a 100644
--- a/collects/rnrs/io/ports-6.ss
+++ b/collects/rnrs/io/ports-6.ss
@@ -196,13 +196,15 @@
     port
     (lambda (bytes start end can-buffer/block? enable-breaks?)
       (check-disconnect)
-      (cond
-       [enable-breaks?
-        (parameterize-break #t (write-bytes (subbytes start end) port))]
-       [can-buffer/block?
-        (write-bytes (subbytes start end) port)]
-       [else
-        (write-bytes-avail* (subbytes start end) port)]))
+      (if (= start end)
+          (flush-output port)
+          (cond
+           [enable-breaks?
+            (parameterize-break #t (write-bytes (subbytes start end) port))]
+           [can-buffer/block?
+            (write-bytes (subbytes start end) port)]
+           [else
+            (write-bytes-avail* (subbytes start end) port)])))
     (lambda ()
       (unless disconnected?
         (close-output-port port)))
diff --git a/collects/rnrs/main-6.ss b/collects/rnrs/main-6.ss
new file mode 100644
index 0000000000..7ad9ddbdd7
--- /dev/null
+++ b/collects/rnrs/main-6.ss
@@ -0,0 +1,33 @@
+#lang scheme/base
+
+(define-syntax re-export
+  (syntax-rules ()
+    [(_) (re-export rnrs/base-6
+                    rnrs/exceptions-6
+                    rnrs/programs-6
+                    rnrs/files-6
+                    rnrs/bytevectors-6
+                    rnrs/hashtables-6
+                    rnrs/sorting-6
+                    rnrs/syntax-case-6
+                    rnrs/conditions-6
+                    rnrs/unicode-6
+                    rnrs/control-6
+                    rnrs/lists-6
+                    rnrs/enums-6
+                    rnrs/arithmetic/bitwise-6
+                    rnrs/arithmetic/fixnums-6
+                    rnrs/arithmetic/flonums-6
+                    rnrs/io/ports-6
+                    rnrs/io/simple-6
+                    rnrs/records/inspection-6
+                    rnrs/records/syntactic-6
+                    rnrs/records/procedural-6)]
+    [(_ id) (begin
+              (require id)
+              (provide (all-from-out id)))]
+    [(_ id ...)
+     (begin (re-export id) ...)]))
+
+(re-export)
+
diff --git a/collects/rnrs/main.ss b/collects/rnrs/main.ss
new file mode 100644
index 0000000000..4faf552b89
--- /dev/null
+++ b/collects/rnrs/main.ss
@@ -0,0 +1,7 @@
+#lang scheme/base
+
+(define-syntax-rule (bounce)
+  (begin
+    (require rnrs/main-6)
+    (provide (all-from-out rnrs/main-6))))
+(bounce)
\ No newline at end of file
diff --git a/collects/rnrs/mutable-strings-6.ss b/collects/rnrs/mutable-strings-6.ss
new file mode 100644
index 0000000000..5994ad87ba
--- /dev/null
+++ b/collects/rnrs/mutable-strings-6.ss
@@ -0,0 +1,3 @@
+#lang scheme/base
+
+(provide string-set! string-fill!)
diff --git a/collects/rnrs/r5rs-6.ss b/collects/rnrs/r5rs-6.ss
new file mode 100644
index 0000000000..821e794be6
--- /dev/null
+++ b/collects/rnrs/r5rs-6.ss
@@ -0,0 +1,15 @@
+#lang scheme/base
+
+(require (prefix-in r5rs: r5rs))
+
+(provide exact->inexact
+         inexact->exact
+         quotient
+         remainder
+         modulo
+         (rename-out [r5rs:delay delay]
+                     [r5rs:force force]
+                     [r5rs:null-environment null-environment]
+                     [r5rs:scheme-report-environment scheme-report-environment]))
+         
+                     
\ No newline at end of file
diff --git a/collects/scheme/mpair.ss b/collects/scheme/mpair.ss
index 2051d7c4cb..6e14373100 100644
--- a/collects/scheme/mpair.ss
+++ b/collects/scheme/mpair.ss
@@ -1,5 +1,7 @@
 #lang scheme/base
 
+(require (for-syntax scheme/base))
+
 (provide mmap
          mfor-each
          mlist
@@ -66,14 +68,30 @@
    [(null? l) null]
    [else (cons (mcar l) (mlist->list (mcdr l)))]))
 
-(define mlist
-  (case-lambda
-   [() null]
-   [(a) (mcons a null)]
-   [(a b) (mcons a (mcons b null))]
-   [(a b c) (mcons a (mcons b (mcons c null)))]
-   [(a b c d) (mcons a (mcons b (mcons c (mcons d null))))]
-   [l (list->mlist l)]))
+(define-syntax mlist
+  (make-set!-transformer
+   (lambda (stx)
+     (syntax-case stx (set!)
+       [(set! id . _) (raise-syntax-error #f
+                                          "cannot mutate imported variable"
+                                          stx
+                                          #'id)]
+       [(_ a) #'(mcons a null)]
+       [(_ a b) #'(mcons a (mcons b null))]
+       [(_ a b c) #'(mcons a (mcons b (mcons c null)))]
+       [(_ arg ...) #'(-mlist arg ...)]
+       [_ #'-mlist]))))
+
+(define -mlist
+  (let ([mlist
+         (case-lambda
+          [() null]
+          [(a) (mcons a null)]
+          [(a b) (mcons a (mcons b null))]
+          [(a b c) (mcons a (mcons b (mcons c null)))]
+          [(a b c d) (mcons a (mcons b (mcons c (mcons d null))))]
+          [l (list->mlist l)])])
+    mlist))
 
 (define (mlist? l)
   (cond
diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl
index dba87b7fee..adc63b2ba3 100644
--- a/collects/scribblings/reference/stx-trans.scrbl
+++ b/collects/scribblings/reference/stx-trans.scrbl
@@ -403,8 +403,8 @@ and a module-contextless version of @scheme[id-stx] otherwise.
 
 
 @defproc[(syntax-local-certifier [active? boolean? #f])
-         (syntax? (any/c (or/c procedure? false/c)) 
-                  . opt-> . syntax?)]{
+         ((syntax?) (any/c (or/c procedure? false/c)) 
+          . ->* . syntax?)]{
 
 Returns a procedure that captures any certificates currently available
 for @scheme[syntax-local-value] or @scheme[local-expand]. The
@@ -611,7 +611,9 @@ instantiated or visited even if no binding is imported into a module.
 }}
 
 
-@defproc[(syntax-local-require-certifier) (syntax? . -> . syntax?)]{
+@defproc[(syntax-local-require-certifier)
+         ((syntax?) (or/c false/c (syntax? . -> . syntax?)) 
+          . ->* . syntax?)]{
 
 Like @scheme[syntax-local-certifier], but to certify @tech{syntax
 objects} that correspond to @scheme[require] sub-forms, so that
@@ -703,7 +705,9 @@ A structure representing a single imported identifier:
 }}
 
 
-@defproc[(syntax-local-provide-certifier) (syntax? . -> . syntax?)]{
+@defproc[(syntax-local-provide-certifier)
+         ((syntax?) (or/c false/c (syntax? . -> . syntax?)) 
+          . ->* . syntax?)]{
 
 Like @scheme[syntax-local-certifier], but to certify @tech{syntax
 objects} that correspond to @scheme[provide] sub-forms, so that