Tweak interface for syntax-parser macros.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 973ed5c7ba10b918262bb267f2f9af93b963be23..82727d6da5bd9633050527c2295371f41c269e52 100644 (file)
--- 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 59a5bfdaafdd1c53f0e96e6a968f944b73cdd3de..a1e912aa808a18dfbbc03a17fc32c0a6f55c9897 100644 (file)
--- 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 16453897d0963ebad868d54e31f64a79898a863c..af4388dba47ce962873f6aaa4bab31f537a0c1f8 100644 (file)
--- 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))))
 \f
 ;;;; 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))
 \f
 ;;;; Repeat combinators
 
@@ -341,19 +348,6 @@ USA.
              (success input* senv output* failure*))
            failure))))
 \f
-(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