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

add tracking of require and provide subforms

Browse Source 
Use `syntax-track-origin` and 'disappeared-use properties to
communicate `require` and `provide` form bindings to tools such as
Check Syntax.

Relevant to PR 13186
This commit is contained in:
Matthew Flatt 2015-03-09 14:48:29 -06:00
parent 59777ca17a
commit 5749d4080c
5 changed files with 157 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
pkgs/racket-test-core/tests/racket/module.rktl
View File

@ -1353,6 +1353,42 @@
(test #t syntax? (expand-syntax (expand lifted-require-of-submodule))) (test #t syntax? (expand-syntax (expand lifted-require-of-submodule)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check addition of 'disappeared-use by `provide`
(require (rename-in racket/base [lib racket-base:lib]))
(let ()
(define (find-disappeared stx id)
(let loop ([s stx])
(cond
[(syntax? s)
(define p (cons (syntax-property s 'disappeared-use)
(syntax-property s 'origin)))
(or (let loop ([p p])
(cond
[(identifier? p) (and (free-identifier=? p id)
(eq? (syntax-e p) (syntax-e id)))]
[(pair? p) (or (loop (car p))
(loop (cdr p)))]
[else #f]))
(loop (syntax-e s)))]
[(pair? s)
(or (loop (car s))
(loop (cdr s)))]
[else #f])))
(let ([form (expand `(module m racket/base
(provide (struct-out s))
(struct s ())))])
(test #t find-disappeared form #'struct-out))
(let ([form (expand `(module m racket/base
(require (only-in racket/base car))))])
(test #t find-disappeared form #'only-in))
(let ([form (expand `(module m racket/base
(require (rename-in racket/base [lib racket-base:lib])
(racket-base:lib "racket/base"))))])
(test #t find-disappeared form #'racket-base:lib)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs) (report-errs)

150
racket/collects/racket/private/reqprov.rkt
View File

@ -55,17 +55,17 @@
(if (and (eq? new-mp #'mp) (if (and (eq? new-mp #'mp)
(eq? (car d) 'submod)) (eq? (car d) 'submod))
stx stx
(datum->syntax (syntax-track/form (datum->syntax
stx stx
(list* kw new-mp #'rest) (list* kw new-mp #'rest)
stx stx)
stx)))])] stx)))])]
[(eq? (car d) kw) stx] [(eq? (car d) kw) stx]
[else (datum->syntax [else (syntax-track/form (datum->syntax
stx stx
(cons kw (cdr d)) (cons kw (cdr d))
stx stx)
stx)])) stx)]))
stx))) stx)))
(define-for-syntax (check-lib-form stx) (define-for-syntax (check-lib-form stx)
@ -298,12 +298,13 @@
(simple-path? #'path) (simple-path? #'path)
(list (mode-wrap (list (mode-wrap
base-mode base-mode
(datum->syntax (syntax-track/form
#'path (datum->syntax
(syntax-e #'path
(quasisyntax (syntax-e
(prefix pfx #,(xlate-path #'path)))) (quasisyntax
in (prefix pfx #,(xlate-path #'path))))
in)
in)))] in)))]
[(except-in path id ...) [(except-in path id ...)
(and (simple-path? #'path) (and (simple-path? #'path)
@ -312,27 +313,32 @@
(lambda (a b) #t))) (lambda (a b) #t)))
(list (mode-wrap (list (mode-wrap
base-mode base-mode
(datum->syntax (syntax-track/form
#'path (datum->syntax
(syntax-e #'path
(quasisyntax/loc in (syntax-e
(all-except #,(xlate-path #'path) id ...))))))] (quasisyntax/loc in
(all-except #,(xlate-path #'path) id ...))))
in)))]
;; General case: ;; General case:
[_ (let-values ([(imports sources) (expand-import in)]) [_ (let-values ([(imports sources) (expand-import in)])
;; TODO: collapse back to simple cases when possible ;; TODO: collapse back to simple cases when possible
(append (cons/syntax-track/form
(map (lambda (import) #'(just-meta 0)
#`(just-meta in
#,(import-orig-mode import) (append
#,(mode-wrap (phase+ base-mode (import-req-mode import)) (map (lambda (import)
#`(rename #,(import-src-mod-path import) #`(just-meta
#,(import-local-id import) #,(import-orig-mode import)
#,(import-src-sym import))))) #,(mode-wrap (phase+ base-mode (import-req-mode import))
imports) #`(rename #,(import-src-mod-path import)
(map (lambda (src) #,(import-local-id import)
(mode-wrap (phase+ base-mode (import-source-mode src)) #,(import-src-sym import)))))
#`(only #,(import-source-mod-path-stx src)))) imports)
sources)))]))] (map (lambda (src)
(mode-wrap (phase+ base-mode (import-source-mode src))
#`(only #,(import-source-mod-path-stx src))))
sources))))]))]
[transform-one [transform-one
(lambda (in) (lambda (in)
;; Recognize `for-syntax', etc. for simple cases: ;; Recognize `for-syntax', etc. for simple cases:
@ -340,25 +346,31 @@
[(for-meta n elem ...) [(for-meta n elem ...)
(or (exact-integer? (syntax-e #'n)) (or (exact-integer? (syntax-e #'n))
(not (syntax-e #'n))) (not (syntax-e #'n)))
(apply append (cons/syntax-track/form
(map (lambda (in) #'(for-meta n)
(transform-simple in (syntax-e #'n))) in
(syntax->list #'(elem ...))))] (apply append
(map (lambda (in)
(transform-simple in (syntax-e #'n)))
(syntax->list #'(elem ...)))))]
[(for-something elem ...) [(for-something elem ...)
(and (identifier? #'for-something) (and (identifier? #'for-something)
(ormap (lambda (i) (free-identifier=? i #'for-something)) (ormap (lambda (i) (free-identifier=? i #'for-something))
(list #'for-syntax #'for-template #'for-label))) (list #'for-syntax #'for-template #'for-label)))
(apply append (cons/syntax-track/form
(map (lambda (in) #'(for-something)
(transform-simple in in
(cond (apply append
[(free-identifier=? #'for-something #'for-syntax) (map (lambda (in)
1] (transform-simple in
[(free-identifier=? #'for-something #'for-template) (cond
-1] [(free-identifier=? #'for-something #'for-syntax)
[(free-identifier=? #'for-something #'for-label) 1]
#f]))) [(free-identifier=? #'for-something #'for-template)
(syntax->list #'(elem ...))))] -1]
[(free-identifier=? #'for-something #'for-label)
#f])))
(syntax->list #'(elem ...)))))]
[_ (transform-simple in 0 #| run phase |#)]))]) [_ (transform-simple in 0 #| run phase |#)]))])
(syntax-case stx () (syntax-case stx ()
[(_ in) [(_ in)
@ -401,6 +413,15 @@
"not at module level or top level" "not at module level or top level"
stx)])) stx)]))
(define-for-syntax (syntax-track/form stx orig)
(syntax-track-origin stx orig (syntax-local-introduce (car (syntax-e orig)))))
(define-for-syntax (cons/syntax-track/form stx orig l)
;; Add `stx` as a dummy require if needed to track `orig`
(if (pair? l)
(cons (syntax-track/form (car l) orig)
(cdr l))
(cons (syntax-track/form stx orig) l)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; require transformers ;; require transformers
@ -721,11 +742,32 @@
exports)))]) exports)))])
(syntax-case stx () (syntax-case stx ()
[(_ out ...) [(_ out ...)
(with-syntax ([(new-out ...) (let ([outs (syntax->list #'(out ...))])
(apply append (with-syntax ([(new-out ...) (apply append (map transform-simple outs))])
(map transform-simple (syntax->list #'(out ...))))]) (copy-disappeared-uses
(syntax/loc stx outs
(begin new-out ...)))]))])) (syntax/loc stx
(begin new-out ...)))))]))]))
(define-for-syntax (copy-disappeared-uses outs r)
(cond
[(null? outs) r]
[else
(let ([p (syntax-property (car outs) 'disappeared-use)]
[name (if (identifier? (car outs))
#f
(syntax-local-introduce (car (syntax-e (car outs)))))]
[combine (lambda (b a)
(if a
(if b
(cons a b)
a)
b))])
(syntax-property r 'disappeared-use
(combine p
(combine
name
(syntax-property r 'disappeared-use)))))]))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; provide transformers ;; provide transformers

4
racket/collects/racket/provide-transform.rkt
View File

@ -75,7 +75,9 @@
#f #f
"result from provide pre-transformer is not a syntax object" "result from provide pre-transformer is not a syntax object"
stx)) stx))
v) (syntax-property v
'disappeared-use
(syntax-local-introduce #'id)))
stx))] stx))]
[_ stx])))) [_ stx]))))

13
racket/src/racket/src/module.c
View File

@ -11016,7 +11016,7 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e,
Scheme_Comp_Env *cenv, Scheme_Compile_Info *rec, int drec, Scheme_Comp_Env *cenv, Scheme_Compile_Info *rec, int drec,
Scheme_Object **_expanded) Scheme_Object **_expanded)
{ {
Scheme_Object *l, *rebuilt = scheme_null, *protect_stx = NULL; Scheme_Object *l, *rebuilt = scheme_null, *protect_stx = NULL, *rebuild_from = scheme_null;
int protect_cnt = 0, mode_cnt = 0, expanded = 0; int protect_cnt = 0, mode_cnt = 0, expanded = 0;
Scheme_Object *mode = scheme_make_integer(0), *mode_stx = NULL; Scheme_Object *mode = scheme_make_integer(0), *mode_stx = NULL;
Scheme_Object *all_x_defs_out, *all_x_defs; Scheme_Object *all_x_defs_out, *all_x_defs;
@ -11041,6 +11041,8 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e,
if (SAME_OBJ(protect_symbol, av)) { if (SAME_OBJ(protect_symbol, av)) {
if (protect_cnt) if (protect_cnt)
scheme_wrong_syntax(NULL, a, e, "nested `protect' not allowed"); scheme_wrong_syntax(NULL, a, e, "nested `protect' not allowed");
if (_expanded)
rebuild_from = scheme_make_pair(a, rebuild_from);
protect_stx = a; protect_stx = a;
a = SCHEME_STX_CDR(a); a = SCHEME_STX_CDR(a);
a = scheme_flatten_syntax_list(a, NULL); a = scheme_flatten_syntax_list(a, NULL);
@ -11142,6 +11144,9 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e,
if (!all_x_defs) all_x_defs = scheme_null; if (!all_x_defs) all_x_defs = scheme_null;
p = expand_provide(p, at_phase, tables, all_defs, cenv, rec, drec); p = expand_provide(p, at_phase, tables, all_defs, cenv, rec, drec);
if (_expanded)
rebuild_from = scheme_make_pair(p, rebuild_from);
/* Check for '(begin datum ...) result: */ /* Check for '(begin datum ...) result: */
p = scheme_flatten_syntax_list(p, &islist); p = scheme_flatten_syntax_list(p, &islist);
if (!islist) if (!islist)
@ -11440,6 +11445,12 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e,
a = SCHEME_STX_CAR(e); a = SCHEME_STX_CAR(e);
rebuilt = scheme_make_pair(a, scheme_reverse(rebuilt)); rebuilt = scheme_make_pair(a, scheme_reverse(rebuilt));
rebuilt = scheme_datum_to_syntax(rebuilt, e, e, 0, 2); rebuilt = scheme_datum_to_syntax(rebuilt, e, e, 0, 2);
while (SCHEME_PAIRP(rebuild_from)) {
rebuilt = scheme_stx_track(rebuilt, SCHEME_CAR(rebuild_from), NULL);
rebuild_from = SCHEME_CDR(rebuild_from);
}
*_expanded = rebuilt; *_expanded = rebuilt;
} else { } else {
*_expanded = e; *_expanded = e;

16
racket/src/racket/src/syntax.c
View File

@ -656,7 +656,7 @@ Scheme_Object *scheme_stx_track(Scheme_Object *naya,
for (; SCHEME_PAIRP(oe); oe = SCHEME_CDR(oe)) { for (; SCHEME_PAIRP(oe); oe = SCHEME_CDR(oe)) {
a = SCHEME_CAR(SCHEME_CAR(oe)); a = SCHEME_CAR(SCHEME_CAR(oe));
if (!SAME_OBJ(a, source_symbol) && !SAME_OBJ(a, share_symbol)) { if (!SAME_OBJ(a, source_symbol) && !SAME_OBJ(a, share_symbol)) {
if (!SAME_OBJ(a, origin_symbol)) { if (!origin || !SAME_OBJ(a, origin_symbol)) {
p = ICONS(SCHEME_CAR(oe), scheme_null); p = ICONS(SCHEME_CAR(oe), scheme_null);
} else { } else {
p = ICONS(ICONS(a, ICONS(origin, p = ICONS(ICONS(a, ICONS(origin,
@ -675,7 +675,7 @@ Scheme_Object *scheme_stx_track(Scheme_Object *naya,
oe = first; oe = first;
} }
if (add) { if (add && origin) {
oe = ICONS(ICONS(origin_symbol, oe = ICONS(ICONS(origin_symbol,
ICONS(origin, scheme_null)), ICONS(origin, scheme_null)),
oe); oe);
@ -686,10 +686,14 @@ Scheme_Object *scheme_stx_track(Scheme_Object *naya,
oe = NULL; oe = NULL;
} }
if (!oe) if (!oe) {
oe = ICONS(ICONS(origin_symbol, if (origin)
ICONS(origin, scheme_null)), oe = ICONS(ICONS(origin_symbol,
scheme_null); ICONS(origin, scheme_null)),
scheme_null);
else
oe = scheme_null;
}
/* Merge ne and oe (ne takes precedence). */ /* Merge ne and oe (ne takes precedence). */