Implement GENERATE-PATTERN-MATCHER.

diff --git a/src/compiler/base/pmlook.scm b/src/compiler/base/pmlook.scm
index c71e0bcd38c81fc68473af51f389123067bfd731..6e1bf30f1da70815351bab053ebe791f379d0ca9 100644 (file)
--- a/src/compiler/base/pmlook.scm
+++ b/src/compiler/base/pmlook.scm
@@ -94,9 +94,42 @@ USA.
     (and value-list
         (apply body value-list))))
 
-;; Stub definition for the moment.
+;; GENERATE-PATTERN-MATCHER compiles a pattern into Scheme code.
+;; There must be no repeated occurrences of a pattern variable.
 (define (generate-pattern-matcher pattern body environment)
-  (error "GENERATE-PATTERN-MATCHER: Stub not yet implemented."))
+  (let ((r-and     (close-syntax 'AND environment))
+       (r-declare (close-syntax 'DECLARE environment))
+       (r-car     (close-syntax 'CAR environment))
+       (r-cdr     (close-syntax 'CDR environment))
+       (r-eq?     (close-syntax 'EQ? environment))
+       (r-eqv?    (close-syntax 'EQV? environment))
+       (r-lambda  (close-syntax 'LAMBDA environment))
+       (r-not     (close-syntax 'NOT environment))
+       (r-null?   (close-syntax 'NULL? environment))
+       (r-pair?   (close-syntax 'PAIR? environment))
+       (r-quote   (close-syntax 'QUOTE environment)))
+    (let descend ((pattern pattern)
+                 (body `(,body ,@(pattern-variables pattern))))
+      (if (pair? pattern)
+         (if (eq? (car pattern) pattern-variable-tag)
+             `(,r-lambda (,(cdr pattern)) ,body)
+             (let ((instance (generate-uninterned-symbol)))
+               `(,r-lambda (,instance)
+                           (,r-and (,r-pair? ,instance)
+                                   (,(descend (car pattern)
+                                           `(,(descend (cdr pattern) body)
+                                             (,r-cdr ,instance)))
+                                    (,r-car ,instance))))))
+         (let ((instance (generate-uninterned-symbol)))
+           `(,r-lambda (,instance)
+               (,r-declare (integrate ,instance))
+               (,r-and
+                ,(cond ((symbol? pattern) `(,r-eq?   ,instance (,r-quote ,pattern)))
+                       ((null? pattern)   `(,r-null? ,instance))
+                       ((not pattern)     `(,r-not   ,instance))
+                       ((fixnum? pattern) `(,r-eq?   ,instance ,pattern))
+                       (else              `(,r-eqv?  ,instance (,r-quote ,pattern))))
+                ,body)))))))
 
 (define (pattern-variables pattern)
   (let loop ((pattern pattern) (vars '()))