From f6531a307f22a70903b17c46e9fe2076bbef5622 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 26 Jul 2005 17:00:09 +0000
Subject: [PATCH] initial reference implementation of library form that might
 appear in R6RS

svn: r449
---
 collects/r6rs/doc.txt            |  51 +++++
 collects/r6rs/info.ss            |   3 +
 collects/r6rs/library-module.ss  | 149 +++++++++++++
 collects/r6rs/library-repl.ss    |  31 +++
 collects/r6rs/library.ss         |  40 ++++
 collects/r6rs/private/helpers.ss | 344 +++++++++++++++++++++++++++++++
 collects/r6rs/private/uri.ss     |  57 +++++
 collects/r6rs/r6rs.ss            |  73 +++++++
 collects/r6rs/reader.ss          | 281 +++++++++++++++++++++++++
 9 files changed, 1029 insertions(+)
 create mode 100644 collects/r6rs/doc.txt
 create mode 100644 collects/r6rs/info.ss
 create mode 100644 collects/r6rs/library-module.ss
 create mode 100644 collects/r6rs/library-repl.ss
 create mode 100644 collects/r6rs/library.ss
 create mode 100644 collects/r6rs/private/helpers.ss
 create mode 100644 collects/r6rs/private/uri.ss
 create mode 100644 collects/r6rs/r6rs.ss
 create mode 100644 collects/r6rs/reader.ss

