From 5749d4080cf410103e185cea4f7abde888c4ea11 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 9 Mar 2015 14:48:29 -0600 Subject: [PATCH] add tracking of `require` and `provide` subforms 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 --- .../racket-test-core/tests/racket/module.rktl | 36 +++++ racket/collects/racket/private/reqprov.rkt | 150 +++++++++++------- racket/collects/racket/provide-transform.rkt | 4 +- racket/src/racket/src/module.c | 13 +- racket/src/racket/src/syntax.c | 16 +- 5 files changed, 157 insertions(+), 62 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/module.rktl b/pkgs/racket-test-core/tests/racket/module.rktl index 5b5df25646..b658b53d37 100644 --- a/pkgs/racket-test-core/tests/racket/module.rktl +++ b/pkgs/racket-test-core/tests/racket/module.rktl @@ -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) diff --git a/racket/collects/racket/private/reqprov.rkt b/racket/collects/racket/private/reqprov.rkt index 102eef279f..a32387889c 100644 --- a/racket/collects/racket/private/reqprov.rkt +++ b/racket/collects/racket/private/reqprov.rkt @@ -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 diff --git a/racket/collects/racket/provide-transform.rkt b/racket/collects/racket/provide-transform.rkt index 325a63b2a6..22306a7a31 100644 --- a/racket/collects/racket/provide-transform.rkt +++ b/racket/collects/racket/provide-transform.rkt @@ -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])))) diff --git a/racket/src/racket/src/module.c b/racket/src/racket/src/module.c index 685a4fc2d0..c56e93cc0c 100644 --- a/racket/src/racket/src/module.c +++ b/racket/src/racket/src/module.c @@ -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; diff --git a/racket/src/racket/src/syntax.c b/racket/src/racket/src/syntax.c index c06f2b988d..aca03a31aa 100644 --- a/racket/src/racket/src/syntax.c +++ b/racket/src/racket/src/syntax.c @@ -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). */