From: Chris Hanson Date: Wed, 7 Mar 2018 02:26:54 +0000 (-0800) Subject: Some more tweaks to the low-level macro interfaces. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~217 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=eb30a0592a8e7b1b09a5c5478e17b027afa71f89;p=mit-scheme.git Some more tweaks to the low-level macro interfaces. --- diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index 9b8f6a474..5c9f065b0 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -143,9 +143,6 @@ USA. (car p))) supported-features)) -(define (get-closing-env) - (runtime-environment->syntactic system-global-environment)) - (define :receive (spar-transformer->runtime (delay @@ -161,7 +158,7 @@ USA. (spar-push-elt spar-arg:form) (spar+ (spar-push-elt spar-arg:form)) spar-match-null)) - get-closing-env)) + system-global-environment)) (define-syntax :define-record-type (er-macro-transformer @@ -245,7 +242,7 @@ USA. spar-match-null)) (spar+ (spar-push-elt spar-arg:form)) spar-match-null)) - get-closing-env)) + system-global-environment)) (define named-let-strategy 'internal-definition) diff --git a/src/runtime/syntax-low.scm b/src/runtime/syntax-low.scm index a1e912aa8..f55945110 100644 --- a/src/runtime/syntax-low.scm +++ b/src/runtime/syntax-low.scm @@ -35,48 +35,54 @@ USA. ;;; They can become required after 9.3 release. (define (sc-macro-transformer->expander transformer env #!optional expr) - (expander-item (sc-wrapper transformer (runtime-getter env)) - expr)) + (keyword-item (sc-wrapper transformer (runtime-getter env)) + expr)) (define (sc-macro-transformer->keyword-item transformer closing-senv expr) - (expander-item (sc-wrapper transformer (lambda () closing-senv)) - expr)) + (keyword-item (sc-wrapper transformer (lambda () closing-senv)) + expr)) (define (sc-wrapper transformer get-closing-senv) - (wrap-no-hist - (lambda (form use-senv) - (close-syntax (transformer form use-senv) - (get-closing-senv))))) + (lambda (form use-senv hist) + (reclassify (with-error-context form use-senv hist + (lambda () + (transformer form use-senv))) + (get-closing-senv) + hist))) (define (rsc-macro-transformer->expander transformer env #!optional expr) - (expander-item (rsc-wrapper transformer (runtime-getter env)) - expr)) + (keyword-item (rsc-wrapper transformer (runtime-getter env)) + expr)) (define (rsc-macro-transformer->keyword-item transformer closing-senv expr) - (expander-item (rsc-wrapper transformer (lambda () closing-senv)) - expr)) + (keyword-item (rsc-wrapper transformer (lambda () closing-senv)) + expr)) (define (rsc-wrapper transformer get-closing-senv) - (wrap-no-hist - (lambda (form use-senv) - (close-syntax (transformer form (get-closing-senv)) - use-senv)))) + (lambda (form use-senv hist) + (reclassify (with-error-context form use-senv hist + (lambda () + (transformer form (get-closing-senv)))) + use-senv + hist))) (define (er-macro-transformer->expander transformer env #!optional expr) - (expander-item (er-wrapper transformer (runtime-getter env)) - expr)) + (keyword-item (er-wrapper transformer (runtime-getter env)) + expr)) (define (er-macro-transformer->keyword-item transformer closing-senv expr) - (expander-item (er-wrapper transformer (lambda () closing-senv)) - expr)) + (keyword-item (er-wrapper transformer (lambda () closing-senv)) + expr)) (define (er-wrapper transformer get-closing-senv) - (wrap-no-hist - (lambda (form use-senv) - (close-syntax (transformer form - (make-er-rename (get-closing-senv)) - (make-er-compare use-senv)) - use-senv)))) + (lambda (form use-senv hist) + (reclassify (with-error-context form use-senv hist + (lambda () + (transformer form + (make-er-rename (get-closing-senv)) + (make-er-compare use-senv)))) + use-senv + hist))) (define (make-er-rename closing-senv) (lambda (identifier) @@ -87,15 +93,18 @@ USA. (identifier=? use-senv x use-senv y))) (define (spar-macro-transformer->expander spar env expr) - (expander-item (spar-wrapper spar (runtime-getter env)) - expr)) + (keyword-item (spar-wrapper spar (runtime-getter env)) + expr)) (define (spar-macro-transformer->keyword-item spar closing-senv expr) - (expander-item (spar-wrapper spar (lambda () closing-senv)) - expr)) + (keyword-item (spar-wrapper spar (lambda () closing-senv)) + expr)) (define (spar-wrapper spar get-closing-senv) - (spar-transformer-promise-caller (delay spar) get-closing-senv)) + (lambda (form use-senv hist) + (reclassify (spar-call spar form use-senv hist (get-closing-senv)) + use-senv + hist))) (define (runtime-getter env) (lambda () @@ -115,22 +124,6 @@ USA. (define (keyword-item-has-expr? item) (not (default-object? (keyword-item-expr item)))) -(define (expander-item transformer expr) - (keyword-item (transformer->classifier transformer) - expr)) - -(define (transformer->classifier transformer) - (lambda (form senv hist) - (reclassify (transformer form senv hist) - senv - hist))) - -(define (wrap-no-hist transformer) - (lambda (form senv hist) - (with-error-context form senv hist - (lambda () - (transformer form senv))))) - (define (classifier->runtime classifier) (make-unmapped-macro-reference-trap (keyword-item classifier))) @@ -149,14 +142,16 @@ USA. (lambda (form senv hist) (spar-call (force promise) form senv hist senv))) -(define (spar-transformer->runtime promise get-closing-senv) +(define (spar-transformer->runtime promise env) (classifier->runtime - (transformer->classifier - (spar-transformer-promise-caller promise get-closing-senv)))) - -(define (spar-transformer-promise-caller promise get-closing-senv) - (lambda (form use-senv hist) - (spar-call (force promise) form use-senv hist (get-closing-senv)))) + (lambda (form use-senv hist) + (reclassify (spar-call (force promise) + form + use-senv + hist + (runtime-environment->syntactic env)) + use-senv + hist)))) (define (syntactic-keyword->item keyword environment) (let ((item (environment-lookup-macro environment keyword)))