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

adjust `local-expand' to add 'submodule property

Browse Source
This commit is contained in:
Matthew Flatt 2012-08-13 16:20:51 -06:00
parent b043da6ea6
commit 23bca99ba1
5 changed files with 52 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/scribblings/reference/stx-trans.scrbl
View File

@ -223,9 +223,15 @@ and @racket[module*] is in @racket[stop-ids], then the
@racket[#%plain-module-begin] transformer refrains from expanding
@racket[module*] sub-forms. Otherwise, the
@racket[#%plain-module-begin] transformer detects and expands sub-forms
(such as @racket[define-values]) independent of the correspond
(such as @racket[define-values]) independent of the corresponding
identifier's presence in @racket[stop-ids].
When @racket[context-v] is @racket['module-begin], and the result of
expansion is a @racket[#%plain-module-begin] form, then a
@racket['submodule] @tech{syntax property} is added to each enclosed
@racket[module] form (but not @racket[module*] forms) in the same way as by
@racket[module] expansion.
The optional @racket[intdef-ctx] argument must be either @racket[#f],
the result of @racket[syntax-local-make-definition-context], or a list
of such results. In the latter two cases, lexical information for

22
collects/tests/racket/submodule.rktl
View File

@ -763,4 +763,26 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module local-expand-lang racket/base
(require (for-syntax racket/base))
(provide (rename-out [mb #%module-begin]) (except-out (all-from-out racket/base) #%module-begin))
(define-syntax (mb stx)
(syntax-case stx ()
[(_ rest ...)
(local-expand #'(#%plain-module-begin rest ...) 'module-begin (list #'module*))])))
(module local-expand-lang2 racket/base
(require (for-syntax racket/base))
(provide (rename-out [mb #%module-begin]) (except-out (all-from-out racket/base) #%module-begin))
(define-syntax (mb stx)
(syntax-case stx ()
[(_ rest ...)
#'(#%plain-module-begin (begin-for-syntax (module* foo #f)) rest ...)])))
;; check that the macro-introduced `module*' works right:
(module local-expand-lang-test 'local-expand-lang
(module m 'local-expand-lang2))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

2
src/racket/src/eval.c
View File

@ -4980,6 +4980,8 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
return scheme_values(2, a);
} else {
SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, l);
if (kind == SCHEME_MODULE_FRAME)
l = scheme_annotate_existing_submodules(l, 0);
return l;
}
}

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

@ -6497,7 +6497,7 @@ static Scheme_Object *strip_lexical_context(Scheme_Object *stx)
static Scheme_Object *do_annotate_submodules_k(void);
Scheme_Object *do_annotate_submodules(Scheme_Object *fm, int phase)
Scheme_Object *do_annotate_submodules(Scheme_Object *fm, int phase, int incl_star)
{
Scheme_Object *a, *d, *v;
int changed = 0;
@ -6507,6 +6507,8 @@ Scheme_Object *do_annotate_submodules(Scheme_Object *fm, int phase)
{
Scheme_Thread *p = scheme_current_thread;
p->ku.k.p1 = (void *)fm;
p->ku.k.i1 = phase;
p->ku.k.i2 = incl_star;
return scheme_handle_stack_overflow(do_annotate_submodules_k);
}
#endif
@ -6521,17 +6523,21 @@ Scheme_Object *do_annotate_submodules(Scheme_Object *fm, int phase)
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)) {
|| (incl_star
&& 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;
v = scheme_stx_property(a, scheme_intern_symbol("submodule"), NULL);
if (SCHEME_FALSEP(v)) {
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);
v = do_annotate_submodules(a, phase+1, incl_star);
if (!SAME_OBJ(v, a)) {
changed = 1;
a = v;
@ -6540,7 +6546,7 @@ Scheme_Object *do_annotate_submodules(Scheme_Object *fm, int phase)
scheme_make_integer(0), scheme_make_integer(phase),
NULL)) {
/* found `begin' */
v = do_annotate_submodules(a, phase);
v = do_annotate_submodules(a, phase, incl_star);
if (!SAME_OBJ(v, a)) {
changed = 1;
a = v;
@ -6550,7 +6556,7 @@ Scheme_Object *do_annotate_submodules(Scheme_Object *fm, int phase)
}
v = SCHEME_STX_CDR(fm);
d = do_annotate_submodules(v, phase);
d = do_annotate_submodules(v, phase, incl_star);
if (!changed && SAME_OBJ(v, d))
return fm;
@ -6569,10 +6575,10 @@ static Scheme_Object *do_annotate_submodules_k(void)
p->ku.k.p1 = NULL;
return do_annotate_submodules(fm, p->ku.k.i1);
return do_annotate_submodules(fm, p->ku.k.i1, p->ku.k.i2);
}
static Scheme_Object *annotate_existing_submodules(Scheme_Object *orig_fm)
Scheme_Object *scheme_annotate_existing_submodules(Scheme_Object *orig_fm, int incl_star)
{
Scheme_Object *fm = orig_fm;
@ -6584,7 +6590,7 @@ static Scheme_Object *annotate_existing_submodules(Scheme_Object *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 do_annotate_submodules(orig_fm, 0, incl_star);
}
return orig_fm;
@ -7022,7 +7028,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
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);
fm = scheme_annotate_existing_submodules(fm, 1);
} else {
fm = scheme_make_pair(scheme_datum_to_syntax(module_begin_symbol, form, mb_ctx, 0, 2),
fm);

2
src/racket/src/schpriv.h
View File

@ -3307,6 +3307,8 @@ void scheme_prep_namespace_rename(Scheme_Env *menv);
Scheme_Object *scheme_string_to_submodule_path(char *_s, intptr_t len);
char *scheme_submodule_path_to_string(Scheme_Object *p, intptr_t *_len);
Scheme_Object *scheme_annotate_existing_submodules(Scheme_Object *orig_fm, int incl_star);
/*========================================================================*/
/* errors and exceptions */
/*========================================================================*/