Rewrite core of pattern compiler to use rules.

diff --git a/src/runtime/syntax-parser.scm b/src/runtime/syntax-parser.scm
index 9c9aafc934568820b824f724d57d370e8bdc54a7..868f44fa9f7b454b6310c5ba14b0eb8506c58e16 100644 (file)
--- 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