From 8a350a7dfd1b8784e9597722144fac7267bda84e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 5 Jun 2013 07:13:14 -0600 Subject: [PATCH] =?UTF-8?q?fix=20interaction=20of=20shadower,=20rename=20t?= =?UTF-8?q?rasnformer,=20and=20free-id=3D=3F?= --- collects/tests/racket/macro.rktl | 8 ++++++++ src/racket/src/compenv.c | 14 +++++++++++--- src/racket/src/env.c | 9 ++++++--- src/racket/src/schpriv.h | 2 +- 4 files changed, 26 insertions(+), 7 deletions(-) diff --git a/collects/tests/racket/macro.rktl b/collects/tests/racket/macro.rktl index 7a5c2c53ab..6b4c5a6b88 100644 --- a/collects/tests/racket/macro.rktl +++ b/collects/tests/racket/macro.rktl @@ -230,6 +230,14 @@ (foozzz foozz) foozz))) +(test #t 'free-identifier=?-of-rename-via-shadower + (let ([y 5]) + (let-syntax ([m (lambda (stx) + #`(quote-syntax #,(syntax-local-get-shadower #'x)))]) + (let-syntax ([x (make-rename-transformer #'y)]) + (free-identifier=? (m) #'y))))) + + (test #t set!-transformer? (make-set!-transformer void)) (test #t rename-transformer? (make-rename-transformer #'void)) diff --git a/src/racket/src/compenv.c b/src/racket/src/compenv.c index 7a4a76bb1b..f7048d37c3 100644 --- a/src/racket/src/compenv.c +++ b/src/racket/src/compenv.c @@ -2439,10 +2439,11 @@ Scheme_Object *scheme_namespace_lookup_value(Scheme_Object *sym, Scheme_Env *gen return v; } -Scheme_Object *scheme_find_local_shadower(Scheme_Object *sym, Scheme_Object *sym_marks, Scheme_Comp_Env *env) +Scheme_Object *scheme_find_local_shadower(Scheme_Object *sym, Scheme_Object *sym_marks, Scheme_Comp_Env *env, + Scheme_Object **_free_id) { Scheme_Comp_Env *frame; - Scheme_Object *esym, *uid = NULL, *env_marks, *prop; + Scheme_Object *esym, *uid = NULL, *env_marks, *prop, *val; /* Walk backward through the frames, looking for a renaming binding with the same marks as the given identifier, sym. Skip over @@ -2482,12 +2483,19 @@ Scheme_Object *scheme_find_local_shadower(Scheme_Object *sym, Scheme_Object *sym prop = scheme_stx_property(esym, unshadowable_symbol, NULL); if (SCHEME_FALSEP(prop)) { env_marks = scheme_stx_extract_marks(esym); - if (scheme_equal(env_marks, sym_marks)) { /* This used to have 1 || --- why? */ + if (scheme_equal(env_marks, sym_marks)) { sym = esym; if (COMPILE_DATA(frame)->const_uids) uid = COMPILE_DATA(frame)->const_uids[i]; else uid = frame->uid; + val = COMPILE_DATA(frame)->const_vals[i]; + if (val && SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) { + if (scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(val))) { + val = scheme_rename_transformer_id(SCHEME_PTR_VAL(val)); + *_free_id = val; + } + } break; } } diff --git a/src/racket/src/env.c b/src/racket/src/env.c index 40b0c51c8c..c60bb7c27c 100644 --- a/src/racket/src/env.c +++ b/src/racket/src/env.c @@ -2327,7 +2327,7 @@ static Scheme_Object * local_get_shadower(int argc, Scheme_Object *argv[]) { Scheme_Comp_Env *env; - Scheme_Object *sym, *sym_marks = NULL, *orig_sym, *uid = NULL; + Scheme_Object *sym, *sym_marks = NULL, *orig_sym, *uid = NULL, *free_id = NULL; env = scheme_current_thread->current_local_env; if (!env) @@ -2341,7 +2341,7 @@ local_get_shadower(int argc, Scheme_Object *argv[]) sym_marks = scheme_stx_extract_marks(sym); - uid = scheme_find_local_shadower(sym, sym_marks, env); + uid = scheme_find_local_shadower(sym, sym_marks, env, &free_id); if (!uid) { uid = scheme_tl_id_sym(env->genv, sym, NULL, 0, @@ -2366,12 +2366,15 @@ local_get_shadower(int argc, Scheme_Object *argv[]) result = scheme_datum_to_syntax(SCHEME_STX_VAL(sym), orig_sym, sym, 0, 0); ((Scheme_Stx *)result)->props = ((Scheme_Stx *)orig_sym)->props; - + rn = scheme_make_rename(uid, 1); scheme_set_rename(rn, 0, result); result = scheme_add_rename(result, rn); + if (free_id) + scheme_install_free_id_rename(result, free_id, NULL, scheme_make_integer(0)); + if (!scheme_stx_is_clean(orig_sym)) result = scheme_stx_taint(result); diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 00b8a9f35e..ef884b94c2 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -2677,7 +2677,7 @@ Scheme_Comp_Env *scheme_new_expand_env(Scheme_Env *genv, Scheme_Object *insp, in Scheme_Object *scheme_namespace_lookup_value(Scheme_Object *sym, Scheme_Env *genv, Scheme_Object **_id, int *_use_map); Scheme_Object *scheme_find_local_shadower(Scheme_Object *sym, Scheme_Object *sym_marks, - Scheme_Comp_Env *env); + Scheme_Comp_Env *env, Scheme_Object **_free_id); Scheme_Object *scheme_do_local_lift_expr(const char *who, int stx_pos, int argc, Scheme_Object *argv[]); Scheme_Object *scheme_local_lift_context(Scheme_Comp_Env *env);