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

fix expansion loop in a definition context

Browse Source 
Add the current definition context's scope to any expression that is
produced by macro expansion before trying to expand again, in case the
expansion needs to refer to a definition introduced by a previous
expansion.

Previously, the scope was added before any expansion and after any
expansion, but that misses intermediate points.

The old expander had this bug, too (some of the new tests fail there),
but it showed up less often and was sometimes considered correct, for
various reasons.
This commit is contained in:
Matthew Flatt 2015-07-20 10:57:45 -06:00
parent a6fe7b3f40
commit 3d87d61039
8 changed files with 165 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1171,6 +1171,93 @@
((mylam (x) (x 1 2)) 'any))))))
;; ----------------------------------------
;; Make sure an internal-definition context expansion
;; propagates the context's scope while expanding an expression:
;; (Test from Spencer Florence)
(module check-intfdef-expansion-scope racket/base
(require (for-syntax syntax/parse
racket/base))
;; a standard context for identifiers
(define-for-syntax ctx #'ctx)
;; create an ID with the context `ctx`, and the current
;; expander mark (so that the mark is canceled later),
;; and the location loc
(define-for-syntax (make-id loc)
(syntax-local-introduce
(datum->syntax ctx 'id loc)))
;; This introduces a binding
(define-syntax (def stx)
(syntax-parse stx
[(def)
(with-syntax ([id (make-id #'here)])
#'(define id 5))]))
;; this attempts to use the binding introduced by `def`
(define-syntax (use stx)
(syntax-parse stx
[(use)
(with-syntax ([id (make-id #'here)])
#'id)]))
(let ()
(def)
(use)))
;; ----------------------------------------
;; Similar to preceding, but at module level using an initialy
;; empty scope set:
(module check-module-recur-expansion-scope racket/kernel
(#%require racket/base)
(require (for-syntax racket/base
syntax/parse))
;; empty context:
(define-for-syntax ctx (datum->syntax #f 'ctx))
(define-for-syntax (make-id loc)
(syntax-local-introduce
(datum->syntax ctx 'id loc)))
(define-syntax (def stx)
(syntax-parse stx
[(def)
(with-syntax ([id (make-id #'here)])
#'(define-syntax-rule (id) (define x 1)))]))
(define-syntax (use stx)
(syntax-parse stx
[(use)
(with-syntax ([id (make-id #'here)])
#'(id))]))
(begin
(def)
(use)))
;; Module body is expanded with `local-expand`:
(module check-module-local-expand-recur-expansion-scope racket/base
(require (for-syntax racket/base
syntax/parse))
;; empty context:
(define-for-syntax ctx (datum->syntax #f 'ctx))
(define-for-syntax (make-id loc)
(syntax-local-introduce
(datum->syntax ctx 'id loc)))
(define-syntax (def stx)
(syntax-parse stx
[(def)
(with-syntax ([id (make-id #'here)])
#'(define-syntax-rule (id) (define x 1)))]))
(define-syntax (use stx)
(syntax-parse stx
[(use)
(with-syntax ([id (make-id #'here)])
#'(id))]))
(begin
(def)
(use)))
;; ----------------------------------------
(report-errs)

20
pkgs/racket-test/tests/units/test-unit.rkt
View File

@ -1811,6 +1811,26 @@
(define-values/invoke-unit u@ (import) (export s^))
x))
;; ----------------------------------------
;; May sure unit body expansion doesn't mangle context:
(test 5
(invoke-unit
(let ([x 5])
(define-syntax-rule (m) x)
(unit (import) (export)
(define x 6)
(m)))))
(test 5
(invoke-unit
(let-syntax ([x (syntax-rules ()
[(_) 5])])
(define-syntax-rule (m) (x))
(unit (import) (export)
(define (x) 6)
(m)))))
;; ----------------------------------------
;; Make sure that right-hand side of a `define-values`

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

@ -4964,6 +4964,12 @@ compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
form = compile_expand_macro_app(name, menv, var, form, env, rec, drec, need_macro_scope);
SCHEME_EXPAND_OBSERVE_EXIT_MACRO(rec[drec].observer, form);
if (env->expand_result_adjust) {
Scheme_Expand_Result_Adjust_Proc adjust;
adjust = env->expand_result_adjust;
form = adjust(form, env->expand_result_adjust_arg);
}
if (rec[drec].comp)
goto top;
else {
@ -5640,6 +5646,11 @@ static Scheme_Object *beginify(Scheme_Comp_Env *env, Scheme_Object *lst)
0, 0);
}
static Scheme_Object *add_scope_at_arbitrary_phase(Scheme_Object *stx, Scheme_Object *rib)
{
return scheme_stx_add_scope(stx, rib, scheme_make_integer(0));
}
static Scheme_Object *
compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
Scheme_Compile_Expand_Info *rec, int drec,
@ -5685,10 +5696,13 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
env);
env->intdef_name = ectx;
env->expand_result_adjust = add_scope_at_arbitrary_phase;
env->expand_result_adjust_arg = rib;
forms = scheme_datum_to_syntax(forms, scheme_false, scheme_false, 0, 0);
old = forms;
forms = scheme_stx_add_scope(forms, rib, scheme_env_phase(env->genv));
forms = add_scope_at_arbitrary_phase(forms, rib);
SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(rec[drec].observer, forms, old);
try_again:
@ -5709,16 +5723,10 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
is_last = SCHEME_STX_NULLP(SCHEME_STX_CDR(forms));
result = forms;
old = first;
/* Check for macro expansion, which could mask the real
define-values, define-syntax, etc.: */
first = scheme_check_immediate_macro(first, env, rec, drec, &gval, is_last);
if (!SAME_OBJ(first, old)) {
old = first;
first = scheme_stx_add_scope(first, rib, scheme_env_phase(env->genv));
}
if (SAME_OBJ(gval, scheme_begin_syntax)) {
/* Inline content */
@ -5925,6 +5933,8 @@ compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
/* Remember extended environment */
env = scheme_new_compilation_frame(0, SCHEME_INTDEF_FRAME, frame_scopes, new_env);
env->intdef_name = ectx;
env->expand_result_adjust = add_scope_at_arbitrary_phase;
env->expand_result_adjust_arg = rib;
}
define_try_again:

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

@ -3972,7 +3972,7 @@ static void *compile_k(void)
Resolve_Prefix *rp;
Resolve_Info *ri;
Optimize_Info *oi;
Scheme_Object *gval, *insp;
Scheme_Object *gval, *insp, *rib;
Scheme_Comp_Env *cenv;
form = (Scheme_Object *)p->ku.k.p1;
@ -3992,7 +3992,9 @@ static void *compile_k(void)
/* Renamings for requires: */
if (rename) {
form = scheme_top_introduce(form, genv);
}
rib = genv->stx_context;
} else
rib = NULL;
tl_queue = scheme_null;
@ -4036,6 +4038,11 @@ static void *compile_k(void)
SCHEME_TOPLEVEL_FRAME
| SCHEME_KEEP_SCOPES_FRAME);
if (rib) {
cenv->expand_result_adjust = scheme_stx_push_introduce_module_context;
cenv->expand_result_adjust_arg = rib;
}
if (for_eval) {
/* Need to look for top-level `begin', and if we
find one, break it up to eval first expression
@ -4833,9 +4840,9 @@ scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_ids, Scheme_O
return scheme_datum_to_syntax(l, scheme_false, scheme_false, 0, 0);
}
static Scheme_Object *add_intdef_renamings(Scheme_Object *l, Scheme_Object *renaming, Scheme_Object *phase)
static Scheme_Object *add_intdef_renamings(Scheme_Object *l, Scheme_Object *renaming)
{
Scheme_Object *rl = renaming;
Scheme_Object *rl = renaming, *phase = scheme_make_integer(0);
if (SCHEME_PAIRP(renaming)) {
while (!SCHEME_NULLP(rl)) {
@ -4877,7 +4884,7 @@ static void update_intdef_chain(Scheme_Object *intdef)
static Scheme_Object *
do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, int argc, Scheme_Object **argv)
{
Scheme_Comp_Env *env, *orig_env, **ip;
Scheme_Comp_Env *env, *orig_env, *adjust_env = NULL, **ip;
Scheme_Object *l, *local_scope, *renaming = NULL, *orig_l, *exp_expr = NULL;
int cnt, pos, kind, is_modstar;
int bad_sub_env = 0, bad_intdef = 0, keep_ref_ids = 0;
@ -4900,9 +4907,10 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
if (for_expr)
kind = 0; /* expression */
else if (!for_stx && SAME_OBJ(argv[1], module_symbol))
else if (!for_stx && SAME_OBJ(argv[1], module_symbol)) {
kind = SCHEME_MODULE_FRAME | SCHEME_USE_SCOPES_TO_NEXT; /* module body */
else if (!for_stx && SAME_OBJ(argv[1], module_begin_symbol))
adjust_env = orig_env;
} else if (!for_stx && SAME_OBJ(argv[1], module_begin_symbol))
kind = SCHEME_MODULE_BEGIN_FRAME; /* just inside module for expanding to `#%module-begin` */
else if (SAME_OBJ(argv[1], top_level_symbol)) {
kind = SCHEME_TOPLEVEL_FRAME;
@ -4988,6 +4996,12 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
| kind),
NULL,
env);
if (adjust_env && adjust_env->expand_result_adjust) {
env->expand_result_adjust = adjust_env->expand_result_adjust;
env->expand_result_adjust_arg = adjust_env->expand_result_adjust_arg;
}
if (catch_lifts < 0) {
/* Note: extra frames can get inserted after env by pair_lifted */
ip = MALLOC_N(Scheme_Comp_Env *, 1);
@ -5090,8 +5104,11 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
l = scheme_stx_flip_scope(l, local_scope, scheme_env_phase(env->genv));
}
if (renaming)
l = add_intdef_renamings(l, renaming, scheme_env_phase(env->genv));
if (renaming) {
l = add_intdef_renamings(l, renaming);
env->expand_result_adjust = add_intdef_renamings;
env->expand_result_adjust_arg = renaming;
}
SCHEME_EXPAND_OBSERVE_LOCAL_PRE(observer, l);
@ -5148,7 +5165,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, l);
if (renaming)
l = add_intdef_renamings(l, renaming, scheme_env_phase(env->genv));
l = add_intdef_renamings(l, renaming);
if (for_expr) {
/* Package up expanded expr with the environment. */

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

@ -8682,6 +8682,9 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_
rn_set = env->genv->stx_context;
xenv->expand_result_adjust = introduce_to_module_context;
xenv->expand_result_adjust_arg = rn_set;
vec = get_table(bxs->tables, scheme_make_integer(phase));
if (SCHEME_FALSEP(SCHEME_VEC_ELS(vec)[0]))
SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->genv->toplevel;

4
racket/src/racket/src/mzmark_compenv.inc
View File

@ -25,6 +25,8 @@ static int mark_comp_env_MARK(void *p, struct NewGC *gc) {
gcMARK2(e->use, gc);
gcMARK2(e->lifts, gc);
gcMARK2(e->expand_result_adjust_arg, gc);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Comp_Env));
}
@ -49,6 +51,8 @@ static int mark_comp_env_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(e->use, gc);
gcFIXUP2(e->lifts, gc);
gcFIXUP2(e->expand_result_adjust_arg, gc);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Comp_Env));
}

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

@ -1269,6 +1269,8 @@ mark_comp_env {
gcMARK2(e->use, gc);
gcMARK2(e->lifts, gc);
gcMARK2(e->expand_result_adjust_arg, gc);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Comp_Env));
}

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

@ -2547,6 +2547,8 @@ typedef struct Comp_Prefix
Scheme_Hash_Table *stxes; /* syntax objects */
} Comp_Prefix;
typedef Scheme_Object *(*Scheme_Expand_Result_Adjust_Proc)(Scheme_Object *stx, Scheme_Object *arg);
typedef struct Scheme_Comp_Env
{
MZTAG_IF_REQUIRED
@ -2579,6 +2581,9 @@ typedef struct Scheme_Comp_Env
Scheme_Hash_Tree *skip_table; /* for jumping ahead in the chain */
int skip_depth; /* depth in simple frames, used to trigger skip_table creation */
Scheme_Expand_Result_Adjust_Proc expand_result_adjust;
Scheme_Object *expand_result_adjust_arg;
struct Scheme_Comp_Env *next;
} Scheme_Comp_Env;