From 2747f5128148c076b4fc21ecab82a6ec3c170220 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 6 Mar 2018 17:26:11 -0800 Subject: [PATCH] Tweak interface for syntax-parser macros. --- src/runtime/runtime.pkg | 8 ++---- src/runtime/syntax-low.scm | 26 ++++++++++------- src/runtime/syntax-parser.scm | 54 ++++++++++++++++------------------- 3 files changed, 42 insertions(+), 46 deletions(-) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 973ed5c7b..82727d6da 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4446,6 +4446,7 @@ USA. rsc-macro-transformer->expander sc-macro-transformer->expander spar-macro-transformer->expander + spar-transformer->runtime syntactic-keyword->item) (export (runtime syntax) classifier->keyword @@ -4460,9 +4461,7 @@ USA. sc-macro-transformer->keyword-item spar-classifier->keyword spar-classifier->runtime - spar-transformer->runtime - spar-macro-transformer->keyword-item - spar-promise-caller)) + spar-macro-transformer->keyword-item)) (define-package (runtime syntax items) (files "syntax-items") @@ -4541,6 +4540,7 @@ USA. spar* spar+ spar-append-map-values + spar-arg:close spar-arg:form spar-arg:hist spar-arg:senv @@ -4560,10 +4560,8 @@ USA. spar-or spar-push spar-push-body - spar-push-closed spar-push-id spar-push-id= - spar-push-partially-closed spar-push-value spar-push-values spar-repeat diff --git a/src/runtime/syntax-low.scm b/src/runtime/syntax-low.scm index 59a5bfdaa..a1e912aa8 100644 --- a/src/runtime/syntax-low.scm +++ b/src/runtime/syntax-low.scm @@ -92,12 +92,10 @@ USA. (define (spar-macro-transformer->keyword-item spar closing-senv expr) (expander-item (spar-wrapper spar (lambda () closing-senv)) - expr)) + expr)) (define (spar-wrapper spar get-closing-senv) - (lambda (form senv hist) - (close-syntax (spar-call spar form senv hist) - (get-closing-senv)))) + (spar-transformer-promise-caller (delay spar) get-closing-senv)) (define (runtime-getter env) (lambda () @@ -142,17 +140,23 @@ USA. (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)))) + (classifier->runtime (spar-classifier-promise-caller promise))) (define (spar-classifier->keyword promise) - (classifier->keyword (spar-promise-caller promise))) + (classifier->keyword (spar-classifier-promise-caller promise))) -(define (spar-promise-caller promise) +(define (spar-classifier-promise-caller promise) (lambda (form senv hist) - (spar-call (force promise) form senv hist))) + (spar-call (force promise) form senv hist senv))) + +(define (spar-transformer->runtime promise get-closing-senv) + (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)))) (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 16453897d..af4388dba 100644 --- a/src/runtime/syntax-parser.scm +++ b/src/runtime/syntax-parser.scm @@ -64,9 +64,9 @@ USA. ;;; ;;; (failure) -(define (spar-call spar form senv hist) - (spar (%new-input form hist) - senv +(define (spar-call spar form use-senv hist closing-senv) + (spar (%new-input form hist closing-senv) + use-senv (%new-output) (lambda (input senv output failure) (declare (ignore senv failure)) @@ -74,26 +74,28 @@ USA. (error "Rule failed to match entire form.")) (output 'get-only)) (lambda () - (serror form senv hist "Ill-formed syntax:" form)))) + (serror form use-senv hist "Ill-formed syntax:" form)))) ;;;; Inputs and outputs -(define (%new-input form hist) - (lambda (operator) - (case operator - ((form) form) - ((hist) hist) - ((car) (%new-input (car form) (hist-car hist))) - ((cdr) (%new-input (cdr form) (hist-cdr hist))) - (else (error "Unknown operator:" operator))))) - -(define (%null-input) - (%new-input '() (initial-hist '()))) +(define (%new-input form hist closing-senv) + (let loop ((form form) (hist hist)) + (lambda (operator) + (case operator + ((form) form) + ((hist) hist) + ((closing-senv) closing-senv) + ((car) (loop (car form) (hist-car hist))) + ((cdr) (loop (cdr form) (hist-cdr hist))) + ((discard) (loop '() (initial-hist '()))) + (else (error "Unknown operator:" operator)))))) (define (%input-form input) (input 'form)) (define (%input-hist input) (input 'hist)) +(define (%input-closing-senv input) (input 'closing-senv)) (define (%input-car input) (input 'car)) (define (%input-cdr input) (input 'cdr)) +(define (%input-discard input) (input 'discard)) (define (%input-pair? input) (pair? (%input-form input))) (define (%input-null? input) (null? (%input-form input))) @@ -152,13 +154,19 @@ USA. (define (%subst-arg input senv output arg) (cond ((eq? arg spar-arg:form) (%input-form input)) ((eq? arg spar-arg:hist) (%input-hist input)) + ((eq? arg spar-arg:close) (make-closer (%input-closing-senv input))) ((eq? arg spar-arg:senv) senv) ((eq? arg spar-arg:value) (%output-top output)) ((eq? arg spar-arg:values) (%output-all output)) (else arg))) +(define (make-closer senv) + (lambda (expr) + (close-syntax expr senv))) + (define-deferred spar-arg:form (string->uninterned-symbol ".form.")) (define-deferred spar-arg:hist (string->uninterned-symbol ".hist.")) +(define-deferred spar-arg:close (string->uninterned-symbol ".close.")) (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.")) @@ -196,8 +204,7 @@ USA. (%subst-args input senv output irritants)))) (define (spar-discard-form input senv output success failure) - (declare (ignore input)) - (success (%null-input) senv output failure)) + (success (%input-discard input) senv output failure)) ;;;; Repeat combinators @@ -341,19 +348,6 @@ USA. (success input* senv output* failure*)) failure)))) -(define-deferred spar-push-closed - (spar-push-value make-syntactic-closure - spar-arg:senv - '() - spar-arg:form)) - -(define-deferred spar-push-partially-closed - (spar-push-value (lambda (senv form) - (lambda (free) - (make-syntactic-closure senv free form))) - spar-arg:senv - spar-arg:form)) - (define-deferred spar-push-classified (spar-push-value classify-form spar-arg:form -- 2.25.1