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

adjust rename-transformer expansion to transfer srcloc of use to expansion

Browse Source
This commit is contained in:
Matthew Flatt 2010-08-19 07:37:47 -06:00
parent a7bc964c69
commit 7abbff4749
4 changed files with 44 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -4711,7 +4711,8 @@ do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int r
v = SCHEME_PTR_VAL(v);
if (scheme_is_rename_transformer(v)) {
sym = scheme_rename_transformer_id(v);
sym = scheme_stx_cert(sym, scheme_false, menv, sym, NULL, 1);
sym = scheme_transfer_srcloc(scheme_stx_cert(sym, scheme_false, menv, sym, NULL, 1),
v);
renamed = 1;
menv = NULL;
SCHEME_USE_FUEL(1);

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

@ -6577,8 +6577,9 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
} else if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) {
if (scheme_is_rename_transformer(SCHEME_PTR_VAL(val))) {
/* It's a rename. Look up the target name and try again. */
name = scheme_stx_cert(scheme_rename_transformer_id(SCHEME_PTR_VAL(val)),
scheme_false, menv, name, NULL, 1);
name = scheme_transfer_srcloc(scheme_stx_cert(scheme_rename_transformer_id(SCHEME_PTR_VAL(val)),
scheme_false, menv, name, NULL, 1),
name);
menv = NULL;
SCHEME_USE_FUEL(1);
} else {
@ -6782,7 +6783,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
new_name = scheme_stx_track(new_name, find_name, find_name);
}
new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1);
find_name = new_name;
find_name = scheme_transfer_srcloc(new_name, find_name);
SCHEME_USE_FUEL(1);
menv = NULL;
protected = 0;
@ -6899,7 +6900,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
new_name = scheme_stx_track(new_name, find_name, find_name);
}
new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1);
find_name = new_name;
find_name = scheme_transfer_srcloc(new_name, find_name);
SCHEME_USE_FUEL(1);
menv = NULL;
} else
@ -6986,7 +6987,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
new_name = scheme_stx_track(new_name, find_name, find_name);
}
new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1);
find_name = new_name;
find_name = scheme_transfer_srcloc(new_name, find_name);
SCHEME_USE_FUEL(1);
menv = NULL;
} else

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

@ -1023,6 +1023,8 @@ XFORM_NONGCING Scheme_Object *scheme_phase_index_symbol(int src_phase_index);
Scheme_Object *scheme_explode_syntax(Scheme_Object *stx, Scheme_Hash_Table *ht);
void scheme_populate_pt_ht(struct Scheme_Module_Phase_Exports * pt);
Scheme_Object *scheme_transfer_srcloc(Scheme_Object *to, Scheme_Object *from);
/*========================================================================*/
/* syntax run-time structures */
/*========================================================================*/

34
src/racket/src/stxobj.c
View File

@ -8855,6 +8855,40 @@ static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv)
return scheme_stx_track(argv[0], argv[1], argv[2]);
}
Scheme_Object *scheme_transfer_srcloc(Scheme_Object *to, Scheme_Object *from)
{
if (!SAME_OBJ(((Scheme_Stx *)from)->srcloc, empty_srcloc)) {
Scheme_Stx *stx = (Scheme_Stx *)to;
Scheme_Object *wraps, *modinfo_cache;
Scheme_Object *certs;
long lazy_prefix;
wraps = stx->wraps;
if (STX_KEY(stx) & STX_SUBSTX_FLAG) {
modinfo_cache = NULL;
lazy_prefix = stx->u.lazy_prefix;
} else {
modinfo_cache = stx->u.modinfo_cache;
lazy_prefix = 0;
}
certs = stx->certs;
stx = (Scheme_Stx *)scheme_make_stx(stx->val,
((Scheme_Stx *)from)->srcloc,
stx->props);
stx->wraps = wraps;
if (modinfo_cache)
stx->u.modinfo_cache = modinfo_cache;
else
stx->u.lazy_prefix = lazy_prefix; /* same as NULL modinfo if no SUBSTX */
stx->certs = certs;
return (Scheme_Object *)stx;
} else
return to;
}
static Scheme_Object *delta_introducer(int argc, struct Scheme_Object *argv[], Scheme_Object *p)
{
Scheme_Object *r, *delta;