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)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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)

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

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

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

@ -75,7 +75,9 @@
#f
"result from provide pre-transformer is not a syntax object"
stx))
v)
(syntax-property v
'disappeared-use
(syntax-local-introduce #'id)))
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_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;
Scheme_Object *mode = scheme_make_integer(0), *mode_stx = NULL;
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 (protect_cnt)
scheme_wrong_syntax(NULL, a, e, "nested `protect' not allowed");
if (_expanded)
rebuild_from = scheme_make_pair(a, rebuild_from);
protect_stx = a;
a = SCHEME_STX_CDR(a);
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;
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: */
p = scheme_flatten_syntax_list(p, &islist);
if (!islist)
@ -11440,6 +11445,12 @@ void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e,
a = SCHEME_STX_CAR(e);
rebuilt = scheme_make_pair(a, scheme_reverse(rebuilt));
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;
} else {
*_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)) {
a = SCHEME_CAR(SCHEME_CAR(oe));
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);
} else {
p = ICONS(ICONS(a, ICONS(origin,
@ -675,7 +675,7 @@ Scheme_Object *scheme_stx_track(Scheme_Object *naya,
oe = first;
}
if (add) {
if (add && origin) {
oe = ICONS(ICONS(origin_symbol,
ICONS(origin, scheme_null)),
oe);
@ -686,10 +686,14 @@ Scheme_Object *scheme_stx_track(Scheme_Object *naya,
oe = NULL;
}
if (!oe)
oe = ICONS(ICONS(origin_symbol,
ICONS(origin, scheme_null)),
scheme_null);
if (!oe) {
if (origin)
oe = ICONS(ICONS(origin_symbol,
ICONS(origin, scheme_null)),
scheme_null);
else
oe = scheme_null;
}
/* Merge ne and oe (ne takes precedence). */