From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 28 Mar 2018 04:41:07 +0000 (-0700)
Subject: Rewrite patterns as (elt (list ...)) rather than (list (elt ...)).
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~167
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=48249e603bb357558442ea38ff166033e0a8f940;p=mit-scheme.git

Rewrite patterns as (elt (list ...)) rather than (list (elt ...)).
---

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index 8f047b032..a73bc6db8 100644
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -40,8 +40,8 @@ USA.
     (let ((clause-pattern* (lambda args (apply clause-pattern args))))
       (spar-or
 	(spar-push-elt-if identifier? spar-arg:form)
-	(spar-call-with-values list
-	  (spar-elt
+	(spar-elt
+	  (spar-call-with-values list
 	    (spar-or
 	      (spar-and (spar-push-elt-if spar-arg:compare 'or spar-arg:form)
 			(spar* clause-pattern*)
@@ -53,7 +53,7 @@ USA.
 			clause-pattern*
 			(spar-match-null))))))))
   `((values compare)
-    (list (+ (list (elt (spar ,clause-pattern)
+    (list (+ (elt (list (spar ,clause-pattern)
 			(* any)))))))
 
 (define (generate-cond-expand compare clauses)
@@ -188,7 +188,7 @@ USA.
 	       (and ,not (values #f))
 	       (elt id (list (* symbol))))
 	   (or id ,not)
-	   (list (* (list (elt symbol id (or id (values #f)))))))
+	   (list (* (elt (list symbol id (or id (values #f)))))))
        (lambda (type-name parent maker-name maker-args pred-name field-specs)
 	 (apply scons-begin
 		(scons-define type-name
@@ -391,12 +391,13 @@ USA.
    (delay
      (scons-rule
 	 (let ((action-pattern
-		'(if (keyword =>)
-		     any
+		'(if (noise-keyword =>)
+		     (and (values =>)
+			  any)
 		     (and (values begin)
 			  (+ any)))))
 	   `(any
-	     (list (* (list (elt (list (elt (* any)))
+	     (list (* (list (elt (elt (list (* any)))
 				 ,action-pattern))))
 	     (or (list (elt (noise-keyword else)
 			    ,action-pattern))
@@ -444,9 +445,9 @@ USA.
   (spar-transformer->runtime
    (delay
      (scons-rule
-	 `((list (* ,cons-clause-pattern))
-	   (or (list (elt (noise-keyword else)
-			  (+ any)))
+	 `((list (* ,cond-clause-pattern))
+	   (or (elt (noise-keyword else)
+		    (list (+ any)))
 	       (values #f)))
        (lambda (clauses else-actions)
 	 (fold-right expand-cond-clause
@@ -456,11 +457,12 @@ USA.
 		     clauses))))
    system-global-environment))
 
-(define cons-clause-pattern
-  '(list (elt (and (not (noise-keyword else))
+(define cond-clause-pattern
+  '(elt (list (and (not (noise-keyword else))
 		   any)
-	      (if (keyword =>)
-		  any
+	      (if (noise-keyword =>)
+		  (and (values =>)
+		       any)
 		  (and (values begin)
 		       (* any))))))
 
@@ -488,8 +490,8 @@ USA.
   (spar-transformer->runtime
    (delay
      (scons-rule
-	 `((list (elt (* (list (elt id any (? any))))))
-	   ,cons-clause-pattern
+	 `((elt (list (* (elt (list id any (? any))))))
+	   ,cond-clause-pattern
 	   (list (* any)))
        (lambda (bindings test-clause actions)
 	 (let ((loop-name (new-identifier 'do-loop)))
@@ -602,7 +604,7 @@ USA.
   (spar-transformer->runtime
    (delay
      (scons-rule
-	 `((list (elt (* (list (or id (elt any) (elt id any))))))
+	 `((elt (list (* (list (or id (elt any) (elt id any))))))
 	   (list (* any)))
        (lambda (clauses body-exprs)
 	 (let recur1 ((conjunct #t) (clauses clauses))