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

fix problem with package, define*, and macro-introduced identifiers

Browse Source 
svn: r14671
This commit is contained in:
Matthew Flatt 2009-04-30 23:57:45 +00:00
parent 1cb53bdf2a
commit 2b8b10dd40
8 changed files with 312 additions and 145 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/scheme/package.ss
View File

@ -219,14 +219,12 @@
ids))] ids))]
[add-package-context (lambda (def-ctxes) [add-package-context (lambda (def-ctxes)
(lambda (stx) (lambda (stx)
(for/fold ([stx stx]) (let ([q (local-expand #`(quote #,stx)
([def-ctx (in-list (reverse def-ctxes))]) ctx
(let ([q (local-expand #`(quote #,stx) (list #'quote)
ctx def-ctxes)])
(list #'quote) (syntax-case q ()
def-ctx)]) [(_ stx) #'stx]))))])
(syntax-case q ()
[(_ stx) #'stx])))))])
(let loop ([exprs init-exprs] (let loop ([exprs init-exprs]
[rev-forms null] [rev-forms null]
[def-ctxes (list def-ctx)]) [def-ctxes (list def-ctx)])
@ -293,11 +291,10 @@
(lambda () (lambda ()
(list (quote-syntax hidden) ...)))))))))))] (list (quote-syntax hidden) ...)))))))))))]
[else [else
(let ([expr ((add-package-context (cdr def-ctxes)) (let ([expr (local-expand (car exprs)
(local-expand ((add-package-context (cdr def-ctxes)) (car exprs)) ctx
ctx kernel-forms
kernel-forms def-ctxes)])
(car def-ctxes)))])
(syntax-case expr (begin) (syntax-case expr (begin)
[(begin . rest) [(begin . rest)
(loop (append (flatten-begin expr) (cdr exprs)) (loop (append (flatten-begin expr) (cdr exprs))

19
collects/scribblings/reference/stx-trans.scrbl
View File

@ -156,7 +156,11 @@ with an empty context is used, instead.}
@defproc[(local-expand [stx syntax?] @defproc[(local-expand [stx syntax?]
[context-v (or/c 'expression 'top-level 'module 'module-begin list?)] [context-v (or/c 'expression 'top-level 'module 'module-begin list?)]
[stop-ids (or/c (listof identifier?) #f)] [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?]{ syntax?]{
Expands @scheme[stx] in the lexical context of the expression 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 outermost form of @scheme[stx] is a macro (i.e., expansion does not
proceed to sub-expressions). proceed to sub-expressions).
The optional @scheme[intdef-ctx] argument must be either @scheme[#f] The optional @scheme[intdef-ctx] argument must be either @scheme[#f],
or the result of @scheme[syntax-local-make-definition-context]. In the the result of @scheme[syntax-local-make-definition-context], or a list
latter case, lexical information for internal definitions is added to of such results. In the latter two cases, lexical information for
@scheme[stx] before it is expanded. The lexical information is also internal definitions is added to @scheme[stx] before it is expanded
added to the expansion result (because the expansion might introduce (in reverse order relative to the list). The lexical information is
bindings or references to internal-definition bindings). 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 Expansion of @scheme[stx] can use certificates for the expression
already being expanded (see @secref["stxcerts"]) , and @tech{inactive already being expanded (see @secref["stxcerts"]) , and @tech{inactive

15
collects/tests/mzscheme/package.ss
View File

@ -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) (report-errs)

74
src/mzscheme/src/eval.c
View File

@ -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); 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 * static Scheme_Object *
do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, int argc, Scheme_Object **argv) 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_Comp_Env *env, *orig_env, **ip;
Scheme_Object *l, *local_mark, *renaming = NULL, *orig_l, *exp_expr = NULL; Scheme_Object *l, *local_mark, *renaming = NULL, *orig_l, *exp_expr = NULL;
int cnt, pos, kind; int cnt, pos, kind;
int bad_sub_env = 0; int bad_sub_env = 0, bad_intdef = 0;
Scheme_Object *observer, *catch_lifts_key = NULL; Scheme_Object *observer, *catch_lifts_key = NULL;
env = scheme_current_thread->current_local_env; 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)) if (!scheme_is_sub_env(stx_env, env))
bad_sub_env = 1; bad_sub_env = 1;
env = stx_env; 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) { if (argc > 4) {
@ -9385,18 +9432,13 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
/* Report errors related to 3rd argument, finally */ /* Report errors related to 3rd argument, finally */
if (argc > 3) { if (argc > 3) {
if (SCHEME_TRUEP(argv[3])) { if (bad_intdef) {
if (SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[3]))) { scheme_wrong_type(name, "internal-definition context, non-empty list of internal-definition contexts, or #f", 3, argc, argv);
if (bad_sub_env) { return NULL;
scheme_raise_exn(MZEXN_FAIL_CONTRACT, "%s: transforming context does " } else if (bad_sub_env) {
"not match internal-definition context at the front of the context list", scheme_raise_exn(MZEXN_FAIL_CONTRACT, "%s: transforming context does not match internal-definition context",
name); name);
return NULL; return NULL;
}
} else {
scheme_wrong_type(name, "internal-definition context or #f", 3, argc, argv);
return NULL;
}
} }
} }
@ -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); l = scheme_stx_activate_certs(l);
if (renaming) if (renaming)
l = scheme_add_rename(l, renaming); l = add_intdef_renamings(l, renaming);
SCHEME_EXPAND_OBSERVE_LOCAL_PRE(observer, l); 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); SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, l);
if (renaming) if (renaming)
l = scheme_add_rename(l, renaming); l = add_intdef_renamings(l, renaming);
if (for_expr) { if (for_expr) {
/* Package up expanded expr with the environment. */ /* Package up expanded expr with the environment. */

1
src/mzscheme/src/schpriv.h
View File

@ -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(Scheme_Object *o, Scheme_Object *rename);
Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib); 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 *scheme_stx_remove_extra_marks(Scheme_Object *o, Scheme_Object *relative_to,
Scheme_Object *uid); Scheme_Object *uid);

178
src/mzscheme/src/stxobj.c
View File

@ -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_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_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) 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 new vectors can be added imperatively; simplification turns this
into a vector 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 - A wrap-elem <rename-table> is a module rename set
the hash table maps renamed syms to modname-srcname pairs 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); 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() static Scheme_Hash_Table *make_recur_table()
{ {
if (quick_hash_table) { if (quick_hash_table) {
@ -3404,7 +3442,7 @@ static Scheme_Object *check_floating_id(Scheme_Object *stx)
return scheme_false; return scheme_false;
} }
#define EXPLAIN_RESOLVE 0 #define EXPLAIN_RESOLVE 1
#if EXPLAIN_RESOLVE #if EXPLAIN_RESOLVE
int scheme_explain_resolves = 0; int scheme_explain_resolves = 0;
# define EXPLAIN(x) if (scheme_explain_resolves) { x; } # 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; return orig;
} }
/* This needs to be a multiple of 3: */ /* This needs to be a multiple of 4: */
#define QUICK_STACK_SIZE 12 #define QUICK_STACK_SIZE 16
/* Although resolve_env may call itself recursively, the recursion /* Although resolve_env may call itself recursively, the recursion
depth is bounded (by the fact that modules can't be nested, 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 *o_rename_stack = scheme_null, *recur_skip_ribs = skip_ribs;
Scheme_Object *mresult = scheme_false, *mresult_insp; Scheme_Object *mresult = scheme_false, *mresult_insp;
Scheme_Object *modidx_shift_to = NULL, *modidx_shift_from = NULL; 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 stack_pos = 0, no_lexical = 0;
int is_in_module = 0, skip_other_mods = 0, floating_checked = 0; int is_in_module = 0, skip_other_mods = 0, floating_checked = 0;
Scheme_Lexical_Rib *rib = NULL, *did_rib = NULL; Scheme_Lexical_Rib *rib = NULL, *did_rib = NULL;
@ -3992,21 +4030,27 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
while (1) { while (1) {
if (WRAP_POS_END_P(wraps)) { if (WRAP_POS_END_P(wraps)) {
/* See rename case for info on rename_stack: */ /* 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; int did_lexical = 0;
EXPLAIN(fprintf(stderr, "%d Rename...\n", depth)); EXPLAIN(fprintf(stderr, "%d Rename...\n", depth));
result = scheme_false; result = scheme_false;
result_free_rename = scheme_false; result_free_rename = scheme_false;
rib_delim = scheme_null;
while (!SCHEME_NULLP(o_rename_stack)) { 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)) { if (SAME_OBJ(key, result)) {
EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0))); EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0)));
did_lexical = 1; did_lexical = 1;
result = SCHEME_CDR(SCHEME_CAR(o_rename_stack)); rd = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[3];
result_free_rename = SCHEME_CDR(result); if (SCHEME_TRUEP(rd) && !SAME_OBJ(rd, rib_delim) && is_in_rib_delim(result, rd)) {
result = SCHEME_CAR(result); /* 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 { } else {
EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0))); EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0)));
if (SAME_OBJ(key, scheme_true)) { if (SAME_OBJ(key, scheme_true)) {
@ -4020,9 +4064,15 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
key = rename_stack[stack_pos - 1]; key = rename_stack[stack_pos - 1];
if (SAME_OBJ(key, result)) { if (SAME_OBJ(key, result)) {
EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0))); EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0)));
result = rename_stack[stack_pos - 2]; rd = rename_stack[stack_pos - 4];
result_free_rename = rename_stack[stack_pos - 3]; if (SCHEME_TRUEP(rd) && !SAME_OBJ(rd, rib_delim) && is_in_rib_delim(result, rd)) {
did_lexical = 1; /* 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 { } else {
EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0))); EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0)));
if (SAME_OBJ(key, scheme_true)) { if (SAME_OBJ(key, scheme_true)) {
@ -4030,7 +4080,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
did_lexical = 0; did_lexical = 0;
} }
} }
stack_pos -= 3; stack_pos -= 4;
} }
if (!did_lexical) { if (!did_lexical) {
result = mresult; result = mresult;
@ -4485,12 +4535,18 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
free_id_rename = vec; free_id_rename = vec;
} }
if (stack_pos < QUICK_STACK_SIZE) { if (stack_pos < QUICK_STACK_SIZE) {
rename_stack[stack_pos++] = rib_delim;
rename_stack[stack_pos++] = free_id_rename; rename_stack[stack_pos++] = free_id_rename;
rename_stack[stack_pos++] = envname; rename_stack[stack_pos++] = envname;
rename_stack[stack_pos++] = other_env; rename_stack[stack_pos++] = other_env;
} else { } else {
o_rename_stack = CONS(CONS(other_env, CONS(envname, free_id_rename)), Scheme_Object *vec;
o_rename_stack); 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) { if (is_rib) {
/* skip future instances of the same rib; /* skip future instances of the same rib;
@ -4531,6 +4587,10 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
} else } else
rib = NULL; 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))) { } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))) {
EXPLAIN(fprintf(stderr, "%d mark %p\n", depth, WRAP_POS_FIRST(wraps))); EXPLAIN(fprintf(stderr, "%d mark %p\n", depth, WRAP_POS_FIRST(wraps)));
did_rib = NULL; did_rib = NULL;
@ -5465,8 +5525,8 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
{ {
WRAP_POS w, prev, w2; WRAP_POS w, prev, w2;
Scheme_Object *stack = scheme_null, *key, *old_key, *prec_ribs = NULL, *prev_prec_ribs; Scheme_Object *stack = scheme_null, *key, *old_key, *prec_ribs = NULL, *prev_prec_ribs;
Scheme_Object *ribs_stack = scheme_null; Scheme_Object *ribs_stack = scheme_null, *rib_delim = scheme_false;
Scheme_Object *v, *v2, *v2l, *stx, *name, *svl, *end_mutable = NULL; Scheme_Object *v, *v2, *v2l, *v2rdl, *stx, *name, *svl, *end_mutable = NULL, **v2_rib_delims = NULL, *svrdl;
Scheme_Lexical_Rib *did_rib = NULL; Scheme_Lexical_Rib *did_rib = NULL;
Scheme_Hash_Table *skip_ribs_ht = NULL, *prev_skip_ribs_ht; Scheme_Hash_Table *skip_ribs_ht = NULL, *prev_skip_ribs_ht;
int copy_on_write, no_rib_mutation = 1; 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; old_key = NULL;
v2l = scheme_null; v2l = scheme_null;
v2rdl = NULL;
EXPLAIN_S(fprintf(stderr, "[in simplify]\n")); 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); ribs_stack = scheme_make_pair(scheme_false, ribs_stack);
} else { } else {
ribs_stack = scheme_make_pair(scheme_make_pair(prec_ribs, 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); ribs_stack);
} }
@ -5643,6 +5705,10 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
break; 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); WRAP_POS_INC(w);
@ -5667,6 +5733,8 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
Scheme_Object *local_ribs; Scheme_Object *local_ribs;
int ii, vvsize, done_rib_pos = 0; int ii, vvsize, done_rib_pos = 0;
rib_delim = scheme_false;
if (SCHEME_FALSEP(SCHEME_CAR(ribs_stack))) { if (SCHEME_FALSEP(SCHEME_CAR(ribs_stack))) {
EXPLAIN_S(fprintf(stderr, " skip rib %p=%s\n", v, EXPLAIN_S(fprintf(stderr, " skip rib %p=%s\n", v,
scheme_write_to_string(((Scheme_Lexical_Rib *)v)->timestamp, NULL))); 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; vsize = 0;
local_ribs = NULL; local_ribs = NULL;
} else { } else {
prec_ribs = SCHEME_CAR(SCHEME_CAR(ribs_stack)); rib_delim = SCHEME_CAR(ribs_stack);
skip_ribs_ht = (Scheme_Hash_Table *)SCHEME_CDR(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); ribs_stack = SCHEME_CDR(ribs_stack);
if (SCHEME_RIBP(v)) { if (SCHEME_RIBP(v)) {
@ -5707,6 +5778,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
size = vsize; size = vsize;
v2 = scheme_make_vector(2 + (2 * size), NULL); v2 = scheme_make_vector(2 + (2 * size), NULL);
v2_rib_delims = MALLOC_N(Scheme_Object *, size);
pos = 0; /* counter for used slots */ 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 /* Either this name is in prev, in which case the answer
must match this rename's target, or this rename's must match this rename's target, or this rename's
answer applies. */ answer applies. */
Scheme_Object *ok = NULL, *ok_replace = NULL; Scheme_Object *ok = NULL, *ok_replace = NULL, **ok_replace_rd = NULL;
int ok_replace_index = 0; int ok_replace_index = 0, ok_replace_rd_index = 0;
Scheme_Object *other_env, *free_id_rename, *prev_env, *orig_prev_env; Scheme_Object *other_env, *free_id_rename, *prev_env, *orig_prev_env;
if (rib) { if (rib) {
@ -5774,7 +5846,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
if (!WRAP_POS_END_P(prev) if (!WRAP_POS_END_P(prev)
|| SCHEME_PAIRP(v2l)) { || SCHEME_PAIRP(v2l)) {
WRAP_POS w3; WRAP_POS w3;
Scheme_Object *vp; Scheme_Object *vp, **vrdp;
/* Check marks (now that we have the correct barriers). */ /* Check marks (now that we have the correct barriers). */
WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); 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; orig_prev_env = prev_env;
if (SCHEME_PAIRP(prev_env)) prev_env = SCHEME_CAR(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)) {
ok = SCHEME_VEC_ELS(v)[0]; if (SCHEME_FALSEP(rib_delim)
ok_replace = v2; || SAME_OBJ(v2_rib_delims[j], rib_delim)
ok_replace_index = 2 + size + j; || !is_in_rib_delim(prev_env, rib_delim)) {
if (!free_id_rename && SCHEME_PAIRP(orig_prev_env)) ok = SCHEME_VEC_ELS(v)[0];
free_id_rename = SCHEME_CDR(orig_prev_env); 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 { } else {
EXPLAIN_S(fprintf(stderr, " not matching prev rib\n")); EXPLAIN_S(fprintf(stderr, " not matching prev rib\n"));
ok = NULL; ok = NULL;
@ -5816,12 +5893,19 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
int passed_mutable = 0; int passed_mutable = 0;
WRAP_POS_COPY(w3, prev); WRAP_POS_COPY(w3, prev);
svl = v2l; svl = v2l;
svrdl = v2rdl;
for (; SCHEME_PAIRP(svl) || !WRAP_POS_END_P(w3); ) { for (; SCHEME_PAIRP(svl) || !WRAP_POS_END_P(w3); ) {
if (SAME_OBJ(svl, end_mutable)) passed_mutable = 1; if (SAME_OBJ(svl, end_mutable)) passed_mutable = 1;
if (SCHEME_PAIRP(svl)) if (SCHEME_PAIRP(svl)) {
vp = SCHEME_CAR(svl); vp = SCHEME_CAR(svl);
else if (svrdl)
vrdp = (Scheme_Object **)SCHEME_CAR(svrdl);
else
vrdp = NULL;
} else {
vp = WRAP_POS_FIRST(w3); vp = WRAP_POS_FIRST(w3);
vrdp = NULL;
}
if (SCHEME_VECTORP(vp)) { if (SCHEME_VECTORP(vp)) {
psize = SCHEME_RENAME_LEN(vp); psize = SCHEME_RENAME_LEN(vp);
for (j = 0; j < psize; j++) { 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]; prev_env = SCHEME_VEC_ELS(vp)[2+psize+j];
orig_prev_env = prev_env; orig_prev_env = prev_env;
if (SCHEME_PAIRP(prev_env)) prev_env = SCHEME_CAR(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]; ok = SCHEME_VEC_ELS(v)[0];
if (!free_id_rename && SCHEME_PAIRP(orig_prev_env)) if (!free_id_rename && SCHEME_PAIRP(orig_prev_env))
free_id_rename = SCHEME_CDR(orig_prev_env); free_id_rename = SCHEME_CDR(orig_prev_env);
@ -5839,14 +5926,17 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
scheme_write_to_string(other_env, NULL))); scheme_write_to_string(other_env, NULL)));
ok = NULL; ok = NULL;
/* Alternate time/space tradeoff: could be /* Alternate time/space tradeoff: could be
SCHEME_VEC_ELS(vp)[2+psize+j], SCHEME_VEC_ELS(vp)[2+psize+j],
which is the value from prev */ 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 /* Can overwrite old map, instead
of adding a new one. */ of adding a new one. */
ok_replace = vp; ok_replace = vp;
ok_replace_index = 2 + psize + j; ok_replace_index = 2 + psize + j;
ok_replace_rd = vrdp;
ok_replace_rd_index = j;
} }
break; break;
} }
@ -5854,9 +5944,10 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
if (j < psize) if (j < psize)
break; break;
} }
if (SCHEME_PAIRP(svl)) if (SCHEME_PAIRP(svl)) {
svl = SCHEME_CDR(svl); svl = SCHEME_CDR(svl);
else { if (svrdl) svrdl = SCHEME_CDR(svrdl);
} else {
WRAP_POS_INC(w3); 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", EXPLAIN_S(fprintf(stderr, " replace mapping %s\n",
scheme_write_to_string(ok, NULL))); scheme_write_to_string(ok, NULL)));
SCHEME_VEC_ELS(ok_replace)[ok_replace_index] = ok; SCHEME_VEC_ELS(ok_replace)[ok_replace_index] = ok;
ok_replace_rd[ok_replace_rd_index] = rib_delim;
} else { } else {
EXPLAIN_S(fprintf(stderr, " add mapping %s\n", EXPLAIN_S(fprintf(stderr, " add mapping %s\n",
scheme_write_to_string(ok, NULL))); scheme_write_to_string(ok, NULL)));
SCHEME_VEC_ELS(v2)[2+size+pos] = ok; SCHEME_VEC_ELS(v2)[2+size+pos] = ok;
v2_rib_delims[pos] = rib_delim;
pos++; pos++;
} }
} else { } else {
@ -5945,6 +6038,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab
} }
v2l = CONS(v2, v2l); v2l = CONS(v2, v2l);
v2rdl = scheme_make_raw_pair((Scheme_Object *)v2_rib_delims, v2rdl);
} }
WRAP_POS_DEC(w); 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 empty simplified vector, which we drop */
} else if (SCHEME_RIB_DELIMP(a)) {
/* simpliciation eliminates the need for rib delimiters */
} else if (SCHEME_RENAMESP(a) } else if (SCHEME_RENAMESP(a)
|| SCHEME_RENAMES_SETP(a)) { || SCHEME_RENAMES_SETP(a)) {
int which = 0; int which = 0;
@ -8252,7 +8348,15 @@ static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv)
Scheme_Stx *stx; Scheme_Stx *stx;
if (!SCHEME_STXP(argv[0])) 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]; stx = (Scheme_Stx *)argv[0];

