From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 20 Sep 2009 06:54:13 +0000 (-0700)
Subject: Refactor syntax to break it into smaller, more coherent pieces.
X-Git-Tag: 20100708-Gtk~328
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d846a9b166f5dd72a83e9a11b1be5590d60ced3e;p=mit-scheme.git

Refactor syntax to break it into smaller, more coherent pieces.
Simplify where easy to do so.
---

diff --git a/src/compiler/machines/C/compiler.pkg b/src/compiler/machines/C/compiler.pkg
index 839dc510b..17272cda4 100644
--- a/src/compiler/machines/C/compiler.pkg
+++ b/src/compiler/machines/C/compiler.pkg
@@ -213,9 +213,7 @@ USA.
 	  make-rvalue
 	  make-snode
 	  package
-	  rule-matcher)
-  (import (runtime syntactic-closures)
-	  syntax-match?))
+	  rule-matcher))
 
 (define-package (compiler declarations)
   (files "machines/C/decls")
diff --git a/src/compiler/machines/i386/compiler.pkg b/src/compiler/machines/i386/compiler.pkg
index 34314bdb9..572de333f 100644
--- a/src/compiler/machines/i386/compiler.pkg
+++ b/src/compiler/machines/i386/compiler.pkg
@@ -214,9 +214,7 @@ USA.
 	  make-rvalue
 	  make-snode
 	  package
-	  rule-matcher)
-  (import (runtime syntactic-closures)
-	  syntax-match?))
+	  rule-matcher))
 
 (define-package (compiler declarations)
   (files "machines/i386/decls")
diff --git a/src/edwin/clsmac.scm b/src/edwin/clsmac.scm
index af5d48ed0..24dae1590 100644
--- a/src/edwin/clsmac.scm
+++ b/src/edwin/clsmac.scm
@@ -86,24 +86,21 @@ USA.
 (define with-instance-variables
   (make-unmapped-macro-reference-trap
    (make-compiler-item
-    (lambda (form environment history)
-      (if (syntax-match? '(IDENTIFIER EXPRESSION (* IDENTIFIER) + EXPRESSION)
-			 (cdr form))
-	  (let ((class-name (cadr form))
-		(self (caddr form))
-		(free-names (cadddr form))
-		(body (cddddr form)))
-	    (transform-instance-variables
-	     (class-instance-transforms
-	      (name->class (identifier->symbol class-name)))
-	     (compile/subexpression self environment history select-caddr)
-	     free-names
-	     (compile/subexpression
-	      `(,(close-syntax 'BEGIN system-global-environment) ,@body)
-	      environment
-	      history
-	      select-cddddr)))
-	  (ill-formed-syntax form))))))
+    (lambda (form environment)
+      (syntax-check '(KEYWORD IDENTIFIER EXPRESSION (* IDENTIFIER) + EXPRESSION)
+		    form)
+      (let ((class-name (cadr form))
+	    (self (caddr form))
+	    (free-names (cadddr form))
+	    (body (cddddr form)))
+	(transform-instance-variables
+	 (class-instance-transforms
+	  (name->class (identifier->symbol class-name)))
+	 (compile/expression self environment)
+	 free-names
+	 (compile/expression
+	  `(,(close-syntax 'BEGIN system-global-environment) ,@body)
+	  environment)))))))
 
 (define-syntax ==>
   (syntax-rules ()
diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg
index cba2d0e8f..05499b982 100644
--- a/src/edwin/edwin.pkg
+++ b/src/edwin/edwin.pkg
@@ -135,11 +135,9 @@ USA.
 	  define-method
 	  usual==>
 	  with-instance-variables)
-  (import (runtime syntactic-closures)
-	  compile/subexpression
-	  make-compiler-item
-	  select-caddr
-	  select-cddddr))
+  (import (runtime syntax)
+	  compile/expression
+	  make-compiler-item))
 
 (define-package (edwin class-macros transform-instance-variables)
   (files "xform")
diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm
index 7b8e5575a..21362245a 100644
--- a/src/runtime/defstr.scm
+++ b/src/runtime/defstr.scm
@@ -73,37 +73,35 @@ differences:
 
 |#
 
-(define-expander 'DEFINE-STRUCTURE system-global-environment
-  (lambda (form environment closing-environment)
-    (if (not (and (pair? (cdr form)) (list? (cddr form))))
-	(error "Ill-formed special form:" form))
-    (make-syntactic-closure closing-environment '()
-      (let ((name-and-options (cadr form))
-	    (slot-descriptions (cddr form)))
+(define-syntax define-structure
+  (sc-macro-transformer
+   (lambda (form use-environment)
+     (syntax-check '(KEYWORD + DATUM) form)
+     (capture-syntactic-environment
+      (lambda (closing-environment)
 	(let ((structure
-	       (call-with-values
-		   (lambda ()
+	       (receive (name options)
+		   (let ((name-and-options (cadr form)))
 		     (if (pair? name-and-options)
 			 (values (car name-and-options) (cdr name-and-options))
 			 (values name-and-options '())))
-		 (lambda (name options)
-		   (if (not (symbol? name))
-		       (error "Structure name must be a symbol:" name))
-		   (if (not (list? options))
-		       (error "Structure options must be a list:" options))
-		   (let ((context
-			  (make-parser-context name
-					       environment
-					       closing-environment)))
-		     (parse/options options
-				    (parse/slot-descriptions slot-descriptions)
-				    context))))))
+		 (if (not (symbol? name))
+		     (error "Structure name must be a symbol:" name))
+		 (if (not (list? options))
+		     (error "Structure options must be a list:" options))
+		 (let ((context
+			(make-parser-context name
+					     use-environment
+					     closing-environment)))
+		   (parse/options options
+				  (parse/slot-descriptions (cddr form))
+				  context)))))
 	  `(BEGIN ,@(type-definitions structure)
 		  ,@(constructor-definitions structure)
 		  ,@(accessor-definitions structure)
 		  ,@(modifier-definitions structure)
 		  ,@(predicate-definitions structure)
-		  ,@(copier-definitions structure)))))))
+		  ,@(copier-definitions structure))))))))
 
 ;;;; Parse options
 
@@ -255,7 +253,7 @@ differences:
       (and (identifier? object)
 	   (there-exists? false-expression-names
 	     (lambda (name)
-	       (identifier=? (parser-context/environment context)
+	       (identifier=? (parser-context/use-environment context)
 			     object
 			     (parser-context/closing-environment context)
 			     name))))))
@@ -563,10 +561,10 @@ differences:
   (eq? (structure/physical-type structure) 'RECORD))
 
 (define-record-type <parser-context>
-    (make-parser-context name environment closing-environment)
+    (make-parser-context name use-environment closing-environment)
     parser-context?
   (name parser-context/name)
-  (environment parser-context/environment)
+  (use-environment parser-context/use-environment)
   (closing-environment parser-context/closing-environment))
 
 (define-record-type <option>
@@ -595,7 +593,7 @@ differences:
 		(parser-context/closing-environment context)))
 
 (define (close name context)
-  (close-syntax name (parser-context/environment context)))
+  (close-syntax name (parser-context/use-environment context)))
 
 (define (accessor-definitions structure)
   (let ((context (structure/context structure)))
diff --git a/src/runtime/ed-ffi.scm b/src/runtime/ed-ffi.scm
index 93028823b..4f45c3cd5 100644
--- a/src/runtime/ed-ffi.scm
+++ b/src/runtime/ed-ffi.scm
@@ -49,7 +49,7 @@ USA.
     ("dbgcmd"	(runtime debugger-command-loop))
     ("dbgutl"	(runtime debugger-utilities))
     ("debug"	(runtime debugger))
-    ("defstr"	(runtime defstruct))
+    ("defstr"	(runtime syntax defstruct))
     ("dospth"	(runtime pathname dos))
     ("dragon4"	(runtime number))
     ("emacs"	(runtime emacs-interface))
@@ -92,11 +92,13 @@ USA.
     ("krypt"	(runtime krypt))
     ("kryptdum"	(runtime krypt))
     ("lambda"	(runtime lambda-abstraction))
+    ("lambda-list" (runtime lambda-list))
     ("lambdx"	(runtime alternative-lambda))
     ("list"	(runtime list))
     ("load"	(runtime load))
     ("mime-codec" (runtime mime-codec))
-    ("mit-syntax" (runtime syntactic-closures))
+    ("mit-macros" (runtime mit-macros))
+    ("mit-syntax" (runtime syntax mit))
     ("msort"	(runtime merge-sort))
     ("ntdir"	(runtime directory))
     ("ntprm"	(runtime os-primitives))
@@ -149,11 +151,17 @@ USA.
     ("structure-parser" (runtime structure-parser))
     ("symbol"	(runtime symbol))
     ("syncproc"	(runtime synchronous-subprocess))
-    ("syntactic-closures" (runtime syntactic-closures))
-    ("syntax-check" (runtime syntactic-closures))
-    ("syntax-output" (runtime syntactic-closures))
-    ("syntax-rules" (runtime syntactic-closures))
-    ("syntax-transforms" (runtime syntactic-closures))
+    ("syntax"	(runtime syntax top-level))
+    ("syntax-check" (runtime syntax check))
+    ("syntax-classify" (runtime syntax classify))
+    ("syntax-declaration" (runtime syntax declaration))
+    ("syntax-definitions" (runtime syntax definitions))
+    ("syntax-compile" (runtime syntax compile))
+    ("syntax-environment" (runtime syntax environment))
+    ("syntax-items" (runtime syntax items))
+    ("syntax-output" (runtime syntax output))
+    ("syntax-rules" (runtime syntax syntax-rules))
+    ("syntax-transforms" (runtime syntax transforms))
     ("sysclk"	(runtime system-clock))
     ("sysmac"	(runtime system-macros))
     ("system"	(runtime system))
diff --git a/src/runtime/lambda-list.scm b/src/runtime/lambda-list.scm
new file mode 100644
index 000000000..e0a7b0099
--- /dev/null
+++ b/src/runtime/lambda-list.scm
@@ -0,0 +1,184 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Lambda lists
+
+(declare (usual-integrations))
+
+(define (r4rs-lambda-list? object)
+  (let loop ((object object) (seen '()))
+    (or (null? object)
+	(if (identifier? object)
+	    (not (memq object seen))
+	    (and (pair? object)
+		 (identifier? (car object))
+		 (not (memq (car object) seen))
+		 (loop (cdr object) (cons (car object) seen)))))))
+
+(define-guarantee r4rs-lambda-list "R4RS lambda list")
+
+(define (parse-r4rs-lambda-list bvl)
+  (let loop ((bvl* bvl) (required '()))
+    (cond ((and (pair? bvl*)
+		(identifier? (car bvl*)))
+	   (loop (cdr bvl*)
+		 (cons (car bvl*) required)))
+	  ((null? bvl*)
+	   (values (reverse! required) #f))
+	  ((identifier? bvl*)
+	   (values (reverse! required) bvl*))
+	  (else
+	   (error:not-r4rs-lambda-list bvl)))))
+
+(define (map-r4rs-lambda-list procedure bvl)
+  (let loop ((bvl* bvl))
+    (cond ((and (pair? bvl*)
+		(identifier? (car bvl*)))
+	   (cons (procedure (car bvl*))
+		 (loop (cdr bvl*))))
+	  ((null? bvl*)
+	   '())
+	  ((identifier? bvl*)
+	   (procedure bvl*))
+	  (else
+	   (error:not-r4rs-lambda-list bvl)))))
+
+(define (mit-lambda-list? object)
+  (letrec
+      ((parse-required
+	(lambda (object seen)
+	  (or (null? object)
+	      (if (identifier? object)
+		  (not (memq object seen))
+		  (and (pair? object)
+		       (cond ((eq? (car object) lambda-tag:optional)
+			      (and (pair? (cdr object))
+				   (parse-parameter (cadr object) seen
+				     (lambda (seen)
+				       (parse-optional (cddr object) seen)))))
+			     ((eq? (car object) lambda-tag:rest)
+			      (parse-rest (cdr object) seen))
+			     (else
+			      (parse-parameter (car object) seen
+				(lambda (seen)
+				  (parse-required (cdr object) seen))))))))))
+       (parse-optional
+	(lambda (object seen)
+	  (or (null? object)
+	      (if (identifier? object)
+		  (not (memq object seen))
+		  (and (pair? object)
+		       (cond ((eq? (car object) lambda-tag:optional)
+			      #f)
+			     ((eq? (car object) lambda-tag:rest)
+			      (parse-rest (cdr object) seen))
+			     (else
+			      (parse-parameter (car object) seen
+				(lambda (seen)
+				  (parse-optional (cdr object) seen))))))))))
+       (parse-rest
+	(lambda (object seen)
+	  (and (pair? object)
+	       (parse-parameter (car object) seen
+		 (lambda (seen)
+		   seen
+		   (null? (cdr object)))))))
+       (parse-parameter
+	(lambda (object seen k)
+	  (if (identifier? object)
+	      (and (not (memq object seen))
+		   (k (cons object seen)))
+	      (and (pair? object)
+		   (identifier? (car object))
+		   (list? (cdr object))
+		   (not (memq (car object) seen))
+		   (k (cons (car object) seen)))))))
+    (parse-required object '())))
+
+(define-guarantee mit-lambda-list "MIT/GNU Scheme lambda list")
+
+(define lambda-tag:optional (object-new-type (ucode-type constant) 3))
+(define lambda-tag:rest (object-new-type (ucode-type constant) 4))
+(define lambda-tag:key (object-new-type (ucode-type constant) 5))
+(define lambda-tag:aux (object-new-type (ucode-type constant) 8))
+
+(define (parse-mit-lambda-list lambda-list)
+  (let ((required (list '()))
+	(optional (list '())))
+    (define (parse-parameters cell pattern)
+      (let loop ((pattern pattern))
+	(cond ((null? pattern) (finish #f))
+	      ((identifier? pattern) (finish pattern))
+	      ((not (pair? pattern)) (bad-lambda-list pattern))
+	      ((eq? (car pattern) lambda-tag:rest)
+	       (if (and (pair? (cdr pattern)) (null? (cddr pattern)))
+		   (cond ((identifier? (cadr pattern)) (finish (cadr pattern)))
+			 ((and (pair? (cadr pattern))
+			       (identifier? (caadr pattern)))
+			  (finish (caadr pattern)))
+			 (else (bad-lambda-list (cdr pattern))))
+		   (bad-lambda-list (cdr pattern))))
+	      ((eq? (car pattern) lambda-tag:optional)
+	       (if (eq? cell required)
+		   (parse-parameters optional (cdr pattern))
+		   (bad-lambda-list pattern)))
+	      ((identifier? (car pattern))
+	       (set-car! cell (cons (car pattern) (car cell)))
+	       (loop (cdr pattern)))
+	      ((and (pair? (car pattern)) (identifier? (caar pattern)))
+	       (set-car! cell (cons (caar pattern) (car cell)))
+	       (loop (cdr pattern)))
+	      (else (bad-lambda-list pattern)))))
+
+    (define (finish rest)
+      (let ((required (reverse! (car required)))
+	    (optional (reverse! (car optional))))
+	(do ((parameters
+	      (append required optional (if rest (list rest) '()))
+	      (cdr parameters)))
+	    ((null? parameters))
+	  (if (memq (car parameters) (cdr parameters))
+	      (error "lambda list has duplicate parameter:"
+		     (car parameters)
+		     (error-irritant/noise " in")
+		     lambda-list)))
+	(values required optional rest)))
+
+    (define (bad-lambda-list pattern)
+      (error:not-mit-lambda-list pattern 'PARSE-MIT-LAMBDA-LIST))
+
+    (parse-parameters required lambda-list)))
+
+(define (map-mit-lambda-list procedure bvl)
+  (let loop ((bvl bvl))
+    (if (pair? bvl)
+	(cons (if (or (eq? (car bvl) lambda-tag:optional)
+		      (eq? (car bvl) lambda-tag:rest))
+		  (car bvl)
+		  (procedure (car bvl)))
+	      (loop (cdr bvl)))
+	(if (identifier? bvl)
+	    (procedure bvl)
+	    '()))))
\ No newline at end of file
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index ed27dbb24..f2f773d33 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -359,10 +359,11 @@ USA.
 	 ("random" . (RUNTIME RANDOM-NUMBER))
 	 ("gentag" . (RUNTIME GENERIC-PROCEDURE))
 	 ("poplat" . (RUNTIME POPULATION))
-	 ("record" . (RUNTIME RECORD))
-	 ("syntax-transforms" . (RUNTIME SYNTACTIC-CLOSURES))))
+	 ("record" . (RUNTIME RECORD))))
       (files2
-       '(("prop1d" . (RUNTIME 1D-PROPERTY))
+       '(("syntax-items" . (RUNTIME SYNTAX ITEMS))
+	 ("syntax-transforms" . (RUNTIME SYNTAX TRANSFORMS))
+	 ("prop1d" . (RUNTIME 1D-PROPERTY))
 	 ("events" . (RUNTIME EVENT-DISTRIBUTOR))
 	 ("gdatab" . (RUNTIME GLOBAL-DATABASE))
 	 ("gcfinal" . (RUNTIME GC-FINALIZER))
@@ -381,9 +382,6 @@ USA.
 		      #t)
   (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-PACKAGE! #t)
   (package-initialize '(RUNTIME RECORD) 'INITIALIZE-RECORD-TYPE-TYPE! #t)
-  (package-initialize '(RUNTIME SYNTACTIC-CLOSURES)
-		      'INITIALIZE-SYNTAX-TRANSFORMS!
-		      #t)
   (load-files files2)
   (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-PACKAGE! #t)
   (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) 'INITIALIZE-PACKAGE! #t)
@@ -496,6 +494,7 @@ USA.
    (RUNTIME UNSYNTAXER)
    (RUNTIME PRETTY-PRINTER)
    (RUNTIME EXTENDED-SCODE-EVAL)
+   (RUNTIME SYNTAX DEFINITIONS)
    ;; REP Loops
    (RUNTIME INTERRUPT-HANDLER)
    (RUNTIME GC-STATISTICS)
diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
new file mode 100644
index 000000000..97578338f
--- /dev/null
+++ b/src/runtime/mit-macros.scm
@@ -0,0 +1,568 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; MIT/GNU Scheme macros
+
+(declare (usual-integrations))
+
+;;;; SRFI features
+
+(define-syntax :cond-expand
+  (er-macro-transformer
+   (lambda (form rename compare)
+     (let ((if-error (lambda () (ill-formed-syntax form))))
+       (if (syntax-match? '(+ (DATUM * FORM)) (cdr form))
+	   (let loop ((clauses (cdr form)))
+	     (let ((req (caar clauses))
+		   (if-true (lambda () `(,(rename 'BEGIN) ,@(cdar clauses)))))
+	       (if (and (identifier? req)
+			(compare (rename 'ELSE) req))
+		   (if (null? (cdr clauses))
+		       (if-true)
+		       (if-error))
+		   (let req-loop
+		       ((req req)
+			(if-true if-true)
+			(if-false
+			 (lambda ()
+			   (if (null? (cdr clauses))
+			       (if-error)
+			       (loop (cdr clauses))))))
+		     (cond ((identifier? req)
+			    (if (any (lambda (feature)
+				       (compare (rename feature) req))
+				     supported-srfi-features)
+				(if-true)
+				(if-false)))
+			   ((and (syntax-match? '(IDENTIFIER DATUM) req)
+				 (compare (rename 'NOT) (car req)))
+			    (req-loop (cadr req)
+				      if-false
+				      if-true))
+			   ((and (syntax-match? '(IDENTIFIER * DATUM) req)
+				 (compare (rename 'AND) (car req)))
+			    (let and-loop ((reqs (cdr req)))
+			      (if (pair? reqs)
+				  (req-loop (car reqs)
+					    (lambda () (and-loop (cdr reqs)))
+					    if-false)
+				  (if-true))))
+			   ((and (syntax-match? '(IDENTIFIER * DATUM) req)
+				 (compare (rename 'OR) (car req)))
+			    (let or-loop ((reqs (cdr req)))
+			      (if (pair? reqs)
+				  (req-loop (car reqs)
+					    if-true
+					    (lambda () (or-loop (cdr reqs))))
+				  (if-false))))
+			   (else
+			    (if-error)))))))
+	   (if-error))))))
+
+(define supported-srfi-features
+  '(MIT
+    MIT/GNU
+    SRFI-0                              ;COND-EXPAND
+    SRFI-1                              ;List Library
+    SRFI-2                              ;AND-LET*
+    SRFI-6                              ;Basic String Ports
+    SRFI-8                              ;RECEIVE
+    SRFI-9                              ;DEFINE-RECORD-TYPE
+    SRFI-23                             ;ERROR
+    SRFI-27                             ;Sources of Random Bits
+    SRFI-30                             ;Nested Multi-Line Comments (#| ... |#)
+    SRFI-62                             ;S-expression comments
+    SRFI-69				;Basic Hash Tables
+    ))
+
+(define-syntax :receive
+  (er-macro-transformer
+   (lambda (form rename compare)
+     compare				;ignore
+     (if (syntax-match? '(R4RS-BVL FORM + FORM) (cdr form))
+	 `(,(rename 'CALL-WITH-VALUES)
+	   (,(rename 'LAMBDA) () ,(caddr form))
+	   (,(rename 'LAMBDA) ,(cadr form) ,@(cdddr form)))
+	 (ill-formed-syntax form)))))
+
+(define-syntax :define-record-type
+  (er-macro-transformer
+   (lambda (form rename compare)
+     compare				;ignore
+     (if (syntax-match? '(IDENTIFIER
+			  (IDENTIFIER * IDENTIFIER)
+			  IDENTIFIER
+			  * (IDENTIFIER IDENTIFIER ? IDENTIFIER))
+			(cdr form))
+	 (let ((type (cadr form))
+	       (constructor (car (caddr form)))
+	       (c-tags (cdr (caddr form)))
+	       (predicate (cadddr form))
+	       (fields (cddddr form))
+	       (de (rename 'DEFINE)))
+	   `(,(rename 'BEGIN)
+	     (,de ,type (,(rename 'MAKE-RECORD-TYPE) ',type ',(map car fields)))
+	     (,de ,constructor (,(rename 'RECORD-CONSTRUCTOR) ,type ',c-tags))
+	     (,de ,predicate (,(rename 'RECORD-PREDICATE) ,type))
+	     ,@(append-map
+		(lambda (field)
+		  (let ((name (car field)))
+		    (cons `(,de ,(cadr field)
+				(,(rename 'RECORD-ACCESSOR) ,type ',name))
+			  (if (pair? (cddr field))
+			      `((,de ,(caddr field)
+				     (,(rename 'RECORD-MODIFIER) ,type ',name)))
+			      '()))))
+		fields)))
+	 (ill-formed-syntax form)))))
+
+(define-syntax :define
+  (er-macro-transformer
+   (lambda (form rename compare)
+     compare				;ignore
+     (receive (name value) (parse-define-form form rename)
+       `(,keyword:define ,name ,value)))))
+
+(define (parse-define-form form rename)
+  (cond ((syntax-match? '((DATUM . MIT-BVL) + FORM) (cdr form))
+	 (parse-define-form
+	  `(,(car form) ,(caadr form)
+			,(if (identifier? (caadr form))
+			     `(,(rename 'NAMED-LAMBDA) ,@(cdr form))
+			     `(,(rename 'LAMBDA) ,(cdadr form) ,@(cddr form))))
+	  rename))
+	((syntax-match? '(IDENTIFIER ? EXPRESSION) (cdr form))
+	 (values (cadr form)
+		 (if (pair? (cddr form))
+		     (caddr form)
+		     (unassigned-expression))))
+	(else
+	 (ill-formed-syntax form))))
+
+(define-syntax :let
+  (er-macro-transformer
+   (lambda (form rename compare)
+     compare				;ignore
+     (cond ((syntax-match? '(IDENTIFIER (* (IDENTIFIER ? EXPRESSION)) + FORM)
+			   (cdr form))
+	    (let ((name (cadr form))
+		  (bindings (caddr form))
+		  (body (cdddr form)))
+	      `((,(rename 'LETREC)
+		 ((,name (,(rename 'NAMED-LAMBDA) (,name ,@(map car bindings))
+						  ,@body)))
+		 ,name)
+		,@(map (lambda (binding)
+			 (if (pair? (cdr binding))
+			     (cadr binding)
+			     (unassigned-expression)))
+		       bindings))))
+	   ((syntax-match? '((* (IDENTIFIER ? EXPRESSION)) + FORM) (cdr form))
+	    `(,keyword:let ,@(cdr (normalize-let-bindings form))))
+	   (else
+	    (ill-formed-syntax form))))))
+
+(define (normalize-let-bindings form)
+  `(,(car form) ,(map (lambda (binding)
+			(if (pair? (cdr binding))
+			    binding
+			    (list (car binding) (unassigned-expression))))
+		      (cadr form))
+		,@(cddr form)))
+
+(define-syntax :let*
+  (er-macro-transformer
+   (lambda (form rename compare)
+     rename compare			;ignore
+     (expand/let* form keyword:let))))
+
+(define-syntax :let*-syntax
+  (er-macro-transformer
+   (lambda (form rename compare)
+     rename compare			;ignore
+     (expand/let* form keyword:let-syntax))))
+
+(define (expand/let* form let-keyword)
+  (syntax-check '(KEYWORD (* DATUM) + FORM) form)
+  (let ((bindings (cadr form))
+	(body (cddr form)))
+    (if (pair? bindings)
+	(let loop ((bindings bindings))
+	  (if (pair? (cdr bindings))
+	      `(,let-keyword (,(car bindings)) ,(loop (cdr bindings)))
+	      `(,let-keyword ,bindings ,@body)))
+	`(,let-keyword ,bindings ,@body))))
+
+(define-syntax :and
+  (er-macro-transformer
+   (lambda (form rename compare)
+     compare				;ignore
+     (syntax-check '(KEYWORD * EXPRESSION) form)
+     (let ((operands (cdr form)))
+       (if (pair? operands)
+	   (let ((if-keyword (rename 'IF)))
+	     (let loop ((operands operands))
+	       (if (pair? (cdr operands))
+		   `(,if-keyword ,(car operands)
+				 ,(loop (cdr operands))
+				 #F)
+		   (car operands))))
+	   `#T)))))
+
+(define-syntax :case
+  (er-macro-transformer
+   (lambda (form rename compare)
+     (syntax-check '(KEYWORD EXPRESSION + (DATUM * EXPRESSION)) form)
+     (letrec
+	 ((process-clause
+	   (lambda (clause rest)
+	     (cond ((null? (car clause))
+		    (process-rest rest))
+		   ((and (identifier? (car clause))
+			 (compare (rename 'ELSE) (car clause))
+			 (null? rest))
+		    `(,(rename 'BEGIN) ,@(cdr clause)))
+		   ((list? (car clause))
+		    `(,(rename 'IF) ,(process-predicate (car clause))
+				    (,(rename 'BEGIN) ,@(cdr clause))
+				    ,(process-rest rest)))
+		   (else
+		    (syntax-error "Ill-formed clause:" clause)))))
+	  (process-rest
+	   (lambda (rest)
+	     (if (pair? rest)
+		 (process-clause (car rest) (cdr rest))
+		 (unspecific-expression))))
+	  (process-predicate
+	   (lambda (items)
+	     ;; Optimize predicate for speed in compiled code.
+	     (cond ((null? (cdr items))
+		    (single-test (car items)))
+		   ((null? (cddr items))
+		    `(,(rename 'OR) ,(single-test (car items))
+				    ,(single-test (cadr items))))
+		   ((null? (cdddr items))
+		    `(,(rename 'OR) ,(single-test (car items))
+				    ,(single-test (cadr items))
+				    ,(single-test (caddr items))))
+		   ((null? (cddddr items))
+		    `(,(rename 'OR) ,(single-test (car items))
+				    ,(single-test (cadr items))
+				    ,(single-test (caddr items))
+				    ,(single-test (cadddr items))))
+		   (else
+		    `(,(rename
+			(if (for-all? items eq-testable?) 'MEMQ 'MEMV))
+		      ,(rename 'TEMP)
+		      ',items)))))
+	  (single-test
+	   (lambda (item)
+	     `(,(rename (if (eq-testable? item) 'EQ? 'EQV?))
+	       ,(rename 'TEMP)
+	       ',item)))
+	  (eq-testable?
+	   (lambda (item)
+	     (or (symbol? item)
+		 (boolean? item)
+		 ;; remainder are implementation dependent:
+		 (char? item)
+		 (fix:fixnum? item)))))
+       `(,(rename 'LET) ((,(rename 'TEMP) ,(cadr form)))
+			,(process-clause (caddr form)
+					 (cdddr form)))))))
+
+(define-syntax :cond
+  (er-macro-transformer
+   (lambda (form rename compare)
+     (let ((clauses (cdr form)))
+       (if (not (pair? clauses))
+	   (syntax-error "Form must have at least one clause:" form))
+       (let loop ((clause (car clauses)) (rest (cdr clauses)))
+	 (expand/cond-clause clause rename compare (null? rest)
+			     (if (pair? rest)
+				 (loop (car rest) (cdr rest))
+				 (unspecific-expression))))))))
+
+(define-syntax :do
+  (er-macro-transformer
+   (lambda (form rename compare)
+     (syntax-check '(KEYWORD (* (IDENTIFIER EXPRESSION ? EXPRESSION))
+			     (+ FORM)
+			     * FORM)
+		   form)
+     (let ((bindings (cadr form))
+	   (r-loop (rename 'DO-LOOP)))
+       `(,(rename 'LET)
+	 ,r-loop
+	 ,(map (lambda (binding)
+		 (list (car binding) (cadr binding)))
+	       bindings)
+	 ,(expand/cond-clause (caddr form) rename compare #f
+			      `(,(rename 'BEGIN)
+				,@(cdddr form)
+				(,r-loop ,@(map (lambda (binding)
+						  (if (pair? (cddr binding))
+						      (caddr binding)
+						      (car binding)))
+						bindings)))))))))
+
+(define (expand/cond-clause clause rename compare else-allowed? alternative)
+  (if (not (and (pair? clause) (list? (cdr clause))))
+      (syntax-error "Ill-formed clause:" clause))
+  (cond ((and (identifier? (car clause))
+	      (compare (rename 'ELSE) (car clause)))
+	 (if (not else-allowed?)
+	     (syntax-error "Misplaced ELSE clause:" clause))
+	 (if (or (not (pair? (cdr clause)))
+		 (and (identifier? (cadr clause))
+		      (compare (rename '=>) (cadr clause))))
+	     (syntax-error "Ill-formed ELSE clause:" clause))
+	 `(,(rename 'BEGIN) ,@(cdr clause)))
+	((not (pair? (cdr clause)))
+	 (let ((r-temp (rename 'TEMP)))
+	   `(,(rename 'LET) ((,r-temp ,(car clause)))
+			    (,(rename 'IF) ,r-temp ,r-temp ,alternative))))
+	((and (identifier? (cadr clause))
+	      (compare (rename '=>) (cadr clause)))
+	 (if (not (and (pair? (cddr clause))
+		       (null? (cdddr clause))))
+	     (syntax-error "Ill-formed => clause:" clause))
+	 (let ((r-temp (rename 'TEMP)))
+	   `(,(rename 'LET) ((,r-temp ,(car clause)))
+			    (,(rename 'IF) ,r-temp
+					   (,(caddr clause) ,r-temp)
+					   ,alternative))))
+	(else
+	 `(,(rename 'IF) ,(car clause)
+			 (,(rename 'BEGIN) ,@(cdr clause))
+			 ,alternative))))
+
+(define-syntax :quasiquote
+  (er-macro-transformer
+   (lambda (form rename compare)
+
+     (define (descend-quasiquote x level return)
+       (cond ((pair? x) (descend-quasiquote-pair x level return))
+	     ((vector? x) (descend-quasiquote-vector x level return))
+	     (else (return 'QUOTE x))))
+
+     (define (descend-quasiquote-pair x level return)
+       (cond ((not (and (pair? x)
+			(identifier? (car x))
+			(pair? (cdr x))
+			(null? (cddr x))))
+	      (descend-quasiquote-pair* x level return))
+	     ((compare (rename 'QUASIQUOTE) (car x))
+	      (descend-quasiquote-pair* x (+ level 1) return))
+	     ((compare (rename 'UNQUOTE) (car x))
+	      (if (zero? level)
+		  (return 'UNQUOTE (cadr x))
+		  (descend-quasiquote-pair* x (- level 1) return)))
+	     ((compare (rename 'UNQUOTE-SPLICING) (car x))
+	      (if (zero? level)
+		  (return 'UNQUOTE-SPLICING (cadr x))
+		  (descend-quasiquote-pair* x (- level 1) return)))
+	     (else
+	      (descend-quasiquote-pair* x level return))))
+
+     (define (descend-quasiquote-pair* x level return)
+       (descend-quasiquote (car x) level
+	 (lambda (car-mode car-arg)
+	   (descend-quasiquote (cdr x) level
+	     (lambda (cdr-mode cdr-arg)
+	       (cond ((and (eq? car-mode 'QUOTE) (eq? cdr-mode 'QUOTE))
+		      (return 'QUOTE x))
+		     ((eq? car-mode 'UNQUOTE-SPLICING)
+		      (if (and (eq? cdr-mode 'QUOTE) (null? cdr-arg))
+			  (return 'UNQUOTE car-arg)
+			  (return 'APPEND
+				  (list car-arg
+					(finalize-quasiquote cdr-mode
+							     cdr-arg)))))
+		     ((and (eq? cdr-mode 'QUOTE) (list? cdr-arg))
+		      (return 'LIST
+			      (cons (finalize-quasiquote car-mode car-arg)
+				    (map (lambda (element)
+					   (finalize-quasiquote 'QUOTE
+								element))
+					 cdr-arg))))
+		     ((eq? cdr-mode 'LIST)
+		      (return 'LIST
+			      (cons (finalize-quasiquote car-mode car-arg)
+				    cdr-arg)))
+		     (else
+		      (return
+		       'CONS
+		       (list (finalize-quasiquote car-mode car-arg)
+			     (finalize-quasiquote cdr-mode cdr-arg))))))))))
+
+     (define (descend-quasiquote-vector x level return)
+       (descend-quasiquote (vector->list x) level
+	 (lambda (mode arg)
+	   (case mode
+	     ((QUOTE) (return 'QUOTE x))
+	     ((LIST) (return 'VECTOR arg))
+	     (else
+	      (return 'LIST->VECTOR
+		      (list (finalize-quasiquote mode arg))))))))
+
+     (define (finalize-quasiquote mode arg)
+       (case mode
+	 ((QUOTE) `(,(rename 'QUOTE) ,arg))
+	 ((UNQUOTE) arg)
+	 ((UNQUOTE-SPLICING) (syntax-error ",@ in illegal context:" arg))
+	 (else `(,(rename mode) ,@arg))))
+
+     (syntax-check '(KEYWORD EXPRESSION) form)
+     (descend-quasiquote (cadr form) 0 finalize-quasiquote))))
+
+;;;; SRFI 2: AND-LET*
+
+;;; The SRFI document is a little unclear about the semantics, imposes
+;;; the weird restriction that variables may be duplicated (citing
+;;; LET*'s similar restriction, which doesn't actually exist), and the
+;;; reference implementation is highly non-standard and hard to
+;;; follow.  This passes all of the tests except for the one that
+;;; detects duplicate bound variables, though.
+
+(define-syntax :and-let*
+  (er-macro-transformer
+   (lambda (form rename compare)
+     compare
+     (let ((%and (rename 'AND))
+	   (%let (rename 'LET))
+	   (%begin (rename 'BEGIN)))
+       (cond ((syntax-match? '(() * FORM) (cdr form))
+	      `(,%begin #T ,@(cddr form)))
+	     ((syntax-match? '((* DATUM) * FORM) (cdr form))
+	      (let ((clauses (cadr form))
+		    (body (cddr form)))
+		(define (expand clause recur)
+		  (cond ((syntax-match? 'IDENTIFIER clause)
+			 (recur clause))
+			((syntax-match? '(EXPRESSION) clause)
+			 (recur (car clause)))
+			((syntax-match? '(IDENTIFIER EXPRESSION) clause)
+			 (let ((tail (recur (car clause))))
+			   (and tail `(,%let (,clause) ,tail))))
+			(else #f)))
+		(define (recur clauses make-body)
+		  (expand (car clauses)
+			  (let ((clauses (cdr clauses)))
+			    (if (null? clauses)
+				make-body
+				(lambda (conjunct)
+				  `(,%and ,conjunct
+					  ,(recur clauses make-body)))))))
+		(or (recur clauses
+			   (if (null? body)
+			       (lambda (conjunct) conjunct)
+			       (lambda (conjunct)
+				 `(,%and ,conjunct (,%begin ,@body)))))
+		    (ill-formed-syntax form))))
+	     (else
+	      (ill-formed-syntax form)))))))
+
+(define-syntax :access
+  (er-macro-transformer
+   (lambda (form rename compare)
+     rename compare			;ignore
+     (cond ((syntax-match? '(IDENTIFIER EXPRESSION) (cdr form))
+	    `(,keyword:access ,@(cdr form)))
+	   ((syntax-match? '(IDENTIFIER IDENTIFIER + FORM) (cdr form))
+	    `(,keyword:access ,(cadr form) (,(car form) ,@(cddr form))))
+	   (else
+	    (ill-formed-syntax form))))))
+
+(define-syntax :cons-stream
+  (er-macro-transformer
+   (lambda (form rename compare)
+     compare				;ignore
+     (syntax-check '(KEYWORD EXPRESSION EXPRESSION) form)
+     `(,(rename 'CONS) ,(cadr form)
+		       (,(rename 'DELAY) ,(caddr form))))))
+
+(define-syntax :define-integrable
+  (er-macro-transformer
+   (lambda (form rename compare)
+     compare				;ignore
+     (let ((r-begin (rename 'BEGIN))
+	   (r-declare (rename 'DECLARE))
+	   (r-define (rename 'DEFINE)))
+       (cond ((syntax-match? '(IDENTIFIER EXPRESSION) (cdr form))
+	      `(,r-begin
+		(,r-declare (INTEGRATE ,(cadr form)))
+		(,r-define ,@(cdr form))))
+	     ((syntax-match? '((IDENTIFIER * IDENTIFIER) + FORM) (cdr form))
+	      `(,r-begin
+		(,r-declare (INTEGRATE-OPERATOR ,(caadr form)))
+		(,r-define ,(cadr form)
+			   (,r-declare (INTEGRATE ,@(cdadr form)))
+			   ,@(cddr form))))
+	     (else
+	      (ill-formed-syntax form)))))))
+
+(define-syntax :fluid-let
+  (er-macro-transformer
+   (lambda (form rename compare)
+     compare
+     (syntax-check '(KEYWORD (* (FORM ? EXPRESSION)) + FORM) form)
+     (let ((names (map car (cadr form)))
+	   (r-let (rename 'LET))
+	   (r-lambda (rename 'LAMBDA))
+	   (r-set! (rename 'SET!)))
+       (let ((out-temps
+	      (map (lambda (name)
+		     name
+		     (make-synthetic-identifier 'OUT-TEMP))
+		   names))
+	     (in-temps
+	      (map (lambda (name)
+		     name
+		     (make-synthetic-identifier 'IN-TEMP))
+		   names))
+	     (swap
+	      (lambda (tos names froms)
+		`(,r-lambda ()
+			    ,@(map (lambda (to name from)
+				     `(,r-set! ,to
+					       (,r-set! ,name
+							(,r-set! ,from))))
+				   tos
+				   names
+				   froms)
+			    ,(unspecific-expression)))))
+	 `(,r-let (,@(map cons in-temps (map cdr (cadr form)))
+		   ,@(map list out-temps))
+		  (,(rename 'SHALLOW-FLUID-BIND)
+		   ,(swap out-temps names in-temps)
+		   (,r-lambda () ,@(cddr form))
+		   ,(swap in-temps names out-temps))))))))
+
+(define (unspecific-expression)
+  `(,keyword:unspecific))
+
+(define (unassigned-expression)
+  `(,keyword:unassigned))
\ No newline at end of file
diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index b7cb3d349..dd695a675 100644
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -29,88 +29,55 @@ USA.
 
 ;;;; Macro transformers
 
-(define (define-er-macro-transformer keyword environment transformer)
-  (syntactic-environment/define environment keyword
-    (er-macro-transformer->expander transformer environment)))
-
-(define (transformer-keyword transformer->expander-name transformer->expander)
-  (lambda (form environment definition-environment history)
+(define (transformer-keyword name transformer->expander)
+  (lambda (form environment definition-environment)
     definition-environment		;ignore
-    (syntax-check '(KEYWORD EXPRESSION) form history)
-    (expression->keyword-value-item (classify/subexpression (cadr form)
-							    environment
-							    history
-							    select-cadr)
-				    environment
-				    history
-				    transformer->expander-name
-				    transformer->expander)))
-
-(define (expression->keyword-value-item item environment history
-					transformer->expander-name
-					transformer->expander)
-  (make-keyword-value-item
-   history
-   (transformer->expander
-    (transformer-eval (compile-item/expression item)
-		      (syntactic-environment->environment environment))
-    environment)
-   (make-expression-item history
-     (lambda ()
-       (output/combination
-	(output/access-reference transformer->expander-name
-				 system-global-environment)
-	(list (compile-item/expression item)
-	      (output/the-environment)))))))
+    (syntax-check '(KEYWORD EXPRESSION) form)
+    (let ((item (classify/expression (cadr form) environment)))
+      (make-keyword-value-item
+       (transformer->expander (transformer-eval (compile-item/expression item)
+						environment)
+			      environment)
+       (make-expression-item
+	(lambda ()
+	  (output/combination (output/runtime-reference name)
+			      (list (compile-item/expression item)
+				    (output/the-environment)))))))))
 
-(define-classifier 'SC-MACRO-TRANSFORMER system-global-environment
+(define classifier:sc-macro-transformer
   ;; "Syntactic Closures" transformer
   (transformer-keyword 'SC-MACRO-TRANSFORMER->EXPANDER
 		       sc-macro-transformer->expander))
 
-(define-classifier 'RSC-MACRO-TRANSFORMER system-global-environment
+(define classifier:rsc-macro-transformer
   ;; "Reversed Syntactic Closures" transformer
   (transformer-keyword 'RSC-MACRO-TRANSFORMER->EXPANDER
 		       rsc-macro-transformer->expander))
 
-(define-classifier 'ER-MACRO-TRANSFORMER system-global-environment
+(define classifier:er-macro-transformer
   ;; "Explicit Renaming" transformer
   (transformer-keyword 'ER-MACRO-TRANSFORMER->EXPANDER
 		       er-macro-transformer->expander))
 
-(define-classifier 'NON-HYGIENIC-MACRO-TRANSFORMER system-global-environment
+(define classifier:non-hygienic-macro-transformer
   (transformer-keyword 'NON-HYGIENIC-MACRO-TRANSFORMER->EXPANDER
 		       non-hygienic-macro-transformer->expander))
 
 ;;;; Core primitives
 
-(define-compiler 'LAMBDA system-global-environment
-  (lambda (form environment history)
-    (syntax-check '(KEYWORD MIT-BVL + FORM) form history)
-    (call-with-values
-	(lambda ()
-	  (compile/lambda (cadr form)
-			  (cddr form)
-			  select-cddr
-			  environment
-			  history))
-      (lambda (bvl body)
-	(output/lambda bvl body)))))
+(define (compiler:lambda form environment)
+  (syntax-check '(KEYWORD MIT-BVL + FORM) form)
+  (receive (bvl body)
+      (compile/lambda (cadr form) (cddr form) environment)
+    (output/lambda bvl body)))
 
-(define-compiler 'NAMED-LAMBDA system-global-environment
-  (lambda (form environment history)
-    (syntax-check '(KEYWORD (IDENTIFIER . MIT-BVL) + FORM) form history)
-    (call-with-values
-	(lambda ()
-	  (compile/lambda (cdadr form)
-			  (cddr form)
-			  select-cddr
-			  environment
-			  history))
-      (lambda (bvl body)
-	(output/named-lambda (identifier->symbol (caadr form)) bvl body)))))
+(define (compiler:named-lambda form environment)
+  (syntax-check '(KEYWORD (IDENTIFIER . MIT-BVL) + FORM) form)
+  (receive (bvl body)
+      (compile/lambda (cdadr form) (cddr form) environment)
+    (output/named-lambda (identifier->symbol (caadr form)) bvl body)))
 
-(define (compile/lambda bvl body select-body environment history)
+(define (compile/lambda bvl body environment)
   (let ((environment (make-internal-syntactic-environment environment)))
     ;; Force order -- bind names before classifying body.
     (let ((bvl
@@ -121,935 +88,293 @@ USA.
 	      (compile-body-item
 	       (classify/body body
 			      environment
-			      environment
-			      history
-			      select-body))))))
-
-(define (map-mit-lambda-list procedure bvl)
-  (let loop ((bvl bvl))
-    (if (pair? bvl)
-	(cons (if (or (eq? (car bvl) lambda-optional-tag)
-		      (eq? (car bvl) lambda-rest-tag))
-		  (car bvl)
-		  (procedure (car bvl)))
-	      (loop (cdr bvl)))
-	(if (identifier? bvl)
-	    (procedure bvl)
-	    '()))))
-
-(define-classifier 'BEGIN system-global-environment
-  (lambda (form environment definition-environment history)
-    (syntax-check '(KEYWORD * FORM) form history)
-    (make-body-item history
-		    (classify/subforms (cdr form)
-				       environment
-				       definition-environment
-				       history
-				       select-cdr))))
-
-(define-compiler 'IF system-global-environment
-  (lambda (form environment history)
-    (syntax-check '(KEYWORD EXPRESSION EXPRESSION ? EXPRESSION)
-		  form history)
-    (output/conditional
-     (compile/subexpression (cadr form) environment history select-cadr)
-     (compile/subexpression (caddr form) environment history select-caddr)
-     (if (pair? (cdddr form))
-	 (compile/subexpression (cadddr form)
-				environment
-				history
-				select-cadddr)
-	 (output/unspecific)))))
-
-(define-compiler 'QUOTE system-global-environment
-  (lambda (form environment history)
-    environment			;ignore
-    (syntax-check '(KEYWORD DATUM) form history)
-    (output/constant (strip-syntactic-closures (cadr form)))))
-
-(define-compiler 'SET! system-global-environment
-  (lambda (form environment history)
-    (syntax-check '(KEYWORD FORM ? EXPRESSION) form history)
-    (call-with-values
-	(lambda ()
-	  (classify/sublocation (cadr form) environment history select-cadr))
-      (lambda (name environment-item)
-	(let ((value
-	       (if (pair? (cddr form))
-		   (compile/subexpression (caddr form)
-					  environment
-					  history
-					  select-caddr)
-		   (output/unassigned))))
-	  (if environment-item
-	      (output/access-assignment
-	       name
-	       (compile-item/expression environment-item)
-	       value)
-	      (output/assignment name value)))))))
-
-(define (classify/sublocation form environment history selector)
-  (classify/location form
-		     environment
-		     (history/add-subproblem form
-					     environment
-					     history
-					     selector)))
-
-(define (classify/location form environment history)
-  (let ((item (classify/expression form environment history)))
+			      environment))))))
+
+(define (classifier:begin form environment definition-environment)
+  (syntax-check '(KEYWORD * FORM) form)
+  (classify/body (cdr form) environment definition-environment))
+
+(define (compiler:if form environment)
+  (syntax-check '(KEYWORD EXPRESSION EXPRESSION ? EXPRESSION) form)
+  (output/conditional
+   (compile/expression (cadr form) environment)
+   (compile/expression (caddr form) environment)
+   (if (pair? (cdddr form))
+       (compile/expression (cadddr form) environment)
+       (output/unspecific))))
+
+(define (compiler:quote form environment)
+  environment				;ignore
+  (syntax-check '(KEYWORD DATUM) form)
+  (output/constant (strip-syntactic-closures (cadr form))))
+
+(define (compiler:set! form environment)
+  (syntax-check '(KEYWORD FORM ? EXPRESSION) form)
+  (receive (name environment-item)
+      (classify/location (cadr form) environment)
+    (let ((value
+	   (if (pair? (cddr form))
+	       (compile/expression (caddr form) environment)
+	       (output/unassigned))))
+      (if environment-item
+	  (output/access-assignment
+	   name
+	   (compile-item/expression environment-item)
+	   value)
+	  (output/assignment name value)))))
+
+(define (classify/location form environment)
+  (let ((item (classify/expression form environment)))
     (cond ((variable-item? item)
 	   (values (variable-item/name item) #f))
 	  ((access-item? item)
 	   (values (access-item/name item) (access-item/environment item)))
 	  (else
-	   (syntax-error history "Variable required in this context:" form)))))
+	   (syntax-error "Variable required in this context:" form)))))
 
-(define-compiler 'DELAY system-global-environment
-  (lambda (form environment history)
-    (syntax-check '(KEYWORD EXPRESSION) form history)
-    (output/delay
-     (compile/subexpression (cadr form)
-			    environment
-			    history
-			    select-cadr))))
+(define (compiler:delay form environment)
+  (syntax-check '(KEYWORD EXPRESSION) form)
+  (output/delay (compile/expression (cadr form) environment)))
 
 ;;;; Definitions
 
-(define-er-macro-transformer 'DEFINE system-global-environment
-  (let ((keyword
-	 (classifier->keyword
-	  (lambda (form environment definition-environment history)
-	    (classify/define form environment definition-environment history
-			     variable-binding-theory)))))
-    (lambda (form rename compare)
-      compare				;ignore
-      (parse-define-form form rename
-	(lambda (name value)
-	  `(,keyword ,name ,value))))))
-
-(define (parse-define-form form rename receiver)
-  (cond ((syntax-match? '((IDENTIFIER . MIT-BVL) + FORM) (cdr form))
-	 (parse-define-form
-	  `(,(car form) ,(caadr form)
-			(,(rename 'NAMED-LAMBDA) ,@(cdr form)))
-	  rename
-	  receiver))
-	((syntax-match? '((DATUM . MIT-BVL) + FORM) (cdr form))
-	 (parse-define-form
-	  `(,(car form) ,(caadr form)
-			(,(rename 'LAMBDA) ,(cdadr form) ,@(cddr form)))
-	  rename
-	  receiver))
-	((syntax-match? '(IDENTIFIER) (cdr form))
-	 (receiver (cadr form) (unassigned-expression)))
-	((syntax-match? '(IDENTIFIER EXPRESSION) (cdr form))
-	 (receiver (cadr form) (caddr form)))
-	(else
-	 (ill-formed-syntax form))))
+(define keyword:define
+  (classifier->keyword
+   (lambda (form environment definition-environment)
+     (classify/define form environment definition-environment
+		      variable-binding-theory))))
 
-(define-classifier 'DEFINE-SYNTAX system-global-environment
-  (lambda (form environment definition-environment history)
-    (syntax-check '(KEYWORD IDENTIFIER EXPRESSION) form history)
-    (classify/define form environment definition-environment history
-		     syntactic-binding-theory)))
+(define (classifier:define-syntax form environment definition-environment)
+  (syntax-check '(KEYWORD IDENTIFIER EXPRESSION) form)
+  (classify/define form environment definition-environment
+		   syntactic-binding-theory))
 
-(define (classify/define form environment definition-environment history
+(define (classify/define form environment definition-environment
 			 binding-theory)
   (if (not (syntactic-environment/top-level? definition-environment))
       (syntactic-environment/define definition-environment
 				    (cadr form)
-				    (make-reserved-name-item history)))
+				    (make-reserved-name-item)))
   (binding-theory definition-environment
 		  (cadr form)
-		  (classify/subexpression (caddr form)
-					  environment
-					  history
-					  select-caddr)
-		  history))
+		  (classify/expression (caddr form) environment)))
 
-(define (syntactic-binding-theory environment name item history)
+(define (syntactic-binding-theory environment name item)
   (if (not (keyword-item? item))
-      (let ((history (item/history item)))
-	(syntax-error history "Syntactic binding value must be a keyword:"
-		      (history/original-form history))))
-  (syntactic-environment/define environment
-                                name
-                                (item/new-history item #f))
+      (syntax-error "Syntactic binding value must be a keyword:" name))
+  (syntactic-environment/define environment name item)
   ;; User-defined macros at top level are preserved in the output.
   (if (and (keyword-value-item? item)
            (syntactic-environment/top-level? environment))
-      (make-binding-item history
-                         (rename-top-level-identifier name)
-                         item)
-      (make-null-binding-item history)))
+      (make-binding-item (rename-top-level-identifier name) item)
+      (make-null-binding-item)))
 
-(define (variable-binding-theory environment name item history)
+(define (variable-binding-theory environment name item)
   (if (keyword-item? item)
-      (let ((history (item/history item)))
-	(syntax-error history "Binding value may not be a keyword:"
-		      (history/original-form history))))
-  (make-binding-item history (bind-variable! environment name) item))
-
-;;;; SRFI features
-
-(define-er-macro-transformer 'COND-EXPAND system-global-environment
-  (lambda (form rename compare)
-    (let ((if-error (lambda () (ill-formed-syntax form))))
-      (if (syntax-match? '(+ (DATUM * FORM)) (cdr form))
-	  (let loop ((clauses (cdr form)))
-	    (let ((req (caar clauses))
-		  (if-true (lambda () `(,(rename 'BEGIN) ,@(cdar clauses)))))
-	      (if (and (identifier? req)
-		       (compare (rename 'ELSE) req))
-		  (if (null? (cdr clauses))
-		      (if-true)
-		      (if-error))
-		  (let req-loop
-		      ((req req)
-		       (if-true if-true)
-		       (if-false
-			(lambda ()
-			  (if (null? (cdr clauses))
-			      (if-error)
-			      (loop (cdr clauses))))))
-		    (cond ((identifier? req)
-			   (if (there-exists? supported-srfi-features
-				 (lambda (feature)
-				   (compare (rename feature) req)))
-			       (if-true)
-			       (if-false)))
-			  ((and (syntax-match? '(IDENTIFIER DATUM) req)
-				(compare (rename 'NOT) (car req)))
-			   (req-loop (cadr req)
-				     if-false
-				     if-true))
-			  ((and (syntax-match? '(IDENTIFIER * DATUM) req)
-				(compare (rename 'AND) (car req)))
-			   (let and-loop ((reqs (cdr req)))
-			     (if (pair? reqs)
-				 (req-loop (car reqs)
-					   (lambda () (and-loop (cdr reqs)))
-					   if-false)
-				 (if-true))))
-			  ((and (syntax-match? '(IDENTIFIER * DATUM) req)
-				(compare (rename 'OR) (car req)))
-			   (let or-loop ((reqs (cdr req)))
-			     (if (pair? reqs)
-				 (req-loop (car reqs)
-					   if-true
-					   (lambda () (or-loop (cdr reqs))))
-				 (if-false))))
-			  (else
-			   (if-error)))))))
-	  (if-error)))))
-
-(define supported-srfi-features
-  '(MIT
-    MIT/GNU
-    SRFI-0                              ;COND-EXPAND
-    SRFI-1                              ;List Library
-    SRFI-2                              ;AND-LET*
-    SRFI-6                              ;Basic String Ports
-    SRFI-8                              ;RECEIVE
-    SRFI-9                              ;DEFINE-RECORD-TYPE
-    SRFI-23                             ;ERROR
-    SRFI-27                             ;Sources of Random Bits
-    SRFI-30                             ;Nested Multi-Line Comments (#| ... |#)
-    SRFI-62                             ;S-expression comments
-    SRFI-69))                           ;Basic Hash Tables
-
-(define-er-macro-transformer 'RECEIVE system-global-environment
-  (lambda (form rename compare)
-    compare				;ignore
-    (if (syntax-match? '(R4RS-BVL FORM + FORM) (cdr form))
-	`(,(rename 'CALL-WITH-VALUES)
-	  (,(rename 'LAMBDA) () ,(caddr form))
-	  (,(rename 'LAMBDA) ,(cadr form) ,@(cdddr form)))
-	(ill-formed-syntax form))))
-
-(define-er-macro-transformer 'DEFINE-RECORD-TYPE system-global-environment
-  (lambda (form rename compare)
-    compare				;ignore
-    (if (syntax-match? '(IDENTIFIER
-			 (IDENTIFIER * IDENTIFIER)
-			 IDENTIFIER
-			 * (IDENTIFIER IDENTIFIER ? IDENTIFIER))
-		       (cdr form))
-	(let ((type (cadr form))
-	      (constructor (car (caddr form)))
-	      (c-tags (cdr (caddr form)))
-	      (predicate (cadddr form))
-	      (fields (cddddr form))
-	      (de (rename 'DEFINE)))
-	  `(,(rename 'BEGIN)
-	    (,de ,type (,(rename 'MAKE-RECORD-TYPE) ',type ',(map car fields)))
-	    (,de ,constructor (,(rename 'RECORD-CONSTRUCTOR) ,type ',c-tags))
-	    (,de ,predicate (,(rename 'RECORD-PREDICATE) ,type))
-	    ,@(append-map
-	       (lambda (field)
-		 (let ((name (car field)))
-		   (cons `(,de ,(cadr field)
-			       (,(rename 'RECORD-ACCESSOR) ,type ',name))
-			 (if (pair? (cddr field))
-			     `((,de ,(caddr field)
-				    (,(rename 'RECORD-MODIFIER) ,type ',name)))
-			     '()))))
-	       fields)))
-	(ill-formed-syntax form))))
+      (syntax-error "Binding value may not be a keyword:" name))
+  (make-binding-item (bind-variable! environment name) item))
 
 ;;;; LET-like
 
-(define-er-macro-transformer 'LET system-global-environment
-  (let ((keyword
-	 (classifier->keyword
-	  (lambda (form environment definition-environment history)
-	    definition-environment
-	    (let* ((binding-environment
-		    (make-internal-syntactic-environment environment))
-		   (body-environment
-		    (make-internal-syntactic-environment binding-environment)))
-	      (classify/let-like form
-				 environment
-				 binding-environment
-				 body-environment
-				 history
-				 variable-binding-theory
-				 output/let))))))
-    (lambda (form rename compare)
-      compare				;ignore
-      (cond ((syntax-match? '(IDENTIFIER (* (IDENTIFIER ? EXPRESSION)) + FORM)
-			    (cdr form))
-	     (let ((name (cadr form))
-		   (bindings (caddr form))
-		   (body (cdddr form)))
-	       `((,(rename 'LETREC)
-		  ((,name (,(rename 'NAMED-LAMBDA) (,name ,@(map car bindings))
-						   ,@body)))
-		  ,name)
-		 ,@(map (lambda (binding)
-			  (if (pair? (cdr binding))
-			      (cadr binding)
-			      (unassigned-expression)))
-			bindings))))
-	    ((syntax-match? '((* (IDENTIFIER ? EXPRESSION)) + FORM) (cdr form))
-	     `(,keyword ,@(cdr (normalize-let-bindings form))))
-	    (else
-	     (ill-formed-syntax form))))))
-
-(define-er-macro-transformer 'LET* system-global-environment
-  (lambda (form rename compare)
-    compare			;ignore
-    (expand/let* form rename 'LET)))
-
-(define-classifier 'LETREC system-global-environment
-  (lambda (form environment definition-environment history)
-    definition-environment
-    (syntax-check '(KEYWORD (* (IDENTIFIER ? EXPRESSION)) + FORM) form history)
-    (let* ((binding-environment
-	    (make-internal-syntactic-environment environment))
-	   (body-environment
-	    (make-internal-syntactic-environment binding-environment)))
-      (for-each (let ((item (make-reserved-name-item history)))
-		  (lambda (binding)
-		    (syntactic-environment/define binding-environment
-						  (car binding)
-						  item)))
-		(cadr form))
-      (classify/let-like form
-			 binding-environment
-			 binding-environment
-			 body-environment
-			 history
-			 variable-binding-theory
-			 output/letrec))))
-
-(define (normalize-let-bindings form)
-  `(,(car form) ,(map (lambda (binding)
-			(if (pair? (cdr binding))
-			    binding
-			    (list (car binding) (unassigned-expression))))
-		      (cadr form))
-		,@(cddr form)))
+(define keyword:let
+  (classifier->keyword
+   (lambda (form environment definition-environment)
+     definition-environment
+     (let* ((binding-environment
+	     (make-internal-syntactic-environment environment))
+	    (body-environment
+	     (make-internal-syntactic-environment binding-environment)))
+       (classify/let-like form
+			  environment
+			  binding-environment
+			  body-environment
+			  variable-binding-theory
+			  output/let)))))
+
+(define (classifier:letrec form environment definition-environment)
+  definition-environment
+  (syntax-check '(KEYWORD (* (IDENTIFIER ? EXPRESSION)) + FORM) form)
+  (let* ((binding-environment
+	  (make-internal-syntactic-environment environment))
+	 (body-environment
+	  (make-internal-syntactic-environment binding-environment)))
+    (for-each (let ((item (make-reserved-name-item)))
+		(lambda (binding)
+		  (syntactic-environment/define binding-environment
+						(car binding)
+						item)))
+	      (cadr form))
+    (classify/let-like form
+		       binding-environment
+		       binding-environment
+		       body-environment
+		       variable-binding-theory
+		       output/letrec)))
 
-(define-classifier 'LET-SYNTAX system-global-environment
-  (lambda (form environment definition-environment history)
-    definition-environment
-    (syntax-check '(KEYWORD (* (IDENTIFIER EXPRESSION)) + FORM) form history)
-    (let* ((binding-environment
-	    (make-internal-syntactic-environment environment))
-	   (body-environment
-	    (make-internal-syntactic-environment binding-environment)))
-      (classify/let-like form
-			 environment
-			 binding-environment
-			 body-environment
-			 history
-			 syntactic-binding-theory
-			 output/let))))
-
-(define-er-macro-transformer 'LET*-SYNTAX system-global-environment
-  (lambda (form rename compare)
-    compare			;ignore
-    (expand/let* form rename 'LET-SYNTAX)))
+(define (classifier:let-syntax form environment definition-environment)
+  definition-environment
+  (syntax-check '(KEYWORD (* (IDENTIFIER EXPRESSION)) + FORM) form)
+  (let* ((binding-environment
+	  (make-internal-syntactic-environment environment))
+	 (body-environment
+	  (make-internal-syntactic-environment binding-environment)))
+    (classify/let-like form
+		       environment
+		       binding-environment
+		       body-environment
+		       syntactic-binding-theory
+		       output/let)))
+
+(define keyword:let-syntax
+  (classifier->keyword classifier:let-syntax))
+
+(define (classifier:letrec-syntax form environment definition-environment)
+  definition-environment
+  (syntax-check '(KEYWORD (* (IDENTIFIER EXPRESSION)) + FORM) form)
+  (let* ((binding-environment
+	  (make-internal-syntactic-environment environment))
+	 (body-environment
+	  (make-internal-syntactic-environment binding-environment)))
+    (for-each (let ((item (make-reserved-name-item)))
+		(lambda (binding)
+		  (syntactic-environment/define binding-environment
+						(car binding)
+						item)))
+	      (cadr form))
+    (classify/let-like form
+		       binding-environment
+		       binding-environment
+		       body-environment
+		       syntactic-binding-theory
+		       output/letrec)))
 
-(define-classifier 'LETREC-SYNTAX system-global-environment
-  (lambda (form environment definition-environment history)
-    definition-environment
-    (syntax-check '(KEYWORD (* (IDENTIFIER EXPRESSION)) + FORM) form history)
-    (let* ((binding-environment
-	    (make-internal-syntactic-environment environment))
-	   (body-environment
-	    (make-internal-syntactic-environment binding-environment)))
-      (for-each (let ((item (make-reserved-name-item history)))
-		  (lambda (binding)
-		    (syntactic-environment/define binding-environment
-						  (car binding)
-						  item)))
-		(cadr form))
-      (classify/let-like form
-			 binding-environment
-			 binding-environment
-			 body-environment
-			 history
-			 syntactic-binding-theory
-			 output/letrec))))
-
 (define (classify/let-like form
 			   value-environment
 			   binding-environment
 			   body-environment
-			   history
 			   binding-theory
 			   output/let)
   ;; Classify right-hand sides first, in order to catch references to
   ;; reserved names.  Then bind names prior to classifying body.
   (let* ((bindings
-	  (delete-matching-items!
-	      (map (lambda (binding item)
-		     (binding-theory binding-environment
-				     (car binding)
-				     item
-				     history))
-		   (cadr form)
-		   (select-map (lambda (binding selector)
-				 (classify/subexpression (cadr binding)
-							 value-environment
-							 history
-							 (selector/add-cadr
-							  selector)))
-			       (cadr form)
-			       select-cadr))
-	    null-binding-item?))
+	  (remove! null-binding-item?
+		   (map (lambda (binding item)
+			  (binding-theory binding-environment
+					  (car binding)
+					  item))
+			(cadr form)
+			(map (lambda (binding)
+			       (classify/expression (cadr binding)
+						    value-environment))
+			     (cadr form)))))
 	 (body
 	  (classify/body (cddr form)
 			 body-environment
-			 body-environment
-			 history
-			 select-cddr)))
+			 body-environment)))
     (if (eq? binding-theory syntactic-binding-theory)
 	body
-	(make-expression-item history
-	 (lambda ()
-	   (output/let (map binding-item/name bindings)
-		       (map (lambda (binding)
-			      (compile-item/expression
-			       (binding-item/value binding)))
-			    bindings)
-		       (compile-body-item body)))))))
-
-(define (expand/let* form rename let-keyword)
-  (capture-expansion-history
-   (lambda (history)
-     (syntax-check '(KEYWORD (* DATUM) + FORM) form history)
-     (let ((bindings (cadr form))
-	   (body (cddr form))
-	   (keyword (rename let-keyword)))
-       (if (pair? bindings)
-	   (let loop ((bindings bindings))
-	     (if (pair? (cdr bindings))
-		 `(,keyword (,(car bindings)) ,(loop (cdr bindings)))
-		 `(,keyword ,bindings ,@body)))
-	   `(,keyword ,bindings ,@body))))))
-
-;;;; Bodies
-
-(define (compile-body-item item)
-  (call-with-values
-      (lambda ()
-	(extract-declarations-from-body (body-item/components item)))
-    (lambda (declaration-items items)
-      (output/body (map declaration-item/text declaration-items)
-		   (compile-body-items item items)))))
-
-;;;; Derived syntax
-
-(define-er-macro-transformer 'AND system-global-environment
-  (lambda (form rename compare)
-    compare				;ignore
-    (capture-expansion-history
-     (lambda (history)
-       (syntax-check '(KEYWORD * EXPRESSION) form history)
-       (let ((operands (cdr form)))
-	 (if (pair? operands)
-	     (let ((if-keyword (rename 'IF)))
-	       (let loop ((operands operands))
-		 (if (pair? (cdr operands))
-		     `(,if-keyword ,(car operands)
-				   ,(loop (cdr operands))
-				   #F)
-		     (car operands))))
-	     `#T))))))
-
-(define-compiler 'OR system-global-environment
-  (lambda (form environment history)
-    (syntax-check '(KEYWORD * EXPRESSION) form history)
-    (if (pair? (cdr form))
-	(let loop ((expressions (cdr form)) (selector select-cdr))
-	  (let ((compiled
-		 (compile/subexpression (car expressions)
-					environment
-					history
-					(selector/add-car selector))))
-	    (if (pair? (cdr expressions))
-		(output/disjunction compiled
-				    (loop (cdr expressions)
-					  (selector/add-cdr selector)))
-		compiled)))
-	`#F)))
+	(make-expression-item
+	 (let ((names (map binding-item/name bindings))
+	       (values (map binding-item/value bindings)))
+	   (lambda ()
+	     (output/let names
+			 (map compile-item/expression values)
+			 (compile-body-item body))))))))
 
-(define-er-macro-transformer 'CASE system-global-environment
-  (lambda (form rename compare)
-    (capture-expansion-history
-     (lambda (history)
-       (syntax-check '(KEYWORD EXPRESSION + (DATUM * EXPRESSION)) form history)
-       (call-with-syntax-error-procedure
-	(lambda (syntax-error)
-	  (letrec
-	      ((process-clause
-		(lambda (clause rest)
-		  (cond ((null? (car clause))
-			 (process-rest rest))
-			((and (identifier? (car clause))
-			      (compare (rename 'ELSE) (car clause))
-			      (null? rest))
-			 `(,(rename 'BEGIN) ,@(cdr clause)))
-			((list? (car clause))
-			 `(,(rename 'IF) ,(process-predicate (car clause))
-					 (,(rename 'BEGIN) ,@(cdr clause))
-					 ,(process-rest rest)))
-			(else
-			 (syntax-error "Ill-formed clause:" clause)))))
-	       (process-rest
-		(lambda (rest)
-		  (if (pair? rest)
-		      (process-clause (car rest) (cdr rest))
-		      (unspecific-expression))))
-	       (process-predicate
-		(lambda (items)
-		  ;; Optimize predicate for speed in compiled code.
-		  (cond ((null? (cdr items))
-			 (single-test (car items)))
-			((null? (cddr items))
-			 `(,(rename 'OR) ,(single-test (car items))
-					 ,(single-test (cadr items))))
-			((null? (cdddr items))
-			 `(,(rename 'OR) ,(single-test (car items))
-					 ,(single-test (cadr items))
-					 ,(single-test (caddr items))))
-			((null? (cddddr items))
-			 `(,(rename 'OR) ,(single-test (car items))
-					 ,(single-test (cadr items))
-					 ,(single-test (caddr items))
-					 ,(single-test (cadddr items))))
-			(else
-			 `(,(rename
-			     (if (for-all? items eq-testable?) 'MEMQ 'MEMV))
-			   ,(rename 'TEMP)
-			   ',items)))))
-	       (single-test
-		(lambda (item)
-		  `(,(rename (if (eq-testable? item) 'EQ? 'EQV?))
-		    ,(rename 'TEMP)
-		    ',item)))
-	       (eq-testable?
-		(lambda (item)
-		  (or (symbol? item)
-		      (boolean? item)
-		      ;; remainder are implementation dependent:
-		      (char? item)	
-		      (fix:fixnum? item)))))
-	    `(,(rename 'LET) ((,(rename 'TEMP) ,(cadr form)))
-			     ,(process-clause (caddr form)
-					      (cdddr form))))))))))
-
-(define-er-macro-transformer 'COND system-global-environment
-  (lambda (form rename compare)
-    (capture-expansion-history
-     (lambda (history)
-       (let ((clauses (cdr form)))
-	 (if (not (pair? clauses))
-	     (syntax-error history "Form must have at least one clause:" form))
-	 (let loop ((clause (car clauses)) (rest (cdr clauses)))
-	   (expand/cond-clause clause rename compare history (null? rest)
-			       (if (pair? rest)
-				   (loop (car rest) (cdr rest))
-				   (unspecific-expression)))))))))
-
-(define-er-macro-transformer 'DO system-global-environment
-  (lambda (form rename compare)
-    (capture-expansion-history
-     (lambda (history)
-       (syntax-check '(KEYWORD (* (IDENTIFIER EXPRESSION ? EXPRESSION))
-			       (+ FORM)
-			       * FORM)
-		      form history)
-       (let ((bindings (cadr form))
-	     (r-loop (rename 'DO-LOOP)))
-	 `(,(rename 'LET)
-	   ,r-loop
-	   ,(map (lambda (binding)
-		   (list (car binding) (cadr binding)))
-		 bindings)
-	   ,(expand/cond-clause (caddr form) rename compare history #f
-				`(,(rename 'BEGIN)
-				  ,@(cdddr form)
-				  (,r-loop ,@(map (lambda (binding)
-						    (if (pair? (cddr binding))
-							(caddr binding)
-							(car binding)))
-						  bindings))))))))))
-
-(define (expand/cond-clause clause rename compare history else-allowed?
-			    alternative)
-  (if (not (and (pair? clause) (list? (cdr clause))))
-      (syntax-error history "Ill-formed clause:" clause))
-  (cond ((and (identifier? (car clause))
-	      (compare (rename 'ELSE) (car clause)))
-	 (if (not else-allowed?)
-	     (syntax-error history "Misplaced ELSE clause:" clause))
-	 (if (or (not (pair? (cdr clause)))
-		 (and (identifier? (cadr clause))
-		      (compare (rename '=>) (cadr clause))))
-	     (syntax-error history "Ill-formed ELSE clause:" clause))
-	 `(,(rename 'BEGIN) ,@(cdr clause)))
-	((not (pair? (cdr clause)))
-	 (let ((r-temp (rename 'TEMP)))
-	   `(,(rename 'LET) ((,r-temp ,(car clause)))
-			    (,(rename 'IF) ,r-temp ,r-temp ,alternative))))
-	((and (identifier? (cadr clause))
-	      (compare (rename '=>) (cadr clause)))
-	 (if (not (and (pair? (cddr clause))
-		       (null? (cdddr clause))))
-	     (syntax-error history "Ill-formed => clause:" clause))
-	 (let ((r-temp (rename 'TEMP)))
-	   `(,(rename 'LET) ((,r-temp ,(car clause)))
-			    (,(rename 'IF) ,r-temp
-					   (,(caddr clause) ,r-temp)
-					   ,alternative))))
-	(else
-	 `(,(rename 'IF) ,(car clause)
-			 (,(rename 'BEGIN) ,@(cdr clause))
-			 ,alternative))))
-
-(define-er-macro-transformer 'QUASIQUOTE system-global-environment
-  (lambda (form rename compare)
-    (call-with-syntax-error-procedure
-     (lambda (syntax-error)
-       (define (descend-quasiquote x level return)
-	 (cond ((pair? x) (descend-quasiquote-pair x level return))
-	       ((vector? x) (descend-quasiquote-vector x level return))
-	       (else (return 'QUOTE x))))
-       (define (descend-quasiquote-pair x level return)
-	 (cond ((not (and (pair? x)
-			  (identifier? (car x))
-			  (pair? (cdr x))
-			  (null? (cddr x))))
-		(descend-quasiquote-pair* x level return))
-	       ((compare (rename 'QUASIQUOTE) (car x))
-		(descend-quasiquote-pair* x (+ level 1) return))
-	       ((compare (rename 'UNQUOTE) (car x))
-		(if (zero? level)
-		    (return 'UNQUOTE (cadr x))
-		    (descend-quasiquote-pair* x (- level 1) return)))
-	       ((compare (rename 'UNQUOTE-SPLICING) (car x))
-		(if (zero? level)
-		    (return 'UNQUOTE-SPLICING (cadr x))
-		    (descend-quasiquote-pair* x (- level 1) return)))
-	       (else
-		(descend-quasiquote-pair* x level return))))
-       (define (descend-quasiquote-pair* x level return)
-	 (descend-quasiquote (car x) level
-	   (lambda (car-mode car-arg)
-	     (descend-quasiquote (cdr x) level
-	       (lambda (cdr-mode cdr-arg)
-		 (cond ((and (eq? car-mode 'QUOTE) (eq? cdr-mode 'QUOTE))
-			(return 'QUOTE x))
-		       ((eq? car-mode 'UNQUOTE-SPLICING)
-			(if (and (eq? cdr-mode 'QUOTE) (null? cdr-arg))
-			    (return 'UNQUOTE car-arg)
-			    (return 'APPEND
-				    (list car-arg
-					  (finalize-quasiquote cdr-mode
-							       cdr-arg)))))
-		       ((and (eq? cdr-mode 'QUOTE) (list? cdr-arg))
-			(return 'LIST
-				(cons (finalize-quasiquote car-mode car-arg)
-				      (map (lambda (element)
-					     (finalize-quasiquote 'QUOTE
-								  element))
-					   cdr-arg))))
-		       ((eq? cdr-mode 'LIST)
-			(return 'LIST
-				(cons (finalize-quasiquote car-mode car-arg)
-				      cdr-arg)))
-		       (else
-			(return
-			 'CONS
-			 (list (finalize-quasiquote car-mode car-arg)
-			       (finalize-quasiquote cdr-mode cdr-arg))))))))))
-       (define (descend-quasiquote-vector x level return)
-	 (descend-quasiquote (vector->list x) level
-	   (lambda (mode arg)
-	     (case mode
-	       ((QUOTE) (return 'QUOTE x))
-	       ((LIST) (return 'VECTOR arg))
-	       (else
-		(return 'LIST->VECTOR
-			(list (finalize-quasiquote mode arg))))))))
-       (define (finalize-quasiquote mode arg)
-	 (case mode
-	   ((QUOTE) `(,(rename 'QUOTE) ,arg))
-	   ((UNQUOTE) arg)
-	   ((UNQUOTE-SPLICING) (syntax-error ",@ in illegal context:" arg))
-	   (else `(,(rename mode) ,@arg))))
-       (capture-expansion-history
-	(lambda (history)
-	  (syntax-check '(KEYWORD EXPRESSION) form history)
-	  (descend-quasiquote (cadr form) 0 finalize-quasiquote)))))))
-
-;;;; SRFI 2: AND-LET*
-
-;;; The SRFI document is a little unclear about the semantics, imposes
-;;; the weird restriction that variables may be duplicated (citing
-;;; LET*'s similar restriction, which doesn't actually exist), and the
-;;; reference implementation is highly non-standard and hard to
-;;; follow.  This passes all of the tests except for the one that
-;;; detects duplicate bound variables, though.
-
-(define-er-macro-transformer 'AND-LET* system-global-environment
-  (lambda (form rename compare)
-    compare
-    (let ((%and (rename 'AND))
-          (%let (rename 'LET))
-          (%begin (rename 'BEGIN)))
-      (cond ((syntax-match? '(() * FORM) (cdr form))
-             `(,%begin #T ,@(cddr form)))
-            ((syntax-match? '((* DATUM) * FORM) (cdr form))
-             (let ((clauses (cadr form))
-                   (body (cddr form)))
-               (define (expand clause recur)
-                 (cond ((syntax-match? 'IDENTIFIER clause)
-                        (recur clause))
-                       ((syntax-match? '(EXPRESSION) clause)
-                        (recur (car clause)))
-                       ((syntax-match? '(IDENTIFIER EXPRESSION) clause)
-                        (let ((tail (recur (car clause))))
-                          (and tail `(,%let (,clause) ,tail))))
-                       (else #f)))
-               (define (recur clauses make-body)
-                 (expand (car clauses)
-                         (let ((clauses (cdr clauses)))
-                           (if (null? clauses)
-                               make-body
-                               (lambda (conjunct)
-                                 `(,%and ,conjunct
-                                         ,(recur clauses make-body)))))))
-               (or (recur clauses
-                          (if (null? body)
-                              (lambda (conjunct) conjunct)
-                              (lambda (conjunct)
-                                `(,%and ,conjunct (,%begin ,@body)))))
-                   (ill-formed-syntax form))))
-            (else
-             (ill-formed-syntax form))))))
+(define (compile-body-item item)
+  (receive (declaration-items items)
+      (extract-declarations-from-body (body-item/components item))
+    (output/body (map declaration-item/text declaration-items)
+		 (compile-body-items items))))
+
+;; TODO: this is a compiler rather than a macro because it uses the
+;; special OUTPUT/DISJUNCTION.  Unfortunately something downstream in
+;; the compiler wants this, but it would be nice to eliminate this
+;; hack.
+(define (compiler:or form environment)
+  (syntax-check '(KEYWORD * EXPRESSION) form)
+  (if (pair? (cdr form))
+      (let loop ((expressions (cdr form)))
+	(let ((compiled (compile/expression (car expressions) environment)))
+	  (if (pair? (cdr expressions))
+	      (output/disjunction compiled (loop (cdr expressions)))
+	      compiled)))
+      `#F))
 
 ;;;; MIT-specific syntax
 
-(define-er-macro-transformer 'ACCESS system-global-environment
-  (let ((keyword
-	 (classifier->keyword
-	  (lambda (form environment definition-environment history)
-	    definition-environment
-	    (make-access-item history
-			      (cadr form)
-			      (classify/subexpression (caddr form)
-						      environment
-						      history
-						      select-caddr))))))
-    (lambda (form rename compare)
-      rename compare			;ignore
-      (cond ((syntax-match? '(IDENTIFIER EXPRESSION) (cdr form))
-	     `(,keyword ,@(cdr form)))
-	    ((syntax-match? '(IDENTIFIER IDENTIFIER + FORM) (cdr form))
-	     `(,keyword ,(cadr form) (,(car form) ,@(cddr form))))
-	    (else
-	     (ill-formed-syntax form))))))
-
-(define <access-item>
-  (make-item-type "access-item" '(NAME ENVIRONMENT)
-    (lambda (item)
-      (output/access-reference
-       (access-item/name item)
-       (compile-item/expression (access-item/environment item))))))
-
-(define make-access-item
-  (item-constructor <access-item> '(NAME ENVIRONMENT)))
-
-(define access-item?
-  (item-predicate <access-item>))
-
-(define access-item/name
-  (item-accessor <access-item> 'NAME))
-
-(define access-item/environment
-  (item-accessor <access-item> 'ENVIRONMENT))
-
-(define-er-macro-transformer 'CONS-STREAM system-global-environment
-  (lambda (form rename compare)
-    compare				;ignore
-    (capture-expansion-history
-     (lambda (history)
-       (syntax-check '(KEYWORD EXPRESSION EXPRESSION) form history)
-       `(,(rename 'CONS) ,(cadr form)
-			 (,(rename 'DELAY) ,(caddr form)))))))
-
-(define-er-macro-transformer 'DEFINE-INTEGRABLE system-global-environment
-  (lambda (form rename compare)
-    compare				;ignore
-    (let ((r-declare (rename 'DECLARE)))
-      (cond ((syntax-match? '(IDENTIFIER EXPRESSION) (cdr form))
-	     `(,(rename 'BEGIN)
-	       (,r-declare (INTEGRATE ,(cadr form)))
-	       (,(rename 'DEFINE) ,@(cdr form))))
-	    ((syntax-match? '((IDENTIFIER * IDENTIFIER) + FORM) (cdr form))
-	     `(,(rename 'BEGIN)
-	       (,r-declare (INTEGRATE-OPERATOR ,(caadr form)))
-	       (,(rename 'DEFINE) ,(cadr form)
-				  (,r-declare (INTEGRATE ,@(cdadr form)))
-				  ,@(cddr form))))
-	    (else
-	     (ill-formed-syntax form))))))
-
-(define-er-macro-transformer 'FLUID-LET system-global-environment
-  (lambda (form rename compare)
-    compare
-    (capture-expansion-history
-     (lambda (history)
-       (syntax-check '(KEYWORD (* (FORM ? EXPRESSION)) + FORM)
-		     form history)
-       (let ((names (map car (cadr form)))
-	     (r-let (rename 'LET))
-	     (r-lambda (rename 'LAMBDA))
-	     (r-set! (rename 'SET!)))
-	 (let ((out-temps
-		(map (lambda (name)
-		       name
-		       (make-synthetic-identifier 'OUT-TEMP))
-		     names))
-	       (in-temps
-		(map (lambda (name)
-		       name
-		       (make-synthetic-identifier 'IN-TEMP))
-		     names))
-	       (swap
-		(lambda (tos names froms)
-		  `(,r-lambda ()
-			      ,@(map (lambda (to name from)
-				       `(,r-set! ,to
-						 (,r-set! ,name
-							  (,r-set! ,from))))
-				     tos
-				     names
-				     froms)
-			      ,(unspecific-expression)))))
-	   `(,r-let (,@(map cons in-temps (map cdr (cadr form)))
-		     ,@(map list out-temps))
-		    (,(rename 'SHALLOW-FLUID-BIND)
-		     ,(swap out-temps names in-temps)
-		     (,r-lambda () ,@(cddr form))
-		     ,(swap in-temps names out-temps)))))))))
-
-(define-compiler 'THE-ENVIRONMENT system-global-environment
-  (lambda (form environment history)
-    environment
-    (syntax-check '(KEYWORD) form history)
-    (if (not (syntactic-environment/top-level? environment))
-	(syntax-error history "This form allowed only at top level:" form))
-    (output/the-environment)))
-
-(define (unspecific-expression)
-  (compiler->form
-   (lambda (form environment history)
-     form environment history		;ignore
+(define-record-type <access-item>
+    (make-access-item name environment)
+    access-item?
+  (name access-item/name)
+  (environment access-item/environment))
+
+(define keyword:access
+  (classifier->keyword
+   (lambda (form environment definition-environment)
+     definition-environment
+     (make-access-item (cadr form)
+		       (classify/expression (caddr form) environment)))))
+
+(define-item-compiler <access-item>
+  (lambda (item)
+    (output/access-reference
+     (access-item/name item)
+     (compile-item/expression (access-item/environment item)))))
+
+(define (compiler:the-environment form environment)
+  environment
+  (syntax-check '(KEYWORD) form)
+  (if (not (syntactic-environment/top-level? environment))
+      (syntax-error "This form allowed only at top level:" form))
+  (output/the-environment))
+
+(define keyword:unspecific
+  (compiler->keyword
+   (lambda (form environment)
+     form environment			;ignore
      (output/unspecific))))
 
-(define (unassigned-expression)
-  (compiler->form
-   (lambda (form environment history)
-     form environment history		;ignore
+(define keyword:unassigned
+  (compiler->keyword
+   (lambda (form environment)
+     form environment			;ignore
      (output/unassigned))))
 
 ;;;; Declarations
 
-(define-classifier 'DECLARE system-global-environment
-  (lambda (form environment definition-environment history)
-    definition-environment
-    (syntax-check '(KEYWORD * (SYMBOL * DATUM)) form history)
-    (make-declaration-item history
-			   (lambda ()
-			     (map-declaration-references (cdr form)
-							 environment
-							 history
-							 select-cdr)))))
-
-(define-classifier 'LOCAL-DECLARE system-global-environment
-  (lambda (form environment definition-environment history)
-    (syntax-check '(KEYWORD (* (SYMBOL * DATUM)) + FORM) form history)
-    (let ((body
-	   (classify/body (cddr form)
-			  environment
-			  definition-environment
-			  history
-			  select-cddr)))
-      (make-expression-item history
-	(lambda ()
-	  (output/local-declare (map-declaration-references (cadr form)
-							    environment
-							    history
-							    select-cadr)
-				(compile-body-item body)))))))
-
-(define (map-declaration-references declarations environment history selector)
-  (select-map (lambda (declaration selector)
-		(process-declaration declaration selector
-		  (lambda (form selector)
-		    (classify/variable-subexpression form
-						     environment
-						     history
-						     selector))
-		  (lambda (declaration selector)
-		    (syntax-error (history/add-subproblem declaration
-							  environment
-							  history
-							  selector)
-				  "Ill-formed declaration:"
-				  declaration))))
-	      declarations
-	      selector))
-
-(define (classify/variable-subexpression form environment history selector)
-  (let ((item (classify/subexpression form environment history selector)))
+(define (classifier:declare form environment definition-environment)
+  definition-environment
+  (syntax-check '(KEYWORD * (SYMBOL * DATUM)) form)
+  (make-declaration-item
+   (lambda ()
+     (classify/declarations (cdr form) environment))))
+
+(define (classifier:local-declare form environment definition-environment)
+  (syntax-check '(KEYWORD (* (SYMBOL * DATUM)) + FORM) form)
+  (let ((body
+	 (classify/body (cddr form)
+			environment
+			definition-environment)))
+    (make-expression-item
+     (lambda ()
+       (output/local-declare (classify/declarations (cadr form) environment)
+			     (compile-body-item body))))))
+
+(define (classify/declarations declarations environment)
+  (map (lambda (declaration)
+	 (classify/declaration declaration environment))
+       declarations))
+
+(define (classify/declaration declaration environment)
+  (map-declaration-identifiers (lambda (identifier)
+				 (variable-item/name
+				  (classify/variable-reference identifier
+							       environment)))
+			       declaration))
+
+(define (classify/variable-reference identifier environment)
+  (let ((item (classify/expression identifier environment)))
     (if (not (variable-item? item))
-	(syntax-error history "Variable required in this context:" form))
-    (variable-item/name item)))
\ No newline at end of file
+	(syntax-error "Variable required in this context:" identifier))
+    item))
\ No newline at end of file
diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm
index 802b461f9..9adb7f580 100644
--- a/src/runtime/parse.scm
+++ b/src/runtime/parse.scm
@@ -523,20 +523,15 @@ USA.
     (cond ((string-ci=? name "null") '())
 	  ((string-ci=? name "false") #f)
 	  ((string-ci=? name "true") #t)
-	  ((string-ci=? name "optional") lambda-optional-tag)
-	  ((string-ci=? name "rest") lambda-rest-tag)
-	  ((string-ci=? name "key") lambda-key-tag)
-	  ((string-ci=? name "aux") lambda-aux-tag)
+	  ((string-ci=? name "optional") lambda-tag:optional)
+	  ((string-ci=? name "rest") lambda-tag:rest)
+	  ((string-ci=? name "key") lambda-tag:key)
+	  ((string-ci=? name "aux") lambda-tag:aux)
 	  ((string-ci=? name "eof") (eof-object))
 	  ((string-ci=? name "default") (default-object))
 	  ((string-ci=? name "unspecific") unspecific)
 	  (else (error:illegal-named-constant name)))))
 
-(define lambda-optional-tag (object-new-type (ucode-type constant) 3))
-(define lambda-rest-tag (object-new-type (ucode-type constant) 4))
-(define lambda-aux-tag (object-new-type (ucode-type constant) 8))
-(define lambda-key-tag (object-new-type (ucode-type constant) 5))
-
 (define (handler:special-arg port db ctx char1 char2)
   ctx char1
   (let loop ((n (char->digit char2 10)))
diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index fc9ec2f42..bd3b56f5c 100644
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -459,16 +459,9 @@ USA.
 					error?))))))
 
 (define (->type-name object)
-  (let* ((string
-	  (cond ((string? object) object)
-		((symbol? object) (symbol-name object))
-		(else (error:wrong-type-argument object "type name" #f))))
-	 (n (string-length string)))
-    (if (and (fix:> n 2)
-	     (char=? (string-ref string 0) #\<)
-	     (char=? (string-ref string (fix:- n 1)) #\>))
-	(substring string 1 (fix:- n 1))
-	string)))
+  (cond ((string? object) object)
+	((symbol? object) (symbol-name object))
+	(else (error:wrong-type-argument object "type name" #f))))
 
 (define (list-of-unique-symbols? object)
   (and (list-of-type? object symbol?)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 02c2b7f1e..efed5372a 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2388,6 +2388,21 @@ USA.
 	  weak-set-cdr!
 	  xcons))
 
+(define-package (runtime lambda-list)
+  (files "lambda-list")
+  (parent (runtime))
+  (export ()
+	  lambda-tag:aux
+	  lambda-tag:key
+	  lambda-tag:optional
+	  lambda-tag:rest
+	  map-mit-lambda-list
+	  map-r4rs-lambda-list
+	  mit-lambda-list?
+	  parse-mit-lambda-list
+	  parse-r4rs-lambda-list
+	  r4rs-lambda-list?))
+
 (define-package (runtime srfi-1)
   (files "srfi-1")
   (parent (runtime))
@@ -2726,21 +2741,10 @@ USA.
 	  (*parser-table* runtime-parser-table))
   (export (runtime character)
 	  char-set/atom-delimiters)
-  (export (runtime syntactic-closures)
-	  lambda-optional-tag
-	  lambda-rest-tag)
   (export (runtime unparser)
 	  char-set/atom-delimiters
 	  char-set/number-leaders
-	  char-set/symbol-quotes
-	  lambda-aux-tag
-	  lambda-key-tag
-	  lambda-optional-tag
-	  lambda-rest-tag)
-  (export (runtime unsyntaxer)
-	  lambda-aux-tag
-	  lambda-optional-tag
-	  lambda-rest-tag)
+	  char-set/symbol-quotes)
   (initialization (initialize-package!)))
 
 (define-package (runtime parser-table)
@@ -3087,7 +3091,7 @@ USA.
 	  unmapped-macro-reference-trap?
 	  unmapped-unassigned-reference-trap?
 	  unmapped-unbound-reference-trap?)
-  (export (runtime syntactic-closures)
+  (export (runtime syntax)
 	  make-macro-reference-trap-expression)
   (export (runtime unsyntaxer)
 	  macro-reference-trap-expression-transformer
@@ -4185,65 +4189,271 @@ USA.
 	  with-output-to-truncated-string)
   (initialization (initialize-package!)))
 
-(define-package (runtime syntactic-closures)
-  (files "syntactic-closures"
-	 "syntax-output"
-	 "syntax-transforms"
-	 "mit-syntax"
-	 "syntax-rules"
-	 "syntax-check")
-  (parent (runtime))
+(define-package (runtime syntax)
+  (files)
+  (parent (runtime)))
+
+(define-package (runtime syntax top-level)
+  (files "syntax")
+  (parent (runtime syntax))
   (export ()
 	  <syntactic-closure>
-	  call-with-syntax-error-procedure
 	  capture-syntactic-environment
 	  close-syntax
-	  er-macro-transformer->expander
-	  guarantee-syntactic-environment
+	  error:not-identifier
+	  error:not-syntactic-closure
+	  error:not-synthetic-identifier
+	  guarantee-identifier
+	  guarantee-syntactic-closure
+	  guarantee-synthetic-identifier
 	  identifier->symbol
 	  identifier=?
 	  identifier?
-	  ill-formed-syntax
-	  lambda-tag:fluid-let
-	  lambda-tag:let
-	  lambda-tag:unnamed
 	  make-syntactic-closure
 	  make-synthetic-identifier
-	  mit-lambda-list?
-	  non-hygienic-macro-transformer->expander
-	  parse-mit-lambda-list
-	  r4rs-lambda-list?
 	  reverse-syntactic-environments
-	  rsc-macro-transformer->expander
-	  sc-macro-transformer->expander
 	  strip-syntactic-closures
-	  supported-srfi-features
 	  syntactic-closure/environment
 	  syntactic-closure/form
 	  syntactic-closure/free-names
 	  syntactic-closure?
+	  syntax
+	  syntax*
+	  syntax-error
+	  synthetic-identifier?)
+  (export (runtime syntax)
+	  classifier->keyword
+	  compile/expression
+	  compiler->keyword
+	  lookup-identifier))
+
+(define-package (runtime syntax items)
+  (files "syntax-items")
+  (parent (runtime syntax))
+  (export (runtime syntax)
+	  <binding-item>
+	  <body-item>
+	  <classifier-item>
+	  <compiler-item>
+	  <declaration-item>
+	  <expander-item>
+	  <expression-item>
+	  <keyword-value-item>
+	  <null-binding-item>
+	  <reserved-name-item>
+	  <variable-item>
+	  binding-item/name
+	  binding-item/value
+	  binding-item?
+	  body-item/components
+	  classifier-item/classifier
+	  classifier-item?
+	  compiler-item/compiler
+	  compiler-item?
+	  declaration-item/text
+	  declaration-item?
+	  expander-item/expander
+	  expander-item?
+	  expression-item/compiler
+	  flatten-body-items
+	  item->list
+	  keyword-item?
+	  keyword-value-item/expression
+	  keyword-value-item/item
+	  keyword-value-item?
+	  make-binding-item
+	  make-body-item
+	  make-classifier-item
+	  make-compiler-item
+	  make-declaration-item
+	  make-expander-item
+	  make-expression-item
+	  make-keyword-value-item
+	  make-null-binding-item
+	  make-reserved-name-item
+	  make-variable-item
+	  null-binding-item?
+	  reserved-name-item?
+	  variable-item/name
+	  variable-item?))
+
+(define-package (runtime syntax environment)
+  (files "syntax-environment")
+  (parent (runtime syntax))
+  (export ()
+	  error:not-syntactic-environment
+	  guarantee-syntactic-environment
+	  syntactic-environment?)
+  (export (runtime syntax)
+	  bind-variable!
+	  make-internal-syntactic-environment
+	  make-partial-syntactic-environment
+	  make-top-level-syntactic-environment
+	  null-syntactic-environment
 	  syntactic-environment->environment
+	  syntactic-environment/define
 	  syntactic-environment/lookup
 	  syntactic-environment/top-level?
-	  syntactic-environment?
-	  syntactic-keyword->item
-	  syntax
-	  syntax*
+	  syntactic-environment?))
+
+(define-package (runtime syntax check)
+  (files "syntax-check")
+  (parent (runtime syntax))
+  (export ()
+	  ill-formed-syntax
+	  syntax-check
 	  syntax-match?
-	  synthetic-identifier?
-	  )
+	  syntax-match?*))
+
+(define-package (runtime syntax classify)
+  (files "syntax-classify")
+  (parent (runtime syntax))
+  (export (runtime syntax)
+	  classify/body
+	  classify/expression
+	  classify/form
+	  extract-declarations-from-body))
+
+(define-package (runtime syntax compile)
+  (files "syntax-compile")
+  (parent (runtime syntax))
+  (export (runtime syntax)
+	  compile-body-item/top-level
+	  compile-body-items
+	  compile-item/expression
+	  compile-item/expression
+	  define-item-compiler))
+
+(define-package (runtime syntax output)
+  (files "syntax-output")
+  (parent (runtime syntax))
+  (export ()
+	  lambda-tag:fluid-let
+	  lambda-tag:let
+	  lambda-tag:unnamed)
+  (export (runtime syntax)
+	  *rename-database*
+	  initial-rename-database
+	  make-name-generator
+	  make-rename-id
+	  output/access-assignment
+	  output/access-reference
+	  output/assignment
+	  output/body
+	  output/combination
+	  output/conditional
+	  output/constant
+	  output/definition
+	  output/delay
+	  output/disjunction
+	  output/lambda
+	  output/let
+	  output/letrec
+	  output/local-declare
+	  output/named-lambda
+	  output/post-process-expression
+	  output/runtime-reference
+	  output/sequence
+	  output/the-environment
+	  output/top-level-definition
+	  output/top-level-sequence
+	  output/top-level-syntax-definition
+	  output/unassigned
+	  output/unassigned-test
+	  output/unspecific
+	  output/variable
+	  rename-identifier
+	  rename-top-level-identifier
+	  transformer-eval))
+
+(define-package (runtime syntax declaration)
+  (files "syntax-declaration")
+  (parent (runtime syntax))
+  (export (runtime syntax)
+	  map-declaration-identifiers))
+
+(define-package (runtime syntax transforms)
+  (files "syntax-transforms")
+  (parent (runtime syntax))
+  (export ()
+	  er-macro-transformer->expander
+	  non-hygienic-macro-transformer->expander
+	  rsc-macro-transformer->expander
+	  sc-macro-transformer->expander
+	  syntactic-keyword->item))
+
+(define-package (runtime syntax mit)
+  (files "mit-syntax")
+  (parent (runtime syntax))
+  (export (runtime syntax definitions)
+	  classifier:begin
+	  classifier:declare
+	  classifier:define-syntax
+	  classifier:er-macro-transformer
+	  classifier:let-syntax
+	  classifier:letrec
+	  classifier:letrec-syntax
+	  classifier:local-declare
+	  classifier:non-hygienic-macro-transformer
+	  classifier:rsc-macro-transformer
+	  classifier:sc-macro-transformer
+	  compiler:delay
+	  compiler:if
+	  compiler:lambda
+	  compiler:named-lambda
+	  compiler:or
+	  compiler:quote
+	  compiler:set!
+	  compiler:the-environment)
+  (export (runtime mit-macros)
+	  keyword:access
+	  keyword:define
+	  keyword:let
+	  keyword:let-syntax
+	  keyword:unassigned
+	  keyword:unspecific))
+
+(define-package (runtime mit-macros)
+  (files "mit-macros")
+  (parent (runtime))
+  (export ()
+	  (access :access)
+	  (and :and)
+	  (and-let* :and-let*)
+	  (case :case)
+	  (cond :cond)
+	  (cond-expand :cond-expand)
+	  (cons-stream :cons-stream)
+	  (define :define)
+	  (define-integrable :define-integrable)
+	  (define-record-type :define-record-type)
+	  (do :do)
+	  (fluid-let :fluid-let)
+	  (let :let)
+	  (let* :let*)
+	  (let*-syntax :let*-syntax)
+	  (quasiquote :quasiquote)
+	  (receive :receive)
+	  supported-srfi-features)
   (export (runtime)
-	  parse-define-form)
-  (export (runtime defstruct)
-	  define-expander
-	  parse-mit-lambda-list))
+	  parse-define-form))
 
-(define-package (runtime defstruct)
+(define-package (runtime syntax syntax-rules)
+  (files "syntax-rules")
+  (parent (runtime syntax))
+  (export (runtime syntax definitions)
+	  er-macro-transformer:syntax-rules))
+
+(define-package (runtime syntax defstruct)
   (files "defstr")
-  (parent (runtime))
+  (parent (runtime syntax))
   (export ()
-	  ;;define-structure
-	  ))
+	  define-structure))
+
+(define-package (runtime syntax definitions)
+  (files "syntax-definitions")
+  (parent (runtime syntax))
+  (initialization (initialize-package!)))
 
 (define-package (runtime system-macros)
   (files "sysmac")
diff --git a/src/runtime/syntactic-closures.scm b/src/runtime/syntactic-closures.scm
deleted file mode 100644
index 4499712c5..000000000
--- a/src/runtime/syntactic-closures.scm
+++ /dev/null
@@ -1,1140 +0,0 @@
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
-    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-    2006, 2007, 2008, 2009 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Syntactic Closures
-;;;  Based on a design by Alan Bawden.
-
-;;; This is a two-stage program: the first stage classifies input
-;;; expressions into types, e.g. "definition", "lambda body",
-;;; "expression", etc., and the second stage compiles those classified
-;;; expressions ("items") into output code.  The classification stage
-;;; permits discovery of internal definitions prior to code
-;;; generation.  It also identifies keywords and variables, which
-;;; allows a powerful form of syntactic binding to be implemented.
-
-;;; See "Syntactic Closures", by Alan Bawden and Jonathan Rees, in
-;;; Proceedings of the 1988 ACM Conference on Lisp and Functional
-;;; Programming, page 86.
-
-(declare (usual-integrations))
-
-;;;; Compiler
-
-(define (syntax form environment)
-  (syntax* (list form) environment))
-
-(define (syntax* forms environment)
-  (if (not (list? forms))
-      (error:wrong-type-argument forms "list" 'SYNTAX*))
-  (guarantee-syntactic-environment environment 'SYNTAX*)
-  (fluid-let ((*rename-database* (initial-rename-database)))
-    (output/post-process-expression
-     (if (syntactic-environment/top-level? environment)
-	 (let ((environment
-		(make-top-level-syntactic-environment environment)))
-	   (compile-body-items/top-level
-	    (classify/body-forms forms
-				 environment
-				 environment
-				 (make-top-level-history forms environment)
-				 select-object)))
-	 (output/sequence
-	  (compile/expressions forms
-			       environment
-			       (make-top-level-history forms environment)))))))
-
-(define (compile-item/top-level item)
-  (if (binding-item? item)
-      (let ((name (binding-item/name item))
-	    (value (binding-item/value item)))
-	(if (keyword-value-item? value)
-	    (output/top-level-syntax-definition
-	     name
-	     (compile-item/expression (keyword-value-item/expression value)))
-	    (output/top-level-definition
-	     name
-	     (compile-item/expression value))))
-      (compile-item/expression item)))
-
-(define (compile-body-items/top-level body-items)
-  (call-with-values (lambda () (extract-declarations-from-body body-items))
-    (lambda (declaration-items body-items)
-      (output/top-level-sequence (map declaration-item/text declaration-items)
-				 (map compile-item/top-level body-items)))))
-
-(define (compile-item/expression item)
-  (if (not (item? item))
-      (error:wrong-type-argument item "item" 'COMPILE-ITEM/EXPRESSION))
-  (let ((compiler (get-item-compiler item)))
-    (if (not compiler)
-	(error:bad-range-argument item 'COMPILE-ITEM/EXPRESSION))
-    (compiler item)))
-
-(define (get-item-compiler item)
-  (let ((entry
-	 (assq (record-type-descriptor (item/record item)) item-compilers)))
-    (and entry
-	 (cdr entry))))
-
-(define (define-item-compiler rtd compiler)
-  (let ((entry (assq rtd item-compilers)))
-    (if entry
-	(set-cdr! entry compiler)
-	(begin
-	  (set! item-compilers (cons (cons rtd compiler) item-compilers))
-	  unspecific))))
-
-(define item-compilers '())
-
-(define (compile/expression expression environment history)
-  (compile-item/expression
-   (classify/expression expression environment history)))
-
-(define (compile/expressions expressions environment history)
-  (compile/subexpressions expressions environment history select-object))
-
-(define (compile/subexpression expression environment history selector)
-  (compile-item/expression
-   (classify/subexpression expression environment history selector)))
-
-(define (compile/subexpressions expressions environment history selector)
-  (select-map (lambda (expression selector)
-		(compile/subexpression expression
-				       environment
-				       history
-				       selector))
-	      expressions
-	      selector))
-
-;;;; Classifier
-
-(define (classify/form form environment definition-environment history)
-  (cond ((identifier? form)
-	 (let ((item
-		(item/new-history (lookup-identifier environment form)
-				  history)))
-	   (if (keyword-item? item)
-	       (make-keyword-ref-item (strip-keyword-value-item item)
-				      form
-				      history)
-	       item)))
-	((syntactic-closure? form)
-	 (let ((form (syntactic-closure/form form))
-	       (environment
-		(make-filtered-syntactic-environment
-		 (syntactic-closure/free-names form)
-		 environment
-		 (syntactic-closure/environment form))))
-	   (classify/form form
-			  environment
-			  definition-environment
-			  (history/replace-reduction form
-						     environment
-						     history))))
-	((pair? form)
-	 (let ((item
-		(strip-keyword-value-item
-		 (classify/subexpression (car form) environment history
-					 select-car))))
-	   (cond ((classifier-item? item)
-		  ((classifier-item/classifier item) form
-						     environment
-						     definition-environment
-						     history))
-		 ((compiler-item? item)
-		  (classify/compiler item form environment history))
-		 ((expander-item? item)
-		  (classify/expander item
-				     form
-				     environment
-				     definition-environment
-				     history))
-		 (else
-		  (if (not (list? (cdr form)))
-		      (syntax-error history
-				    "Combination must be a proper list:"
-				    form))
-		  (let ((items
-			 (classify/subexpressions (cdr form)
-						  environment
-						  history
-						  select-cdr)))
-		    (make-expression-item
-		     history
-		     (lambda ()
-		       (output/combination
-			(compile-item/expression item)
-			(map compile-item/expression items)))))))))
-	(else
-	 (make-expression-item history (lambda () (output/constant form))))))
-
-(define (classify/compiler item form environment history)
-  (make-expression-item history
-    (lambda ()
-      ((compiler-item/compiler item) form environment history))))
-
-(define (classify/expander item form environment definition-environment
-			   history)
-  (let ((form
-	 ((expander-item/expander item) form
-					environment
-					(expander-item/environment item))))
-    (classify/form form
-		   environment
-		   definition-environment
-		   (history/add-reduction form environment history))))
-
-(define (classify/subform form environment definition-environment
-			  history selector)
-  (classify/form form
-		 environment
-		 definition-environment
-		 (history/add-subproblem form environment history selector)))
-
-(define (classify/subforms forms environment definition-environment
-			   history selector)
-  (select-map (lambda (form selector)
-		(classify/subform form environment definition-environment
-				  history selector))
-	      forms
-	      selector))
-
-(define (classify/expression expression environment history)
-  (classify/form expression environment null-syntactic-environment history))
-
-(define (classify/subexpression expression environment history selector)
-  (classify/subform expression environment null-syntactic-environment
-		    history selector))
-
-(define (classify/subexpressions expressions environment history selector)
-  (classify/subforms expressions environment null-syntactic-environment
-		     history selector))
-
-(define (classify/body forms environment definition-environment history
-		       selector)
-  (make-body-item history
-		  (classify/body-forms forms
-				       environment
-				       definition-environment
-				       history
-				       selector)))
-
-(define (classify/body-forms forms environment definition-environment history
-			     selector)
-  ;; Top-level syntactic definitions affect all forms that appear
-  ;; after them, so classify FORMS in order.
-  (let forms-loop ((forms forms) (selector selector) (body-items '()))
-    (if (pair? forms)
-	(let items-loop
-	    ((items
-	      (item->list
-	       (classify/subform (car forms)
-				 environment
-				 definition-environment
-				 history
-				 (selector/add-car selector))))
-	     (body-items body-items))
-	  (if (pair? items)
-	      (items-loop (cdr items)
-			  (if (null-binding-item? (car items))
-			      body-items
-			      (cons (car items) body-items)))
-	      (forms-loop (cdr forms)
-			  (selector/add-cdr selector)
-			  body-items)))
-	(reverse! body-items))))
-
-(define (extract-declarations-from-body items)
-  (let loop ((items items) (declarations '()) (items* '()))
-    (if (pair? items)
-	(if (declaration-item? (car items))
-	    (loop (cdr items)
-		  (cons (car items) declarations)
-		  items*)
-	    (loop (cdr items)
-		  declarations
-		  (cons (car items) items*)))
-	(values (reverse! declarations) (reverse! items*)))))
-
-(define (strip-keyword-value-item item)
-  (if (keyword-value-item? item)
-      (keyword-value-item/item item)
-      item))
-
-;;;; Syntactic Closures
- 
-(define-record-type <syntactic-closure>
-    (%make-syntactic-closure environment free-names form)
-    syntactic-closure?
-  (environment syntactic-closure/environment)
-  (free-names syntactic-closure/free-names)
-  (form syntactic-closure/form))
-
-(define (make-syntactic-closure environment free-names form)
-  (guarantee-syntactic-environment environment 'MAKE-SYNTACTIC-CLOSURE)
-  (guarantee-list-of-type free-names identifier?
-			  "list of identifiers" 'MAKE-SYNTACTIC-CLOSURE)
-  (if (or (memq form free-names)	;LOOKUP-IDENTIFIER assumes this.
-	  (and (syntactic-closure? form)
-	       (null? (syntactic-closure/free-names form))
-	       (not (identifier? (syntactic-closure/form form))))
-	  (not (or (syntactic-closure? form)
-		   (pair? form)
-		   (symbol? form))))
-      form
-      (%make-syntactic-closure environment free-names form)))
-
-(define (strip-syntactic-closures object)
-  (if (let loop ((object object))
-	(if (pair? object)
-	    (or (loop (car object))
-		(loop (cdr object)))
-	    (syntactic-closure? object)))
-      (let loop ((object object))
-	(if (pair? object)
-	    (cons (loop (car object))
-		  (loop (cdr object)))
-	    (if (syntactic-closure? object)
-		(loop (syntactic-closure/form object))
-		object)))
-      object))
-
-(define (close-syntax form environment)
-  (make-syntactic-closure environment '() form))
-
-(define (identifier? object)
-  (or (symbol? object)
-      (synthetic-identifier? object)))
-
-(define (synthetic-identifier? object)
-  (and (syntactic-closure? object)
-       (identifier? (syntactic-closure/form object))))
-
-(define (make-synthetic-identifier identifier)
-  (close-syntax identifier null-syntactic-environment))
-
-(define (identifier->symbol identifier)
-  (or (let loop ((identifier identifier))
-	(if (syntactic-closure? identifier)
-	    (loop (syntactic-closure/form identifier))
-	    (and (symbol? identifier)
-		 identifier)))
-      (error:wrong-type-argument identifier "identifier" 'IDENTIFIER->SYMBOL)))
-
-(define (identifier=? environment-1 identifier-1 environment-2 identifier-2)
-  (let ((item-1 (lookup-identifier environment-1 identifier-1))
-	(item-2 (lookup-identifier environment-2 identifier-2)))
-    (or (item=? item-1 item-2)
-	;; This is necessary because an identifier that is not
-	;; explicitly bound by an environment is mapped to a variable
-	;; item, and the variable items are not cached.  Therefore
-	;; two references to the same variable result in two
-	;; different variable items.
-	(and (variable-item? item-1)
-	     (variable-item? item-2)
-	     (eq? (variable-item/name item-1)
-		  (variable-item/name item-2))))))
-
-;;;; Syntactic Environments
-
-(define (syntactic-environment? object)
-  (or (internal-syntactic-environment? object)
-      (top-level-syntactic-environment? object)
-      (environment? object)
-      (filtered-syntactic-environment? object)
-      (null-syntactic-environment? object)))
-
-(define (guarantee-syntactic-environment object name)
-  (if (not (syntactic-environment? object))
-      (error:wrong-type-argument object "syntactic environment" name)))
-
-(define (syntactic-environment/top-level? object)
-  (or (top-level-syntactic-environment? object)
-      (interpreter-environment? object)))
-
-(define (lookup-identifier environment identifier)
-  (let ((item (syntactic-environment/lookup environment identifier)))
-    (cond (item
-	   (if (reserved-name-item? item)
-	       (syntax-error (item/history item)
-			     "Premature reference to reserved name:"
-			     identifier)
-	       item))
-	  ((symbol? identifier)
-	   (make-variable-item identifier))
-	  ((syntactic-closure? identifier)
-	   (lookup-identifier (syntactic-closure/environment identifier)
-			      (syntactic-closure/form identifier)))
-	  (else
-	   (error:wrong-type-argument identifier "identifier"
-				      'LOOKUP-IDENTIFIER)))))
-
-(define (syntactic-environment/lookup environment name)
-  (cond ((internal-syntactic-environment? environment)
-	 (internal-syntactic-environment/lookup environment name))
-	((top-level-syntactic-environment? environment)
-	 (top-level-syntactic-environment/lookup environment name))
-	((environment? environment)
-	 (and (symbol? name)
-	      (environment/lookup environment name)))
-	((filtered-syntactic-environment? environment)
-	 (filtered-syntactic-environment/lookup environment name))
-	((null-syntactic-environment? environment)
-	 (null-syntactic-environment/lookup environment name))
-	(else
-	 (error:wrong-type-argument environment "syntactic environment"
-				    'SYNTACTIC-ENVIRONMENT/LOOKUP))))
-
-(define (syntactic-environment/define environment name item)
-  (cond ((internal-syntactic-environment? environment)
-	 (internal-syntactic-environment/define environment name item))
-	((top-level-syntactic-environment? environment)
-	 (top-level-syntactic-environment/define environment name item))
-	((environment? environment)
-	 (environment/define environment name item))
-	((filtered-syntactic-environment? environment)
-	 (filtered-syntactic-environment/define environment name item))
-	((null-syntactic-environment? environment)
-	 (null-syntactic-environment/define environment name item))
-	(else
-	 (error:wrong-type-argument environment "syntactic environment"
-				    'SYNTACTIC-ENVIRONMENT/DEFINE))))
-
-(define (syntactic-environment/rename environment name)
-  (cond ((internal-syntactic-environment? environment)
-	 (internal-syntactic-environment/rename environment name))
-	((top-level-syntactic-environment? environment)
-	 (top-level-syntactic-environment/rename environment name))
-	((environment? environment)
-	 (environment/rename environment name))
-	((filtered-syntactic-environment? environment)
-	 (filtered-syntactic-environment/rename environment name))
-	((null-syntactic-environment? environment)
-	 (null-syntactic-environment/rename environment name))
-	(else
-	 (error:wrong-type-argument environment "syntactic environment"
-				    'SYNTACTIC-ENVIRONMENT/RENAME))))
-
-(define (syntactic-environment->environment environment)
-  (cond ((internal-syntactic-environment? environment)
-	 (internal-syntactic-environment->environment environment))
-	((top-level-syntactic-environment? environment)
-	 (top-level-syntactic-environment->environment environment))
-	((environment? environment)
-	 environment)
-	((filtered-syntactic-environment? environment)
-	 (filtered-syntactic-environment->environment environment))
-	((null-syntactic-environment? environment)
-	 (null-syntactic-environment->environment environment))
-	(else
-	 (error:wrong-type-argument environment "syntactic environment"
-				    'SYNTACTIC-ENVIRONMENT->ENVIRONMENT))))
-
-;;; Null syntactic environments signal an error for any operation.
-;;; They are used as the definition environment for expressions (to
-;;; prevent illegal use of definitions) and to seal off environments
-;;; used in magic keywords.
-
-(define-record-type <null-syntactic-environment>
-    (%make-null-syntactic-environment)
-    null-syntactic-environment?)
-
-(define null-syntactic-environment
-  (%make-null-syntactic-environment))
-
-(define (null-syntactic-environment/lookup environment name)
-  environment
-  (error "Can't lookup name in null syntactic environment:" name))
-
-(define (null-syntactic-environment/define environment name item)
-  environment
-  (error "Can't bind name in null syntactic environment:" name item))
-
-(define (null-syntactic-environment/rename environment name)
-  environment
-  (error "Can't rename name in null syntactic environment:" name))
-
-(define (null-syntactic-environment->environment environment)
-  environment
-  (error "Can't evaluate in null syntactic environment."))
-
-;;; Runtime environments can be used to look up keywords, but can't be
-;;; modified.
-
-(define (environment/lookup environment name)
-  (let ((item (environment-lookup-macro environment name)))
-    (cond ((or (item? item) (not item))
-	   item)
-	  ;; **** Kludge to support bootstrapping.
-	  ((procedure? item)
-	   (non-hygienic-macro-transformer->expander item environment))
-	  (else
-	   (error:wrong-type-datum item "syntactic keyword")))))
-
-(define (environment/define environment name item)
-  (environment-define-macro environment name item))
-
-(define (environment/rename environment name)
-  environment
-  (rename-top-level-identifier name))
-
-;;; Top-level syntactic environments represent top-level environments.
-;;; They are always layered over a real syntactic environment.
-
-(define-record-type <top-level-syntactic-environment>
-    (%make-top-level-syntactic-environment parent bound)
-    top-level-syntactic-environment?
-  (parent top-level-syntactic-environment/parent)
-  (bound top-level-syntactic-environment/bound
-	 set-top-level-syntactic-environment/bound!))
-
-(define (make-top-level-syntactic-environment parent)
-  (guarantee-syntactic-environment parent
-				   'MAKE-TOP-LEVEL-SYNTACTIC-ENVIRONMENT)
-  (if (not (or (syntactic-environment/top-level? parent)
-	       (null-syntactic-environment? parent)))
-      (error:bad-range-argument parent "top-level syntactic environment"
-				'MAKE-TOP-LEVEL-SYNTACTIC-ENVIRONMENT))
-  (%make-top-level-syntactic-environment parent '()))
-
-(define (top-level-syntactic-environment/lookup environment name)
-  (let ((binding
-	 (assq name (top-level-syntactic-environment/bound environment))))
-    (if binding
-	(cdr binding)
-	(syntactic-environment/lookup
-	 (top-level-syntactic-environment/parent environment)
-	 name))))
-
-(define (top-level-syntactic-environment/define environment name item)
-  (let ((bound (top-level-syntactic-environment/bound environment)))
-    (let ((binding (assq name bound)))
-      (if binding
-	  (set-cdr! binding item)
-	  (set-top-level-syntactic-environment/bound!
-	   environment
-	   (cons (cons name item) bound))))))
-
-(define (top-level-syntactic-environment/rename environment name)
-  environment
-  (rename-top-level-identifier name))
-
-(define (top-level-syntactic-environment->environment environment)
-  (syntactic-environment->environment
-   (top-level-syntactic-environment/parent environment)))
-
-;;; Internal syntactic environments represent environments created by
-;;; procedure application.
-
-(define-record-type <internal-syntactic-environment>
-    (%make-internal-syntactic-environment parent bound free rename-state)
-    internal-syntactic-environment?
-  (parent internal-syntactic-environment/parent)
-  (bound internal-syntactic-environment/bound
-	 set-internal-syntactic-environment/bound!)
-  (free internal-syntactic-environment/free
-	set-internal-syntactic-environment/free!)
-  (rename-state internal-syntactic-environment/rename-state))
-
-(define (make-internal-syntactic-environment parent)
-  (guarantee-syntactic-environment parent 'MAKE-INTERNAL-SYNTACTIC-ENVIRONMENT)
-  (%make-internal-syntactic-environment parent '() '() (make-rename-id)))
-
-(define (internal-syntactic-environment/lookup environment name)
-  (let ((binding
-	 (or (assq name (internal-syntactic-environment/bound environment))
-	     (assq name (internal-syntactic-environment/free environment)))))
-    (if binding
-	(cdr binding)
-	(let ((item
-	       (syntactic-environment/lookup
-		(internal-syntactic-environment/parent environment)
-		name)))
-	  (set-internal-syntactic-environment/free!
-	   environment
-	   (cons (cons name item)
-		 (internal-syntactic-environment/free environment)))
-	  item))))
-
-(define (internal-syntactic-environment/define environment name item)
-  (cond ((assq name (internal-syntactic-environment/bound environment))
-	 => (lambda (binding)
-	      (set-cdr! binding item)))
-	((assq name (internal-syntactic-environment/free environment))
-	 (if (reserved-name-item? item)
-	     (syntax-error (item/history item)
-			   "Premature reference to reserved name:"
-			   name)
-	     (error "Can't define name; already free:" name)))
-	(else
-	 (set-internal-syntactic-environment/bound!
-	  environment
-	  (cons (cons name item)
-		(internal-syntactic-environment/bound environment))))))
-
-(define (internal-syntactic-environment/rename environment name)
-  (rename-identifier
-   name
-   (internal-syntactic-environment/rename-state environment)))
-
-(define (internal-syntactic-environment->environment environment)
-  (syntactic-environment->environment
-   (internal-syntactic-environment/parent environment)))
-
-;;; Filtered syntactic environments are used to implement syntactic
-;;; closures that have free names.
-
-(define-record-type <filtered-syntactic-environment>
-    (%make-filtered-syntactic-environment names
-					  names-environment
-					  else-environment)
-    filtered-syntactic-environment?
-  (names filtered-syntactic-environment/names)
-  (names-environment filtered-syntactic-environment/names-environment)
-  (else-environment filtered-syntactic-environment/else-environment))
-
-(define (make-filtered-syntactic-environment names
-					     names-environment
-					     else-environment)
-  (if (or (null? names)
-	  (eq? names-environment else-environment))
-      else-environment
-      (%make-filtered-syntactic-environment names
-					    names-environment
-					    else-environment)))
-
-(define (filtered-syntactic-environment/lookup environment name)
-  (syntactic-environment/lookup
-   (if (memq name (filtered-syntactic-environment/names environment))
-       (filtered-syntactic-environment/names-environment environment)
-       (filtered-syntactic-environment/else-environment environment))
-   name))
-
-(define (filtered-syntactic-environment/define environment name item)
-  ;; **** Shouldn't this be a syntax error?  It can happen as the
-  ;; result of a misplaced definition.  ****
-  (error "Can't bind name in filtered syntactic environment:"
-	 environment name item))
-
-(define (filtered-syntactic-environment/rename environment name)
-  (syntactic-environment/rename
-   (if (memq name (filtered-syntactic-environment/names environment))
-       (filtered-syntactic-environment/names-environment environment)
-       (filtered-syntactic-environment/else-environment environment))
-   name))
-
-(define (filtered-syntactic-environment->environment environment)
-  ;; **** Shouldn't this be a syntax error?  It can happen as the
-  ;; result of a partially-closed transformer.  ****
-  (error "Can't evaluate in filtered syntactic environment:" environment))
-
-;;;; Items
-
-;;; Some of the item code is in "syntax-transform.scm" because it is
-;;; needed during the cold load.
-
-(define item?
-  (record-predicate <item>))
-
-(define item/history
-  (record-accessor <item> 'HISTORY))
-
-(define (item/new-history item history)
-  (make-item history (item/record item)))
-
-(define item/record
-  (record-accessor <item> 'RECORD))
-
-(define (item=? x y)
-  (eq? (item/record x) (item/record y)))
-
-(define (make-item-type name fields compiler)
-  (let ((rtd (make-record-type name fields)))
-    (define-item-compiler rtd compiler)
-    rtd))
-
-(define (item-predicate rtd)
-  (let ((predicate (record-predicate rtd)))
-    (lambda (item)
-      (predicate (item/record item)))))
-
-(define (item-accessor rtd field)
-  (let ((accessor (record-accessor rtd field)))
-    (lambda (item)
-      (accessor (item/record item)))))
-
-(define (illegal-expression-item item description)
-  (let ((history (item/history item)))
-    (syntax-error history
-		  (string-append description
-				 " may not be used as an expression:")
-		  (history/original-form history))))
-
-;;; Reserved name items do not represent any form, but instead are
-;;; used to reserve a particular name in a syntactic environment.  If
-;;; the classifier refers to a reserved name, a syntax error is
-;;; signalled.  This is used in the implementation of LETREC-SYNTAX
-;;; to signal a meaningful error when one of the <init>s refers to
-;;; one of the names being bound.
-
-(define <reserved-name-item>
-  (make-item-type "reserved-name-item" '()
-    (lambda (item)
-      (illegal-expression-item item "Reserved name"))))
-
-(define make-reserved-name-item
-  (item-constructor <reserved-name-item> '()))
-
-(define reserved-name-item?
-  (item-predicate <reserved-name-item>))
-
-;;; Keyword items represent macro keywords.  There are several flavors
-;;; of keyword item.
-
-(define (keyword-item? item)
-  (or (classifier-item? item)
-      (compiler-item? item)
-      (expander-item? item)
-      (keyword-value-item? item)))
-
-(define (make-keyword-type name fields)
-  (make-item-type name fields keyword-item-compiler))
-
-(define (keyword-item-compiler item)
-  (illegal-expression-item item "Syntactic keyword"))
-
-
-(define <classifier-item>
-  (make-keyword-type "classifier-item" '(CLASSIFIER)))
-
-(define make-classifier-item
-  (keyword-constructor <classifier-item> '(CLASSIFIER)))
-
-(define classifier-item?
-  (item-predicate <classifier-item>))
-
-(define classifier-item/classifier
-  (item-accessor <classifier-item> 'CLASSIFIER))
-
-
-(define <compiler-item>
-  (make-keyword-type "compiler-item" '(COMPILER)))
-
-(define make-compiler-item
-  (keyword-constructor <compiler-item> '(COMPILER)))
-
-(define compiler-item?
-  (item-predicate <compiler-item>))
-
-(define compiler-item/compiler
-  (item-accessor <compiler-item> 'COMPILER))
-
-
-(define-item-compiler <expander-item>
-  keyword-item-compiler)
-
-(define expander-item?
-  (item-predicate <expander-item>))
-
-(define expander-item/expander
-  (item-accessor <expander-item> 'EXPANDER))
-
-(define expander-item/environment
-  (item-accessor <expander-item> 'ENVIRONMENT))
-
-
-(define <keyword-value-item>
-  (make-keyword-type "keyword-value-item" '(ITEM EXPRESSION)))
-
-(define make-keyword-value-item
-  (item-constructor <keyword-value-item> '(ITEM EXPRESSION)))
-
-(define keyword-value-item?
-  (item-predicate <keyword-value-item>))
-
-(define keyword-value-item/item
-  (item-accessor <keyword-value-item> 'ITEM))
-
-(define keyword-value-item/expression
-  (item-accessor <keyword-value-item> 'EXPRESSION))
-
-(define (make-keyword-ref-item item identifier history)
-  (make-keyword-value-item history item
-    (make-expression-item history
-      (let ((name (identifier->symbol identifier)))
-	(lambda ()
-	  (output/combination
-	   (output/access-reference 'SYNTACTIC-KEYWORD->ITEM
-				    system-global-environment)
-	   (list name (output/the-environment))))))))
-
-;;; Variable items represent run-time variables.
-
-(define <variable-item>
-  (make-item-type "variable-item" '(NAME)
-    (lambda (item)
-      (output/variable (variable-item/name item)))))
-
-(define make-variable-item
-  (let ((constructor (item-constructor <variable-item> '(NAME))))
-    (lambda (name)
-      (constructor #f name))))
-
-(define variable-item?
-  (item-predicate <variable-item>))
-
-(define variable-item/name
-  (item-accessor <variable-item> 'NAME))
-
-;;; Expression items represent any kind of expression other than a
-;;; run-time variable or a sequence.  The ANNOTATION field is used to
-;;; make expression items that can appear in non-expression contexts
-;;; (for example, this could be used in the implementation of SETF).
-
-(define <expression-item>
-  (make-item-type "expression-item" '(COMPILER ANNOTATION)
-    (lambda (item)
-      ((expression-item/compiler item)))))
-
-(define make-special-expression-item
-  (item-constructor <expression-item> '(COMPILER ANNOTATION)))
-
-(define expression-item?
-  (item-predicate <expression-item>))
-
-(define expression-item/compiler
-  (item-accessor <expression-item> 'COMPILER))
-
-(define expression-item/annotation
-  (item-accessor <expression-item> 'ANNOTATION))
-
-(define (make-expression-item history compiler)
-  (make-special-expression-item history compiler #f))
-
-;;; Unassigned items represent the right hand side of a binding that
-;;; has no explicit value.
-
-(define <unassigned-item>
-  (make-item-type "unassigned-item" '()
-    (lambda (item)
-      item				;ignore
-      (output/unassigned))))
-
-(define make-unassigned-item
-  (item-constructor <unassigned-item> '()))
-
-(define unassigned-item?
-  (item-predicate <unassigned-item>))
-
-;;; Declaration items represent block-scoped declarations that are to
-;;; be passed through to the compiler.
-
-(define <declaration-item>
-  (make-item-type "declaration-item" '(TEXT)
-    (lambda (item)
-      (illegal-expression-item item "Declaration"))))
-
-(define make-declaration-item
-  (item-constructor <declaration-item> '(TEXT)))
-
-(define declaration-item?
-  (item-predicate <declaration-item>))
-
-(define declaration-item/text
-  (let ((accessor (item-accessor <declaration-item> 'TEXT)))
-    (lambda (item)
-      ((accessor item)))))
-
-;;; Body items represent sequences (e.g. BEGIN).
-
-(define <body-item>
-  (make-item-type "body-item" '(COMPONENTS)
-    (lambda (item)
-      (compile-body-items item (body-item/components item)))))
-
-(define (compile-body-items item items)
-  (let ((items (flatten-body-items items)))
-    (if (not (pair? items))
-	(illegal-expression-item item "Empty sequence"))
-    (output/sequence
-     (map (lambda (item)
-	    (if (binding-item? item)
-		(let ((value (binding-item/value item)))
-		  (if (keyword-value-item? value)
-		      (output/sequence '())
-		      (output/definition (binding-item/name item)
-					 (compile-item/expression value))))
-		(compile-item/expression item)))
-	  items))))
-
-(define make-body-item
-  (item-constructor <body-item> '(COMPONENTS)))
-
-(define body-item?
-  (item-predicate <body-item>))
-
-(define body-item/components
-  (item-accessor <body-item> 'COMPONENTS))
-
-;;; Binding items represent definitions, whether top-level or
-;;; internal, keyword or variable.  Null binding items are for
-;;; definitions that don't emit code.
-
-(define <binding-item>
-  (make-item-type "binding-item" '(NAME VALUE)
-    (lambda (item)
-      (illegal-expression-item item "Definition"))))
-
-(define make-binding-item
-  (item-constructor <binding-item> '(NAME VALUE)))
-
-(define binding-item?
-  (item-predicate <binding-item>))
-
-(define binding-item/name
-  (item-accessor <binding-item> 'NAME))
-
-(define binding-item/value
-  (item-accessor <binding-item> 'VALUE))
-
-(define <null-binding-item>
-  (make-item-type "null-binding-item" '()
-    (lambda (item)
-      (illegal-expression-item item "Definition"))))
-
-(define make-null-binding-item
-  (item-constructor <null-binding-item> '()))
-
-(define null-binding-item?
-  (item-predicate <null-binding-item>))
-
-(define (bind-variable! environment name)
-  (let ((rename (syntactic-environment/rename environment name)))
-    (syntactic-environment/define environment
-				  name
-				  (make-variable-item rename))
-    rename))
-
-;;;; Expansion History
-;;;  This records each step of the expansion process, separating it
-;;;  into subproblems (really, subforms) and reductions.  The history
-;;;  is attached to the items that are the result of classification,
-;;;  so that meaningful debugging information is available after
-;;;  classification has been performed.  The history is NOT preserved
-;;;  by the compilation process, although it might be useful to
-;;;  extract a small part of the recorded information and store it in
-;;;  the output (for example, keeping track of what input form each
-;;;  output form corresponds to).
-
-;;;  Note: this abstraction could be implemented in a much simpler
-;;;  way, to reduce memory usage.  A history need not remember
-;;;  anything other than the original-form for the current reduction,
-;;;  plus a bit saying whether that original-form is also the current
-;;;  one (for replace-reduction).
-
-(define (make-top-level-history forms environment)
-  (list (list (cons forms environment))))
-
-(define (history/add-reduction form environment history)
-  (and history
-       (cons (cons (cons form environment)
-		   (car history))
-	     (cdr history))))
-
-(define (history/replace-reduction form environment history)
-  ;; This is like ADD-REDUCTION, but it discards the current reduction
-  ;; before adding a new one.  This is used when the current reduction
-  ;; is not interesting, such as when reducing a syntactic closure.
-  (and history
-       (cons (cons (cons form environment)
-		   (cdar history))
-	     (cdr history))))
-
-(define (history/add-subproblem form environment history selector)
-  (and history
-       (cons (list (cons form environment))
-	     (cons (cons selector (car history))
-		   (cdr history)))))
-
-(define (history/original-form history)
-  (and history
-       (caar (last-pair (car history)))))
-
-;;;; Selectors
-;;;  These are used by the expansion history to record subproblem
-;;;  nesting so that debugging tools can show that nesting usefully.
-;;;  By using abstract selectors, it is possible to locate the cell
-;;;  that holds the pointer to a given subform.
-
-(define (selector/apply selector object)
-  (if (pair? selector)
-      (selector/apply (cdr selector)
-		      (if (>= (car selector) 0)
-			  (list-ref object (car selector))
-			  (list-tail object (- (car selector)))))
-      object))
-
-(define (selector/add-car selector)
-  (if (and (pair? selector) (< (car selector) 0))
-      (cons (- (car selector)) (cdr selector))
-      (cons 0 selector)))
-
-(define (selector/add-cdr selector)
-  (if (and (pair? selector) (< (car selector) 0))
-      (cons (- (car selector) 1) (cdr selector))
-      (cons -1 selector)))
-
-(define select-object '())
-(define select-car (selector/add-car select-object))
-(define select-cdr (selector/add-cdr select-object))
-(define select-caar (selector/add-car select-car))
-(define select-cadr (selector/add-car select-cdr))
-(define select-cdar (selector/add-cdr select-car))
-(define select-cddr (selector/add-cdr select-cdr))
-(define select-caaar (selector/add-car select-caar))
-(define select-caadr (selector/add-car select-cadr))
-(define select-cadar (selector/add-car select-cdar))
-(define select-caddr (selector/add-car select-cddr))
-(define select-cdaar (selector/add-cdr select-caar))
-(define select-cdadr (selector/add-cdr select-cadr))
-(define select-cddar (selector/add-cdr select-cdar))
-(define select-cdddr (selector/add-cdr select-cddr))
-(define select-caaaar (selector/add-car select-caaar))
-(define select-caaadr (selector/add-car select-caadr))
-(define select-caadar (selector/add-car select-cadar))
-(define select-caaddr (selector/add-car select-caddr))
-(define select-cadaar (selector/add-car select-cdaar))
-(define select-cadadr (selector/add-car select-cdadr))
-(define select-caddar (selector/add-car select-cddar))
-(define select-cadddr (selector/add-car select-cdddr))
-(define select-cdaaar (selector/add-cdr select-caaar))
-(define select-cdaadr (selector/add-cdr select-caadr))
-(define select-cdadar (selector/add-cdr select-cadar))
-(define select-cdaddr (selector/add-cdr select-caddr))
-(define select-cddaar (selector/add-cdr select-cdaar))
-(define select-cddadr (selector/add-cdr select-cdadr))
-(define select-cdddar (selector/add-cdr select-cddar))
-(define select-cddddr (selector/add-cdr select-cdddr))
-
-(define (selector/add-cadr selector)
-  (selector/add-car (selector/add-cdr selector)))
-
-(define (selector/add-cddr selector)
-  (selector/add-cdr (selector/add-cdr selector)))
-
-(define (select-map procedure items selector)
-  (let loop ((items items) (selector selector))
-    (if (pair? items)
-	(cons (procedure (car items) (selector/add-car selector))
-	      (loop (cdr items) (selector/add-cdr selector)))
-	'())))
-
-(define (select-for-each procedure items selector)
-  (let loop ((items items) (selector selector))
-    (if (pair? items)
-	(begin
-	  (procedure (car items) (selector/add-car selector))
-	  (loop (cdr items) (selector/add-cdr selector))))))
-
-;;;; Utilities
-
-(define (define-classifier keyword environment classifier)
-  (syntactic-environment/define environment
-				keyword
-				(make-classifier-item classifier)))
-
-(define (define-compiler keyword environment compiler)
-  (syntactic-environment/define environment
-				keyword
-				(make-compiler-item compiler)))
-
-(define (define-expander keyword environment expander)
-  (syntactic-environment/define environment
-				keyword
-				(make-expander-item expander environment)))
-
-(define (classifier->keyword classifier)
-  (item->keyword (make-classifier-item classifier)))
-
-(define (compiler->keyword compiler)
-  (item->keyword (make-compiler-item compiler)))
-
-(define (expander->keyword expander environment)
-  (item->keyword (make-expander-item expander environment)))
-
-(define (item->keyword item)
-  (let ((environment
-	 (make-internal-syntactic-environment null-syntactic-environment)))
-    (syntactic-environment/define environment 'KEYWORD item)
-    (close-syntax 'KEYWORD environment)))
-
-(define (classifier->form classifier)
-  `(,(classifier->keyword classifier)))
-
-(define (compiler->form compiler)
-  `(,(compiler->keyword compiler)))
-
-(define (expander->form expander environment)
-  `(,(expander->keyword expander environment)))
-
-(define (capture-syntactic-environment expander)
-  (classifier->form
-   (lambda (form environment definition-environment history)
-     form				;ignore
-     (let ((form (expander environment)))
-       (classify/form form
-		      environment
-		      definition-environment
-		      (history/replace-reduction form environment history))))))
-
-(define (capture-expansion-history expander)
-  (classifier->form
-   (lambda (form environment definition-environment history)
-     form				;ignore
-     (let ((form (expander history)))
-       (classify/form form
-		      environment
-		      definition-environment
-		      (history/replace-reduction form environment history))))))
-
-(define (call-with-syntax-error-procedure expander)
-  (capture-expansion-history
-   (lambda (history)
-     (expander
-      (lambda rest
-	(apply syntax-error history rest))))))
-
-(define (flatten-body-items items)
-  (append-map item->list items))
-
-(define (item->list item)
-  (if (body-item? item)
-      (flatten-body-items (body-item/components item))
-      (list item)))
-
-(define (reverse-syntactic-environments environment procedure)
-  (capture-syntactic-environment
-   (lambda (closing-environment)
-     (close-syntax (procedure closing-environment) environment))))
\ No newline at end of file
diff --git a/src/runtime/syntax-check.scm b/src/runtime/syntax-check.scm
index d032689dd..77511e16f 100644
--- a/src/runtime/syntax-check.scm
+++ b/src/runtime/syntax-check.scm
@@ -28,14 +28,12 @@ USA.
 
 (declare (usual-integrations))
 
-(define (syntax-check pattern form history)
+(define (syntax-check pattern form)
   (if (not (syntax-match? (cdr pattern) (cdr form)))
-      (syntax-error history "Ill-formed special form:" form)))
+      (ill-formed-syntax form)))
 
 (define (ill-formed-syntax form)
-  (call-with-syntax-error-procedure
-   (lambda (syntax-error)
-     (syntax-error "Ill-formed special form:" form))))
+  (syntax-error "Ill-formed special form:" form))
 
 (define (syntax-match? pattern object)
   (let ((match-error
@@ -93,114 +91,8 @@ USA.
 		   (syntax-match? (cdr pattern) (cdr object))))))
 	  (else
 	   (eqv? pattern object)))))
-
-;;;; Lambda lists
-
-(define (r4rs-lambda-list? object)
-  (let loop ((object object) (seen '()))
-    (or (null? object)
-	(if (identifier? object)
-	    (not (memq object seen))
-	    (and (pair? object)
-		 (identifier? (car object))
-		 (not (memq (car object) seen))
-		 (loop (cdr object) (cons (car object) seen)))))))
-
-(define (mit-lambda-list? object)
-  (letrec
-      ((parse-required
-	(lambda (object seen)
-	  (or (null? object)
-	      (if (identifier? object)
-		  (not (memq object seen))
-		  (and (pair? object)
-		       (cond ((eq? (car object) lambda-optional-tag)
-			      (and (pair? (cdr object))
-				   (parse-parameter (cadr object) seen
-				     (lambda (seen)
-				       (parse-optional (cddr object) seen)))))
-			     ((eq? (car object) lambda-rest-tag)
-			      (parse-rest (cdr object) seen))
-			     (else
-			      (parse-parameter (car object) seen
-				(lambda (seen)
-				  (parse-required (cdr object) seen))))))))))
-       (parse-optional
-	(lambda (object seen)
-	  (or (null? object)
-	      (if (identifier? object)
-		  (not (memq object seen))
-		  (and (pair? object)
-		       (cond ((eq? (car object) lambda-optional-tag)
-			      #f)
-			     ((eq? (car object) lambda-rest-tag)
-			      (parse-rest (cdr object) seen))
-			     (else
-			      (parse-parameter (car object) seen
-				(lambda (seen)
-				  (parse-optional (cdr object) seen))))))))))
-       (parse-rest
-	(lambda (object seen)
-	  (and (pair? object)
-	       (parse-parameter (car object) seen
-		 (lambda (seen)
-		   seen
-		   (null? (cdr object)))))))
-       (parse-parameter
-	(lambda (object seen k)
-	  (if (identifier? object)
-	      (and (not (memq object seen))
-		   (k (cons object seen)))
-	      (and (pair? object)
-		   (identifier? (car object))
-		   (list? (cdr object))
-		   (not (memq (car object) seen))
-		   (k (cons (car object) seen)))))))
-    (parse-required object '())))
-
-(define (parse-mit-lambda-list lambda-list)
-  (let ((required (list '()))
-	(optional (list '())))
-    (define (parse-parameters cell pattern)
-      (let loop ((pattern pattern))
-	(cond ((null? pattern) (finish #f))
-	      ((identifier? pattern) (finish pattern))
-	      ((not (pair? pattern)) (bad-lambda-list pattern))
-	      ((eq? (car pattern) lambda-rest-tag)
-	       (if (and (pair? (cdr pattern)) (null? (cddr pattern)))
-		   (cond ((identifier? (cadr pattern)) (finish (cadr pattern)))
-			 ((and (pair? (cadr pattern))
-			       (identifier? (caadr pattern)))
-			  (finish (caadr pattern)))
-			 (else (bad-lambda-list (cdr pattern))))
-		   (bad-lambda-list (cdr pattern))))
-	      ((eq? (car pattern) lambda-optional-tag)
-	       (if (eq? cell required)
-		   (parse-parameters optional (cdr pattern))
-		   (bad-lambda-list pattern)))
-	      ((identifier? (car pattern))
-	       (set-car! cell (cons (car pattern) (car cell)))
-	       (loop (cdr pattern)))
-	      ((and (pair? (car pattern)) (identifier? (caar pattern)))
-	       (set-car! cell (cons (caar pattern) (car cell)))
-	       (loop (cdr pattern)))
-	      (else (bad-lambda-list pattern)))))
-
-    (define (finish rest)
-      (let ((required (reverse! (car required)))
-	    (optional (reverse! (car optional))))
-	(do ((parameters
-	      (append required optional (if rest (list rest) '()))
-	      (cdr parameters)))
-	    ((null? parameters))
-	  (if (memq (car parameters) (cdr parameters))
-	      (error "lambda list has duplicate parameter:"
-		     (car parameters)
-		     (error-irritant/noise " in")
-		     lambda-list)))
-	(values required optional rest)))
-
-    (define (bad-lambda-list pattern)
-      (error "Ill-formed lambda list:" pattern))
 
-    (parse-parameters required lambda-list)))
\ No newline at end of file
+(define (syntax-match?* patterns instance)
+  (any (lambda (pattern)
+	 (syntax-match? pattern instance))
+       patterns))
\ No newline at end of file
diff --git a/src/runtime/syntax-classify.scm b/src/runtime/syntax-classify.scm
new file mode 100644
index 000000000..0c296944c
--- /dev/null
+++ b/src/runtime/syntax-classify.scm
@@ -0,0 +1,130 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Syntax Classifier
+
+(declare (usual-integrations))
+
+(define (classify/form form environment definition-environment)
+  (cond ((identifier? form)
+	 (let ((item (lookup-identifier form environment)))
+	   (if (keyword-item? item)
+	       (make-keyword-value-item
+		(strip-keyword-value-item item)
+		(make-expression-item
+		 (let ((name (identifier->symbol form)))
+		   (lambda ()
+		     (output/combination
+		      (output/runtime-reference 'SYNTACTIC-KEYWORD->ITEM)
+		      (list (output/constant name)
+			    (output/the-environment)))))))
+	       item)))
+	((syntactic-closure? form)
+	 (let ((form (syntactic-closure/form form))
+	       (free-names (syntactic-closure/free-names form))
+	       (closing-env (syntactic-closure/environment form)))
+	   (classify/form form
+			  (make-partial-syntactic-environment free-names
+							      environment
+							      closing-env)
+			  definition-environment)))
+	((pair? form)
+	 (let ((item
+		(strip-keyword-value-item
+		 (classify/expression (car form) environment))))
+	   (cond ((classifier-item? item)
+		  ((classifier-item/classifier item) form
+						     environment
+						     definition-environment))
+		 ((compiler-item? item)
+		  (make-expression-item
+		   (let ((compiler (compiler-item/compiler item)))
+		     (lambda ()
+		       (compiler form environment)))))
+		 ((expander-item? item)
+		  (classify/form ((expander-item/expander item) form
+								environment)
+				 environment
+				 definition-environment))
+		 (else
+		  (if (not (list? (cdr form)))
+		      (syntax-error "Combination must be a proper list:" form))
+		  (make-expression-item
+		   (let ((items (classify/expressions (cdr form) environment)))
+		     (lambda ()
+		       (output/combination
+			(compile-item/expression item)
+			(map compile-item/expression items)))))))))
+	(else
+	 (make-expression-item (lambda () (output/constant form))))))
+
+(define (strip-keyword-value-item item)
+  (if (keyword-value-item? item)
+      (keyword-value-item/item item)
+      item))
+
+(define (classify/forms forms environment definition-environment)
+  (map (lambda (form)
+	 (classify/form form environment definition-environment))
+       forms))
+
+(define (classify/expression expression environment)
+  (classify/form expression environment null-syntactic-environment))
+
+(define (classify/expressions expressions environment)
+  (classify/forms expressions environment null-syntactic-environment))
+
+(define (classify/body forms environment definition-environment)
+  ;; Top-level syntactic definitions affect all forms that appear
+  ;; after them, so classify FORMS in order.
+  (make-body-item
+   (let forms-loop ((forms forms) (body-items '()))
+     (if (pair? forms)
+	 (let items-loop
+	     ((items
+	       (item->list
+		(classify/form (car forms)
+			       environment
+			       definition-environment)))
+	      (body-items body-items))
+	   (if (pair? items)
+	       (items-loop (cdr items)
+			   (if (null-binding-item? (car items))
+			       body-items
+			       (cons (car items) body-items)))
+	       (forms-loop (cdr forms) body-items)))
+	 (reverse! body-items)))))
+
+(define (extract-declarations-from-body items)
+  (let loop ((items items) (declarations '()) (items* '()))
+    (if (pair? items)
+	(if (declaration-item? (car items))
+	    (loop (cdr items)
+		  (cons (car items) declarations)
+		  items*)
+	    (loop (cdr items)
+		  declarations
+		  (cons (car items) items*)))
+	(values (reverse! declarations) (reverse! items*)))))
\ No newline at end of file
diff --git a/src/runtime/syntax-compile.scm b/src/runtime/syntax-compile.scm
new file mode 100644
index 000000000..73683e4e0
--- /dev/null
+++ b/src/runtime/syntax-compile.scm
@@ -0,0 +1,118 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Syntax Compiler
+
+(declare (usual-integrations))
+
+(define (compile-item/top-level item)
+  (if (binding-item? item)
+      (let ((name (binding-item/name item))
+	    (value (binding-item/value item)))
+	(if (keyword-value-item? value)
+	    (output/top-level-syntax-definition
+	     name
+	     (compile-item/expression (keyword-value-item/expression value)))
+	    (output/top-level-definition
+	     name
+	     (compile-item/expression value))))
+      (compile-item/expression item)))
+
+(define (compile-body-item/top-level body-item)
+  (receive (declaration-items body-items)
+      (extract-declarations-from-body (body-item/components body-item))
+    (output/top-level-sequence (map declaration-item/text declaration-items)
+			       (map compile-item/top-level body-items))))
+
+(define (compile-body-items items)
+  (let ((items (flatten-body-items items)))
+    (if (not (pair? items))
+	(syntax-error "Empty body"))
+    (output/sequence
+     (map (lambda (item)
+	    (if (binding-item? item)
+		(let ((value (binding-item/value item)))
+		  (if (keyword-value-item? value)
+		      (output/sequence '())
+		      (output/definition (binding-item/name item)
+					 (compile-item/expression value))))
+		(compile-item/expression item)))
+	  items))))
+
+(define (compile-item/expression item)
+  (let ((compiler (get-item-compiler item)))
+    (if (not compiler)
+	(error:bad-range-argument item 'COMPILE-ITEM/EXPRESSION))
+    (compiler item)))
+
+(define (get-item-compiler item)
+  (let ((entry (assq (record-type-descriptor item) item-compilers)))
+    (and entry
+	 (cdr entry))))
+
+(define (define-item-compiler rtd compiler)
+  (let ((entry (assq rtd item-compilers)))
+    (if entry
+	(set-cdr! entry compiler)
+	(begin
+	  (set! item-compilers (cons (cons rtd compiler) item-compilers))
+	  unspecific))))
+
+(define item-compilers '())
+
+(define (illegal-expression-compiler description)
+  (lambda (item)
+    (syntax-error (string description " may not be used as an expression:")
+		  item)))
+
+(define-item-compiler <reserved-name-item>
+  (illegal-expression-compiler "Reserved name"))
+
+(let ((compiler (illegal-expression-compiler "Syntactic keyword")))
+  (define-item-compiler <classifier-item> compiler)
+  (define-item-compiler <compiler-item> compiler)
+  (define-item-compiler <expander-item> compiler)
+  (define-item-compiler <keyword-value-item> compiler))
+
+(define-item-compiler <variable-item>
+  (lambda (item)
+    (output/variable (variable-item/name item))))
+
+(define-item-compiler <expression-item>
+  (lambda (item)
+    ((expression-item/compiler item))))
+
+(define-item-compiler <body-item>
+  (lambda (item)
+    (compile-body-items (body-item/components item))))
+
+(define-item-compiler <declaration-item>
+  (illegal-expression-compiler "Declaration"))
+
+(define-item-compiler <binding-item>
+  (illegal-expression-compiler "Definition"))
+
+(define-item-compiler <null-binding-item>
+  (illegal-expression-compiler "Definition"))
\ No newline at end of file
diff --git a/src/runtime/syntax-declaration.scm b/src/runtime/syntax-declaration.scm
new file mode 100644
index 000000000..fc2c2eeac
--- /dev/null
+++ b/src/runtime/syntax-declaration.scm
@@ -0,0 +1,146 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Declarations
+
+(declare (usual-integrations))
+
+(define (define-declaration name pattern mapper)
+  (let ((entry (assq name known-declarations)))
+    (if entry
+	(set-cdr! entry (cons pattern mapper))
+	(begin
+	  (set! known-declarations
+		(cons (cons name (cons pattern mapper))
+		      known-declarations))
+	  unspecific))))
+
+(define (map-declaration-identifiers procedure declaration)
+  (if (not (pair? declaration))
+      (error "Ill-formed declaration:" declaration))
+  (let ((entry (assq (car declaration) known-declarations)))
+    (if (and entry (syntax-match? (cadr entry) (cdr declaration)))
+	((cddr entry) declaration procedure)
+	(begin
+	  (warn "Unknown declaration:" declaration)
+	  declaration))))
+
+(define known-declarations '())
+
+(for-each (lambda (keyword)
+	    (define-declaration keyword '()
+	      (lambda (declaration procedure)
+		procedure
+		declaration)))
+	  '(AUTOMAGIC-INTEGRATIONS
+	    NO-AUTOMAGIC-INTEGRATIONS
+	    ETA-SUBSTITUTION
+	    NO-ETA-SUBSTITUTION
+	    OPEN-BLOCK-OPTIMIZATIONS
+	    NO-OPEN-BLOCK-OPTIMIZATIONS))
+
+(for-each (lambda (keyword)
+	    (define-declaration keyword '(* IDENTIFIER)
+	      (lambda (declaration procedure)
+		(cons (car declaration)
+		      (map procedure (cdr declaration))))))
+	  ;; The names in USUAL-INTEGRATIONS are always global.
+	  '(
+	    USUAL-INTEGRATIONS
+	    INTEGRATE
+	    INTEGRATE-OPERATOR
+	    INTEGRATE-SAFELY
+	    IGNORE
+	    TYPE-CHECKS
+	    NO-TYPE-CHECKS
+	    RANGE-CHECKS
+	    NO-RANGE-CHECKS
+	    ))
+
+(define-declaration 'INTEGRATE-EXTERNAL
+  `(* ,(lambda (object)
+	 (or (string? object)
+	     (pathname? object))))
+  (lambda (declaration procedure)
+    procedure
+    declaration))
+
+(for-each
+ (lambda (keyword)
+   (define-declaration keyword '(DATUM)
+     (lambda (declaration procedure)
+       (list (car declaration)
+	     (let loop ((varset (cadr declaration)))
+	       (cond ((syntax-match? '('SET * IDENTIFIER) varset)
+		      (cons (car varset)
+			    (map procedure (cdr varset))))
+		     ((syntax-match?* '(('UNION * DATUM)
+					('INTERSECTION * DATUM)
+					('DIFFERENCE DATUM DATUM))
+				      varset)
+		      (cons (car varset)
+			    (map loop (cdr varset))))
+		     (else varset)))))))
+ '(CONSTANT
+   IGNORE-ASSIGNMENT-TRAPS
+   IGNORE-REFERENCE-TRAPS
+   PURE-FUNCTION
+   SIDE-EFFECT-FREE
+   USUAL-DEFINITION
+   UUO-LINK))
+
+(define-declaration 'REPLACE-OPERATOR '(* (IDENTIFIER * (DATUM DATUM)))
+  (lambda (declaration procedure)
+    (cons (car declaration)
+	  (map (lambda (rule)
+		 (cons (procedure (car rule))
+		       (map (lambda (clause)
+			      (list (car clause)
+				    (if (identifier? (cadr clause))
+					(procedure (cadr clause))
+					(cadr clause))))
+			    (cdr rule))))
+	       (cdr declaration)))))
+
+(define-declaration 'REDUCE-OPERATOR '(* (IDENTIFIER DATUM * DATUM))
+  (lambda (declaration procedure)
+    (cons (car declaration)
+	  (map (lambda (rule)
+		 (cons* (procedure (car rule))
+			(if (identifier? (cadr rule))
+			    (procedure (cadr rule))
+			    (cadr rule))
+			(map (lambda (clause)
+			       (if (syntax-match?*
+				    '(('NULL-VALUE IDENTIFIER DATUM)
+				      ('SINGLETON IDENTIFIER)
+				      ('WRAPPER IDENTIFIER ? DATUM))
+				    clause)
+				   (cons* (car clause)
+					  (procedure (cadr clause))
+					  (cddr clause))
+				   clause))
+			     (cddr rule))))
+	       (cdr declaration)))))
\ No newline at end of file
diff --git a/src/runtime/syntax-definitions.scm b/src/runtime/syntax-definitions.scm
new file mode 100644
index 000000000..cdda78df7
--- /dev/null
+++ b/src/runtime/syntax-definitions.scm
@@ -0,0 +1,64 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Code to install syntax keywords in global environment
+
+(declare (usual-integrations))
+
+(define (initialize-package!)
+  (create-bindings system-global-environment))
+
+(define (create-bindings environment)
+
+  (define (def name item)
+    (syntactic-environment/define environment name item))
+
+  (define (define-classifier name classifier)
+    (def name (make-classifier-item classifier)))
+
+  (define-classifier 'BEGIN classifier:begin)
+  (define-classifier 'DECLARE classifier:declare)
+  (define-classifier 'DEFINE-SYNTAX classifier:define-syntax)
+  (define-classifier 'ER-MACRO-TRANSFORMER classifier:er-macro-transformer)
+  (define-classifier 'LET-SYNTAX classifier:let-syntax)
+  (define-classifier 'LETREC classifier:letrec)
+  (define-classifier 'LETREC-SYNTAX classifier:letrec-syntax)
+  (define-classifier 'LOCAL-DECLARE classifier:local-declare)
+  (define-classifier 'NON-HYGIENIC-MACRO-TRANSFORMER
+    classifier:non-hygienic-macro-transformer)
+  (define-classifier 'RSC-MACRO-TRANSFORMER classifier:rsc-macro-transformer)
+  (define-classifier 'SC-MACRO-TRANSFORMER classifier:sc-macro-transformer)
+
+  (define (define-compiler name compiler)
+    (def name (make-compiler-item compiler)))
+
+  (define-compiler 'DELAY compiler:delay)
+  (define-compiler 'IF compiler:if)
+  (define-compiler 'LAMBDA compiler:lambda)
+  (define-compiler 'NAMED-LAMBDA compiler:named-lambda)
+  (define-compiler 'OR compiler:or)
+  (define-compiler 'QUOTE compiler:quote)
+  (define-compiler 'SET! compiler:set!)
+  (define-compiler 'THE-ENVIRONMENT compiler:the-environment))
\ No newline at end of file
diff --git a/src/runtime/syntax-environment.scm b/src/runtime/syntax-environment.scm
new file mode 100644
index 000000000..b1b4d964f
--- /dev/null
+++ b/src/runtime/syntax-environment.scm
@@ -0,0 +1,303 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Syntactic Environments
+
+(declare (usual-integrations))
+
+(define (syntactic-environment? object)
+  (or (internal-syntactic-environment? object)
+      (top-level-syntactic-environment? object)
+      (environment? object)
+      (partial-syntactic-environment? object)
+      (null-syntactic-environment? object)))
+
+(define-guarantee syntactic-environment "syntactic environment")
+
+(define (syntactic-environment/top-level? object)
+  (or (top-level-syntactic-environment? object)
+      (interpreter-environment? object)))
+
+(define (syntactic-environment/lookup environment name)
+  (cond ((internal-syntactic-environment? environment)
+	 (internal-syntactic-environment/lookup environment name))
+	((top-level-syntactic-environment? environment)
+	 (top-level-syntactic-environment/lookup environment name))
+	((environment? environment)
+	 (and (symbol? name)
+	      (environment/lookup environment name)))
+	((partial-syntactic-environment? environment)
+	 (partial-syntactic-environment/lookup environment name))
+	((null-syntactic-environment? environment)
+	 (null-syntactic-environment/lookup environment name))
+	(else
+	 (error:not-syntactic-environment environment
+					  'SYNTACTIC-ENVIRONMENT/LOOKUP))))
+
+(define (syntactic-environment/define environment name item)
+  (cond ((internal-syntactic-environment? environment)
+	 (internal-syntactic-environment/define environment name item))
+	((top-level-syntactic-environment? environment)
+	 (top-level-syntactic-environment/define environment name item))
+	((environment? environment)
+	 (environment/define environment name item))
+	((partial-syntactic-environment? environment)
+	 (partial-syntactic-environment/define environment name item))
+	((null-syntactic-environment? environment)
+	 (null-syntactic-environment/define environment name item))
+	(else
+	 (error:not-syntactic-environment environment
+					  'SYNTACTIC-ENVIRONMENT/DEFINE))))
+
+(define (syntactic-environment/rename environment name)
+  (cond ((internal-syntactic-environment? environment)
+	 (internal-syntactic-environment/rename environment name))
+	((top-level-syntactic-environment? environment)
+	 (top-level-syntactic-environment/rename environment name))
+	((environment? environment)
+	 (environment/rename environment name))
+	((partial-syntactic-environment? environment)
+	 (partial-syntactic-environment/rename environment name))
+	((null-syntactic-environment? environment)
+	 (null-syntactic-environment/rename environment name))
+	(else
+	 (error:not-syntactic-environment environment
+					  'SYNTACTIC-ENVIRONMENT/RENAME))))
+
+(define (syntactic-environment->environment environment)
+  (cond ((internal-syntactic-environment? environment)
+	 (internal-syntactic-environment->environment environment))
+	((top-level-syntactic-environment? environment)
+	 (top-level-syntactic-environment->environment environment))
+	((environment? environment)
+	 environment)
+	((partial-syntactic-environment? environment)
+	 (partial-syntactic-environment->environment environment))
+	((null-syntactic-environment? environment)
+	 (null-syntactic-environment->environment environment))
+	(else
+	 (error:not-syntactic-environment
+	  environment
+	  'SYNTACTIC-ENVIRONMENT->ENVIRONMENT))))
+
+(define (bind-variable! environment name)
+  (let ((rename (syntactic-environment/rename environment name)))
+    (syntactic-environment/define environment
+				  name
+				  (make-variable-item rename))
+    rename))
+
+;;; Null syntactic environments signal an error for any operation.
+;;; They are used as the definition environment for expressions (to
+;;; prevent illegal use of definitions) and to seal off environments
+;;; used in magic keywords.
+
+(define-record-type <null-syntactic-environment>
+    (%make-null-syntactic-environment)
+    null-syntactic-environment?)
+
+(define null-syntactic-environment
+  (%make-null-syntactic-environment))
+
+(define (null-syntactic-environment/lookup environment name)
+  environment
+  (error "Can't lookup name in null syntactic environment:" name))
+
+(define (null-syntactic-environment/define environment name item)
+  environment
+  (error "Can't bind name in null syntactic environment:" name item))
+
+(define (null-syntactic-environment/rename environment name)
+  environment
+  (error "Can't rename name in null syntactic environment:" name))
+
+(define (null-syntactic-environment->environment environment)
+  environment
+  (error "Can't evaluate in null syntactic environment."))
+
+;;; Runtime environments can be used to look up keywords, but can't be
+;;; modified.
+
+(define (environment/lookup environment name)
+  (let ((item (environment-lookup-macro environment name)))
+    (if (procedure? item)
+	;; **** Kludge to support bootstrapping.
+	(non-hygienic-macro-transformer->expander item environment)
+	item)))
+
+(define (environment/define environment name item)
+  (environment-define-macro environment name item))
+
+(define (environment/rename environment name)
+  environment
+  (rename-top-level-identifier name))
+
+;;; Top-level syntactic environments represent top-level environments.
+;;; They are always layered over a real syntactic environment.
+
+(define-record-type <top-level-syntactic-environment>
+    (%make-top-level-syntactic-environment parent bound)
+    top-level-syntactic-environment?
+  (parent top-level-syntactic-environment/parent)
+  (bound top-level-syntactic-environment/bound
+	 set-top-level-syntactic-environment/bound!))
+
+(define (make-top-level-syntactic-environment parent)
+  (guarantee-syntactic-environment parent
+				   'MAKE-TOP-LEVEL-SYNTACTIC-ENVIRONMENT)
+  (if (not (or (syntactic-environment/top-level? parent)
+	       (null-syntactic-environment? parent)))
+      (error:bad-range-argument parent "top-level syntactic environment"
+				'MAKE-TOP-LEVEL-SYNTACTIC-ENVIRONMENT))
+  (%make-top-level-syntactic-environment parent '()))
+
+(define (top-level-syntactic-environment/lookup environment name)
+  (let ((binding
+	 (assq name (top-level-syntactic-environment/bound environment))))
+    (if binding
+	(cdr binding)
+	(syntactic-environment/lookup
+	 (top-level-syntactic-environment/parent environment)
+	 name))))
+
+(define (top-level-syntactic-environment/define environment name item)
+  (let ((bound (top-level-syntactic-environment/bound environment)))
+    (let ((binding (assq name bound)))
+      (if binding
+	  (set-cdr! binding item)
+	  (set-top-level-syntactic-environment/bound!
+	   environment
+	   (cons (cons name item) bound))))))
+
+(define (top-level-syntactic-environment/rename environment name)
+  environment
+  (rename-top-level-identifier name))
+
+(define (top-level-syntactic-environment->environment environment)
+  (syntactic-environment->environment
+   (top-level-syntactic-environment/parent environment)))
+
+;;; Internal syntactic environments represent environments created by
+;;; procedure application.
+
+(define-record-type <internal-syntactic-environment>
+    (%make-internal-syntactic-environment parent bound free rename-state)
+    internal-syntactic-environment?
+  (parent internal-syntactic-environment/parent)
+  (bound internal-syntactic-environment/bound
+	 set-internal-syntactic-environment/bound!)
+  (free internal-syntactic-environment/free
+	set-internal-syntactic-environment/free!)
+  (rename-state internal-syntactic-environment/rename-state))
+
+(define (make-internal-syntactic-environment parent)
+  (guarantee-syntactic-environment parent 'MAKE-INTERNAL-SYNTACTIC-ENVIRONMENT)
+  (%make-internal-syntactic-environment parent '() '() (make-rename-id)))
+
+(define (internal-syntactic-environment/lookup environment name)
+  (let ((binding
+	 (or (assq name (internal-syntactic-environment/bound environment))
+	     (assq name (internal-syntactic-environment/free environment)))))
+    (if binding
+	(cdr binding)
+	(let ((item
+	       (syntactic-environment/lookup
+		(internal-syntactic-environment/parent environment)
+		name)))
+	  (set-internal-syntactic-environment/free!
+	   environment
+	   (cons (cons name item)
+		 (internal-syntactic-environment/free environment)))
+	  item))))
+
+(define (internal-syntactic-environment/define environment name item)
+  (cond ((assq name (internal-syntactic-environment/bound environment))
+	 => (lambda (binding)
+	      (set-cdr! binding item)))
+	((assq name (internal-syntactic-environment/free environment))
+	 (if (reserved-name-item? item)
+	     (syntax-error "Premature reference to reserved name:" name)
+	     (error "Can't define name; already free:" name)))
+	(else
+	 (set-internal-syntactic-environment/bound!
+	  environment
+	  (cons (cons name item)
+		(internal-syntactic-environment/bound environment))))))
+
+(define (internal-syntactic-environment/rename environment name)
+  (rename-identifier
+   name
+   (internal-syntactic-environment/rename-state environment)))
+
+(define (internal-syntactic-environment->environment environment)
+  (syntactic-environment->environment
+   (internal-syntactic-environment/parent environment)))
+
+;;; Partial syntactic environments are used to implement syntactic
+;;; closures that have free names.
+
+(define-record-type <partial-syntactic-environment>
+    (%make-partial-syntactic-environment names
+					 names-environment
+					 else-environment)
+    partial-syntactic-environment?
+  (names partial-syntactic-environment/names)
+  (names-environment partial-syntactic-environment/names-environment)
+  (else-environment partial-syntactic-environment/else-environment))
+
+(define (make-partial-syntactic-environment names
+					    names-environment
+					    else-environment)
+  (if (or (null? names)
+	  (eq? names-environment else-environment))
+      else-environment
+      (%make-partial-syntactic-environment names
+					   names-environment
+					   else-environment)))
+
+(define (partial-syntactic-environment/lookup environment name)
+  (syntactic-environment/lookup
+   (if (memq name (partial-syntactic-environment/names environment))
+       (partial-syntactic-environment/names-environment environment)
+       (partial-syntactic-environment/else-environment environment))
+   name))
+
+(define (partial-syntactic-environment/define environment name item)
+  ;; **** Shouldn't this be a syntax error?  It can happen as the
+  ;; result of a misplaced definition.  ****
+  (error "Can't bind name in partial syntactic environment:"
+	 environment name item))
+
+(define (partial-syntactic-environment/rename environment name)
+  (syntactic-environment/rename
+   (if (memq name (partial-syntactic-environment/names environment))
+       (partial-syntactic-environment/names-environment environment)
+       (partial-syntactic-environment/else-environment environment))
+   name))
+
+(define (partial-syntactic-environment->environment environment)
+  ;; **** Shouldn't this be a syntax error?  It can happen as the
+  ;; result of a partially-closed transformer.  ****
+  (error "Can't evaluate in partial syntactic environment:" environment))
\ No newline at end of file
diff --git a/src/runtime/syntax-items.scm b/src/runtime/syntax-items.scm
new file mode 100644
index 000000000..304536027
--- /dev/null
+++ b/src/runtime/syntax-items.scm
@@ -0,0 +1,124 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Syntax Items
+
+(declare (usual-integrations))
+
+;;; Reserved name items do not represent any form, but instead are
+;;; used to reserve a particular name in a syntactic environment.  If
+;;; the classifier refers to a reserved name, a syntax error is
+;;; signalled.  This is used in the implementation of LETREC-SYNTAX
+;;; to signal a meaningful error when one of the <init>s refers to
+;;; one of the names being bound.
+
+(define-record-type <reserved-name-item>
+    (make-reserved-name-item)
+    reserved-name-item?)
+
+;;; Keyword items represent macro keywords.  There are several flavors
+;;; of keyword item.
+
+(define-record-type <classifier-item>
+    (make-classifier-item classifier)
+    classifier-item?
+  (classifier classifier-item/classifier))
+
+(define-record-type <compiler-item>
+    (make-compiler-item compiler)
+    compiler-item?
+  (compiler compiler-item/compiler))
+
+(define-record-type <expander-item>
+    (make-expander-item expander)
+    expander-item?
+  (expander expander-item/expander))
+
+(define-record-type <keyword-value-item>
+    (make-keyword-value-item item expression)
+    keyword-value-item?
+  (item keyword-value-item/item)
+  (expression keyword-value-item/expression))
+
+(define (keyword-item? item)
+  (or (classifier-item? item)
+      (compiler-item? item)
+      (expander-item? item)
+      (keyword-value-item? item)))
+
+;;; Variable items represent run-time variables.
+
+(define-record-type <variable-item>
+    (make-variable-item name)
+    variable-item?
+  (name variable-item/name))
+
+;;; Expression items represent any kind of expression other than a
+;;; run-time variable or a sequence.
+
+(define-record-type <expression-item>
+    (make-expression-item compiler)
+    expression-item?
+  (compiler expression-item/compiler))
+
+;;; Body items represent sequences (e.g. BEGIN).
+
+(define-record-type <body-item>
+    (make-body-item components)
+    body-item?
+  (components body-item/components))
+
+(define (flatten-body-items items)
+  (append-map item->list items))
+
+(define (item->list item)
+  (if (body-item? item)
+      (flatten-body-items (body-item/components item))
+      (list item)))
+
+;;; Declaration items represent block-scoped declarations that are to
+;;; be passed through to the compiler.
+
+(define-record-type <declaration-item>
+    (make-declaration-item get-text)
+    declaration-item?
+  (get-text declaration-item/get-text))
+
+(define (declaration-item/text item)
+  ((declaration-item/get-text item)))
+
+;;; Binding items represent definitions, whether top-level or
+;;; internal, keyword or variable.  Null binding items are for
+;;; definitions that don't emit code.
+
+(define-record-type <binding-item>
+    (make-binding-item name value)
+    binding-item?
+  (name binding-item/name)
+  (value binding-item/value))
+
+(define-record-type <null-binding-item>
+    (make-null-binding-item)
+    null-binding-item?)
\ No newline at end of file
diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm
index 5d2ffd7c1..7ecbc3347 100644
--- a/src/runtime/syntax-output.scm
+++ b/src/runtime/syntax-output.scm
@@ -27,12 +27,8 @@ USA.
 
 (declare (usual-integrations))
 
-(define (syntax-error history . rest)
-  history				;ignore
-  (apply error rest))
-
-(define (transformer-eval expression environment)
-  (eval expression environment))
+(define (transformer-eval output environment)
+  (eval output (syntactic-environment->environment environment)))
 
 (define (output/variable name)
   (make-variable name))
@@ -140,201 +136,17 @@ USA.
   (make-combination (ucode-primitive lexical-assignment)
 		    (list environment name value)))
 
+(define (output/runtime-reference name)
+  (output/access-reference name system-global-environment))
+
 (define (output/local-declare declarations body)
   (make-declaration declarations body))
 
-(define lambda-tag:unnamed
-  ((ucode-primitive string->symbol) "#[unnamed-procedure]"))
-
-(define lambda-tag:let
-  ((ucode-primitive string->symbol) "#[let-procedure]"))
-
-(define lambda-tag:fluid-let
-  ((ucode-primitive string->symbol) "#[fluid-let-procedure]"))
+(define lambda-tag:unnamed '|#[unnamed-procedure]|)
+(define lambda-tag:let '|#[let-procedure]|)
+(define lambda-tag:fluid-let '|#[fluid-let-procedure]|)
 
-;;;; Declarations
-
-(define (define-declaration name pattern mapper)
-  (let ((entry (assq name known-declarations)))
-    (if entry
-	(set-cdr! entry (cons pattern mapper))
-	(begin
-	  (set! known-declarations
-		(cons (cons name (cons pattern mapper))
-		      known-declarations))
-	  unspecific))))
-
-(define (process-declaration declaration
-			     selector
-			     map-identifier
-			     ill-formed-declaration)
-  (if (pair? declaration)
-      (let ((entry (assq (car declaration) known-declarations)))
-	(if (and entry (syntax-match? (cadr entry) (cdr declaration)))
-	    ((cddr entry) declaration selector map-identifier)
-	    (begin
-	      (warn "Unknown declaration:" declaration)
-	      declaration)))
-      (ill-formed-declaration declaration selector)))
-
-(define known-declarations '())
-
-(for-each (lambda (keyword)
-	    (define-declaration keyword '()
-	      (lambda (declaration selector map-identifier)
-		selector map-identifier
-		declaration)))
-	  '(AUTOMAGIC-INTEGRATIONS
-	    NO-AUTOMAGIC-INTEGRATIONS
-	    ETA-SUBSTITUTION
-	    NO-ETA-SUBSTITUTION
-	    OPEN-BLOCK-OPTIMIZATIONS
-	    NO-OPEN-BLOCK-OPTIMIZATIONS))
-
-(for-each (lambda (keyword)
-	    (define-declaration keyword '(* IDENTIFIER)
-	      (lambda (declaration selector map-identifier)
-		(cons (car declaration)
-		      (select-map map-identifier
-				  (cdr declaration)
-				  (selector/add-cdr selector))))))
-	  ;; The names in USUAL-INTEGRATIONS are always global.
-	  '(
-	    USUAL-INTEGRATIONS
-	    INTEGRATE
-	    INTEGRATE-OPERATOR
-	    INTEGRATE-SAFELY
-	    IGNORE
-	    TYPE-CHECKS
-	    NO-TYPE-CHECKS
-	    RANGE-CHECKS
-	    NO-RANGE-CHECKS
-	    ))
-
-(define-declaration 'INTEGRATE-EXTERNAL
-  `(* ,(lambda (object)
-	 (or (string? object)
-	     (pathname? object))))
-  (lambda (declaration selector map-identifier)
-    selector map-identifier
-    declaration))
-
-(for-each
- (lambda (keyword)
-   (define-declaration keyword '(DATUM)
-     (lambda (declaration selector map-identifier)
-       (list (car declaration)
-	     (let loop
-		 ((varset (cadr declaration))
-		  (selector (selector/add-cadr selector)))
-	       (cond ((syntax-match? '('SET * IDENTIFIER) varset)
-		      (cons (car varset)
-			    (select-map map-identifier
-					(cdr varset)
-					(selector/add-cdr selector))))
-		     ((or (syntax-match? '('UNION * DATUM) varset)
-			  (syntax-match? '('INTERSECTION * DATUM) varset)
-			  (syntax-match? '('DIFFERENCE DATUM DATUM) varset))
-		      (cons (car varset)
-			    (select-map loop
-					(cdr varset)
-					(selector/add-cdr selector))))
-		     (else varset)))))))
- '(CONSTANT
-   IGNORE-ASSIGNMENT-TRAPS
-   IGNORE-REFERENCE-TRAPS
-   PURE-FUNCTION
-   SIDE-EFFECT-FREE
-   USUAL-DEFINITION
-   UUO-LINK))
-
-(define-declaration 'REPLACE-OPERATOR '(* (IDENTIFIER * (DATUM DATUM)))
-  (lambda (declaration selector map-identifier)
-    (cons (car declaration)
-	  (select-map
-	   (lambda (rule selector)
-	     (cons (map-identifier (car rule) (selector/add-car selector))
-		   (select-map
-		    (lambda (clause selector)
-		      (list (car clause)
-			    (if (identifier? (cadr clause))
-				(map-identifier (cadr clause)
-						(selector/add-cadr selector))
-				(cadr clause))))
-		    (cdr rule)
-		    (selector/add-cdr selector))))
-	   (cdr declaration)
-	   (selector/add-cdr selector)))))
-
-(define-declaration 'REDUCE-OPERATOR '(* (IDENTIFIER DATUM * DATUM))
-  (lambda (declaration selector map-identifier)
-    (cons (car declaration)
-	  (select-map
-	   (lambda (rule selector)
-	     (cons* (map-identifier (car rule) (selector/add-car selector))
-		    (if (identifier? (cadr rule))
-			(map-identifier (cadr rule)
-					(selector/add-cadr selector))
-			(cadr rule))
-		    (select-map
-		     (lambda (clause selector)
-		       (if (or (syntax-match? '('NULL-VALUE IDENTIFIER DATUM)
-					      clause)
-			       (syntax-match? '('SINGLETON IDENTIFIER)
-					      clause)
-			       (syntax-match? '('WRAPPER IDENTIFIER ? DATUM)
-					      clause))
-			   (cons* (car clause)
-				  (map-identifier (cadr clause)
-						  (selector/add-cadr selector))
-				  (cddr clause))
-			   clause))
-		     (cddr rule)
-		     (selector/add-cddr selector))))
-	   (cdr declaration)
-	   (selector/add-cdr selector)))))
-
-;;;; Identifiers
-
-(define *rename-database*)
-
-(define-structure (rename-database (constructor initial-rename-database ())
-				   (conc-name rename-database/))
-  (frame-number 0)
-  (mapping-table (make-equal-hash-table) read-only #t)
-  (unmapping-table (make-eq-hash-table) read-only #t)
-  (id-table (make-eq-hash-table) read-only #t))
-
-(define (make-rename-id)
-  (delay
-    (let ((n (+ (rename-database/frame-number *rename-database*) 1)))
-      (set-rename-database/frame-number! *rename-database* n)
-      n)))
-
-(define (rename-identifier identifier rename-id)
-  (let ((key (cons identifier rename-id))
-	(mapping-table (rename-database/mapping-table *rename-database*)))
-    (or (hash-table/get mapping-table key #f)
-	(let ((mapped-identifier
-	       (string->uninterned-symbol
-		(symbol-name (identifier->symbol identifier)))))
-	  (hash-table/put! mapping-table key mapped-identifier)
-	  (hash-table/put! (rename-database/unmapping-table *rename-database*)
-			   mapped-identifier
-			   key)
-	  mapped-identifier))))
-
-(define (rename-top-level-identifier identifier)
-  (if (symbol? identifier)
-      identifier
-      (rename-identifier identifier (delay 0))))
-
-(define (make-name-generator)
-  (let ((id (make-rename-id)))
-    (lambda (identifier)
-      (rename-identifier identifier id))))
-
-;;; Post processing
+;;;; Post processing
 
 (define (output/post-process-expression expression)
   (let ((unmapping (empty-unmapping)))
@@ -351,76 +163,6 @@ USA.
   (or (hash-table/get unmapping identifier #f)
       (finalize-mapped-identifier identifier)))
 
-(define (unmap-identifier identifier)
-  (let ((entry
-	 (hash-table/get (rename-database/unmapping-table *rename-database*)
-			 identifier
-			 #f)))
-    (if entry
-	(identifier->symbol (car entry))
-	(begin
-	  (if (not (symbol? identifier))
-	      (error:bad-range-argument identifier 'UNMAP-IDENTIFIER))
-	  identifier))))
-
-(define (finalize-mapped-identifier identifier)
-  (let ((entry
-	 (hash-table/get (rename-database/unmapping-table *rename-database*)
-			 identifier
-			 #f)))
-    (if entry
-	(let ((identifier (car entry))
-	      (frame-number (force (cdr entry))))
-	  (if (interned-symbol? identifier)
-	      (map-interned-symbol identifier frame-number)
-	      (map-uninterned-identifier identifier frame-number)))
-	(begin
-	  (if (not (symbol? identifier))
-	      (error:bad-range-argument identifier
-					'FINALIZE-MAPPED-IDENTIFIER))
-	  identifier))))
-
-(define (map-interned-symbol symbol frame-number)
-  (string->symbol
-   (string-append "."
-		  (symbol-name symbol)
-		  "."
-		  (number->string frame-number))))
-
-(define (map-uninterned-identifier identifier frame-number)
-  (let ((table (rename-database/id-table *rename-database*))
-	(symbol (identifier->symbol identifier)))
-    (let ((alist (hash-table/get table symbol '())))
-      (let ((entry (assv frame-number alist)))
-	(if entry
-	    (let ((entry* (assq identifier (cdr entry))))
-	      (if entry*
-		  (cdr entry*)
-		  (let ((mapped-symbol
-			 (map-indexed-symbol symbol
-					     frame-number
-					     (length (cdr entry)))))
-		    (set-cdr! entry
-			      (cons (cons identifier mapped-symbol)
-				    (cdr entry)))
-		    mapped-symbol)))
-	    (let ((mapped-symbol (map-indexed-symbol symbol frame-number 0)))
-	      (hash-table/put! table
-			       symbol
-			       (cons (list frame-number
-					   (cons identifier mapped-symbol))
-				     alist))
-	      mapped-symbol))))))
-
-(define (map-indexed-symbol symbol frame-number index-number)
-  (string->symbol
-   (string-append "."
-		  (symbol-name symbol)
-		  "."
-		  (number->string frame-number)
-		  "-"
-		  (number->string index-number))))
-
 ;;;; Compute substitution
 
 (define (compute-substitution expression unmapping)
@@ -469,37 +211,6 @@ USA.
 					unmapping))
 	    (loop (cdr identifiers) (cdr unmapped)))))
     free-references))
-
-;;; Reference Set
-
-(define (null-reference-set)
-  '())
-
-(define (singleton-reference-set identifier)
-  (list (cons identifier (unmap-identifier identifier))))
-
-(define (reference-set-union s1 s2)
-  (if (pair? s1)
-      (if (assq (caar s1) s2)
-	  (reference-set-union (cdr s1) s2)
-	  (cons (car s1) (reference-set-union (cdr s1) s2)))
-      s2))
-
-(define (add-to-reference-set identifier reference-set)
-  (if (assq identifier reference-set)
-      reference-set
-      (cons (cons identifier (unmap-identifier identifier)) reference-set)))
-
-(define (remove-from-reference-set identifiers reference-set)
-  (delete-matching-items reference-set
-    (lambda (item)
-      (memq (car item) identifiers))))
-
-(define (unmapping-collision? identifier unmapped-identifier reference-set)
-  (find-matching-item reference-set
-    (lambda (item)
-      (and (eq? unmapped-identifier (cdr item))
-	   (not (eq? identifier (car item)))))))
 
 (define (compute-substitution/subexpression get-subexpression)
   (lambda (expression unmapping)
@@ -599,14 +310,7 @@ USA.
 
 (define (substitute-in-declarations substitution declarations)
   (map (lambda (declaration)
-	 (process-declaration declaration select-object
-			      (lambda (identifier selector)
-				selector
-				(substitution identifier))
-			      (lambda (declaration selector)
-				selector
-				(error "Ill-formed declaration:"
-				       declaration))))
+	 (map-declaration-identifiers substitution declaration))
        declarations))
 
 (define (alpha-substitute/default substitution expression)
@@ -685,4 +389,135 @@ USA.
 		       (OPEN-BLOCK ,alpha-substitute/open-block)
 		       (SEQUENCE ,alpha-substitute/sequence)
 		       (UNASSIGNED? ,alpha-substitute/unassigned?)
-		       (VARIABLE ,alpha-substitute/variable))))
\ No newline at end of file
+		       (VARIABLE ,alpha-substitute/variable))))
+
+;;;; Identifiers
+
+(define *rename-database*)
+
+(define-structure (rename-database (constructor initial-rename-database ())
+				   (conc-name rename-database/))
+  (frame-number 0)
+  (mapping-table (make-equal-hash-table) read-only #t)
+  (unmapping-table (make-eq-hash-table) read-only #t)
+  (id-table (make-eq-hash-table) read-only #t))
+
+(define (make-rename-id)
+  (delay
+    (let ((n (+ (rename-database/frame-number *rename-database*) 1)))
+      (set-rename-database/frame-number! *rename-database* n)
+      n)))
+
+(define (rename-identifier identifier rename-id)
+  (let ((key (cons identifier rename-id))
+	(mapping-table (rename-database/mapping-table *rename-database*)))
+    (or (hash-table/get mapping-table key #f)
+	(let ((mapped-identifier
+	       (utf8-string->uninterned-symbol
+		(symbol-name (identifier->symbol identifier)))))
+	  (hash-table/put! mapping-table key mapped-identifier)
+	  (hash-table/put! (rename-database/unmapping-table *rename-database*)
+			   mapped-identifier
+			   key)
+	  mapped-identifier))))
+
+(define (rename-top-level-identifier identifier)
+  (if (symbol? identifier)
+      identifier
+      (rename-identifier identifier (delay 0))))
+
+(define (make-name-generator)
+  (let ((id (make-rename-id)))
+    (lambda (identifier)
+      (rename-identifier identifier id))))
+
+(define (unmap-identifier identifier)
+  (let ((entry
+	 (hash-table/get (rename-database/unmapping-table *rename-database*)
+			 identifier
+			 #f)))
+    (if entry
+	(identifier->symbol (car entry))
+	(begin
+	  (if (not (symbol? identifier))
+	      (error:bad-range-argument identifier 'UNMAP-IDENTIFIER))
+	  identifier))))
+
+(define (finalize-mapped-identifier identifier)
+  (let ((entry
+	 (hash-table/get (rename-database/unmapping-table *rename-database*)
+			 identifier
+			 #f)))
+    (if entry
+	(let ((identifier (car entry))
+	      (frame-number (force (cdr entry))))
+	  (if (interned-symbol? identifier)
+	      (map-interned-symbol identifier frame-number)
+	      (map-uninterned-identifier identifier frame-number)))
+	(begin
+	  (if (not (symbol? identifier))
+	      (error:bad-range-argument identifier
+					'FINALIZE-MAPPED-IDENTIFIER))
+	  identifier))))
+
+(define (map-interned-symbol symbol-to-map frame-number)
+  (symbol "." symbol-to-map "." frame-number))
+
+(define (map-uninterned-identifier identifier frame-number)
+  (let ((table (rename-database/id-table *rename-database*))
+	(symbol (identifier->symbol identifier)))
+    (let ((alist (hash-table/get table symbol '())))
+      (let ((entry (assv frame-number alist)))
+	(if entry
+	    (let ((entry* (assq identifier (cdr entry))))
+	      (if entry*
+		  (cdr entry*)
+		  (let ((mapped-symbol
+			 (map-indexed-symbol symbol
+					     frame-number
+					     (length (cdr entry)))))
+		    (set-cdr! entry
+			      (cons (cons identifier mapped-symbol)
+				    (cdr entry)))
+		    mapped-symbol)))
+	    (let ((mapped-symbol (map-indexed-symbol symbol frame-number 0)))
+	      (hash-table/put! table
+			       symbol
+			       (cons (list frame-number
+					   (cons identifier mapped-symbol))
+				     alist))
+	      mapped-symbol))))))
+
+(define (map-indexed-symbol symbol-to-map frame-number index-number)
+  (symbol "." symbol-to-map "." frame-number "-" index-number))
+
+;;;; Reference Set
+
+(define (null-reference-set)
+  '())
+
+(define (singleton-reference-set identifier)
+  (list (cons identifier (unmap-identifier identifier))))
+
+(define (reference-set-union s1 s2)
+  (if (pair? s1)
+      (if (assq (caar s1) s2)
+	  (reference-set-union (cdr s1) s2)
+	  (cons (car s1) (reference-set-union (cdr s1) s2)))
+      s2))
+
+(define (add-to-reference-set identifier reference-set)
+  (if (assq identifier reference-set)
+      reference-set
+      (cons (cons identifier (unmap-identifier identifier)) reference-set)))
+
+(define (remove-from-reference-set identifiers reference-set)
+  (delete-matching-items reference-set
+    (lambda (item)
+      (memq (car item) identifiers))))
+
+(define (unmapping-collision? identifier unmapped-identifier reference-set)
+  (find-matching-item reference-set
+    (lambda (item)
+      (and (eq? unmapped-identifier (cdr item))
+	   (not (eq? identifier (car item)))))))
\ No newline at end of file
diff --git a/src/runtime/syntax-rules.scm b/src/runtime/syntax-rules.scm
index 7240f927d..10c3e1957 100644
--- a/src/runtime/syntax-rules.scm
+++ b/src/runtime/syntax-rules.scm
@@ -34,47 +34,41 @@ USA.
 
 (declare (usual-integrations))
 
-(define-er-macro-transformer 'SYNTAX-RULES system-global-environment
-  (lambda (form rename compare)
-    (call-with-syntax-error-procedure
-     (lambda (syntax-error)
-       (expand/syntax-rules form rename compare syntax-error)))))
-
-(define (expand/syntax-rules form rename compare syntax-error)
-  (if (syntax-match? '((* IDENTIFIER) * ((IDENTIFIER . DATUM) EXPRESSION))
-		     (cdr form))
-      (let ((keywords (cadr form))
-	    (clauses (cddr form)))
-	(if (let loop ((keywords keywords))
-	      (and (pair? keywords)
-		   (or (memq (car keywords) (cdr keywords))
-		       (loop (cdr keywords)))))
-	    (syntax-error "Keywords list contains duplicates:" keywords)
-	    (let ((r-form (rename 'FORM))
-		  (r-rename (rename 'RENAME))
-		  (r-compare (rename 'COMPARE)))
-	      `(,(rename 'ER-MACRO-TRANSFORMER)
-		(,(rename 'LAMBDA)
-		 (,r-form ,r-rename ,r-compare)
-		 ,r-compare		;prevent compiler warnings
-		 ,(let loop ((clauses clauses))
-		    (if (pair? clauses)
-			(let ((pattern (caar clauses)))
-			  (let ((sids
-				 (parse-pattern rename compare keywords
-						pattern r-form)))
-			    `(,(rename 'IF)
-			      ,(generate-match rename compare keywords
-					       r-rename r-compare
-					       pattern r-form)
-			      ,(generate-output rename compare r-rename
-						sids (cadar clauses)
-						syntax-error)
-			      ,(loop (cdr clauses)))))
-			`(,(rename 'BEGIN)
-			  ,r-rename	;prevent compiler warnings
-			  (,(rename 'ILL-FORMED-SYNTAX) ,r-form)))))))))
-      (syntax-error "Ill-formed special form:" form)))
+(define-syntax syntax-rules
+  (er-macro-transformer
+   (lambda (form rename compare)
+     (syntax-check '(KEYWORD (* IDENTIFIER) * ((IDENTIFIER . DATUM) EXPRESSION))
+		   form)
+     (let ((keywords (cadr form))
+	   (clauses (cddr form)))
+       (if (let loop ((keywords keywords))
+	     (and (pair? keywords)
+		  (or (memq (car keywords) (cdr keywords))
+		      (loop (cdr keywords)))))
+	   (syntax-error "Keywords list contains duplicates:" keywords)
+	   (let ((r-form (rename 'FORM))
+		 (r-rename (rename 'RENAME))
+		 (r-compare (rename 'COMPARE)))
+	     `(,(rename 'ER-MACRO-TRANSFORMER)
+	       (,(rename 'LAMBDA)
+		(,r-form ,r-rename ,r-compare)
+		,r-compare		;prevent compiler warnings
+		,(let loop ((clauses clauses))
+		   (if (pair? clauses)
+		       (let ((pattern (caar clauses)))
+			 (let ((sids
+				(parse-pattern rename compare keywords
+					       pattern r-form)))
+			   `(,(rename 'IF)
+			     ,(generate-match rename compare keywords
+					      r-rename r-compare
+					      pattern r-form)
+			     ,(generate-output rename compare r-rename
+					       sids (cadar clauses))
+			     ,(loop (cdr clauses)))))
+		       `(,(rename 'BEGIN)
+			 ,r-rename	;prevent compiler warnings
+			 (,(rename 'ILL-FORMED-SYNTAX) ,r-form))))))))))))
 
 (define (parse-pattern rename compare keywords pattern expression)
   (let loop
@@ -176,7 +170,7 @@ USA.
 		(else `(,(rename 'IF) ,predicate ,consequent #F))))))
     (loop pattern expression)))
 
-(define (generate-output rename compare r-rename sids template syntax-error)
+(define (generate-output rename compare r-rename sids template)
   (let loop ((template template) (ellipses '()))
     (cond ((identifier? template)
 	   (let ((sid
@@ -187,7 +181,7 @@ USA.
 			     (loop (cdr sids)))))))
 	     (if sid
 		 (begin
-		   (add-control! sid ellipses syntax-error)
+		   (add-control! sid ellipses)
 		   (sid-expression sid))
 		 `(,r-rename ,(syntax-quote template)))))
 	  ((or (zero-or-more? template rename compare)
@@ -198,8 +192,7 @@ USA.
 						  ellipsis
 						  (loop (car template)
 							(cons ellipsis
-							      ellipses))
-						  syntax-error))
+							      ellipses))))
 			     (loop (cddr template) ellipses)))
 	  ((pair? template)
 	   (optimized-cons rename compare
@@ -208,7 +201,7 @@ USA.
 	  (else
 	   `(,(rename 'QUOTE) ,template)))))
 
-(define (add-control! sid ellipses syntax-error)
+(define (add-control! sid ellipses)
   (let loop ((sid sid) (ellipses ellipses))
     (let ((control (sid-control sid)))
       (cond (control
@@ -223,7 +216,7 @@ USA.
 		 (syntax-error "Missing ellipsis in expansion." #f))
 	     (loop control (cdr ellipses)))))))
 
-(define (generate-ellipsis rename ellipsis body syntax-error)
+(define (generate-ellipsis rename ellipsis body)
   (let ((sids (ellipsis-sids ellipsis)))
     (if (pair? sids)
 	(let ((name (sid-name (car sids)))
@@ -259,9 +252,9 @@ USA.
 
 (define (syntax-quote expression)
   `(,(compiler->keyword
-      (lambda (form environment history)
+      (lambda (form environment)
 	environment			;ignore
-	(syntax-check '(KEYWORD DATUM) form history)
+	(syntax-check '(KEYWORD DATUM) form)
 	(output/constant (cadr form))))
     ,expression))
 
diff --git a/src/runtime/syntax-transforms.scm b/src/runtime/syntax-transforms.scm
index 75e59cf1e..b1b95bf2c 100644
--- a/src/runtime/syntax-transforms.scm
+++ b/src/runtime/syntax-transforms.scm
@@ -30,73 +30,48 @@ USA.
 
 (declare (usual-integrations))
 
-;;;; Items
-
-(define (item-constructor rtd fields)
-  (let ((constructor (record-constructor rtd fields)))
-    (lambda (history . arguments)
-      (make-item history (apply constructor arguments)))))
-
-(define (keyword-constructor type fields)
-  (let ((constructor (item-constructor type fields)))
-    (lambda arguments
-      (apply constructor #f arguments))))
-
-(define <item>)
-(define make-item)
-(define <expander-item>)
-(define make-expander-item)
-
-(define (initialize-syntax-transforms!)
-  (set! <item>
-	(make-record-type "item" '(HISTORY RECORD)))
-  (set! make-item
-	(record-constructor <item> '(HISTORY RECORD)))
-  (set! <expander-item>
-	(make-record-type "expander-item" '(EXPANDER ENVIRONMENT)))
-  (set! make-expander-item
-	(keyword-constructor <expander-item> '(EXPANDER ENVIRONMENT)))
-  unspecific)
-
 (define (sc-macro-transformer->expander transformer closing-environment)
-  (make-expander-item (lambda (form environment closing-environment)
-			(make-syntactic-closure closing-environment '()
-			  (transformer form environment)))
-		      closing-environment))
+  (make-expander-item
+   (lambda (form use-environment)
+     (close-syntax (transformer form use-environment)
+		   closing-environment))))
 
 (define (rsc-macro-transformer->expander transformer closing-environment)
-  (make-expander-item (lambda (form environment closing-environment)
-			(make-syntactic-closure environment '()
-			  (transformer form closing-environment)))
-		      closing-environment))
+  (make-expander-item
+   (lambda (form use-environment)
+     (close-syntax (transformer form closing-environment)
+		   use-environment))))
 
 (define (er-macro-transformer->expander transformer closing-environment)
   (make-expander-item
-   (lambda (form environment closing-environment)
-     (make-syntactic-closure environment '()
-       (transformer
-	form
-	(let ((renames '()))
-	  (lambda (identifier)
-	    (let ((association (assq identifier renames)))
-	      (if association
-		  (cdr association)
-		  (let ((rename
-			 (make-syntactic-closure closing-environment '()
-			   identifier)))
-		    (set! renames (cons (cons identifier rename) renames))
-		    rename)))))
-	(lambda (x y)
-	  (identifier=? environment x environment y)))))
-   closing-environment))
+   (lambda (form use-environment)
+     (close-syntax (transformer form
+				(make-er-rename closing-environment)
+				(make-er-compare use-environment))
+		   use-environment))))
+
+(define (make-er-rename closing-environment)
+  (let ((renames '()))
+    (lambda (identifier)
+      (let ((p (assq identifier renames)))
+	(if p
+	    (cdr p)
+	    (let ((rename (close-syntax identifier closing-environment)))
+	      (set! renames (cons (cons identifier rename) renames))
+	      rename))))))
+
+(define (make-er-compare use-environment)
+  (lambda (x y)
+    (identifier=? use-environment x
+		  use-environment y)))
 
 (define (non-hygienic-macro-transformer->expander transformer
 						  closing-environment)
-  (make-expander-item (lambda (form environment closing-environment)
-			closing-environment
-			(make-syntactic-closure environment '()
-			  (apply transformer (cdr form))))
-		      closing-environment))
+  closing-environment
+  (make-expander-item
+   (lambda (form use-environment)
+     (close-syntax (apply transformer (cdr form))
+		   use-environment))))
 
 (define (syntactic-keyword->item keyword environment)
   (let ((item (environment-lookup-macro environment keyword)))
diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
new file mode 100644
index 000000000..bd9ff38f8
--- /dev/null
+++ b/src/runtime/syntax.scm
@@ -0,0 +1,193 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Syntactic Closures
+;;;  Based on a design by Alan Bawden.
+
+;;; This is a two-stage program: the first stage classifies input
+;;; expressions into types, e.g. "definition", "lambda body",
+;;; "expression", etc., and the second stage compiles those classified
+;;; expressions ("items") into output code.  The classification stage
+;;; permits discovery of internal definitions prior to code
+;;; generation.  It also identifies keywords and variables, which
+;;; allows a powerful form of syntactic binding to be implemented.
+
+;;; See "Syntactic Closures", by Alan Bawden and Jonathan Rees, in
+;;; Proceedings of the 1988 ACM Conference on Lisp and Functional
+;;; Programming, page 86.
+
+(declare (usual-integrations))
+
+;;;; Top level
+
+(define (syntax form environment)
+  (syntax* (list form) environment))
+
+(define (syntax* forms environment)
+  (guarantee-list forms 'SYNTAX*)
+  (guarantee-syntactic-environment environment 'SYNTAX*)
+  (fluid-let ((*rename-database* (initial-rename-database)))
+    (output/post-process-expression
+     (if (syntactic-environment/top-level? environment)
+	 (compile-body-item/top-level
+	  (let ((environment
+		 (make-top-level-syntactic-environment environment)))
+	    (classify/body forms
+			   environment
+			   environment)))
+	 (output/sequence (compile/expressions forms environment))))))
+
+(define (compile/expression expression environment)
+  (compile-item/expression (classify/expression expression environment)))
+
+(define (compile/expressions expressions environment)
+  (map (lambda (expression)
+	 (compile/expression expression environment))
+       expressions))
+
+;;;; Syntactic closures
+
+(define-record-type <syntactic-closure>
+    (%make-syntactic-closure environment free-names form)
+    syntactic-closure?
+  (environment syntactic-closure/environment)
+  (free-names syntactic-closure/free-names)
+  (form syntactic-closure/form))
+
+(define-guarantee syntactic-closure "syntactic closure")
+
+(define (make-syntactic-closure environment free-names form)
+  (guarantee-syntactic-environment environment 'MAKE-SYNTACTIC-CLOSURE)
+  (guarantee-list-of-type free-names identifier?
+			  "list of identifiers" 'MAKE-SYNTACTIC-CLOSURE)
+  (if (or (memq form free-names)	;LOOKUP-IDENTIFIER assumes this.
+	  (and (syntactic-closure? form)
+	       (null? (syntactic-closure/free-names form))
+	       (not (identifier? (syntactic-closure/form form))))
+	  (not (or (syntactic-closure? form)
+		   (pair? form)
+		   (symbol? form))))
+      form
+      (%make-syntactic-closure environment free-names form)))
+
+(define (strip-syntactic-closures object)
+  (if (let loop ((object object))
+	(if (pair? object)
+	    (or (loop (car object))
+		(loop (cdr object)))
+	    (syntactic-closure? object)))
+      (let loop ((object object))
+	(if (pair? object)
+	    (cons (loop (car object))
+		  (loop (cdr object)))
+	    (if (syntactic-closure? object)
+		(loop (syntactic-closure/form object))
+		object)))
+      object))
+
+(define (close-syntax form environment)
+  (make-syntactic-closure environment '() form))
+
+;;;; Identifiers
+
+(define (identifier? object)
+  (or (symbol? object)
+      (synthetic-identifier? object)))
+
+(define (synthetic-identifier? object)
+  (and (syntactic-closure? object)
+       (identifier? (syntactic-closure/form object))))
+
+(define-guarantee identifier "identifier")
+(define-guarantee synthetic-identifier "synthetic identifier")
+
+(define (make-synthetic-identifier identifier)
+  (close-syntax identifier null-syntactic-environment))
+
+(define (identifier->symbol identifier)
+  (or (let loop ((identifier identifier))
+	(if (syntactic-closure? identifier)
+	    (loop (syntactic-closure/form identifier))
+	    (and (symbol? identifier)
+		 identifier)))
+      (error:not-identifier identifier 'IDENTIFIER->SYMBOL)))
+
+(define (identifier=? environment-1 identifier-1 environment-2 identifier-2)
+  (let ((item-1 (lookup-identifier identifier-1 environment-1))
+	(item-2 (lookup-identifier identifier-2 environment-2)))
+    (or (eq? item-1 item-2)
+	;; This is necessary because an identifier that is not
+	;; explicitly bound by an environment is mapped to a variable
+	;; item, and the variable items are not cached.  Therefore
+	;; two references to the same variable result in two
+	;; different variable items.
+	(and (variable-item? item-1)
+	     (variable-item? item-2)
+	     (eq? (variable-item/name item-1)
+		  (variable-item/name item-2))))))
+
+(define (lookup-identifier identifier environment)
+  (let ((item (syntactic-environment/lookup environment identifier)))
+    (cond (item
+	   (if (reserved-name-item? item)
+	       (syntax-error "Premature reference to reserved name:" identifier)
+	       item))
+	  ((symbol? identifier)
+	   (make-variable-item identifier))
+	  ((syntactic-closure? identifier)
+	   (lookup-identifier (syntactic-closure/form identifier)
+			      (syntactic-closure/environment identifier)))
+	  (else
+	   (error:not-identifier identifier 'LOOKUP-IDENTIFIER)))))
+
+;;;; Utilities
+
+(define (syntax-error . rest)
+  (apply error rest))
+
+(define (classifier->keyword classifier)
+  (item->keyword (make-classifier-item classifier)))
+
+(define (compiler->keyword compiler)
+  (item->keyword (make-compiler-item compiler)))
+
+(define (item->keyword item)
+  (let ((environment
+	 (make-internal-syntactic-environment null-syntactic-environment)))
+    (syntactic-environment/define environment 'KEYWORD item)
+    (close-syntax 'KEYWORD environment)))
+
+(define (capture-syntactic-environment expander)
+  `(,(classifier->keyword
+      (lambda (form environment definition-environment)
+	form				;ignore
+	(classify/form (expander environment)
+		       environment
+		       definition-environment)))))
+
+(define (reverse-syntactic-environments environment procedure)
+  (capture-syntactic-environment
+   (lambda (closing-environment)
+     (close-syntax (procedure closing-environment) environment))))
\ No newline at end of file
diff --git a/src/runtime/sysmac.scm b/src/runtime/sysmac.scm
index 3550d67ef..6a28552fc 100644
--- a/src/runtime/sysmac.scm
+++ b/src/runtime/sysmac.scm
@@ -98,11 +98,11 @@ USA.
   (er-macro-transformer
    (lambda (form rename compare)
      compare
-     (parse-define-form form rename
-       (lambda (name value)
-	 `(,(rename 'BEGIN)
-	    (,(rename 'DEFINE) ,name)
-	    (,(rename 'ADD-BOOT-INIT!)
-	     (,(rename 'LAMBDA) ()
-	       (,(rename 'SET!) ,name ,value)
-	       ,(rename 'UNSPECIFIC)))))))))
\ No newline at end of file
+     (receive (name value)
+	 (parse-define-form form rename)
+       `(,(rename 'BEGIN)
+	  (,(rename 'DEFINE) ,name)
+	  (,(rename 'ADD-BOOT-INIT!)
+	   (,(rename 'LAMBDA) ()
+	     (,(rename 'SET!) ,name ,value)
+	     ,(rename 'UNSPECIFIC))))))))
\ No newline at end of file
diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm
index 06098342e..d5226e4cc 100644
--- a/src/runtime/unpars.scm
+++ b/src/runtime/unpars.scm
@@ -311,10 +311,10 @@ USA.
 	((eq? object #t) (*unparse-string "#t"))
 	((default-object? object) (*unparse-string "#!default"))
 	((eof-object? object) (*unparse-string "#!eof"))
-	((eq? object lambda-aux-tag) (*unparse-string "#!aux"))
-	((eq? object lambda-key-tag) (*unparse-string "#!key"))
-	((eq? object lambda-optional-tag) (*unparse-string "#!optional"))
-	((eq? object lambda-rest-tag) (*unparse-string "#!rest"))
+	((eq? object lambda-tag:aux) (*unparse-string "#!aux"))
+	((eq? object lambda-tag:key) (*unparse-string "#!key"))
+	((eq? object lambda-tag:optional) (*unparse-string "#!optional"))
+	((eq? object lambda-tag:rest) (*unparse-string "#!rest"))
 	((eq? object unspecific) (*unparse-string "#!unspecific"))
 	(else (unparse/default object))))
 
diff --git a/src/runtime/unsyn.scm b/src/runtime/unsyn.scm
index 5e132ea11..f70800590 100644
--- a/src/runtime/unsyn.scm
+++ b/src/runtime/unsyn.scm
@@ -355,13 +355,13 @@ USA.
 (define (lambda-list required optional rest auxiliary)
   (let ((optional (if (null? optional)
 		      '()
-		      (cons lambda-optional-tag optional)))
+		      (cons lambda-tag:optional optional)))
 	(rest (cond ((not rest) '())
 		    ((null? auxiliary) rest)
-		    (else (list lambda-rest-tag rest)))))
+		    (else (list lambda-tag:rest rest)))))
     (if (null? auxiliary)
 	`(,@required ,@optional . ,rest)
-	`(,@required ,@optional ,@rest ,lambda-aux-tag ,@auxiliary))))
+	`(,@required ,@optional ,@rest ,lambda-tag:aux ,@auxiliary))))
 
 (define (lambda-components** expression receiver)
   (lambda-components expression
diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg
index d2df7f9c9..e50bff449 100644
--- a/src/sf/sf.pkg
+++ b/src/sf/sf.pkg
@@ -80,9 +80,7 @@ USA.
 	  integrate/top-level
 	  integrate/get-top-level-block
 	  reassign
-	  variable/final-value)
-  (import (runtime parser)
-	  lambda-optional-tag))
+	  variable/final-value))
 
 (define-package (scode-optimizer cgen)
   (files "cgen")
diff --git a/src/sf/subst.scm b/src/sf/subst.scm
index 6fa6ac545..a2dc122ec 100644
--- a/src/sf/subst.scm
+++ b/src/sf/subst.scm
@@ -781,7 +781,7 @@ you ask for.
 	(let ((arg-list (append (procedure/required procedure)
 				(if (null? (procedure/optional procedure))
 				    '()
-				    (cons lambda-optional-tag
+				    (cons lambda-tag:optional
 					  (procedure/optional procedure)))
 				(if (not (procedure/rest procedure))
 				    '()