From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 27 Mar 2018 07:29:18 +0000 (-0700)
Subject: Rewrite COND and DO to use spar rules.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~172
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3a9b060ca5abed8b60928ec16b26a6b9901b3d67;p=mit-scheme.git

Rewrite COND and DO to use spar rules.
---

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index cf64cb4ce..dc6c5edb1 100644
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -450,69 +450,76 @@ USA.
 	     (process-clauses clauses))))))
    system-global-environment))
 
-(define-syntax :cond
-  (er-macro-transformer
-   (lambda (form rename compare)
-     (let ((clauses (cdr form)))
-       (if (not (pair? clauses))
-	   (syntax-error "Form must have at least one clause:" form))
-       (let loop ((clause (car clauses)) (rest (cdr clauses)))
-	 (expand/cond-clause clause rename compare (null? rest)
-			     (if (pair? rest)
-				 (loop (car rest) (cdr rest))
-				 (unspecific-expression))))))))
-
-(define-syntax :do
-  (er-macro-transformer
-   (lambda (form rename compare)
-     (syntax-check '(_ (* (identifier expression ? expression))
-		       (+ form)
-		       * form)
-		   form)
-     (let ((bindings (cadr form))
-	   (r-loop (rename 'DO-LOOP)))
-       `(,(rename 'LET)
-	 ,r-loop
-	 ,(map (lambda (binding)
-		 (list (car binding) (cadr binding)))
-	       bindings)
-	 ,(expand/cond-clause (caddr form) rename compare #f
-			      `(,(rename 'BEGIN)
-				,@(cdddr form)
-				(,r-loop ,@(map (lambda (binding)
-						  (if (pair? (cddr binding))
-						      (caddr binding)
-						      (car binding)))
-						bindings)))))))))
-
-(define (expand/cond-clause clause rename compare else-allowed? alternative)
-  (if (not (and (pair? clause) (list? (cdr clause))))
-      (syntax-error "Ill-formed clause:" clause))
-  (cond ((and (identifier? (car clause))
-	      (compare (rename 'ELSE) (car clause)))
-	 (if (not else-allowed?)
-	     (syntax-error "Misplaced ELSE clause:" clause))
-	 (if (or (not (pair? (cdr clause)))
-		 (and (identifier? (cadr clause))
-		      (compare (rename '=>) (cadr clause))))
-	     (syntax-error "Ill-formed ELSE clause:" clause))
-	 `(,(rename 'BEGIN) ,@(cdr clause)))
-	((not (pair? (cdr clause)))
-	 `(,(rename 'OR) ,(car clause) ,alternative))
-	((and (identifier? (cadr clause))
-	      (compare (rename '=>) (cadr clause)))
-	 (if (not (and (pair? (cddr clause))
-		       (null? (cdddr clause))))
-	     (syntax-error "Ill-formed => clause:" clause))
-	 (let ((r-temp (rename 'TEMP)))
-	   `(,(rename 'LET) ((,r-temp ,(car clause)))
-			    (,(rename 'IF) ,r-temp
-					   (,(caddr clause) ,r-temp)
-					   ,alternative))))
-	(else
-	 `(,(rename 'IF) ,(car clause)
-			 (,(rename 'BEGIN) ,@(cdr clause))
-			 ,alternative))))
+(define :cond
+  (spar-transformer->runtime
+   (delay
+     (scons-rule
+	 `((list (* ,cons-clause-pattern))
+	   (or (list (elt (noise-keyword else)
+			  (+ any)))
+	       (values #f)))
+       (lambda (clauses else-actions)
+	 (let loop ((clauses clauses))
+	   (cond ((pair? clauses)
+		  (expand-cond-clause (car clauses)
+				      (loop (cdr clauses))))
+		 (else-actions (apply scons-begin else-actions))
+		 (else (unspecific-expression)))))))
+   system-global-environment))
+
+(define cons-clause-pattern
+  '(list (elt (and (not (noise-keyword else))
+		   any)
+	      (if (keyword =>)
+		  any
+		  (and (values begin)
+		       (* any))))))
+
+(define (expand-cond-clause clause rest)
+  (let ((predicate (car clause))
+	(type (cadr clause))
+	(actions (cddr clause)))
+    (case type
+      ((=>)
+       (let ((temp (new-identifier 'temp)))
+	 (scons-let (list (list temp predicate))
+	   (scons-if temp
+		     (scons-call (car actions) temp)
+		     rest))))
+      ((begin)
+       (if (pair? actions)
+	   (scons-if predicate
+		     (apply scons-begin actions)
+		     rest)
+	   (scons-or predicate rest)))
+      (else
+       (error "Unknown clause type:" type)))))
+
+(define :do
+  (spar-transformer->runtime
+   (delay
+     (scons-rule
+	 `((list (elt (* (list (elt id any (? any))))))
+	   ,cons-clause-pattern
+	   (list (* any)))
+       (lambda (bindings test-clause actions)
+	 (let ((loop-name (new-identifier 'do-loop)))
+	   (scons-named-let loop-name
+	       (map (lambda (binding)
+		      (list (car binding)
+			    (cadr binding)))
+		    bindings)
+	     (expand-cond-clause test-clause
+				 (scons-begin
+				   (apply scons-begin actions)
+				   (apply scons-call
+					  loop-name
+					  (map (lambda (binding)
+						 (if (pair? (cddr binding))
+						     (caddr binding)
+						     (car binding)))
+					       bindings)))))))))
+   system-global-environment))
 
 (define-syntax :quasiquote
   (er-macro-transformer