From: Chris Hanson Date: Tue, 27 Mar 2018 06:53:18 +0000 (-0700) Subject: Add context to items, for errors that happen during item compilation. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~174 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=17a8b97f187fef90b3c33f0973d4504b94dd5279;p=mit-scheme.git Add context to items, for errors that happen during item compilation. --- diff --git a/src/edwin/clsmac.scm b/src/edwin/clsmac.scm index 80ce27921..a3ecd2c72 100644 --- a/src/edwin/clsmac.scm +++ b/src/edwin/clsmac.scm @@ -101,14 +101,14 @@ USA. ,@(cddddr form)) senv rest))) - (expr-item - (lambda () - (transform-instance-variables - (class-instance-transforms - (name->class (identifier->symbol class-name))) - (compile-expr-item self-item) - free-names - (compile-item body-item)))))))) + (expr-item #f + (lambda () + (transform-instance-variables + (class-instance-transforms + (name->class (identifier->symbol class-name))) + (compile-expr-item self-item) + free-names + (compile-item body-item)))))))) (define-syntax ==> (syntax-rules () diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm index eb8dd7319..b4d620370 100644 --- a/src/runtime/host-adapter.scm +++ b/src/runtime/host-adapter.scm @@ -189,8 +189,11 @@ USA. env 'microcode-type)))) (let ((env (->environment '(runtime syntax)))) - (provide-rename env 'make-expression-item 'expr-item) (provide-rename env 'compile-item/expression 'compile-expr-item) + (if (unbound? env 'expr-item) + (eval '(define (expr-item ctx compiler) + (make-expression-item compiler)) + env)) (if (unbound? env 'compile-item) (eval '(define (compile-item body-item) (compile-body-items (item->list body-item))) diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm index 95a636598..f9273a826 100644 --- a/src/runtime/mit-syntax.scm +++ b/src/runtime/mit-syntax.scm @@ -42,10 +42,10 @@ USA. (transformer->keyword-item (transformer-eval transformer senv) senv - (expr-item - (lambda () - (output/top-level-syntax-expander transformer->expander-name - transformer))))))) + (expr-item (serror-ctx form senv hist) + (lambda () + (output/top-level-syntax-expander transformer->expander-name + transformer))))))) (define :sc-macro-transformer ;; "Syntactic Closures" transformer @@ -76,12 +76,13 @@ USA. (define :begin (spar-classifier->runtime (delay - (spar-encapsulate-values - (lambda (deferred-items) - (seq-item - (map-in-order (lambda (p) (p)) - deferred-items))) + (spar-call-with-values + (lambda (ctx . deferred-items) + (seq-item ctx + (map-in-order (lambda (p) (p)) + deferred-items))) (spar-elt) + (spar-push spar-arg:ctx) (spar* (spar-elt spar-push-deferred-classified)) (spar-match-null))))) @@ -90,10 +91,11 @@ USA. (delay (spar-call-with-values if-item (spar-elt) + (spar-push spar-arg:ctx) (spar-elt spar-push-classified) (spar-elt spar-push-classified) (spar-or (spar-elt spar-push-classified) - (spar-push-value unspecific-item)) + (spar-push-value unspecific-item spar-arg:ctx)) (spar-match-null))))) (define :quote @@ -101,6 +103,7 @@ USA. (delay (spar-call-with-values constant-item (spar-elt) + (spar-push spar-arg:ctx) (spar-elt (spar-push-value strip-syntactic-closures spar-arg:form)) (spar-match-null))))) @@ -109,6 +112,7 @@ USA. (delay (spar-call-with-values quoted-id-item (spar-elt) + (spar-push spar-arg:ctx) (spar-elt (spar-match identifier? spar-arg:form) (spar-push-value lookup-identifier spar-arg:form spar-arg:senv) @@ -121,13 +125,15 @@ USA. (spar-classifier->runtime (delay (spar-call-with-values - (lambda (lhs-item rhs-item) + (lambda (ctx lhs-item rhs-item) (if (var-item? lhs-item) - (assignment-item (var-item-id lhs-item) rhs-item) - (access-assignment-item (access-item-name lhs-item) + (assignment-item ctx (var-item-id lhs-item) rhs-item) + (access-assignment-item ctx + (access-item-name lhs-item) (access-item-env lhs-item) rhs-item))) (spar-elt) + (spar-push spar-arg:ctx) (spar-elt spar-push-classified (spar-or (spar-match (lambda (lhs-item) @@ -137,7 +143,7 @@ USA. (spar-error "Variable required in this context:" spar-arg:form))) (spar-or (spar-elt spar-push-classified) - (spar-push-value unassigned-item)) + (spar-push-value unassigned-item spar-arg:ctx)) (spar-match-null))))) ;; TODO: this is a classifier rather than a macro because it uses the @@ -147,8 +153,9 @@ USA. (define :or (spar-classifier->runtime (delay - (spar-encapsulate-values or-item + (spar-call-with-values or-item (spar-elt) + (spar-push spar-arg:ctx) (spar* (spar-elt spar-push-classified)) (spar-match-null))))) @@ -157,6 +164,7 @@ USA. (delay (spar-call-with-values delay-item (spar-elt) + (spar-push spar-arg:ctx) (spar-elt spar-push-deferred-classified) (spar-match-null))))) @@ -167,6 +175,7 @@ USA. (delay (spar-call-with-values defn-item (spar-elt) + (spar-push spar-arg:ctx) (spar-elt (spar-match identifier? spar-arg:form) (spar-push-value bind-variable spar-arg:form spar-arg:senv)) @@ -177,73 +186,91 @@ USA. (spar-classifier->runtime (delay (spar-call-with-values - (lambda (id senv item) + (lambda (ctx id item) (receive (id senv) (if (closed-identifier? id) (values (syntactic-closure-form id) (syntactic-closure-senv id)) - (values id senv)) + (values id (serror-ctx-senv ctx))) (bind-keyword id senv item) ;; User-defined macros at top level are preserved in the output. (if (and (keyword-item-has-expr? item) (senv-top-level? senv)) - (syntax-defn-item id (keyword-item-expr item)) - (seq-item '())))) + (syntax-defn-item ctx id (keyword-item-expr item)) + (seq-item ctx '())))) (spar-elt) + (spar-push spar-arg:ctx) (spar-push-elt-if identifier? spar-arg:form) - (spar-push spar-arg:senv) (spar-elt spar-push-classified (spar-or (spar-match keyword-item? spar-arg:value) (spar-error "Keyword binding value must be a keyword:" spar-arg:form))) (spar-match-null))))) - + ;;;; Lambdas (define :lambda (spar-classifier->runtime (delay (spar-call-with-values - (lambda (bvl body senv) - (assemble-lambda-item scode-lambda-name:unnamed bvl body senv)) + (lambda (ctx bvl body-ctx body) + (assemble-lambda-item ctx scode-lambda-name:unnamed bvl + body-ctx body)) (spar-elt) + (spar-push spar-arg:ctx) (spar-push-elt-if mit-lambda-list? spar-arg:form) - spar-push-body)))) + (spar-push-body))))) (define :named-lambda (spar-classifier->runtime (delay (spar-call-with-values - (lambda (name bvl body senv) - (assemble-lambda-item (identifier->symbol name) bvl body senv)) + (lambda (ctx name bvl body-ctx body) + (assemble-lambda-item ctx (identifier->symbol name) bvl + body-ctx body)) (spar-elt) + (spar-push spar-arg:ctx) (spar-elt (spar-push-elt-if identifier? spar-arg:form) (spar-push-form-if mit-lambda-list? spar-arg:form)) - spar-push-body)))) - -(define (assemble-lambda-item name bvl body senv) - (let ((frame-senv (make-internal-senv senv))) - (lambda-item name + (spar-push-body))))) + +(define (spar-push-body) + (spar-and + (spar-push spar-arg:ctx) + (spar-encapsulate-values + (lambda (elts) + (lambda (frame-senv) + (let ((body-senv (make-internal-senv frame-senv))) + (map-in-order (lambda (elt) (elt body-senv)) + elts)))) + (spar+ (spar-elt spar-push-open-classified)) + (spar-match-null)))) + +(define (assemble-lambda-item ctx name bvl body-ctx body) + (let ((frame-senv (make-internal-senv (serror-ctx-senv ctx)))) + (lambda-item ctx + name (map-mit-lambda-list (lambda (id) (bind-variable id frame-senv)) bvl) (lambda () - (body-item (body frame-senv)))))) + (body-item body-ctx (body frame-senv)))))) ;;;; LET-like (define spar-promise:let-syntax (delay (spar-call-with-values - (lambda (bindings body senv) - (let ((frame-senv (make-internal-senv senv))) + (lambda (ctx bindings body-ctx body) + (let ((frame-senv (make-internal-senv (serror-ctx-senv ctx)))) (for-each (lambda (binding) (bind-keyword (car binding) frame-senv (cdr binding))) bindings) - (seq-item (body frame-senv)))) + (seq-item body-ctx (body frame-senv)))) (spar-elt) + (spar-push spar-arg:ctx) (spar-elt (spar-call-with-values list (spar* @@ -252,7 +279,7 @@ USA. (spar-elt spar-push-classified) (spar-match-null))))) (spar-match-null)) - spar-push-body))) + (spar-push-body)))) (define :let-syntax (spar-classifier->runtime spar-promise:let-syntax)) @@ -264,8 +291,8 @@ USA. (spar-classifier->runtime (delay (spar-call-with-values - (lambda (bindings body senv) - (let ((frame-senv (make-internal-senv senv)) + (lambda (ctx bindings body-ctx body) + (let ((frame-senv (make-internal-senv (serror-ctx-senv ctx))) (ids (map car bindings))) (for-each (lambda (id) (reserve-identifier id frame-senv)) @@ -276,8 +303,9 @@ USA. (map (lambda (binding) ((cdr binding) frame-senv)) bindings)) - (seq-item (body frame-senv)))) + (seq-item body-ctx (body frame-senv)))) (spar-elt) + (spar-push spar-arg:ctx) (spar-elt (spar-call-with-values list (spar* @@ -286,13 +314,14 @@ USA. (spar-elt spar-push-open-classified) (spar-match-null))))) (spar-match-null)) - spar-push-body)))) + (spar-push-body))))) ;;;; MIT-specific syntax (define-record-type - (access-item name env) + (access-item ctx name env) access-item? + (ctx access-item-ctx) (name access-item-name) (env access-item-env)) @@ -301,6 +330,7 @@ USA. (delay (spar-call-with-values access-item (spar-elt) + (spar-push spar-arg:ctx) (spar-push-elt-if identifier? spar-arg:form) (spar-elt spar-push-classified) (spar-match-null))))) @@ -319,7 +349,7 @@ USA. spar-arg:form spar-arg:senv)) (spar-elt) (spar-match-null) - (spar-push-value the-environment-item))))) + (spar-push-value the-environment-item spar-arg:ctx))))) (define keyword:unspecific (spar-classifier->keyword @@ -327,7 +357,7 @@ USA. (spar-and (spar-elt) (spar-match-null) - (spar-push-value unspecific-item))))) + (spar-push-value unspecific-item spar-arg:ctx))))) (define keyword:unassigned (spar-classifier->keyword @@ -335,7 +365,7 @@ USA. (spar-and (spar-elt) (spar-match-null) - (spar-push-value unassigned-item))))) + (spar-push-value unassigned-item spar-arg:ctx))))) ;;;; Declarations @@ -343,20 +373,22 @@ USA. (spar-classifier->runtime (delay (spar-call-with-values - (lambda (senv hist decls) - (decl-item - (lambda () - (smap (lambda (decl hist) - (map-decl-ids (lambda (id selector) - (classify-id id - senv - (hist-select selector hist))) - decl)) - decls - (hist-cadr hist))))) + (lambda (ctx decls) + (let ((senv (serror-ctx-senv ctx)) + (hist (serror-ctx-hist ctx))) + (decl-item ctx + (lambda () + (smap (lambda (decl hist) + (map-decl-ids (lambda (id selector) + (classify-id id + senv + (hist-select selector + hist))) + decl)) + decls + (hist-cadr hist)))))) (spar-elt) - (spar-push spar-arg:senv) - (spar-push spar-arg:hist) + (spar-push spar-arg:ctx) (spar-call-with-values list (spar* (spar-push-elt-if (lambda (form) @@ -371,4 +403,59 @@ USA. (if (not (var-item? item)) (serror (serror-ctx id senv hist) "Variable required in this context:" id)) - (var-item-id item))) \ No newline at end of file + (var-item-id item))) + +;;;; Specific expression items + +(define (access-assignment-item ctx name env-item rhs-item) + (expr-item ctx + (lambda () + (output/access-assignment name + (compile-expr-item env-item) + (compile-expr-item rhs-item))))) + +(define (assignment-item ctx id rhs-item) + (expr-item ctx + (lambda () + (output/assignment id (compile-expr-item rhs-item))))) + +(define (decl-item ctx classify) + (expr-item ctx + (lambda () + (output/declaration (classify))))) + +(define (delay-item ctx classify) + (expr-item ctx + (lambda () + (output/delay (compile-expr-item (classify)))))) + +(define (if-item ctx predicate consequent alternative) + (expr-item ctx + (lambda () + (output/conditional (compile-expr-item predicate) + (compile-expr-item consequent) + (compile-expr-item alternative))))) + +(define (lambda-item ctx name bvl classify-body) + (expr-item ctx + (lambda () + (output/lambda name bvl (compile-item (classify-body)))))) + +(define (or-item ctx . items) + (expr-item ctx + (lambda () + (output/disjunction (map compile-expr-item items))))) + +(define (quoted-id-item ctx var-item) + (expr-item ctx + (lambda () + (output/quoted-identifier (var-item-id var-item))))) + +(define (the-environment-item ctx) + (expr-item ctx output/the-environment)) + +(define (unspecific-item ctx) + (expr-item ctx output/unspecific)) + +(define (unassigned-item ctx) + (expr-item ctx output/unassigned)) \ No newline at end of file diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 941bd25e4..25a1723a6 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4486,40 +4486,29 @@ USA. (files "syntax-items") (parent (runtime syntax)) (export (runtime syntax) - access-assignment-item - assignment-item body-item combination-item compile-expr-item compile-item constant-item - decl-item define-expr-item-compiler defn-item defn-item-id defn-item-syntax? defn-item-value defn-item? - delay-item expr-item expr-item-compiler + expr-item-ctx expr-item? flatten-items - if-item item->list - lambda-item - let-item - or-item - quoted-id-item reserved-name-item reserved-name-item? seq-item seq-item-elements seq-item? syntax-defn-item - the-environment-item - unassigned-item - unspecific-item var-item var-item-id var-item?)) @@ -4584,7 +4573,6 @@ USA. spar-opt spar-or spar-push - spar-push-body spar-push-elt spar-push-elt-if spar-push-form-if @@ -4595,6 +4583,7 @@ USA. spar-transform-values spar-with-mapped-senv) (export (runtime syntax) + spar-arg:ctx spar-call spar-push-classified spar-push-deferred-classified @@ -4607,6 +4596,7 @@ USA. scons-and scons-begin scons-call + scons-close scons-declare scons-define scons-delay diff --git a/src/runtime/syntax-items.scm b/src/runtime/syntax-items.scm index 2017e509f..b13ffb69b 100644 --- a/src/runtime/syntax-items.scm +++ b/src/runtime/syntax-items.scm @@ -28,7 +28,7 @@ USA. (declare (usual-integrations)) -;;; These items can be stored in a syntactic environment. +;;; These items (and keyword-item) can be stored in a syntactic environment. ;;; Variable items represent run-time variables. @@ -61,23 +61,24 @@ USA. ;;; Definition items, whether top-level or internal, keyword or variable. -(define (syntax-defn-item id value) +(define (syntax-defn-item ctx id value) (guarantee identifier? id 'syntax-defn-item) (guarantee defn-item-value? value 'syntax-defn-item) - (%defn-item id value #t)) + (%defn-item ctx id value #t)) -(define (defn-item id value) +(define (defn-item ctx id value) (guarantee identifier? id 'defn-item) (guarantee defn-item-value? value 'defn-item) - (%defn-item id value #f)) + (%defn-item ctx id value #f)) (define (defn-item-value? object) (not (reserved-name-item? object))) (register-predicate! defn-item-value? 'defn-item-value) (define-record-type - (%defn-item id value syntax?) + (%defn-item ctx id value syntax?) defn-item? + (ctx defn-item-ctx) (id defn-item-id) (value defn-item-value) (syntax? defn-item-syntax?)) @@ -90,16 +91,17 @@ USA. ;;; Sequence items. -(define (seq-item elements) +(define (seq-item ctx elements) (let ((elements (flatten-items elements))) (if (and (pair? elements) (null? (cdr elements))) (car elements) - (%seq-item elements)))) + (%seq-item ctx elements)))) (define-record-type - (%seq-item elements) + (%seq-item ctx elements) seq-item? + (ctx seq-item-ctx) (elements seq-item-elements)) (define (flatten-items items) @@ -114,87 +116,26 @@ USA. ;;; run-time variable or a sequence. (define-record-type - (expr-item compiler) + (expr-item ctx compiler) expr-item? + (ctx expr-item-ctx) (compiler expr-item-compiler)) - -;;;; Specific expression items - -(define (combination-item operator operands) - (expr-item - (lambda () - (output/combination (compile-expr-item operator) - (map compile-expr-item operands))))) - -(define (constant-item datum) - (expr-item - (lambda () - (output/constant datum)))) - -(define (lambda-item name bvl classify-body) - (expr-item - (lambda () - (output/lambda name bvl (compile-item (classify-body)))))) - -(define (let-item names value-items body-item) - (expr-item - (lambda () - (output/let names - (map compile-expr-item value-items) - (compile-item body-item))))) - -(define (body-item items) - (expr-item - (lambda () - (output/body (map compile-item (flatten-items items)))))) - -(define (if-item predicate consequent alternative) - (expr-item - (lambda () - (output/conditional (compile-expr-item predicate) - (compile-expr-item consequent) - (compile-expr-item alternative))))) - -(define (quoted-id-item var-item) - (expr-item - (lambda () - (output/quoted-identifier (var-item-id var-item))))) - -(define (assignment-item id rhs-item) - (expr-item - (lambda () - (output/assignment id (compile-expr-item rhs-item))))) - -(define (access-assignment-item name env-item rhs-item) - (expr-item - (lambda () - (output/access-assignment name - (compile-expr-item env-item) - (compile-expr-item rhs-item))))) - -(define (delay-item classify) - (expr-item - (lambda () - (output/delay (compile-expr-item (classify)))))) - -(define (or-item items) - (expr-item - (lambda () - (output/disjunction (map compile-expr-item items))))) - -(define (decl-item classify) - (expr-item - (lambda () - (output/declaration (classify))))) - -(define (the-environment-item) - (expr-item output/the-environment)) - -(define (unspecific-item) - (expr-item output/unspecific)) - -(define (unassigned-item) - (expr-item output/unassigned)) + +(define (body-item ctx items) + (expr-item ctx + (lambda () + (output/body (map compile-item (flatten-items items)))))) + +(define (combination-item ctx operator operands) + (expr-item ctx + (lambda () + (output/combination (compile-expr-item operator) + (map compile-expr-item operands))))) + +(define (constant-item ctx datum) + (expr-item ctx + (lambda () + (output/constant datum)))) ;;;; Compiler diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm index 3d98702ff..7e3a1a5f5 100644 --- a/src/runtime/syntax-parser.scm +++ b/src/runtime/syntax-parser.scm @@ -157,6 +157,8 @@ USA. ((eq? arg spar-arg:close) (make-closer (%input-closing-senv input))) ((eq? arg spar-arg:compare) (make-comparer (%input-closing-senv input) senv)) + ((eq? arg spar-arg:ctx) + (serror-ctx (%input-form input) senv (%input-hist input))) ((eq? arg spar-arg:senv) senv) ((eq? arg spar-arg:value) (%output-top output)) ((eq? arg spar-arg:values) (%output-all output)) @@ -175,6 +177,7 @@ USA. (define-deferred spar-arg:hist (string->uninterned-symbol ".hist.")) (define-deferred spar-arg:close (string->uninterned-symbol ".close.")) (define-deferred spar-arg:compare (string->uninterned-symbol ".compare.")) +(define-deferred spar-arg:ctx (string->uninterned-symbol ".ctx.")) (define-deferred spar-arg:senv (string->uninterned-symbol ".senv.")) (define-deferred spar-arg:value (string->uninterned-symbol ".value.")) (define-deferred spar-arg:values (string->uninterned-symbol ".values.")) @@ -412,18 +415,6 @@ USA. (declare (ignore senv)) (lambda (senv*) (classify-form form senv* hist))))) - -(define-deferred spar-push-body - (spar-and - (spar-encapsulate-values - (lambda (elts) - (lambda (frame-senv) - (let ((body-senv (make-internal-senv frame-senv))) - (map-in-order (lambda (elt) (elt body-senv)) - elts)))) - (spar+ (spar-elt spar-push-open-classified)) - (spar-match-null)) - (spar-push spar-arg:senv))) ;;;; Value combinators diff --git a/src/runtime/syntax-rules.scm b/src/runtime/syntax-rules.scm index ea233b723..74bdb2eb6 100644 --- a/src/runtime/syntax-rules.scm +++ b/src/runtime/syntax-rules.scm @@ -253,7 +253,7 @@ USA. `(,(classifier->keyword (lambda (form senv hist) (scheck '(_ datum) form senv hist) - (constant-item (cadr form)))) + (constant-item (serror-ctx form senv hist) (cadr form)))) ,expression)) (define (optimized-cons rename compare a d) diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm index 26a74006b..4d890d7f9 100644 --- a/src/runtime/syntax.scm +++ b/src/runtime/syntax.scm @@ -55,10 +55,10 @@ USA. (with-identifier-renaming (lambda () (compile-item - (body-item - (map-in-order (lambda (form) - (classify-form form senv (initial-hist form))) - forms))))))) + (body-item #f + (map-in-order (lambda (form) + (classify-form form senv (initial-hist form))) + forms))))))) ;;;; Classifier @@ -79,16 +79,16 @@ USA. (let ((item (classify-form (car form) senv (hist-car hist)))) (if (keyword-item? item) ((keyword-item-impl item) form senv hist) - (begin + (let ((ctx (serror-ctx form senv hist))) (if (not (list? (cdr form))) - (serror (serror-ctx form senv hist) - "Combination must be a proper list:" form)) - (combination-item item + (serror ctx "Combination must be a proper list:" form)) + (combination-item ctx + item (classify-forms (cdr form) senv (hist-cdr hist))))))) (else - (constant-item form)))) + (constant-item (serror-ctx form senv hist) form)))) (define (reclassify form env hist) (classify-form form env (hist-reduce form hist)))