Repository navigation
Expand file tree
/
Copy pathlocal.rkt
More file actions
123 lines (121 loc) · 6.47 KB
/
Copy pathlocal.rkt
File metadata and controls
123 lines (121 loc) · 6.47 KB
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
#lang racket/base
(require (for-syntax racket/base)
(for-syntax syntax/kerncase
racket/private/stx
"intdef-util.rkt"))
(provide (for-syntax do-local))
; splicing-hygiene-hack? note:
; This implementation is used for both `local` and `splicing-local`. In the
; case of `splicing-local`, local bindings will be rebound in the surrounding
; definition context via `define`. The expander does not understand that theese
; bindings are intended to be local to the form and will remove use-site
; scopes. To avoid ambiguous reference problems, do-local needs to treat
; use-site scopes in the same way for the initial bindings. So when
; splicing-hygiene-hack? is true, use-site scopes from the surronding context
; are removed from binding identifiers.
(define-for-syntax (do-local stx splicing-hygiene-hack? combine)
(syntax-case stx ()
[(_ (defn ...) body1 body ...)
(let* ([def-ctx (syntax-local-make-definition-context)]
[as-binding (lambda (id) (let ([id1 (syntax-local-identifier-as-binding id def-ctx)])
(if splicing-hygiene-hack?
(syntax-local-identifier-as-binding id1)
id1)))]
[expand-context (cons (gensym 'intdef)
(let ([orig-ctx (syntax-local-context)])
(if (pair? orig-ctx)
orig-ctx
null)))]
[defs (let ()
(let loop ([defns (syntax->list (syntax (defn ...)))])
(apply
append
(map
(lambda (defn)
(let ([d (local-expand
defn
expand-context
(kernel-form-identifier-list)
def-ctx)]
[check-ids (lambda (defn ids)
(for-each
(lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"not an identifier for definition"
defn
id)))
ids))])
(syntax-case d (define-values define-syntaxes begin)
[(begin defn ...)
(loop (syntax->list (syntax (defn ...))))]
[(define-values (id ...) body)
(let ([ids (syntax->list (syntax (id ...)))])
(check-ids d ids)
(syntax-local-bind-syntaxes (map as-binding ids) #f def-ctx)
(list d))]
[(define-values . rest)
(raise-syntax-error
#f "ill-formed definition" stx d)]
[(define-syntaxes (id ...) rhs)
(let ([ids (syntax->list (syntax (id ...)))])
(check-ids d ids)
(with-syntax ([rhs (local-transformer-expand
#'rhs
'expression
null)])
(syntax-local-bind-syntaxes (map as-binding ids) #'rhs def-ctx)
(list (datum->syntax d (list #'define-syntaxes #'(id ...) #'rhs) d d))))]
[(define-syntaxes . rest)
(raise-syntax-error
#f "ill-formed definition" stx d)]
[_else
(raise-syntax-error
#f "not a definition" stx defn)])))
defns))))])
(internal-definition-context-seal def-ctx)
(let ([ids (apply append
(map
(lambda (d)
(syntax-case d ()
[(_ ids . __) (syntax->list (syntax ids))]))
defs))]
[vbindings (apply append
(map (lambda (d)
(syntax-case d (define-values)
[(define-values ids rhs)
(with-syntax ([ids (map as-binding
(syntax->list #'ids))])
(list #'(ids rhs)))]
[_ null]))
defs))]
[sbindings (apply append
(map (lambda (d)
(syntax-case d (define-syntaxes)
[(define-syntaxes ids rhs)
(with-syntax ([ids (map as-binding
(syntax->list #'ids))])
(list #'(ids rhs)))]
[_ null]))
defs))])
(raise-if-duplicate-identifiers "duplicate identifier" stx ids)
(with-syntax ([sbindings sbindings]
[vbindings vbindings]
[(body ...)
(map (lambda (stx)
(internal-definition-context-introduce
def-ctx
stx
'add))
(syntax->list #'(body1 body ...)))])
(add-decl-props
def-ctx
defs
(combine def-ctx
expand-context
#'sbindings
#'vbindings
#'(body ...))))))]
[(_ x body1 body ...)
(raise-syntax-error #f "not a definition sequence" stx (syntax x))]))