suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Track the origin of modules produced by module+ forms

Browse Source 
This ensures the 'origin property is propagated from macros that expand
to module+ forms.
This commit is contained in:
Alexis King 2016-10-30 17:32:22 -07:00
parent 81cd3622d3
commit 393afa3759
2 changed files with 38 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
pkgs/racket-test-core/tests/racket/submodule.rktl
View File

@ -477,7 +477,7 @@
(test 'b dynamic-require '(submod 'subm-example-12 b) 'b)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The `section' form:
;; The `module+' form:
(module module+-example-1 racket/base
(module+ alpha (define a root) (provide a))
@ -519,6 +519,18 @@
(test 3 dynamic-require '(submod 'module+-example-2 a b) 'x)
;; Check that module+ propagates properties
(let* ([stx-1 (syntax-property #'(module+ plus) 'foo 'bar)]
[stx-2 (syntax-property #'(module+ plus) 'baz 'qux)]
[expanded-stx (expand #`(module m racket/base
#,stx-1
#,stx-2))])
(syntax-case expanded-stx (module #%plain-module-begin)
[(module _ _ (#%plain-module-begin _ submodule))
(begin
(test 'bar syntax-property #'submodule 'foo)
(test 'qux syntax-property #'submodule 'baz))]))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check module-source for submodule:

23
racket/collects/racket/private/submodule.rkt
View File

@ -27,8 +27,9 @@
;; list and lift a module-end declaration if necessary:
(let ([stxs-box (get-stxs-box stx #'the-submodule #t)])
(set-box! stxs-box
(append (reverse (syntax->list (syntax-local-introduce #'(e ...))))
(unbox stxs-box))))
(cons (append (reverse (syntax->list (syntax-local-introduce #'(e ...))))
(car (unbox stxs-box)))
(cons stx (cdr (unbox stxs-box))))))
(syntax/loc stx (begin)))])]
[else
(raise-syntax-error #f
@ -52,7 +53,7 @@
form-stx
(list #'define-module the-submodule-stx)
form-stx)))
(box null))))))
(box (cons null null)))))))
;; A use of this form is lifted to the end of the enclosing module
;; for each submodule created by `module+':
@ -60,14 +61,24 @@
(lambda (stx)
(syntax-case stx ()
[(_ the-submodule)
(let ([stxs-box (get-stxs-box #f #'the-submodule #f)])
(let* ([stxs-box (get-stxs-box #f #'the-submodule #f)]
;; Propagate the lexical context of the first `module+'
;; for the implicit `#%module-begin':
[module-decl
(datum->syntax
stx
(list*
#'module*
#'the-submodule
#f ; namespace context is the original context
(map syntax-local-introduce (reverse (unbox stxs-box))))
stx))]))))
(map syntax-local-introduce (reverse (car (unbox stxs-box)))))
stx)])
;; Add 'origin and copy properties for every original declaration
(let loop ([stx module-decl]
[origs (cdr (unbox stxs-box))])
(if (null? origs) stx
(let* ([orig (car origs)]
[id-stx (if (symbol? (syntax-e orig)) orig
(car (syntax-e orig)))])
(loop (syntax-track-origin stx orig id-stx)
(cdr origs))))))]))))