From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 15 Feb 2018 03:29:32 +0000 (-0800)
Subject: Refactor the syntax-error mechanism.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~241
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4da2f21cc445dae8169ef4f6efd97232bbf2c6c6;p=mit-scheme.git

Refactor the syntax-error mechanism.

* There's now a condition type for syntax errors.
* There's a distinction between errors that happen in macro expanders and those
  that happen inside the syntax implementation.
* All syntax errors now get the (form senv hist) objects.
* Syntax errors don't yet use the history to report context; that will come
  later.
---

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index abfa61f79..73c429ac0 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -531,6 +531,7 @@ USA.
    (RUNTIME EXTENDED-SCODE-EVAL)
    (runtime syntax items)
    (runtime syntax rename)
+   (runtime syntax top-level)
    ;; REP Loops
    (RUNTIME INTERRUPT-HANDLER)
    (RUNTIME GC-STATISTICS)
diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index 15ff888b4..7c6f3fb8f 100644
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -33,7 +33,7 @@ USA.
 
 (define (transformer-keyword procedure-name transformer->expander)
   (lambda (form senv hist)
-    (syntax-check '(_ expression) form)
+    (scheck '(_ expression) form senv hist)
     (let ((transformer (compile-expr-item (classify-form-cadr form senv hist))))
       (transformer->expander (transformer-eval transformer senv)
 			     senv
@@ -68,7 +68,7 @@ USA.
 (define :lambda
   (classifier->runtime
    (lambda (form senv hist)
-     (syntax-check '(_ mit-bvl + form) form)
+     (scheck '(_ mit-bvl + form) form senv hist)
      (classify-lambda scode-lambda-name:unnamed
 		      (cadr form)
 		      form senv hist))))
@@ -76,7 +76,7 @@ USA.
 (define :named-lambda
   (classifier->runtime
    (lambda (form senv hist)
-     (syntax-check '(_ (identifier . mit-bvl) + form) form)
+     (scheck '(_ (identifier . mit-bvl) + form) form senv hist)
      (classify-lambda (identifier->symbol (caadr form))
 		      (cdadr form)
 		      form senv hist))))
@@ -97,19 +97,19 @@ USA.
 (define :delay
   (classifier->runtime
    (lambda (form senv hist)
-     (syntax-check '(_ expression) form)
+     (scheck '(_ expression) form senv hist)
      (delay-item (lambda () (classify-form-cadr form senv hist))))))
 
 (define :begin
   (classifier->runtime
    (lambda (form senv hist)
-     (syntax-check '(_ * form) form)
+     (scheck '(_ * form) form senv hist)
      (seq-item (classify-forms-in-order-cdr form senv hist)))))
 
 (define :if
   (classifier->runtime
    (lambda (form senv hist)
-     (syntax-check '(_ expression expression ? expression) form)
+     (scheck '(_ expression expression ? expression) form senv hist)
      (if-item (classify-form-cadr form senv hist)
 	      (classify-form-caddr form senv hist)
 	      (if (pair? (cdddr form))
@@ -119,24 +119,22 @@ USA.
 (define :quote
   (classifier->runtime
    (lambda (form senv hist)
-     (declare (ignore senv hist))
-     (syntax-check '(_ datum) form)
+     (scheck '(_ datum) form senv hist)
      (constant-item (strip-syntactic-closures (cadr form))))))
 
 (define :quote-identifier
   (classifier->runtime
    (lambda (form senv hist)
-     (declare (ignore hist))
-     (syntax-check '(_ identifier) form)
+     (scheck '(_ identifier) form senv hist)
      (let ((item (lookup-identifier (cadr form) senv)))
        (if (not (var-item? item))
-	   (syntax-error "Can't quote a keyword identifier:" form))
+	   (serror form senv hist "Can't quote a keyword identifier:" form))
        (quoted-id-item item)))))
 
 (define :set!
   (classifier->runtime
    (lambda (form senv hist)
-     (syntax-check '(_ form ? expression) form)
+     (scheck '(_ form ? expression) form senv hist)
      (let ((lhs-item (classify-form-cadr form senv hist))
 	   (rhs-item
 	    (if (pair? (cddr form))
@@ -149,8 +147,8 @@ USA.
 				      (access-item-env lhs-item)
 				      rhs-item))
 	     (else
-	      (syntax-error "Variable required in this context:"
-			    (cadr form))))))))
+	      (serror form senv hist "Variable required in this context:"
+		      (cadr form))))))))
 
 ;; TODO: this is a classifier rather than a macro because it uses the
 ;; special OUTPUT/DISJUNCTION.  Unfortunately something downstream in
@@ -159,7 +157,7 @@ USA.
 (define :or
   (classifier->runtime
    (lambda (form senv hist)
-     (syntax-check '(_ * expression) form)
+     (scheck '(_ * expression) form senv hist)
      (or-item (classify-forms-cdr form senv hist)))))
 
 ;;;; Definitions
@@ -173,7 +171,7 @@ USA.
 (define :define-syntax
   (classifier->runtime
    (lambda (form senv hist)
-     (syntax-check '(_ identifier expression) form)
+     (scheck '(_ identifier expression) form senv hist)
      (let ((name (cadr form))
 	   (item (classify-keyword-value-caddr form senv hist)))
        (bind-keyword name senv item)
@@ -186,7 +184,7 @@ USA.
 (define (classify-keyword-value form senv hist)
   (let ((item (classify-form form senv hist)))
     (if (not (keyword-item? item))
-	(syntax-error "Keyword binding value must be a keyword:" form))
+	(serror form senv hist "Keyword binding value must be a keyword:" form))
     item))
 
 (define (classify-keyword-value-cadr form senv hist)
@@ -215,7 +213,7 @@ USA.
 						hist)))))))
 
 (define (classifier:let-syntax form senv hist)
-  (syntax-check '(_ (* (identifier expression)) + form) form)
+  (scheck '(_ (* (identifier expression)) + form) form senv hist)
   (let ((body-senv (make-internal-senv senv)))
     (sfor-each (lambda (binding hist)
 		 (bind-keyword (car binding)
@@ -223,8 +221,7 @@ USA.
 			       (classify-keyword-value-cadr binding senv hist)))
 	       (cadr form)
 	       (hist-cadr hist))
-    (seq-item
-     (classify-forms-in-order-cddr form body-senv hist))))
+    (seq-item (classify-forms-in-order-cddr form body-senv hist))))
 
 (define :let-syntax
   (classifier->runtime classifier:let-syntax))
@@ -235,7 +232,7 @@ USA.
 (define :letrec-syntax
   (classifier->runtime
    (lambda (form senv hist)
-     (syntax-check '(_ (* (identifier expression)) + form) form)
+     (scheck '(_ (* (identifier expression)) + form) form senv hist)
      (let ((vals-senv (make-internal-senv senv)))
        (let ((bindings (cadr form))
 	     (hist (hist-cadr hist)))
@@ -278,10 +275,9 @@ USA.
 (define :the-environment
   (classifier->runtime
    (lambda (form senv hist)
-     (declare (ignore hist))
-     (syntax-check '(_) form)
+     (scheck '(_) form senv hist)
      (if (not (senv-top-level? senv))
-	 (syntax-error "This form allowed only at top level:" form))
+	 (serror form senv hist "This form allowed only at top level:" form))
      (the-environment-item))))
 
 (define keyword:unspecific
@@ -301,7 +297,7 @@ USA.
 (define :declare
   (classifier->runtime
    (lambda (form senv hist)
-     (syntax-check '(_ * (identifier * datum)) form)
+     (scheck '(_ * (identifier * datum)) form senv hist)
      (decl-item
       (lambda ()
 	(smap (lambda (decl hist)
@@ -316,5 +312,5 @@ USA.
 (define (classify-id id senv hist)
   (let ((item (classify-form id senv hist)))
     (if (not (var-item? item))
-	(syntax-error "Variable required in this context:" id))
+	(serror 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 212a23e41..4e3fd703a 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4408,7 +4408,6 @@ USA.
 	  biselect-cddr
 	  biselect-cdr
 	  biselect-list-elts
-	  biselect-subform
 	  biselector:cadddr
 	  biselector:caddr
 	  biselector:cadr
@@ -4427,6 +4426,8 @@ USA.
 	  classify-forms-cdr
 	  classify-forms-in-order-cddr
 	  classify-forms-in-order-cdr
+	  classify-subform
+	  error:syntax
 	  hist-caddr
 	  hist-cadr
 	  hist-car
@@ -4436,8 +4437,10 @@ USA.
 	  hist-select
 	  initial-hist
 	  raw-identifier?
+	  serror
 	  sfor-each
-	  smap))
+	  smap
+	  subform-select))
 
 (define-package (runtime syntax items)
   (files "syntax-items")
@@ -4522,7 +4525,9 @@ USA.
 	  ill-formed-syntax
 	  syntax-check
 	  syntax-match?
-	  syntax-match?*))
+	  syntax-match?*)
+  (export (runtime syntax)
+	  scheck))
 
 (define-package (runtime syntax rename)
   (files "syntax-rename")
diff --git a/src/runtime/syntax-check.scm b/src/runtime/syntax-check.scm
index 0b6bb647b..3004bde89 100644
--- a/src/runtime/syntax-check.scm
+++ b/src/runtime/syntax-check.scm
@@ -29,6 +29,12 @@ USA.
 
 (declare (usual-integrations))
 
+;;; 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)))
+
+;;; External checker for macros.
 (define (syntax-check pattern form)
   (if (not (syntax-match? (cdr pattern) (cdr form)))
       (ill-formed-syntax form)))
diff --git a/src/runtime/syntax-environment.scm b/src/runtime/syntax-environment.scm
index cd703cc80..54ac0ab93 100644
--- a/src/runtime/syntax-environment.scm
+++ b/src/runtime/syntax-environment.scm
@@ -50,12 +50,8 @@ USA.
 
 (define lookup-identifier
   (id-dispatcher (lambda (identifier senv)
-		   (let ((item ((senv-lookup senv) identifier)))
-		     (if (reserved-name-item? item)
-			 (syntax-error "Premature reference to reserved name:"
-				       identifier))
-		     (or item
-			 (var-item identifier))))
+		   (or ((senv-lookup senv) identifier)
+		       (var-item identifier)))
 		 'lookup-identifier))
 
 (define reserve-identifier
@@ -211,10 +207,7 @@ USA.
 	     => (lambda (binding)
 		  (set-cdr! binding item)))
 	    ((assq identifier free)
-	     (if (reserved-name-item? item)
-		 (syntax-error "Premature reference to reserved name:"
-			       identifier)
-		 (error "Can't define name; already free:" identifier)))
+	     (error "Can't define name; already free:" identifier))
 	    (else
 	     (set! bound (cons (cons identifier item) bound))
 	     unspecific)))
diff --git a/src/runtime/syntax-items.scm b/src/runtime/syntax-items.scm
index c0db7aac3..6be040b91 100644
--- a/src/runtime/syntax-items.scm
+++ b/src/runtime/syntax-items.scm
@@ -253,7 +253,7 @@ USA.
 (define (illegal-expression-compiler description)
   (let ((message (string description " may not be used as an expression:")))
     (lambda (item)
-      (syntax-error message item))))
+      (error message item))))
 
 (define-item-compiler reserved-name-item?
   (illegal-expression-compiler "Reserved name"))
diff --git a/src/runtime/syntax-rules.scm b/src/runtime/syntax-rules.scm
index 6f94dc051..ea233b723 100644
--- a/src/runtime/syntax-rules.scm
+++ b/src/runtime/syntax-rules.scm
@@ -252,8 +252,7 @@ USA.
 (define (syntax-quote expression)
   `(,(classifier->keyword
       (lambda (form senv hist)
-	(declare (ignore senv hist))
-	(syntax-check '(_ datum) form)
+	(scheck '(_ datum) form senv hist)
 	(constant-item (cadr form))))
     ,expression))
 
diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index 866583009..9d6f506dd 100644
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -76,28 +76,35 @@ USA.
 	   (cond ((classifier-item? item)
 		  ((classifier-item-impl item) form senv hist))
 		 ((expander-item? item)
-		  (reclassify ((expander-item-impl item) form senv)
+		  (reclassify (with-error-context form senv hist
+				(lambda ()
+				  ((expander-item-impl item) form senv)))
 			      senv
 			      hist))
 		 (else
 		  (if (not (list? (cdr form)))
-		      (syntax-error "Combination must be a proper list:" form))
+		      (serror form senv hist "Combination must be a proper list:" form))
 		  (combination-item item
 				    (classify-forms-cdr form senv hist))))))
 	(else
 	 (constant-item form))))
 
+(define (classify-subform selector form senv hist)
+  (classify-form (subform-select selector form)
+		 senv
+		 (hist-select selector hist)))
+
 (define (classify-form-car form senv hist)
-  (classify-form (car form) senv (hist-car hist)))
+  (classify-subform biselector:car form senv hist))
 
 (define (classify-form-cadr form senv hist)
-  (classify-form (cadr form) senv (hist-cadr hist)))
+  (classify-subform biselector:cadr form senv hist))
 
 (define (classify-form-caddr form senv hist)
-  (classify-form (caddr form) senv (hist-caddr hist)))
+  (classify-subform biselector:caddr form senv hist))
 
 (define (classify-form-cadddr form senv hist)
-  (classify-form (cadddr form) senv (hist-cadddr hist)))
+  (classify-subform biselector:cadddr form senv hist))
 
 (define (reclassify form env hist)
   (classify-form form env (hist-reduce form hist)))
@@ -289,10 +296,10 @@ USA.
 	    (biselect-list-elts (cdr list) (biselect-cdr selector)))
       '()))
 
-(define (biselect-subform selector form)
+(define (subform-select selector form)
   (if (> selector 1)
-      (biselect-subform (quotient selector 2)
-			(if (even? selector) (car form) (cdr form)))
+      (subform-select (quotient selector 2)
+		      (if (even? selector) (car form) (cdr form)))
       form))
 
 (define-integrable biselector:cr     #b00001)
@@ -305,11 +312,41 @@ USA.
 (define-integrable biselector:cadddr #b10111)
 (define-integrable biselector:cddddr #b11111)
 
+;;;; Errors
+
+(define-deferred condition-type:syntax-error
+  (make-condition-type 'syntax-error
+      condition-type:simple-error
+      '(form senv hist message irritants)
+    (lambda (condition port)
+      (format-error-message (access-condition condition 'message)
+			    (access-condition condition 'irritants)
+			    port))))
+
+(define-deferred error:syntax
+  (condition-signaller condition-type:syntax-error
+		       (default-object)
+		       standard-error-handler))
+
+;;; Internal signaller for classifiers.
+(define (serror form senv hist message . irritants)
+  (error:syntax form senv hist message irritants))
+
+(define-deferred error-context
+  (make-unsettable-parameter unspecific))
+
+(define (with-error-context form senv hist thunk)
+  (parameterize* (list (cons error-context (list form senv hist)))
+		 thunk))
+
+;;; External signaller for macros.
+(define (syntax-error message . irritants)
+  (let ((context (error-context)))
+    (error:syntax (car context) (cadr context) (caddr context)
+		  message irritants)))
+
 ;;;; Utilities
 
-(define (syntax-error . rest)
-  (apply error rest))
-
 (define (classifier->keyword classifier)
   (close-syntax 'keyword
 		(make-keyword-senv 'keyword