diff --git a/collects/r6rs/doc.txt b/collects/r6rs/doc.txt
new file mode 100644
index 0000000000..c70031c9f1
--- /dev/null
+++ b/collects/r6rs/doc.txt
@@ -0,0 +1,51 @@
+
+The _r6rs_ collection contains support for things that might become
+part of the R6RS standard.
+
+
+To write an R6RS library:
+ 
+ #reader(lib "library.ss" "r6rs")
+ (library "name" ....)
+
+where "name" matches the containing file name without the file path
+or suffix.
+
+
+To evaluate R6RS `library' and `import' forms at the REPL (or with
+`load', etc):
+
+ > (require (lib "library-repl.ss" "r6rs"))
+
+or start MzScheme as
+
+ % mzscheme -L library-repl.ss r6rs
+
+
+To import a collection-based library, use
+
+ "scheme://<collection>/...<collection>/<file>"
+
+instead of
+
+ (lib "<file>" "<collection>" ... "<collection>")
+
+A "scheme://" URI must have at least one <collection> and a <file> to
+be translated to a `lib' reference. If the indicated collection does
+not exist, a path is invented based on the "mzlib" collection; this
+supports absolute URIs that name `library's entered in the REPL.
+
+
+Limitations:
+
+ - doesn't enforce that a for-run import isn't also
+   a for-expand import in a different import-spec
+
+ - doesn't enforce that idenfiers in a macro expansion
+   are only the ones declared by indirect-export
+
+ - doesn't check that an identifiers in an indirect-export
+   declaration are actually defined
+
+ - reader adjusts only string, character, and quoted-symbol
+   syntax, for now
diff --git a/collects/r6rs/info.ss b/collects/r6rs/info.ss
new file mode 100644
index 0000000000..efbb202c3b
--- /dev/null
+++ b/collects/r6rs/info.ss
@@ -0,0 +1,3 @@
+
+(module info (lib "infotab.ss" "setup")
+  (define name "R6RS"))
diff --git a/collects/r6rs/library-module.ss b/collects/r6rs/library-module.ss
new file mode 100644
index 0000000000..470e0203ce
--- /dev/null
+++ b/collects/r6rs/library-module.ss
@@ -0,0 +1,149 @@
+
+(module library-module mzscheme
+  (require-for-syntax "private/helpers.ss"
+		      (lib "kerncase.ss" "syntax")
+		      (lib "context.ss" "syntax"))
+
+  (provide (rename library-module-begin #%module-begin)
+	   import)
+
+  (define-syntax define-impdef-placeholder
+    (syntax-rules ()
+      [(_ id) (begin
+		(define-syntax (id stx)
+		  (raise-syntax-error
+		   #f
+		   "only allowed at the beginning of a `library' form"
+		   stx))
+		(provide id))]))
+
+  (define-impdef-placeholder export)
+  (define-impdef-placeholder indirect-export)
+
+  (define-syntax (import stx)
+    (unless (eq? (syntax-local-context) 'top-level)
+      (raise-syntax-error
+       #f
+       "only allowed at the beginning of a `library' form or outside a library at the top level"
+       stx))
+    (syntax-case stx ()
+      [(_ i ...)
+       #`(begin #,@(map translate-import (syntax->list #'(i ...))))]))
+
+  (define-for-syntax (split-bodies bodies)
+    (let loop ([bodies bodies]
+	       [imports null]
+	       [exports null]
+	       [indirect-exports null])
+      (if (null? bodies)
+	  (values (reverse imports)
+		  (reverse exports)
+		  (reverse indirect-exports)
+		  null)
+	  (syntax-case (car bodies) (import export indirect-export)
+	    [(import in ...)
+	     (loop (cdr bodies)
+		   (append (syntax->list #'(in ...)) imports)
+		   exports
+		   indirect-exports)]
+	    [(import . rest)
+	     (raise-syntax-error #f "bad syntax" (car bodies))]
+	    [(export out ...)
+	     (loop (cdr bodies)
+		   imports
+		   (append (syntax->list #'(out ...)) exports)
+		   indirect-exports)]
+	    [(export . rest)
+	     (raise-syntax-error #f "bad syntax" (car bodies))]
+	    [(indirect-export indirect ...)
+	     (loop (cdr bodies)
+		   imports
+		   exports
+		   (append (syntax->list #'(indirect ...)) indirect-exports))]
+	    [(indirect-export . rest)
+	     (raise-syntax-error #f "bad syntax" (car bodies))]
+	    [else (values (reverse imports)
+			  (reverse exports)
+			  (reverse indirect-exports)
+			  bodies)]))))
+
+  (define-for-syntax (make-unboxer id)
+    (with-syntax ([id id])
+      (make-set!-transformer
+       (lambda (stx)
+	 (syntax-case stx (set!)
+	   [(set! _ v) #'(set-box! id v)]
+	   [(_ arg ...) #'((unbox id) arg ...)]
+	   [_ #'(unbox id)])))))
+
+  (define-syntax (library-module-begin stx)
+    (syntax-case stx ()
+      [(_ (__ name lang body ...))
+       (let ([stx (syntax-case stx () [(_ o) #'o])])
+	 (unless (and (string? (syntax-e #'name))
+		      (uri? (syntax-e #'name)))
+	   (raise-syntax-error 
+	    #f
+	    "library name must be a URI"
+	    stx
+	    #'name))
+	 (unless (and (string? (syntax-e #'lang))
+		      (string=? "scheme://r6rs" (syntax-e #'lang)))
+	   (raise-syntax-error 
+	    #f
+	    "language position must be \"scheme://r6rs\""
+	    stx
+	    #'lang))
+	 (let ([bodies (syntax->list #'(body ...))])
+	   (let-values ([(imports exports indirect-exports bodies)
+			 (split-bodies bodies)])
+	     #`(#%plain-module-begin
+		(require #,(datum->syntax-object stx '(all-except (lib "r6rs.ss" "r6rs")
+								  #%module-begin)))
+		(require-for-syntax #,(datum->syntax-object stx '(lib "r6rs.ss" "r6rs")))
+		(require #,(datum->syntax-object stx '(lib "library-module.ss" "r6rs")))
+		#,@(map translate-import imports)
+		#,@(map translate-export exports)
+		(begin-library-body
+		 #,indirect-exports
+		 #,bodies)))))]
+      [(_ x)
+       (raise-syntax-error
+	#f
+	"bad syntax"
+	#'x)]))
+
+  (define-for-syntax stops (list*
+			    #'import
+			    #'export
+			    #'indirect-export
+			    (kernel-form-identifier-list #'here)))
+
+  (define-syntax (begin-library-body stx)
+    (syntax-case stx ()
+      [(_ indirects ())
+       #'(begin)]
+      [(_ indirects (body0 body ...))
+       (let ([comdef (local-expand #'body0
+				   'module
+				   stops)])
+	 (syntax-case comdef (begin define-syntaxes define-values)
+	   [(begin comdef ...)
+	    #`(begin-library-body indirects (comdef ... body ...))]
+	   [(define-syntaxes (id ...) rhs)
+	    #`(begin (define-syntaxes (id ...) rhs)
+		     (begin-library-body indirects (body ...)))]
+	   [(define-values (id ...) rhs)
+	    (with-syntax ([(gen-id ...) (generate-temporaries #'(id ...))])
+	      #`(begin 
+		  (define-values (gen-id ...) 
+		    (let-values ([(id ...) rhs])
+		      (values (box id) ...)))
+		  (define-syntaxes (id ...)
+		    (values (make-unboxer (quote-syntax gen-id)) ...))
+		  (begin-library-body indirects (body ...))))]
+	   [expr
+	    ;; begin0 forces an expression (not defn):
+	    #`(begin
+		(begin0 expr)
+		(begin-library-body indirects (body ...)))]))])))
diff --git a/collects/r6rs/library-repl.ss b/collects/r6rs/library-repl.ss
new file mode 100644
index 0000000000..c2f9814aaf
--- /dev/null
+++ b/collects/r6rs/library-repl.ss
@@ -0,0 +1,31 @@
+
+(module library-repl mzscheme
+  (require (all-except "library-module.ss" #%module-begin)
+	   (prefix r6rs: "reader.ss"))
+  (require-for-syntax "private/uri.ss")
+  (provide import export indirect-export library)
+
+  (current-readtable r6rs:r6rs-readtable)
+
+  (define-syntax (library stx)
+    (syntax-case stx ()
+      [(_ name . rest)
+       (unless (string? (syntax-e #'name))
+	 (raise-syntax-error
+	  #f
+	  "expected a string for the library name"
+	  stx
+	  #'name))
+       (let ([modname (uri->symbol (syntax-e #'name))])
+	 #`(begin
+	     (module #,modname (lib "library-module.ss" "r6rs")
+	       #,(datum->syntax-object
+		  #f
+		  (list '#%module-begin stx)))
+	     ;; Notify module-name resolver that we defined something that
+	     ;;  might otherwise be loaded.
+	     ((current-module-name-resolver) #f '#,modname #f)))])))
+
+
+
+
diff --git a/collects/r6rs/library.ss b/collects/r6rs/library.ss
new file mode 100644
index 0000000000..8a0d3b2a89
--- /dev/null
+++ b/collects/r6rs/library.ss
@@ -0,0 +1,40 @@
+
+(module library mzscheme
+  (provide (rename lib-read read)
+	   (rename lib-read-syntax read-syntax))
+
+  (require (prefix r6rs: "reader.ss"))
+
+  (define lib-read
+    (case-lambda
+     [() (lib-read (current-input-port))]
+     [(input) (lib-read-syntax (object-name (current-input-port)) (current-input-port))]))
+		  
+  (define lib-read-syntax
+    (case-lambda
+     [() (lib-read-syntax (object-name (current-input-port)) (current-input-port))]
+     [(src-v) (lib-read-syntax src-v (current-input-port))]
+     [(src-v input) (let ([r1 (r6rs:read-syntax src-v input)]
+			  [r2 (r6rs:read-syntax src-v input)])
+		      (let ([name-stx (and (syntax? r1)
+					   (eof-object? r2)
+					   (pair? (syntax-e r1))
+					   (eq? 'library (syntax-e (car (syntax-e r1))))
+					   (or (and
+						(pair? (cdr (syntax-e r1)))
+						(cadr (syntax-e r1)))
+					       (and
+						(syntax? (cdr (syntax-e r1)))
+						(pair? (syntax-e (cdr (syntax-e r1))))
+						(car (syntax-e (cdr (syntax-e r1)))))))])
+			(unless (and name-stx (string? (syntax-e name-stx)))
+			  (error 'r6rs-load-handler
+				 "expected a single `library' form with a string name, found something else"))
+			(datum->syntax-object
+			 #f
+			 `(module ,(string->symbol (syntax-e name-stx)) (lib "library-module.ss" "r6rs")
+			    (#%module-begin ,r1)))))])))
+
+			    
+			
+
diff --git a/collects/r6rs/private/helpers.ss b/collects/r6rs/private/helpers.ss
new file mode 100644
index 0000000000..f454b956ed
--- /dev/null
+++ b/collects/r6rs/private/helpers.ss
@@ -0,0 +1,344 @@
+
+(module helpers mzscheme
+  (require (lib "list.ss")
+	   "uri.ss")
+  (require-for-template mzscheme)
+
+  (provide translate-import
+	   translate-export
+	   uri?)
+
+  (define (uri? s)
+    ;; Need a proper test here!
+    #t)
+
+  (define ((check-identifier stx) id)
+    (unless (identifier? id)
+      (raise-syntax-error
+       #f
+       "expected an identifier"
+       stx
+       id)))
+
+  (define (check-present orig-i what nested !not exceptions names)
+    (for-each (lambda (en)
+		(unless (!not (ormap (lambda (i) (bound-identifier=? (car en) i))
+				    names))
+		  (raise-syntax-error
+		   #f
+		   (format "~a in nested ~a" what nested)
+		   orig-i
+		   (car en))))
+	      exceptions))
+
+  (define (add-prefix prefix id)
+    (if prefix
+	(datum->syntax-object id
+			      (string->symbol
+			       (format "~a~a" (syntax-e prefix) (syntax-e id)))
+			      id)
+	id))
+
+  (define (locate-rename id renames)
+    (cond
+     [(null? renames) #f]
+     [(bound-identifier=? id (caar renames)) (cdar renames)]
+     [else (locate-rename id (cdr renames))]))
+
+  (define (apply-rename new-names old-names name-pairs)
+    (map (lambda (i)
+	   (or (ormap (lambda (new old)
+			(and (bound-identifier=? (car i) new)
+			     (cons old (cdr i))))
+		      new-names old-names)
+	       i))
+	 name-pairs))
+
+  (define (remove-all-prefixes orig-i name-pairs form prefix)
+    (let ([s (symbol->string (syntax-e prefix))])
+      (map (lambda (i)
+	     (let ([old (symbol->string (syntax-e (car i)))])
+	       (unless (and ((string-length old) . >= . (string-length s))
+			    (string=? s (substring old 0 (string-length s))))
+		 (raise-syntax-error
+		  #f
+		  (format "~a does not have prefix ~s added by nested `prefix' form"
+			  form
+			  s)
+		  orig-i
+		  (car i)))
+	       (cons (datum->syntax-object (car i)
+					   (string->symbol (substring old (string-length s)))
+					   (car i))
+		     (cdr i))))
+	   name-pairs)))		  
+
+  (define (check-unique-names orig-i what names)
+    (let ([dup (check-duplicate-identifier names)])
+      (when dup
+	(raise-syntax-error
+	 #f
+	 (format "duplicate ~a identifier" what)
+	 orig-i
+	 dup))))
+
+  (define (localize i stx)
+    (datum->syntax-object i (syntax-e stx)))
+
+  (define (translate-import i)
+    (define orig-i #`(import #,i))
+    (syntax-case* i (for run expand) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
+      [(for sub run expand)
+       (finish-translate-import orig-i #'sub #t #t)]
+      [(for sub expand run)
+       (finish-translate-import orig-i #'sub #t #t)]
+      [(for sub run)
+       (finish-translate-import orig-i #'sub #t #f)]
+      [(for sub expand)
+       (finish-translate-import orig-i #'sub #f #t)]
+      [(for . _)
+       (raise-syntax-error
+	#f
+	"bad `for' form"
+	orig-i
+	i)]
+      [_else
+       (finish-translate-import orig-i i #t #f)]))
+
+  (define (finish-translate-import orig-i i run? expand?)
+    (define (mk-require l)
+      (cond
+       [(and run? expand?)
+	#`(begin (require #,@l) (require-for-syntax #,@l))]
+       [run?
+	#`(require #,@l)]
+       [expand?
+	#`(require-for-syntax #,@l)]))
+    (translate-impexp
+     i orig-i
+     (lambda (i exceptions onlys renames extra-prefix)
+       ;; Found a base URI?
+       (unless (and (string? (syntax-e i))
+		    (uri? (syntax-e i)))
+	 (raise-syntax-error
+	  #f
+	  "expected a URI string or an `only', `except', `add-prefix', or `rename' form"
+	  orig-i
+	  i))
+       (let ([name (datum->syntax-object i (uri->module-path (syntax-e i)) i)])
+	 (cond
+	  [onlys
+	   ;; Onlys are implemented with `rename':
+	   (mk-require (map (lambda (name-pair)
+			      #`(rename #,name #,(cdr name-pair) #,(car name-pair)))
+			    onlys))]
+	  [(or exceptions (pair? renames))
+	   ;; First import non-renamed, then renamed:
+	   (mk-require (cons
+			(localize i #`(#,(if extra-prefix #'prefix-all-except #'all-except)
+				       #,@(if extra-prefix (list extra-prefix) null)
+				       #,name
+				       #,@(append (map car (or exceptions null))
+						  (map car renames))))
+			(map (lambda (i)
+			       #`(rename #,name #,(cdr i) #,(car i)))
+			     renames)))]
+	  [extra-prefix
+	   (mk-require (list (localize i #`(prefix #,extra-prefix #,name))))]
+	  [else
+	   (mk-require (list name))])))))
+
+  (define (translate-export i)
+    (define orig-i #`(export #,i))
+    (translate-impexp 
+     i orig-i
+     (lambda (i exceptions onlys renames extra-prefix)
+       (syntax-case* i (all-defined) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
+	 [(all-defined)
+	  (cond
+	   [onlys
+	    #`(provide #,@(map (lambda (name-pair)
+				 #`(rename #,(car name-pair) #,(cdr name-pair)))
+			       onlys))]
+	   [(or exceptions (pair? renames))
+	    ;; First import non-renamed, then renamed:
+	    #`(provide (#,(if extra-prefix #'prefix-all-defined-except #'all-defined-except)
+			#,@(if extra-prefix (list extra-prefix) null)
+			#,@(append (map car (or exceptions null))
+				   (map car renames)))
+		       #,@(map (lambda (i)
+				 #`(rename #,(car i) #,(cdr i)))
+			       renames))]
+	   [extra-prefix
+	    #`(provide (prefix-all-defined #,extra-prefix))]
+	   [else
+	    #`(provide (all-defined))])]
+	 [(all-defined . _)
+	  (raise-syntax-error #f "bad syntax" i)]
+	 [_else
+	  (begin
+	    (unless (identifier? i)
+	      (raise-syntax-error
+	       #f
+	       "expected an identifier or an `all-defined', `only', `except', `add-prefix', or `rename' form"
+	       orig-i
+	       i))
+	    (when exceptions
+	      (check-present orig-i "except not" "identifier" values exceptions (list i)))
+	    (when onlys
+	      (check-present orig-i "only not" "identifier" values onlys (list i)))
+	    (when renames
+	      (check-present orig-i "rename not" "identifier" values renames (list i)))
+	    (cond
+	     [(pair? exceptions)
+	      ;; Must be the only exception, so nothing is exported
+	      #'(provide)]
+	     [(pair? renames)
+	      #`(provide (rename #,(caar renames) #,(cdar renames)))]
+	     [extra-prefix
+	      #`(provide (rename #,i #,(add-prefix extra-prefix i)))]
+	     [else #`(provide #,i)]))]))))
+
+  (define (translate-impexp i orig-i k)
+    (let loop ([i i]
+	       [exceptions #f]    ; #f if onlys
+	       [onlys #f]         ; #f if exceptions
+	       [renames null]     ; null if onlys
+	       [extra-prefix #f]) ; #f if onlys, already folded into exceptions & renames
+      (syntax-case* i (only except rename add-prefix) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
+	[(only sub name ...)
+	 (let ([names (syntax->list #'(name ...))])
+	   (for-each (check-identifier i) names)
+	   (check-unique-names orig-i "`only'" names)
+	   (check-present orig-i "rename not" "`only' list" values renames names)
+	   (cond
+	    [exceptions
+	     (check-present orig-i "except not" "`only' list" values exceptions names)
+	     (loop #'sub
+		   #f
+		   (remove* exceptions (map (lambda (i) 
+					      (cons i (or (locate-rename i renames)
+							  (add-prefix extra-prefix i))))
+					    names)
+			    (lambda (a b) (bound-identifier=? (car a) (car b))))
+		   null
+		   #f)]
+	    [onlys
+	     (check-present orig-i "only not" "`only' list" values onlys names)
+	     (loop #'sub #f onlys null #f)]
+	    [else
+	     (loop #'sub
+		   #f
+		   (map (lambda (i)
+			  (cons i (or (locate-rename i renames)
+				      (add-prefix extra-prefix i))))
+			names)
+		   null
+		   #f)]))]
+	[(only . _)
+	 (raise-syntax-error
+	  #f
+	  "bad syntax"
+	  i)]
+	[(except sub name ...)
+	 (let ([names (syntax->list #'(name ...))])
+	   (for-each (check-identifier i) names)
+	   (check-unique-names orig-i "`except'" names)
+	   (check-present orig-i "rename" "`except' list" not renames names)
+	   (let ([remove-exceptions
+		  (lambda ()
+		    (remove* exceptions renames (lambda (a b) (bound-identifier=? (car a) (car b)))))])
+	     (cond
+	      [(pair? exceptions)
+	       (check-present orig-i "except" "`except' list" not exceptions names)
+	       ;; union the exceptions
+	       (loop #'sub
+		     (append
+		      (remove* exceptions (map (lambda (i) 
+						 (cons i (or (locate-rename i renames)
+							     (add-prefix extra-prefix i))))
+					       names)
+			       (lambda (a b) (bound-identifier=? (car a) (car b))))
+		      exceptions)
+		     #f
+		     (remove-exceptions)
+		     extra-prefix)]
+	      [(pair? onlys)
+	       (check-present orig-i "only" "`except' list" not onlys names)
+	       (loop #'sub #f onlys null #f)]
+	      [else
+	       (loop #'sub
+		     (map (lambda (i)
+			    (cons i (add-prefix extra-prefix i)))
+			  names) 
+		     #f
+		     (remove-exceptions)
+		     extra-prefix)])))]
+	[(except . _)
+	 (raise-syntax-error
+	  #f
+	  "bad syntax"
+	  i)]
+	[(rename sub (new old) ...)
+	 (let* ([new-names (syntax->list #'(new ...))]
+		[old-names (syntax->list #'(old ...))]
+		[name-pairs (map (lambda (old new)
+				   (cons old (add-prefix extra-prefix new)))
+				 old-names new-names)])
+	   (for-each (check-identifier i) (apply append (map list new-names old-names)))
+	   (check-unique-names orig-i "`rename' target" new-names)
+	   (check-unique-names orig-i "`rename' source" old-names)
+	   (let ([combine-renames
+		  (lambda ()
+		    (let ([renames (apply-rename new-names old-names renames)])
+		      (append
+		       renames
+		       (remove* renames name-pairs 
+				(lambda (a b)
+				  (bound-identifier=? (car a) (car b)))))))])
+	     (cond
+	      [exceptions
+	       (loop #'sub
+		     (apply-rename new-names old-names exceptions)
+		     #f
+		     (combine-renames)
+		     extra-prefix)]
+	      [onlys
+	       (loop #'sub
+		     #f
+		     (apply-rename new-names old-names onlys)
+		     null
+		     #f)]
+	      [else
+	       (loop #'sub
+		     #f
+		     #f
+		     (combine-renames)
+		     extra-prefix)])))]
+	[(rename . _)
+	 (raise-syntax-error
+	  #f
+	  "bad syntax"
+	  i)]
+	[(add-prefix sub prefix)
+	 (cond
+	  [onlys
+	   (loop #'sub
+		 #f
+		 (remove-all-prefixes orig-i onlys "only" #'prefix)
+		 null
+		 #f)]
+	  [else
+	   (loop #'sub
+		 (and exceptions
+		      (remove-all-prefixes orig-i exceptions "except" #'prefix))
+		 #f
+		 (remove-all-prefixes orig-i renames "rename" #'prefix)
+		 (add-prefix extra-prefix #'prefix))])]
+	[(add-prefix . _)
+	 (raise-syntax-error
+	  #f
+	  "bad syntax"
+	  i)]
+	[_else
+	 (k i exceptions onlys renames extra-prefix)]))))
diff --git a/collects/r6rs/private/uri.ss b/collects/r6rs/private/uri.ss
new file mode 100644
index 0000000000..b3b589694a
--- /dev/null
+++ b/collects/r6rs/private/uri.ss
@@ -0,0 +1,57 @@
+
+(module uri mzscheme
+  (require (lib "string.ss")
+	   (lib "list.ss"))
+  (provide uri->symbol
+	   uri->module-path)
+
+  (define rx:scheme-uri #rx"^[sS][cC][hH][eE][mM][eE]://([^/]+/+[^/]+.*)$")
+
+  (define (uri->scheme-path s)
+    (let ([m (regexp-match rx:scheme-uri s)])
+      (and m
+	   (let ([l (filter (lambda (s)
+			      (not (string=? s "")))
+			    (regexp-split #rx"/" (cadr m)))])
+	     (let loop ([l l][accum null])
+	       (cond
+		[(null? (cdr l))
+		 (let ([s (car l)])
+		   (cons (if (regexp-match #rx"[.]" s)
+			     s
+			     (string-append s ".scm"))
+			 (reverse accum)))]
+		[else (loop (cdr l) (cons (car l) accum))]))))))
+	   
+
+  (define (uri->symbol s)
+    (let ([p (uri->scheme-path s)])
+      (cond
+       [p (string->symbol
+	   (string-append
+	    ","
+	    (let ([collpath
+		   ;; Try to get real collection; if it doesn't exist,
+		   ;;  make one up relative to mzlib.
+		   (with-handlers ([exn:fail:filesystem?
+				    (lambda (exn)
+				      (simplify-path
+				       (apply build-path (collection-path "mzlib")
+					      'up
+					      (cdr p))))])
+		     (apply collection-path (cdr p)))])
+	      (path->string (build-path collpath
+					(path-replace-suffix (car p) #""))))))]
+       [else (string->symbol s)])))
+
+  (define (uri->module-path s)
+    (let ([p (uri->scheme-path s)])
+      (cond
+       [p 
+	;; If the collection exists, build a `lib' path. Otherwise, assume
+	;;  that we're in REPL mode, and make up a symbol using uri->symbol
+	(if (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
+	      (apply collection-path (cdr p)))
+	    `(lib ,@p)
+	    (uri->symbol s))]
+       [else (string->symbol s)]))))
diff --git a/collects/r6rs/r6rs.ss b/collects/r6rs/r6rs.ss
new file mode 100644
index 0000000000..ebf602afd8
--- /dev/null
+++ b/collects/r6rs/r6rs.ss
@@ -0,0 +1,73 @@
+
+(module r6rs mzscheme
+  (require (prefix r5rs: (lib "r5rs.ss" "lang")))
+
+  ;; R5RS values
+  (provide car cdr caar cadr cdar cddr
+	   caaar caadr cadar caddr cdaar cdadr cddar cdddr
+	   caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+	   cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+	   map = < > <= >= max min + - * / 
+	   abs gcd lcm exp log sin cos tan not eq?
+	   call-with-current-continuation make-string
+	   symbol->string string->symbol make-rectangular 
+	   exact->inexact inexact->exact number->string string->number 
+	   rationalize output-port? current-input-port current-output-port current-error-port 
+	   open-input-file open-output-file close-input-port close-output-port
+	   with-output-to-file transcript-on transcript-off flush-output
+	   string-length string-ci<=? string-ci>=? string-append 
+	   string->list list->string string-fill! 
+	   vector-length vector->list list->vector vector-fill!
+	   char-alphabetic? char-numeric? char-whitespace? 
+	   char-upper-case? char-lower-case? char->integer integer->char char-downcase
+	   call-with-output-file call-with-input-file with-input-from-file
+	   apply for-each symbol? pair? cons set-car! set-cdr! null? list? list length append reverse
+	   list-tail list-ref memq memv member assq assv assoc procedure?
+	   number? complex? real? rational? integer? exact? inexact? zero?
+	   positive?  negative? odd? even? 
+	   quotient remainder modulo floor ceiling truncate round 
+	   numerator denominator asin acos atan sqrt
+	   expt make-polar real-part imag-part angle magnitude input-port?
+	   read read-char peek-char eof-object?
+	   char-ready? write display newline write-char load 
+	   string? string string-ref string-set! string=? substring string-copy
+	   string-ci=? string<? string>? string<=? string>=? string-ci<? string-ci>?
+	   vector? make-vector vector vector-ref vector-set! 
+	   char? char=? char<? char>? char<=? char>=? 
+	   char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=? 
+	   char-upcase boolean? eqv? equal? force
+	   call-with-values values eval port? scheme-report-environment null-environment 
+	   interaction-environment dynamic-wind)
+
+  ;; Extra values for R6RS:
+  (provide bound-identifier=?
+	   (rename syntax->list syntax-object->list))
+
+  ;; R5RS syntax (plus revised #%module-begin)
+  (provide quasiquote unquote unquote-splicing 
+	   if let and or cond case define delay do
+	   (rename r5rs:letrec letrec)
+	   let* begin lambda quote set!
+	   define-syntax let-syntax letrec-syntax
+
+	   ;; We have to include the following MzScheme-isms to do anything,
+	   ;; but they're not legal R5RS names, anyway.
+	   #%app #%datum #%top 
+	   (rename r6rs-module-begin #%module-begin)
+	   (rename require #%require)
+	   (rename provide #%provide))
+
+  ;; Extra syntax for R6RS:
+  (provide syntax-rules syntax-case syntax)
+
+  (define-syntax r6rs-module-begin
+    (lambda (stx)
+      (datum->syntax-object
+       (quote-syntax here)
+       (list* (quote-syntax #%plain-module-begin)
+	      (list 'require-for-syntax 
+		    (datum->syntax-object
+		     stx
+		     '(lib "r6rs.ss" "r6rs")))
+	      (cdr (syntax-e stx)))
+       stx))))
diff --git a/collects/r6rs/reader.ss b/collects/r6rs/reader.ss
new file mode 100644
index 0000000000..2aec7ec92c
--- /dev/null
+++ b/collects/r6rs/reader.ss
@@ -0,0 +1,281 @@
+
+(module reader mzscheme
+  (provide r6rs-readtable
+	   (rename r6rs-read read)
+	   (rename r6rs-read-syntax read-syntax))
+
+  ;; for raise-read-[eof-]error:
+  (require (lib "readerr.ss" "syntax"))
+
+  (define hex-digits (string->list "0123456789abcdefABCDEF"))
+  (define standard-delimiters (string->list ";',`()[]{}"))
+
+  ;; hex-value : char -> int
+  (define (hex-value ch)
+    (cond
+     [(char-numeric? ch)
+      (- (char->integer ch) 48)]
+     [(memv ch '(#\a #\b #\c #\d #\e #\f))
+      (- (char->integer ch) 87)]
+     [else
+      (- (char->integer ch) 55)]))
+
+  ;; read-delimited-string : char input-port .... -> string
+  ;;  Reads a string or symbol, given the closing character
+  (define (read-delimited-string closer-ch port
+				 what src line col pos)
+    ;; raise-bad-eof
+    ;;  Reports an unexpected EOF in a string/symbol
+    (define (raise-bad-eof len)
+      (raise-read-eof-error 
+       (format "unexpected end-of-file in ~a" what) 
+       src line col pos len))
+
+    ;; to-hex : char int -> int
+    ;;  Checks input and gets it's value as a hex digit
+    (define (to-hex ch len)
+      (unless (memv ch hex-digits)
+	(if (eof-object? ch)
+	    (raise-bad-eof len)
+	    (raise-read-error 
+	     (format "expected a hex digit for ~a, found: ~e" what ch)
+	     src line col pos len)))
+      (hex-value ch))
+
+    ;; loop to read string/symbol characters; track the length for error reporting
+    (let loop ([chars null][len 1])
+      (let ([ch (read-char port)])
+	(cond
+	 ;; eof
+	 [(eof-object? ch) (raise-bad-eof len)]
+	 ;; closing quote or bar
+	 [(char=? ch closer-ch) (list->string (reverse chars))]
+	 ;; escape
+	 [(char=? ch #\\)
+	  (let ([ch (read-char port)])
+	    (cond
+	     ;; eof after escape
+	     [(eof-object? ch) (raise-bad-eof (add1 len))]
+	     ;; newline escape
+	     [(char=? #\newline ch)
+	      ;; Eat whitespace until we find a newline...
+	      (let w-loop ([len (+ len 1)])
+		(let ([ch (peek-char port)])
+		  (cond
+		   [(eof-object? ch) (raise-bad-eof len)]
+		   [(and (char-whitespace? ch)
+			 (not (char=? #\newline ch))) 
+		    (read-char port)
+		    (w-loop (+ len 1))]
+		   [else
+		    (loop chars len)])))]
+	     ;; space escape
+	     [(char=? #\space ch)
+	      (loop (cons #\space chars) (+ len 2))]
+	     ;; 2-digit hex escape
+	     [(char=? #\x ch)
+	      (let* ([ch1 (to-hex (read-char port) (+ len 2))]
+		     [ch2 (to-hex (read-char port) (+ len 3))])
+		(loop (cons (integer->char (+ (* ch1 16) ch2)) 
+			    chars)
+		      (+ len 3)))]
+	     ;; 4-digit hex escape
+	     [(char=? #\u ch)
+	      (let* ([ch1 (to-hex (read-char port) (+ len 2))]
+		     [ch2 (to-hex (read-char port) (+ len 3))]
+		     [ch3 (to-hex (read-char port) (+ len 4))]
+		     [ch4 (to-hex (read-char port) (+ len 5))])
+		(let ([v (+ (* ch1 4096) (* ch2 256) (* ch3 16) ch4)])
+		  (when (<= #xD8FF v #xDFFF)
+		    (raise-read-error 
+		     (format "out-of-range character for ~a: \\u~a~a~a~a" 
+			     what ch1 ch2 ch3 ch4)
+		     src line col pos (+ len 5)))
+		  (loop (cons (integer->char v) chars) 
+			(+ len 5))))]
+	     ;; 8-digit hex escape
+	     [(char=? #\U ch)
+	      (let* ([ch1 (to-hex (read-char port) (+ len 2))]
+		     [ch2 (to-hex (read-char port) (+ len 3))]
+		     [ch3 (to-hex (read-char port) (+ len 4))]
+		     [ch4 (to-hex (read-char port) (+ len 5))]
+		     [ch5 (to-hex (read-char port) (+ len 6))]
+		     [ch6 (to-hex (read-char port) (+ len 7))]
+		     [ch7 (to-hex (read-char port) (+ len 8))]
+		     [ch8 (to-hex (read-char port) (+ len 9))])
+		(let ([v (+ (* ch1 268435456) (* ch2 16777216) (* ch3 1048576) (* ch4 65536)
+			    (* ch5 4096) (* ch6 256) (* ch7 16) ch8)])
+		  (when (or (> v #x10FFFF)
+			    (<= #xD8FF v #xDFFF))
+		    (raise-read-error 
+		     (format "out-of-range character for ~a: \\U~a~a~a~a~a~a~a~a" 
+			     what ch1 ch2 ch3 ch4 ch5 ch6 ch7 ch8)
+		     src line col pos (+ len 9)))
+		  (loop (cons (integer->char v) chars)
+			(+ len 9))))]
+	     ;; other escapes
+	     [else (let ([v (case ch
+			      [(#\a) 7]
+			      [(#\b) 8]
+			      [(#\t) 9]
+			      [(#\n) 10]
+			      [(#\v) 11]
+			      [(#\f) 12]
+			      [(#\r) 13]
+			      [(#\") 34]
+			      [(#\\) 92]
+			      [(#\|) 124]
+			      ;; not a valid escape!
+			      [else
+			       (raise-read-error 
+				(format "illegal escape for ~a: \\~a" what ch)
+				src line col pos (+ len 2))])])
+		     (loop (cons (integer->char v) chars) (+ len 2)))]))]
+	 ;; other character
+	 [else (loop (cons ch chars) (+ len 1))]))))
+
+  ;; read-quoted-symbol
+  ;;  Reader macro for |
+  (define (read-quoted-symbol ch port src line col pos)
+    (string->symbol (read-delimited-string #\| port
+					    "symbol" src line col pos)))
+  
+  ;; read-quoted-string
+  ;;  Reader macro for "
+  (define (read-quoted-string ch port src line col pos)
+    (read-delimited-string #\" port 
+			    "string" src line col pos))
+
+  ;; read-character
+  ;;  Reader macro for characters
+  (define (read-character ch port src line col pos)
+
+    ;; make-char-const : list-of-char len -> char
+    ;;  Checks whether the character sequence names a char,
+    ;;  and either reports and error or returns the character
+    (define (make-char-const chars len)
+      (let ([chars (reverse chars)])
+	(if (null? (cdr chars))
+	    ;; simple case: single character
+	    (car chars)
+	    ;; multi-character name:
+	    (let ([name (list->string chars)])
+	      ;; raise-bad-char
+	      ;;  When it's not a valid character
+	      (define (raise-bad-char detail)
+		(raise-read-error 
+		 (format "bad character constant~a: #\\~a" detail name)
+		 src line col pos len))
+
+	      ;; hex-char : int -> char
+	      ;;  Checks whether chars has n hex digits, and
+	      ;;  produces the character if so
+	      (define (hex-char n)
+		(unless (= (+ n 1) (length chars))
+		  (raise-bad-char (format " (expected ~a hex digits after #\\~a) "
+					  n
+					  (car chars))))
+		(for-each (lambda (c) 
+			    (unless (memv c hex-digits)
+			      (raise-bad-char (format " (expected hex digit, found ~a) " c))))
+			  (cdr chars))
+		(let loop ([n 0][chars (cdr chars)])
+		  (if (null? chars)
+		      (begin
+			(when (or (> n #x10FFFF)
+				  (<= #xD8FF n #xDFFF))
+			  (raise-read-error 
+			   (format "out-of-range character: #\\~a" name)
+			   src line col pos (+ len 9)))
+			(integer->char n))
+		      (loop (+ (* n 16) (hex-value (car chars)))
+			    (cdr chars)))))
+
+	      ;; Check for standard names or hex, and report an error if not
+	      (case (string->symbol name)
+		[(nul) (integer->char 0)]
+		[(alarm) (integer->char 7)]
+		[(backspace) (integer->char 8)]
+		[(tab) (integer->char 9)]
+		[(newline linefeed) (integer->char 10)]
+		[(vtab) (integer->char 11)]
+		[(page) (integer->char 12)]
+		[(return) (integer->char 13)]
+		[(esc) (integer->char 27)]
+		[(space) (integer->char 32)]
+		[(delete) (integer->char 127)]
+		[else
+		 ;; Hex?
+		 (case (car chars)
+		   [(#\x)
+		    (hex-char 2)]
+		   [(#\u)
+		    (hex-char 4)]
+		   [(#\U)
+		    (hex-char 8)]
+		   [else
+		    (raise-bad-char "")])])))))
+    
+    ;; read the leading character:
+    (let ([ch (read-char port)])
+      (when (eof-object? ch)
+	(raise-read-eof-error "unexpected end-of-file after #\\"
+			      src line col pos 2))
+      ;; loop until delimiter:
+      (let loop ([len 3][chars (list ch)])
+	(let ([ch (peek-char port)])
+	  (if (eof-object? ch)
+	      ;; eof is a delimiter
+	      (make-char-const chars len)
+	      ;; otherwise, consult the current readtable to find delimiters
+	      ;; in case someone extends r6rs-readtable:
+	      (let-values ([(kind proc dispatch-proc) 
+			    (readtable-mapping (current-readtable) ch)])
+		(cond
+		 [(eq? kind 'terminating-macro) 
+		  ;; a terminating macro is a delimiter by definition
+		  (make-char-const chars len)]
+		 [(or (char-whitespace? ch)
+		      (member ch standard-delimiters))
+		  ;; something mapped to one of the standard delimiters is
+		  ;; a delimiter
+		  (make-char-const chars len)]
+		 [else 
+		  ;; otherwise, it's not a delimiter
+		  (read-char port)
+		  (loop (add1 len) (cons ch chars))])))))))
+
+  (define (reject-backslash ch port src line col pos)
+    (raise-read-error 
+     "illegal character in input: \\"
+     src line col pos 1))
+
+  ;; r6rs-readtable
+  ;;  Extends MzScheme's default reader to handle quoted symbols,
+  ;;   strings, and characters:
+  (define r6rs-readtable
+    (make-readtable #f
+		    ;; New syntax:
+		    #\| 'terminating-macro read-quoted-symbol
+		    #\" 'terminating-macro read-quoted-string
+		    #\\ 'dispatch-macro read-character
+		    ;; Disable \ symbol escape:
+		    #\\ 'terminating-macro reject-backslash))
+		    
+
+  ;; r6rs-read
+  ;;  Like the normal read, but uses r6rs-readtable
+  (define r6rs-read
+    (case-lambda
+     [() (r6rs-read (current-input-port))]
+     [(input) (parameterize ([current-readtable r6rs-readtable])
+		(read input))]))
+
+  ;; r6rs-read-syntax
+  ;;  Like the normal read-syntax, but uses r6rs-readtable
+  (define r6rs-read-syntax
+    (case-lambda
+     [() (r6rs-read-syntax (object-name (current-input-port)) (current-input-port))]
+     [(src-v) (r6rs-read-syntax src-v (current-input-port))]
+     [(src-v input) (parameterize ([current-readtable r6rs-readtable])
+		      (read-syntax src-v input))])))