From 18110ec09af4dda238f8b811424426102ec6881f Mon Sep 17 00:00:00 2001 From: Joe Marshall Date: Thu, 12 Jan 2012 19:32:15 -0800 Subject: [PATCH] Implement GENERATE-PATTERN-MATCHER. --- src/compiler/base/pmlook.scm | 37 ++++++++++++++++++++++++++++++++++-- 1 file changed, 35 insertions(+), 2 deletions(-) diff --git a/src/compiler/base/pmlook.scm b/src/compiler/base/pmlook.scm index c71e0bcd3..6e1bf30f1 100644 --- 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 '())) -- 2.25.1