r6rs progress

svn: r8775

collects/r5rs/main.ss

@@ -199,7 +199,8 @@
                 [unquote
                  (zero? depth)
                  (raise-syntax-error
-                  "invalid content within quasiquote"
+                  #f
+                  "invalid context within quasiquote"
                   stx
                   form)]
                 [((unquote-splicing e) . rest)
@@ -212,7 +213,8 @@
                 [unquote-splicing 
                  (zero? depth)
                  (raise-syntax-error
-                  "invalid content within quasiquote"
+                  #f
+                  "invalid context within quasiquote"
                   stx
                   form)]
                 [(r5rs:quasiquote . e)

collects/r6rs/main.ss

@@ -282,7 +282,7 @@ FIXME:
                 append
                 (map syntax->list
                      (syntax->list #'((id id2) ...)))))
-     #`(except-in #,(parse-import-set orig #'im) id ...)]
+     #`(rename-in #,(parse-import-set orig #'im) [id id2] ...)]
     [(rename . _) (bad)]
     [_ (parse-library-reference orig stx)]))
 
@@ -312,8 +312,10 @@ FIXME:
                                   (with-syntax ([is (parse-import-set orig #'base-im)])
                                     (if (null? levels)
                                         #'()
-                                        (with-syntax ([(level ...) levels])
+                                        (with-syntax ([(level ...) levels]
-                                          #`((for-meta level is) ...)))))]
+                                                      [prelims (datum->syntax orig
+                                                                              'r6rs/private/prelims)])
+                                          #`((for-meta level is prelims) ...)))))]
                                [(for . _)
                                 (raise-syntax-error
                                  #f
@@ -321,8 +323,10 @@ FIXME:
                                  orig
                                  im)]
                                [_ (list (parse-import-set orig im))]))
-                           (syntax->list #'(im ...)))])
+                           (syntax->list #'(im ...)))]
-         #'(require im ... ...))])))
+                     [prelims (datum->syntax orig
+                                             'r6rs/private/prelims)])
+         #'(require prelims im ... ...))])))
 
 (define-syntax (r6rs-export stx)
   (let ([orig (syntax-case stx ()

collects/r6rs/private/inline-rules.ss

@@ -0,0 +1,18 @@
+#lang scheme/base
+
+(require (for-syntax scheme/base)
+         (for-template scheme/base))
+
+(provide inline-rules)
+
+(define-syntax-rule (inline-rules orig-id [pat result] ...)
+  (make-set!-transformer
+   (lambda (stx)
+     (syntax-case stx (set!)
+       [(set! . _)
+        (raise-syntax-error #f
+                            "cannot mutate"
+                            stx)]
+       [pat #'result] ...
+       [(id . args) #'(orig-id . args)]
+       [id #'orig-id]))))

collects/r6rs/private/prelims.ss

@@ -0,0 +1,22 @@
+#lang scheme/base
+
+;; PLT Scheme pre-requisites for any phase
+
+(require (for-syntax scheme/base))
+
+(provide
+ (rename-out [datum #%datum])
+ #%app #%top #%top-interaction)
+
+;; ----------------------------------------
+;; Datum
+
+(define-syntax (datum stx)
+  (syntax-case stx ()
+    [(_ . thing)
+     (if (vector? (syntax-e #'thing))
+         (raise-syntax-error 'r6rs
+                             "a vector is not an expression"
+                             #'thing)
+         #`(quote thing))]))
+

collects/r6rs/private/qq-gen.ss

@@ -0,0 +1,81 @@
+#lang scheme/base
+
+;; used for quasiquote and quasisyntax
+
+(require (for-syntax scheme/base))
+
+(provide define-generalized-qq)
+
+(define-syntax-rule (define-generalized-qq r6rs:quasiquote 
+                      quasiquote unquote unquote-splicing)
+  (...
+   (define-syntax (r6rs:quasiquote stx)
+     ;; Replace (unquote expr ...) with (unquote expr) ...
+     (syntax-case stx ()
+       [(_ tmpl)
+        (let ([new-tmpl
+               (let loop ([tmpl #'tmpl][level 0])
+                 (syntax-case tmpl (r6rs:quasiquote)
+                   [((u expr ...) . rest)
+                    (or (free-identifier=? #'u #'unquote)
+                        (free-identifier=? #'u #'unquote-splicing))
+                    (let ([new-rest (loop #'rest level)])
+                      (if (zero? level)
+                          (if (and (eq? new-rest #'rest)
+                                   (= 1 (length (syntax->list #'(expr ...)))))
+                              tmpl
+                              (datum->syntax
+                               tmpl
+                               (append (let ([a (car (syntax-e tmpl))])
+                                         (map (lambda (expr)
+                                                (datum->syntax
+                                                 a
+                                                 (list (car (syntax-e a))
+                                                       expr)
+                                                 a a a))
+                                              (syntax->list #'(expr ...))))
+                                       new-rest)
+                               tmpl tmpl tmpl))
+                          (let* ([first (car (syntax-e tmpl))]
+                                 [new-first (loop first (sub1 level))])
+                            (if (and (eq? new-first first)
+                                     (eq? new-rest #'rest))
+                                tmpl
+                                (datum->syntax
+                                 tmpl
+                                 (cons new-first new-rest)
+                                 tmpl tmpl tmpl)))))]
+                   [(r6rs:quasiquote expr)
+                    (let ([new-expr (loop #'expr (add1 level))])
+                      (if (eq? new-expr #'expr)
+                          tmpl
+                          (datum->syntax
+                           tmpl
+                           (cons (car (syntax-e tmpl) new-expr))
+                           tmpl tmpl tmpl)))]
+                   [(a . b)
+                    (let ([new-a (loop #'a level)]
+                          [new-b (loop #'b level)])
+                      (if (and (eq? new-a #'a)
+                               (eq? new-b #'b))
+                          tmpl
+                          (datum->syntax
+                           tmpl
+                           (cons new-a new-b)
+                           tmpl tmpl tmpl)))]
+                   [#(a ...)
+                    (let* ([as (syntax->list #'(a ...))]
+                           [new-as (map (lambda (a)
+                                          (loop a level))
+                                        as)])
+                      (if (andmap eq? as new-as)
+                          tmpl
+                          (datum->syntax
+                           tmpl
+                           (list->vector new-as)
+                           tmpl tmpl tmpl)))]
+                   [_ tmpl]))])
+          (datum->syntax
+           stx
+           (list #'r5rs:quasiquote new-tmpl)
+           stx stx stx))]))))

collects/r6rs/private/records-core.ss

@@ -0,0 +1,357 @@
+#!r6rs
+
+;; Implementation of procedural layer for R6RS Records
+
+;; Based on the SRFI implementation:
+; Copyright (C) Michael Sperber (2005). All Rights Reserved. 
+; 
+; Permission is hereby granted, free of charge, to any person
+; obtaining a copy of this software and associated documentation files
+; (the "Software"), to deal in the Software without restriction,
+; including without limitation the rights to use, copy, modify, merge,
+; publish, distribute, sublicense, and/or sell copies of the Software,
+; and to permit persons to whom the Software is furnished to do so,
+; subject to the following conditions:
+; 
+; The above copyright notice and this permission notice shall be
+; included in all copies or substantial portions of the Software.
+; 
+; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+; SOFTWARE.
+
+(library (r6rs private records-core)
+  (export make-record-type-descriptor
+	  record-type-descriptor?
+	  record-type-name
+	  record-type-parent
+	  record-type-sealed?
+	  record-type-uid
+	  record-type-field-names
+	  record-type-opaque?
+	  make-record-constructor-descriptor record-constructor
+	  record-predicate
+	  record-accessor record-mutator
+	  record-field-mutable? record-type-generative?
+	  record? record-rtd)
+  (import (rnrs base (6))
+          (rnrs list (6))
+          (rnrs io simple (6)) ;; REMOVEME 
+	  (r6rs private vector-types))
+  
+  (define make-field-spec cons)
+
+  (define field-spec-mutable? car)
+  (define field-spec-name cdr)
+
+  (define (field-spec=? spec-1 spec-2)
+    (and (eq? (field-spec-mutable? spec-1)
+	      (field-spec-mutable? spec-2))
+	 (eq? (field-spec-name spec-1)
+	      (field-spec-name spec-2))))
+
+  (define :record-type-data (make-vector-type 'record-type-descriptor 
+					      #f ; no supertype
+					      #f ; no per-type data
+					      '(#f #f #f #f #f #f) ; all fields immutable
+					      #t)) ; opaque
+
+  (define (make-record-type-data name uid sealed? opaque? field-specs parent)
+    ((typed-vector-constructor :record-type-data)
+     name uid sealed? opaque? field-specs parent))
+
+  (define (record-type-data? thing)
+    ((vector-type-predicate :record-type-data) thing))
+
+  (define (typed-vector-ref t v pos)
+    ((typed-vector-accessor t pos) v))
+
+  (define (record-type-name rtd)
+    (typed-vector-ref :record-type-data (vector-type-data rtd) 0))
+  (define (record-type-uid rtd)
+    ;; this is #f in the generative case
+    (typed-vector-ref :record-type-data (vector-type-data rtd) 1))
+  (define (record-type-sealed? rtd)
+    (typed-vector-ref :record-type-data (vector-type-data rtd) 2))
+  (define (record-type-opaque? rtd)
+    (typed-vector-ref :record-type-data (vector-type-data rtd) 3))
+  (define (record-type-field-specs rtd)
+    (typed-vector-ref :record-type-data (vector-type-data rtd) 4))
+  (define (record-type-parent rtd)
+    (typed-vector-ref :record-type-data (vector-type-data rtd) 5))
+
+  (define (record-type-descriptor=? rtd-1 rtd-2)
+    (and (eq? (record-type-parent rtd-1) (record-type-parent rtd-2))
+	 (eq? (record-type-uid rtd-1) (record-type-uid rtd-2))
+	 (for-all field-spec=?
+		  (record-type-field-specs rtd-1)
+		  (record-type-field-specs rtd-2))))
+
+  (define (uid->record-type-descriptor uid)
+    (find (lambda (rtd)
+	    (eq? (record-type-uid rtd) uid))
+	  *nongenerative-record-types*))
+
+  (define (record-type-generative? rtd)
+    (not (record-type-uid rtd)))
+
+  (define *nongenerative-record-types* '())
+
+  (define (append-field-mutable-specs parent)
+    (if parent
+	(append (append-field-mutable-specs (record-type-parent parent))
+		(map field-spec-mutable? (record-type-field-specs parent)))
+	'()))
+
+  (define (make-record-type-descriptor name parent uid sealed? opaque? field-specs)
+    (if (not (symbol? name))
+        (assertion-violation 'make-record-type-descriptor "not a symbol for record type name" name))
+    (if (not (or (not parent)
+                 (record-type-descriptor? parent)))
+	(assertion-violation 'make-record-type-descriptor "parent not #f or a record type descriptor" parent))             
+    (if (not (or (not uid)
+                 (symbol? uid)))
+	(assertion-violation 'make-record-type-descriptor "uid must be #f or a symbol" parent))
+    (if (and parent
+	     (record-type-sealed? parent))
+	(assertion-violation 'make-record-type-descriptor "can't extend a sealed parent type" parent))
+    (if (not (list? field-specs))
+        (assertion-violation 'make-record-type-descriptor "field specification must be a list" field-specs))
+    (let ((opaque? (if parent
+		       (or (record-type-opaque? parent)
+			   opaque?)
+		       opaque?))
+	  (field-specs (map parse-field-spec field-specs)))
+      (let ((rtd 
+	     (make-vector-type name
+			       parent
+			       (make-record-type-data name uid (and sealed? #t) (and opaque? #t) field-specs parent)
+			       (append (append-field-mutable-specs parent)
+				       (map field-spec-mutable? field-specs))
+			       opaque?)))
+	(if uid
+	    (cond
+	     ((uid->record-type-descriptor uid)
+	      => (lambda (old-rtd)
+		   (if (record-type-descriptor=? rtd old-rtd)
+		       old-rtd
+		       (assertion-violation 'make-record-type
+                                            "mismatched nongenerative record types with identical uids"
+                                            old-rtd rtd))))
+	     (else
+	      (set! *nongenerative-record-types* 
+		    (cons rtd *nongenerative-record-types*))
+	      rtd))
+	    rtd))))
+
+  (define (record-type-descriptor? thing)
+    (and (vector-type? thing)
+	 (record-type-data? (vector-type-data thing))))
+
+  (define (ensure-rtd thing)
+    (if (not (record-type-descriptor? thing))
+	(assertion-violation 'make-record-type "not a record-type descriptor" thing)))
+
+  (define (parse-field-spec spec)
+    (if (not (and (list? spec)
+                  (= 2 (length spec))))
+        (assertion-violation 'make-record-type
+                             "field spec list element is not a list of two elements"
+                             spec))
+    (apply (lambda (mutability name)
+             (if (not (symbol? name))
+                 (assertion-violation 'make-record-type
+                                      "field spec name is not a symbol"
+                                      name))
+	     (make-field-spec
+	      (case mutability
+		((mutable) #t)
+		((immutable) #f)
+		(else (assertion-violation 'make-record-type
+                                           "field spec with invalid mutability specification" spec)))
+	      name))
+	   spec))
+
+  (define (record-type-field-names rtd)
+    (map field-spec-name (record-type-field-specs rtd)))
+
+  (define (field-count rtd)
+    (let loop ((rtd rtd)
+	       (count 0))
+      (if (not rtd)
+	  count
+	  (loop (record-type-parent rtd)
+		(+ count (length (record-type-field-specs rtd)))))))
+  
+  (define (record? thing)
+    (and (typed-vector? thing)
+	 (let ((rtd (typed-vector-type thing)))
+	   (and (record-type-descriptor? rtd)
+		(not (record-type-opaque? rtd))))))
+
+  (define (record-rtd rec)
+    (if (record? rec)
+	(typed-vector-type rec)
+	(assertion-violation 'record-rtd "cannot extract rtd of a non-record or opaque record" rec)))
+
+  ;; Constructing constructors
+
+  (define :record-constructor-descriptor (make-vector-type 'record-constructor-descriptor #f #f '(#f #f #f #f) #t))
+
+  (define record-type-constrctor-descriptor?
+    (vector-type-predicate :record-constructor-descriptor))
+
+  (define (make-record-constructor-descriptor rtd previous protocol)
+    (if (not (record-type-descriptor? rtd))
+        (assertion-violation 'make-record-constructor-descriptor
+                             "not a record type descriptor" rtd))
+    (if (not (or (not previous)
+                 (record-type-constrctor-descriptor? previous)))
+        (assertion-violation 'make-record-constructor-descriptor
+                             "not #f or a parent record type constructor descriptor" previous))
+    (if (not (or (not protocol)
+                 (procedure? protocol)))
+        (assertion-violation 'make-record-constructor-descriptor
+                             "not #f or procedure for protocol" protocol))
+    (let ((parent (record-type-parent rtd)))
+      (if (and previous (not parent))
+	  (assertion-violation 'make-record-constructor-descriptor
+                               "mismatch between rtd and constructor descriptor" rtd previous))
+      (if (and protocol parent (not previous))
+          (assertion-violation 'make-record-constructor-descriptor
+                               "non-default protocol requested, but no parent constrcutor descriptor given" rtd previous))
+      (if (and previous
+	       (not protocol)
+	       (record-constructor-descriptor-custom-protocol? previous))
+	  (assertion-violation 'make-record-constructor-descriptor
+                               "default protocol requested when parent constructor descriptor has custom one"
+                               protocol previous)) 
+      
+      (let ((custom-protocol? (and protocol #t))
+	    (protocol (or protocol (default-protocol rtd)))
+	    (previous
+	     (if (or previous
+		     (not parent))
+		 previous
+		 (make-record-constructor-descriptor parent #f #f))))
+	
+	((typed-vector-constructor :record-constructor-descriptor)
+	 rtd protocol custom-protocol? previous))))
+
+  (define (split-at l n)
+    (if (zero? n)
+	(values '() l)
+	(let-values (((a b) (split-at (cdr l) (- n 1))))
+	  (values (cons (car l) a) b))))
+
+  (define (default-protocol rtd)
+    (let ((parent (record-type-parent rtd)))
+      (if (not parent)
+	  (lambda (p)
+	    (lambda field-values
+	      (apply p field-values)))
+	  (let ((parent-field-count (field-count parent)))
+	    (lambda (p)
+	      (lambda all-field-values
+		(call-with-values
+		    (lambda () (split-at all-field-values parent-field-count))
+		  (lambda (parent-field-values this-field-values)
+		    (apply (apply p parent-field-values) this-field-values)))))))))
+
+  (define (record-constructor-descriptor-rtd desc)
+    (typed-vector-ref :record-constructor-descriptor desc 0))
+  (define (record-constructor-descriptor-protocol desc)
+    (typed-vector-ref :record-constructor-descriptor desc 1))
+  ;; this field is for error checking
+  (define (record-constructor-descriptor-custom-protocol? desc)
+    (typed-vector-ref :record-constructor-descriptor desc 2))
+  (define (record-constructor-descriptor-previous desc)
+    (typed-vector-ref :record-constructor-descriptor desc 3))
+
+  ;; A "seeder" is the procedure passed to the cons conser, used to seed
+  ;; the initial field values.
+
+  (define (make-make-seeder real-rtd wrap for-desc)
+    (let recur ((for-desc for-desc))
+      (let* ((for-rtd (record-constructor-descriptor-rtd for-desc))
+	     (for-rtd-field-count (length (record-type-field-specs for-rtd))))
+	(cond
+	 ((record-constructor-descriptor-previous for-desc)
+	  => (lambda (parent-desc)
+	       (let ((parent-protocol (record-constructor-descriptor-protocol parent-desc))
+		     (parent-make-seeder (recur parent-desc)))
+		 (lambda extension-field-values
+		   (lambda parent-protocol-args
+		     (lambda for-rtd-field-values
+		       (if (not (= (length for-rtd-field-values) for-rtd-field-count))
+			   (assertion-violation 'make-record-constructor
+                                                "wrong number of arguments to record constructor"
+                                                for-rtd for-rtd-field-values))
+		       (apply (parent-protocol
+			       (apply parent-make-seeder
+				      (append for-rtd-field-values extension-field-values)))
+			      parent-protocol-args)))))))
+	 (else
+	  (lambda extension-field-values
+	    (lambda for-rtd-field-values
+	      (if (not (= (length for-rtd-field-values) for-rtd-field-count))
+		  (assertion-violation 'make-record-constructor
+                                       "wrong number of arguments to record constructor"
+                                       for-rtd for-rtd-field-values))
+	      (wrap
+	       (apply (typed-vector-constructor real-rtd)
+		      (append for-rtd-field-values extension-field-values))))))))))
+
+  ;; does RTD-1 represent an ancestor of RTD-2?
+
+  ;; This suggests the corresponding procedure in VECTOR-TYPES should be
+  ;; abstracted out.
+
+  (define (rtd-ancestor? rtd-1 rtd-2)
+    (let loop ((rtd-2 rtd-2))
+      (or (eq? rtd-1 rtd-2)
+	  (and rtd-2
+	       (loop (record-type-parent rtd-2))))))
+
+  (define (record-constructor desc)
+    (let* ((rtd (record-constructor-descriptor-rtd desc)))
+      ((record-constructor-descriptor-protocol desc)
+       ((make-make-seeder rtd (lambda (r) r) desc)))))
+
+  (define (record-predicate rtd)
+    (vector-type-predicate rtd))
+
+  (define (check-field-id who rtd field-id)
+    (if (not (record-type-descriptor? rtd))
+        (assertion-violation who
+                             "not a record type descriptor" rtd))
+    (if (not (and (integer? field-id)
+                  (exact? field-id)
+                  (>= field-id 0)
+                  (< field-id (length (record-type-field-specs rtd)))))
+        (assertion-violation who
+                             "invalid index (not a non-negative exact integer less than the field count)" field-id)))
+
+  (define (record-accessor rtd field-id)
+    (check-field-id 'record-accessor rtd field-id)
+    (typed-vector-accessor rtd (field-id-index rtd field-id)))
+
+  (define (record-mutator rtd field-id)
+    (check-field-id 'record-mutator rtd field-id)
+    (if (not (record-field-mutable? rtd field-id))
+	(assertion-violation 'record-mutator
+                             "record-mutator called on immutable field" rtd field-id))
+    (typed-vector-mutator rtd (field-id-index rtd field-id)))
+
+  ;; A FIELD-ID is an index, which refers to a field in RTD itself.
+  (define (field-id-index rtd field-id)
+    (+ (field-count (record-type-parent rtd))
+       field-id))
+
+  (define (record-field-mutable? rtd field-id)
+    (field-spec-mutable? (list-ref (record-type-field-specs rtd) field-id))))

collects/r6rs/private/records-explicit.ss

@@ -0,0 +1,265 @@
+#!r6rs
+
+;; Implementation of explicit-naming layer for R6RS Records
+
+;; Based on the SRFI implementation:
+; Copyright (C) Michael Sperber (2005). All Rights Reserved. 
+; 
+; Permission is hereby granted, free of charge, to any person
+; obtaining a copy of this software and associated documentation files
+; (the "Software"), to deal in the Software without restriction,
+; including without limitation the rights to use, copy, modify, merge,
+; publish, distribute, sublicense, and/or sell copies of the Software,
+; and to permit persons to whom the Software is furnished to do so,
+; subject to the following conditions:
+; 
+; The above copyright notice and this permission notice shall be
+; included in all copies or substantial portions of the Software.
+; 
+; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+; SOFTWARE.
+
+(library (r6rs private records-explicit)
+  (export define-record-type
+	  record-type-descriptor
+	  record-constructor-descriptor
+          fields mutable immutable parent protocol 
+          sealed opaque nongenerative)
+  (import (rnrs base)
+	  (rnrs records procedural))
+
+  (define-syntax define-aux
+    (syntax-rules ()
+      [(_ id) (define-syntax id (syntax-rules ()))]
+      [(_ id ...) (begin (define-aux id) ...)]))
+
+  (define-aux
+    fields mutable immutable parent protocol sealed opaque nongenerative)
+
+  ;; ASSQ at the syntax level
+  (define-syntax define-alist-extractor
+    (syntax-rules ()
+      ((define-alist-extractor ?name ?name/cps ?tag ?default)
+       (begin
+
+	 (define-syntax ?name/cps
+	   (syntax-rules (?tag)
+	     ((?name/cps () ?k . ?rands)
+	      (?k ?default . ?rands))
+	     ((?name/cps ((?tag ?val) . ?rest) ?k . ?rands)
+	      (?k ?val . ?rands))
+	     ((?name/cps ((?another-tag ?val) . ?rest) ?k . ?rands)
+	      (?name/cps ?rest ?k . ?rands))))
+
+	 (define-syntax ?name
+	   (syntax-rules (?tag)
+	     ((?name ())
+	      ?default)
+	     ((?name ((?tag ?val) . ?rest))
+	      ?val)
+	     ((?name ((?another-tag ?val) . ?rest))
+	      (?name ?rest))))))))
+
+  (define-alist-extractor extract-parent extract-parent/cps parent no-record-type)
+  (define-alist-extractor extract-sealed extract-sealed/cps sealed #f)
+  (define-alist-extractor extract-opaque extract-opaque/cps opaque #f)
+  (define-alist-extractor extract-protocol extract-protocol/cps
+    protocol #f)
+  (define-alist-extractor extract-nongenerative extract-nongenerative/cps nongenerative #f)
+
+  (define-alist-extractor extract-record-name extract-record-name/cps record-name cant-happen)
+  (define-alist-extractor extract-constructor-name extract-constructor-name/cps
+    constructor-name cant-happen)
+  (define-alist-extractor extract-predicate-name extract-predicate-name/cps
+    predicate-name cant-happen)
+
+
+  (define-syntax define-record-type
+    (syntax-rules ()
+      ((define-record-type (?record-name ?constructor-name ?predicate-name)
+	 ?clause ...)
+       (define-record-type-1
+	 ((record-name ?record-name)		; prop alist
+	  (constructor-name ?constructor-name)
+	  (predicate-name ?predicate-name))
+	 ()				; fields
+	 ?clause ...))))
+
+  (define-syntax define-record-type-1
+    (syntax-rules (parent protocol sealed nongenerative opaque fields mutable immutable)
+      ;; find PARENT clause
+      ((define-record-type-1 ?props
+	 ?field-specs
+	 (parent ?parent)
+	 ?clause ...)
+       (define-record-type-1 ((parent ?parent) . ?props)
+	 ?field-specs
+	 ?clause ...))
+
+      ;; find PROTOCOL clause
+      ((define-record-type-1 ?props
+	 ?field-specs
+	 (protocol ?protocol)
+	 ?clause ...)
+       (define-record-type-1 ((protocol ?protocol) . ?props)
+	 ?field-specs
+	 ?clause ...))
+
+      ;; find SEALED clause
+      ((define-record-type-1 ?props
+	 ?field-specs
+	 (sealed #t)
+	 ?clause ...)
+       (define-record-type-1 ((sealed #t) . ?props)
+	 ?field-specs
+	 ?clause ...))
+      ((define-record-type-1 ?props
+	 ?field-specs
+	 (sealed #f)
+	 ?clause ...)
+       (define-record-type-1 ((sealed #f) . ?props)
+	 ?field-specs
+	 ?clause ...))
+
+      ;; find OPAQUE clause
+      ((define-record-type-1 ?props
+	 ?field-specs
+	 (opaque #t)
+	 ?clause ...)
+       (define-record-type-1 ((opaque #t) . ?props)
+	 ?field-specs
+	 ?clause ...))
+      ((define-record-type-1 ?props
+	 ?field-specs
+	 (opaque #f)
+	 ?clause ...)
+       (define-record-type-1 ((opaque #f) . ?props)
+	 ?field-specs
+	 ?clause ...))
+
+      ;; parse FIELDS clause
+
+      ;; base case
+      ((define-record-type-1 ?props
+	 (?field-spec ...)
+	 (fields)
+	 ?clause ...)
+       (define-record-type-1 ?props
+	 (?field-spec ...)
+	 ?clause ...))
+
+      ;; complete spec
+      ((define-record-type-1 ?props
+	 (?field-spec ...)
+	 (fields (immutable ?field-name ?accessor) ?rest ...)
+	 ?clause ...)
+       (define-record-type-1 ?props
+	 (?field-spec ... (immutable ?field-name (?accessor))) 
+	 (fields ?rest ...)
+	 ?clause ...))
+
+      ((define-record-type-1 ?props
+	 (?field-spec ...)
+	 (fields (mutable ?field-name ?accessor ?mutator) ?rest ...)
+	 ?clause ...)
+       (define-record-type-1 ?props
+	 (?field-spec ... (mutable ?field-name (?accessor ?mutator)))
+	 (fields ?rest ...)
+	 ?clause ...))
+
+      ;; find NONGENERATIVE clause
+      ((define-record-type-1 ?props
+	 ?field-specs
+	 (nongenerative ?uid)
+	 ?clause ...)
+       (define-record-type-1 ((nongenerative '?uid) . ?props)
+	 ?field-specs
+	 ?clause ...))
+
+      ;; generate code
+      ((define-record-type-1 ?props
+	 ((?mutability ?field-name ?procs) ...))
+
+       (begin
+	 ;; where we need LETREC* semantics if this is to work internally
+
+	 (define $rtd
+	   (make-record-type-descriptor (extract-record-name/cps ?props quote)
+					(extract-parent/cps ?props record-type-descriptor)
+					(extract-nongenerative ?props)
+					(extract-sealed ?props)
+					(extract-opaque ?props)
+					'((?mutability ?field-name) ...)))
+
+	 (define $constructor-descriptor
+	   (make-record-constructor-descriptor
+	    $rtd
+	    (extract-parent/cps ?props record-constructor-descriptor)
+	    (extract-protocol ?props)))
+
+	 (extract-record-name/cps
+	  ?props
+	  define-record-type-name $rtd $constructor-descriptor)
+
+	 (extract-constructor-name/cps
+	  ?props
+	  define
+	  (record-constructor $constructor-descriptor))
+	 
+	 (extract-predicate-name/cps ?props
+				     define (record-predicate $rtd))
+
+	 (define-record-fields $rtd
+	   0 (?field-name ?procs) ...)))))
+
+  (define-syntax define-record-type-name
+    (syntax-rules ()
+      ((define-record-type-name ?name ?rtd ?constructor-descriptor)
+       (define-syntax ?name
+	 (syntax-rules (descriptor constructor-descriptor)
+	   ((?name descriptor) ?rtd)
+	   ((?name constructor-descriptor) ?constructor-descriptor))))))
+
+  (define-syntax no-record-type
+    (syntax-rules (descriptor constructor-descriptor)
+      ((?name descriptor) #f)
+      ((?name constructor-descriptor) #f)))
+
+  (define-syntax record-type-descriptor
+    (syntax-rules ()
+      ((record-type-descriptor ?record-type)
+       (?record-type descriptor))))
+
+  (define-syntax record-constructor-descriptor
+    (syntax-rules ()
+      ((record-constructor-descriptor ?record-type)
+       (?record-type constructor-descriptor))))
+
+  (define-syntax define-record-fields
+    (syntax-rules ()
+      ((define-record-fields ?rtd ?index)
+       (begin))
+      ((define-record-fields ?rtd ?index (?field-name ?procs) . ?rest)
+       (begin
+	 (define-record-field ?rtd ?field-name ?index ?procs)
+	 (define-record-fields ?rtd (+ 1 ?index) . ?rest)))))
+
+  (define-syntax define-record-field
+    (syntax-rules ()
+      ((define-record-field ?rtd
+	 ?field-name ?index (?accessor-name))
+       (define ?accessor-name
+	 (record-accessor ?rtd ?index)))
+      ((define-record-field ?rtd
+	 ?field-name ?index (?accessor-name ?mutator-name))
+       (begin
+	 (define ?accessor-name
+	   (record-accessor ?rtd ?index))
+	 (define ?mutator-name
+	   (record-mutator ?rtd ?index)))))))

collects/r6rs/private/vector-types.ss

@@ -0,0 +1,93 @@
+#lang scheme/base
+
+; PLT module definition for vector types for R6RS Records
+
+; Copyright (C) Matthew Flatt (2006). All Rights Reserved. 
+; 
+; Permission is hereby granted, free of charge, to any person
+; obtaining a copy of this software and associated documentation files
+; (the "Software"), to deal in the Software without restriction,
+; including without limitation the rights to use, copy, modify, merge,
+; publish, distribute, sublicense, and/or sell copies of the Software,
+; and to permit persons to whom the Software is furnished to do so,
+; subject to the following conditions:
+; 
+; The above copyright notice and this permission notice shall be
+; included in all copies or substantial portions of the Software.
+; 
+; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+; SOFTWARE.
+
+(require scheme/mpair)
+
+(provide (rename-out [make-a-vector-type make-vector-type])
+         vector-type?
+         vector-type-data
+         vector-type-predicate
+         typed-vector-constructor
+         typed-vector-accessor typed-vector-mutator
+         typed-vector?
+         typed-vector-type)
+
+(define-struct vector-type (data field-count supertype
+                                 struct-type constructor predicate accessor mutator))
+
+(define-values (prop:typed-vector typed-vector? typed-vector-ref)
+  (make-struct-type-property 'typed-vector))
+
+(define (make-a-vector-type name supertype data field-mutability opaque?)
+  (let* ([super-field-count (if supertype
+                                (vector-type-field-count supertype)
+                                0)]
+         [field-mutability (list-tail (mlist->list field-mutability) super-field-count)]
+         [bx (box #f)])
+    (let-values ([(struct: make-s s? s-ref s-set!)
+                  (make-struct-type name 
+                                    (and supertype
+                                         (vector-type-struct-type supertype))
+                                    (length field-mutability) 0 #f
+                                    (list (cons prop:typed-vector bx))
+                                    (and opaque? (current-inspector))
+                                    #f ; not a procedure
+                                    (let loop ([field-mutability field-mutability]
+                                               [index 0])
+                                      (cond
+                                       [(null? field-mutability) null]
+                                       [(not (car field-mutability)) (cons index
+                                                                           (loop (cdr field-mutability)
+                                                                                 (add1 index)))]
+                                       [else (loop (cdr field-mutability) (add1 index))])))])
+      (let ([vt (make-vector-type data 
+                                  (+ (length field-mutability) super-field-count)
+                                  supertype
+                                  struct: make-s s? 
+                                  s-ref s-set!)])
+        (set-box! bx vt)
+        vt))))
+
+(define (vector-type-index t pos)
+  (let* ([supertype (vector-type-supertype t)]
+         [super-field-count (if supertype
+                                (vector-type-field-count supertype)
+                                0)])
+    (if (pos . < . super-field-count)
+        (vector-type-index supertype pos)
+        (- pos super-field-count))))
+
+(define (typed-vector-constructor t)
+  (vector-type-constructor t))
+
+(define (typed-vector-type v)
+  (unbox (typed-vector-ref v)))
+
+(define (typed-vector-accessor t pos)
+  (make-struct-field-accessor (vector-type-accessor t) (vector-type-index t pos)))
+
+(define (typed-vector-mutator t pos)
+  (make-struct-field-mutator (vector-type-mutator t) (vector-type-index t pos)))

collects/rnrs/arithmetic/bitwise-6.ss

@@ -0,0 +1,38 @@
+#lang scheme/base
+
+(provide bitwise-and
+         bitwise-ior
+         bitwise-xor
+         bitwise-not
+         bitwise-if
+         (rename-out [integer-length bitwise-length])
+         bitwise-first-bit-set
+         (rename-out [arithmetic-shift bitwise-arithmetic-shift])
+         bitwise-arithmetic-shift-left
+         bitwise-arithmetic-shift-right
+         bitwise-copy-bit)
+
+
+(define (bitwise-if a b c)
+  (bitwise-ior (bitwise-and a b)
+               (bitwise-and (bitwise-not a) c)))
+
+(define (bitwise-first-bit-set b)
+  (if (zero? b)
+      -1
+      (let loop ([b b][pos 0])
+        (if (zero? (bitwise-and b 1))
+            (loop (arithmetic-shift b) (add1 pos))
+            pos))))
+
+
+(define (bitwise-arithmetic-shift-left v s)
+  (arithmetic-shift v s))
+(define (bitwise-arithmetic-shift-right v s)
+  (arithmetic-shift v (- s)))
+
+(define (bitwise-copy-bit a b c)
+  (let ([mask (bitwise-arithmetic-shift-left 1 b)])
+    (bitwise-if mask
+                (bitwise-arithmetic-shift-left c b)
+                a)))

collects/rnrs/arithmetic/fixnums-6.ss

@@ -0,0 +1,184 @@
+#lang scheme/base
+
+(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)
+         (for-syntax r6rs/private/inline-rules))
+
+(provide fixnum?
+         fixnum-width
+         least-fixnum
+         greatest-fixnum)
+
+(define (fixnum-width) 30)
+(define (least-fixnum) -1073741824)
+(define (greatest-fixnum) +1073741824)
+
+(define (r6rs:fixnum? v)
+  (and (exact-integer? v)
+       (<= -1073741824 v 1073741823)))
+
+(define-syntax fixnum?
+  (inline-rules
+   r6rs:fixnum?
+   [(_ a) (let ([v a])
+            (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 ...))
+  (if (fixnum? v)
+      v
+      (fx-proc tmp ...)))
+
+(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)]))]))
+
+(define-fx = fx=? (a b c ...) nocheck)
+(define-fx > fx>? (a b c ...) nocheck)
+(define-fx < fx<? (a b c ...) nocheck)
+(define-fx <= fx<=? (a b c ...) nocheck)
+(define-fx >= fx>=? (a b c ...) nocheck)
+
+(define-fx zero? fxzero? (a) nocheck)
+(define-fx positive? fxpositive? (a) nocheck)
+(define-fx negative? fxnegative? (a) nocheck)
+(define-fx odd? fxodd? (a) nocheck)
+(define-fx even? fxeven? (a) nocheck)
+
+(define-fx max fxmax (a b ...) nocheck)
+(define-fx max fxmin (a b ...) nocheck)
+
+(define-fx + fx+ (a b) check)
+(define-fx * fx* (a b) check)
+(define-fx - fx- [(a) (a b)] check)
+
+(define-fx div-and-mod fxdiv-and-mod (a b) nocheck)
+(define-fx div fxdiv (a b) nocheck)
+(define-fx mod fxmod (a b) nocheck)
+(define-fx div0-and-mod0 fxdiv0-and-mod0 (a b) nocheck)
+(define-fx div0 fxdiv0 (a b) nocheck)
+(define-fx mod0 fxmod0 (a b) nocheck)
+
+(define (fx+/carry a b c)
+  '...)
+
+(define (fx-/carry a b c)
+  '...)
+
+(define (fx*/carry a b c)
+  '...)
+
+(define-fx bitwise-not fxnot (a) nocheck)
+(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 (fxif a b c)
+  '...
+  (bitwise-if a b c))
+
+(define-syntax-rule (define-shifter fxarithmetic-shift r6rs:fxarithmetic-shift
+                      lower-bound bounds adjust)
+  (begin
+    (provide fxarithmetic-shift)
+    (define-syntax fxarithmetic-shift
+      (inline-rules
+       r6rs:fxarithmetic-shift
+       [(_ a b)
+        (let ([t1 a]
+              [t2 b])
+          (if (and (fixnum? a)
+                   (and (exact-integer? b) (<= lower-bound b 30)))
+              (let ([v (arithmetic-shift a (adjust b))])
+                (if (fixnum? v)
+                    v
+                    (r6rs:fxarithmetic-shift t1 t2)))
+              (r6rs:fxarithmetic-shift t1 t2)))]))
+    (define (r6rs:fxarithmetic-shift a b)
+      (unless (fixnum? a)
+        (raise-type-error 'fxarithmetic-shift "fixnum" a))
+      (unless (and (exact-integer? b) (<= lower-bound b 30))
+        (raise-type-error 'fxarithmetic-shift bounds b))
+      (let ([v (arithmetic-shift a (adjust b))])
+        (if (fixnum? v)
+            v
+            (implementation-restriction 'fxarithmetic-shift v))))))
+
+(define-shifter fxarithmetic-shift r6rs:fxarithmetic-shift
+  -30 "exact integer in [-30, 30]" values)
+(define-shifter fxarithmetic-shift-left r6rs:fxarithmetic-shift-left
+  0 "exact integer in [0, 30]" values)
+(define-shifter fxarithmetic-shift-right r6rs:fxarithmetic-shift-right
+  0 "exact integer in [0, 30]" -)

collects/rnrs/base-6.ss

@@ -2,21 +2,19 @@
 
 (require (for-syntax scheme/base
                      r6rs/private/identifier-syntax)
+         r6rs/private/qq-gen
          (prefix-in r5rs: r5rs)
          (only-in r6rs/private/readtable rx:number)
          scheme/bool)
 
 (provide 
- ;; PLT Scheme pre-requisites:
- (rename-out [datum #%datum])
- #%app #%top #%top-interaction
 
  ;; 11.2
  (rename-out [r5rs:define define]
-             [r5rs:define-syntax define-syntax])
+             [r6rs:define-syntax define-syntax])
 
  ;; 11.4.1
- quote
+ (rename-out [r5rs:quote quote])
 
  ;; 11.4.2
  (rename-out [r5rs:lambda lambda])
@@ -154,13 +152,13 @@
  assertion-violation assert
 
  ;; 11.15
- apply
+ (rename-out [r5rs:apply apply])
  call-with-current-continuation call/cc
  values call-with-values
  dynamic-wind
 
  ;; 11.17
- (rename-out [r5rs:quasiquote quasiquote]) ;; FIXME: need the R6RS extension
+ (rename-out [r6rs:quasiquote quasiquote])
  unquote unquote-splicing
 
  ;; 11.18
@@ -168,7 +166,9 @@
 
  ;; 11.19
  (for-syntax syntax-rules
-             identifier-syntax)
+             identifier-syntax
+             ...
+             _)
 
  )
 
@@ -291,32 +291,72 @@
 (define-struct (exn:fail:contract:r6rs exn:fail:contract) (who irritants))
 
 (define (r6rs:error who msg . irritants)
+  (raise
    (make-exn:fail:r6rs
     (format "~a: ~a" who msg)
     (current-continuation-marks)
     who
-   irritants))
+    irritants)))
 
 (define (assertion-violation who msg . irritants)
+  (raise
    (make-exn:fail:r6rs
     (format "~a: ~a" who msg)
     (current-continuation-marks)
     who
-   irritants))
+    irritants)))
 
 (define-syntax-rule (assert expr)
   (unless expr
     (assrtion-violation #f "assertion failed")))
 
 ;; ----------------------------------------
-;; Datum
+;; quasiquote generalization
 
-(define-syntax (datum stx)
+(define-generalized-qq r6rs:quasiquote 
+  quasiquote unquote unquote-splicing)
+
+;; ----------------------------------------
+;; define-syntax: wrap a transformer to
+;;  ensure that the result of an expansion is
+;;  a wrapped syntax object.
+
+(define-syntax (r6rs:define-syntax stx)
   (syntax-case stx ()
-    [(_ . thing)
+    [(_ id expr)
-     (if (vector? (syntax-e #'thing))
+     (identifier? #'id)
-         (raise-syntax-error 'r6rs
+     (syntax/loc stx
-                             "a vector is not an expression"
+       (define-syntax id (wrap-as-needed expr)))]))
-                             #'thing)
+
-         #`(quote thing))]))
+(define-for-syntax (wrap r stx)
+  (cond
+   [(syntax? r) r]
+   [(symbol? r) (error 'macro
+                       "transformer result included a raw symbol: ~e"
+                       r)]
+   [(mpair? r) (datum->syntax
+                stx
+                (cons (wrap (mcar r) stx)
+                      (wrap (mcdr r) stx))
+                stx)]
+   [(vector? r) (datum->syntax
+                 stx
+                 (list->vector
+                  (map (lambda (r) (wrap r stx))
+                       (vector->list r)))
+                 stx)]
+   [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))
 

collects/rnrs/control-6.ss

@@ -0,0 +1,45 @@
+#lang scheme/base
+
+(require (for-syntax scheme/base)
+         scheme/mpair)
+
+(provide when unless do 
+         (rename-out [r6rs:case-lambda case-lambda]))
+
+(define-syntax (r6rs:case-lambda stx)
+  (syntax-case stx ()
+    [(_ clause ...)
+     (quasisyntax/loc stx
+       (case-lambda
+        . #,(map (lambda (clause)
+                   (syntax-case clause ()
+                     [[formals body1 body ...]
+                      (syntax-case #'formals ()
+                        [(id ...)
+                         (andmap identifier? (syntax->list #'(id ...)))
+                         clause]
+                        [(id ... . rest)
+                         (and (identifier? #'rest)
+                              (andmap identifier? (syntax->list #'(id ...))))
+                         #`[formals 
+                            (let ([rest (list->mlist rest)])
+                              body1 body ...)]]
+                        [rest
+                         (identifier? #'rest)
+                         #`[formals 
+                            (let ([rest (list->mlist rest)])
+                              body1 body ...)]]
+                        [_
+                         (raise-syntax-error
+                          #f
+                          "ill-formed argument sequence"
+                          stx
+                          #'formals)])]
+                     [else
+                      (raise-syntax-error
+                       #f
+                       "ill-formed clause"
+                       stx
+                       clause)]))
+                 (syntax->list #'(clause ...)))))]))
+

collects/rnrs/hashtables-6.ss

@@ -0,0 +1,137 @@
+#lang scheme/base
+
+(provide make-eq-hashtable
+         make-eqv-hashtable
+         (rename-out [r6rs:make-hashtable make-hashtable])
+         hashtable-size
+         hashtable-ref
+         hashtable-set!
+         hashtable-delete!
+         hashtable-contains?
+         hashtable-update!
+         hashtable-copy
+         hashtable-clear!
+         hashtable-keys
+         hashtable-entries
+         hashtable-equivalence-function
+         hashtable-hash-function
+         hashtable-mutable?
+         (rename-out [equal-hash-code equal-hash])
+         string-hash
+         string-ci-hash
+         symbol-hash)
+
+(define-struct hashtable ([ht #:mutable] 
+                          wrap
+                          unwrap
+                          mutable? 
+                          equivalence-function
+                          hash-function))
+
+(define-struct eqv-box (val)
+  #:property prop:equal+hash (list
+                              (lambda (a b recur) (eqv? (eqv-box-val a)
+                                                        (eqv-box-val b)))
+                              (lambda (v recur) (equal-hash-code (eqv-box-val v)))
+                              (lambda (v recur) (equal-secondary-hash-code (eqv-box-val v)))))
+                              
+
+(define (make-eq-hashtable [k 0])
+  (unless (exact-nonnegative-integer? k)
+    (raise-type-error 'make-eq-hashtable "exact, nonnegative integer" k))
+  (make-hashtable (make-hash-table) values values #t eq? #f))
+
+(define (make-eqv-hashtable [k 0])
+  (unless (exact-nonnegative-integer? k)
+    (raise-type-error 'make-eqv-hashtable "exact, nonnegative integer" k))
+  (make-hashtable (make-hash-table 'equal) make-eqv-box eqv-box-val #t eqv? #f))
+
+(define r6rs:make-hashtable
+  (let ([make-hashtable
+         (lambda (hash =? [k 0])
+           (unless (and (procedure? hash)
+                        (procedure-arity-includes? hash 1))
+             (raise-type-error 'make-hashtable "procedure (arity 1)" hash))
+           (unless (and (procedure? =?)
+                        (procedure-arity-includes? =? 2))
+             (raise-type-error 'make-hashtable "procedure (arity 2)" =?))
+           (unless (exact-nonnegative-integer? k)
+             (raise-type-error 'make-hashtable "exact, nonnegative integer" k))
+           (let ()
+             (define-struct hash-box (val)
+               #:property prop:equal+hash (list
+                                           (lambda (a b recur) (=? (hash-box-val a)
+                                                                   (hash-box-val b)))
+                                           (lambda (v recur) (hash (hash-box-val v)))
+                                           (lambda (v recur) 10001)))
+             (make-hashtable (make-hash-table 'equal) make-hash-box hash-box-val #t =? hash)))])
+    make-hashtable))
+
+(define (hashtable-size ht)
+  (hash-table-count (hashtable-ht ht)))
+
+(define tag (gensym))
+
+(define (hashtable-ref ht key default)
+  (let ([v (hash-table-get (hashtable-ht ht) ((hashtable-wrap ht) key) tag)])
+    (if (eq? v tag)
+        default
+        v)))
+
+(define (hashtable-set! ht key val)
+  (if (hashtable-mutable? ht)
+      (hash-table-put! (hashtable-ht ht) ((hashtable-wrap ht) key) val)
+      (raise-type-error 'hashtable-set! "mutable hashtable" ht)))
+
+(define (hashtable-delete! ht key)
+  (if (hashtable-mutable? ht)
+      (hash-table-remove! (hashtable-ht ht) ((hashtable-wrap ht) key))
+      (raise-type-error 'hashtable-delete! "mutable hashtable" ht)))
+
+(define (hashtable-contains? ht key)
+  (not (eq? (hash-table-get (hashtable-ht ht) ((hashtable-wrap ht) key) tag)
+            tag)))
+
+(define (hashtable-update! ht key proc default)
+  (hashtable-set! ht key (proc (hashtable-ref ht key default))))
+
+(define (hashtable-copy ht [mutable? #f])
+  (make-hashtable (hash-table-copy (hashtable-ht ht))
+                  (hashtable-wrap ht)
+                  (hashtable-unwrap ht)
+                  mutable?
+                  (hashtable-equivalence-function ht)))
+
+(define (hashtable-clear! ht [k 0])
+  (unless (exact-nonnegative-integer? k)
+    (raise-type-error 'hashtable-clear! "exact, nonnegative integer" k))
+  (if (hashtable-mutable? ht)
+      (set-hashtable-ht! (if (eq? values (hashtable-wrap ht))
+                             (make-hash-table)
+                             (make-hash-table 'equal)))
+      (raise-type-error 'hashtable-clear! "mutable hashtable" ht)))
+
+(define (hashtable-keys ht)
+  (let ([unwrap (hashtable-unwrap ht)])
+    (hash-table-map (hashtable-ht ht) (lambda (a b) (unwrap a)))))
+
+(define (hashtable-entries ht)
+  (let ([ps (hash-table-map (hashtable-ht ht) cons)]
+        [unwrap (hashtable-unwrap ht)])
+    (values (list->vector (map (lambda (p) (unwrap (car p))) ps))
+            (list->vector (map cdr ps)))))
+
+(define (string-hash s)
+  (unless (string? s)
+    (raise-type-error 'string-hash "string" s))
+  (equal-hash-code s))
+
+(define (string-ci-hash s)
+  (unless (string? s)
+    (raise-type-error 'string-ci-hash "string" s))
+  (equal-hash-code (string-foldcase s)))
+
+(define (symbol-hash s)
+  (unless (symbol? s)
+    (raise-type-error 'symbol-hash "symbol" s))
+  (eq-hash-code s))

collects/rnrs/io/simple-6.ss

@@ -0,0 +1,24 @@
+#lang scheme/base
+
+(provide (rename-out [eof eof-object])
+         eof-object?
+         call-with-input-file
+         call-with-output-file
+         input-port?
+         output-port?
+         current-input-port
+         current-output-port
+         current-error-port
+         with-input-from-file
+         with-output-to-file
+         open-input-file
+         open-output-file
+         close-input-port
+         close-output-port
+         read-char
+         peek-char
+         read
+         write-char
+         newline
+         display
+         write)

collects/rnrs/list-6.ss

@@ -0,0 +1,241 @@
+#!r6rs
+
+;; implementation mostly from Mike Sperber
+; The (rnrs lists (6)) library.
+
+(library (rnrs lists (6))
+  (export find
+          for-all exists
+ 
+          filter
+          partition
+          fold-left
+          fold-right
+          remp remove remv remq
+          memp member memv memq
+          assp assoc assv assq
+          cons*)
+  (import (rnrs base (6))
+          (rnrs control (6)))
+
+  (define (assert-procedure who obj)
+    (if (not (procedure? obj))
+        (assertion-violation who "not a procedure" obj)))
+
+  (define (find proc list)
+    (assert-procedure 'find proc)
+    (let loop ((list list))
+      (cond
+       ((null? list) #f)
+       ((proc (car list)) (car list))
+       (else (loop (cdr list))))))
+
+  (define (check-nulls who the-list the-lists lists)
+    (for-each (lambda (list)
+                (if (not (null? list))
+                    (apply assertion-violation who
+                           "argument lists don't have the same size"
+                           list lists)))
+              lists))
+
+  (define for-all 
+    (case-lambda
+     [(proc list)
+      (assert-procedure 'for-all proc)
+      (for-all1 proc list)]
+     [(proc list . lists)
+      (assert-procedure 'for-all proc)
+      (cond
+       ((null? list)
+        (check-nulls 'for-all list lists lists)
+        #t)
+       (else
+        (let loop ((list list) (lists lists))
+          (let ((next (cdr list)))
+            (cond
+             ((null? next)
+              (apply proc (car list) (map car lists))) 
+             ((apply proc (car list) (map car lists))
+              (loop next (map cdr lists)))
+             (else #f))))))]))
+
+  (define (for-all1 proc list)
+    (if (null? list)
+        #t
+        (let loop ((list list))
+          (let ((next (cdr list)))
+            (cond
+             ((null? next) (proc (car list))) 
+             ((proc (car list)) (loop next))
+             (else #f))))))
+
+  (define exists
+    (case-lambda
+     [(proc list)
+      (assert-procedure 'exists proc)
+      (exists1 proc list)]
+     [(proc list . lists)
+      (assert-procedure 'exists proc)
+      (cond
+       ((null? list)
+        (check-nulls 'exists list lists lists)
+        #f)
+       (else
+        (let loop ((list list) (lists lists))
+          (let ((next (cdr list)))
+            (if (null? next)
+                (apply proc (car list) (map car lists))
+                (or (apply proc (car list) (map car lists))
+                    (loop next (map cdr lists))))))))]))
+
+  (define (exists1 proc list)
+    (if (null? list)
+        #t
+        (let loop ((list list))
+          (let ((next (cdr list)))
+            (if (null? next)
+                (proc (car list))
+                (or (proc (car list))
+                    (loop next)))))))
+
+  (define (filter proc list)
+    (assert-procedure 'filter proc)
+    (let loop ((list list))
+      (cond ((null? list) '())
+            ((proc (car list))
+             (let ([r (loop (cdr list))])
+               (if (eq? r (cdr list))
+                   list
+                   (cons (car list) r))))
+            (else
+             (loop (cdr list))))))
+
+  (define (partition proc list)
+    (assert-procedure 'partition proc)
+    (let loop ((list list) (yes '()) (no '()))
+      (cond ((null? list)
+             (values (reverse yes) (reverse no)))
+            ((proc (car list))
+             (loop (cdr list) (cons (car list) yes) no))
+            (else
+             (loop (cdr list) yes (cons (car list) no))))))
+
+  (define (fold-left combine nil the-list . the-lists)
+    (assert-procedure 'fold-left combine)
+    (if (null? the-lists)
+        (fold-left1 combine nil the-list)
+        (let loop ((accum nil) (list the-list) (lists the-lists))
+          (if (null? list)
+              (begin
+                (check-nulls 'fold-left the-list the-lists lists)
+                accum)
+              (loop (apply combine accum (car list) (map car lists))
+                    (cdr list)
+                    (map cdr lists))))))
+
+  (define (fold-left1 combine nil list)
+    (let loop ((accum nil) (list list))
+      (if (null? list)
+          accum
+          (loop (combine accum (car list))
+                (cdr list)))))
+
+
+  (define (fold-right combine nil the-list . the-lists)
+    (assert-procedure 'fold-right combine)
+    (if (null? the-lists)
+        (fold-right1 combine nil the-list)
+        (let recur ((list the-list) (lists the-lists))
+          (if (null? list)
+              (begin
+                (check-nulls 'fold-right the-list the-lists lists)
+                nil)
+              (apply combine
+                     (car list)
+                     (append (map car lists)
+                             (cons (recur (cdr list) (map cdr lists))
+                                   '())))))))
+
+  (define (fold-right1 combine nil list)
+    (let recur ((list list))
+      (if (null? list)
+          nil
+          (combine (car list) (recur (cdr list))))))
+
+  (define (remp proc list)
+    (assert-procedure 'remp proc)
+    (let recur ((list list))
+      (cond ((null? list) '())
+            ((proc (car list))
+             (recur (cdr list)))
+            (else
+             (let ([r (recur (cdr list))])
+               (if (eq? r (cdr list))
+                   list
+                   (cons (car list) r)))))))
+
+  ;; Poor man's inliner
+  (define-syntax define-remove-like
+    (syntax-rules ()
+      ((define-remove-like ?name ?equal?)
+       (define (?name obj list)
+         (let recur ((list list))
+           (cond ((null? list) '())
+                 ((?equal? obj (car list))
+                  (recur (cdr list)))
+                 (else
+                  (let ([r (recur (cdr list))])
+                    (if (eq? r (cdr list))
+                        list
+                        (cons (car list) r))))))))))
+
+  (define-remove-like remove equal?)
+  (define-remove-like remv eqv?)
+  (define-remove-like remq eq?)
+
+  (define (memp proc list)
+    (assert-procedure 'member proc)
+    (let loop ((list list))
+      (cond ((null? list) #f)
+            ((proc (car list)) list)
+            (else (loop (cdr list))))))
+
+  (define-syntax define-member-like
+    (syntax-rules ()
+      ((define-member-like ?name ?equal?)
+       (define (?name obj list)
+         (let loop ((list list))
+           (cond ((null? list) #f)
+                 ((?equal? obj (car list)) list)
+                 (else (loop (cdr list)))))))))
+
+  (define-member-like member equal?)
+  (define-member-like memv eqv?)
+  (define-member-like memq eq?)
+
+  (define (assp proc alist)
+    (assert-procedure 'assp proc)
+    (let loop ((alist alist))
+      (if (null? alist)
+          #f
+          (let ((p (car alist)))
+            (if (proc (car p))
+                p
+                (loop (cdr alist)))))))
+
+  (define-syntax define-assoc-like
+    (syntax-rules ()
+      ((define-assoc-like ?name ?equal?)
+       (define (?name obj alist)
+         (let loop ((alist alist))
+           (if (null? alist)
+               #f
+               (let ((p (car alist)))
+                 (if (?equal? obj (car p))
+                     p
+                     (loop (cdr alist))))))))))
+
+  (define (cons* obj . objs)
+    (if (null? objs)
+        obj
+        (cons obj (apply cons* objs)))))

collects/rnrs/records/inspection-6.ss

@@ -0,0 +1,13 @@
+#!r6rs
+
+(library (rnrs records inspection (6))
+  (export record-type-name
+	  record-type-parent
+	  record-type-sealed?
+	  record-type-uid
+	  record-type-generative?
+	  record-type-field-names
+	  record-type-opaque?
+	  record-field-mutable?
+	  record? record-rtd)
+  (import (r6rs private records-core)))

collects/rnrs/records/procedural-6.ss

@@ -0,0 +1,9 @@
+#!r6rs
+
+(library (rnrs records procedural (6))
+  (export make-record-type-descriptor
+	  record-type-descriptor?
+	  make-record-constructor-descriptor record-constructor
+	  record-predicate
+	  record-accessor record-mutator)
+  (import (r6rs private records-core)))

collects/rnrs/records/syntactic-6.ss

@@ -0,0 +1,170 @@
+#!r6rs
+
+;; Implementation of implicit-naming layer for R6RS Records
+
+;; Based on the SRFI implementation:
+; Copyright (C) Michael Sperber (2005). All Rights Reserved. 
+; 
+; Permission is hereby granted, free of charge, to any person
+; obtaining a copy of this software and associated documentation files
+; (the "Software"), to deal in the Software without restriction,
+; including without limitation the rights to use, copy, modify, merge,
+; publish, distribute, sublicense, and/or sell copies of the Software,
+; and to permit persons to whom the Software is furnished to do so,
+; subject to the following conditions:
+; 
+; The above copyright notice and this permission notice shall be
+; included in all copies or substantial portions of the Software.
+; 
+; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+; SOFTWARE.
+
+(library (rnrs records syntactic (6))
+  (export define-record-type
+	  record-type-descriptor
+	  record-constructor-descriptor
+          fields mutable immutable parent protocol 
+          sealed opaque nongenerative)
+  (import (for (rnrs base (6)) run expand)
+          (for (rnrs syntax-case (6)) expand)
+	  (rename (r6rs private records-explicit)
+		  (define-record-type define-record-type/explicit)))
+
+  ;; R5RS part of the implementation of DEFINE-RECORD-TYPE for Records SRFI
+
+  (define-syntax define-record-type
+    (syntax-rules ()
+      ((define-record-type (?record-name ?constructor-name ?predicate-name)
+	 ?clause ...)
+       (define-record-type-1 ?record-name (?record-name ?constructor-name ?predicate-name)
+	 ()
+	 ?clause ...))
+      ((define-record-type ?record-name
+	 ?clause ...)
+       (define-record-type-1 ?record-name ?record-name
+	 ()
+	 ?clause ...))))
+
+  (define-syntax define-record-type-1
+    (syntax-rules (fields)
+
+      ;; find FIELDS clause
+      ((define-record-type-1 ?record-name ?record-name-spec
+	 (?simple-clause ...)
+	 (fields ?field-spec ...)
+	 ?clause ...)
+       (process-fields-clause (fields ?field-spec ...)
+			      ?record-name ?record-name-spec
+			      (?simple-clause ...)
+			      ?clause ...))
+
+      ;; collect all other clauses
+      ((define-record-type-1 ?record-name ?record-name-spec
+	 (?simple-clause ...)
+	 ?clause0
+	 ?clause ...)
+       (define-record-type-1 ?record-name ?record-name-spec
+	 (?simple-clause ... ?clause0)
+	 ?clause ...))
+
+      ;; pass it on
+      ((define-record-type-1 ?record-name ?record-name-spec
+	 (?simple-clause ...))
+
+       (define-record-type-2 ?record-name ?record-name-spec
+	 (?simple-clause ...)))))
+
+  ;; syntax-rules part
+
+  (define-syntax define-record-type-2
+    (lambda (form)
+      (syntax-case form ()
+	((_ ?record-name (?record-name-2 ?constructor-name ?predicate-name)
+	    (?simple-clause ...))
+
+	 (syntax
+	  (begin
+	    (define-record-type/explicit (?record-name ?constructor-name ?predicate-name)
+	      ?simple-clause ...))))
+
+	((_ ?record-name ?record-name-2
+	    (?simple-clause ...))
+
+	 (with-syntax ((?constructor-name
+			(datum->syntax (syntax ?record-name)
+					      (string->symbol
+					       (string-append "make-"
+							      (symbol->string
+							       (syntax->datum
+								(syntax ?record-name)))))))
+		       (?predicate-name
+			(datum->syntax (syntax ?record-name)
+					      (string->symbol
+					       (string-append (symbol->string
+							       (syntax->datum
+								(syntax ?record-name)))
+							      "?")))))
+	   
+	   
+	   (syntax
+	    (define-record-type-2 ?record-name (?record-name ?constructor-name ?predicate-name)
+	      (?simple-clause ...))))))))
+
+  (define-syntax process-fields-clause
+    (lambda (form)
+      (syntax-case form (fields mutable immutable)
+	((_ (fields ?field-clause ...)
+	    ?record-name ?record-name-spec
+	    (?simple-clause ...)
+	    ?clause ...)
+
+	 (let ((record-name (symbol->string (syntax->datum (syntax ?record-name)))))
+	   (with-syntax
+	       (((?simple-field ...)
+		 (map (lambda (clause)
+			(syntax-case clause (mutable immutable)
+			  ((immutable ?field-name)
+			   (with-syntax ((?accessor-name
+					  (datum->syntax
+					   (syntax ?field-name)
+					   (string->symbol
+					    (string-append record-name "-"
+							   (symbol->string
+							    (syntax->datum
+							     (syntax ?field-name))))))))
+			     (syntax
+			      (immutable ?field-name ?accessor-name))))
+			  ((mutable ?field-name)
+			   (with-syntax ((?accessor-name
+					  (datum->syntax
+					   (syntax ?field-name)
+					   (string->symbol
+					    (string-append record-name "-"
+							   (symbol->string
+							    (syntax->datum
+							     (syntax ?field-name)))))))
+					 (?mutator-name
+					  (datum->syntax
+					   (syntax ?field-name)
+					   (string->symbol
+					    (string-append record-name "-"
+							   (symbol->string
+							    (syntax->datum
+							     (syntax ?field-name)))
+							   "-set!")))))
+			     (syntax
+			      (mutable ?field-name ?accessor-name ?mutator-name))))
+			  (?clause
+			   clause)))
+		      (syntax (?field-clause ...)))))
+	     (syntax
+	      (define-record-type-1 
+		?record-name ?record-name-spec
+		(?simple-clause ... (fields ?simple-field ...))
+		?clause ...)))))))))

collects/rnrs/sorting-6.ss

@@ -0,0 +1,19 @@
+#lang scheme/base
+
+(require scheme/mpair)
+
+(provide list-sort
+         vector-sort
+         vector-sort!)
+
+(define (list-sort < l)
+  ;; FIXME (performance): `sort' internally converts 
+  ;; a list to an mlist!
+  (list->mlist (sort (mlist->list l) <)))
+
+(define (vector-sort < v)
+  (list->vector (sort (vector->list v) <)))
+
+(define (vector-sort! < v)
+  (let ([v2 (vector-sort < v)])
+    (vector-copy! v 0 v2)))

collects/rnrs/syntax-case-6.ss

@@ -0,0 +1,278 @@
+#lang scheme/base
+
+(require (for-syntax scheme/base)
+         r6rs/private/qq-gen
+         scheme/stxparam
+         scheme/mpair)
+
+(provide make-variable-transformer
+         (rename-out [r6rs:syntax-case syntax-case]
+                     [r6rs:syntax syntax])
+         _ ...
+         identifier?
+         bound-identifier=?
+         (rename-out [r6rs:free-identifier=? free-identifier=?]
+                     [r6rs:datum->syntax datum->syntax]
+                     [r6rs:syntax->datum syntax->datum])
+         generate-temporaries
+         (rename-out [r6rs:with-syntax with-syntax]
+                     [r6rs:quasisyntax quasisyntax])
+         unsyntax unsyntax-splicing
+         (rename-out [raise-syntax-error syntax-violation]))
+
+(define (r6rs:free-identifier=? a b)
+  (free-identifier=? a a))
+
+(define (r6rs:datum->syntax id datum)
+  (unless (identifier? id)
+    (raise-type-error 'datum->syntax "identifier?" id))
+  (datum->syntax id (convert-mpairs datum)))
+
+(define (r6rs:syntax->datum stx)
+  (convert-pairs (syntax->datum stx)))
+
+(define (make-variable-transformer proc)
+  (make-set!-transformer proc))
+
+(define unwrapped-tag (gensym))
+
+(define (wrap expr)
+  (datum->syntax #f
+                 (convert-mpairs expr)
+                 (list unwrapped-tag #f #f #f #f)))
+
+(define (convert-mpairs expr)
+  (cond
+   [(mpair? expr)
+    (cons (convert-mpairs (mcar expr))
+          (convert-mpairs (mcdr expr)))]
+   [(vector? expr)
+    (list->vector (map convert-mpairs (vector->list expr)))]
+   [else expr]))
+
+(define (convert-pairs expr)
+  (cond
+   [(pair? expr)
+    (mcons (convert-pairs (car expr))
+           (convert-pairs (cdr expr)))]
+   [(vector? expr)
+    (list->vector (map convert-pairs (vector->list expr)))]
+   [else expr]))
+
+;; R6RS syntax-case has different wrapping rules than PLT Scheme for
+;; the result of `syntax'. We have to recognize pattern variables
+;; to unwrap appropriately.
+
+;; Also, R6RS doesn't have (... <tmpl>) quoting in patterns --- only
+;; in templates. <<<< FIXME
+
+(define-syntax-parameter pattern-vars null)
+
+(provide pattern-vars)
+
+(define-for-syntax (add-pattern-vars ids)
+  (append (syntax->list ids)
+          (syntax-parameter-value (quote-syntax pattern-vars))))
+
+;; ----------------------------------------
+
+(define-for-syntax (extract-pattern-ids stx lits)
+  (syntax-case stx ()
+    [(a . b) (append (extract-pattern-ids #'a lits)
+                     (extract-pattern-ids #'b lits))]
+    [#(a ...) (apply append
+                     (map (lambda (a)
+                            (extract-pattern-ids a lits))
+                          (syntax->list #'(a ...))))]
+    [a
+     (identifier? #'a)
+     (if (or (ormap (lambda (lit)
+                      (free-identifier=? lit #'a))
+                    lits)
+             (free-identifier=? #'a #'(... ...))
+             (free-identifier=? #'a #'_))
+         null
+         (list #'a))]
+    [_ null]))
+
+(define-syntax (r6rs:syntax-case stx)
+  (syntax-case stx ()
+    [(_ expr (lit ...) clause ...)
+     (let ([lits (syntax->list #'(lit ...))])
+       (for-each (lambda (lit)
+                   (unless (identifier? lit)
+                     (raise-syntax-error #f
+                                         "bad literal"
+                                         stx
+                                         lit))
+                   (when (free-identifier=? lit #'(... ...))
+                     (raise-syntax-error #f
+                                         "ellipses cannot be literal"
+                                         stx
+                                         lit))
+                   
+                   (when (free-identifier=? lit #'_)
+                     (raise-syntax-error #f
+                                         "underscore cannot be literal"
+                                         stx
+                                         lit)))
+                 lits)
+       (quasisyntax/loc stx
+         (syntax-case (wrap expr) (lit ...)
+           . #,(map (lambda (clause)
+                      (syntax-case clause ()
+                        [(pat val)
+                         (with-syntax ([pat-ids (extract-pattern-ids #'pat lits)])
+                           #`(pat (syntax-parameterize ([pattern-vars
+                                                         (add-pattern-vars #'pat-ids)])
+                                    val)))]
+                        [(pat fender val)
+                         (with-syntax ([pat-ids (extract-pattern-ids #'pat lits)])
+                           #`(pat (syntax-parameterize ([pattern-vars
+                                                         (add-pattern-vars #'pat-ids)])
+                                    fender)
+                                  (syntax-parameterize ([pattern-vars
+                                                         (add-pattern-vars #'pat-ids)])
+                                    val)))]
+                        [else clause]))
+                    (syntax->list #'(clause ...))))))]
+    [(_ . rest) (syntax/loc stx (syntax-case . rest))]))
+
+;; ----------------------------------------
+
+(define-for-syntax (make-unwrap-map tmpl pattern-vars)
+  (let loop ([tmpl tmpl]
+             [in-ellipses? #f]
+             [counting? #f])
+    (syntax-case tmpl ()
+      [(ellipses expr)
+       (and (not in-ellipses?)
+            (identifier? #'ellipses)
+            (free-identifier=? #'ellipses #'(... ...)))
+       (loop #'expr #t #f)]
+      [(expr ellipses . rest)
+       (and (not in-ellipses?)
+            (identifier? #'ellipses)
+            (free-identifier=? #'ellipses #'(... ...)))
+       (box (cons (loop #'expr #f #f)
+                  (loop #'rest #f #t)))]
+      [(a . b) (let ([a (loop #'a in-ellipses? #f)]
+                     [b (loop #'b in-ellipses? counting?)])
+                 (if (or a b counting?)
+                     (cons a b)
+                     #f))]
+      [#(a ...) (let ([as (map (lambda (a)
+                                 (loop a in-ellipses? #f))
+                               (syntax->list #'(a ...)))])
+                  (if (ormap values as)
+                      (list->vector as)
+                      #f))]
+      [a
+       (identifier? #'a)
+       (ormap (lambda (pat-var)
+                (free-identifier=? #'a pat-var))
+              pattern-vars)]
+      [_ #f])))
+
+(define (unwrap stx mapping)
+  (cond
+   [(not mapping)
+    ;; In case stx is a pair, explicitly convert
+    (datum->syntax #f (convert-mpairs stx))]
+   [(eq? mapping #t)
+    ;; was a pattern var; unwrap based on srcloc:
+    (let loop ([v stx])
+      (cond
+       [(syntax? v)
+        (if (eq? (syntax-source v) unwrapped-tag)
+            (loop (syntax-e v))
+            v)]
+       [(pair? v) (mcons (loop (car v))
+                         (loop (cdr v)))]
+       [(vector? v) (list->vector
+                     (map loop (vector->list v)))]
+       [else v]))]
+   [(pair? mapping)
+    (let ([p (if (syntax? stx)
+                 (syntax-e stx)
+                 stx)])
+      (mcons (unwrap (car p) (car mapping))
+             (unwrap (cdr p) (cdr mapping))))]
+   [(vector? mapping)
+    (list->vector (unwrap (vector->list (syntax-e stx)) (vector->list mapping)))]
+   [(box? mapping)
+    ;; ellipses
+    (let* ([mapping (unbox mapping)]
+           [rest-mapping (cdr mapping)]
+           [rest-size 
+            ;; count number of cons cells we need at the end:
+            (let loop ([m rest-mapping])
+              (if (pair? m)
+                  (add1 (loop (cdr m)))
+                  0))]
+           [repeat-stx (reverse
+                        (list-tail (let loop ([stx stx][accum null])
+                                     (let ([p (if (syntax? stx)
+                                                  (syntax-e stx)
+                                                  stx)])
+                                       (if (pair? p)
+                                           (loop (cdr p) (cons (car p) accum))
+                                           accum)))
+                                   rest-size))]
+           [rest-stx (let loop ([stx stx][size (length repeat-stx)])
+                       (if (zero? size)
+                           stx
+                           (let ([p (if (syntax? stx)
+                                        (syntax-e stx)
+                                        stx)])
+                             (loop (cdr p) (sub1 size)))))])
+      (let ([repeats (list->mlist
+                      (map (lambda (rep)
+                             (unwrap rep (car mapping)))
+                           repeat-stx))]
+            [rest-mapping 
+             ;; collapse #fs to single #f:
+             (if (let loop ([rest-mapping rest-mapping])
+                   (if (pair? rest-mapping)
+                       (if (not (car rest-mapping))
+                           (loop (cdr rest-mapping))
+                           #f)
+                       (not rest-mapping)))
+                 #f
+                 rest-mapping)])
+                                        
+        (if (and (not rest-mapping)
+                 (or (null? rest-stx)
+                     (and (syntax? rest-stx)
+                          (null? (syntax-e rest-stx)))))
+            repeats
+            (mappend repeats
+                     (unwrap rest-stx rest-mapping)))))]
+   [else (error 'unwrap "srtange unwrap mapping: ~e" mapping)]))
+
+(define-syntax (r6rs:syntax stx)
+  (syntax-case stx ()
+    [(_ tmpl)
+     (quasisyntax/loc stx
+       (unwrap #,(syntax/loc stx (syntax tmpl))
+               '#,(make-unwrap-map #'tmpl
+                                   (syntax-parameter-value #'pattern-vars))))]
+    [(_ . rest) (syntax/loc stx (syntax . rest))]))
+
+;; ----------------------------------------
+
+;; Implementation from R6RS --- which gives the following
+;; strange behavior:
+;;
+;;  > (with-syntax ([a 10][... 11]) #'(a ...))
+;;  (10 11)
+
+
+(define-syntax r6rs:with-syntax
+  (syntax-rules ()
+    [(_ [(p e0) ...] e1 e2 ...)
+     (r6rs:syntax-case (mlist e0 ...) ()
+       [(p ...) (let () e1 e2 ...)])]))
+
+(define-generalized-qq r6rs:quasisyntax
+  quasisyntax unsyntax unyntaxquote-splicing)

collects/rnrs/unicode-6.ss

@@ -0,0 +1,39 @@
+#lang scheme/base
+
+;; FIXME: there could be all sorts of mismatches between the R6RS
+;;  definitions and those in `scheme/base'.
+
+(provide
+ char-upcase
+ char-downcase
+ char-titlecase
+ char-foldcase
+ char-ci=?
+ char-ci<?
+ char-ci>?
+ char-ci<=?
+ char-ci>=?
+ char-alphabetic?
+ char-numeric?
+ char-whitespace?
+ char-upper-case?
+ char-lower-case?
+ char-title-case?
+ char-general-category
+ 
+ string-upcase
+ string-downcase
+ string-titlecase
+ string-foldcase
+ string-ci=?
+ string-ci<?
+ string-ci>?
+ string-ci<=?
+ string-ci>=?
+ 
+ string-normalize-nfd
+ string-normalize-nfkd
+ string-normalize-nfc
+ string-normalize-nfkc)
+
+ 

collects/scribblings/scribble/struct.scrbl

@@ -399,7 +399,7 @@ label to be shown in the ``on this page'' table for HTML output.
 }
 
 
-@defstruct[(link-element element) ([tag any/c])]{
+@defstruct[(link-element element) ([tag tag?])]{
 
 Hyperlinks the content to @scheme[tag].
 

collects/srfi/32/vmsort.scm

@@ -4,7 +4,8 @@
            vector-merge-sort
            vector-merge-sort!)
   
-  (require "vector-util.scm")
+  (require "vector-util.scm"
+           (only scheme/base vector-copy!))
   
   ;;; The sort package -- stable vector merge & merge sort -*- Scheme -*-
   ;;; Copyright (c) 1998 by Olin Shivers.
@@ -66,13 +67,10 @@
   
   (define (%vector-merge! elt< v v1 v2 start start1 end1 start2 end2)
     (letrec ((vblit (lambda (fromv j i end)      ; Blit FROMV[J,END) to V[I,?].
-                      (let lp ((j j) (i i))
+                      (vector-copy! v i fromv j end))))
-                        (vector-set! v i (vector-ref fromv j))
-                        (let ((j (+ j 1)))
-                          (if (< j end) (lp j (+ i 1))))))))
       
-      (cond ((<= end1 start1) (if (< start2 end2) (vblit v2 start2 start)))
+      (cond ((<= end1 start1) (if (< start2 end2) (vblit v2 start2 start end2)))
-            ((<= end2 start2) (vblit v1 start1 start))
+            ((<= end2 start2) (vblit v1 start1 start end1))
             
             ;; Invariants: I is next index of V to write; X = V1[J]; Y = V2[K].
             (else (let lp ((i start)
@@ -105,7 +103,7 @@
                             (pair? (cdr maybe-args))
                             (pair? (cddr maybe-args)))
                        (caddr maybe-args)
-                       (vector-copy v))))
+                       (make-vector (vector-length v)))))
          (%vector-merge-sort! < v start end temp)))))
   
   (define (vector-merge-sort < v . maybe-args)
@@ -194,16 +192,14 @@
         (call-with-values
          (lambda ()
            (let recur ((l l) (want (- r l)))
-             (let ((len (- r l)))
              (let lp ((pfxlen (getrun v0 l r)) (pfxlen2 1)
                       (v v0) (temp temp0)
                       (v=v0? #t))
-                 (if (or (>= pfxlen want) (= pfxlen len))
+               (if (or (>= pfxlen want) (= pfxlen (- r l)))
                    (values pfxlen v v=v0?)
                    (let ((pfxlen2 (let lp ((j pfxlen2))
                                     (let ((j*2 (+ j j)))
-                                        (if (<= j pfxlen) (lp j*2) j))))
+                                      (if (<= j*2 pfxlen) (lp j*2) j)))))
-                           (tail-len (- len pfxlen)))
                      ;; PFXLEN2 is now the largest power of 2 <= PFXLEN.
                      ;; (Just think of it as being roughly PFXLEN.)
                      (call-with-values
@@ -213,7 +209,7 @@
                          (merge temp v nr-vec l pfxlen nr-len
                                 (xor nrvec=v0? v=v0?))
                          (lp (+ pfxlen nr-len) (+ pfxlen2 pfxlen2)
-                              temp v (not v=v0?))))))))))
+                             temp v (not v=v0?)))))))))
          (lambda (ignored-len ignored-ansvec ansvec=v0?)
            (if (not ansvec=v0?) (vector-portion-copy! v0 temp0 l r))))))
   

src/mzscheme/src/module.c

@@ -1781,6 +1781,8 @@ int scheme_is_module_path(Scheme_Object *obj)
         int i;
         mzchar *s;
         obj = SCHEME_CAR(obj);
+        if (!SCHEME_CHAR_STRINGP(obj))
+          return 0;
         s = SCHEME_CHAR_STR_VAL(obj);
         i = SCHEME_CHAR_STRLEN_VAL(obj);
         if (!i)