syntax-local-lift-require: fix problems for meta-compile-time use
Various repairs correct problems with `local-require` in a phase-1 context.
This commit is contained in:
Matthew Flatt
parent
7bee7bbadc
commit
a72ef3ec05
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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) {
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user