From 17a8b97f187fef90b3c33f0973d4504b94dd5279 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 26 Mar 2018 23:53:18 -0700
Subject: [PATCH] Add context to items, for errors that happen during item
 compilation.

---
 src/edwin/clsmac.scm          |  16 +--
 src/runtime/host-adapter.scm  |   5 +-
 src/runtime/mit-syntax.scm    | 203 ++++++++++++++++++++++++----------
 src/runtime/runtime.pkg       |  16 +--
 src/runtime/syntax-items.scm  | 117 +++++---------------
 src/runtime/syntax-parser.scm |  15 +--
 src/runtime/syntax-rules.scm  |   2 +-
 src/runtime/syntax.scm        |  18 +--
 8 files changed, 202 insertions(+), 190 deletions(-)

diff --git a/src/edwin/clsmac.scm b/src/edwin/clsmac.scm
index 80ce27921..a3ecd2c72 100644
--- a/src/edwin/clsmac.scm
+++ b/src/edwin/clsmac.scm
@@ -101,14 +101,14 @@ USA.
 		     ,@(cddddr form))
 		   senv
 		   rest)))
-       (expr-item
-	(lambda ()
-	  (transform-instance-variables
-	   (class-instance-transforms
-	    (name->class (identifier->symbol class-name)))
-	   (compile-expr-item self-item)
-	   free-names
-	   (compile-item body-item))))))))
+       (expr-item #f
+	 (lambda ()
+	   (transform-instance-variables
+	    (class-instance-transforms
+	     (name->class (identifier->symbol class-name)))
+	    (compile-expr-item self-item)
+	    free-names
+	    (compile-item body-item))))))))
 
 (define-syntax ==>
   (syntax-rules ()
diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm
index eb8dd7319..b4d620370 100644
--- a/src/runtime/host-adapter.scm
+++ b/src/runtime/host-adapter.scm
@@ -189,8 +189,11 @@ USA.
                           env 'microcode-type))))
 
   (let ((env (->environment '(runtime syntax))))
-    (provide-rename env 'make-expression-item 'expr-item)
     (provide-rename env 'compile-item/expression 'compile-expr-item)
+    (if (unbound? env 'expr-item)
+	(eval '(define (expr-item ctx compiler)
+		 (make-expression-item compiler))
+	      env))
     (if (unbound? env 'compile-item)
 	(eval '(define (compile-item body-item)
 		 (compile-body-items (item->list body-item)))
diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index 95a636598..f9273a826 100644
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -42,10 +42,10 @@ USA.
       (transformer->keyword-item
        (transformer-eval transformer senv)
        senv
-       (expr-item
-	(lambda ()
-	  (output/top-level-syntax-expander transformer->expander-name
-					    transformer)))))))
+       (expr-item (serror-ctx form senv hist)
+	 (lambda ()
+	   (output/top-level-syntax-expander transformer->expander-name
+					     transformer)))))))
 
 (define :sc-macro-transformer
   ;; "Syntactic Closures" transformer
@@ -76,12 +76,13 @@ USA.
 (define :begin
   (spar-classifier->runtime
    (delay
-     (spar-encapsulate-values
-	 (lambda (deferred-items)
-	   (seq-item
-	    (map-in-order (lambda (p) (p))
-			  deferred-items)))
+     (spar-call-with-values
+	 (lambda (ctx . deferred-items)
+	   (seq-item ctx
+	     (map-in-order (lambda (p) (p))
+			   deferred-items)))
        (spar-elt)
+       (spar-push spar-arg:ctx)
        (spar* (spar-elt spar-push-deferred-classified))
        (spar-match-null)))))
 
@@ -90,10 +91,11 @@ USA.
    (delay
      (spar-call-with-values if-item
        (spar-elt)
+       (spar-push spar-arg:ctx)
        (spar-elt spar-push-classified)
        (spar-elt spar-push-classified)
        (spar-or (spar-elt spar-push-classified)
-		(spar-push-value unspecific-item))
+		(spar-push-value unspecific-item spar-arg:ctx))
        (spar-match-null)))))
 
 (define :quote
@@ -101,6 +103,7 @@ USA.
    (delay
      (spar-call-with-values constant-item
        (spar-elt)
+       (spar-push spar-arg:ctx)
        (spar-elt (spar-push-value strip-syntactic-closures spar-arg:form))
        (spar-match-null)))))
 
