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

change 'syntax-local-transformer-expand' to capture lifts into a 'let'

Browse Source 
svn: r13274
This commit is contained in:
Matthew Flatt 2009-01-24 13:49:33 +00:00
parent d40989e222
commit ed6e1ffda6
4 changed files with 78 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/scribblings/reference/numbers.scrbl
View File

@ -593,9 +593,9 @@ Returns
(arithmetic-shift n (- start)))
]
but in constant time when @scheme[n] is positive, @scheme[start] is no
more than the maximum width of a fixnum, and @scheme[(- end start)] is
no more than the maximum width of a fixnum.
but in constant time when @scheme[n] is positive, @scheme[start] and
@scheme[end] are fixnums, and @scheme[(- end start)] is no more than
the maximum width of a fixnum.
@mz-examples[(bitwise-bit-field 13 1 1)
(bitwise-bit-field 13 1 3)

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

@ -155,7 +155,11 @@ avoids quadratic expansion times when local expansions are nested.
syntax?]{
Like @scheme[local-expand], but @scheme[stx] is expanded as a
transformer expression instead of a run-time expression.}
transformer expression instead of a run-time expression, and any
lifted expressions---from calls to
@scheme[syntax-local-lift-expression] during the expansion of
@scheme[stx]---are captured into a @scheme[let-values] form in the
result.}
@defproc[(local-expand/capture-lifts [stx syntax?]
@ -165,7 +169,7 @@ transformer expression instead of a run-time expression.}
[lift-ctx any/c (gensym 'lifts)])
syntax?]{
Like @scheme[local-expand], the result is a syntax object that
Like @scheme[local-expand], but the result is a syntax object that
represents a @scheme[begin] expression. Lifted expressions---from
calls to @scheme[syntax-local-lift-expression] during the expansion of
@scheme[stx]---appear with their identifiers in @scheme[define-values]

90
src/mzscheme/src/eval.c
View File

@ -6158,6 +6158,27 @@ static Scheme_Object *pair_lifted(Scheme_Object *_ip, Scheme_Object **_id, Schem
return icons(icons(*_id, scheme_null), icons(expr, scheme_null));
}
static Scheme_Object *add_lifts_as_let(Scheme_Object *obj, Scheme_Object *l, Scheme_Comp_Env *env,
Scheme_Object *orig_form)
{
Scheme_Object *revl = scheme_null, *a;
if (SCHEME_NULLP(l)) return obj;
for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
revl = icons(SCHEME_CAR(l), revl);
}
for (; SCHEME_PAIRP(revl); revl = SCHEME_CDR(revl)) {
a = SCHEME_CAR(revl);
obj = icons(scheme_datum_to_syntax(let_values_symbol, scheme_false, scheme_sys_wraps(env), 0, 0),
icons(icons(a, scheme_null),
icons(obj, scheme_null)));
}
return scheme_datum_to_syntax(obj, orig_form, scheme_false, 0, 0);
}
static Scheme_Object *compile_expand_expr_lift_to_let_k(void);
static Scheme_Object *
@ -6239,7 +6260,7 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
return form;
} else {
/* We have lifts, so add let* wrapper and go again */
Scheme_Object *o, *revl;
Scheme_Object *o;
if (rec[drec].comp) {
/* Wrap compiled part so the compiler recognizes it later: */
o = scheme_alloc_object();
@ -6247,15 +6268,7 @@ compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env,
SCHEME_IPTR_VAL(o) = form;
} else
o = form;
for (revl = scheme_null; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
revl = icons(SCHEME_CAR(l), revl);
}
for (; SCHEME_PAIRP(revl); revl = SCHEME_CDR(revl)) {
o = icons(scheme_datum_to_syntax(let_values_symbol, scheme_false, scheme_sys_wraps(env), 0, 0),
icons(icons(SCHEME_CAR(revl), scheme_null),
icons(o, scheme_null)));
}
form = scheme_datum_to_syntax(o, orig_form, scheme_false, 0, 0);
form = add_lifts_as_let(o, l, env, orig_form);
SCHEME_EXPAND_OBSERVE_LETLIFT_LOOP(rec[drec].observer, form);
form = compile_expand_expr_lift_to_let(form, env, recs, 1);
if (rec[drec].comp)
@ -8834,14 +8847,13 @@ static Scheme_Object *add_lifts_as_begin(Scheme_Object *obj, Scheme_Object *l, S
obj);
obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 0, 0);
return obj;
}
static void *expand_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *obj, *certs, *observer, *catch_lifts_key;
Scheme_Comp_Env *env;
Scheme_Comp_Env *env, **ip;
Scheme_Expand_Info erec1;
int depth, rename, just_to_top, as_local, comp_flags;
@ -8852,7 +8864,7 @@ static void *expand_k(void)
just_to_top = p->ku.k.i3;
catch_lifts_key = p->ku.k.p4;
certs = (Scheme_Object *)p->ku.k.p3;
as_local = p->ku.k.i4;
as_local = p->ku.k.i4; /* < 0 => catch lifts to let */
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
@ -8872,6 +8884,14 @@ static void *expand_k(void)
comp_flags = get_comp_flags(NULL);
if (as_local < 0) {
/* Insert a dummy frame so that `pair_lifted' can add more. */
env = scheme_new_compilation_frame(0, 0, env, NULL);
ip = MALLOC_N(Scheme_Comp_Env *, 1);
*ip = env;
} else
ip = NULL;
/* Loop for lifted expressions: */
while (1) {
erec1.comp = 0;
@ -8884,10 +8904,14 @@ static void *expand_k(void)
erec1.env_already = 0;
erec1.comp_flags = comp_flags;
if (catch_lifts_key)
scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env),
if (catch_lifts_key) {
Scheme_Object *data;
data = (as_local < 0) ? (Scheme_Object *)ip : scheme_sys_wraps(env);
scheme_frame_captures_lifts(env,
(as_local < 0) ? pair_lifted : scheme_make_lifted_defn, data,
scheme_false, catch_lifts_key,
(!as_local && catch_lifts_key) ? scheme_null : NULL);
}
if (just_to_top) {
Scheme_Object *gval;
@ -8902,12 +8926,15 @@ static void *expand_k(void)
if (SCHEME_PAIRP(l)
|| SCHEME_PAIRP(rl)) {
l = scheme_append(rl, l);
obj = add_lifts_as_begin(obj, l, env);
if (as_local < 0)
obj = add_lifts_as_let(obj, l, env, scheme_false);
else
obj = add_lifts_as_begin(obj, l, env);
SCHEME_EXPAND_OBSERVE_LIFT_LOOP(erec1.observer,obj);
if ((depth >= 0) || as_local)
break;
} else {
if (as_local) {
if (as_local > 0) {
obj = add_lifts_as_begin(obj, scheme_null, env);
SCHEME_EXPAND_OBSERVE_LIFT_LOOP(erec1.observer,obj);
}
@ -8928,6 +8955,7 @@ static Scheme_Object *_expand(Scheme_Object *obj, Scheme_Comp_Env *env,
int depth, int rename, int just_to_top,
Scheme_Object *catch_lifts_key, int eb,
Scheme_Object *certs, int as_local)
/* as_local < 0 => catch lifts to let */
{
Scheme_Thread *p = scheme_current_thread;
@ -9187,7 +9215,7 @@ scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_id, Scheme_Ob
static Scheme_Object *
do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, int argc, Scheme_Object **argv)
{
Scheme_Comp_Env *env, *orig_env;
Scheme_Comp_Env *env, *orig_env, **ip;
Scheme_Object *l, *local_mark, *renaming = NULL, *orig_l, *exp_expr = NULL;
int cnt, pos, kind;
int bad_sub_env = 0;
@ -9254,6 +9282,13 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
| SCHEME_FOR_STOPS
| kind),
env, NULL);
if (catch_lifts < 0) {
/* Note: extra frames can get inserted after env by pair_lifted */
ip = MALLOC_N(Scheme_Comp_Env *, 1);
*ip = env;
} else
ip = NULL;
if (kind == SCHEME_INTDEF_FRAME)
env->intdef_name = argv[1];
env->in_modidx = scheme_current_thread->current_local_modidx;
@ -9334,9 +9369,14 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
Scheme_Object *xl, *gval;
Scheme_Compile_Expand_Info drec[1];
if (catch_lifts_key)
scheme_frame_captures_lifts(env, scheme_make_lifted_defn, scheme_sys_wraps(env), scheme_false,
if (catch_lifts_key) {
Scheme_Object *data;
data = (catch_lifts < 0) ? (Scheme_Object *)ip : scheme_sys_wraps(env);
scheme_frame_captures_lifts(env,
(catch_lifts < 0) ? pair_lifted : scheme_make_lifted_defn, data,
scheme_false,
catch_lifts_key, NULL);
}
memset(drec, 0, sizeof(drec));
drec[0].value_name = scheme_false; /* or scheme_current_thread->current_local_name ? */
@ -9358,7 +9398,10 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
}
if (catch_lifts_key) {
xl = add_lifts_as_begin(xl, scheme_frame_get_lifts(env), env);
if (catch_lifts < 0)
xl = add_lifts_as_let(xl, scheme_frame_get_lifts(env), env, orig_l);
else
xl = add_lifts_as_begin(xl, scheme_frame_get_lifts(env), env);
SCHEME_EXPAND_OBSERVE_LIFT_LOOP(observer,xl);
}
@ -9366,7 +9409,8 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
} else {
/* Expand the expression. depth = -2 means expand all the way, but
preserve letrec-syntax. */
l = _expand(l, env, -2, 0, 0, catch_lifts_key, 0, scheme_current_thread->current_local_certs, 1);
l = _expand(l, env, -2, 0, 0, catch_lifts_key, 0, scheme_current_thread->current_local_certs,
catch_lifts ? catch_lifts : 1);
}
SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, l);
@ -9425,7 +9469,7 @@ local_expand_expr(int argc, Scheme_Object **argv)
static Scheme_Object *
local_transformer_expand(int argc, Scheme_Object **argv)
{
return do_local_expand("local-transformer-expand", 1, 0, 0, argc, argv);
return do_local_expand("local-transformer-expand", 1, -1, 0, argc, argv);
}
static Scheme_Object *

2
src/mzscheme/src/number.c
View File

@ -316,7 +316,7 @@ scheme_init_number (Scheme_Env *env)
scheme_add_global_constant("bitwise-bit-field",
scheme_make_folding_prim(bitwise_bit_field,
"bitwise_bit_field",
"bitwise-bit-field",
3, 3, 1),
env);