fix problem with package, define*, and macro-introduced identifiers
svn: r14671
This commit is contained in:
Matthew Flatt
parent
1cb53bdf2a
commit
2b8b10dd40
|
|
@ -219,14 +219,12 @@
|
|||
ids))]
|
||||
[add-package-context (lambda (def-ctxes)
|
||||
(lambda (stx)
|
||||
(for/fold ([stx stx])
|
||||
([def-ctx (in-list (reverse def-ctxes))])
|
||||
(let ([q (local-expand #`(quote #,stx)
|
||||
ctx
|
||||
(list #'quote)
|
||||
def-ctx)])
|
||||
def-ctxes)])
|
||||
(syntax-case q ()
|
||||
[(_ stx) #'stx])))))])
|
||||
[(_ stx) #'stx]))))])
|
||||
(let loop ([exprs init-exprs]
|
||||
[rev-forms null]
|
||||
[def-ctxes (list def-ctx)])
|
||||
|
|
@ -293,11 +291,10 @@
|
|||
(lambda ()
|
||||
(list (quote-syntax hidden) ...)))))))))))]
|
||||
[else
|
||||
(let ([expr ((add-package-context (cdr def-ctxes))
|
||||
(local-expand ((add-package-context (cdr def-ctxes)) (car exprs))
|
||||
(let ([expr (local-expand (car exprs)
|
||||
ctx
|
||||
kernel-forms
|
||||
(car def-ctxes)))])
|
||||
def-ctxes)])
|
||||
(syntax-case expr (begin)
|
||||
[(begin . rest)
|
||||
(loop (append (flatten-begin expr) (cdr exprs))
|
||||
|
|
|
|||
|
|
@ -156,7 +156,11 @@ with an empty context is used, instead.}
|
|||
@defproc[(local-expand [stx syntax?]
|
||||
[context-v (or/c 'expression 'top-level 'module 'module-begin list?)]
|
||||
[stop-ids (or/c (listof identifier?) #f)]
|
||||
[intdef-ctx (or/c internal-definition-context? #f) #f])
|
||||
[intdef-ctx (or/c internal-definition-context?
|
||||
(and/c pair?
|
||||
(listof internal-definition-context?))
|
||||
#f)
|
||||
#f])
|
||||
syntax?]{
|
||||
|
||||
Expands @scheme[stx] in the lexical context of the expression
|
||||
|
|
@ -176,12 +180,13 @@ instead of a list, then @scheme[stx] is expanded only as long as the
|
|||
outermost form of @scheme[stx] is a macro (i.e., expansion does not
|
||||
proceed to sub-expressions).
|
||||
|
||||
The optional @scheme[intdef-ctx] argument must be either @scheme[#f]
|
||||
or the result of @scheme[syntax-local-make-definition-context]. In the
|
||||
latter case, lexical information for internal definitions is added to
|
||||
@scheme[stx] before it is expanded. The lexical information is also
|
||||
added to the expansion result (because the expansion might introduce
|
||||
bindings or references to internal-definition bindings).
|
||||
The optional @scheme[intdef-ctx] argument must be either @scheme[#f],
|
||||
the result of @scheme[syntax-local-make-definition-context], or a list
|
||||
of such results. In the latter two cases, lexical information for
|
||||
internal definitions is added to @scheme[stx] before it is expanded
|
||||
(in reverse order relative to the list). The lexical information is
|
||||
also added to the expansion result (because the expansion might
|
||||
introduce bindings or references to internal-definition bindings).
|
||||
|
||||
Expansion of @scheme[stx] can use certificates for the expression
|
||||
already being expanded (see @secref["stxcerts"]) , and @tech{inactive
|
||||
|
|
|
|||
|
|
@ -196,4 +196,19 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(test-pack-seq
|
||||
10
|
||||
(define-package p5 (q)
|
||||
(define* x 10)
|
||||
(define-syntax (y stx)
|
||||
(syntax-case stx ()
|
||||
[(_ z) #'(begin (define z x))]))
|
||||
(define* x 12)
|
||||
(define* z 13)
|
||||
(y q))
|
||||
(open-package p5)
|
||||
q)
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(report-errs)
|
||||
|
|
|
|||
|
|
@ -9274,13 +9274,31 @@ scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_id, Scheme_Ob
|
|||
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 *rl = renaming;
|
||||
|
||||
if (SCHEME_PAIRP(renaming)) {
|
||||
l = scheme_add_rib_delimiter(l, scheme_null);
|
||||
while (!SCHEME_NULLP(rl)) {
|
||||
l = scheme_add_rename(l, SCHEME_CAR(rl));
|
||||
rl = SCHEME_CDR(rl);
|
||||
}
|
||||
l = scheme_add_rib_delimiter(l, renaming);
|
||||
} else {
|
||||
l = scheme_add_rename(l, renaming);
|
||||
}
|
||||
|
||||
return l;
|
||||
}
|
||||
|
||||
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_Object *l, *local_mark, *renaming = NULL, *orig_l, *exp_expr = NULL;
|
||||
int cnt, pos, kind;
|
||||
int bad_sub_env = 0;
|
||||
int bad_sub_env = 0, bad_intdef = 0;
|
||||
Scheme_Object *observer, *catch_lifts_key = NULL;
|
||||
|
||||
env = scheme_current_thread->current_local_env;
|
||||
|
|
@ -9324,7 +9342,36 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
|
|||
if (!scheme_is_sub_env(stx_env, env))
|
||||
bad_sub_env = 1;
|
||||
env = stx_env;
|
||||
} else if (SCHEME_PAIRP(argv[3])) {
|
||||
Scheme_Object *rl = argv[3];
|
||||
while (SCHEME_PAIRP(rl)) {
|
||||
if (SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(SCHEME_CAR(rl)))) {
|
||||
Scheme_Comp_Env *stx_env;
|
||||
stx_env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(SCHEME_CAR(rl));
|
||||
if (!scheme_is_sub_env(stx_env, env))
|
||||
bad_sub_env = 1;
|
||||
} else
|
||||
break;
|
||||
rl = SCHEME_CDR(rl);
|
||||
}
|
||||
if (!SCHEME_NULLP(rl))
|
||||
bad_intdef = 1;
|
||||
else {
|
||||
rl = argv[3];
|
||||
env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(SCHEME_CAR(rl));
|
||||
if (SCHEME_NULLP(SCHEME_CDR(rl)))
|
||||
renaming = SCHEME_PTR2_VAL(SCHEME_CAR(rl));
|
||||
else {
|
||||
/* reverse and extract: */
|
||||
renaming = scheme_null;
|
||||
while (!SCHEME_NULLP(rl)) {
|
||||
renaming = cons(SCHEME_PTR2_VAL(SCHEME_CAR(rl)), renaming);
|
||||
rl = SCHEME_CDR(rl);
|
||||
}
|
||||
}
|
||||
}
|
||||
} else
|
||||
bad_intdef = 1;
|
||||
}
|
||||
|
||||
if (argc > 4) {
|
||||
|
|
@ -9385,19 +9432,14 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
|
|||
|
||||
/* Report errors related to 3rd argument, finally */
|
||||
if (argc > 3) {
|
||||
if (SCHEME_TRUEP(argv[3])) {
|
||||
if (SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[3]))) {
|
||||
if (bad_sub_env) {
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT, "%s: transforming context does "
|
||||
"not match internal-definition context at the front of the context list",
|
||||
if (bad_intdef) {
|
||||
scheme_wrong_type(name, "internal-definition context, non-empty list of internal-definition contexts, or #f", 3, argc, argv);
|
||||
return NULL;
|
||||
} else if (bad_sub_env) {
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT, "%s: transforming context does not match internal-definition context",
|
||||
name);
|
||||
return NULL;
|
||||
}
|
||||
} else {
|
||||
scheme_wrong_type(name, "internal-definition context or #f", 3, argc, argv);
|
||||
return NULL;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
l = argv[0];
|
||||
|
|
@ -9424,7 +9466,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
|
|||
l = scheme_stx_activate_certs(l);
|
||||
|
||||
if (renaming)
|
||||
l = scheme_add_rename(l, renaming);
|
||||
l = add_intdef_renamings(l, renaming);
|
||||
|
||||
SCHEME_EXPAND_OBSERVE_LOCAL_PRE(observer, l);
|
||||
|
||||
|
|
@ -9479,7 +9521,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 = scheme_add_rename(l, renaming);
|
||||
l = add_intdef_renamings(l, renaming);
|
||||
|
||||
if (for_expr) {
|
||||
/* Package up expanded expr with the environment. */
|
||||
|
|
|
|||
|
|
@ -744,6 +744,7 @@ int *scheme_stx_get_rib_sealed(Scheme_Object *rib);
|
|||
|
||||
Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename);
|
||||
Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib);
|
||||
Scheme_Object *scheme_add_rib_delimiter(Scheme_Object *o, Scheme_Object *ribs);
|
||||
|
||||
Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *o, Scheme_Object *relative_to,
|
||||
Scheme_Object *uid);
|
||||
|
|
|
|||
|
|
@ -220,6 +220,7 @@ static Module_Renames *krn;
|
|||
#define SCHEME_RENAMES_SETP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rename_table_set_type))
|
||||
|
||||
#define SCHEME_MODIDXP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_module_index_type))
|
||||
#define SCHEME_RIB_DELIMP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rib_delimiter_type))
|
||||
|
||||
static int is_rename_inspector_info(Scheme_Object *v)
|
||||
{
|
||||
|
|
@ -267,6 +268,15 @@ static int is_rename_inspector_info(Scheme_Object *v)
|
|||
new vectors can be added imperatively; simplification turns this
|
||||
into a vector
|
||||
|
||||
- A wrap-elem (make-rib-delimiter <list-of-rib>)
|
||||
appears in pairs around rib elements; the deeper is just a
|
||||
bracket, while the shallow one contains a non-empty list of
|
||||
ribs; for each environment name defined within the set of
|
||||
ribs, no rib within the set can build on a binding to that
|
||||
environment past the end delimiter; this is used by `local-expand'
|
||||
when given a list of ribs, and simplifcation eliminates
|
||||
rib delimiters
|
||||
|
||||
- A wrap-elem <rename-table> is a module rename set
|
||||
the hash table maps renamed syms to modname-srcname pairs
|
||||
|
||||
|
|
@ -1942,6 +1952,34 @@ Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib)
|
|||
return scheme_add_rename(o, rib);
|
||||
}
|
||||
|
||||
Scheme_Object *scheme_add_rib_delimiter(Scheme_Object *o, Scheme_Object *ribs)
|
||||
{
|
||||
Scheme_Object *s;
|
||||
|
||||
s = scheme_alloc_small_object();
|
||||
s->type = scheme_rib_delimiter_type;
|
||||
SCHEME_BOX_VAL(s) = ribs;
|
||||
|
||||
return scheme_add_rename(o, s);
|
||||
}
|
||||
|
||||
static int is_in_rib_delim(Scheme_Object *envname, Scheme_Object *rib_delim)
|
||||
{
|
||||
Scheme_Object *l = SCHEME_BOX_VAL(rib_delim);
|
||||
Scheme_Lexical_Rib *rib;
|
||||
|
||||
while (!SCHEME_NULLP(l)) {
|
||||
rib = (Scheme_Lexical_Rib *)SCHEME_CAR(l);
|
||||
while (rib) {
|
||||
if (rib->rename && SAME_OBJ(envname, SCHEME_VEC_ELS(rib->rename)[0]))
|
||||
return 1;
|
||||
rib = rib->next;
|
||||
}
|
||||
l = SCHEME_CDR(l);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
static Scheme_Hash_Table *make_recur_table()
|
||||
{
|
||||
if (quick_hash_table) {
|
||||
|
|
@ -3404,7 +3442,7 @@ static Scheme_Object *check_floating_id(Scheme_Object *stx)
|
|||
return scheme_false;
|
||||
}
|
||||
|
||||
#define EXPLAIN_RESOLVE 0
|
||||
#define EXPLAIN_RESOLVE 1
|
||||
#if EXPLAIN_RESOLVE
|
||||
int scheme_explain_resolves = 0;
|
||||
# define EXPLAIN(x) if (scheme_explain_resolves) { x; }
|
||||
|
|
@ -3940,8 +3978,8 @@ static Scheme_Object *extend_cached_env(Scheme_Object *orig, Scheme_Object *othe
|
|||
return orig;
|
||||
}
|
||||
|
||||
/* This needs to be a multiple of 3: */
|
||||
#define QUICK_STACK_SIZE 12
|
||||
/* This needs to be a multiple of 4: */
|
||||
#define QUICK_STACK_SIZE 16
|
||||
|
||||
/* Although resolve_env may call itself recursively, the recursion
|
||||
depth is bounded (by the fact that modules can't be nested,
|
||||
|
|
@ -3970,7 +4008,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
|
|||
Scheme_Object *o_rename_stack = scheme_null, *recur_skip_ribs = skip_ribs;
|
||||
Scheme_Object *mresult = scheme_false, *mresult_insp;
|
||||
Scheme_Object *modidx_shift_to = NULL, *modidx_shift_from = NULL;
|
||||
Scheme_Object *rename_stack[QUICK_STACK_SIZE];
|
||||
Scheme_Object *rename_stack[QUICK_STACK_SIZE], *rib_delim = scheme_false;
|
||||
int stack_pos = 0, no_lexical = 0;
|
||||
int is_in_module = 0, skip_other_mods = 0, floating_checked = 0;
|
||||
Scheme_Lexical_Rib *rib = NULL, *did_rib = NULL;
|
||||
|
|
@ -3992,21 +4030,27 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
|
|||
while (1) {
|
||||
if (WRAP_POS_END_P(wraps)) {
|
||||
/* See rename case for info on rename_stack: */
|
||||
Scheme_Object *result, *result_free_rename, *key;
|
||||
Scheme_Object *result, *result_free_rename, *key, *rd;
|
||||
int did_lexical = 0;
|
||||
|
||||
EXPLAIN(fprintf(stderr, "%d Rename...\n", depth));
|
||||
|
||||
result = scheme_false;
|
||||
result_free_rename = scheme_false;
|
||||
rib_delim = scheme_null;
|
||||
while (!SCHEME_NULLP(o_rename_stack)) {
|
||||
key = SCHEME_CAAR(o_rename_stack);
|
||||
key = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[0];
|
||||
if (SAME_OBJ(key, result)) {
|
||||
EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0)));
|
||||
did_lexical = 1;
|
||||
result = SCHEME_CDR(SCHEME_CAR(o_rename_stack));
|
||||
result_free_rename = SCHEME_CDR(result);
|
||||
result = SCHEME_CAR(result);
|
||||
rd = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[3];
|
||||
if (SCHEME_TRUEP(rd) && !SAME_OBJ(rd, rib_delim) && is_in_rib_delim(result, rd)) {
|
||||
/* not a match, due to rib delimiter */
|
||||
} else {
|
||||
result = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[1];
|
||||
result_free_rename = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[2];
|
||||
rib_delim = rd;
|
||||
}
|
||||
} else {
|
||||
EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0)));
|
||||
if (SAME_OBJ(key, scheme_true)) {
|
||||
|
|
@ -4020,9 +4064,15 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
|
|||
key = rename_stack[stack_pos - 1];
|
||||
if (SAME_OBJ(key, result)) {
|
||||
EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0)));
|
||||
rd = rename_stack[stack_pos - 4];
|
||||
if (SCHEME_TRUEP(rd) && !SAME_OBJ(rd, rib_delim) && is_in_rib_delim(result, rd)) {
|
||||
/* not a match, due to rib delimiter */
|
||||
} else {
|
||||
result = rename_stack[stack_pos - 2];
|
||||
result_free_rename = rename_stack[stack_pos - 3];
|
||||
rib_delim = rd;
|
||||
did_lexical = 1;
|
||||
}
|
||||
} else {
|
||||
EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0)));
|
||||
if (SAME_OBJ(key, scheme_true)) {
|
||||
|
|
@ -4030,7 +4080,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
|
|||
did_lexical = 0;
|
||||
}
|
||||
}
|
||||
stack_pos -= 3;
|
||||
stack_pos -= 4;
|
||||
}
|
||||
if (!did_lexical) {
|
||||
result = mresult;
|
||||
|
|
@ -4485,12 +4535,18 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
|
|||
free_id_rename = vec;
|
||||
}
|
||||
if (stack_pos < QUICK_STACK_SIZE) {
|
||||
rename_stack[stack_pos++] = rib_delim;
|
||||
rename_stack[stack_pos++] = free_id_rename;
|
||||
rename_stack[stack_pos++] = envname;
|
||||
rename_stack[stack_pos++] = other_env;
|
||||
} else {
|
||||
o_rename_stack = CONS(CONS(other_env, CONS(envname, free_id_rename)),
|
||||
o_rename_stack);
|
||||
Scheme_Object *vec;
|
||||
vec = scheme_make_vector(4, NULL);
|
||||
SCHEME_VEC_ELS(vec)[0] = other_env;
|
||||
SCHEME_VEC_ELS(vec)[1] = envname;
|
||||
SCHEME_VEC_ELS(vec)[2] = free_id_rename;
|
||||
SCHEME_VEC_ELS(vec)[3] = rib_delim;
|
||||
o_rename_stack = CONS(vec, o_rename_stack);
|
||||
}
|
||||
if (is_rib) {
|
||||
/* skip future instances of the same rib;
|
||||
|
|
@ -4531,6 +4587,10 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
|
|||
} else
|
||||
rib = NULL;
|
||||
}
|
||||
} else if (SCHEME_RIB_DELIMP(WRAP_POS_FIRST(wraps))) {
|
||||
rib_delim = WRAP_POS_FIRST(wraps);
|
||||
if (SCHEME_NULLP(SCHEME_BOX_VAL(rib_delim)))
|
||||
rib_delim = scheme_false;
|
||||
} else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))) {
|
||||
EXPLAIN(fprintf(stderr, "%d mark %p\n", depth, WRAP_POS_FIRST(wraps)));
|
||||
did_rib = NULL;
|
||||
|
|
@ -5465,8 +5525,8 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
{
|
||||
WRAP_POS w, prev, w2;
|
||||
Scheme_Object *stack = scheme_null, *key, *old_key, *prec_ribs = NULL, *prev_prec_ribs;
|
||||
Scheme_Object *ribs_stack = scheme_null;
|
||||
Scheme_Object *v, *v2, *v2l, *stx, *name, *svl, *end_mutable = NULL;
|
||||
Scheme_Object *ribs_stack = scheme_null, *rib_delim = scheme_false;
|
||||
Scheme_Object *v, *v2, *v2l, *v2rdl, *stx, *name, *svl, *end_mutable = NULL, **v2_rib_delims = NULL, *svrdl;
|
||||
Scheme_Lexical_Rib *did_rib = NULL;
|
||||
Scheme_Hash_Table *skip_ribs_ht = NULL, *prev_skip_ribs_ht;
|
||||
int copy_on_write, no_rib_mutation = 1;
|
||||
|
|
@ -5509,6 +5569,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
old_key = NULL;
|
||||
|
||||
v2l = scheme_null;
|
||||
v2rdl = NULL;
|
||||
|
||||
EXPLAIN_S(fprintf(stderr, "[in simplify]\n"));
|
||||
|
||||
|
|
@ -5625,7 +5686,8 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
ribs_stack = scheme_make_pair(scheme_false, ribs_stack);
|
||||
} else {
|
||||
ribs_stack = scheme_make_pair(scheme_make_pair(prec_ribs,
|
||||
(Scheme_Object *)prev_skip_ribs_ht),
|
||||
scheme_make_pair((Scheme_Object *)prev_skip_ribs_ht,
|
||||
rib_delim)),
|
||||
ribs_stack);
|
||||
}
|
||||
|
||||
|
|
@ -5643,6 +5705,10 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
break;
|
||||
}
|
||||
}
|
||||
} else if (SCHEME_RIB_DELIMP(WRAP_POS_FIRST(w))) {
|
||||
rib_delim = WRAP_POS_FIRST(w);
|
||||
if (SCHEME_NULLP(SCHEME_BOX_VAL(rib_delim)))
|
||||
rib_delim = scheme_false;
|
||||
}
|
||||
|
||||
WRAP_POS_INC(w);
|
||||
|
|
@ -5667,6 +5733,8 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
Scheme_Object *local_ribs;
|
||||
int ii, vvsize, done_rib_pos = 0;
|
||||
|
||||
rib_delim = scheme_false;
|
||||
|
||||
if (SCHEME_FALSEP(SCHEME_CAR(ribs_stack))) {
|
||||
EXPLAIN_S(fprintf(stderr, " skip rib %p=%s\n", v,
|
||||
scheme_write_to_string(((Scheme_Lexical_Rib *)v)->timestamp, NULL)));
|
||||
|
|
@ -5674,8 +5742,11 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
vsize = 0;
|
||||
local_ribs = NULL;
|
||||
} else {
|
||||
prec_ribs = SCHEME_CAR(SCHEME_CAR(ribs_stack));
|
||||
skip_ribs_ht = (Scheme_Hash_Table *)SCHEME_CDR(SCHEME_CAR(ribs_stack));
|
||||
rib_delim = SCHEME_CAR(ribs_stack);
|
||||
prec_ribs = SCHEME_CAR(rib_delim);
|
||||
rib_delim = SCHEME_CDR(rib_delim);
|
||||
skip_ribs_ht = (Scheme_Hash_Table *)SCHEME_CAR(rib_delim);
|
||||
rib_delim = SCHEME_CDR(rib_delim);
|
||||
ribs_stack = SCHEME_CDR(ribs_stack);
|
||||
|
||||
if (SCHEME_RIBP(v)) {
|
||||
|
|
@ -5707,6 +5778,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
size = vsize;
|
||||
|
||||
v2 = scheme_make_vector(2 + (2 * size), NULL);
|
||||
v2_rib_delims = MALLOC_N(Scheme_Object *, size);
|
||||
|
||||
pos = 0; /* counter for used slots */
|
||||
|
||||
|
|
@ -5737,8 +5809,8 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
/* Either this name is in prev, in which case the answer
|
||||
must match this rename's target, or this rename's
|
||||
answer applies. */
|
||||
Scheme_Object *ok = NULL, *ok_replace = NULL;
|
||||
int ok_replace_index = 0;
|
||||
Scheme_Object *ok = NULL, *ok_replace = NULL, **ok_replace_rd = NULL;
|
||||
int ok_replace_index = 0, ok_replace_rd_index = 0;
|
||||
Scheme_Object *other_env, *free_id_rename, *prev_env, *orig_prev_env;
|
||||
|
||||
if (rib) {
|
||||
|
|
@ -5774,7 +5846,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
if (!WRAP_POS_END_P(prev)
|
||||
|| SCHEME_PAIRP(v2l)) {
|
||||
WRAP_POS w3;
|
||||
Scheme_Object *vp;
|
||||
Scheme_Object *vp, **vrdp;
|
||||
|
||||
/* Check marks (now that we have the correct barriers). */
|
||||
WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps);
|
||||
|
|
@ -5799,11 +5871,16 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
orig_prev_env = prev_env;
|
||||
if (SCHEME_PAIRP(prev_env)) prev_env = SCHEME_CAR(prev_env);
|
||||
if (SAME_OBJ(prev_env, other_env)) {
|
||||
if (SCHEME_FALSEP(rib_delim)
|
||||
|| SAME_OBJ(v2_rib_delims[j], rib_delim)
|
||||
|| !is_in_rib_delim(prev_env, rib_delim)) {
|
||||
ok = SCHEME_VEC_ELS(v)[0];
|
||||
ok_replace = v2;
|
||||
ok_replace_index = 2 + size + j;
|
||||
ok_replace_rd = v2_rib_delims;
|
||||
if (!free_id_rename && SCHEME_PAIRP(orig_prev_env))
|
||||
free_id_rename = SCHEME_CDR(orig_prev_env);
|
||||
}
|
||||
} else {
|
||||
EXPLAIN_S(fprintf(stderr, " not matching prev rib\n"));
|
||||
ok = NULL;
|
||||
|
|
@ -5816,12 +5893,19 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
int passed_mutable = 0;
|
||||
WRAP_POS_COPY(w3, prev);
|
||||
svl = v2l;
|
||||
svrdl = v2rdl;
|
||||
for (; SCHEME_PAIRP(svl) || !WRAP_POS_END_P(w3); ) {
|
||||
if (SAME_OBJ(svl, end_mutable)) passed_mutable = 1;
|
||||
if (SCHEME_PAIRP(svl))
|
||||
if (SCHEME_PAIRP(svl)) {
|
||||
vp = SCHEME_CAR(svl);
|
||||
if (svrdl)
|
||||
vrdp = (Scheme_Object **)SCHEME_CAR(svrdl);
|
||||
else
|
||||
vrdp = NULL;
|
||||
} else {
|
||||
vp = WRAP_POS_FIRST(w3);
|
||||
vrdp = NULL;
|
||||
}
|
||||
if (SCHEME_VECTORP(vp)) {
|
||||
psize = SCHEME_RENAME_LEN(vp);
|
||||
for (j = 0; j < psize; j++) {
|
||||
|
|
@ -5829,7 +5913,10 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
prev_env = SCHEME_VEC_ELS(vp)[2+psize+j];
|
||||
orig_prev_env = prev_env;
|
||||
if (SCHEME_PAIRP(prev_env)) prev_env = SCHEME_CAR(prev_env);
|
||||
if (SAME_OBJ(prev_env, other_env)) {
|
||||
if (SAME_OBJ(prev_env, other_env)
|
||||
&& (SCHEME_FALSEP(rib_delim)
|
||||
|| (vrdp && (SAME_OBJ(vrdp[j], rib_delim)))
|
||||
|| !is_in_rib_delim(prev_env, rib_delim))) {
|
||||
ok = SCHEME_VEC_ELS(v)[0];
|
||||
if (!free_id_rename && SCHEME_PAIRP(orig_prev_env))
|
||||
free_id_rename = SCHEME_CDR(orig_prev_env);
|
||||
|
|
@ -5842,11 +5929,14 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
SCHEME_VEC_ELS(vp)[2+psize+j],
|
||||
which is the value from prev */
|
||||
}
|
||||
if (ok && SCHEME_PAIRP(svl) && !passed_mutable) {
|
||||
if (ok && SCHEME_PAIRP(svl) && !passed_mutable
|
||||
&& (SCHEME_FALSEP(rib_delim) || vrdp)) {
|
||||
/* Can overwrite old map, instead
|
||||
of adding a new one. */
|
||||
ok_replace = vp;
|
||||
ok_replace_index = 2 + psize + j;
|
||||
ok_replace_rd = vrdp;
|
||||
ok_replace_rd_index = j;
|
||||
}
|
||||
break;
|
||||
}
|
||||
|
|
@ -5854,9 +5944,10 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
if (j < psize)
|
||||
break;
|
||||
}
|
||||
if (SCHEME_PAIRP(svl))
|
||||
if (SCHEME_PAIRP(svl)) {
|
||||
svl = SCHEME_CDR(svl);
|
||||
else {
|
||||
if (svrdl) svrdl = SCHEME_CDR(svrdl);
|
||||
} else {
|
||||
WRAP_POS_INC(w3);
|
||||
}
|
||||
}
|
||||
|
|
@ -5887,10 +5978,12 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
EXPLAIN_S(fprintf(stderr, " replace mapping %s\n",
|
||||
scheme_write_to_string(ok, NULL)));
|
||||
SCHEME_VEC_ELS(ok_replace)[ok_replace_index] = ok;
|
||||
ok_replace_rd[ok_replace_rd_index] = rib_delim;
|
||||
} else {
|
||||
EXPLAIN_S(fprintf(stderr, " add mapping %s\n",
|
||||
scheme_write_to_string(ok, NULL)));
|
||||
SCHEME_VEC_ELS(v2)[2+size+pos] = ok;
|
||||
v2_rib_delims[pos] = rib_delim;
|
||||
pos++;
|
||||
}
|
||||
} else {
|
||||
|
|
@ -5945,6 +6038,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
|
|||
}
|
||||
|
||||
v2l = CONS(v2, v2l);
|
||||
v2rdl = scheme_make_raw_pair((Scheme_Object *)v2_rib_delims, v2rdl);
|
||||
}
|
||||
|
||||
WRAP_POS_DEC(w);
|
||||
|
|
@ -6062,6 +6156,8 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
|
|||
}
|
||||
}
|
||||
/* else empty simplified vector, which we drop */
|
||||
} else if (SCHEME_RIB_DELIMP(a)) {
|
||||
/* simpliciation eliminates the need for rib delimiters */
|
||||
} else if (SCHEME_RENAMESP(a)
|
||||
|| SCHEME_RENAMES_SETP(a)) {
|
||||
int which = 0;
|
||||
|
|
@ -8252,7 +8348,15 @@ static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv)
|
|||
Scheme_Stx *stx;
|
||||
|
||||
if (!SCHEME_STXP(argv[0]))
|
||||
scheme_wrong_type("syntax-property", "syntax", 0, argc, argv);
|
||||
scheme_wrong_type("syntax-property-symbol-keys", "syntax", 0, argc, argv);
|
||||
|
||||
// REMOVEME
|
||||
{
|
||||
scheme_explain_resolves++;
|
||||
resolve_env(NULL, argv[0], scheme_make_integer(0),
|
||||
1, NULL, NULL, NULL, NULL, 0, NULL);
|
||||
--scheme_explain_resolves;
|
||||
}
|
||||
|
||||
stx = (Scheme_Stx *)argv[0];
|
||||
|
||||
|
|
|
|||
|
|
@ -168,84 +168,85 @@ enum {
|
|||
scheme_logger_type, /* 150 */
|
||||
scheme_log_reader_type, /* 151 */
|
||||
scheme_free_id_info_type, /* 152 */
|
||||
scheme_rib_delimiter_type, /* 153 */
|
||||
|
||||
#ifdef MZTAG_REQUIRED
|
||||
_scheme_last_normal_type_, /* 153 */
|
||||
_scheme_last_normal_type_, /* 154 */
|
||||
|
||||
scheme_rt_weak_array, /* 154 */
|
||||
scheme_rt_weak_array, /* 155 */
|
||||
|
||||
scheme_rt_comp_env, /* 155 */
|
||||
scheme_rt_constant_binding, /* 156 */
|
||||
scheme_rt_resolve_info, /* 157 */
|
||||
scheme_rt_optimize_info, /* 158 */
|
||||
scheme_rt_compile_info, /* 159 */
|
||||
scheme_rt_cont_mark, /* 160 */
|
||||
scheme_rt_saved_stack, /* 161 */
|
||||
scheme_rt_reply_item, /* 162 */
|
||||
scheme_rt_closure_info, /* 163 */
|
||||
scheme_rt_overflow, /* 164 */
|
||||
scheme_rt_overflow_jmp, /* 165 */
|
||||
scheme_rt_meta_cont, /* 166 */
|
||||
scheme_rt_dyn_wind_cell, /* 167 */
|
||||
scheme_rt_dyn_wind_info, /* 168 */
|
||||
scheme_rt_dyn_wind, /* 169 */
|
||||
scheme_rt_dup_check, /* 170 */
|
||||
scheme_rt_thread_memory, /* 171 */
|
||||
scheme_rt_input_file, /* 172 */
|
||||
scheme_rt_input_fd, /* 173 */
|
||||
scheme_rt_oskit_console_input, /* 174 */
|
||||
scheme_rt_tested_input_file, /* 175 */
|
||||
scheme_rt_tested_output_file, /* 176 */
|
||||
scheme_rt_indexed_string, /* 177 */
|
||||
scheme_rt_output_file, /* 178 */
|
||||
scheme_rt_load_handler_data, /* 179 */
|
||||
scheme_rt_pipe, /* 180 */
|
||||
scheme_rt_beos_process, /* 181 */
|
||||
scheme_rt_system_child, /* 182 */
|
||||
scheme_rt_tcp, /* 183 */
|
||||
scheme_rt_write_data, /* 184 */
|
||||
scheme_rt_tcp_select_info, /* 185 */
|
||||
scheme_rt_namespace_option, /* 186 */
|
||||
scheme_rt_param_data, /* 187 */
|
||||
scheme_rt_will, /* 188 */
|
||||
scheme_rt_struct_proc_info, /* 189 */
|
||||
scheme_rt_linker_name, /* 190 */
|
||||
scheme_rt_param_map, /* 191 */
|
||||
scheme_rt_finalization, /* 192 */
|
||||
scheme_rt_finalizations, /* 193 */
|
||||
scheme_rt_cpp_object, /* 194 */
|
||||
scheme_rt_cpp_array_object, /* 195 */
|
||||
scheme_rt_stack_object, /* 196 */
|
||||
scheme_rt_preallocated_object, /* 197 */
|
||||
scheme_thread_hop_type, /* 198 */
|
||||
scheme_rt_srcloc, /* 199 */
|
||||
scheme_rt_evt, /* 200 */
|
||||
scheme_rt_syncing, /* 201 */
|
||||
scheme_rt_comp_prefix, /* 202 */
|
||||
scheme_rt_user_input, /* 203 */
|
||||
scheme_rt_user_output, /* 204 */
|
||||
scheme_rt_compact_port, /* 205 */
|
||||
scheme_rt_read_special_dw, /* 206 */
|
||||
scheme_rt_regwork, /* 207 */
|
||||
scheme_rt_buf_holder, /* 208 */
|
||||
scheme_rt_parameterization, /* 209 */
|
||||
scheme_rt_print_params, /* 210 */
|
||||
scheme_rt_read_params, /* 211 */
|
||||
scheme_rt_native_code, /* 212 */
|
||||
scheme_rt_native_code_plus_case, /* 213 */
|
||||
scheme_rt_jitter_data, /* 214 */
|
||||
scheme_rt_module_exports, /* 215 */
|
||||
scheme_rt_delay_load_info, /* 216 */
|
||||
scheme_rt_marshal_info, /* 217 */
|
||||
scheme_rt_unmarshal_info, /* 218 */
|
||||
scheme_rt_runstack, /* 219 */
|
||||
scheme_rt_sfs_info, /* 220 */
|
||||
scheme_rt_validate_clearing, /* 221 */
|
||||
scheme_rt_rb_node, /* 222 */
|
||||
scheme_rt_comp_env, /* 156 */
|
||||
scheme_rt_constant_binding, /* 157 */
|
||||
scheme_rt_resolve_info, /* 158 */
|
||||
scheme_rt_optimize_info, /* 159 */
|
||||
scheme_rt_compile_info, /* 160 */
|
||||
scheme_rt_cont_mark, /* 161 */
|
||||
scheme_rt_saved_stack, /* 162 */
|
||||
scheme_rt_reply_item, /* 163 */
|
||||
scheme_rt_closure_info, /* 164 */
|
||||
scheme_rt_overflow, /* 165 */
|
||||
scheme_rt_overflow_jmp, /* 166 */
|
||||
scheme_rt_meta_cont, /* 167 */
|
||||
scheme_rt_dyn_wind_cell, /* 168 */
|
||||
scheme_rt_dyn_wind_info, /* 169 */
|
||||
scheme_rt_dyn_wind, /* 170 */
|
||||
scheme_rt_dup_check, /* 171 */
|
||||
scheme_rt_thread_memory, /* 172 */
|
||||
scheme_rt_input_file, /* 173 */
|
||||
scheme_rt_input_fd, /* 174 */
|
||||
scheme_rt_oskit_console_input, /* 175 */
|
||||
scheme_rt_tested_input_file, /* 176 */
|
||||
scheme_rt_tested_output_file, /* 177 */
|
||||
scheme_rt_indexed_string, /* 178 */
|
||||
scheme_rt_output_file, /* 179 */
|
||||
scheme_rt_load_handler_data, /* 180 */
|
||||
scheme_rt_pipe, /* 181 */
|
||||
scheme_rt_beos_process, /* 182 */
|
||||
scheme_rt_system_child, /* 183 */
|
||||
scheme_rt_tcp, /* 184 */
|
||||
scheme_rt_write_data, /* 185 */
|
||||
scheme_rt_tcp_select_info, /* 186 */
|
||||
scheme_rt_namespace_option, /* 187 */
|
||||
scheme_rt_param_data, /* 188 */
|
||||
scheme_rt_will, /* 189 */
|
||||
scheme_rt_struct_proc_info, /* 190 */
|
||||
scheme_rt_linker_name, /* 191 */
|
||||
scheme_rt_param_map, /* 192 */
|
||||
scheme_rt_finalization, /* 193 */
|
||||
scheme_rt_finalizations, /* 194 */
|
||||
scheme_rt_cpp_object, /* 195 */
|
||||
scheme_rt_cpp_array_object, /* 196 */
|
||||
scheme_rt_stack_object, /* 197 */
|
||||
scheme_rt_preallocated_object, /* 198 */
|
||||
scheme_thread_hop_type, /* 199 */
|
||||
scheme_rt_srcloc, /* 200 */
|
||||
scheme_rt_evt, /* 201 */
|
||||
scheme_rt_syncing, /* 202 */
|
||||
scheme_rt_comp_prefix, /* 203 */
|
||||
scheme_rt_user_input, /* 204 */
|
||||
scheme_rt_user_output, /* 205 */
|
||||
scheme_rt_compact_port, /* 206 */
|
||||
scheme_rt_read_special_dw, /* 207 */
|
||||
scheme_rt_regwork, /* 208 */
|
||||
scheme_rt_buf_holder, /* 209 */
|
||||
scheme_rt_parameterization, /* 210 */
|
||||
scheme_rt_print_params, /* 211 */
|
||||
scheme_rt_read_params, /* 212 */
|
||||
scheme_rt_native_code, /* 213 */
|
||||
scheme_rt_native_code_plus_case, /* 214 */
|
||||
scheme_rt_jitter_data, /* 215 */
|
||||
scheme_rt_module_exports, /* 216 */
|
||||
scheme_rt_delay_load_info, /* 217 */
|
||||
scheme_rt_marshal_info, /* 218 */
|
||||
scheme_rt_unmarshal_info, /* 219 */
|
||||
scheme_rt_runstack, /* 220 */
|
||||
scheme_rt_sfs_info, /* 221 */
|
||||
scheme_rt_validate_clearing, /* 222 */
|
||||
scheme_rt_rb_node, /* 223 */
|
||||
#endif
|
||||
|
||||
scheme_place_type, /* 223 */
|
||||
scheme_engine_type, /* 224 */
|
||||
scheme_place_type, /* 224 */
|
||||
scheme_engine_type, /* 225 */
|
||||
|
||||
_scheme_last_type_
|
||||
};
|
||||
|
|
|
|||
|
|
@ -619,6 +619,8 @@ void scheme_register_traversers(void)
|
|||
GC_REG_TRAV(scheme_log_reader_type, mark_log_reader);
|
||||
|
||||
GC_REG_TRAV(scheme_rt_runstack, runstack_val);
|
||||
|
||||
GC_REG_TRAV(scheme_rib_delimiter_type, small_object);
|
||||
}
|
||||
|
||||
END_XFORM_SKIP;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user