@@ -109,6 +112,7 @@ USA.
    (delay
      (spar-call-with-values quoted-id-item
        (spar-elt)
+       (spar-push spar-arg:ctx)
        (spar-elt
 	 (spar-match identifier? spar-arg:form)
 	 (spar-push-value lookup-identifier spar-arg:form spar-arg:senv)
@@ -121,13 +125,15 @@ USA.
   (spar-classifier->runtime
    (delay
      (spar-call-with-values
-	 (lambda (lhs-item rhs-item)
+	 (lambda (ctx lhs-item rhs-item)
 	   (if (var-item? lhs-item)
-	       (assignment-item (var-item-id lhs-item) rhs-item)
-	       (access-assignment-item (access-item-name lhs-item)
+	       (assignment-item ctx (var-item-id lhs-item) rhs-item)
+	       (access-assignment-item ctx
+				       (access-item-name lhs-item)
 				       (access-item-env lhs-item)
 				       rhs-item)))
        (spar-elt)
+       (spar-push spar-arg:ctx)
        (spar-elt
 	 spar-push-classified
 	 (spar-or (spar-match (lambda (lhs-item)
@@ -137,7 +143,7 @@ USA.
 		  (spar-error "Variable required in this context:"
 			      spar-arg:form)))
        (spar-or (spar-elt spar-push-classified)
-		(spar-push-value unassigned-item))
+		(spar-push-value unassigned-item spar-arg:ctx))
        (spar-match-null)))))
 
 ;; TODO: this is a classifier rather than a macro because it uses the
@@ -147,8 +153,9 @@ USA.
 (define :or
   (spar-classifier->runtime
    (delay
-     (spar-encapsulate-values or-item
+     (spar-call-with-values or-item
        (spar-elt)
+       (spar-push spar-arg:ctx)
        (spar* (spar-elt spar-push-classified))
        (spar-match-null)))))
 
@@ -157,6 +164,7 @@ USA.
    (delay
      (spar-call-with-values delay-item
        (spar-elt)
+       (spar-push spar-arg:ctx)
        (spar-elt spar-push-deferred-classified)
        (spar-match-null)))))
 
@@ -167,6 +175,7 @@ USA.
    (delay
      (spar-call-with-values defn-item
        (spar-elt)
+       (spar-push spar-arg:ctx)
        (spar-elt
 	 (spar-match identifier? spar-arg:form)
 	 (spar-push-value bind-variable spar-arg:form spar-arg:senv))
@@ -177,73 +186,91 @@ USA.
   (spar-classifier->runtime
    (delay
      (spar-call-with-values
-	 (lambda (id senv item)
+	 (lambda (ctx id item)
 	   (receive (id senv)
 	       (if (closed-identifier? id)
 		   (values (syntactic-closure-form id)
 			   (syntactic-closure-senv id))
-		   (values id senv))
+		   (values id (serror-ctx-senv ctx)))
 	     (bind-keyword id senv item)
 	     ;; User-defined macros at top level are preserved in the output.
 	     (if (and (keyword-item-has-expr? item)
 		      (senv-top-level? senv))
-		 (syntax-defn-item id (keyword-item-expr item))
-		 (seq-item '()))))
+		 (syntax-defn-item ctx id (keyword-item-expr item))
+		 (seq-item ctx '()))))
        (spar-elt)
+       (spar-push spar-arg:ctx)
        (spar-push-elt-if identifier? spar-arg:form)
-       (spar-push spar-arg:senv)
        (spar-elt
 	 spar-push-classified
 	 (spar-or (spar-match keyword-item? spar-arg:value)
 		  (spar-error "Keyword binding value must be a keyword:"
 			      spar-arg:form)))
        (spar-match-null)))))
-
+
 ;;;; Lambdas
 
 (define :lambda
   (spar-classifier->runtime
    (delay
      (spar-call-with-values
-	 (lambda (bvl body senv)
-	   (assemble-lambda-item scode-lambda-name:unnamed bvl body senv))
+	 (lambda (ctx bvl body-ctx body)
+	   (assemble-lambda-item ctx scode-lambda-name:unnamed bvl
+				 body-ctx body))
        (spar-elt)
+       (spar-push spar-arg:ctx)
        (spar-push-elt-if mit-lambda-list? spar-arg:form)
-       spar-push-body))))
+       (spar-push-body)))))
 
 (define :named-lambda
   (spar-classifier->runtime
    (delay
      (spar-call-with-values
-	 (lambda (name bvl body senv)
-	   (assemble-lambda-item (identifier->symbol name) bvl body senv))
+	 (lambda (ctx name bvl body-ctx body)
+	   (assemble-lambda-item ctx (identifier->symbol name) bvl
+				 body-ctx body))
        (spar-elt)
+       (spar-push spar-arg:ctx)
        (spar-elt
 	 (spar-push-elt-if identifier? spar-arg:form)
 	 (spar-push-form-if mit-lambda-list? spar-arg:form))
-       spar-push-body))))
-
-(define (assemble-lambda-item name bvl body senv)
-  (let ((frame-senv (make-internal-senv senv)))
-    (lambda-item name
+       (spar-push-body)))))
+
+(define (spar-push-body)
+  (spar-and
+    (spar-push spar-arg:ctx)
+    (spar-encapsulate-values
+	(lambda (elts)
+	  (lambda (frame-senv)
+	    (let ((body-senv (make-internal-senv frame-senv)))
+	      (map-in-order (lambda (elt) (elt body-senv))
+			    elts))))
+      (spar+ (spar-elt spar-push-open-classified))
+      (spar-match-null))))
+
+(define (assemble-lambda-item ctx name bvl body-ctx body)
+  (let ((frame-senv (make-internal-senv (serror-ctx-senv ctx))))
+    (lambda-item ctx
+		 name
 		 (map-mit-lambda-list (lambda (id)
 					(bind-variable id frame-senv))
 				      bvl)
 		 (lambda ()
-		   (body-item (body frame-senv))))))
+		   (body-item body-ctx (body frame-senv))))))
 
 ;;;; LET-like
 
 (define spar-promise:let-syntax
   (delay
     (spar-call-with-values
-	(lambda (bindings body senv)
-	  (let ((frame-senv (make-internal-senv senv)))
+	(lambda (ctx bindings body-ctx body)
+	  (let ((frame-senv (make-internal-senv (serror-ctx-senv ctx))))
 	    (for-each (lambda (binding)
 			(bind-keyword (car binding) frame-senv (cdr binding)))
 		      bindings)
-	    (seq-item (body frame-senv))))
+	    (seq-item body-ctx (body frame-senv))))
       (spar-elt)
+      (spar-push spar-arg:ctx)
       (spar-elt
 	(spar-call-with-values list
 	 (spar*
@@ -252,7 +279,7 @@ USA.
 		       (spar-elt spar-push-classified)
 		       (spar-match-null)))))
 	(spar-match-null))
-       spar-push-body)))
+       (spar-push-body))))
 
 (define :let-syntax
   (spar-classifier->runtime spar-promise:let-syntax))
