From 278aed1c13ba183458a9e4cd6ec66df1dadf98c9 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 26 Jan 2012 23:55:24 -0500 Subject: [PATCH] Fix error messages involving internal definitions * module/ice-9/psyntax.scm (syntax-type): Return an additional value that contains the entire form in _all_ cases, including for definition forms. Previously, the entire form was not returned for definition forms. (expand-expr): Add an additional argument that contains the entire form in _all_ cases, including for definition forms. Use it to include the entire form in the error message for internal definitions in contexts where they are not allowed, and improve the error message to be more comprehensible for Scheme beginners. Also include the source location information, which was previously missing from the error message. (expand-top-sequence, expand, expand-body): Receive the additional return value from 'syntax-type'. * module/ice-9/psyntax-pp.scm: Regenerate. * NEWS: Add news entry. --- NEWS | 1 + module/ice-9/psyntax-pp.scm |12980 ++++++++++++++++++++++--------------------- module/ice-9/psyntax.scm | 75 +- 3 files changed, 6587 insertions(+), 6469 deletions(-) diff --git a/NEWS b/NEWS index ad0910c..5a74fc9 100644 --- a/NEWS +++ b/NEWS @@ -173,6 +173,7 @@ Search the manual for these identifiers and modules, for more. ** Fix serialization. ** Fix erroneous check in `set-procedure-properties!'. ** Fix generalized-vector-{ref,set!} for slices. +** Fix error messages involving internal definitions. ** HTTP: Extend handling of "Cache-Control" header. ** HTTP: Fix qstring writing of cache-extension values ** HTTP: Fix validators for various list-style headers. diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 20ea8eb..9812f3a 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -982,7 +982,7 @@ (lambda () (let ((e (car body))) (syntax-type e r w (or (source-annotation e) s) #f mod #f))) - (lambda (type value e w s mod) + (lambda (type value form e w s mod) (case type ((begin-form) (syntax-case e () @@ -1079,18 +1079,20 @@ exps))) ((displaced-lexical) (syntax-violation #f "identifier out of context" - e (wrap value w mod))) + (source-wrap form w s mod) + (wrap value w mod))) (else (syntax-violation #f "cannot define keyword at top level" - e (wrap value w mod)))))) + (source-wrap form w s mod) + (wrap value w mod)))))) (else (values (cons (if (eq? m 'c&e) - (let ((x (expand-expr type value e r w s mod))) + (let ((x (expand-expr type value form e r w s mod))) (top-level-eval-hook x mod) x) (lambda () - (expand-expr type value e r w s mod))) + (expand-expr type value form e r w s mod))) exps))))))) (lambda (exps) (scan (cdr body) r w s m esew mod exps)))))) @@ -1132,8 +1134,8 @@ (syntax-violation 'eval-when "invalid situation" e (car l)))))))) - ;; syntax-type returns six values: type, value, e, w, s, and mod. The - ;; first two are described in the table below. + ;; syntax-type returns seven values: type, value, form, e, w, s, and + ;; mod. The first two are described in the table below. ;; ;; type value explanation ;; ------------------------------------------------------------------- @@ -1162,10 +1164,11 @@ ;; constant none self-evaluating datum ;; other none anything else ;; - ;; For definition forms (define-form, define-syntax-parameter-form, - ;; and define-syntax-form), e is the rhs expression. For all - ;; others, e is the entire form. w is the wrap for e. s is the - ;; source for the entire form. mod is the module for e. + ;; form is the entire form. For definition forms (define-form, + ;; define-syntax-form, and define-syntax-parameter-form), e is the + ;; rhs expression. For all others, e is the entire form. w is the + ;; wrap for both form and e. s is the source for the entire form. + ;; mod is the module for both form and e. ;; ;; syntax-type expands macros and unwraps as necessary to get to one ;; of the forms above. It also parses definition forms, although @@ -1179,28 +1182,28 @@ (b (lookup n r mod)) (type (binding-type b))) (case type - ((lexical) (values type (binding-value b) e w s mod)) - ((global) (values type n e w s mod)) + ((lexical) (values type (binding-value b) e e w s mod)) + ((global) (values type n e e w s mod)) ((macro) (if for-car? - (values type (binding-value b) e w s mod) + (values type (binding-value b) e e w s mod) (syntax-type (expand-macro (binding-value b) e r w s rib mod) r empty-wrap s rib mod #f))) - (else (values type (binding-value b) e w s mod))))) + (else (values type (binding-value b) e e w s mod))))) ((pair? e) (let ((first (car e))) (call-with-values (lambda () (syntax-type first r w s rib mod #t)) - (lambda (ftype fval fe fw fs fmod) + (lambda (ftype fval fform fe fw fs fmod) (case ftype ((lexical) - (values 'lexical-call fval e w s mod)) + (values 'lexical-call fval e e w s mod)) ((global) ;; If we got here via an (@@ ...) expansion, we need to ;; make sure the fmod information is propagated back ;; correctly -- hence this consing. (values 'global-call (make-syntax-object fval w fmod) - e w s mod)) + e e w s mod)) ((macro) (syntax-type (expand-macro fval e r w s rib mod) r empty-wrap s rib mod for-car?)) @@ -1209,23 +1212,24 @@ (lambda (e r w s mod) (syntax-type e r w s rib mod for-car?)))) ((core) - (values 'core-form fval e w s mod)) + (values 'core-form fval e e w s mod)) ((local-syntax) - (values 'local-syntax-form fval e w s mod)) + (values 'local-syntax-form fval e e w s mod)) ((begin) - (values 'begin-form #f e w s mod)) + (values 'begin-form #f e e w s mod)) ((eval-when) - (values 'eval-when-form #f e w s mod)) + (values 'eval-when-form #f e e w s mod)) ((define) (syntax-case e () ((_ name val) (id? #'name) - (values 'define-form #'name #'val w s mod)) + (values 'define-form #'name e #'val w s mod)) ((_ (name . args) e1 e2 ...) (and (id? #'name) (valid-bound-ids? (lambda-var-list #'args))) ;; need lambda here... (values 'define-form (wrap #'name w mod) + (wrap e w mod) (decorate-source (cons #'lambda (wrap #'(args e1 e2 ...) w mod)) s) @@ -1233,38 +1237,39 @@ ((_ name) (id? #'name) (values 'define-form (wrap #'name w mod) + (wrap e w mod) #'(if #f #f) empty-wrap s mod)))) ((define-syntax) (syntax-case e () ((_ name val) (id? #'name) - (values 'define-syntax-form #'name #'val w s mod)))) + (values 'define-syntax-form #'name e #'val w s mod)))) ((define-syntax-parameter) (syntax-case e () ((_ name val) (id? #'name) - (values 'define-syntax-parameter-form #'name #'val w s mod)))) + (values 'define-syntax-parameter-form #'name e #'val w s mod)))) (else - (values 'call #f e w s mod))))))) + (values 'call #f e e w s mod))))))) ((syntax-object? e) (syntax-type (syntax-object-expression e) r (join-wraps w (syntax-object-wrap e)) (or (source-annotation e) s) rib (or (syntax-object-module e) mod) for-car?)) - ((self-evaluating? e) (values 'constant #f e w s mod)) - (else (values 'other #f e w s mod))))) + ((self-evaluating? e) (values 'constant #f e e w s mod)) + (else (values 'other #f e e w s mod))))) (define expand (lambda (e r w mod) (call-with-values (lambda () (syntax-type e r w (source-annotation e) #f mod #f)) - (lambda (type value e w s mod) - (expand-expr type value e r w s mod))))) + (lambda (type value form e w s mod) + (expand-expr type value form e r w s mod))))) (define expand-expr - (lambda (type value e r w s mod) + (lambda (type value form e r w s mod) (case type ((lexical) (build-lexical-reference 'value s e value)) @@ -1318,8 +1323,8 @@ (expand-sequence #'(e1 e2 ...) r w s mod) (expand-void)))))) ((define-form define-syntax-form define-syntax-parameter-form) - (syntax-violation #f "definition in expression context" - e (wrap value w mod))) + (syntax-violation #f "internal definition in a context where definitions are not allowed" + (source-wrap form w s mod))) ((syntax) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap e w s mod))) @@ -1463,7 +1468,7 @@ (let ((e (cdar body)) (er (caar body))) (call-with-values (lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod #f)) - (lambda (type value e w s mod) + (lambda (type value form e w s mod) (case type ((define-form) (let ((id (wrap value w mod)) (label (gen-label))) @@ -2222,7 +2227,7 @@ ((_ (head tail ...) val) (call-with-values (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t)) - (lambda (type value ee ww ss modmod) + (lambda (type value formform ee ww ss modmod) (case type ((module-ref) (let ((val (expand #'val r w mod))) -- 1.7.5.4