From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 28 Mar 2018 04:34:09 +0000 (-0700)
Subject: Convert and-let* to scons-rule.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~168
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c94a365e227e1c17d33c4b9af050a3ed857f0895;p=mit-scheme.git

Convert and-let* to scons-rule.
---

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 882fc8e92..8f047b032 100644
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -598,43 +598,26 @@ USA.
 ;;; follow.  This passes all of the tests except for the one that
 ;;; detects duplicate bound variables, though.
 
-(define-syntax :and-let*
-  (er-macro-transformer
-   (lambda (form rename compare)
-     compare
-     (let ((%and (rename 'AND))
-	   (%let (rename 'LET))
-	   (%begin (rename 'BEGIN)))
-       (cond ((syntax-match? '(() * form) (cdr form))
-	      `(,%begin #T ,@(cddr form)))
-	     ((syntax-match? '((* datum) * form) (cdr form))
-	      (let ((clauses (cadr form))
-		    (body (cddr form)))
-		(define (expand clause recur)
-		  (cond ((syntax-match? 'identifier clause)
-			 (recur clause))
-			((syntax-match? '(expression) clause)
-			 (recur (car clause)))
-			((syntax-match? '(identifier expression) clause)
-			 (let ((tail (recur (car clause))))
-			   (and tail `(,%let (,clause) ,tail))))
-			(else #f)))
-		(define (recur clauses make-body)
-		  (expand (car clauses)
-			  (let ((clauses (cdr clauses)))
-			    (if (null? clauses)
-				make-body
-				(lambda (conjunct)
-				  `(,%and ,conjunct
-					  ,(recur clauses make-body)))))))
-		(or (recur clauses
-			   (if (null? body)
-			       (lambda (conjunct) conjunct)
-			       (lambda (conjunct)
-				 `(,%and ,conjunct (,%begin ,@body)))))
-		    (ill-formed-syntax form))))
-	     (else
-	      (ill-formed-syntax form)))))))
+(define :and-let*
+  (spar-transformer->runtime
+   (delay
+     (scons-rule
+	 `((list (elt (* (list (or id (elt any) (elt id any))))))
+	   (list (* any)))
+       (lambda (clauses body-exprs)
+	 (let recur1 ((conjunct #t) (clauses clauses))
+	   (cond ((pair? clauses)
+		  (scons-and conjunct
+			     (let ((clause (car clauses)))
+			       (let ((rest (recur1 (car clause) (cdr clauses))))
+				 (if (pair? (cdr clause))
+				     (scons-let (list clause) rest)
+				     rest)))))
+		 ((pair? body-exprs)
+		  (scons-and conjunct (apply scons-begin body-exprs)))
+		 (else
+		  conjunct))))))
+   system-global-environment))
 
 (define :access
   (spar-transformer->runtime