expander: fix problem with module->namespace
and shifts
When expanding in a namespace for a module unmarshaled from ".zo" form, a scope corresponding to the module's "inside edge" is added to every expansion. Before this repair, the scope was detached from module path index shifts that might apply to the bindings (including references to bulk bindings). Repair the problem by adding suitable shifts when adding the scope. Thanks to William Hatch for the bug report.
This commit is contained in:
parent
53f7a95dc2
commit
32b256886e
|
@ -76,6 +76,7 @@
|
||||||
(expand-context (root-expand-context-self-mpi root-ctx)
|
(expand-context (root-expand-context-self-mpi root-ctx)
|
||||||
(root-expand-context-module-scopes root-ctx)
|
(root-expand-context-module-scopes root-ctx)
|
||||||
(root-expand-context-post-expansion-scope root-ctx)
|
(root-expand-context-post-expansion-scope root-ctx)
|
||||||
|
(root-expand-context-post-expansion-shifts root-ctx)
|
||||||
(root-expand-context-top-level-bind-scope root-ctx)
|
(root-expand-context-top-level-bind-scope root-ctx)
|
||||||
(root-expand-context-all-scopes-stx root-ctx)
|
(root-expand-context-all-scopes-stx root-ctx)
|
||||||
(root-expand-context-use-site-scopes root-ctx)
|
(root-expand-context-use-site-scopes root-ctx)
|
||||||
|
|
|
@ -260,6 +260,12 @@
|
||||||
(and same-kind?
|
(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)))]
|
||||||
|
[post-expansion-shifts
|
||||||
|
#:parent root-expand-context
|
||||||
|
(if (and same-kind?
|
||||||
|
(eq? context 'top-level))
|
||||||
|
(root-expand-context-post-expansion-shifts ctx)
|
||||||
|
null)]
|
||||||
[post-expansion-scope-action
|
[post-expansion-scope-action
|
||||||
(if (and intdefs (not (null? intdefs)))
|
(if (and intdefs (not (null? intdefs)))
|
||||||
(lambda (s placeholder-sc)
|
(lambda (s placeholder-sc)
|
||||||
|
|
|
@ -463,9 +463,11 @@
|
||||||
;; if the macro expands to a definition form, the binding will be
|
;; if the macro expands to a definition form, the binding will be
|
||||||
;; in the definition context's scope. The sepcific action depends
|
;; in the definition context's scope. The sepcific action depends
|
||||||
;; on the expansion context.
|
;; on the expansion context.
|
||||||
|
(define new-s
|
||||||
((expand-context-post-expansion-scope-action ctx)
|
((expand-context-post-expansion-scope-action ctx)
|
||||||
s
|
s
|
||||||
(root-expand-context-post-expansion-scope ctx))]
|
(root-expand-context-post-expansion-scope ctx)))
|
||||||
|
(syntax-add-shifts new-s (root-expand-context-post-expansion-shifts ctx))]
|
||||||
[else s]))
|
[else s]))
|
||||||
|
|
||||||
(define (accumulate-def-ctx-scopes ctx def-ctx-scopes)
|
(define (accumulate-def-ctx-scopes ctx def-ctx-scopes)
|
||||||
|
|
|
@ -21,6 +21,7 @@
|
||||||
(self-mpi ; MPI for the enclosing module during compilation
|
(self-mpi ; MPI for the enclosing module during compilation
|
||||||
module-scopes ; list of scopes for enclosing module or top level; includes next two fields
|
module-scopes ; list of scopes for enclosing module or top level; includes next two fields
|
||||||
* post-expansion-scope ; #f or scope to add to every expansion; often module's inside edge
|
* post-expansion-scope ; #f or scope to add to every expansion; often module's inside edge
|
||||||
|
* post-expansion-shifts ; a list of MPIshifts to go with `post-expansion-scope`
|
||||||
top-level-bind-scope ; #f or a scope to constrain expansion bindings; see "expand-bind-top.rkt"
|
top-level-bind-scope ; #f or a scope to constrain expansion bindings; see "expand-bind-top.rkt"
|
||||||
all-scopes-stx ; scopes like the initial import, which correspond to original forms
|
all-scopes-stx ; scopes like the initial import, which correspond to original forms
|
||||||
* use-site-scopes ; #f or boxed list: scopes that should be pruned from binders
|
* use-site-scopes ; #f or boxed list: scopes that should be pruned from binders
|
||||||
|
@ -41,6 +42,7 @@
|
||||||
(root-expand-context self-mpi
|
(root-expand-context self-mpi
|
||||||
module-scopes
|
module-scopes
|
||||||
post-expansion-scope
|
post-expansion-scope
|
||||||
|
null ; post-expansion-shifts
|
||||||
(new-scope 'module) ; top-level-bind-scope
|
(new-scope 'module) ; top-level-bind-scope
|
||||||
(or all-scopes-stx
|
(or all-scopes-stx
|
||||||
(add-scopes empty-syntax module-scopes))
|
(add-scopes empty-syntax module-scopes))
|
||||||
|
@ -57,7 +59,8 @@
|
||||||
(datum->syntax
|
(datum->syntax
|
||||||
#f
|
#f
|
||||||
(vector (add-scopes empty-syntax (root-expand-context-module-scopes ctx))
|
(vector (add-scopes empty-syntax (root-expand-context-module-scopes ctx))
|
||||||
(add-scope empty-syntax (root-expand-context-post-expansion-scope ctx))
|
(syntax-add-shifts (add-scope empty-syntax (root-expand-context-post-expansion-scope ctx))
|
||||||
|
(root-expand-context-post-expansion-shifts ctx))
|
||||||
(syntax-module-path-index-shift (root-expand-context-all-scopes-stx ctx) orig-self new-self)
|
(syntax-module-path-index-shift (root-expand-context-all-scopes-stx ctx) orig-self new-self)
|
||||||
(add-scopes empty-syntax (unbox (root-expand-context-use-site-scopes ctx)))
|
(add-scopes empty-syntax (unbox (root-expand-context-use-site-scopes ctx)))
|
||||||
(for/hasheqv ([(phase ht) (in-hash (root-expand-context-defined-syms ctx))]) ; make immutable
|
(for/hasheqv ([(phase ht) (in-hash (root-expand-context-defined-syms ctx))]) ; make immutable
|
||||||
|
@ -83,6 +86,7 @@
|
||||||
(root-expand-context self
|
(root-expand-context self
|
||||||
(extract-scope-list (vector-ref vec 0)) ; module-scopes
|
(extract-scope-list (vector-ref vec 0)) ; module-scopes
|
||||||
(extract-scope (vector-ref vec 1)) ; post-expansion-scope
|
(extract-scope (vector-ref vec 1)) ; post-expansion-scope
|
||||||
|
(extract-shifts (vector-ref vec 1)) ; post-expansion-scope-shifts
|
||||||
(new-scope 'module) ; top-level-bind-scope
|
(new-scope 'module) ; top-level-bind-scope
|
||||||
(vector-ref vec 2) ; all-scopes-stx
|
(vector-ref vec 2) ; all-scopes-stx
|
||||||
(box (extract-scope-list (vector-ref vec 3))) ; use-site-scopes
|
(box (extract-scope-list (vector-ref vec 3))) ; use-site-scopes
|
||||||
|
@ -110,6 +114,9 @@
|
||||||
(define s (syntax-scope-set stx 0))
|
(define s (syntax-scope-set stx 0))
|
||||||
(generalize-scope (set-first s)))
|
(generalize-scope (set-first s)))
|
||||||
|
|
||||||
|
(define (extract-shifts stx)
|
||||||
|
(syntax-mpi-shifts stx))
|
||||||
|
|
||||||
(define (unpack-defined-syms v)
|
(define (unpack-defined-syms v)
|
||||||
(hash-copy ; make mutable
|
(hash-copy ; make mutable
|
||||||
(for/hasheqv ([(phase ht-s) (in-hash (syntax-e v))])
|
(for/hasheqv ([(phase ht-s) (in-hash (syntax-e v))])
|
||||||
|
|
|
@ -37,6 +37,7 @@
|
||||||
syntax-apply-shifts
|
syntax-apply-shifts
|
||||||
binding-module-path-index-shift
|
binding-module-path-index-shift
|
||||||
syntax-transfer-shifts
|
syntax-transfer-shifts
|
||||||
|
syntax-add-shifts
|
||||||
|
|
||||||
syntax-source-module
|
syntax-source-module
|
||||||
identifier-prune-to-source-module)
|
identifier-prune-to-source-module)
|
||||||
|
@ -280,7 +281,9 @@
|
||||||
[else b]))
|
[else b]))
|
||||||
|
|
||||||
(define (syntax-transfer-shifts to-s from-s [inspector #f] #:non-source? [non-source? #f])
|
(define (syntax-transfer-shifts to-s from-s [inspector #f] #:non-source? [non-source? #f])
|
||||||
(define shifts (syntax-mpi-shifts from-s))
|
(syntax-add-shifts to-s (syntax-mpi-shifts from-s) inspector #:non-source? non-source?))
|
||||||
|
|
||||||
|
(define (syntax-add-shifts to-s shifts [inspector #f] #:non-source? [non-source? #f])
|
||||||
(cond
|
(cond
|
||||||
[(and (null? shifts) inspector)
|
[(and (null? shifts) inspector)
|
||||||
(syntax-set-inspector to-s inspector)]
|
(syntax-set-inspector to-s inspector)]
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user