From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001 From: Yale AI Dept Date: Wed, 14 Jul 1993 13:08:00 -0500 Subject: Import to github. --- util/pattern-vars.scm | 40 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) create mode 100644 util/pattern-vars.scm (limited to 'util/pattern-vars.scm') diff --git a/util/pattern-vars.scm b/util/pattern-vars.scm new file mode 100644 index 0000000..78cb361 --- /dev/null +++ b/util/pattern-vars.scm @@ -0,0 +1,40 @@ +;;; This collects the vars bound in a pattern. + +(define-walker collect-pattern-vars ast-td-collect-pattern-vars-walker) + +(define (collect-pattern-vars x) + (collect-pattern-vars-1 x '())) + +(define (collect-pattern-vars-1 x vars-so-far) + (call-walker collect-pattern-vars x vars-so-far)) + +(define (collect-pattern-vars/list l vars-so-far) + (if (null? l) + vars-so-far + (collect-pattern-vars/list (cdr l) + (collect-pattern-vars-1 (car l) vars-so-far)))) + +(define-local-syntax (collect-pattern-vars-processor + slot type object-form accum-form) + (let ((stype (sd-type slot)) + (sname (sd-name slot))) + (cond ((eq? stype 'var-ref) + `(cons (struct-slot ',type ',sname ,object-form) ,accum-form)) + ((eq? stype 'pattern) + `(collect-pattern-vars-1 + (struct-slot ',type ',sname ,object-form) + ,accum-form)) + ((equal? stype '(list pattern)) + `(collect-pattern-vars/list + (struct-slot ',type ',sname ,object-form) ,accum-form)) + (else +; (format '#t "Collect-pattern-vars: skipping slot ~A in ~A~%" +; sname +; type) + accum-form) + ))) + +(define-collecting-walker-methods collect-pattern-vars + (as-pat irr-pat var-pat wildcard-pat const-pat plus-pat pcon list-pat + pp-pat-list pp-pat-plus pp-pat-negated) + collect-pattern-vars-processor) -- cgit v1.2.3