Formalize the context of a syntax error.

diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index bec68be6625f01548cf5d05d7abb427f9a4f0545..95a636598f8dfeb8f00c391cead2767f326e13c7 100644 (file)
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -369,5 +369,6 @@ USA.
 (define (classify-id id senv hist)
   (let ((item (classify-form id senv hist)))
     (if (not (var-item? item))
-       (serror id senv hist "Variable required in this context:" id))
+       (serror (serror-ctx id senv hist)
+               "Variable required in this context:" id))
     (var-item-id item)))
\ No newline at end of file

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index d7586c4c5584317f8f1f29553a1fdb40306105b6..941bd25e4eca6b03e0106075e0a6c30ea2c92a86 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4435,7 +4435,6 @@ USA.
          biselector:cdr
          biselector:cr
          classify-form
-         error:syntax
          hist-cadr
          hist-car
          hist-cddr
@@ -4445,6 +4444,11 @@ USA.
          initial-hist
          raw-identifier?
          serror
+         serror-ctx
+         serror-ctx-form
+         serror-ctx-hist
+         serror-ctx-senv
+         serror-ctx?
          smap
          subform-select)
   (export (runtime syntax low)

diff --git a/src/runtime/syntax-check.scm b/src/runtime/syntax-check.scm
index 3004bde89f03d22c75b7645db2fc5d0f60a8a1cc..2c6d93ff4f4c4654cbf2c9a466231f7a85d72e36 100644 (file)
--- a/src/runtime/syntax-check.scm
+++ b/src/runtime/syntax-check.scm
@@ -32,7 +32,7 @@ USA.
 ;;; Internal checker for classifiers.
 (define (scheck pattern form senv hist)
   (if (not (syntax-match? (cdr pattern) (cdr form)))
-      (serror form senv hist "Ill-formed special form:" form)))
+      (serror (serror-ctx form senv hist) "Ill-formed special form:" form)))
 
 ;;; External checker for macros.
 (define (syntax-check pattern form)

diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index d48e54f063bd1a2ca1082958112f18f9b684c236..3d98702ff4b8f45a6456f4af65cc0ba14bb2657d 100644 (file)
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -74,7 +74,7 @@ USA.
              (error "Rule failed to match entire form."))
          (output 'get-only))
        (lambda ()
-         (serror form use-senv hist "Ill-formed syntax:" form))))
+         (serror (serror-ctx form use-senv hist) "Ill-formed syntax:" form))))
 \f
 ;;;; Inputs and outputs
 
@@ -211,9 +211,7 @@ USA.
   (lambda (input senv output success failure)
     (declare (ignore success failure))
     (apply serror
-          (%input-form input)
-          senv
-          (%input-hist input)
+          (serror-ctx (%input-form input) senv (%input-hist input))
           message
           (%subst-args input senv output irritants))))
 

diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index a8df6d6ee3f54f077272ffa886b42182e3962ca9..26a74006b05ea8098085269c686c50f51e472469 100644 (file)
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -66,7 +66,7 @@ USA.
   (cond ((identifier? form)
         (let ((item (lookup-identifier form senv)))
           (if (reserved-name-item? item)
-              (serror form senv hist
+              (serror (serror-ctx form senv hist)
                       "Premature reference to reserved name:" form))
           item))
        ((syntactic-closure? form)
@@ -81,7 +81,7 @@ USA.
               ((keyword-item-impl item) form senv hist)
               (begin
                  (if (not (list? (cdr form)))
-                     (serror form senv hist
+                     (serror (serror-ctx form senv hist)
                              "Combination must be a proper list:" form))
                  (combination-item item
                                    (classify-forms (cdr form)
@@ -274,10 +274,17 @@ USA.
 \f
 ;;;; Errors
 
+(define-record-type <serror-ctx>
+    (serror-ctx form senv hist)
+    serror-ctx?
+  (form serror-ctx-form)
+  (senv serror-ctx-senv)
+  (hist serror-ctx-hist))
+
 (define-deferred condition-type:syntax-error
   (make-condition-type 'syntax-error
       condition-type:simple-error
-      '(form senv hist message irritants)
+      '(context message irritants)
     (lambda (condition port)
       (format-error-message (access-condition condition 'message)
                            (access-condition condition 'irritants)
@@ -289,24 +296,19 @@ USA.
                       standard-error-handler))
 
 ;;; Internal signaller for classifiers.
-(define (serror form senv hist message . irritants)
-  (error:syntax form senv hist message irritants))
+(define (serror ctx message . irritants)
+  (error:syntax ctx message irritants))
 
 (define-deferred error-context
   (make-unsettable-parameter unspecific))
 
 (define (with-error-context form senv hist thunk)
-  (parameterize* (list (cons error-context (vector form senv hist)))
+  (parameterize* (list (cons error-context (serror-ctx form senv hist)))
                 thunk))
 
 ;;; External signaller for macros.
 (define (syntax-error message . irritants)
-  (let ((context (error-context)))
-    (error:syntax (vector-ref context 0)
-                 (vector-ref context 1)
-                 (vector-ref context 2)
-                 message
-                 irritants)))
+  (error:syntax (error-context) message irritants))
 \f
 ;;;; Utilities