diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index c22dd13626..2f1245f317 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -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[ diff --git a/collects/tests/racket/stx.rktl b/collects/tests/racket/stx.rktl index fd7a727125..8ad007c85a 100644 --- a/collects/tests/racket/stx.rktl +++ b/collects/tests/racket/stx.rktl @@ -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) diff --git a/src/racket/src/compenv.c b/src/racket/src/compenv.c index 8ca9d63e17..9544fb0b56 100644 --- a/src/racket/src/compenv.c +++ b/src/racket/src/compenv.c @@ -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) diff --git a/src/racket/src/compile.c b/src/racket/src/compile.c index 2937038ef5..8648ae2cb0 100644 --- a/src/racket/src/compile.c +++ b/src/racket/src/compile.c @@ -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; } diff --git a/src/racket/src/env.c b/src/racket/src/env.c index 72e8b0eba5..ae403f6eb2 100644 --- a/src/racket/src/env.c +++ b/src/racket/src/env.c @@ -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; } } diff --git a/src/racket/src/error.c b/src/racket/src/error.c index 4d2937ee08..f13a9492da 100644 --- a/src/racket/src/error.c +++ b/src/racket/src/error.c @@ -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, diff --git a/src/racket/src/module.c b/src/racket/src/module.c index 8adb9164d7..2a32446a46 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -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); diff --git a/src/racket/src/mzmark_type.inc b/src/racket/src/mzmark_type.inc index 8bb4a67c7f..3ab370bf96 100644 --- a/src/racket/src/mzmark_type.inc +++ b/src/racket/src/mzmark_type.inc @@ -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); diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index b99812f2bb..521dc4d6b2 100644 --- a/src/racket/src/mzmarksrc.c +++ b/src/racket/src/mzmarksrc.c @@ -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); diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index bc07b4cdb2..1cefd6b408 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -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,