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
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
|
#lang racket/base
(require racket/stxparam
syntax/parse/private/residual ;; keep abs. path
(for-syntax racket/base
racket/list
syntax/kerncase
syntax/strip-context
racket/private/sc
racket/syntax
"rep-data.rkt"))
(provide with
fail-handler
cut-prompt
undo-stack
wrap-user-code
fail
try
let-attributes
let-attributes*
let/unpack
defattrs/unpack
check-literal
no-shadow
curried-stxclass-parser
app-argu)
#|
TODO: rename file
This file contains "runtime" (ie, phase 0) auxiliary *macros* used in
expansion of syntax-parse etc. This file must not contain any
reference that persists in a compiled program; those must go in
residual.rkt.
|#
;; == with ==
(define-syntax (with stx)
(syntax-case stx ()
[(with ([stxparam expr] ...) . body)
(with-syntax ([(var ...) (generate-temporaries #'(stxparam ...))])
(syntax/loc stx
(let ([var expr] ...)
(syntax-parameterize ((stxparam (make-rename-transformer (quote-syntax var)))
...)
. body))))]))
;; == Control information ==
(define-syntax-parameter fail-handler
(lambda (stx)
(wrong-syntax stx "internal error: fail-handler used out of context")))
(define-syntax-parameter cut-prompt
(lambda (stx)
(wrong-syntax stx "internal error: cut-prompt used out of context")))
(define-syntax-parameter undo-stack
(lambda (stx)
(wrong-syntax stx "internal error: undo-stack used out of context")))
(define-syntax-rule (wrap-user-code e)
(with ([fail-handler #f]
[cut-prompt #t]
[undo-stack null])
e))
(define-syntax-rule (fail fs)
(fail-handler undo-stack fs))
(define-syntax (try stx)
(syntax-case stx ()
[(try e0 e ...)
(with-syntax ([(re ...) (reverse (syntax->list #'(e ...)))])
(with-syntax ([(fh ...) (generate-temporaries #'(re ...))])
(with-syntax ([(next-fh ... last-fh) #'(fail-handler fh ...)])
#'(let* ([fh (lambda (undos1 fs1)
(with ([fail-handler
(lambda (undos2 fs2)
(unwind-to undos2 undos1)
(next-fh undos1 (cons fs1 fs2)))]
[undo-stack undos1])
re))]
...)
(with ([fail-handler
(lambda (undos2 fs2)
(unwind-to undos2 undo-stack)
(last-fh undo-stack fs2))]
[undo-stack undo-stack])
e0)))))]))
;; == Attributes
(define-for-syntax (parse-attr x)
(syntax-case x ()
[#s(attr name depth syntax?) #'(name depth syntax?)]))
(define-syntax (let-attributes stx)
(syntax-case stx ()
[(let-attributes ([a value] ...) . body)
(with-syntax ([((name depth syntax?) ...)
(map parse-attr (syntax->list #'(a ...)))])
(with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))]
[(stmp ...) (generate-temporaries #'(name ...))])
#'(letrec-syntaxes+values
([(stmp) (attribute-mapping (quote-syntax vtmp) 'name 'depth
(if 'syntax? #f (quote-syntax check-attr-value)))]
...)
([(vtmp) value] ...)
(letrec-syntaxes+values
([(name) (make-syntax-mapping 'depth (quote-syntax stmp))] ...)
()
. body))))]))
;; (let-attributes* (([id num] ...) (expr ...)) expr) : expr
;; Special case: empty attrs need not match number of value exprs.
(define-syntax let-attributes*
(syntax-rules ()
[(la* (() _) . body)
(let () . body)]
[(la* ((a ...) (val ...)) . body)
(let-attributes ([a val] ...) . body)]))
;; (let/unpack (([id num] ...) expr) expr) : expr
;; Special case: empty attrs need not match packed length
(define-syntax (let/unpack stx)
(syntax-case stx ()
[(let/unpack (() packed) body)
#'body]
[(let/unpack ((a ...) packed) body)
(with-syntax ([(tmp ...) (generate-temporaries #'(a ...))])
#'(let-values ([(tmp ...) (apply values packed)])
(let-attributes ([a tmp] ...) body)))]))
(define-syntax (defattrs/unpack stx)
(syntax-case stx ()
[(defattrs (a ...) packed)
(with-syntax ([((name depth syntax?) ...)
(map parse-attr (syntax->list #'(a ...)))])
(with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))]
[(stmp ...) (generate-temporaries #'(name ...))])
#'(begin (define-values (vtmp ...) (apply values packed))
(define-syntax stmp
(attribute-mapping (quote-syntax vtmp) 'name 'depth
(if 'syntax? #f (quote-syntax check-attr-value))))
...
(define-syntax name (make-syntax-mapping 'depth (quote-syntax stmp)))
...)))]))
(define-syntax-rule (phase-of-enclosing-module)
(variable-reference->module-base-phase
(#%variable-reference)))
;; (check-literal id phase-level-expr ctx) -> void
(define-syntax (check-literal stx)
(syntax-case stx ()
[(check-literal id used-phase-expr ctx)
(let* ([ok-phases/ct-rel
;; id is bound at each of ok-phases/ct-rel
;; (phase relative to the compilation of the module in which the
;; 'syntax-parse' (or related) form occurs)
(filter (lambda (p) (identifier-binding #'id p)) '(0 1 -1 #f))])
;; so we can avoid run-time call to identifier-binding if
;; (+ (phase-of-enclosing-module) ok-phase/ct-rel) = used-phase
(with-syntax ([ok-phases/ct-rel ok-phases/ct-rel])
#`(check-literal* (quote-syntax id)
used-phase-expr
(phase-of-enclosing-module)
'ok-phases/ct-rel
;; If context is not stripped, racket complains about
;; being unable to restore bindings for compiled code;
;; and all we want is the srcloc, etc.
(quote-syntax #,(strip-context #'ctx)))))]))
;; ====
(begin-for-syntax
(define (check-shadow def)
(syntax-case def ()
[(_def (x ...) . _)
(parameterize ((current-syntax-context def))
(for ([x (in-list (syntax->list #'(x ...)))])
(let ([v (syntax-local-value x (lambda _ #f))])
(when (syntax-pattern-variable? v)
(wrong-syntax
x
;; FIXME: customize "~do pattern" vs "#:do block" as appropriate
"definition in ~~do pattern must not shadow attribute binding")))))])))
(define-syntax (no-shadow stx)
(syntax-case stx ()
[(no-shadow e)
(let ([ee (local-expand #'e (syntax-local-context)
(kernel-form-identifier-list))])
(syntax-case ee (begin define-values define-syntaxes)
[(begin d ...)
#'(begin (no-shadow d) ...)]
[(define-values . _)
(begin (check-shadow ee)
ee)]
[(define-syntaxes . _)
(begin (check-shadow ee)
ee)]
[_
ee]))]))
(define-syntax (curried-stxclass-parser stx)
(syntax-case stx ()
[(_ class argu)
(with-syntax ([#s(arguments (parg ...) (kw ...) _) #'argu])
(let ([sc (get-stxclass/check-arity #'class #'class
(length (syntax->list #'(parg ...)))
(syntax->datum #'(kw ...)))])
(with-syntax ([parser (stxclass-parser sc)])
#'(lambda (x cx pr es undos fh cp rl success)
(app-argu parser x cx pr es undos fh cp rl success argu)))))]))
(define-syntax (app-argu stx)
(syntax-case stx ()
[(aa proc extra-parg ... #s(arguments (parg ...) (kw ...) (kwarg ...)))
#|
Use keyword-apply directly?
#'(keyword-apply proc '(kw ...) (list kwarg ...) parg ... null)
If so, create separate no-keyword clause.
|#
;; For now, let #%app handle it.
(with-syntax ([((kw-part ...) ...) #'((kw kwarg) ...)])
#'(proc kw-part ... ... extra-parg ... parg ...))]))
|
