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) (test 'b dynamic-require '(submod 'subm-example-12 b) 'b)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The `section' form: ;; The `module+' form:
(module module+-example-1 racket/base (module module+-example-1 racket/base
(module+ alpha (define a root) (provide a)) (module+ alpha (define a root) (provide a))
@ -519,6 +519,18 @@
(test 3 dynamic-require '(submod 'module+-example-2 a b) 'x) (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: ;; Check module-source for submodule:

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

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