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

allow phase 1+ references to not-yet-defined bindings

Browse Source 
For example,

 (define-for-syntax (f x) (g x))
 (define-for-syntax (g y) y)

is now allowed. The unbound-variable check for phase 1
and up is delayed until after the module body is partially expanded.
This commit is contained in:
Matthew Flatt 2011-08-28 10:23:16 -06:00
parent b628ae8424
commit 4f83f7f279
10 changed files with 205 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/scribblings/reference/syntax.scrbl
View File

@ -1314,10 +1314,18 @@ x
@defform[(#%top . id)]{
Refers to a top-level definition that could bind @racket[id], even if
@racket[id] has a local binding in its context. Such references are
disallowed anywhere within a @racket[module] form. See also
@secref["expand-steps"] for information on how the expander
Refers to a module-level or top-level definition that could bind
@racket[id], even if @racket[id] has a local binding in its context.
Within a @racket[module] form, @racket[(#%top . id)] expands to just
@racket[id]---with the obligation that @racket[id] is defined within
the module. At @tech{phase level} 0, @racket[(#%top . id)] is an
immediate syntax error if @racket[id] is not bound. At @tech{phase
level} 1 and higher, a syntax error is reported if @racket[id] is not
defined at the corresponding phase by the end of @racket[module]-body
@tech{partial expansion}.
See also @secref["expand-steps"] for information on how the expander
introduces @racketidfont{#%top} identifiers.
@examples[

23
collects/tests/racket/stx.rktl
View File

@ -1558,6 +1558,29 @@
(syntax-test #'(evil-via-shadower (m)))
(syntax-test #'(evil-via-delta-introducer (m)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that a for-syntax reference can precede a
;; for-syntax definition
(module pre-definition-reference racket/base
(require (for-syntax racket/base))
(provide (for-syntax f g))
(define-for-syntax (f x) (g (+ x 1)))
(define-for-syntax (g y) (+ y 2)))
(require 'pre-definition-reference)
(test 3 'use (let-syntax ([m (lambda (stx) (datum->syntax stx (f 0)))])
m))
(syntax-test #'(module unbound-reference racket/base
(require (for-syntax racket/base))
(define-for-syntax (f x) nonesuch)))
(syntax-test #'(module unbound-reference racket/base
(require (for-syntax racket/base))
(#%expression
(let-syntax ([g (lambda (stx) nonesuch)])
10))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

23
src/racket/src/compenv.c
View File

@ -637,6 +637,25 @@ Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Com
return o;
}
void scheme_register_unbound_toplevel(Scheme_Comp_Env *env, Scheme_Object *id)
{
Comp_Prefix *cp = env->prefix;
if (!cp->unbound) cp->unbound = scheme_null;
id = scheme_make_pair(id, cp->unbound);
cp->unbound = id;
}
void scheme_merge_undefineds(Scheme_Comp_Env *exp_env, Scheme_Comp_Env *env)
{
if (exp_env->prefix->unbound) {
/* adding a list to env->prefix->unbound indicates a
phase-1 shift for the identifiers in the list: */
scheme_register_unbound_toplevel(env, exp_env->prefix->unbound);
}
}
Scheme_Object *scheme_toplevel_to_flagged_toplevel(Scheme_Object *_tl, int flags)
{
Scheme_Toplevel *tl = (Scheme_Toplevel *)_tl;
@ -1840,7 +1859,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
genv = env->genv;
modname = NULL;
if (genv->module && genv->disallow_unbound) {
if (genv->module && (genv->disallow_unbound > 0)) {
/* Free identifier. Maybe don't continue. */
if (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) {
scheme_wrong_syntax(((flags & SCHEME_SETTING)
@ -1906,7 +1925,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
}
if (!modname && (flags & (SCHEME_SETTING | SCHEME_REFERENCING))
&& (genv->module && genv->disallow_unbound)) {
&& (genv->module && (genv->disallow_unbound > 0))) {
/* Check for set! of unbound identifier: */
if (!scheme_lookup_in_table(genv->toplevel, (const char *)find_global_id)) {
scheme_wrong_syntax(((flags & SCHEME_SETTING)

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

@ -3280,6 +3280,8 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env,
vec->type = (for_stx ? scheme_define_for_syntax_type : scheme_define_syntaxes_type);
scheme_merge_undefineds(exp_env, env);
return vec;
}
@ -3545,6 +3547,8 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
}
*_pos = i;
scheme_merge_undefineds(eenv, rhs_env);
SCHEME_EXPAND_OBSERVE_EXIT_BIND(rec[drec].observer);
}
@ -5049,7 +5053,58 @@ datum_expand(Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Expand_Info
0, 2);
}
static Scheme_Object *check_top(const char *when, Scheme_Object *orig_form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
int scheme_check_top_identifier_bound(Scheme_Object *c, Scheme_Env *genv, int disallow_unbound)
{
Scheme_Object *symbol = c;
Scheme_Object *modidx, *tl_id;
int bad;
tl_id = scheme_tl_id_sym(genv, symbol, NULL, 0, NULL, NULL);
if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) {
/* Since the module has a rename for this id, it's certainly defined. */
bad = 0;
} else {
modidx = scheme_stx_module_name(NULL, &symbol, scheme_make_integer(genv->phase), NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL);
if (modidx) {
/* If it's an access path, resolve it: */
if (genv->module
&& SAME_OBJ(scheme_module_resolve(modidx, 1), genv->module->modname))
bad = 0;
else
bad = 1;
} else
bad = 1;
if (disallow_unbound) {
if (bad || !scheme_lookup_in_table(genv->toplevel, (const char *)SCHEME_STX_SYM(c))) {
GC_CAN_IGNORE const char *reason;
if (genv->phase == 1) {
reason = "unbound identifier in module (in phase 1, transformer environment)";
/* Check in the run-time environment */
if (scheme_lookup_in_table(genv->template_env->toplevel, (const char *)SCHEME_STX_SYM(c))) {
reason = ("unbound identifier in module (in the transformer environment, which does"
" not include the run-time definition)");
} else if (genv->template_env->syntax
&& scheme_lookup_in_table(genv->template_env->syntax, (const char *)SCHEME_STX_SYM(c))) {
reason = ("unbound identifier in module (in the transformer environment, which does"
" not include the macro definition that is visible to run-time expressions)");
}
} else if (genv->phase == 0)
reason = "unbound identifier in module";
else
reason = "unbound identifier in module (in phase %d)";
scheme_wrong_syntax(scheme_expand_stx_string, NULL, c, reason, genv->phase);
}
}
}
return !bad;
}
static Scheme_Object *check_top(Scheme_Object *orig_form,
Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec,
int *_need_bound_check)
{
Scheme_Object *c, *form;
@ -5065,47 +5120,10 @@ static Scheme_Object *check_top(const char *when, Scheme_Object *orig_form, Sche
scheme_wrong_syntax(NULL, NULL, form, NULL);
if (env->genv->module) {
Scheme_Object *modidx, *symbol = c, *tl_id;
int bad;
tl_id = scheme_tl_id_sym(env->genv, symbol, NULL, 0, NULL, NULL);
if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) {
/* Since the module has a rename for this id, it's certainly defined. */
} else {
modidx = scheme_stx_module_name(NULL, &symbol, scheme_make_integer(env->genv->phase), NULL, NULL, NULL,
NULL, NULL, NULL, NULL, NULL);
if (modidx) {
/* If it's an access path, resolve it: */
if (env->genv->module
&& SAME_OBJ(scheme_module_resolve(modidx, 1), env->genv->module->modname))
bad = 0;
else
bad = 1;
} else
bad = 1;
if (env->genv->disallow_unbound) {
if (bad || !scheme_lookup_in_table(env->genv->toplevel, (const char *)SCHEME_STX_SYM(c))) {
GC_CAN_IGNORE const char *reason;
if (env->genv->phase == 1) {
reason = "unbound identifier in module (in phase 1, transformer environment)";
/* Check in the run-time environment */
if (scheme_lookup_in_table(env->genv->template_env->toplevel, (const char *)SCHEME_STX_SYM(c))) {
reason = ("unbound identifier in module (in the transformer environment, which does"
" not include the run-time definition)");
} else if (env->genv->template_env->syntax
&& scheme_lookup_in_table(env->genv->template_env->syntax, (const char *)SCHEME_STX_SYM(c))) {
reason = ("unbound identifier in module (in the transformer environment, which does"
" not include the macro definition that is visible to run-time expressions)");
}
} else if (env->genv->phase == 0)
reason = "unbound identifier in module";
else
reason = "unbound identifier in module (in phase %d)";
scheme_wrong_syntax(when, NULL, c, reason, env->genv->phase);
}
}
}
bad = !scheme_check_top_identifier_bound(c, env->genv, env->genv->disallow_unbound > 0);
if (_need_bound_check)
*_need_bound_check = bad;
}
return c;
@ -5115,8 +5133,12 @@ static Scheme_Object *
top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
{
Scheme_Object *c;
int need_bound_check = 0;
c = check_top(scheme_compile_stx_string, form, env, rec, drec);
c = check_top(form, env, rec, drec, &need_bound_check);
if (need_bound_check)
scheme_register_unbound_toplevel(env, c);
c = scheme_tl_id_sym(env->genv, c, NULL, 0, NULL, NULL);
@ -5137,8 +5159,15 @@ top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
static Scheme_Object *
top_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
{
Scheme_Object *c;
int need_bound_check = 0;
SCHEME_EXPAND_OBSERVE_PRIM_TOP(erec[drec].observer);
check_top(scheme_expand_stx_string, form, env, erec, drec);
c = check_top(form, env, erec, drec, &need_bound_check);
if (need_bound_check)
return c; /* strip `#%top' prefix */
return form;
}

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

@ -892,7 +892,7 @@ void scheme_prepare_exp_env(Scheme_Env *env)
eenv->rename_set = env->rename_set;
if (env->disallow_unbound)
eenv->disallow_unbound = 1;
eenv->disallow_unbound = env->disallow_unbound;
}
}
@ -932,7 +932,7 @@ void scheme_prepare_template_env(Scheme_Env *env)
eenv->label_env = env->label_env;
if (env->disallow_unbound)
eenv->disallow_unbound = 1;
eenv->disallow_unbound = env->disallow_unbound;
}
}

16
src/racket/src/error.c
View File

@ -1973,16 +1973,23 @@ void scheme_unbound_global(Scheme_Bucket *b)
if (home && home->module) {
const char *errmsg;
char *phase, phase_buf[20];
char *phase, phase_buf[20], *phase_note = "";
if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC)))
errmsg = "reference to an identifier before its definition: %S in module: %D%s";
errmsg = "reference to an identifier before its definition: %S in module: %D%s%s";
else
errmsg = "reference to an identifier before its definition: %S%_%s";
errmsg = "reference to an identifier before its definition: %S%_%s%s";
if (home->phase) {
sprintf(phase_buf, " phase: %" PRIdPTR "", home->phase);
phase = phase_buf;
if ((home->phase == 1) && (home->template_env)) {
if (scheme_lookup_in_table(home->template_env->toplevel, (const char *)name))
phase_note = " (which cannot access the run-time definition)";
else if (home->template_env->syntax
&& scheme_lookup_in_table(home->template_env->syntax, (const char *)name))
phase_note = " (which cannot access the syntax binding for run-time expressions)";
}
} else
phase = "";
@ -1991,7 +1998,8 @@ void scheme_unbound_global(Scheme_Bucket *b)
errmsg,
name,
home->module->modsrc,
phase);
phase,
phase_note);
} else {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE,
name,

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

@ -5590,6 +5590,12 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env,
}
scheme_prepare_exp_env(menv);
/* Allow phase-1 references to unbound identifiers; we check
at the end of body expansion to make sure that all referenced
identifiers were eventually bound. Meanwhile,
reference-before-definition errors are possible. */
menv->exp_env->disallow_unbound = -1;
/* For each provide in iim, add a module rename to fm */
saw_mb = add_simple_require_renames(NULL, rn_set, NULL, iim, iidx, scheme_make_integer(0), NULL, 1);
@ -6080,7 +6086,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env
Scheme_Object *lift_data;
Scheme_Object **exis, **et_exis, **exsis;
Scheme_Object *lift_ctx;
Scheme_Object *lifted_reqs = scheme_null, *req_data;
Scheme_Object *lifted_reqs = scheme_null, *req_data, *unbounds = scheme_null;
int exicount, et_exicount, exsicount;
char *exps, *et_exps;
int *all_simple_renames;
@ -6531,11 +6537,14 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env
SCHEME_VEC_ELS(vec)[4] = (for_stx ? scheme_true : scheme_false);
exp_body = scheme_make_pair(vec, exp_body);
if (eenv->prefix->unbound)
unbounds = scheme_make_pair(eenv->prefix->unbound, unbounds);
m = scheme_sfs(m, NULL, max_let_depth);
if (scheme_resolve_info_use_jit(ri))
m = scheme_jit_expr(m);
rp = scheme_prefix_eval_clone(rp);
eval_exptime(names, count, m, eenv->genv, rhs_env, rp, max_let_depth, 0,
(for_stx ? env->genv->exp_env->toplevel : env->genv->syntax), for_stx,
for_stx ? scheme_false : (use_post_ex ? post_ex_rn : rn),
@ -6615,6 +6624,50 @@ static Scheme_Object *do_module_begin(Scheme_Object *orig_form, Scheme_Comp_Env
}
scheme_seal_module_rename_set(post_ex_rn_set, STX_SEAL_BOUND);
/* Check that all bindings used in phase-N expressions (for N >= 1)
were defined by now: */
while (!SCHEME_NULLP(unbounds)) {
Scheme_Object *stack = scheme_null, *lst;
Scheme_Env *uenv = env->genv->exp_env;
lst = SCHEME_CAR(unbounds);
while(1) {
while (!SCHEME_NULLP(lst)) {
p = SCHEME_CAR(lst);
if (SCHEME_PAIRP(p)) {
if (!uenv->exp_env)
scheme_signal_error("internal error: no such environment to check unbounds");
else {
/* switch to nested list, push current list onto stack: */
stack = scheme_make_pair(scheme_make_pair(SCHEME_CDR(lst), (Scheme_Object *)uenv),
stack);
uenv = uenv->exp_env;
lst = SCHEME_CAR(lst);
}
} else {
(void)scheme_check_top_identifier_bound(p, uenv, 1);
lst = SCHEME_CDR(lst);
}
}
if (!SCHEME_NULLP(stack)) {
lst = SCHEME_CAR(stack);
stack = SCHEME_CDR(stack);
uenv = (Scheme_Env *)SCHEME_CDR(lst);
lst = SCHEME_CAR(lst);
} else
break;
}
unbounds = SCHEME_CDR(unbounds);
}
/* Disallow unbound variables from now on: */
{
Scheme_Env *uenv = env->genv->exp_env;
while (uenv) {
uenv->disallow_unbound = 1;
uenv = uenv->exp_env;
}
}
/* Pass 2 */
SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer);

2
src/racket/src/mzmark_type.inc
View File

@ -2381,6 +2381,7 @@ static int comp_prefix_val_SIZE(void *p, struct NewGC *gc) {
static int comp_prefix_val_MARK(void *p, struct NewGC *gc) {
Comp_Prefix *cp = (Comp_Prefix *)p;
gcMARK2(cp->toplevels, gc);
gcMARK2(cp->unbound, gc);
gcMARK2(cp->stxes, gc);
gcMARK2(cp->uses_unsafe, gc);
@ -2391,6 +2392,7 @@ static int comp_prefix_val_MARK(void *p, struct NewGC *gc) {
static int comp_prefix_val_FIXUP(void *p, struct NewGC *gc) {
Comp_Prefix *cp = (Comp_Prefix *)p;
gcFIXUP2(cp->toplevels, gc);
gcFIXUP2(cp->unbound, gc);
gcFIXUP2(cp->stxes, gc);
gcFIXUP2(cp->uses_unsafe, gc);

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

@ -954,6 +954,7 @@ comp_prefix_val {
mark:
Comp_Prefix *cp = (Comp_Prefix *)p;
gcMARK2(cp->toplevels, gc);
gcMARK2(cp->unbound, gc);
gcMARK2(cp->stxes, gc);
gcMARK2(cp->uses_unsafe, gc);

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

@ -2143,6 +2143,7 @@ typedef struct Comp_Prefix
MZTAG_IF_REQUIRED
int num_toplevels, num_stxes;
Scheme_Hash_Table *toplevels; /* buckets for toplevel/module variables */
Scheme_Object *unbound; /* identifiers (and lists of phase-1 shifted unbounds) that were unbound at compile */
Scheme_Hash_Table *stxes; /* syntax objects */
Scheme_Object *uses_unsafe; /* NULL, inspector, or hashtree of inspectors */
} Comp_Prefix;
@ -2506,14 +2507,18 @@ void scheme_delay_load_closure(Scheme_Closure_Data *data);
Scheme_Object *scheme_compiled_void(void);
int scheme_check_top_identifier_bound(Scheme_Object *symbol, Scheme_Env *genv, int disallow_unbound);
Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec,
int imported);
void scheme_register_unbound_toplevel(Scheme_Comp_Env *env, Scheme_Object *id);
Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec);
void scheme_register_unsafe_in_prefix(Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec,
Scheme_Env *menv);
void scheme_merge_undefineds(Scheme_Comp_Env *exp_env, Scheme_Comp_Env *env);
void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a,
Scheme_Env *exp_env, Scheme_Object *insp,