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

macro-debugger: updates for submodules

Browse Source
This commit is contained in:
Ryan Culpepper 2012-03-21 12:00:42 -06:00
parent dd764ca83d
commit f0c03ad921
7 changed files with 71 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/macro-debugger/analysis/private/get-references.rkt
View File

@ -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)]

5
collects/macro-debugger/model/deriv-c.rkt
View File

@ -56,7 +56,7 @@
;; (make-p:#%module-begin <Base> 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 <Base> (listof LocalAction) DerivLL (listof LocalAction))
;; (make-p:define-values <Base> Deriv)
@ -101,6 +101,9 @@
;; (make-p:require <Base> (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 <Base> BDeriv)
(define-struct (p:#%stratified-body prule) (bderiv) #:transparent)

18
collects/macro-debugger/model/deriv-parser.rkt
View File

@ -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)])

6
collects/macro-debugger/model/deriv-tokens.rkt
View File

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

24
collects/macro-debugger/model/reductions.rkt
View File

@ -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

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

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

11
src/racket/src/schexpobs.h
View File

@ -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