From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 23 Mar 2018 06:33:38 +0000 (-0700)
Subject: Rewrite core of pattern compiler to use rules.
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~187
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=12f81af2399cd524c031479a61c83357053ed25a;p=mit-scheme.git

Rewrite core of pattern compiler to use rules.
---

diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index 9c9aafc93..868f44fa9 100644
--- a/src/runtime/syntax-parser.scm
+++ b/src/runtime/syntax-parser.scm
@@ -457,56 +457,46 @@ USA.
 		:push-elt-if :push-value :r4rs-bvl? :senv :seq :symbol? :value)
 
       (define (loop pattern)
-	(cond ((not pattern)
-	       (:push-elt-if (:not) (:form)))
-	      ((symbol? pattern)
-	       (case pattern
-		 ((symbol) (:push-elt-if (:symbol?) (:form)))
-		 ((identifier id) (:push-elt-if (:id?) (:form)))
-		 ((form expr) (:push-elt (:form)))
-		 ((r4rs-bvl) (:push-elt-if (:r4rs-bvl?) (:form)))
-		 ((mit-bvl) (:push-elt-if (:mit-bvl?) (:form)))
-		 ((ignore) (:elt))
-		 (else (bad-pattern pattern))))
-	      ((procedure? pattern)
-	       (:push-elt-if pattern (:form)))
-	      ((and (pair? pattern)
-		    (list? (cdr pattern)))
-	       (case (car pattern)
-		 ((*) (apply :* (map loop (cdr pattern))))
-		 ((+) (apply :+ (map loop (cdr pattern))))
-		 ((?) (apply :opt (map loop (cdr pattern))))
-		 ((or) (apply :or (map loop (cdr pattern))))
-		 ((seq) (apply :seq (map loop (cdr pattern))))
-		 ((quote)
-		  (if (not (and (pair? (cdr pattern))
-				(null? (cddr pattern))))
-		      (bad-pattern pattern))
-		  (:match-elt (:eqv?) (cadr pattern) (:form)))
-		 ((keyword)
-		  (if (not (and (pair? (cdr pattern))
-				(identifier? (cadr pattern))
-				(null? (cddr pattern))))
-		      (bad-pattern pattern))
+	(let-syntax
+	    ((rules
+	      (sc-macro-transformer
+	       (lambda (form senv)
+		 (declare (ignore senv))
+		 `(cond ,@(map (lambda (rule)
+				 `((syntax-match? ,(car rule) pattern)
+				   ,@(cdr rule)))
+			       (cdr form))
+			(else (bad-pattern pattern)))))))
+	  (rules (''symbol (:push-elt-if (:symbol?) (:form)))
+		 ('(or 'identifier 'id) (:push-elt-if (:id?) (:form)))
+		 ('(or 'form 'expr) (:push-elt (:form)))
+		 (''r4rs-bvl (:push-elt-if (:r4rs-bvl?) (:form)))
+		 (''mit-bvl (:push-elt-if (:mit-bvl?) (:form)))
+		 (''ignore (:elt))
+		 (not (:push-elt-if (:not) (:form)))
+		 (procedure? (:push-elt-if pattern (:form)))
+		 ('('spar form) (cadr pattern))
+		 ('('* * form) (apply :* (map loop (cdr pattern))))
+		 ('('+ * form) (apply :+ (map loop (cdr pattern))))
+		 ('('? * form) (apply :opt (map loop (cdr pattern))))
+		 ('('or * form) (apply :or (map loop (cdr pattern))))
+		 ('('seq * form) (apply :seq (map loop (cdr pattern))))
+		 ('('quote form) (:match-elt (:eqv?) (cadr pattern) (:form)))
+		 ('('keyword identifier)
 		  (:match-elt (:compare) (cadr pattern) (:form)))
-		 ((values) (apply :push (map convert-spar-arg (cdr pattern))))
-		 ((value-of)
-		  (apply :push-value
-			 (cadr pattern)
-			 (map convert-spar-arg (cddr pattern))))
-		 ((list) (apply :call (:list) (map loop (cdr pattern))))
-		 ((cons) (apply :call (:cons) (map loop (cdr pattern))))
-		 ((call) (apply :call (cadr pattern) (map loop (cddr pattern))))
-		 ((spar)
-		  (if (not (and (pair? (cdr pattern))
-				(null? (cddr pattern))))
-		      (bad-pattern pattern))
-		  (cadr pattern))
-		 ((elt)
+		 ('('values * form)
+		  (apply :push (map convert-spar-arg (cdr pattern))))
+		 ('('value-of + form)
+		  (apply :push-value (map convert-spar-arg (cdr pattern))))
+		 ('('list * form)
+		  (apply :call (:list) (map loop (cdr pattern))))
+		 ('('cons * form)
+		  (apply :call (:cons) (map loop (cdr pattern))))
+		 ('('call + form)
+		  (apply :call (cadr pattern) (map loop (cddr pattern))))
+		 ('('elt * form)
 		  (:elt (apply :seq (map loop (cdr pattern)))
-			(:match-null)))
-		 (else (bad-pattern pattern))))
-	      (else (bad-pattern pattern))))
+			(:match-null))))))
 
       (define (convert-spar-arg arg)
 	(case arg