From f0c03ad921e63819901fd6c4658fa6735771eed5 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 21 Mar 2012 12:00:42 -0600 Subject: [PATCH] macro-debugger: updates for submodules --- .../analysis/private/get-references.rkt | 8 +++++-- collects/macro-debugger/model/deriv-c.rkt | 5 +++- .../macro-debugger/model/deriv-parser.rkt | 18 ++++++++++---- .../macro-debugger/model/deriv-tokens.rkt | 6 ++++- collects/macro-debugger/model/reductions.rkt | 24 +++++++++++++++++-- src/racket/src/module.c | 12 ++++++++++ src/racket/src/schexpobs.h | 11 ++++++--- 7 files changed, 71 insertions(+), 13 deletions(-) diff --git a/collects/macro-debugger/analysis/private/get-references.rkt b/collects/macro-debugger/analysis/private/get-references.rkt index 544e945de8..48f6daec7b 100644 --- a/collects/macro-debugger/analysis/private/get-references.rkt +++ b/collects/macro-debugger/analysis/private/get-references.rkt @@ -123,8 +123,8 @@ (void)] [(p:module z1 z2 rs ?1 locals tag rename check tag2 ?3 body shift) (recur locals check body)] - [(p:#%module-begin z1 z2 rs ?1 me body ?2) - (recur body)] + [(p:#%module-begin z1 z2 rs ?1 me body ?2 subs) + (recur body subs)] [(p:define-syntaxes z1 z2 rs ?1 prep rhs locals) (recur prep locals) (recur/phase-up rhs)] @@ -164,6 +164,10 @@ (recur inners)] [(p:require _ _ _ _ locals) (recur locals)] + [(p:submodule _ _ _ _ exp) + (recur exp)] + [(p:submodule* _ _ _ _) + (void)] [(p:#%stratified-body _ _ _ _ bderiv) (recur bderiv)] [(p:stop _ _ _ _) (void)] diff --git a/collects/macro-debugger/model/deriv-c.rkt b/collects/macro-debugger/model/deriv-c.rkt index 3c2fe10163..43dcc832c0 100644 --- a/collects/macro-debugger/model/deriv-c.rkt +++ b/collects/macro-debugger/model/deriv-c.rkt @@ -56,7 +56,7 @@ ;; (make-p:#%module-begin Stx ModuleBegin/Phase ?exn) (define-struct (p:module prule) (prep tag rename check tag2 ?3 body shift) #:transparent) -(define-struct (p:#%module-begin prule) (me body ?2) #:transparent) +(define-struct (p:#%module-begin prule) (me body ?2 subs) #:transparent) ;; (make-p:define-syntaxes (listof LocalAction) DerivLL (listof LocalAction)) ;; (make-p:define-values Deriv) @@ -101,6 +101,9 @@ ;; (make-p:require (listof LocalAction)) (define-struct (p:require prule) (locals) #:transparent) +(define-struct (p:submodule prule) (exp) #:transparent) +(define-struct (p:submodule* prule) () #:transparent) + ;; (make-p:#%stratified-body BDeriv) (define-struct (p:#%stratified-body prule) (bderiv) #:transparent) diff --git a/collects/macro-debugger/model/deriv-parser.rkt b/collects/macro-debugger/model/deriv-parser.rkt index 8b1325b2ff..045f421551 100644 --- a/collects/macro-debugger/model/deriv-parser.rkt +++ b/collects/macro-debugger/model/deriv-parser.rkt @@ -30,7 +30,7 @@ (src-pos) (tokens basic-empty-tokens basic-tokens prim-tokens renames-tokens) (end EOF) - #|(debug "/tmp/ryan/DEBUG-PARSER.txt")|# + #| (debug "/tmp/DEBUG-PARSER.txt") |# (error deriv-error)) ;; tokens @@ -292,17 +292,23 @@ ;; instead appear directly here (Prim#%ModuleBegin (#:args e1 e2 rs) - [(prim-#%module-begin ! rename-one (? ModuleBegin/Phase) (? Eval)) + [(prim-#%module-begin ! rename-one (? ModuleBegin/Phase) (? Eval) next (? ExpandSubmodules)) (make p:#%module-begin e1 e2 rs $2 $3 $4 (for/or ([la (in-list $5)]) - (and (local-exn? la) (local-exn-exn la))))]) + (and (local-exn? la) (local-exn-exn la))) + $7)]) #| ;; restore this version when expander fixed (Prim#%ModuleBegin-REAL (#:args e1 e2 rs) - [(prim-#%module-begin ! rename-one (? ModuleBegin/Phase) !) + [(prim-#%module-begin ! rename-one (? ModuleBegin/Phase) ! (? ExpandSubmodules)) (make p:#%module-begin e1 e2 rs $2 $3 $4 $5)]) |# + (ExpandSubmodules + (#:skipped null) + [(enter-prim (? PrimModule) exit-prim (? ExpandSubmodules)) + (cons ($2 $1 $3 null) $4)] + [() null]) (ModuleBegin/Phase [((? ModulePass1) next-group (? ModulePass2) next-group (? ModulePass3)) @@ -336,6 +342,10 @@ (make p:begin-for-syntax $1 $7 null $3 $4 $6 $7)] [(enter-prim prim-require (? Eval) exit-prim) (make p:require $1 $4 null #f $3)] + [(enter-prim prim-submodule ! (? ExpandSubmodules #|one|#) exit-prim) + (make p:submodule $1 $5 null $3 (car $4))] + [(enter-prim prim-submodule* ! exit-prim) + (make p:submodule* $1 $4 null $3)] [() (make p:stop e1 e1 null #f)]) diff --git a/collects/macro-debugger/model/deriv-tokens.rkt b/collects/macro-debugger/model/deriv-tokens.rkt index 9591336a66..25edb6de83 100644 --- a/collects/macro-debugger/model/deriv-tokens.rkt +++ b/collects/macro-debugger/model/deriv-tokens.rkt @@ -97,6 +97,7 @@ prim-varref prim-#%stratified-body prim-begin-for-syntax + prim-submodule prim-submodule* )) ;; ** Signals to tokens @@ -194,7 +195,10 @@ (154 local-value-result ,token-local-value-result) (155 prim-#%stratified-body) (156 prim-begin-for-syntax) - (157 prepare-env))) + (157 prepare-env) + (158 prim-submodule) + (159 prim-submodule*) + )) (define (signal->symbol sig) (if (symbol? sig) diff --git a/collects/macro-debugger/model/reductions.rkt b/collects/macro-debugger/model/reductions.rkt index 0f54430a69..6757bdf582 100644 --- a/collects/macro-debugger/model/reductions.rkt +++ b/collects/macro-debugger/model/reductions.rkt @@ -97,13 +97,14 @@ [Expr ?body body] [#:pattern ?form] [#:rename ?form shift])] - [(Wrap p:#%module-begin (e1 e2 rs ?1 me body ?2)) + [(Wrap p:#%module-begin (e1 e2 rs ?1 me body ?2 subs)) (R [! ?1] [#:pattern ?form] [#:rename ?form me] [#:pattern (?module-begin . ?forms)] [ModuleBegin/Phase ?forms body] - [! ?2])] + [! ?2] + [Submodules ?forms subs])] [(Wrap p:define-syntaxes (e1 e2 rs ?1 prep rhs locals)) (R [! ?1] [#:pattern ?form] @@ -252,6 +253,13 @@ [#:pattern ?form] [#:walk e2 'macro])] + [(Wrap p:submodule* (e1 e2 rs ?1)) + (R [! ?1])] + [(Wrap p:submodule (e1 e2 rs ?1 exp)) + (R [! ?1] + [#:pattern ?form] + [Expr ?form exp])] + [(Wrap p:stop (e1 e2 rs ?1)) (R [! ?1])] @@ -501,6 +509,18 @@ [#f (R)])) +(define (Submodules subs) + (match subs + ['() + (R)] + [(cons sub rest) + (R [#:pattern ?form] + [#:new-local-context + [#:pattern ?form] + [#:set-syntax (wderiv-e1 sub)] + [Expr ?form sub]] + [Submodules ?form rest])])) + ;; List : ListDerivation -> RST (define (List ld) (match ld diff --git a/src/racket/src/module.c b/src/racket/src/module.c index 2ece29611a..03de981828 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -7631,6 +7631,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env env->genv->module->dummy = dummy; } + SCHEME_EXPAND_OBSERVE_NEXT(observer); + /* Submodules */ if (has_submodules) { Scheme_Object *expanded_modules, *root_module_name; @@ -8333,6 +8335,13 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ is_star = scheme_stx_module_eq_x(scheme_modulestar_stx, fst, phase); + SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e); + if (is_star) { + SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE_STAR(observer); + } else { + SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE(observer); + } + if (SCHEME_STX_PAIRP(e)) { p = SCHEME_STX_CDR(e); if (SCHEME_STX_PAIRP(p)) { @@ -8375,6 +8384,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ bxs->saved_submodules = p; kind = MODULE_MODFORM_KIND; } + SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer,e); } else kind = EXPR_MODFORM_KIND; } else @@ -8757,8 +8767,10 @@ static Scheme_Object *expand_submodules(Scheme_Compile_Expand_Info *rec, int dre while (!SCHEME_NULLP(l)) { mod = SCHEME_CAR(l); + SCHEME_EXPAND_OBSERVE_ENTER_PRIM(rec[drec].observer,SCHEME_CAR(mod)); mod = do_module(SCHEME_CAR(mod), env, rec, drec, ancestry, env->genv->module->submodule_path, post, bxs, SCHEME_CDR(mod)); + SCHEME_EXPAND_OBSERVE_EXIT_PRIM(rec[drec].observer,mod); mods = scheme_make_pair(mod, mods); diff --git a/src/racket/src/schexpobs.h b/src/racket/src/schexpobs.h index 4209c23843..bc93f9be92 100644 --- a/src/racket/src/schexpobs.h +++ b/src/racket/src/schexpobs.h @@ -97,7 +97,7 @@ extern Scheme_Object *scheme_get_expand_observe(); _SCHEME_EXPOBS(observer,119,NULL) #define SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE_FOR_SYNTAX(observer) \ _SCHEME_EXPOBS(observer,120,NULL) -#define SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE_FOR_TEMPLATE(observer) \ +#define SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE_FOR_TEMPLATE(observer) \ _SCHEME_EXPOBS(observer,121,NULL) #define SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(observer) \ _SCHEME_EXPOBS(observer,122,NULL) @@ -117,7 +117,12 @@ extern Scheme_Object *scheme_get_expand_observe(); #define SCHEME_EXPAND_OBSERVE_PRIM_BEGIN_FOR_SYNTAX(observer) \ _SCHEME_EXPOBS(observer,156,scheme_false) -#define SCHEME_EXPAND_OBSERVE_VARIABLE(observer,e1,e2) \ +#define SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE(observer) \ + _SCHEME_EXPOBS(observer,158,scheme_false) +#define SCHEME_EXPAND_OBSERVE_PRIM_SUBMODULE_STAR(observer) \ + _SCHEME_EXPOBS(observer,159,scheme_false) + +#define SCHEME_EXPAND_OBSERVE_VARIABLE(observer,e1,e2) \ _SCHEME_EXPOBS(observer,125,scheme_make_pair(e1, e2)) #define SCHEME_EXPAND_OBSERVE_ENTER_CHECK(observer,stx) \ @@ -191,6 +196,6 @@ extern Scheme_Object *scheme_get_expand_observe(); #define SCHEME_EXPAND_OBSERVE_PREPARE_ENV(obs) \ _SCHEME_EXPOBS(obs,157,scheme_false) -/* next: 158 */ +/* next: 160 */ #endif