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
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
#lang racket/base
(require syntax/stx
"stx-util.rkt")
(provide (struct-out ref)
(struct-out tail)
path-get
pathseg-get
path-replace
pathseg-replace)
;; A Path is a (list-of PathSeg)
;; where the PathSegs are listed outermost to innermost
;; for example: (path-get #'((a b) (c d)) (list (make-ref 0) (make-ref 1))) = #'b, not #'c
;; A PathSeg is one of:
;; - (make-ref number)
;; - (make-tail number)
(define-struct pathseg () #:transparent)
(define-struct (ref pathseg) (n) #:transparent)
(define-struct (tail pathseg) (n) #:transparent)
;; path-get : syntax Path -> syntax
(define (path-get stx path)
(let loop ([stx stx] [path path])
(cond [(null? path) stx]
[(pair? path)
(loop (pathseg-get stx (car path)) (cdr path))]
[else
(error 'path-get "bad path: ~s" path)])))
;; pathseg-get : syntax PathSeg -> syntax
(define (pathseg-get stx path)
(cond [(ref? path) (pathseg-get/ref stx (ref-n path))]
[(tail? path) (pathseg-get/tail stx (tail-n path))]))
;; pathseg-get/ref : syntax number -> syntax
(define (pathseg-get/ref stx0 n0)
(let loop ([n n0] [stx stx0])
(unless (stx-pair? stx)
(error 'pathseg-get "ref path out of bounds for syntax: ~s, ~s"
n0
(syntax->datum stx0)))
(if (zero? n)
(stx-car* stx)
(loop (sub1 n) (stx-cdr* stx)))))
;; pathseg-get/tail : syntax number -> syntax
(define (pathseg-get/tail stx0 n0)
(let loop ([n n0] [stx stx0])
(unless (stx-pair? stx)
(error 'pathseg-get "tail path out of bounds for syntax: ~s, ~s" n0 stx0))
(if (zero? n)
(stx-cdr* stx)
(loop (sub1 n) (stx-cdr* stx)))))
;; path-replace : syntax Path syntax -> syntax
(define (path-replace stx path x)
(cond [(null? path) x]
[(pair? path)
(let ([pathseg0 (car path)])
(pathseg-replace stx
pathseg0
(path-replace (pathseg-get stx pathseg0)
(cdr path)
x)))]
[else
(error 'path-replace "bad path: ~s" path)]))
;; pathseg-replace : syntax PathSeg syntax -> syntax
(define (pathseg-replace stx pathseg x)
(cond [(ref? pathseg) (pathseg-replace/ref stx (ref-n pathseg) x)]
[(tail? pathseg) (pathseg-replace/tail stx (tail-n pathseg) x)]
[else (error 'pathseg-replace "bad path: ~s" pathseg)]))
;; pathseg-replace/ref : syntax number syntax -> syntax
(define (pathseg-replace/ref stx0 n0 x)
(let loop ([n n0] [stx stx0])
(unless (stx-pair? stx)
(error 'pathseg-replace "ref path out of bounds for syntax: ~s, ~s" n0 stx0))
(if (zero? n)
(stx-replcar stx x)
(stx-replcdr stx (loop (sub1 n) (stx-cdr* stx))))))
;; pathseg-replace/tail : syntax number syntax -> syntax
(define (pathseg-replace/tail stx0 n0 x)
(let loop ([n n0] [stx stx0])
(unless (stx-pair? stx)
(error 'pathseg-replace "tail path out of bounds for syntax: ~s, ~s" n0 stx0))
(if (zero? n)
(stx-replcdr stx x)
(stx-replcdr stx (loop (sub1 n) (stx-cdr* stx))))))
;; stx-replcar : syntax syntax -> syntax
(define (stx-replcar stx x)
(cond [(pair? stx)
(cons x (cdr stx))]
[(syntax? stx)
(syntax-rearm
(datum->syntax stx (cons x (cdr (syntax-e stx))) stx stx)
stx)]
[else (raise-type-error 'stx-replcar "stx-pair" stx)]))
;; stx-replcdr : syntax syntax -> syntax
(define (stx-replcdr stx x)
(cond [(pair? stx)
(cons (car stx) x)]
[(and (syntax? stx) (pair? (syntax-e stx)))
(syntax-rearm
(datum->syntax stx (cons (car (syntax-e stx)) x) stx stx)
stx)]
[else (raise-type-error 'stx-replcdr "stx-pair" stx)]))
|
