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

macro expander: fix over-eager pruning of use-site scopes

Browse Source 
The bug could cause

 #lang racket/base

 (define x 'outer)

 (define-syntax-rule (def-and-use-m given-x)
    (begin
      (define-syntax-rule (m)
        (let ()
          (define given-x 'inner)
          x))
      (m)))

 (def-and-use-m x)

to produce 'inner when it should produce 'outer.

Thanks to Brian Mastenbrook for pointing the problem and
providing examples.
This commit is contained in:
Matthew Flatt 2015-09-30 06:57:32 -06:00
parent 31549082e6
commit 6e80609998
5 changed files with 124 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1445,6 +1445,114 @@
(eval-syntax #'a)
(eval-syntax (expand-syntax #'b)))])))
;; ----------------------------------------
;; Check that use-site scopes are not pruned too eagerly
;; (based on examples from Brian Mastenbrook)
(module should-be-inner-1 racket/base
(define x 'outer)
(define-syntax-rule (def-m m given-x)
(define-syntax-rule (m d)
(begin
(define given-x 'inner)
(define d x))))
(def-m m x)
(m d)
(provide d))
(test 'inner dynamic-require ''should-be-inner-1 'd)
(module should-be-inner-2 racket/base
(define x 'outer)
(define d
(let ()
(define-syntax-rule (def-m m given-x)
(define-syntax-rule (m)
(begin
(define given-x 'inner)
x)))
(def-m m x)
(m)))
(provide d))
(test 'inner dynamic-require ''should-be-inner-2 'd)
(module should-be-outer-1 racket/base
(define x 'outer)
(define-syntax-rule (def-m m given-x)
(define-syntax-rule (m d)
(define d
(let ()
(define given-x 'inner)
x))))
(def-m m x)
(m d)
(provide d))
(test 'outer dynamic-require ''should-be-outer-1 'd)
(module should-be-outer-2 racket/base
(define x 'outer)
(define-syntax-rule (def-m m given-x)
(define-syntax-rule (m)
(begin
(define given-x 'inner)
x)))
(define d
(let ()
(def-m m x)
(m)))
(provide d))
(test 'outer dynamic-require ''should-be-outer-2 'd)
(module should-be-outer-3 racket/base
(define x 'outer)
(define-syntax-rule (def-m m given-x)
(define-syntax-rule (m)
(begin
(define given-x 'inner)
x)))
(def-m m x)
(define d
(let ()
(m)))
(provide d))
(test 'outer dynamic-require ''should-be-outer-3 'd)
(module should-be-outer-4 racket/base
(define x 'outer)
(define d
(let ()
(define-syntax-rule (def-m m given-x)
(define-syntax-rule (m)
(begin
(define given-x 'inner)
x)))
(def-m m x)
(let ()
(m))))
(provide d))
(test 'outer dynamic-require ''should-be-outer-4 'd)
;; ----------------------------------------
(report-errs)

1
pkgs/racket-test-core/tests/racket/stx.rktl
View File

@ -1408,6 +1408,7 @@
(eval '(require 'mm))
(eval '(current-namespace (module->namespace ''mm)))
(test '(1 2) eval '(list a b))
(eval '(define$ c 7))
(test '(1 2 7) eval '(list a b c))
(eval '(define$ d 8))

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

@ -3407,17 +3407,9 @@ quote_syntax_syntax(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Compi
/* Remove scopes for all enclosing local binding contexts. */
for (frame = env; frame; frame = frame->next) {
if (frame->flags & (SCHEME_TOPLEVEL_FRAME | SCHEME_MODULE_FRAME | SCHEME_MODULE_BEGIN_FRAME))
stx = scheme_stx_adjust_module_use_site_context(stx,
env->genv->stx_context,
SCHEME_STX_REMOVE);
else if (frame->scopes) {
if (frame->flags & SCHEME_KEEP_SCOPES_FRAME)
stx = scheme_stx_adjust_frame_use_site_scopes(stx, frame->scopes,
scheme_env_phase(frame->genv), SCHEME_STX_REMOVE);
else
stx = scheme_stx_adjust_frame_scopes(stx, frame->scopes,
scheme_env_phase(frame->genv), SCHEME_STX_REMOVE);
if ((frame->scopes) && !(frame->flags & SCHEME_KEEP_SCOPES_FRAME)) {
stx = scheme_stx_adjust_frame_scopes(stx, frame->scopes,
scheme_env_phase(frame->genv), SCHEME_STX_REMOVE);
}
}
@ -3482,8 +3474,6 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env,
scheme_define_parse(form, &names, &code, 1, env, 0);
code = scheme_revert_use_site_scopes(code, env);
scheme_prepare_exp_env(env->genv);
scheme_prepare_compile_env(env->genv->exp_env);
@ -3532,8 +3522,6 @@ define_syntaxes_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Ex
scheme_define_parse(form, &names, &code, 1, env, 0);
code = scheme_revert_use_site_scopes(code, env);
SCHEME_EXPAND_OBSERVE_PREPARE_ENV(env->observer);
scheme_prepare_exp_env(env->genv);
@ -6099,8 +6087,6 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
"extra data after expression");
}
expr = SCHEME_STX_CAR(expr);
if (!is_val)
expr = scheme_revert_use_site_scopes(expr, env);
scheme_add_local_syntax(cnt, new_env);

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

@ -9009,8 +9009,6 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
int for_stx;
int max_let_depth;
e = revert_use_site_scopes_via_context(e, rn_set, phase);
for_stx = scheme_stx_free_eq_x(scheme_begin_for_syntax_stx, fst, phase);
SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
@ -9039,7 +9037,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
eenv = scheme_new_comp_env(env->genv->exp_env, env->insp,
frame_scopes,
0);
SCHEME_KEEP_SCOPES_FRAME);
if (!for_stx)
scheme_frame_captures_lifts(eenv, NULL, NULL, scheme_false, scheme_false,
req_data, scheme_false, scheme_false);
@ -9207,7 +9205,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
m = SCHEME_STX_CDR(e);
m = SCHEME_STX_CAR(m);
m = scheme_make_pair(fst,
scheme_make_pair(m, scheme_make_pair(code, scheme_null)));
scheme_make_pair(orig_names, scheme_make_pair(code, scheme_null)));
}
e = scheme_datum_to_syntax(m, e, e, 0, 2);
} else

21
racket/src/racket/src/syntax.c
View File

@ -4118,7 +4118,7 @@ Scheme_Object *scheme_make_module_context(Scheme_Object *insp,
Scheme_Object *shift_or_shifts,
Scheme_Object *debug_name)
{
Scheme_Object *vec;
Scheme_Object *vec, *bx;
Scheme_Object *body_scopes;
Scheme_Object *intro_multi_scope;
@ -4161,7 +4161,8 @@ Scheme_Object *scheme_make_module_context(Scheme_Object *insp,
SCHEME_VEC_ELS(vec)[2] = insp;
SCHEME_VEC_ELS(vec)[3] = shift_or_shifts;
SCHEME_VEC_ELS(vec)[4] = intro_multi_scope;
SCHEME_VEC_ELS(vec)[5] = (Scheme_Object *)empty_scope_set;
bx = scheme_box((Scheme_Object *)empty_scope_set);
SCHEME_VEC_ELS(vec)[5] = bx;
return vec;
}
@ -4202,20 +4203,20 @@ Scheme_Object *scheme_module_context_frame_scopes(Scheme_Object *mc, Scheme_Obje
void scheme_module_context_add_use_site_scope(Scheme_Object *mc, Scheme_Object *use_site_scope)
{
Scheme_Scope_Set *use_site_scopes = (Scheme_Scope_Set *)SCHEME_VEC_ELS(mc)[5];
Scheme_Scope_Set *use_site_scopes = (Scheme_Scope_Set *)SCHEME_BOX_VAL(SCHEME_VEC_ELS(mc)[5]);
STX_ASSERT(SCHEME_SCOPEP(use_site_scope));
use_site_scopes = scope_set_set(use_site_scopes, use_site_scope, scheme_true);
SCHEME_VEC_ELS(mc)[5] = (Scheme_Object *)use_site_scopes;
SCHEME_BOX_VAL(SCHEME_VEC_ELS(mc)[5]) = (Scheme_Object *)use_site_scopes;
}
Scheme_Object *scheme_module_context_use_site_frame_scopes(Scheme_Object *mc)
{
Scheme_Scope_Set *use_site_scopes;
use_site_scopes = (Scheme_Scope_Set *)SCHEME_VEC_ELS(mc)[5];
use_site_scopes = (Scheme_Scope_Set *)SCHEME_BOX_VAL(SCHEME_VEC_ELS(mc)[5]);
if (SAME_OBJ(use_site_scopes, empty_scope_set))
return NULL;
else
@ -4247,10 +4248,7 @@ Scheme_Object *scheme_module_context_at_phase(Scheme_Object *mc, Scheme_Object *
SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(mc)[2];
SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(mc)[3];
SCHEME_VEC_ELS(vec)[4] = SCHEME_VEC_ELS(mc)[4];
/* Any use-site scope from the from another phase don't apply here. This
set only matters for module contexts that are attached to environments,
anyway: */
SCHEME_VEC_ELS(vec)[5] = (Scheme_Object *)empty_scope_set;
SCHEME_VEC_ELS(vec)[5] = SCHEME_VEC_ELS(mc)[5];
return vec;
}
@ -4332,7 +4330,7 @@ Scheme_Object *scheme_stx_unintroduce_from_module_context(Scheme_Object *stx, Sc
Scheme_Object *scheme_stx_adjust_module_use_site_context(Scheme_Object *stx, Scheme_Object *mc, int mode)
{
Scheme_Scope_Set *scopes = (Scheme_Scope_Set *)SCHEME_VEC_ELS(mc)[5];
Scheme_Scope_Set *scopes = (Scheme_Scope_Set *)SCHEME_BOX_VAL(SCHEME_VEC_ELS(mc)[5]);
return scheme_stx_adjust_scopes(stx, scopes, SCHEME_VEC_ELS(mc)[1], mode);
}
@ -4706,7 +4704,8 @@ Scheme_Object *scheme_stx_to_module_context(Scheme_Object *_stx)
SCHEME_VEC_ELS(vec)[2] = scheme_false; /* not sure this is right */
SCHEME_VEC_ELS(vec)[3] = shifts;
SCHEME_VEC_ELS(vec)[4] = intro_multi_scope;
SCHEME_VEC_ELS(vec)[5] = (Scheme_Object *)empty_scope_set;
a = scheme_box((Scheme_Object *)empty_scope_set);
SCHEME_VEC_ELS(vec)[5] = a;
return vec;
}