From 4e89ce82abd61b7f5482e3504bd451f467400ba1 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 26 Mar 2018 22:07:07 -0700
Subject: [PATCH] Formalize the context of a syntax error.

---
 src/runtime/mit-syntax.scm    |  3 ++-
 src/runtime/runtime.pkg       |  6 +++++-
 src/runtime/syntax-check.scm  |  2 +-
 src/runtime/syntax-parser.scm |  6 ++----
 src/runtime/syntax.scm        | 26 ++++++++++++++------------
 5 files changed, 24 insertions(+), 19 deletions(-)

diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index bec68be66..95a636598 100644
--- 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 d7586c4c5..941bd25e4 100644
--- 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 3004bde89..2c6d93ff4 100644
--- 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 d48e54f06..3d98702ff 100644
--- 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))))
 
 ;;;; 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 a8df6d6ee..26a74006b 100644
--- 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.
 
 ;;;; 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))
 
 ;;;; Utilities
 
-- 
2.25.1