Add context to items, for errors that happen during item compilation.

diff --git a/src/edwin/clsmac.scm b/src/edwin/clsmac.scm
index 80ce279211f632d11a616f933b2c389fa28d839b..a3ecd2c72b7732daadbac6b251a76e524787274b 100644 (file)
--- 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 eb8dd7319a69da608a08368e7333c586c1a6430a..b4d620370e0cb2e12801cf1a019cf70459891955 100644 (file)
--- 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 95a636598f8dfeb8f00c391cead2767f326e13c7..f9273a8262b305b5295dab12e7f6e6702aadead3 100644 (file)
--- 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)))))
 \f
@@ -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)))))
-
+\f
 ;;;; 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))))))
 \f
 ;;;; 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)))))
 \f
 ;;;; 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)))))
 \f
 ;;;; 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)))
+\f
+;;;; 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 941bd25e4eca6b03e0106075e0a6c30ea2c92a86..25a1723a6d383cfcea19b86d53d72e916077b6a3 100644 (file)
--- 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 2017e509f4a8154a8a21733ca635e1aa7d12de16..b13ffb69b713b1cd1223cd9c48e0388091db6532 100644 (file)
--- a/src/runtime/syntax-items.scm
+++ b/src/runtime/syntax-items.scm
@@ -28,7 +28,7 @@ USA.
 
 (declare (usual-integrations))
 \f
-;;; 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))
-\f
-;;;; 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))))
 \f
 ;;;; Compiler
 

diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index 3d98702ff4b8f45a6456f4af65cc0ba14bb2657d..7e3a1a5f5080dfc51e15b66876a9b36f93c8f02a 100644 (file)
--- 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)))
 \f
 ;;;; Value combinators
 

diff --git a/src/runtime/syntax-rules.scm b/src/runtime/syntax-rules.scm
index ea233b723cd3fd2855ea1ab556b3719616ea7f60..74bdb2eb6c823bd7fda45fa2a6462eac45fc1a9e 100644 (file)
--- 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 26a74006b05ea8098085269c686c50f51e472469..4d890d7f9d432567427eb52a4c9acac938140cc4 100644 (file)
--- 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)))))))
 \f
 ;;;; 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)))