* 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.
(RUNTIME EXTENDED-SCODE-EVAL)
(runtime syntax items)
(runtime syntax rename)
+ (runtime syntax top-level)
;; REP Loops
(RUNTIME INTERRUPT-HANDLER)
(RUNTIME GC-STATISTICS)
(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
(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))))
(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))))
(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))
(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)))))
\f
(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))
(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
(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
(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)
(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)
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)
(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))
(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)))
(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
(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)
(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
biselect-cddr
biselect-cdr
biselect-list-elts
- biselect-subform
biselector:cadddr
biselector:caddr
biselector:cadr
classify-forms-cdr
classify-forms-in-order-cddr
classify-forms-in-order-cdr
+ classify-subform
+ error:syntax
hist-caddr
hist-cadr
hist-car
hist-select
initial-hist
raw-identifier?
+ serror
sfor-each
- smap))
+ smap
+ subform-select))
(define-package (runtime syntax items)
(files "syntax-items")
ill-formed-syntax
syntax-check
syntax-match?
- syntax-match?*))
+ syntax-match?*)
+ (export (runtime syntax)
+ scheck))
(define-package (runtime syntax rename)
(files "syntax-rename")
(declare (usual-integrations))
\f
+;;; 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)))
(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
=> (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)))
(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"))
(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))
(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)))
(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)
(define-integrable biselector:cadddr #b10111)
(define-integrable biselector:cddddr #b11111)
\f
+;;;; 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)))
+\f
;;;; Utilities
-(define (syntax-error . rest)
- (apply error rest))
-
(define (classifier->keyword classifier)
(close-syntax 'keyword
(make-keyword-senv 'keyword
projects / mit-scheme.git / commitdiff