From 6f0c1d05bac42432c23ba7dc6c5b8c75e10f21bc Mon Sep 17 00:00:00 2001 From: Joe Marshall Date: Tue, 3 Jan 2012 21:45:43 -0800 Subject: [PATCH] Add pattern-lookup-2 --- src/compiler/base/pmlook.scm | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/src/compiler/base/pmlook.scm b/src/compiler/base/pmlook.scm index 0c8d24902..97ac27a57 100644 --- a/src/compiler/base/pmlook.scm +++ b/src/compiler/base/pmlook.scm @@ -69,6 +69,31 @@ USA. (and binding-alist (apply body (map cdr binding-alist))))) +;;; PATTERN-LOOKUP-2 returns either #f or the result of applying +;;; to the values matched by the pattern. The values +;;; are in reverse order of variable occurrence in the pattern. +;;; There must be no repeated occurrences of a pattern variable. + +(define (pattern-lookup-2 pattern body instance) + (let ((value-list + (let loop ((pattern pattern) + (instance instance) + (value-list '())) + ;; Cheat: we know pattern variables are pairs + (cond ((pair? pattern) + (cond ((eq? (car pattern) pattern-variable-tag) + (cons instance value-list)) + ((pair? instance) + (let ((value-list* + (loop (car pattern) (car instance) value-list))) + (and value-list* + (loop (cdr pattern) (cdr instance) value-list*)))) + (else #f))) + ((eqv? pattern instance) value-list) + (else #f))))) + (and value-list + (apply body value-list)))) + (define (pattern-variables pattern) (let loop ((pattern pattern) (vars '())) (cond ((pair? pattern) -- 2.25.1