From a1a2d9c2c7e9c29998759a2c43d27ecdb3658901 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 7 Oct 2016 08:25:31 -0600 Subject: [PATCH] fix missing expansion context for `prop:rename-transformer` proc When calling a procedure that is attached as a `prop:rename-transformer` property value, make sure that any available expansion context is accessible as reflected by `(syntax-transforming?)`. Syntax parameters as rename transformers particularly rely on that information for local expansion. Thanks to Jay for the "stxparam.rktl" test. Closes #1479 --- pkgs/racket-test-core/tests/racket/macro.rktl | 32 +++++++++++++++++++ .../tests/racket/stxparam.rktl | 30 +++++++++++++++++ racket/src/racket/src/compile.c | 14 ++++---- racket/src/racket/src/env.c | 6 ++-- racket/src/racket/src/fun.c | 2 +- racket/src/racket/src/module.c | 4 +-- racket/src/racket/src/schpriv.h | 3 +- racket/src/racket/src/struct.c | 17 ++++++++-- 8 files changed, 91 insertions(+), 17 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/macro.rktl b/pkgs/racket-test-core/tests/racket/macro.rktl index b2a3940acf..226e5b7aa8 100644 --- a/pkgs/racket-test-core/tests/racket/macro.rktl +++ b/pkgs/racket-test-core/tests/racket/macro.rktl @@ -1665,6 +1665,38 @@ (test '(1 2 3) dynamic-require ''uses-local-lift-values-at-expansion-time 'l) +;; ---------------------------------------- +;; Check that a `prop:rename-transformer` procedure is called in a +;; `syntax-transforming?` mode when used as an expression + +(let ([x 'one] + [bad 'bad]) + (let-syntax ([also-x (let () + (struct ax () + #:property + prop:rename-transformer + (lambda (an-ax) + (make-will-executor) + (if (syntax-transforming?) + #'x + #'bad))) + (ax))]) + (test 'one values also-x))) + +(let ([x 'two] + [bad 'bad]) + (let-syntax ([also-x (let () + (struct ax () + #:property + prop:rename-transformer + (lambda (an-ax) + (make-will-executor) + (if (syntax-transforming?) + (syntax-property #'x 'not-free-identifier=? #t) + #'bad))) + (ax))]) + (test 'two values also-x))) + ;; ---------------------------------------- (report-errs) diff --git a/pkgs/racket-test-core/tests/racket/stxparam.rktl b/pkgs/racket-test-core/tests/racket/stxparam.rktl index 928eb447c7..b57be3a2ce 100644 --- a/pkgs/racket-test-core/tests/racket/stxparam.rktl +++ b/pkgs/racket-test-core/tests/racket/stxparam.rktl @@ -175,6 +175,36 @@ (with-handlers ([exn:fail? (λ (x) (exn-message x))]) (eval #'(syntax-parameterize ([x (make-rename-transformer #'f)]) 1))))) +;; ---------------------------------------- +;; Check rename-transformer stx-param when used as an expression, +;; which involves calling the `prop:rename-transformer` is a +;; `syntax-transforming?` mode + +(begin + (define-syntax (slv stx) + (syntax-case stx () + [(_ t) + #`'#,(object-name (syntax-local-value #'t))])) + + (define-syntax one (procedure-rename (λ (stx) #'1) 'one)) + (define-syntax two (procedure-rename (λ (stx) #'2) 'two)) + + (define-syntax-parameter normal + (make-rename-transformer #'one)) + (test #f eq? (slv normal) 'one) + (test #t = normal 1) + (syntax-parameterize ([normal (make-rename-transformer #'two)]) + (test #f eq? (slv normal) 'two) + (test #t = normal 2)) + + (define-rename-transformer-parameter rt + (make-rename-transformer #'one)) + (test #t eq? (slv rt) 'one) + (test #t = rt 1) + (syntax-parameterize ([rt (make-rename-transformer #'two)]) + (test #t eq? (slv rt) 'two) + (test #t = rt 2))) + ;; ---------------------------------------- (report-errs) diff --git a/racket/src/racket/src/compile.c b/racket/src/racket/src/compile.c index 3a8487a092..2d9266905a 100644 --- a/racket/src/racket/src/compile.c +++ b/racket/src/racket/src/compile.c @@ -1339,7 +1339,7 @@ set_compile (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec return scheme_compile_expr(form, env, rec, drec); } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { - find_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); + find_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var), env); SCHEME_USE_FUEL(1); menv = NULL; } else @@ -1435,7 +1435,7 @@ set_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info *e return scheme_expand_expr(form, env, erec, drec); } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); + new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var), env); new_name = scheme_stx_track(new_name, find_name, find_name); find_name = new_name; menv = NULL; @@ -3602,7 +3602,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object if (scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(macro))) { /* Rebind to the target identifier's binding */ scheme_add_binding_copy(name, - scheme_rename_transformer_id(SCHEME_PTR_VAL(macro)), + scheme_rename_transformer_id(SCHEME_PTR_VAL(macro), rhs_env), scheme_make_integer(stx_env->genv->phase)); } } @@ -4363,7 +4363,7 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first, if (scheme_is_rename_transformer(SCHEME_PTR_VAL(val))) { /* It's a rename. Look up the target name and try again. */ Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(val)); + new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(val), env); if (!rec[drec].comp) new_name = scheme_stx_track(new_name, name, name); name = scheme_transfer_srcloc(new_name, name); @@ -4570,7 +4570,7 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, scheme_frame_to_expansion_context_symbol(env->flags))) { /* It's a rename. Look up the target name and try again. */ Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); + new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var), env); if (!rec[drec].comp) { new_name = scheme_stx_track(new_name, find_name, find_name); } @@ -4701,7 +4701,7 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, scheme_frame_to_expansion_context_symbol(env->flags))) { /* It's a rename. Look up the target name and try again. */ Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); + new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var), env); if (!rec[drec].comp) { new_name = scheme_stx_track(new_name, find_name, find_name); } @@ -4800,7 +4800,7 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, if (scheme_expansion_contexts_include(SCHEME_PTR_VAL(var), scheme_frame_to_expansion_context_symbol(env->flags))) { Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); + new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var), env); if (!rec[drec].comp) { new_name = scheme_stx_track(new_name, find_name, find_name); } diff --git a/racket/src/racket/src/env.c b/racket/src/racket/src/env.c index e1a766e46e..78df15e9a7 100644 --- a/racket/src/racket/src/env.c +++ b/racket/src/racket/src/env.c @@ -1623,7 +1623,7 @@ void scheme_shadow(Scheme_Env *env, Scheme_Object *n, Scheme_Object *val, int as /* If the binding is a rename transformer, also install a mapping */ if (scheme_is_binding_rename_transformer(val)) - scheme_add_binding_copy(id, scheme_rename_transformer_id(val), scheme_env_phase(env)); + scheme_add_binding_copy(id, scheme_rename_transformer_id(val, NULL), scheme_env_phase(env)); } static void install_one_binding_name(Scheme_Hash_Table *bt, Scheme_Object *name, Scheme_Object *id, Scheme_Env *benv) @@ -2361,7 +2361,7 @@ 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_transfer_srcloc(scheme_rename_transformer_id(v), sym); + sym = scheme_transfer_srcloc(scheme_rename_transformer_id(v, NULL), sym); renamed = 1; menv = NULL; SCHEME_USE_FUEL(1); @@ -2984,7 +2984,7 @@ rename_transformer_target(int argc, Scheme_Object *argv[]) if (!scheme_is_rename_transformer(argv[0])) scheme_wrong_contract("rename-transformer-target", "rename-transformer?", 0, argc, argv); - return scheme_rename_transformer_id(argv[0]); + return scheme_rename_transformer_id(argv[0], NULL); } static Scheme_Object * diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index 1cb69a5a85..7e160f7fb6 100644 --- a/racket/src/racket/src/fun.c +++ b/racket/src/racket/src/fun.c @@ -1924,7 +1924,7 @@ scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv, if (scheme_is_rename_transformer(rator)) { Scheme_Object *scope; - rator = scheme_rename_transformer_id(rator); + rator = scheme_rename_transformer_id(rator, env); /* rator is now an identifier */ /* and it's introduced by this expression: */ diff --git a/racket/src/racket/src/module.c b/racket/src/racket/src/module.c index 21b32d0e04..2b742705b1 100644 --- a/racket/src/racket/src/module.c +++ b/racket/src/racket/src/module.c @@ -6693,7 +6693,7 @@ static void eval_exptime(Scheme_Object *names, int count, if (SCHEME_TRUEP(ids_for_rename_trans) && scheme_is_binding_rename_transformer(values[i])) { scheme_add_binding_copy(SCHEME_CAR(ids_for_rename_trans), - scheme_rename_transformer_id(values[i]), + scheme_rename_transformer_id(values[i], NULL), scheme_make_integer(at_phase-1)); } scheme_add_to_table(syntax, (const char *)name, macro, 0); @@ -6714,7 +6714,7 @@ static void eval_exptime(Scheme_Object *names, int count, if (SCHEME_TRUEP(ids_for_rename_trans) && scheme_is_binding_rename_transformer(vals)) { scheme_add_binding_copy(SCHEME_CAR(ids_for_rename_trans), - scheme_rename_transformer_id(vals), + scheme_rename_transformer_id(vals, NULL), scheme_make_integer(at_phase-1)); } scheme_add_to_table(syntax, (const char *)name, macro, 0); diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index 235696fc0f..9c85ac2b13 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -2149,6 +2149,7 @@ Scheme_Object *scheme_all_current_continuation_marks(void); void scheme_about_to_move_C_stack(void); +Scheme_Object *scheme_apply_with_dynamic_state(Scheme_Object *rator, int num_rands, Scheme_Object **rands, Scheme_Dynamic_State *dyn_state); Scheme_Object *scheme_apply_multi_with_dynamic_state(Scheme_Object *rator, int num_rands, Scheme_Object **rands, Scheme_Dynamic_State *dyn_state); Scheme_Object *scheme_jump_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, @@ -3681,7 +3682,7 @@ Scheme_Object *scheme_make_marshal_shared(Scheme_Object *v); int scheme_is_rename_transformer(Scheme_Object *o); int scheme_is_binding_rename_transformer(Scheme_Object *o); -Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o); +Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o, Scheme_Comp_Env *env); int scheme_is_set_transformer(Scheme_Object *o); Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o); diff --git a/racket/src/racket/src/struct.c b/racket/src/racket/src/struct.c index c6c53fc7b8..681174e2f8 100644 --- a/racket/src/racket/src/struct.c +++ b/racket/src/racket/src/struct.c @@ -1885,7 +1885,7 @@ int scheme_is_rename_transformer(Scheme_Object *o) int scheme_is_binding_rename_transformer(Scheme_Object *o) { if (scheme_is_rename_transformer(o)) { - o = scheme_rename_transformer_id(o); + o = scheme_rename_transformer_id(o, NULL); o = scheme_stx_property(o, not_free_id_symbol, NULL); if (o && SCHEME_TRUEP(o)) return 0; @@ -1898,7 +1898,7 @@ static int is_stx_id(Scheme_Object *o) { return (SCHEME_STXP(o) && SCHEME_SYMBOL static int is_stx_id_or_proc_1(Scheme_Object *o) { return (is_stx_id(o) || is_proc_1(o)); } -Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o) +Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o, Scheme_Comp_Env *comp_env) { Scheme_Object *a[1]; @@ -1911,7 +1911,18 @@ Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o) a[0] = o; /* apply a continuation barrier here to prevent a capture in * the property access */ - v = scheme_apply(v, 1, a); + if (comp_env && (scheme_current_thread->current_local_env != comp_env)) { + /* Getting identifier during an expansion context */ + Scheme_Dynamic_State dyn_state; + Scheme_Env *genv = comp_env->genv; + scheme_set_dynamic_state(&dyn_state, comp_env, NULL, NULL, scheme_false, + genv, (genv->module + ? (genv->link_midx ? genv->link_midx : genv->module->me->src_modidx) + : NULL)); + v = scheme_apply_with_dynamic_state(v, 1, a, &dyn_state); + } else { + v = scheme_apply(v, 1, a); + } if (!is_stx_id(v)) { scheme_contract_error("prop:rename-transformer", "contract violation for given value",