Simplify slightly be introducing smap.

diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index e9f9147cb4572d6d665eaa2f3ffd2bf67b77bd40..eb479b05d51596175b8072f2727e6bac3aac7d7d 100644 (file)
--- a/src/runtime/mit-syntax.scm
+++ b/src/runtime/mit-syntax.scm
@@ -195,11 +195,11 @@ USA.
    (lambda (form senv hist)
      (let* ((body-senv (make-internal-senv senv))
            (bindings
-            (map (lambda (binding hist)
-                   (cons (bind-variable (car binding) body-senv)
-                         (classify-form-cadr binding senv hist)))
-                 (cadr form)
-                 (subform-hists (cadr form) (hist-cadr hist)))))
+            (smap (lambda (binding hist)
+                    (cons (bind-variable (car binding) body-senv)
+                          (classify-form-cadr binding senv hist)))
+                  (cadr form)
+                  (hist-cadr hist))))
        (let-item (map car bindings)
                 (map cdr bindings)
                 (body-item
@@ -210,12 +210,12 @@ USA.
 (define (classifier:let-syntax form senv hist)
   (syntax-check '(_ (* (identifier expression)) + form) form)
   (let ((body-senv (make-internal-senv senv)))
-    (for-each (lambda (binding hist)
-               (keyword-binder body-senv
-                               (car binding)
-                               (classify-form-cadr binding senv hist)))
-             (cadr form)
-             (subform-hists (cadr form) (hist-cadr hist)))
+    (sfor-each (lambda (binding hist)
+                (keyword-binder body-senv
+                                (car binding)
+                                (classify-form-cadr binding senv hist)))
+              (cadr form)
+              (hist-cadr hist))
     (seq-item
      (classify-forms-in-order-cddr form body-senv hist))))
 
@@ -239,10 +239,10 @@ USA.
         (for-each (lambda (binding item)
                     (keyword-binder binding-senv (car binding) item))
                   bindings
-                  (map (lambda (binding hist)
+                  (smap (lambda (binding hist)
                          (classify-form-cadr binding binding-senv hist))
                        bindings
-                       (subform-hists bindings (hist-cadr hist)))))
+                       (hist-cadr hist))))
        (seq-item
        (classify-forms-in-order-cddr form
                                      (make-internal-senv binding-senv)
@@ -294,18 +294,16 @@ USA.
   (classifier->runtime
    (lambda (form senv hist)
      (syntax-check '(_ * (identifier * datum)) form)
-     (decl-item (lambda () (classify-decls (cdr form) senv (hist-cdr hist)))))))
-
-(define (classify-decls decls senv hist)
-  (map (lambda (decl hist)
-        (classify-decl decl senv hist))
-       decls
-       (subform-hists decls hist)))
-
-(define (classify-decl decl senv hist)
-  (map-decl-ids (lambda (id selector)
-                 (classify-id id senv (hist-select selector hist)))
-               decl))
+     (decl-item
+      (lambda ()
+       (smap (lambda (decl hist)
+               (map-decl-ids (lambda (id selector)
+                               (classify-id id
+                                            senv
+                                            (hist-select selector hist)))
+                             decl))
+             (cdr form)
+             (hist-cdr hist)))))))
 
 (define (classify-id id senv hist)
   (let ((item (classify-form id senv hist)))

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index d2f39a979a4f237e2417560add3f329e1e9a44da..212a23e41898cf3f20e5b0f5bb3a86c308bfed5e 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4436,7 +4436,8 @@ USA.
          hist-select
          initial-hist
          raw-identifier?
-         subform-hists))
+         sfor-each
+         smap))
 
 (define-package (runtime syntax items)
   (files "syntax-items")

diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index 856da4569cbe4263efdbd93ec1a0487a97a65174..866583009036b0b22697cf4f5dcd8db360eb0fe0 100644 (file)
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -103,19 +103,19 @@ USA.
   (classify-form form env (hist-reduce form hist)))
 
 (define (classify-forms forms senv hist)
-  (map (lambda (expr hist)
-        (classify-form expr senv hist))
-       forms
-       (subform-hists forms hist)))
+  (smap (lambda (expr hist)
+         (classify-form expr senv hist))
+       forms
+       hist))
 
 (define (classify-forms-cdr form senv hist)
   (classify-forms (cdr form) senv (hist-cdr hist)))
 
 (define (classify-forms-in-order forms senv hist)
-  (map-in-order (lambda (form hist)
-                 (classify-form form senv hist))
-               forms
-               (subform-hists forms hist)))
+  (smap-in-order (lambda (form hist)
+                  (classify-form form senv hist))
+                forms
+                hist))
 
 (define (classify-forms-in-order-cdr form senv hist)
   (classify-forms-in-order (cdr form) senv (hist-cdr hist)))
@@ -331,4 +331,13 @@ USA.
     (if (pair? (car lists))
        (loop (map cdr lists)
              (cons (apply procedure (map car lists)) values))
-       (reverse! values))))
\ No newline at end of file
+       (reverse! values))))
+
+(define (smap procedure forms hist)
+  (map procedure forms (subform-hists forms hist)))
+
+(define (smap-in-order procedure forms hist)
+  (map-in-order procedure forms (subform-hists forms hist)))
+
+(define (sfor-each procedure forms hist)
+  (for-each procedure forms (subform-hists forms hist)))
\ No newline at end of file