@@ -264,8 +291,8 @@ USA.
   (spar-classifier->runtime
    (delay
      (spar-call-with-values
-	(lambda (bindings body senv)
-	  (let ((frame-senv (make-internal-senv senv))
+	(lambda (ctx bindings body-ctx body)
+	  (let ((frame-senv (make-internal-senv (serror-ctx-senv ctx)))
 		(ids (map car bindings)))
 	    (for-each (lambda (id)
 			(reserve-identifier id frame-senv))
@@ -276,8 +303,9 @@ USA.
 		      (map (lambda (binding)
 			     ((cdr binding) frame-senv))
 			   bindings))
-	    (seq-item (body frame-senv))))
+	    (seq-item body-ctx (body frame-senv))))
       (spar-elt)
+      (spar-push spar-arg:ctx)
       (spar-elt
 	 (spar-call-with-values list
 	   (spar*
@@ -286,13 +314,14 @@ USA.
 			 (spar-elt spar-push-open-classified)
 			 (spar-match-null)))))
 	 (spar-match-null))
-       spar-push-body))))
+       (spar-push-body)))))
 
 ;;;; MIT-specific syntax
 
 (define-record-type <access-item>
-    (access-item name env)
+    (access-item ctx name env)
     access-item?
+  (ctx access-item-ctx)
   (name access-item-name)
   (env access-item-env))
 
