diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index 469ce825f5..cf8b4d4c83 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -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)]) - (syntax-case q () - [(_ stx) #'stx])))))]) + (let ([q (local-expand #`(quote #,stx) + ctx + (list #'quote) + def-ctxes)]) + (syntax-case q () + [(_ 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)) - ctx - kernel-forms - (car def-ctxes)))]) + (let ([expr (local-expand (car exprs) + ctx + kernel-forms + def-ctxes)]) (syntax-case expr (begin) [(begin . rest) (loop (append (flatten-begin expr) (cdr exprs)) diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index f2ee0a869a..f15261e460 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -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 diff --git a/collects/tests/mzscheme/package.ss b/collects/tests/mzscheme/package.ss index 65c6e320c9..246784e200 100644 --- a/collects/tests/mzscheme/package.ss +++ b/collects/tests/mzscheme/package.ss @@ -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) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 3552cff5e0..1115e4c34b 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -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,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 */ 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", - name); - return NULL; - } - } else { - scheme_wrong_type(name, "internal-definition context or #f", 3, argc, argv); - return NULL; - } + 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; } } @@ -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. */ diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 385e3f4e9d..5c5337730d 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -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); diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index a012173ea4..31ecdb87aa 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -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 ) + 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 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))); - result = rename_stack[stack_pos - 2]; - result_free_rename = rename_stack[stack_pos - 3]; - did_lexical = 1; + 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)) { - ok = SCHEME_VEC_ELS(v)[0]; - ok_replace = v2; - ok_replace_index = 2 + size + j; - if (!free_id_rename && SCHEME_PAIRP(orig_prev_env)) - free_id_rename = SCHEME_CDR(orig_prev_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); - else + 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); @@ -5839,14 +5926,17 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab scheme_write_to_string(other_env, NULL))); ok = NULL; /* Alternate time/space tradeoff: could be - SCHEME_VEC_ELS(vp)[2+psize+j], - which is the value from prev */ + 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]; diff --git a/src/mzscheme/src/stypes.h b/src/mzscheme/src/stypes.h index 1cb9de0bcc..bc774cc6e9 100644 --- a/src/mzscheme/src/stypes.h +++ b/src/mzscheme/src/stypes.h @@ -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_ }; diff --git a/src/mzscheme/src/type.c b/src/mzscheme/src/type.c index 5f800c28fa..fdcad81833 100644 --- a/src/mzscheme/src/type.c +++ b/src/mzscheme/src/type.c @@ -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;