From 3a1e8803ffe3ca431522dbeaeaea95e1ada387ca Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 8 Mar 2012 12:50:13 -0700 Subject: [PATCH] fix errortrace for submodules --- collects/errortrace/errortrace-lib.rkt | 92 ++++++--- collects/errortrace/stacktrace.rkt | 41 ++-- collects/scribblings/reference/syntax.scrbl | 14 ++ collects/tests/errortrace/wrap.rkt | 5 +- collects/tests/racket/submodule.rktl | 7 + src/racket/cmdline.inc | 6 +- src/racket/src/fun.c | 2 + src/racket/src/module.c | 214 +++++++++++++++++++- 8 files changed, 327 insertions(+), 54 deletions(-) diff --git a/collects/errortrace/errortrace-lib.rkt b/collects/errortrace/errortrace-lib.rkt index aa18a3c0fe..0b45eb5779 100644 --- a/collects/errortrace/errortrace-lib.rkt +++ b/collects/errortrace/errortrace-lib.rkt @@ -40,21 +40,55 @@ (#%variable-reference))) (define (disarm stx) (syntax-disarm stx code-insp)) - -(define (add-test-coverage-init-code stx) + +(define (transform-all-modules stx proc [in-mod-id (namespace-module-identifier)]) (syntax-case stx () [(mod name init-import mb) (syntax-case (disarm #'mb) (#%plain-module-begin) - [(#%plain-module-begin b1 body ...) - (copy-props - stx - #`(#,(namespace-module-identifier) name init-import - #,(syntax-rearm - #`(#%plain-module-begin - b1 ;; the requires that were introduced earlier - (#%plain-app init-test-coverage '#,(remove-duplicates test-coverage-state)) - body ...) - #'mb)))])])) + [(#%plain-module-begin body ...) + (let () + (define ((handle-top-form phase) expr) + (syntax-case* (disarm expr) (begin-for-syntax module module*) + (lambda (a b) + (free-identifier=? a b phase 0)) + [(begin-for-syntax body ...) + (syntax-rearm + (map (handle-top-form (add1 phase)) + (syntax->list #'(body ...))) + expr)] + [(module . _) + (transform-all-modules expr proc #f)] + [(module* . _) + (transform-all-modules expr proc #f)] + [else expr])) + (define mod-id (or in-mod-id #'mod)) + (proc + (copy-props + stx + #`(#,mod-id name init-import + #,(syntax-rearm + #`(#%plain-module-begin + . #,(map (handle-top-form 0) (syntax->list #'(body ...)))) + #'mb))) + mod-id))])])) + +(define (add-test-coverage-init-code stx) + (transform-all-modules + stx + (lambda (stx mod-id) + (syntax-case stx () + [(mod name init-import mb) + (syntax-case (disarm #'mb) (#%plain-module-begin) + [(#%plain-module-begin b1 body ...) + (copy-props + stx + #`(#,mod-id name init-import + #,(syntax-rearm + #`(#%plain-module-begin + b1 ;; the requires that were introduced earlier + (#%plain-app init-test-coverage '#,(remove-duplicates test-coverage-state)) + body ...) + #'mb)))])])))) (define (annotate-covered-file filename-path [display-string #f]) (annotate-file filename-path @@ -408,23 +442,25 @@ (namespace-base-phase))) (if (eq? (syntax-e #'name) 'errortrace-key) top-e - (let ([top-e (expand-syntax top-e)]) + (let ([top-e (normal (expand-syntax top-e))]) (initialize-test-coverage) - (syntax-case top-e (#%plain-module-begin) - [(mod name init-import mb) - (syntax-case (disarm #'mb) (#%plain-module-begin) - [(#%plain-module-begin body ...) - (let ([meta-depth ((count-meta-levels 0) #'(begin body ...))]) - (add-test-coverage-init-code - (normal - (copy-props - top-e - #`(#,(namespace-module-identifier) name init-import - #,(syntax-rearm - #`(#%plain-module-begin - #,(generate-key-imports meta-depth) - body ...) - #'mb))))))])])))] + (add-test-coverage-init-code + (transform-all-modules + top-e + (lambda (top-e mod-id) + (syntax-case top-e () + [(mod name init-import mb) + (syntax-case (disarm #'mb) (#%plain-module-begin) + [(#%plain-module-begin body ...) + (let ([meta-depth ((count-meta-levels 0) #'(begin body ...))]) + (copy-props + top-e + #`(#,mod-id name init-import + #,(syntax-rearm + #`(#%plain-module-begin + #,(generate-key-imports meta-depth) + body ...) + #'mb))))])]))))))] [_else (let ([e (normal top-e)]) (let ([meta-depth ((count-meta-levels 0) e)]) diff --git a/collects/errortrace/stacktrace.rkt b/collects/errortrace/stacktrace.rkt index 78ed326760..8abeeb5974 100644 --- a/collects/errortrace/stacktrace.rkt +++ b/collects/errortrace/stacktrace.rkt @@ -396,23 +396,9 @@ (add1 phase)))] [(module name init-import mb) - (syntax-case (disarm #'mb) () - [(__plain-module-begin body ...) - ;; Just wrap body expressions - (let ([bodys (syntax->list (syntax (body ...)))]) - (let ([bodyl (map (lambda (b) - (annotate-top b 0)) - bodys)] - [mb #'mb]) - (rearm - expr - (rebuild - disarmed-expr - (list (cons - mb - (rearm - mb - (rebuild mb (map cons bodys bodyl)))))))))])] + (annotate-module expr disarmed-expr)] + [(module* name init-import mb) + (annotate-module expr disarmed-expr)] [(#%expression e) (rearm expr #`(#%expression #,(annotate (syntax e) phase)))] @@ -578,6 +564,27 @@ (syntax->datum expr))]) expr phase))) + + (define (annotate-module expr disarmed-expr) + (syntax-case disarmed-expr () + [(mod name init-import mb) + (syntax-case (disarm #'mb) () + [(__plain-module-begin body ...) + ;; Just wrap body expressions + (let ([bodys (syntax->list (syntax (body ...)))]) + (let ([bodyl (map (lambda (b) + (annotate-top b 0)) + bodys)] + [mb #'mb]) + (rearm + expr + (rebuild + disarmed-expr + (list (cons + mb + (rearm + mb + (rebuild mb (map cons bodys bodyl)))))))))])])) (define annotate (make-annotate #f #f)) (define annotate-top (make-annotate #t #f)) diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 1c4d0e3929..fa5f57b749 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -260,6 +260,20 @@ form. See also @racket[module-compiled-language-info], @racket[module->language-info], and @racketmodname[racket/language-info]. +If a @racket[module] form has a single body @racket[form] and if the +form is a @racket[#%plain-module-begin] form, then the body +@racket[form] is traversed to find @racket[module] and +@racket[module*] forms that are either immediate or under +@racket[begin-for-syntax]. (That is, the body is search before adding +any lexical context due to the module's initial @racket[module-path] +import.) Each such module form is given a @indexed-racket['submodule] +@tech{syntax property} that whose value is the initial module form. +Then, when @racket[module] or @racket[module*] is expanded in a +submodule position, if the form has a @indexed-racket['submodule] +@tech{syntax property}, the property value is used as the form to +expand. This protocol avoids the contamination of submodule lexical +scope when re-expanding @racket[module] forms that contain submodules. + See also @secref["module-eval-model"] and @secref["mod-parse"]. @defexamples[#:eval (syntax-eval) diff --git a/collects/tests/errortrace/wrap.rkt b/collects/tests/errortrace/wrap.rkt index 7aa3457b0b..f15150136f 100644 --- a/collects/tests/errortrace/wrap.rkt +++ b/collects/tests/errortrace/wrap.rkt @@ -17,7 +17,7 @@ (get-output-string o))))) (unless (regexp-match? (regexp-quote (format "~s" (syntax->datum err-stx))) out-str) - (error 'test "not in context for: ~s" (syntax->datum expr)))) + (error 'test "not in context for: ~s got: ~s" (syntax->datum expr) out-str))) (provide wrap-tests) (define (wrap-tests) @@ -25,4 +25,7 @@ (try err-stx) (try #`(syntax-case 'a () (_ #,err-stx))) + (try #`(begin (module m racket/base (module n racket/base #,err-stx)) (require (submod 'm n)))) + (try #`(begin (module m racket/base (module* n racket/base #,err-stx)) (require (submod 'm n)))) + (try #`(begin (module m racket/base (module* n #f #,err-stx)) (require (submod 'm n)))) (void)) diff --git a/collects/tests/racket/submodule.rktl b/collects/tests/racket/submodule.rktl index f820f86c7e..c9d96270e6 100644 --- a/collects/tests/racket/submodule.rktl +++ b/collects/tests/racket/submodule.rktl @@ -220,6 +220,13 @@ (test 120 dynamic-require '(submod 'sub4-m n) 'x) +(eval + (expand + (expand '(module sub3.5-m racket + (begin-for-syntax + (module* n #f (define x 8.5) (provide x))))))) +(test 8.5 dynamic-require '(submod 'sub3.5-m n) 'x) + (eval (expand (expand '(module sub3-m racket/base diff --git a/src/racket/cmdline.inc b/src/racket/cmdline.inc index 84e5fbcebc..334b0a8393 100644 --- a/src/racket/cmdline.inc +++ b/src/racket/cmdline.inc @@ -365,7 +365,7 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl) } /* Use a module path index so that multiple resolutions are no unduly sensitive to changes in the current directory or other configurations: */ - mpi = scheme_make_modidx(a[0], scheme_false, scheme_false); + mpi = scheme_make_modidx(a[0], scheme_make_false(), scheme_make_false()); if (!did_config) configure_environment(mpi); /* Run the module: */ @@ -377,9 +377,9 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl) scheme_make_pair(scheme_intern_symbol("main"), scheme_null))), mpi, - scheme_false); + scheme_make_false()); if (scheme_module_is_declared(a[0], 1)) { - a[1] = scheme_false; + a[1] = scheme_make_false(); scheme_apply(scheme_builtin_value("dynamic-require"), 2, a); } } diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index f87dc96112..50ef6e77ca 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -7086,6 +7086,8 @@ scheme_get_stack_trace(Scheme_Object *mark_set) name = SCHEME_CAR(name); name = SCHEME_PTR_VAL(name); + if (SCHEME_PAIRP(name)) + name = scheme_make_pair(scheme_intern_symbol("submod"), name); loc = scheme_make_location(name, scheme_false, scheme_false, scheme_false, scheme_false); diff --git a/src/racket/src/module.c b/src/racket/src/module.c index cea0473a5b..0f725c27dc 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -6120,6 +6120,201 @@ static Scheme_Object *strip_lexical_context(Scheme_Object *stx) return v; } +static Scheme_Object *do_annotate_submodules_k(void); + +Scheme_Object *do_annotate_submodules(Scheme_Object *fm, int phase) +{ + Scheme_Object *a, *d, *v; + int changed = 0; + +#ifdef DO_STACK_CHECK +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + p->ku.k.p1 = (void *)fm; + return scheme_handle_stack_overflow(do_annotate_submodules_k); + } +#endif + + if (!SCHEME_STX_PAIRP(fm)) + return fm; + + a = SCHEME_STX_CAR(fm); + if (SCHEME_STX_PAIRP(a)) { + v = SCHEME_STX_CAR(a); + if (SCHEME_STX_SYMBOLP(v)) { + if (scheme_stx_module_eq3(scheme_module_stx, v, + scheme_make_integer(0), scheme_make_integer(phase), + NULL) + || scheme_stx_module_eq3(scheme_modulestar_stx, v, + scheme_make_integer(0), scheme_make_integer(phase), + NULL)) { + /* found a submodule */ + a = scheme_stx_property(a, scheme_intern_symbol("submodule"), a); + changed = 1; + } else if (scheme_stx_module_eq3(scheme_begin_for_syntax_stx, v, + scheme_make_integer(0), scheme_make_integer(phase), + NULL)) { + /* found `begin-for-syntax' */ + v = do_annotate_submodules(a, phase+1); + if (!SAME_OBJ(v, a)) { + changed = 1; + a = v; + } + } + } + } + + v = SCHEME_STX_CDR(fm); + d = do_annotate_submodules(v, phase); + + if (!changed && SAME_OBJ(v, d)) + return fm; + + v = scheme_make_pair(a, d); + if (SCHEME_STXP(fm)) + v = scheme_datum_to_syntax(v, fm, fm, 0, 2); + + return v; +} + +static Scheme_Object *do_annotate_submodules_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *fm = (Scheme_Object *)p->ku.k.p1; + + p->ku.k.p1 = NULL; + + return do_annotate_submodules(fm, p->ku.k.i1); +} + +static Scheme_Object *annotate_existing_submodules(Scheme_Object *orig_fm) +{ + Scheme_Object *fm = orig_fm; + + if (!SCHEME_STX_PAIRP(fm)) + return orig_fm; + fm = SCHEME_STX_CAR(fm); + if (!SCHEME_STX_SYMBOLP(fm)) + return orig_fm; + + if (scheme_stx_module_eq(scheme_module_begin_stx, fm, 0)) { + /* It's a `#%plain-module-begin' form */ + return do_annotate_submodules(orig_fm, 0); + } + + return orig_fm; +} + +static Scheme_Object *rebuild_with_phase_shift(Scheme_Object *orig, Scheme_Object *a, Scheme_Object *d, + Scheme_Object *old_midx, Scheme_Object *new_midx) +{ + if (!a) a = SCHEME_STX_CAR(orig); + if (!d) d = SCHEME_STX_CDR(orig); + + a = scheme_make_pair(a, d); + + if (SCHEME_PAIRP(orig)) + return a; + + orig = scheme_stx_phase_shift(orig, NULL, old_midx, new_midx, NULL, NULL); + return scheme_datum_to_syntax(a, orig, orig, 0, 2); +} + +static Scheme_Object *phase_shift_skip_submodules_k(void); + +static Scheme_Object *phase_shift_skip_submodules(Scheme_Object *fm, + Scheme_Object *old_midx, Scheme_Object *new_midx, + int phase) +{ + Scheme_Object *v0, *v1, *v2, *v3, *v4, *naya; + +#ifdef DO_STACK_CHECK +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + p->ku.k.p1 = (void *)fm; + p->ku.k.p2 = (void *)old_midx; + p->ku.k.p3 = (void *)new_midx; + p->ku.k.i1 = phase; + return scheme_handle_stack_overflow(phase_shift_skip_submodules_k); + } +#endif + + if (phase == -1) { + /* at top: */ + v0 = SCHEME_STX_CDR(fm); + v1 = SCHEME_STX_CDR(v0); + v2 = SCHEME_STX_CDR(v1); + v3 = SCHEME_STX_CAR(v2); + v4 = SCHEME_STX_CDR(v3); + + naya = phase_shift_skip_submodules(v4, old_midx, new_midx, 0); + if (SAME_OBJ(naya, v4)) { + return scheme_stx_phase_shift(fm, NULL, old_midx, new_midx, NULL, NULL); + } else { + v3 = rebuild_with_phase_shift(v3, NULL, naya, old_midx, new_midx); + v2 = rebuild_with_phase_shift(v2, v3, NULL, old_midx, new_midx); + v1 = rebuild_with_phase_shift(v1, NULL, v2, old_midx, new_midx); + v0 = rebuild_with_phase_shift(v0, NULL, v1, old_midx, new_midx); + return rebuild_with_phase_shift(fm, NULL, v0, old_midx, new_midx); + } + } else if (SCHEME_STX_NULLP(fm)) { + return fm; + } else { + v1 = SCHEME_STX_CAR(fm); + + if (SCHEME_STX_PAIRP(v1)) { + v2 = SCHEME_STX_CAR(v1); + if (SCHEME_STX_SYMBOLP(v2)) { + if (scheme_stx_module_eq3(scheme_module_stx, v2, + scheme_make_integer(0), scheme_make_integer(phase), + NULL) + || scheme_stx_module_eq3(scheme_modulestar_stx, v2, + scheme_make_integer(0), scheme_make_integer(phase), + NULL)) { + /* found a submodule */ + v2 = SCHEME_STX_CDR(fm); + naya = phase_shift_skip_submodules(v2, old_midx, new_midx, phase); + return rebuild_with_phase_shift(fm, v1, naya, old_midx, new_midx); + } else if (scheme_stx_module_eq3(scheme_begin_for_syntax_stx, v2, + scheme_make_integer(0), scheme_make_integer(phase), + NULL)) { + /* found `begin-for-syntax': */ + naya = phase_shift_skip_submodules(v1, old_midx, new_midx, phase+1); + v2 = SCHEME_STX_CDR(fm); + v3 = phase_shift_skip_submodules(v2, old_midx, new_midx, phase+1); + if (SAME_OBJ(naya, v1) && SAME_OBJ(v2, v3)) + return fm; + else + return rebuild_with_phase_shift(fm, naya, v3, old_midx, new_midx); + } + } + } + + v3 = SCHEME_STX_CDR(fm); + v4 = phase_shift_skip_submodules(v3, old_midx, new_midx, phase); + if (SAME_OBJ(v3, v4)) + return fm; + else + return rebuild_with_phase_shift(fm, v1, v4, old_midx, new_midx); + } +} + +static Scheme_Object *phase_shift_skip_submodules_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *fm = (Scheme_Object *)p->ku.k.p1; + Scheme_Object *old_midx = (Scheme_Object *)p->ku.k.p2; + Scheme_Object *new_midx = (Scheme_Object *)p->ku.k.p3; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + p->ku.k.p3 = NULL; + + return phase_shift_skip_submodules(fm, old_midx, new_midx, p->ku.k.i1); +} + static Scheme_Env *find_env(Scheme_Env *env, intptr_t ph) { intptr_t j; @@ -6415,6 +6610,13 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, if (SCHEME_STX_PAIRP(fm) && SCHEME_STX_NULLP(SCHEME_STX_CDR(fm))) { /* Perhaps expandable... */ fm = SCHEME_STX_CAR(fm); + + /* If the body is `#%plain-module-begin' and if any form is a + `module' form (i.e., already with the `module' binding, then + attach the original form as a property to the `module' form, so + that re-expansion can use it instead of dropping all lexical + context: */ + fm = annotate_existing_submodules(fm); } else { fm = scheme_make_pair(scheme_datum_to_syntax(module_begin_symbol, form, mb_ctx, 0, 2), fm); @@ -6545,11 +6747,10 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, } /* for future expansion, shift away from self_modidx: */ - fm = scheme_stx_phase_shift(fm, NULL, self_modidx, empty_self_modidx, NULL, NULL); - - /* Remember this syntax as-is for re-expansion: */ - if (!SCHEME_NULLP(submodule_ancestry)) - fm = scheme_stx_property(fm, scheme_intern_symbol("submodule"), fm); + if (m->pre_submodules) /* non-NULL => some submodules, even if it's '() */ + fm = phase_shift_skip_submodules(fm, self_modidx, empty_self_modidx, -1); + else + fm = scheme_stx_phase_shift(fm, NULL, self_modidx, empty_self_modidx, NULL, NULL); /* make self_modidx like the empty modidx */ ((Scheme_Modidx *)self_modidx)->resolved = empty_self_modname; @@ -8496,6 +8697,9 @@ static Scheme_Object *expand_submodules(Scheme_Compile_Expand_Info *rec, int dre l = scheme_make_pair(SCHEME_CAR(mods), l); env->genv->module->pre_submodules = l; } + } else if (!SCHEME_NULLP(mods)) { + /* setting pre_submodules to '() indicates that there were submodules during expansion */ + env->genv->module->pre_submodules = scheme_null; } return mods;