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

fix missing expansion context for prop:rename-transformer proc

Browse Source 
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
This commit is contained in:
Matthew Flatt 2016-10-07 08:25:31 -06:00
parent d9750064b9
commit a1a2d9c2c7
8 changed files with 91 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
pkgs/racket-test-core/tests/racket/macro.rktl
View File

@ -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)

30
pkgs/racket-test-core/tests/racket/stxparam.rktl
View File

@ -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)

14
racket/src/racket/src/compile.c
View File

@ -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);
}

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

@ -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 *

2
racket/src/racket/src/fun.c
View File

@ -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: */

4
racket/src/racket/src/module.c
View File

@ -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);

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

@ -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);

17
racket/src/racket/src/struct.c
View File

@ -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",