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

Ryan's macro-observer changes

Browse Source 
svn: r5888
This commit is contained in:
Matthew Flatt 2007-04-08 09:20:34 +00:00
parent 555e5376a3
commit 9c8c0a22cd
3 changed files with 33 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -7843,7 +7843,16 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
orig_l = l;
observer = scheme_get_expand_observe();
SCHEME_EXPAND_OBSERVE_ENTER_LOCAL(observer, l);
if (observer) {
if (for_expr) {
SCHEME_EXPAND_OBSERVE_ENTER_LOCAL_EXPR(observer, l);
} else {
SCHEME_EXPAND_OBSERVE_ENTER_LOCAL(observer, l);
}
if (for_stx) {
SCHEME_EXPAND_OBSERVE_PHASE_UP(observer);
}
}
if (local_mark) {
/* Since we have an expression from local context,
@ -7904,14 +7913,14 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
l = scheme_add_remove_mark(l, local_mark);
}
SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, l);
if (for_expr) {
Scheme_Object *a[2];
SCHEME_EXPAND_OBSERVE_EXIT_LOCAL_EXPR(observer, l, exp_expr);
a[0] = l;
a[1] = exp_expr;
return scheme_values(2, a);
} else
SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, l);
return l;
}

7
src/mzscheme/src/schexpobs.h
View File

@ -106,6 +106,8 @@ extern Scheme_Object *scheme_get_expand_observe();
_SCHEME_EXPOBS(observer,123,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_LETSTAR_VALUES(observer) \
_SCHEME_EXPOBS(observer,124,NULL)
#define SCHEME_EXPAND_OBSERVE_PRIM_EXPRESSION(obs) \
_SCHEME_EXPOBS(obs,138,scheme_false)
#define SCHEME_EXPAND_OBSERVE_VARIABLE(observer,e1,e2) \
_SCHEME_EXPOBS(observer,125,scheme_make_pair(e1, e2))
@ -137,4 +139,9 @@ extern Scheme_Object *scheme_get_expand_observe();
#define SCHEME_EXPAND_OBSERVE_LOCAL_POST(obs,stx) \
_SCHEME_EXPOBS(obs,133,stx)
#define SCHEME_EXPAND_OBSERVE_ENTER_LOCAL_EXPR(obs,stx) \
_SCHEME_EXPOBS(obs,139,stx)
#define SCHEME_EXPAND_OBSERVE_EXIT_LOCAL_EXPR(obs,stx,opaque) \
_SCHEME_EXPOBS(obs,140,scheme_make_pair(stx,opaque))
#endif

29
src/mzscheme/src/syntax.c
View File

@ -4463,6 +4463,7 @@ static Scheme_Object *expression_syntax(Scheme_Object *form, Scheme_Comp_Env *en
static Scheme_Object *expression_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
SCHEME_EXPAND_OBSERVE_PRIM_EXPRESSION(erec[drec].observer);
return single_expand(form, scheme_no_defines(env), erec, drec, 0,
!(env->flags & SCHEME_TOPLEVEL_FRAME));
}
@ -4986,10 +4987,19 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
Resolve_Info *ri;
Optimize_Info *oi;
int vc, nc, j, i;
Scheme_Compile_Info mrec;
certs = rec[drec].certs;
Scheme_Compile_Expand_Info mrec;
certs = rec[drec].certs;
eenv = scheme_new_comp_env(exp_env, insp, 0);
/* First expand for expansion-observation */
{
scheme_init_expand_recs(rec, drec, &mrec, 1);
SCHEME_EXPAND_OBSERVE_PHASE_UP(mrec.observer);
a = scheme_expand_expr_lift_to_let(a, eenv, &mrec, 0);
}
/* Then compile */
mrec.comp = 1;
mrec.dont_mark_local_use = 0;
mrec.resolve_module_ids = 1;
@ -4997,19 +5007,8 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
mrec.certs = certs;
mrec.observer = NULL;
eenv = scheme_new_comp_env(exp_env, insp, 0);
{
mrec.comp = 0;
mrec.observer = rec[drec].observer;
SCHEME_EXPAND_OBSERVE_PHASE_UP(mrec.observer);
a = scheme_expand_expr_lift_to_let(a, eenv, &mrec, 0);
mrec.comp = 1;
mrec.observer = NULL;
}
a = scheme_compile_expr_lift_to_let(a, eenv, &mrec, 0);
/* For internal defn, don't simplify as resolving, because the
expression may have syntax objects with a lexical rename that
is still being extended.