From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 14 Feb 2018 06:11:44 +0000 (-0800)
Subject: Simplify slightly be introducing smap.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~244
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5f98da834186decffe24bb5355fd820059e7361d;p=mit-scheme.git

Simplify slightly be introducing smap.
---

diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm
index e9f9147cb..eb479b05d 100644
--- 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 d2f39a979..212a23e41 100644
--- 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 856da4569..866583009 100644
--- 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