Implement spar-top-level to cut down on boilerplate.

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index ceb4b26b5d417dcc5a70a860ab515e97e4c8b8e5..97a6f450b5290b47f72b272387631f9508600b06 100644 (file)
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -147,64 +147,61 @@ USA.
 (define :receive
   (spar-transformer->runtime
    (delay
-     (spar-call-with-values
-        (lambda (close bvl expr . body-forms)
-          (let ((r-cwv (close 'call-with-values))
-                (r-lambda (close 'lambda)))
-            `(,r-cwv (,r-lambda () ,expr)
-                     (,r-lambda ,bvl ,@body-forms))))
-       (pattern->spar '(ignore (push close) r4rs-bvl expr (+ form)))))
+     (spar-top-level '(r4rs-bvl expr (list (+ form)))
+       (lambda (close bvl expr body-forms)
+        (let ((r-cwv (close 'call-with-values))
+              (r-lambda (close 'lambda)))
+          `(,r-cwv (,r-lambda () ,expr)
+                   (,r-lambda ,bvl ,@body-forms))))))
    system-global-environment))
 
 (define :define-record-type
   (spar-transformer->runtime
    (delay
-     (spar-call-with-values
-        (lambda (close type-name parent maker-name maker-args pred-name
-                       field-specs)
-          (let ((beg (close 'begin))
-                (de (close 'define))
-                (mrt (close 'new-make-record-type))
-                (rc (close 'record-constructor))
-                (rp (close 'record-predicate))
-                (ra (close 'record-accessor))
-                (rm (close 'record-modifier)))
-            `(,beg
-              (,de ,type-name
-                   (,mrt ',type-name
-                         ',(map car field-specs)
-                         ,@(if parent
-                               (list parent)
-                               '())))
-              ,@(if maker-name
-                    `((,de ,maker-name
-                           (,rc ,type-name
-                                ,@(if maker-args
-                                      (list `',maker-args)
+     (spar-top-level
+        '((or (seq id (push #f))
+              (elt id expr))
+          (or (seq '#f (push #f #f))
+              (seq id (push #f))
+              (elt id (list (* symbol))))
+          (or (seq '#f (push #f))
+              id)
+          (list (* (list (elt symbol id (or id (push #f)))))))
+       (lambda (close type-name parent maker-name maker-args pred-name
+                     field-specs)
+        (let ((beg (close 'begin))
+              (de (close 'define))
+              (mrt (close 'new-make-record-type))
+              (rc (close 'record-constructor))
+              (rp (close 'record-predicate))
+              (ra (close 'record-accessor))
+              (rm (close 'record-modifier)))
+          `(,beg
+            (,de ,type-name
+                 (,mrt ',type-name
+                       ',(map car field-specs)
+                       ,@(if parent
+                             (list parent)
+                             '())))
+            ,@(if maker-name
+                  `((,de ,maker-name
+                         (,rc ,type-name
+                              ,@(if maker-args
+                                    (list `',maker-args)
+                                    '()))))
+                  '())
+            ,@(if pred-name
+                  `((,de ,pred-name (,rp ,type-name)))
+                  '())
+            ,@(append-map (lambda (field)
+                            (let ((field-name (car field)))
+                              `((,de ,(cadr field)
+                                     (,ra ,type-name ',field-name))
+                                ,@(if (caddr field)
+                                      `((,de ,(caddr field)
+                                             (,rm ,type-name ',field-name)))
                                       '()))))
-                    '())
-              ,@(if pred-name
-                    `((,de ,pred-name (,rp ,type-name)))
-                    '())
-              ,@(append-map (lambda (field)
-                              (let ((field-name (car field)))
-                                `((,de ,(cadr field)
-                                       (,ra ,type-name ',field-name))
-                                  ,@(if (caddr field)
-                                        `((,de ,(caddr field)
-                                               (,rm ,type-name ',field-name)))
-                                        '()))))
-                            field-specs))))
-       (pattern->spar
-       '(ignore (push close)
-                (or (seq id (push #f))
-                    (elt id expr))
-                (or (seq '#f (push #f #f))
-                    (seq id (push #f))
-                    (elt id (list (* symbol))))
-                (or (seq '#f (push #f))
-                    id)
-                (list (* (list (elt symbol id (or id (push #f))))))))))
+                          field-specs))))))
    system-global-environment))
 \f
 (define-syntax :define
@@ -233,27 +230,25 @@ USA.
 (define :let
   (spar-transformer->runtime
    (delay
-     (spar-call-with-values
-        (lambda (close name bindings . body-forms)
-          (let ((ids (map car bindings))
-                (vals (map cdr bindings)))
-            (if name
-                (generate-named-let close name ids vals body-forms)
-                `((,(close 'named-lambda)
-                   (,scode-lambda-name:let ,@ids)
-                   ,@body-forms)
-                  ,@vals))))
-       (pattern->spar
-       `(ignore (push close)
-                (or id (push #f))
-                (elt
-                 (list
-                  (*
-                   (elt
-                    (cons id
-                          (or expr
-                              (push-value ,unassigned-expression)))))))
-                (+ form)))))
+     (spar-top-level
+        `((or id (push #f))
+          (elt
+           (list
+            (*
+             (elt
+              (cons id
+                    (or expr
+                        (push-value ,unassigned-expression)))))))
+          (list (+ form)))
+       (lambda (close name bindings body-forms)
+        (let ((ids (map car bindings))
+              (vals (map cdr bindings)))
+          (if name
+              (generate-named-let close name ids vals body-forms)
+              `((,(close 'named-lambda)
+                 (,scode-lambda-name:let ,@ids)
+                 ,@body-forms)
+                ,@vals))))))
    system-global-environment))
 
 (define named-let-strategy 'internal-definition)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 2856084f9e70c7298973e171c6c61501d0b6cd8e..10881b824ab7ff18c2d4467a2c150477ccf7ca26 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4580,6 +4580,7 @@ USA.
          spar-repeat
          spar-seq
          spar-succeed
+         spar-top-level
          spar-transform-values
          spar-with-mapped-senv)
   (export (runtime syntax)

diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index d0c0b03709be1a6bbfe895e498636b5498e406ce..d3bdca6facdcf244833426070cec294f042bf464 100644 (file)
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -348,7 +348,7 @@ USA.
 (define (spar-match-null)
   (spar-match null? spar-arg:form))
 
-;;;; Environment combinators
+;;;; Classifier support
 
 (define (spar-with-mapped-senv procedure . spars)
   (let ((spar (%seq spars)))
@@ -360,7 +360,7 @@ USA.
              (declare (ignore senv*))
              (success input* senv output* failure*))
            failure))))
-\f
+
 (define-deferred spar-push-classified
   (spar-push-value classify-form
                   spar-arg:form
@@ -383,6 +383,18 @@ USA.
                   spar-arg:form
                   spar-arg:senv
                   spar-arg:hist))
+
+(define-deferred spar-push-body
+  (spar-seq
+    (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-elt spar-push-open-classified))
+      (spar-match-null))
+    (spar-push spar-arg:senv)))
 \f
 ;;;; Value combinators
 
@@ -426,21 +438,15 @@ USA.
                       (procedure output output*)
                       failure*))
            failure))))
-
-(define-deferred spar-push-body
-  (spar-seq
-    (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-elt spar-push-open-classified))
-      (spar-match-null))
-    (spar-push spar-arg:senv)))
 \f
 ;;;; Shorthand
 
+(define (spar-top-level pattern procedure)
+  (spar-call-with-values procedure
+    (spar-elt)
+    (spar-push spar-arg:close)
+    (pattern->spar pattern)))
+
 (define (make-pattern-compiler expr? caller)
   (call-with-constructors expr?
     (lambda (:* :+ :call :close :cons :elt :eqv? :form :hist :identifier? :list