@@ -301,6 +330,7 @@ USA.
    (delay
      (spar-call-with-values access-item
        (spar-elt)
+       (spar-push spar-arg:ctx)
        (spar-push-elt-if identifier? spar-arg:form)
        (spar-elt spar-push-classified)
        (spar-match-null)))))
@@ -319,7 +349,7 @@ USA.
 			    spar-arg:form spar-arg:senv))
        (spar-elt)
        (spar-match-null)
-       (spar-push-value the-environment-item)))))
+       (spar-push-value the-environment-item spar-arg:ctx)))))
 
 (define keyword:unspecific
   (spar-classifier->keyword
@@ -327,7 +357,7 @@ USA.
      (spar-and
        (spar-elt)
        (spar-match-null)
-       (spar-push-value unspecific-item)))))
+       (spar-push-value unspecific-item spar-arg:ctx)))))
 
 (define keyword:unassigned
   (spar-classifier->keyword
@@ -335,7 +365,7 @@ USA.
      (spar-and
        (spar-elt)
        (spar-match-null)
-       (spar-push-value unassigned-item)))))
+       (spar-push-value unassigned-item spar-arg:ctx)))))
 
 ;;;; Declarations
 
@@ -343,20 +373,22 @@ USA.
   (spar-classifier->runtime
    (delay
      (spar-call-with-values
-	 (lambda (senv hist decls)
-	   (decl-item
-	    (lambda ()
-	      (smap (lambda (decl hist)
-		      (map-decl-ids (lambda (id selector)
-				      (classify-id id
-						   senv
-						   (hist-select selector hist)))
-				    decl))
-		    decls
-		    (hist-cadr hist)))))
+	 (lambda (ctx decls)
+	   (let ((senv (serror-ctx-senv ctx))
+		 (hist (serror-ctx-hist ctx)))
+	     (decl-item ctx
+	       (lambda ()
+		 (smap (lambda (decl hist)
+			 (map-decl-ids (lambda (id selector)
+					 (classify-id id
+						      senv
+						      (hist-select selector
+								   hist)))
+				       decl))
+		       decls
+		       (hist-cadr hist))))))
        (spar-elt)
-       (spar-push spar-arg:senv)
-       (spar-push spar-arg:hist)
+       (spar-push spar-arg:ctx)
        (spar-call-with-values list
 	 (spar*
 	   (spar-push-elt-if (lambda (form)
@@ -371,4 +403,59 @@ USA.
     (if (not (var-item? item))
 	(serror (serror-ctx id senv hist)
 		"Variable required in this context:" id))
-    (var-item-id item)))
\ No newline at end of file
+    (var-item-id item)))
+
+;;;; Specific expression items
+
+(define (access-assignment-item ctx name env-item rhs-item)
+  (expr-item ctx
+    (lambda ()
+      (output/access-assignment name
+				(compile-expr-item env-item)
+				(compile-expr-item rhs-item)))))
+
+(define (assignment-item ctx id rhs-item)
+  (expr-item ctx
+    (lambda ()
+      (output/assignment id (compile-expr-item rhs-item)))))
+
+(define (decl-item ctx classify)
+  (expr-item ctx
+    (lambda ()
+      (output/declaration (classify)))))
+
+(define (delay-item ctx classify)
+  (expr-item ctx
+    (lambda ()
+      (output/delay (compile-expr-item (classify))))))
+
+(define (if-item ctx predicate consequent alternative)
+  (expr-item ctx
+    (lambda ()
+      (output/conditional (compile-expr-item predicate)
+			  (compile-expr-item consequent)
+			  (compile-expr-item alternative)))))
+
+(define (lambda-item ctx name bvl classify-body)
+  (expr-item ctx
+    (lambda ()
+      (output/lambda name bvl (compile-item (classify-body))))))
+
+(define (or-item ctx . items)
+  (expr-item ctx
+    (lambda ()
+      (output/disjunction (map compile-expr-item items)))))
+
+(define (quoted-id-item ctx var-item)
+  (expr-item ctx
+    (lambda ()
+      (output/quoted-identifier (var-item-id var-item)))))
+
+(define (the-environment-item ctx)
+  (expr-item ctx output/the-environment))
+
+(define (unspecific-item ctx)
+  (expr-item ctx output/unspecific))
+
+(define (unassigned-item ctx)
+  (expr-item ctx output/unassigned))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 941bd25e4..25a1723a6 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4486,40 +4486,29 @@ USA.
   (files "syntax-items")
   (parent (runtime syntax))
   (export (runtime syntax)
-	  access-assignment-item
-	  assignment-item
 	  body-item
 	  combination-item
 	  compile-expr-item
 	  compile-item
 	  constant-item
-	  decl-item
 	  define-expr-item-compiler
 	  defn-item
 	  defn-item-id
 	  defn-item-syntax?
 	  defn-item-value
 	  defn-item?
-	  delay-item
 	  expr-item
 	  expr-item-compiler
+	  expr-item-ctx
 	  expr-item?
 	  flatten-items
-	  if-item
 	  item->list
-	  lambda-item
-	  let-item
-	  or-item
-	  quoted-id-item
 	  reserved-name-item
 	  reserved-name-item?
 	  seq-item
 	  seq-item-elements
 	  seq-item?
 	  syntax-defn-item
-	  the-environment-item
-	  unassigned-item
-	  unspecific-item
 	  var-item
 	  var-item-id
 	  var-item?))
@@ -4584,7 +4573,6 @@ USA.
 	  spar-opt
 	  spar-or
 	  spar-push
-	  spar-push-body
 	  spar-push-elt
 	  spar-push-elt-if
 	  spar-push-form-if
@@ -4595,6 +4583,7 @@ USA.
 	  spar-transform-values
 	  spar-with-mapped-senv)
   (export (runtime syntax)
+	  spar-arg:ctx
 	  spar-call
 	  spar-push-classified
 	  spar-push-deferred-classified
@@ -4607,6 +4596,7 @@ USA.
 	  scons-and
 	  scons-begin
 	  scons-call
+	  scons-close
 	  scons-declare
 	  scons-define
 	  scons-delay
diff --git a/src/runtime/syntax-items.scm b/src/runtime/syntax-items.scm
index 2017e509f..b13ffb69b 100644
--- a/src/runtime/syntax-items.scm
+++ b/src/runtime/syntax-items.scm
@@ -28,7 +28,7 @@ USA.
 
 (declare (usual-integrations))
 
-;;; These items can be stored in a syntactic environment.
+;;; These items (and keyword-item) can be stored in a syntactic environment.
 
 ;;; Variable items represent run-time variables.
 
@@ -61,23 +61,24 @@ USA.
 
 ;;; Definition items, whether top-level or internal, keyword or variable.
 
-(define (syntax-defn-item id value)
+(define (syntax-defn-item ctx id value)
   (guarantee identifier? id 'syntax-defn-item)
   (guarantee defn-item-value? value 'syntax-defn-item)
-  (%defn-item id value #t))
+  (%defn-item ctx id value #t))
 
-(define (defn-item id value)
+(define (defn-item ctx id value)
   (guarantee identifier? id 'defn-item)
   (guarantee defn-item-value? value 'defn-item)
-  (%defn-item id value #f))
+  (%defn-item ctx id value #f))
 
 (define (defn-item-value? object)
   (not (reserved-name-item? object)))
 (register-predicate! defn-item-value? 'defn-item-value)
 
 (define-record-type <defn-item>
-    (%defn-item id value syntax?)
+    (%defn-item ctx id value syntax?)
     defn-item?
+  (ctx defn-item-ctx)
   (id defn-item-id)
   (value defn-item-value)
   (syntax? defn-item-syntax?))
@@ -90,16 +91,17 @@ USA.
 
 ;;; Sequence items.
 
-(define (seq-item elements)
+(define (seq-item ctx elements)
   (let ((elements (flatten-items elements)))
     (if (and (pair? elements)
 	     (null? (cdr elements)))
 	(car elements)
-	(%seq-item elements))))
+	(%seq-item ctx elements))))
 
 (define-record-type <seq-item>
-    (%seq-item elements)
+    (%seq-item ctx elements)
     seq-item?
+  (ctx seq-item-ctx)
   (elements seq-item-elements))
 
 (define (flatten-items items)
@@ -114,87 +116,26 @@ USA.
 ;;; run-time variable or a sequence.
 
 (define-record-type <expr-item>
-    (expr-item compiler)
+    (expr-item ctx compiler)
     expr-item?
+  (ctx expr-item-ctx)
   (compiler expr-item-compiler))
-
-;;;; Specific expression items
-
-(define (combination-item operator operands)
-  (expr-item
-   (lambda ()
-     (output/combination (compile-expr-item operator)
-			 (map compile-expr-item operands)))))
-
-(define (constant-item datum)
-  (expr-item
-   (lambda ()
-     (output/constant datum))))
-
-(define (lambda-item name bvl classify-body)
-  (expr-item
-   (lambda ()
-     (output/lambda name bvl (compile-item (classify-body))))))
-
-(define (let-item names value-items body-item)
-  (expr-item
-   (lambda ()
-     (output/let names
-		 (map compile-expr-item value-items)
-		 (compile-item body-item)))))
-
-(define (body-item items)
-  (expr-item
-   (lambda ()
-     (output/body (map compile-item (flatten-items items))))))
-
-(define (if-item predicate consequent alternative)
-  (expr-item
-   (lambda ()
-     (output/conditional (compile-expr-item predicate)
-			 (compile-expr-item consequent)
-			 (compile-expr-item alternative)))))
-
-(define (quoted-id-item var-item)
-  (expr-item
-   (lambda ()
-     (output/quoted-identifier (var-item-id var-item)))))
-
-(define (assignment-item id rhs-item)
-  (expr-item
-   (lambda ()
-     (output/assignment id (compile-expr-item rhs-item)))))
-
-(define (access-assignment-item name env-item rhs-item)
-  (expr-item
-   (lambda ()
-     (output/access-assignment name
-			       (compile-expr-item env-item)
-			       (compile-expr-item rhs-item)))))
-
-(define (delay-item classify)
-  (expr-item
-   (lambda ()
-     (output/delay (compile-expr-item (classify))))))
-
-(define (or-item items)
-  (expr-item
-   (lambda ()
-     (output/disjunction (map compile-expr-item items)))))
-
-(define (decl-item classify)
-  (expr-item
-   (lambda ()
-     (output/declaration (classify)))))
-
-(define (the-environment-item)
-  (expr-item output/the-environment))
-
-(define (unspecific-item)
-  (expr-item output/unspecific))
-
-(define (unassigned-item)
-  (expr-item output/unassigned))
+
+(define (body-item ctx items)
+  (expr-item ctx
+    (lambda ()
+      (output/body (map compile-item (flatten-items items))))))
+
+(define (combination-item ctx operator operands)
+  (expr-item ctx
+    (lambda ()
+      (output/combination (compile-expr-item operator)
+			  (map compile-expr-item operands)))))
+
+(define (constant-item ctx datum)
+  (expr-item ctx
+    (lambda ()
+      (output/constant datum))))
 
 ;;;; Compiler
 
diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index 3d98702ff..7e3a1a5f5 100644
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -157,6 +157,8 @@ USA.
 	((eq? arg spar-arg:close) (make-closer (%input-closing-senv input)))
 	((eq? arg spar-arg:compare)
 	 (make-comparer (%input-closing-senv input) senv))
+	((eq? arg spar-arg:ctx)
+	 (serror-ctx (%input-form input) senv (%input-hist input)))
 	((eq? arg spar-arg:senv) senv)
 	((eq? arg spar-arg:value) (%output-top output))
 	((eq? arg spar-arg:values) (%output-all output))
@@ -175,6 +177,7 @@ USA.
 (define-deferred spar-arg:hist (string->uninterned-symbol ".hist."))
 (define-deferred spar-arg:close (string->uninterned-symbol ".close."))
 (define-deferred spar-arg:compare (string->uninterned-symbol ".compare."))
+(define-deferred spar-arg:ctx (string->uninterned-symbol ".ctx."))
 (define-deferred spar-arg:senv (string->uninterned-symbol ".senv."))
 (define-deferred spar-arg:value (string->uninterned-symbol ".value."))
 (define-deferred spar-arg:values (string->uninterned-symbol ".values."))
@@ -412,18 +415,6 @@ USA.
      (declare (ignore senv))
      (lambda (senv*)
        (classify-form form senv* hist)))))
-
-(define-deferred spar-push-body
-  (spar-and
-    (spar-encapsulate-values
-	(lambda (elts)
-	  (lambda (frame-senv)
-	    (let ((body-senv (make-internal-senv frame-senv)))
-	      (map-in-order (lambda (elt) (elt body-senv))
-			    elts))))
-      (spar+ (spar-elt spar-push-open-classified))
-      (spar-match-null))
-    (spar-push spar-arg:senv)))
 
 ;;;; Value combinators
 
diff --git a/src/runtime/syntax-rules.scm b/src/runtime/syntax-rules.scm
index ea233b723..74bdb2eb6 100644
--- a/src/runtime/syntax-rules.scm
+++ b/src/runtime/syntax-rules.scm
@@ -253,7 +253,7 @@ USA.
   `(,(classifier->keyword
       (lambda (form senv hist)
 	(scheck '(_ datum) form senv hist)
-	(constant-item (cadr form))))
+	(constant-item (serror-ctx form senv hist) (cadr form))))
     ,expression))
 
 (define (optimized-cons rename compare a d)
diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index 26a74006b..4d890d7f9 100644
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -55,10 +55,10 @@ USA.
     (with-identifier-renaming
      (lambda ()
        (compile-item
-	(body-item
-	 (map-in-order (lambda (form)
-			 (classify-form form senv (initial-hist form)))
-		       forms)))))))
+	(body-item #f
+	  (map-in-order (lambda (form)
+			  (classify-form form senv (initial-hist form)))
+			forms)))))))
 
 ;;;; Classifier
 
@@ -79,16 +79,16 @@ USA.
 	 (let ((item (classify-form (car form) senv (hist-car hist))))
 	   (if (keyword-item? item)
 	       ((keyword-item-impl item) form senv hist)
-	       (begin
+	       (let ((ctx (serror-ctx form senv hist)))
 		  (if (not (list? (cdr form)))
-		      (serror (serror-ctx form senv hist)
-			      "Combination must be a proper list:" form))
-		  (combination-item item
+		      (serror ctx "Combination must be a proper list:" form))
+		  (combination-item ctx
+				    item
 				    (classify-forms (cdr form)
 						    senv
 						    (hist-cdr hist)))))))
 	(else
-	 (constant-item form))))
+	 (constant-item (serror-ctx form senv hist) form))))
 
 (define (reclassify form env hist)
   (classify-form form env (hist-reduce form hist)))
-- 
2.25.1