From: Joe Marshall Date: Wed, 4 Jan 2012 05:45:43 +0000 (-0800) Subject: Add pattern-lookup-2 X-Git-Tag: release-9.2.0~334^2~34 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6f0c1d05bac42432c23ba7dc6c5b8c75e10f21bc;p=mit-scheme.git Add pattern-lookup-2 --- 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)