From: Chris Hanson Date: Sun, 4 Mar 2018 06:23:23 +0000 (-0800) Subject: Refactor syntax-low to improve support for spar transformers. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~221 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5d567c5169d58e64dd7d7bdbae2b64f77df8863a;p=mit-scheme.git Refactor syntax-low to improve support for spar transformers. --- diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm index 3c8734bb6..271506480 100644 --- a/src/runtime/mit-syntax.scm +++ b/src/runtime/mit-syntax.scm @@ -74,7 +74,7 @@ USA. ;;;; Core primitives (define :begin - (spar-promise->runtime + (spar-classifier->runtime (delay (spar-encapsulate-values (lambda (deferred-items) @@ -86,7 +86,7 @@ USA. spar-match-null)))) (define :if - (spar-promise->runtime + (spar-classifier->runtime (delay (spar-call-with-values if-item (spar-elt) @@ -97,7 +97,7 @@ USA. spar-match-null)))) (define :quote - (spar-promise->runtime + (spar-classifier->runtime (delay (spar-call-with-values constant-item (spar-elt) @@ -105,7 +105,7 @@ USA. spar-match-null)))) (define :quote-identifier - (spar-promise->runtime + (spar-classifier->runtime (delay (spar-call-with-values quoted-id-item (spar-elt) @@ -118,7 +118,7 @@ USA. spar-match-null)))) (define :set! - (spar-promise->runtime + (spar-classifier->runtime (delay (spar-call-with-values (lambda (lhs-item rhs-item) @@ -145,7 +145,7 @@ USA. ;; the compiler wants this, but it would be nice to eliminate this ;; hack. (define :or - (spar-promise->runtime + (spar-classifier->runtime (delay (spar-encapsulate-values or-item (spar-elt) @@ -153,7 +153,7 @@ USA. spar-match-null)))) (define :delay - (spar-promise->runtime + (spar-classifier->runtime (delay (spar-call-with-values delay-item (spar-elt) @@ -163,7 +163,7 @@ USA. ;;;; Definitions (define keyword:define - (spar-promise->keyword + (spar-classifier->keyword (delay (spar-call-with-values defn-item (spar-elt) @@ -174,7 +174,7 @@ USA. spar-match-null)))) (define :define-syntax - (spar-promise->runtime + (spar-classifier->runtime (delay (spar-call-with-values (lambda (id senv item) @@ -202,7 +202,7 @@ USA. ;;;; Lambdas (define :lambda - (spar-promise->runtime + (spar-classifier->runtime (delay (spar-call-with-values (lambda (bvl body senv) @@ -214,7 +214,7 @@ USA. spar-push-body)))) (define :named-lambda - (spar-promise->runtime + (spar-classifier->runtime (delay (spar-call-with-values (lambda (name bvl body senv) @@ -238,7 +238,7 @@ USA. ;;;; LET-like (define keyword:let - (spar-promise->keyword + (spar-classifier->keyword (delay (spar-call-with-values (lambda (bindings body senv) @@ -282,13 +282,13 @@ USA. spar-push-body))) (define :let-syntax - (spar-promise->runtime spar-promise:let-syntax)) + (spar-classifier->runtime spar-promise:let-syntax)) (define keyword:let-syntax - (spar-promise->keyword spar-promise:let-syntax)) + (spar-classifier->keyword spar-promise:let-syntax)) (define :letrec-syntax - (spar-promise->runtime + (spar-classifier->runtime (delay (spar-call-with-values (lambda (bindings body senv) @@ -324,7 +324,7 @@ USA. (env access-item-env)) (define keyword:access - (spar-promise->keyword + (spar-classifier->keyword (delay (spar-call-with-values access-item (spar-elt) @@ -338,7 +338,7 @@ USA. (compile-expr-item (access-item-env item))))) (define :the-environment - (spar-promise->runtime + (spar-classifier->runtime (delay (spar-seq (spar-or (spar-match senv-top-level? spar-arg:senv) @@ -349,7 +349,7 @@ USA. (spar-push-value the-environment-item))))) (define keyword:unspecific - (spar-promise->keyword + (spar-classifier->keyword (delay (spar-seq (spar-elt) @@ -357,7 +357,7 @@ USA. (spar-push-value unspecific-item))))) (define keyword:unassigned - (spar-promise->keyword + (spar-classifier->keyword (delay (spar-seq (spar-elt) @@ -367,7 +367,7 @@ USA. ;;;; Declarations (define :declare - (spar-promise->runtime + (spar-classifier->runtime (delay (spar-call-with-values (lambda (senv hist decls) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index f8b2d5c40..973ed5c7b 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4420,7 +4420,6 @@ USA. biselector:cddr biselector:cdr biselector:cr - classifier->keyword classify-form error:syntax hist-cadr @@ -4434,7 +4433,6 @@ USA. serror sfor-each smap - spar-promise->keyword subform-select) (export (runtime syntax low) reclassify @@ -4450,6 +4448,7 @@ USA. spar-macro-transformer->expander syntactic-keyword->item) (export (runtime syntax) + classifier->keyword classifier->runtime er-macro-transformer->keyword-item keyword-item @@ -4459,9 +4458,11 @@ USA. keyword-item? rsc-macro-transformer->keyword-item sc-macro-transformer->keyword-item + spar-classifier->keyword + spar-classifier->runtime + spar-transformer->runtime spar-macro-transformer->keyword-item - spar-promise->classifier - spar-promise->runtime)) + spar-promise-caller)) (define-package (runtime syntax items) (files "syntax-items") @@ -4571,7 +4572,7 @@ USA. spar-transform-values spar-with-mapped-senv) (export (runtime syntax) - spar->classifier + spar-call spar-push-classified spar-push-deferred-classified spar-push-open-classified)) diff --git a/src/runtime/syntax-low.scm b/src/runtime/syntax-low.scm index 764d0ad8a..59a5bfdaa 100644 --- a/src/runtime/syntax-low.scm +++ b/src/runtime/syntax-low.scm @@ -43,9 +43,10 @@ USA. expr)) (define (sc-wrapper transformer get-closing-senv) - (lambda (form use-senv) - (close-syntax (transformer form use-senv) - (get-closing-senv)))) + (wrap-no-hist + (lambda (form use-senv) + (close-syntax (transformer form use-senv) + (get-closing-senv))))) (define (rsc-macro-transformer->expander transformer env #!optional expr) (expander-item (rsc-wrapper transformer (runtime-getter env)) @@ -56,9 +57,10 @@ USA. expr)) (define (rsc-wrapper transformer get-closing-senv) - (lambda (form use-senv) - (close-syntax (transformer form (get-closing-senv)) - use-senv))) + (wrap-no-hist + (lambda (form use-senv) + (close-syntax (transformer form (get-closing-senv)) + use-senv)))) (define (er-macro-transformer->expander transformer env #!optional expr) (expander-item (er-wrapper transformer (runtime-getter env)) @@ -69,11 +71,12 @@ USA. expr)) (define (er-wrapper transformer get-closing-senv) - (lambda (form use-senv) - (close-syntax (transformer form - (make-er-rename (get-closing-senv)) - (make-er-compare use-senv)) - use-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)))) (define (make-er-rename closing-senv) (lambda (identifier) @@ -84,19 +87,17 @@ USA. (identifier=? use-senv x use-senv y))) (define (spar-macro-transformer->expander spar env expr) - (keyword-item (spar-wrapper spar (runtime-getter env)) - expr)) + (expander-item (spar-wrapper spar (runtime-getter env)) + expr)) (define (spar-macro-transformer->keyword-item spar closing-senv expr) - (keyword-item (spar-wrapper spar (lambda () closing-senv)) + (expander-item (spar-wrapper spar (lambda () closing-senv)) expr)) (define (spar-wrapper spar get-closing-senv) (lambda (form senv hist) - (reclassify (close-syntax ((spar->classifier spar) form senv hist) - (get-closing-senv)) - senv - hist))) + (close-syntax (spar-call spar form senv hist) + (get-closing-senv)))) (define (runtime-getter env) (lambda () @@ -107,15 +108,6 @@ USA. (define (keyword-item impl #!optional expr) (%keyword-item impl expr)) -(define (expander-item impl expr) - (%keyword-item (lambda (form senv hist) - (reclassify (with-error-context form senv hist - (lambda () - (impl form senv))) - senv - hist)) - expr)) - (define-record-type (%keyword-item impl expr) keyword-item? @@ -125,16 +117,42 @@ 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))) -(define (spar-promise->runtime promise) - (make-unmapped-macro-reference-trap - (keyword-item (spar-promise->classifier promise)))) +(define (classifier->keyword classifier) + (close-syntax 'keyword + (make-keyword-senv 'keyword + (keyword-item classifier)))) + +(define (spar-classifier->runtime promise) + (classifier->runtime (spar-promise-caller promise))) + +(define (spar-transformer->runtime promise) + (classifier->runtime (transformer->classifier (spar-promise-caller promise)))) + +(define (spar-classifier->keyword promise) + (classifier->keyword (spar-promise-caller promise))) -(define (spar-promise->classifier promise) +(define (spar-promise-caller promise) (lambda (form senv hist) - ((spar->classifier (force promise)) form senv hist))) + (spar-call (force promise) form senv hist))) (define (syntactic-keyword->item keyword environment) (let ((item (environment-lookup-macro environment keyword))) diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm index 13625dc32..16453897d 100644 --- a/src/runtime/syntax-parser.scm +++ b/src/runtime/syntax-parser.scm @@ -64,18 +64,17 @@ USA. ;;; ;;; (failure) -(define (spar->classifier spar) - (lambda (form senv hist) - (spar (%new-input form hist) - senv - (%new-output) - (lambda (input senv output failure) - (declare (ignore senv failure)) - (if (not (%input-null? input)) - (error "Rule failed to match entire form.")) - (output 'get-only)) - (lambda () - (serror form senv hist "Ill-formed syntax:" form))))) +(define (spar-call spar form senv hist) + (spar (%new-input form hist) + senv + (%new-output) + (lambda (input senv output failure) + (declare (ignore senv failure)) + (if (not (%input-null? input)) + (error "Rule failed to match entire form.")) + (output 'get-only)) + (lambda () + (serror form senv hist "Ill-formed syntax:" form)))) ;;;; Inputs and outputs diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm index e8cb0eb17..a55171869 100644 --- a/src/runtime/syntax.scm +++ b/src/runtime/syntax.scm @@ -307,14 +307,6 @@ USA. ;;;; Utilities -(define (classifier->keyword classifier) - (close-syntax 'keyword - (make-keyword-senv 'keyword - (keyword-item classifier)))) - -(define (spar-promise->keyword promise) - (classifier->keyword (spar-promise->classifier promise))) - (define (capture-syntactic-environment expander) `(,(classifier->keyword (lambda (form senv hist)