Another round of changes to the spar API.

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index 73c429ac082f727f017a61c4c698f98d9e9488af..5740a39d0f652b17b3700533cd899498462ee4ad 100644 (file)
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -532,6 +532,7 @@ USA.
    (runtime syntax items)
    (runtime syntax rename)
    (runtime syntax top-level)
+   (runtime syntax parser)
    ;; REP Loops
    (RUNTIME INTERRUPT-HANDLER)
    (RUNTIME GC-STATISTICS)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index edfa5e368426914ac437d6f0ecd86e5e342c2aed..a447c98ae852f736251599b51b3c6cb7f13dd9b6 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4440,6 +4440,7 @@ USA.
          serror
          sfor-each
          smap
+         spar-promise->keyword
          subform-select)
   (export (runtime syntax low)
          reclassify
@@ -4464,7 +4465,9 @@ USA.
          keyword-item?
          rsc-macro-transformer->keyword-item
          sc-macro-transformer->keyword-item
-         spar-macro-transformer->keyword-item))
+         spar-macro-transformer->keyword-item
+         spar-promise->classifier
+         spar-promise->runtime))
 
 (define-package (runtime syntax items)
   (files "syntax-items")
@@ -4550,21 +4553,26 @@ USA.
          spar-elt
          spar-fail
          spar-filter-map-values
+         spar-push-id-elt
+         spar-push-id-elt=
          spar-map-values
-         spar-match-elt
-         spar-match-elt-full
          spar-opt
+         spar-push-body
          spar-push-closed-elt
          spar-push-closed-form
+         spar-push-datum
          spar-push-elt
          spar-push-form
+         spar-push-hist
          spar-push-mapped-form
          spar-push-mapped-full
+         spar-push-senv
          spar-push-thunk-value
-         spar-push-value
+         spar-push-values
          spar-repeat
          spar-require-form
          spar-require-full
+         spar-require-null
          spar-require-senv
          spar-require-value
          spar-seq
@@ -4573,8 +4581,12 @@ USA.
          spar-with-mapped-senv)
   (export (runtime syntax)
          spar->classifier
-         spar-classify-elt
-         spar-push-classified))
+         spar-push-classified-elt
+         spar-push-classified-form
+         spar-push-deferred-classified-elt
+         spar-push-deferred-classified-form
+         spar-push-open-classified-elt
+         spar-push-open-classified-form))
 
 (define-package (runtime syntax rename)
   (files "syntax-rename")

diff --git a/src/runtime/syntax-low.scm b/src/runtime/syntax-low.scm
index c05c9d80910b19eb651e7f1a917020b0a7f1ac64..764d0ad8a082582752ccd61f33a1c180a75f089c 100644 (file)
--- a/src/runtime/syntax-low.scm
+++ b/src/runtime/syntax-low.scm
@@ -128,6 +128,14 @@ USA.
 (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 (spar-promise->classifier promise)
+  (lambda (form senv hist)
+    ((spar->classifier (force promise)) form senv hist)))
+
 (define (syntactic-keyword->item keyword environment)
   (let ((item (environment-lookup-macro environment keyword)))
     (if (not item)

diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index 6ce08fdd6b38ce9cedc0fd78d88c2603dd55d2ae..0d3e9f2013a8ebdf8f7ac54abbe767079a86f368 100644 (file)
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -179,18 +179,28 @@ USA.
           (%output-push output (%input-form input))
           failure))
 
-(define (spar-push-value object)
+(define (spar-push-hist input senv output success failure)
+  (success (%null-input)
+          senv
+          (%output-push output (%input-hist input))
+          failure))
+
+(define (spar-push-senv input senv output success failure)
+  (success input
+          senv
+          (%output-push output senv)
+          failure))
+
+(define (spar-push-datum object)
   (lambda (input senv output success failure)
-    (declare (ignore input))
-    (success (%null-input)
+    (success input
             senv
             (%output-push output object)
             failure)))
 
 (define (spar-push-thunk-value procedure)
   (lambda (input senv output success failure)
-    (declare (ignore input))
-    (success (%null-input)
+    (success input
             senv
             (%output-push output (procedure))
             failure)))
@@ -209,7 +219,7 @@ USA.
             (%output-push output (procedure (%input-form input) senv))
             failure)))
 
-(define (spar-push-classified procedure)
+(define (%push-classified procedure)
   (lambda (input senv output success failure)
     (success (%null-input)
             senv
@@ -348,52 +358,85 @@ USA.
 (define spar-discard-elt
   (spar-elt spar-discard-form))
 
+(define spar-require-null
+  (spar-require-form null?))
+
 (define spar-push-elt
   (spar-elt spar-push-form))
 
+;;;; Environment combinators
+
+(define (spar-with-mapped-senv procedure . spars)
+  (let ((spar (%seq spars)))
+    (lambda (input senv output success failure)
+      (spar input
+           (procedure senv)
+           output
+           (lambda (input* senv* output* failure*)
+             (declare (ignore senv*))
+             (success input* senv output* failure*))
+           failure))))
+\f
 (define spar-push-closed-form
   (spar-push-mapped-full
    (lambda (form senv)
      (make-syntactic-closure senv '() form))))
 
+(define spar-push-closed-elt
+  (spar-elt spar-push-closed-form))
+
 (define spar-push-partially-closed-form
   (spar-push-mapped-full
    (lambda (form senv)
      (lambda (free)
        (make-syntactic-closure senv free form)))))
 
-(define spar-push-closed-elt
-  (spar-elt spar-push-closed-form))
-
 (define spar-push-partially-closed-elt
   (spar-elt spar-push-partially-closed-form))
 
-(define (spar-classify-elt procedure)
-  (spar-elt (spar-push-classified procedure)))
+(define-deferred spar-push-classified-form
+  (%push-classified classify-form))
 
-(define (spar-match-elt predicate)
-  (spar-elt (spar-require-form predicate)
-           spar-push-form))
+(define-deferred spar-push-classified-elt
+  (spar-elt spar-push-classified-form))
 
-(define (spar-match-elt-full predicate)
-  (spar-elt (spar-require-full predicate)
-           spar-push-form))
+(define spar-push-deferred-classified-form
+  (%push-classified
+   (lambda (form senv hist)
+     (lambda ()
+       (classify-form form senv hist)))))
 
-;;;; Environment combinators
+(define spar-push-deferred-classified-elt
+  (spar-elt spar-push-deferred-classified-form))
 
-(define (spar-with-mapped-senv procedure . spars)
-  (let ((spar (%seq spars)))
-    (lambda (input senv output success failure)
-      (spar input
-           (procedure senv)
-           output
-           (lambda (input* senv* output* failure*)
-             (declare (ignore senv*))
-             (success input* senv output* failure*))
-           failure))))
+(define spar-push-open-classified-form
+  (%push-classified
+   (lambda (form senv hist)
+     (declare (ignore senv))
+     (lambda (senv*)
+       (classify-form form senv* hist)))))
+
+(define spar-push-open-classified-elt
+  (spar-elt spar-push-open-classified-form))
+
+(define-deferred spar-push-id-elt
+  (spar-elt (spar-require-form identifier?)
+           spar-push-form))
+
+(define (spar-push-id-elt= id)
+  (spar-elt (spar-require-full
+            (lambda (form senv)
+              (and (identifier? form)
+                   (identifier=? senv form senv id))))
+           spar-push-form))
 \f
 ;;;; Value combinators
 
+(define (spar-push-values . spars)
+  (%with-output (lambda (output output*)
+                 (%output-push output (%output-all output*)))
+               spars))
+
 (define (spar-encapsulate-values procedure . spars)
   (%encapsulate procedure spars))
 
@@ -433,4 +476,14 @@ USA.
                       senv*
                       (procedure output output*)
                       failure*))
-           failure))))
\ No newline at end of file
+           failure))))
+
+(define spar-push-body
+  (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-push-open-classified-elt)
+    spar-require-null))
\ No newline at end of file

diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index 2ec9317cecf4a328315ba602f4ab09085fa9a4e1..94352cfaf3c7bc5001268a24a3001b492777c007 100644 (file)
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -347,6 +347,9 @@ USA.
                (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)