145
src/mzscheme/src/stypes.h
View File

@ -168,84 +168,85 @@ enum {
scheme_logger_type, /* 150 */ scheme_logger_type, /* 150 */
scheme_log_reader_type, /* 151 */ scheme_log_reader_type, /* 151 */
scheme_free_id_info_type, /* 152 */ scheme_free_id_info_type, /* 152 */
scheme_rib_delimiter_type, /* 153 */
#ifdef MZTAG_REQUIRED #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_comp_env, /* 156 */
scheme_rt_constant_binding, /* 156 */ scheme_rt_constant_binding, /* 157 */
scheme_rt_resolve_info, /* 157 */ scheme_rt_resolve_info, /* 158 */
scheme_rt_optimize_info, /* 158 */ scheme_rt_optimize_info, /* 159 */
scheme_rt_compile_info, /* 159 */ scheme_rt_compile_info, /* 160 */
scheme_rt_cont_mark, /* 160 */ scheme_rt_cont_mark, /* 161 */
scheme_rt_saved_stack, /* 161 */ scheme_rt_saved_stack, /* 162 */
scheme_rt_reply_item, /* 162 */ scheme_rt_reply_item, /* 163 */
scheme_rt_closure_info, /* 163 */ scheme_rt_closure_info, /* 164 */
scheme_rt_overflow, /* 164 */ scheme_rt_overflow, /* 165 */
scheme_rt_overflow_jmp, /* 165 */ scheme_rt_overflow_jmp, /* 166 */
scheme_rt_meta_cont, /* 166 */ scheme_rt_meta_cont, /* 167 */
scheme_rt_dyn_wind_cell, /* 167 */ scheme_rt_dyn_wind_cell, /* 168 */
scheme_rt_dyn_wind_info, /* 168 */ scheme_rt_dyn_wind_info, /* 169 */
scheme_rt_dyn_wind, /* 169 */ scheme_rt_dyn_wind, /* 170 */
scheme_rt_dup_check, /* 170 */ scheme_rt_dup_check, /* 171 */
scheme_rt_thread_memory, /* 171 */ scheme_rt_thread_memory, /* 172 */
scheme_rt_input_file, /* 172 */ scheme_rt_input_file, /* 173 */
scheme_rt_input_fd, /* 173 */ scheme_rt_input_fd, /* 174 */
scheme_rt_oskit_console_input, /* 174 */ scheme_rt_oskit_console_input, /* 175 */
scheme_rt_tested_input_file, /* 175 */ scheme_rt_tested_input_file, /* 176 */
scheme_rt_tested_output_file, /* 176 */ scheme_rt_tested_output_file, /* 177 */
scheme_rt_indexed_string, /* 177 */ scheme_rt_indexed_string, /* 178 */
scheme_rt_output_file, /* 178 */ scheme_rt_output_file, /* 179 */
scheme_rt_load_handler_data, /* 179 */ scheme_rt_load_handler_data, /* 180 */
scheme_rt_pipe, /* 180 */ scheme_rt_pipe, /* 181 */
scheme_rt_beos_process, /* 181 */ scheme_rt_beos_process, /* 182 */
scheme_rt_system_child, /* 182 */ scheme_rt_system_child, /* 183 */
scheme_rt_tcp, /* 183 */ scheme_rt_tcp, /* 184 */
scheme_rt_write_data, /* 184 */ scheme_rt_write_data, /* 185 */
scheme_rt_tcp_select_info, /* 185 */ scheme_rt_tcp_select_info, /* 186 */
scheme_rt_namespace_option, /* 186 */ scheme_rt_namespace_option, /* 187 */
scheme_rt_param_data, /* 187 */ scheme_rt_param_data, /* 188 */
scheme_rt_will, /* 188 */ scheme_rt_will, /* 189 */
scheme_rt_struct_proc_info, /* 189 */ scheme_rt_struct_proc_info, /* 190 */
scheme_rt_linker_name, /* 190 */ scheme_rt_linker_name, /* 191 */
scheme_rt_param_map, /* 191 */ scheme_rt_param_map, /* 192 */
scheme_rt_finalization, /* 192 */ scheme_rt_finalization, /* 193 */
scheme_rt_finalizations, /* 193 */ scheme_rt_finalizations, /* 194 */
scheme_rt_cpp_object, /* 194 */ scheme_rt_cpp_object, /* 195 */
scheme_rt_cpp_array_object, /* 195 */ scheme_rt_cpp_array_object, /* 196 */
scheme_rt_stack_object, /* 196 */ scheme_rt_stack_object, /* 197 */
scheme_rt_preallocated_object, /* 197 */ scheme_rt_preallocated_object, /* 198 */
scheme_thread_hop_type, /* 198 */ scheme_thread_hop_type, /* 199 */
scheme_rt_srcloc, /* 199 */ scheme_rt_srcloc, /* 200 */
scheme_rt_evt, /* 200 */ scheme_rt_evt, /* 201 */
scheme_rt_syncing, /* 201 */ scheme_rt_syncing, /* 202 */
scheme_rt_comp_prefix, /* 202 */ scheme_rt_comp_prefix, /* 203 */
scheme_rt_user_input, /* 203 */ scheme_rt_user_input, /* 204 */
scheme_rt_user_output, /* 204 */ scheme_rt_user_output, /* 205 */
scheme_rt_compact_port, /* 205 */ scheme_rt_compact_port, /* 206 */
scheme_rt_read_special_dw, /* 206 */ scheme_rt_read_special_dw, /* 207 */
scheme_rt_regwork, /* 207 */ scheme_rt_regwork, /* 208 */
scheme_rt_buf_holder, /* 208 */ scheme_rt_buf_holder, /* 209 */
scheme_rt_parameterization, /* 209 */ scheme_rt_parameterization, /* 210 */
scheme_rt_print_params, /* 210 */ scheme_rt_print_params, /* 211 */
scheme_rt_read_params, /* 211 */ scheme_rt_read_params, /* 212 */
scheme_rt_native_code, /* 212 */ scheme_rt_native_code, /* 213 */
scheme_rt_native_code_plus_case, /* 213 */ scheme_rt_native_code_plus_case, /* 214 */
scheme_rt_jitter_data, /* 214 */ scheme_rt_jitter_data, /* 215 */
scheme_rt_module_exports, /* 215 */ scheme_rt_module_exports, /* 216 */
scheme_rt_delay_load_info, /* 216 */ scheme_rt_delay_load_info, /* 217 */
scheme_rt_marshal_info, /* 217 */ scheme_rt_marshal_info, /* 218 */
scheme_rt_unmarshal_info, /* 218 */ scheme_rt_unmarshal_info, /* 219 */
scheme_rt_runstack, /* 219 */ scheme_rt_runstack, /* 220 */
scheme_rt_sfs_info, /* 220 */ scheme_rt_sfs_info, /* 221 */
scheme_rt_validate_clearing, /* 221 */ scheme_rt_validate_clearing, /* 222 */
scheme_rt_rb_node, /* 222 */ scheme_rt_rb_node, /* 223 */
#endif #endif
scheme_place_type, /* 223 */ scheme_place_type, /* 224 */
scheme_engine_type, /* 224 */ scheme_engine_type, /* 225 */
_scheme_last_type_ _scheme_last_type_
}; };

2
src/mzscheme/src/type.c
View File

@ -619,6 +619,8 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_log_reader_type, mark_log_reader); GC_REG_TRAV(scheme_log_reader_type, mark_log_reader);
GC_REG_TRAV(scheme_rt_runstack, runstack_val); GC_REG_TRAV(scheme_rt_runstack, runstack_val);
GC_REG_TRAV(scheme_rib_delimiter_type, small_object);
} }
END_XFORM_SKIP; END_XFORM_SKIP;