From a72ef3ec05e6cd5d0de491afc056510aa2e49b95 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 27 Jan 2015 08:28:31 -0700 Subject: [PATCH] syntax-local-lift-require: fix problems for meta-compile-time use Various repairs correct problems with `local-require` in a phase-1 context. --- .../racket-test-core/tests/racket/module.rktl | 36 ++++++++ racket/src/racket/src/compenv.c | 2 +- racket/src/racket/src/module.c | 83 +++++++++++++++++-- racket/src/racket/src/schpriv.h | 3 +- racket/src/racket/src/syntax.c | 1 - 5 files changed, 115 insertions(+), 10 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/module.rktl b/pkgs/racket-test-core/tests/racket/module.rktl index 3613840258..87941fb2bd 100644 --- a/pkgs/racket-test-core/tests/racket/module.rktl +++ b/pkgs/racket-test-core/tests/racket/module.rktl @@ -1300,6 +1300,42 @@ (module check-contract-out-by-itself racket (provide (contract-out))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check `local-require` in a compile-time position: + +(module provides-a-for-local-require racket/base + (define a 1) + (provide a)) + +(module uses-a-in-macro-rhs racket/base + (require (for-syntax racket/base)) + (provide one) + + (define-syntax (m stx) + (local-require 'provides-a-for-local-require) + #`#,a) + + (define one (m))) + +(test 1 dynamic-require ''uses-a-in-macro-rhs 'one) + +(module uses-a-in-begin-for-syntax racket/base + (require (for-syntax racket/base)) + (provide one) + + (begin-for-syntax + (define one-ct + (let () + (local-require 'provides-a-for-local-require) + a))) + + (define-syntax (m stx) + #`#,one-ct) + + (define one (m))) + +(test 1 dynamic-require ''uses-a-in-begin-for-syntax 'one) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/racket/src/racket/src/compenv.c b/racket/src/racket/src/compenv.c index db6550f6d2..d9394d3aa9 100644 --- a/racket/src/racket/src/compenv.c +++ b/racket/src/racket/src/compenv.c @@ -2354,7 +2354,7 @@ Scheme_Object *scheme_local_lift_require(Scheme_Object *form, Scheme_Object *ori mark = scheme_new_mark(); if (SCHEME_RPAIRP(data)) - form = scheme_parse_lifted_require(form, phase, mark, SCHEME_CAR(data)); + form = scheme_parse_lifted_require(form, phase, mark, SCHEME_CAR(data), &orig_form); else { form = scheme_toplevel_require_for_expand(form, phase, env, mark); need_prepare = 1; diff --git a/racket/src/racket/src/module.c b/racket/src/racket/src/module.c index 0599d1747e..5d0fafaef0 100644 --- a/racket/src/racket/src/module.c +++ b/racket/src/racket/src/module.c @@ -8022,15 +8022,72 @@ static Scheme_Object *add_lifted_defn(Scheme_Object *data, Scheme_Object **_ids, return scheme_make_lifted_defn(scheme_sys_wraps(env), _ids, expr, _env); } +static Scheme_Object *shift_require_phase(Scheme_Object *e, Scheme_Object *phase, int can_just_meta) +{ + Scheme_Object *l, *a; + + l = e; + if (SCHEME_STXP(l)) l = SCHEME_STX_VAL(l); + if (SCHEME_PAIRP(l)) { + a = SCHEME_CAR(l); + if (SCHEME_STXP(a)) a = SCHEME_STX_VAL(a); + + if (can_just_meta && SAME_OBJ(a, just_meta_symbol)) { + /* Shift any `for-meta` within `just-meta`: */ + l = SCHEME_CDR(l); + if (scheme_proper_list_length(l) >= 1) { + a = SCHEME_CAR(l); + if (SCHEME_STXP(a)) a = SCHEME_STX_VAL(a); + if (SCHEME_FALSEP(a) || SCHEME_INTP(a) || SCHEME_BIGNUMP(a)) { + e = scheme_null; + for (l = SCHEME_CDR(l); SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { + e = scheme_make_pair(shift_require_phase(SCHEME_CAR(l), phase, 0), + e); + } + + e = scheme_reverse(e); + return scheme_make_pair(just_meta_symbol, scheme_make_pair(a, e)); + } else + l = scheme_make_pair(e, scheme_null); + } else + l = scheme_make_pair(e, l); + } else if (SAME_OBJ(a, for_meta_symbol)) { + l = SCHEME_CDR(l); + if (SCHEME_PAIRP(l)) { + a = SCHEME_CAR(l); + if (SCHEME_STXP(a)) a = SCHEME_STX_VAL(a); + if (SCHEME_FALSEP(a)) { + return e; + } else if (SCHEME_INTP(a) || SCHEME_BIGNUMP(a)) { + phase = scheme_bin_plus(a, phase); + l = SCHEME_CDR(l); + } else + l = scheme_make_pair(e, scheme_null); + } else + l = scheme_make_pair(e, scheme_null); + } else if (SAME_OBJ(a, for_label_symbol)) { + return e; + } else if (SAME_OBJ(a, for_syntax_symbol)) { + phase = scheme_bin_plus(scheme_make_integer(1), phase); + l = SCHEME_CDR(l); + } else if (SAME_OBJ(a, for_template_symbol)) { + phase = scheme_bin_plus(scheme_make_integer(-1), phase); + l = SCHEME_CDR(l); + } else + l = scheme_make_pair(e, scheme_null); + } else + l = scheme_make_pair(e, scheme_null); + + return scheme_make_pair(for_meta_symbol, + scheme_make_pair(phase, l)); +} + static Scheme_Object *make_require_form(Scheme_Object *module_path, intptr_t phase, Scheme_Object *mark) { Scheme_Object *e = module_path; if (phase != 0) { - e = scheme_make_pair(for_meta_symbol, - scheme_make_pair(scheme_make_integer(phase), - scheme_make_pair(e, - scheme_null))); + e = shift_require_phase(e, scheme_make_integer(phase), 1); } e = scheme_make_pair(require_stx, scheme_make_pair(e, scheme_null)); e = scheme_datum_to_syntax(e, scheme_false, scheme_false, 0, 0); @@ -8043,7 +8100,8 @@ static Scheme_Object *make_require_form(Scheme_Object *module_path, intptr_t pha Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path, intptr_t phase, Scheme_Object *mark, - void *data) + void *data, + Scheme_Object **_ref_expr) { Scheme_Object *e; Scheme_Object *base_modidx = (Scheme_Object *)((void **)data)[1]; @@ -8056,19 +8114,30 @@ Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path, int *all_simple = (int *)((void **)data)[8]; Scheme_Hash_Table *submodule_names = (Scheme_Hash_Table *)((void **)data)[9]; - e = make_require_form(module_path, phase, mark); + if (*_ref_expr) { + e = scheme_add_rename(*_ref_expr, post_ex_rns); + *_ref_expr = e; + } + + e = make_require_form(module_path, phase - env->phase, mark); parse_requires(e, env->phase, base_modidx, env, for_m, rns, post_ex_rns, check_require_name, tables, redef_modname, 0, 0, 1, - 1, 0, + 1, phase ? 1 : 0, all_simple, NULL, submodule_names, NULL); + scheme_prepare_compile_env(env); + if (phase > env->phase) { + /* Right-hand side of a `define-syntax`; need to prepare compile-time env */ + scheme_prepare_compile_env(env->exp_env); + } + return e; } diff --git a/racket/src/racket/src/schpriv.h b/racket/src/racket/src/schpriv.h index b7d0291fdb..21680d0d5a 100644 --- a/racket/src/racket/src/schpriv.h +++ b/racket/src/racket/src/schpriv.h @@ -2809,7 +2809,8 @@ Scheme_Object *scheme_toplevel_require_for_expand(Scheme_Object *module_path, Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path, intptr_t phase, Scheme_Object *mark, - void *data); + void *data, + Scheme_Object **_ref_expr); void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env); void scheme_set_local_syntax(int pos, Scheme_Object *name, Scheme_Object *val, diff --git a/racket/src/racket/src/syntax.c b/racket/src/racket/src/syntax.c index 2bc60acf12..c06f2b988d 100644 --- a/racket/src/racket/src/syntax.c +++ b/racket/src/racket/src/syntax.c @@ -3808,7 +3808,6 @@ static Scheme_Object *resolve_env(Scheme_Object *a, Scheme_Object *orig_phase, EXPLAIN(fprintf(stderr, "%d Resolving %s@%d [skips: %s]: -------------\n", depth, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)), SCHEME_INT_VAL(orig_phase), scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL))); - WRAP_POS_INIT(wraps, ((Scheme_Stx *)a)->wraps); while (1) {