blob: 78cb36190f776753031ec6479eafb4b2fcf9f544 (
about) (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
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)
|