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

add syntax-local-lift-module

Browse Source
This commit is contained in:
Matthew Flatt 2015-08-14 16:48:20 -06:00
parent dbd5470805
commit 0caf079637
13 changed files with 1913 additions and 1613 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "6.2.900.9")
(define version "6.2.900.10")
(define deps `("racket-lib"
["racket" #:version ,version]))

29
pkgs/racket-doc/scribblings/reference/stx-trans.scrbl
View File

@ -348,7 +348,12 @@ forms, and the expansion of @racket[stx] is the last expression in the
@racket[begin]. The @racket[lift-ctx] value is reported by
@racket[syntax-local-lift-context] during local expansion. The lifted
expressions are not expanded, but instead left as provided in the
@racket[begin] form.}
@racket[begin] form.
If @racket[context-v] is @racket['top-level] or @racket['module], then
@racket[module] forms can appear in the result as added via
@racket[syntax-local-lift-module]. If @racket[context-v] is
@racket['module], then @racket[module*] forms can appear, too.}
@defproc[(local-transformer-expand/capture-lifts [stx any/c]
@ -578,6 +583,28 @@ for caching lift information to avoid redundant lifts.
@transform-time[]}
@defproc[(syntax-local-lift-module [stx syntax?])
void?]{
Cooperates with the @racket[module] form or top-level expansion to add
@racket[stx] as a module declaration in the enclosing module or top-level.
The @racket[stx] form must start with @racket[module] or @racket[module*],
where the latter is only allowed within the expansion of a module.
The module is not immediately declared when
@racket[syntax-local-lift-module] returns. Instead, the module
declaration is recorded for processing when expansion returns to the
enclosing module body or top-level sequence.
@transform-time[] If the current expression being transformed is not
within a @racket[module] form or within a top-level expansion, then
the @exnraise[exn:fail:contract]. If @racket[stx] form does start with
@racket[module] or @racket[module*], or if it starts with @racket[module*]
in a top-level context, the @exnraise[exn:fail:contract].
@history[#:added "6.2.900.10"]}
@defproc[(syntax-local-lift-module-end-declaration [stx syntax?])
void?]{

60
pkgs/racket-test-core/tests/racket/macro.rktl
View File

@ -1019,6 +1019,66 @@
(eval `(require 'm)))
(test "2\n" get-output-string o))
(parameterize ([current-namespace (make-base-namespace)])
(eval `(module m racket/base
(require (for-syntax racket/base))
(define x 10)
(let-syntax ([x (syntax-local-lift-module #'(module m racket/base
(provide x)
(define x 10)))])
(void))))
(test 10 eval `(dynamic-require '(submod 'm m) 'x)))
;; ----------------------------------------
;; Check module lifting in a top-level context
(define-syntax (do-lift-example-1 stx)
(syntax-local-lift-module
#'(module lift-example-1 racket/base
(provide x)
(define x 10)))
#'(void))
(do-lift-example-1)
(test 10 dynamic-require ''lift-example-1 'x)
(test '(begin
(module lift-example-1 racket/base
(provide x)
(define x 10))
(#%app void))
'local-expand/capture-lifts
(let-syntax ([quote-local-expand
(lambda (stx)
(syntax-case stx ()
[(_ e)
#`(quote #,(local-expand/capture-lifts #'e 'top-level null))]))])
(quote-local-expand (do-lift-example-1))))
(define-syntax (do-lift-example-1* stx)
(syntax-local-lift-module
#'(module* lift-example-1* racket/base
(provide x)
(define x 10)))
#'(void))
(err/rt-test (expand '(do-lift-example-1*))
(lambda (exn)
(and (exn:fail:contract? exn)
(regexp-match #rx"cannot lift.*module[*]" (exn-message exn)))))
(test '(begin
(module* lift-example-1* racket/base
(provide x)
(define x 10))
(#%app void))
'local-expand/capture-lifts
(let-syntax ([quote-local-expand
(lambda (stx)
(syntax-case stx ()
[(_ e)
#`(quote #,(local-expand/capture-lifts #'e 'module null))]))])
(quote-local-expand (do-lift-example-1*))))
;; ----------------------------------------
;; Lifting should not introduce `#%top` around
;; the reference to the lifted identifier:

48
pkgs/racket-test-core/tests/racket/module.rktl
View File

@ -1430,6 +1430,54 @@ case of module-leve bindings; it doesn't cover local bindings.
(test #t syntax? (expand-syntax (expand lifted-require-of-submodule)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check module lifting
(module module-lift-example-1 racket/base
(require (for-syntax racket/base))
(define-syntax (m stx)
(syntax-local-lift-module
#'(module m racket/base
(provide x)
(define x 10)))
#'(begin
(require 'm)
(define out x)
(provide out)))
(m))
(test 10 dynamic-require ''module-lift-example-1 'out)
(module module-lift-example-2 racket/base
(require (for-syntax racket/base))
(define-syntax (m stx)
(syntax-local-lift-module #'(module* sub #f
(provide s)
(define s (add1 a))))
#'(void))
(m)
(define a 1))
(test 2 dynamic-require '(submod 'module-lift-example-2 sub) 's)
(module module-lift-example-3 racket/base
(require (for-syntax racket/base))
(define-syntax (m stx)
(syntax-local-lift-module #'(module m racket/base
(provide x)
(define x 11)))
(syntax-local-lift-module-end-declaration
#'(let ()
(local-require (submod "." m))
(set! out x)))
#'(void))
(define out -10)
(m)
(provide out))
(test 11 dynamic-require ''module-lift-example-3 'out)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check addition of 'disappeared-use by `provide`

83
racket/src/racket/src/compenv.c
View File

@ -398,7 +398,8 @@ scheme_add_compilation_binding(int index, Scheme_Object *val, Scheme_Comp_Env *f
void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data,
Scheme_Object *end_stmts, Scheme_Object *context_key,
Scheme_Object *requires, Scheme_Object *provides)
Scheme_Object *requires, Scheme_Object *provides,
Scheme_Object *module_lifts)
{
Scheme_Lift_Capture_Proc *pp;
Scheme_Object *vec;
@ -406,7 +407,7 @@ void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc
pp = (Scheme_Lift_Capture_Proc *)scheme_malloc_atomic(sizeof(Scheme_Lift_Capture_Proc));
*pp = cp;
vec = scheme_make_vector(8, NULL);
vec = scheme_make_vector(9, NULL);
SCHEME_VEC_ELS(vec)[0] = scheme_null;
SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)pp;
SCHEME_VEC_ELS(vec)[2] = data;
@ -415,6 +416,7 @@ void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc
SCHEME_VEC_ELS(vec)[5] = (requires ? requires : scheme_false);
SCHEME_VEC_ELS(vec)[6] = scheme_null; /* accumulated requires */
SCHEME_VEC_ELS(vec)[7] = provides;
SCHEME_VEC_ELS(vec)[8] = module_lifts; /* #f => disallowed; #t or (void) => add to slot 0; (void) => `module*` allowed */
env->lifts = vec;
}
@ -433,7 +435,7 @@ void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Com
p = scheme_make_raw_pair(NULL, (Scheme_Object *)orig_env);
vec = scheme_make_vector(8, NULL);
vec = scheme_make_vector(9, NULL);
SCHEME_VEC_ELS(vec)[0] = scheme_false;
SCHEME_VEC_ELS(vec)[1] = scheme_void;
SCHEME_VEC_ELS(vec)[2] = scheme_void;
@ -442,6 +444,7 @@ void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Com
SCHEME_VEC_ELS(vec)[5] = p; /* (rcons NULL env) => continue with env */
SCHEME_VEC_ELS(vec)[6] = scheme_null;
SCHEME_VEC_ELS(vec)[7] = scheme_false;
SCHEME_VEC_ELS(vec)[8] = scheme_false;
env->lifts = vec;
}
@ -457,6 +460,11 @@ Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env)
return SCHEME_VEC_ELS(env->lifts)[3];
}
Scheme_Object *scheme_frame_get_modules(Scheme_Comp_Env *env)
{
return SCHEME_VEC_ELS(env->lifts)[8];
}
Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env)
{
return SCHEME_VEC_ELS(env->lifts)[6];
@ -2087,6 +2095,18 @@ Scheme_Comp_Env *scheme_get_module_lift_env(Scheme_Comp_Env *env)
return env;
}
static Scheme_Comp_Env *get_lift_env_for_module(Scheme_Comp_Env *env)
{
while (env) {
if ((env->lifts)
&& SCHEME_TRUEP(SCHEME_VEC_ELS(env->lifts)[8]))
break;
env = env->next;
}
return env;
}
Scheme_Object *
scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_scope, Scheme_Comp_Env *env)
{
@ -2113,6 +2133,63 @@ scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_scope,
return scheme_void;
}
Scheme_Object *
scheme_local_lift_module(Scheme_Object *expr, Scheme_Object *local_scope, Scheme_Comp_Env *env)
{
Scheme_Object *pr;
Scheme_Object *orig_expr;
int star_ok, slot;
env = get_lift_env_for_module(env);
if (!env)
scheme_contract_error("syntax-local-lift-module",
"not currently transforming within a module declaration or top level",
NULL);
if (local_scope)
expr = scheme_stx_flip_scope(expr, local_scope, scheme_env_phase(env->genv));
orig_expr = expr;
star_ok = !SAME_OBJ(scheme_true, SCHEME_VEC_ELS(env->lifts)[8]);
if (SCHEME_STX_PAIRP(expr)) {
pr = SCHEME_STX_CAR(expr);
if (scheme_stx_free_eq3(pr, scheme_module_stx, scheme_env_phase(env->genv), scheme_make_integer(0))) {
/* ok */
} else if (scheme_stx_free_eq3(pr, scheme_modulestar_stx, scheme_env_phase(env->genv), scheme_make_integer(0))) {
if (!star_ok)
scheme_contract_error("syntax-local-lift-module",
"cannot lift `module*' to a top-level context",
"syntax", 1, expr,
NULL);
/* otherwise, ok */
} else
pr = NULL;
} else
pr = NULL;
if (!pr)
scheme_contract_error("syntax-local-lift-module",
"not a module declaration",
"syntax", 1, expr,
NULL);
/* Add to separate list or mingle with definitions? */
if (SCHEME_NULLP(SCHEME_VEC_ELS(env->lifts)[8])
|| SCHEME_PAIRP(SCHEME_VEC_ELS(env->lifts)[8]))
slot = 8;
else
slot = 0;
pr = scheme_make_pair(expr, SCHEME_VEC_ELS(env->lifts)[slot]);
SCHEME_VEC_ELS(env->lifts)[slot] = pr;
SCHEME_EXPAND_OBSERVE_LIFT_STATEMENT(scheme_get_expand_observe(), orig_expr);
return scheme_void;
}
Scheme_Object *scheme_local_lift_require(Scheme_Object *form, Scheme_Object *orig_form,
intptr_t phase, Scheme_Object *local_scope, Scheme_Comp_Env *cenv)
{

5
racket/src/racket/src/compile.c
View File

@ -3508,7 +3508,8 @@ begin_for_syntax_expand(Scheme_Object *orig_form, Scheme_Comp_Env *in_env, Schem
while (1) {
scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env),
scheme_false, scheme_top_level_lifts_key(env), scheme_null, scheme_false);
scheme_false, scheme_top_level_lifts_key(env), scheme_null,
scheme_false, scheme_true);
if (rec[drec].comp) {
scheme_init_compile_recs(rec, drec, recs, 1);
@ -5589,7 +5590,7 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
context_key = scheme_generate_lifts_key();
scheme_frame_captures_lifts(inserted, scheme_pair_lifted, (Scheme_Object *)ip, scheme_false,
context_key, NULL, scheme_false);
context_key, NULL, scheme_false, scheme_false);
if (rec[drec].comp) {
scheme_init_compile_recs(rec, drec, recs, 2);

3074
racket/src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

21
racket/src/racket/src/env.c
View File

@ -114,6 +114,7 @@ static Scheme_Object *local_lift_expr(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_exprs(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_context(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_end_statement(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_module(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_lift_provide(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_introducer(int argc, Scheme_Object *argv[]);
@ -804,6 +805,7 @@ static void make_kernel_env(void)
GLOBAL_PRIM_W_ARITY("syntax-local-lift-values-expression", local_lift_exprs, 2, 2, env);
GLOBAL_PRIM_W_ARITY("syntax-local-lift-context", local_lift_context, 0, 0, env);
GLOBAL_PRIM_W_ARITY("syntax-local-lift-module-end-declaration", local_lift_end_statement, 1, 1, env);
GLOBAL_PRIM_W_ARITY("syntax-local-lift-module", local_lift_module, 1, 1, env);
GLOBAL_PRIM_W_ARITY("syntax-local-lift-require", local_lift_require, 2, 2, env);
GLOBAL_PRIM_W_ARITY("syntax-local-lift-provide", local_lift_provide, 1, 1, env);
@ -2772,6 +2774,25 @@ local_lift_end_statement(int argc, Scheme_Object *argv[])
return scheme_local_lift_end_statement(expr, local_scope, env);
}
static Scheme_Object *
local_lift_module(int argc, Scheme_Object *argv[])
{
Scheme_Comp_Env *env;
Scheme_Object *local_scope, *expr;
expr = argv[0];
if (!SCHEME_STXP(expr))
scheme_wrong_contract("syntax-local-lift-module", "syntax?", 0, argc, argv);
env = scheme_current_thread->current_local_env;
local_scope = scheme_current_thread->current_local_scope;
if (!env)
not_currently_transforming("syntax-local-lift-module");
return scheme_local_lift_module(expr, local_scope, env);
}
static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[])
{
Scheme_Comp_Env *env;

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

@ -4148,7 +4148,9 @@ static void *compile_k(void)
before the rest. */
while (1) {
scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv),
scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false);
scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false,
/* lifted modules like definitions: */
scheme_true);
form = scheme_check_immediate_macro(form,
cenv, &rec, 0,
&gval,
@ -4195,7 +4197,9 @@ static void *compile_k(void)
while (1) {
scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv),
scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false);
scheme_false, scheme_top_level_lifts_key(cenv), scheme_null, scheme_false,
/* lifted modules like definitions: */
scheme_true);
scheme_init_compile_recs(&rec, 0, &rec2, 1);
@ -4650,7 +4654,13 @@ static void *expand_k(void)
data,
scheme_false, catch_lifts_key,
(!as_local && catch_lifts_key) ? scheme_null : NULL,
scheme_false);
scheme_false,
/* lifted modules like definitions: */
((env->flags & SCHEME_TOPLEVEL_FRAME)
? scheme_true /* lifted `module` like definition */
: ((env->flags & SCHEME_MODULE_FRAME)
? scheme_void /* lifted `module[*]` like definition */
: scheme_false)));
}
if (just_to_top) {
@ -5268,7 +5278,12 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
data,
scheme_top_level_lifts_key(env),
catch_lifts_key, NULL,
scheme_false);
scheme_false,
((kind & SCHEME_TOPLEVEL_FRAME)
? scheme_true /* lifted `module` like definition */
: ((kind & SCHEME_MODULE_FRAME)
? scheme_void /* lifted `module[*]` like definition */
: scheme_false))); /* no lifted modules */
}
memset(drec, 0, sizeof(drec));

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

@ -8563,6 +8563,79 @@ static Scheme_Object *revert_use_site_scopes_via_context(Scheme_Object *o, Schem
SCHEME_STX_REMOVE);
}
static Scheme_Object *handle_submodule_form(const char *who,
Scheme_Object *e,
Scheme_Comp_Env *env, int phase,
Scheme_Object *rn_set, Scheme_Object *observer,
Module_Begin_Expand_State *bxs,
Scheme_Compile_Expand_Info *rec, int drec,
Scheme_Compile_Expand_Info *erec, int derec,
int *_kind)
{
Scheme_Object *name = NULL, *fst, *p;
int is_star;
fst = SCHEME_STX_CAR(e);
is_star = scheme_stx_free_eq_x(scheme_modulestar_stx, fst, phase);
e = revert_use_site_scopes_via_context(e, rn_set, 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)) {
name = SCHEME_STX_CAR(p);
p = SCHEME_STX_CDR(p);
if (!SCHEME_STX_SYMBOLP(name)
|| !SCHEME_STX_PAIRP(p)) {
name = NULL;
}
}
}
if (!name) {
scheme_wrong_syntax(who, NULL, e, NULL);
}
if (!bxs->submodule_names) {
Scheme_Hash_Table *smn;
smn = scheme_make_hash_table(SCHEME_hash_ptr);
bxs->submodule_names = smn;
}
if (scheme_hash_get(bxs->submodule_names, SCHEME_STX_VAL(name))) {
scheme_wrong_syntax(who, name, fst, "duplicate submodule definition");
}
scheme_hash_set(bxs->submodule_names,
SCHEME_STX_VAL(name),
is_star ? scheme_void : scheme_true);
if (!is_star) {
p = expand_submodules(erec ? erec : rec, erec ? derec :drec, env,
scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), scheme_null), 0,
bxs, !!erec);
if (erec)
e = SCHEME_CAR(p);
else
e = NULL;
*_kind = DONE_MODFORM_KIND;
} else {
p = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)),
bxs->saved_submodules);
bxs->saved_submodules = p;
*_kind = MODULE_MODFORM_KIND;
}
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer,e);
return e;
}
static Scheme_Object *do_module_begin_k(void)
{
Scheme_Thread *p = scheme_current_thread;
@ -8784,7 +8857,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
? scheme_frame_get_provide_lifts(xenv)
: scheme_null);
scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv),
p, lift_ctx, req_data, prev_p);
p, lift_ctx, req_data, prev_p, scheme_void);
maybe_has_lifts = 1;
{
@ -8981,7 +9054,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
0);
if (!for_stx)
scheme_frame_captures_lifts(eenv, NULL, NULL, scheme_false, scheme_false,
req_data, scheme_false);
req_data, scheme_false, scheme_false);
oenv = env;
@ -9220,63 +9293,14 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
|| scheme_stx_free_eq_x(scheme_modulestar_stx, fst, phase)) {
/************ module[*] *************/
/* check outer syntax & name, then expand pre-module or remember for post-module pass */
Scheme_Object *name = NULL;
int is_star;
is_star = scheme_stx_free_eq_x(scheme_modulestar_stx, fst, phase);
e = revert_use_site_scopes_via_context(e, rn_set, 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)) {
name = SCHEME_STX_CAR(p);
p = SCHEME_STX_CDR(p);
if (!SCHEME_STX_SYMBOLP(name)
|| !SCHEME_STX_PAIRP(p)) {
name = NULL;
}
}
}
if (!name) {
scheme_wrong_syntax(who, NULL, e, NULL);
}
if (!bxs->submodule_names) {
Scheme_Hash_Table *smn;
smn = scheme_make_hash_table(SCHEME_hash_ptr);
bxs->submodule_names = smn;
}
if (scheme_hash_get(bxs->submodule_names, SCHEME_STX_VAL(name))) {
scheme_wrong_syntax(who, name, fst, "duplicate submodule definition");
}
scheme_hash_set(bxs->submodule_names,
SCHEME_STX_VAL(name),
is_star ? scheme_void : scheme_true);
if (!is_star) {
p = expand_submodules(erec ? erec : rec, erec ? derec :drec, env,
scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)), scheme_null), 0,
bxs, !!erec);
if (erec)
e = SCHEME_CAR(p);
else
e = NULL;
kind = DONE_MODFORM_KIND;
} else {
p = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(phase)),
bxs->saved_submodules);
bxs->saved_submodules = p;
kind = MODULE_MODFORM_KIND;
}
SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer,e);
int k;
e = handle_submodule_form(who,
e, env, phase,
rn_set, observer,
bxs,
rec, drec, erec, derec,
&k);
kind = k;
} else {
kind = EXPR_MODFORM_KIND;
non_phaseless |= NON_PHASELESS_FORM;
@ -9400,7 +9424,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
ll = (maybe_has_lifts
? scheme_frame_get_provide_lifts(cenv)
: scheme_null);
scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx, req_data, ll);
scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx, req_data, ll, scheme_void);
maybe_has_lifts = 1;
if (kind == DEFN_MODFORM_KIND)
@ -9436,6 +9460,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
p = SCHEME_CDR(p);
} else {
/* Lifts - insert them and try again */
Scheme_Object *fst;
*bxs->all_simple_bindings = 0;
SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, scheme_copy_list(l));
if (erec) {
@ -9447,7 +9472,29 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
e = scheme_make_pair(e, scheme_make_integer(DONE_MODFORM_KIND)); /* don't re-compile/-expand */
SCHEME_CAR(p) = e;
for (ll = l; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) {
e = scheme_make_pair(SCHEME_CAR(ll), scheme_make_integer(DEFN_MODFORM_KIND));
e = SCHEME_CAR(ll);
if (SCHEME_STX_PAIRP(SCHEME_CAR(e)))
fst = SCHEME_STX_CAR(SCHEME_CAR(e));
else
fst = NULL;
if (fst
&& (scheme_stx_free_eq3(fst, scheme_module_stx, scheme_make_integer(phase), scheme_make_integer(0))
|| scheme_stx_free_eq3(fst, scheme_modulestar_stx, scheme_make_integer(phase), scheme_make_integer(0)))) {
/* a `module` or `module*` form; handle as in first pass */
int k;
e = handle_submodule_form(who,
e, env, phase,
rn_set, observer,
bxs,
rec, drec, erec, derec,
&k);
if (e)
e = scheme_make_pair(e, scheme_make_integer(k));
else
e = scheme_make_pair(scheme_void, DONE_MODFORM_KIND);
} else {
e = scheme_make_pair(e, scheme_make_integer(DEFN_MODFORM_KIND));
}
SCHEME_CAR(ll) = e;
}
p = scheme_append(l, p);

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

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1133
#define EXPECTED_PRIM_COUNT 1134
#define EXPECTED_UNSAFE_COUNT 106
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45

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

@ -2835,6 +2835,8 @@ Scheme_Object *scheme_do_local_lift_expr(const char *who, int stx_pos,
Scheme_Object *scheme_local_lift_context(Scheme_Comp_Env *env);
Scheme_Object *scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_scope,
Scheme_Comp_Env *env);
Scheme_Object *scheme_local_lift_module(Scheme_Object *expr, Scheme_Object *local_scope,
Scheme_Comp_Env *env);
Scheme_Object *scheme_local_lift_require(Scheme_Object *form, Scheme_Object *orig_form,
intptr_t phase, Scheme_Object *local_scope,
Scheme_Comp_Env *env);
@ -2890,10 +2892,12 @@ Scheme_Object *scheme_extract_foreign(Scheme_Object *o);
typedef Scheme_Object *(*Scheme_Lift_Capture_Proc)(Scheme_Object *, Scheme_Object **, Scheme_Object *, Scheme_Comp_Env *);
void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data,
Scheme_Object *end_stmts, Scheme_Object *context_key,
Scheme_Object *require_lifts, Scheme_Object *provide_lifts);
Scheme_Object *require_lifts, Scheme_Object *provide_lifts,
Scheme_Object *module_lifts);
void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Comp_Env *env);
Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env);
Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env);
Scheme_Object *scheme_frame_get_end_modules(Scheme_Comp_Env *env);
Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env);
Scheme_Object *scheme_frame_get_provide_lifts(Scheme_Comp_Env *env);
Scheme_Object *scheme_generate_lifts_key(void);

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.2.900.9"
#define MZSCHEME_VERSION "6.2.900.10"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 900
#define MZSCHEME_VERSION_W 9
#define MZSCHEME_VERSION_W 10
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)