Simplify spar interface a bit more.

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 9ae619f4cc2021a1ab7640581ff75140a975b592..ade5c1e71c7f8287fcb0645c39b0b905b561fd8b 100644 (file)
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -238,13 +238,13 @@ USA.
                   ,@vals))))
        (spar-elt)
        (spar-push spar-arg:close)
-       (spar-or (spar-elt spar-push-id)
+       (spar-or (spar-push-elt-if identifier? spar-arg:form)
                (spar-push '#f))
        (spar-elt
-        (spar-push-values
+        (spar-call-with-values list
          (spar* (spar-elt
                   (spar-call-with-values cons
-                    (spar-elt spar-push-id)
+                    (spar-push-elt-if identifier? spar-arg:form)
                     (spar-or (spar-push-elt spar-arg:form)
                              (spar-push-value unassigned-expression)))
                   spar-match-null))

diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index 7d6ee8000887dd3b2dc4b194c6f4b3fe6cb30d59..c9b6a48229cf9b1a22e438e4aa0ba28e4c8890be 100644 (file)
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -190,7 +190,7 @@ USA.
                 (syntax-defn-item id (keyword-item-expr item))
                 (seq-item '()))))
        (spar-elt)
-       (spar-elt spar-push-id)
+       (spar-push-elt-if identifier? spar-arg:form)
        (spar-push spar-arg:senv)
        (spar-elt
         spar-push-classified
@@ -208,9 +208,7 @@ USA.
         (lambda (bvl body senv)
           (assemble-lambda-item scode-lambda-name:unnamed bvl body senv))
        (spar-elt)
-       (spar-elt
-        (spar-match mit-lambda-list? spar-arg:form)
-        (spar-push spar-arg:form))
+       (spar-push-elt-if mit-lambda-list? spar-arg:form)
        spar-push-body))))
 
 (define :named-lambda
@@ -221,9 +219,8 @@ USA.
           (assemble-lambda-item (identifier->symbol name) bvl body senv))
        (spar-elt)
        (spar-elt
-        (spar-elt spar-push-id)
-        (spar-match mit-lambda-list? spar-arg:form)
-        (spar-push spar-arg:form))
+        (spar-push-elt-if identifier? spar-arg:form)
+        (spar-push-if mit-lambda-list? spar-arg:form))
        spar-push-body))))
 
 (define (assemble-lambda-item name bvl body senv)
@@ -248,10 +245,10 @@ USA.
            (seq-item (body frame-senv))))
       (spar-elt)
       (spar-elt
-       (spar-push-values
+       (spar-call-with-values list
         (spar*
           (spar-call-with-values cons
-            (spar-elt (spar-elt spar-push-id)
+            (spar-elt (spar-push-elt-if identifier? spar-arg:form)
                       (spar-elt spar-push-classified)
                       spar-match-null))))
        spar-match-null)
@@ -282,10 +279,10 @@ USA.
            (seq-item (body frame-senv))))
       (spar-elt)
       (spar-elt
-        (spar-push-values
+        (spar-call-with-values list
           (spar*
             (spar-call-with-values cons
-              (spar-elt (spar-elt spar-push-id)
+              (spar-elt (spar-push-elt-if identifier? spar-arg:form)
                         (spar-elt spar-push-open-classified)
                         spar-match-null))))
         spar-match-null)
@@ -304,7 +301,7 @@ USA.
    (delay
      (spar-call-with-values access-item
        (spar-elt)
-       (spar-elt spar-push-id)
+       (spar-push-elt-if identifier? spar-arg:form)
        (spar-elt spar-push-classified)
        spar-match-null))))
 
@@ -360,15 +357,13 @@ USA.
        (spar-elt)
        (spar-push spar-arg:senv)
        (spar-push spar-arg:hist)
-       (spar-push-values
-       (spar*
-         (spar-elt
-           (spar-match (lambda (form)
-                         (and (pair? form)
-                              (identifier? (car form))
-                              (list? (cdr form))))
-                       spar-arg:form)
-           (spar-push spar-arg:form))))
+       (spar-call-with-values list
+        (spar*
+          (spar-push-elt-if (lambda (form)
+                              (and (pair? form)
+                                   (identifier? (car form))
+                                   (list? (cdr form))))
+                            spar-arg:form)))
        spar-match-null))))
 
 (define (classify-id id senv hist)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index ed7142cabbb2d43efb194649d3b3bd565476aaa6..b2d1f5b72b96fdfdfceeba5363b2c955167e57ac 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4572,10 +4572,8 @@ USA.
          spar-push-body
          spar-push-elt
          spar-push-elt-if
-         spar-push-id
          spar-push-if
          spar-push-value
-         spar-push-values
          spar-repeat
          spar-seq
          spar-succeed

diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index 4828c30e6de0ee5d2364708494549de945af7460..c5f834746bfe2d7160433b8a493acfac3c672eba 100644 (file)
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -336,11 +336,14 @@ USA.
                failure)
          (failure)))))
 
+(define (spar-match-elt predicate . args)
+  (spar-elt (apply spar-match predicate args)))
+
 (define (spar-push-elt . args)
   (spar-elt (apply spar-push args)))
 
-(define (spar-push-elt-if . args)
-  (spar-elt (apply spar-push-if args)))
+(define (spar-push-elt-if predicate . args)
+  (spar-elt (apply spar-push-if predicate args)))
 
 (define-deferred spar-match-null
   (spar-match null? spar-arg:form))
@@ -380,20 +383,9 @@ USA.
                   spar-arg:form
                   spar-arg:senv
                   spar-arg:hist))
-
-(define-deferred spar-push-id
-  (spar-seq
-    (spar-match identifier? spar-arg:form)
-    (spar-push spar-arg:form)
-    spar-discard-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))