From 4da2f21cc445dae8169ef4f6efd97232bbf2c6c6 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 14 Feb 2018 19:29:32 -0800
Subject: [PATCH] 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.
---
src/runtime/make.scm | 1 +
src/runtime/mit-syntax.scm | 48 +++++++++++------------
src/runtime/runtime.pkg | 11 ++++--
src/runtime/syntax-check.scm | 6 +++
src/runtime/syntax-environment.scm | 13 ++-----
src/runtime/syntax-items.scm | 2 +-
src/runtime/syntax-rules.scm | 3 +-
src/runtime/syntax.scm | 61 ++++++++++++++++++++++++------
8 files changed, 91 insertions(+), 54 deletions(-)
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
--
2.25.1