1 files changed, 40 insertions, 0 deletions
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)