expander: repair local-expand
with definition context
When `local-expand` receives one or more internal definition contexts, it would forget about any current post-expansion scopes. That's particularly a problem in a 'module-begin expansion context, where the post-expansion scope ensures that any bindings are suitably phase-specific. Closes #2115
This commit is contained in:
parent
3fa6fef654
commit
a1b5bab31b
|
@ -2173,6 +2173,38 @@
|
||||||
|
|
||||||
(test 1 dynamic-require ''local-expand-result-depends-on-use-site-scope 'result)
|
(test 1 dynamic-require ''local-expand-result-depends-on-use-site-scope 'result)
|
||||||
|
|
||||||
|
;; ----------------------------------------
|
||||||
|
;; Make sure `local-expand` doesn't get confused about the
|
||||||
|
;; post-expansion scope needed to make a binding phase-specific
|
||||||
|
|
||||||
|
(module test-for-scope-specific-binding racket/base
|
||||||
|
|
||||||
|
(module l racket/base
|
||||||
|
(require (for-syntax racket/base racket/syntax)
|
||||||
|
syntax/parse/define)
|
||||||
|
|
||||||
|
(provide #%module-begin m
|
||||||
|
(all-from-out racket/base))
|
||||||
|
|
||||||
|
(define-syntax-parser #%module-begin
|
||||||
|
[(_ form ...)
|
||||||
|
(let ([intdef-ctx (syntax-local-make-definition-context #f #f)])
|
||||||
|
(local-expand #'(#%plain-module-begin form ...)
|
||||||
|
'module-begin
|
||||||
|
'()
|
||||||
|
intdef-ctx))])
|
||||||
|
|
||||||
|
(define-syntax-parser m
|
||||||
|
[(_)
|
||||||
|
#:with x (generate-temporary)
|
||||||
|
#'(begin
|
||||||
|
(define x #f)
|
||||||
|
;; The #' here triggers a `syntax-local-value` call:
|
||||||
|
(begin-for-syntax #'x))]))
|
||||||
|
|
||||||
|
(module c (submod ".." l)
|
||||||
|
(#%module-begin
|
||||||
|
(m))))
|
||||||
|
|
||||||
;; ----------------------------------------
|
;; ----------------------------------------
|
||||||
|
|
||||||
|
|
|
@ -232,6 +232,9 @@
|
||||||
(define def-ctx-scopes (if (expand-context-def-ctx-scopes ctx)
|
(define def-ctx-scopes (if (expand-context-def-ctx-scopes ctx)
|
||||||
(unbox (expand-context-def-ctx-scopes ctx))
|
(unbox (expand-context-def-ctx-scopes ctx))
|
||||||
null))
|
null))
|
||||||
|
(define placeholder-sc (and intdefs
|
||||||
|
(not (null? intdefs))
|
||||||
|
(new-scope 'macro)))
|
||||||
(struct*-copy expand-context ctx
|
(struct*-copy expand-context ctx
|
||||||
[context context]
|
[context context]
|
||||||
[env (add-intdef-bindings (expand-context-env ctx)
|
[env (add-intdef-bindings (expand-context-env ctx)
|
||||||
|
@ -256,11 +259,12 @@
|
||||||
[else (or frame-id i-frame-id)]))]
|
[else (or frame-id i-frame-id)]))]
|
||||||
[post-expansion-scope
|
[post-expansion-scope
|
||||||
#:parent root-expand-context
|
#:parent root-expand-context
|
||||||
(if (and intdefs (not (null? intdefs)))
|
(or (and same-kind?
|
||||||
(new-scope 'macro) ; placeholder; action uses `indefs`
|
|
||||||
(and same-kind?
|
|
||||||
(memq context '(module module-begin top-level))
|
(memq context '(module module-begin top-level))
|
||||||
(root-expand-context-post-expansion-scope ctx)))]
|
(root-expand-context-post-expansion-scope ctx))
|
||||||
|
;; Placeholder to make sure `post-expansion-scope-action`
|
||||||
|
;; is used
|
||||||
|
placeholder-sc)]
|
||||||
[post-expansion-shifts
|
[post-expansion-shifts
|
||||||
#:parent root-expand-context
|
#:parent root-expand-context
|
||||||
(if (and same-kind?
|
(if (and same-kind?
|
||||||
|
@ -268,10 +272,14 @@
|
||||||
(root-expand-context-post-expansion-shifts ctx)
|
(root-expand-context-post-expansion-shifts ctx)
|
||||||
null)]
|
null)]
|
||||||
[post-expansion-scope-action
|
[post-expansion-scope-action
|
||||||
(if (and intdefs (not (null? intdefs)))
|
(let ([act (expand-context-post-expansion-scope-action ctx)])
|
||||||
(lambda (s placeholder-sc)
|
(if (and intdefs (not (null? intdefs)))
|
||||||
(add-intdef-scopes s intdefs))
|
(lambda (s sc)
|
||||||
(expand-context-post-expansion-scope-action ctx))]
|
(define s2 (if (eq? sc placeholder-sc)
|
||||||
|
s
|
||||||
|
(act s sc)))
|
||||||
|
(add-intdef-scopes s2 intdefs))
|
||||||
|
act))]
|
||||||
[scopes
|
[scopes
|
||||||
(append def-ctx-scopes
|
(append def-ctx-scopes
|
||||||
(expand-context-scopes ctx))]
|
(expand-context-scopes ctx))]
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user