diff --git a/collects/scribblings/guide/certificates.scrbl b/collects/scribblings/guide/certificates.scrbl index 6f1f768c6b..26a1886f96 100644 --- a/collects/scribblings/guide/certificates.scrbl +++ b/collects/scribblings/guide/certificates.scrbl @@ -41,7 +41,11 @@ example, when @scheme[(go 'a)] is expanded to @scheme[(unchecked-go 8 'a)], a certificate is attached to the result @scheme[(unchecked-go 8 'a)]. Extracting just @scheme[unchecked-go] removes the identifier from the certified expression, so that the reference is disallowed -when it is inserted into @scheme[(unchecked-go #f 'a)]. +when it is inserted into @scheme[(unchecked-go #f 'a)]. The +@scheme[expand] and @scheme[local-expand] (when used with an empty +stop list) functions lift all certificates to the outermost result +expression, except as indicated by @scheme['certify-mode] syntax +properties (see @refsecref["stxcerts"]). In addition to checking module references, the macro expander disallows references to local bindings where the binding identifier is diff --git a/collects/scribblings/reference/stx-certs.scrbl b/collects/scribblings/reference/stx-certs.scrbl index 245c6a15a0..6cd230f1a0 100644 --- a/collects/scribblings/reference/stx-certs.scrbl +++ b/collects/scribblings/reference/stx-certs.scrbl @@ -60,10 +60,11 @@ shape and properties of the result: @scheme['certify-mode] property if it does not already have a @scheme['certify-mode] property value.} - @item{If the result has no @scheme['certify-mode] property value, - but its datum is a pair, and if the syntax object - corresponding to the @scheme[car] of the pair is an - identifier bound to @scheme[begin], then the certificate is + @item{If the result has no @scheme['certify-mode] property value, but + its datum is a pair, and if the syntax object corresponding + to the @scheme[car] of the pair is an identifier bound to + @scheme[begin], @scheme[module], or + @scheme[#%plain-module-begin], then the certificate is propagated as if the syntax object had the @scheme['transparent] property value.} @@ -77,7 +78,11 @@ shape and properties of the result: ] -The expander attaches a new active certificate to a syntax object, +To avoid accidental transfer for a @scheme['certify-mode] property +value, the expander always removes any @scheme['certify-mode] property +on a syntax object that is passed to a syntax transformer. + +As the expander attaches a new active certificate to a syntax object, it also removes any @tech{inactive certificates} attached to any @tech{syntax object} within the one where the certificate is attached, and it re-attaches the formerly @tech{inactive certificates} as @@ -123,6 +128,12 @@ expansion context: ] +Finally, for the result of @scheme[expand] or @scheme[local-expand] +with an empty stop list, certificates are lifted to the outermost +result expression, except to the degree that @scheme['certify-mode] +property values and bindings like @scheme[begin] direct certificates +to sub-expressions. + @defproc[(syntax-recertify [new-stx syntax?] [old-stx syntax?] diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 9af0edf601..4afadbb6f8 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -171,7 +171,14 @@ value and @scheme[cons] it onto the current result of @scheme[syntax-local-context] if it is a list. When an identifier in @scheme[stop-ids] is encountered by the expander -in a subexpression, expansions stops for the subexpression. If +in a subexpression, expansions stops for the subexpression. If +@scheme[stop-ids] is a non-empty list, then +@scheme[begin], @scheme[quote], @scheme[set!], @scheme[lambda], +@scheme[case-lambda], @scheme[let-values], @scheme[letrec-values], +@scheme[if], @scheme[begin0], @scheme[with-continuation-mark], +@scheme[letrec-syntaxes+values], @scheme[#%app], +@scheme[#%expression], @scheme[#%top], and +@scheme[#%variable-reference] are added to @scheme[stop-ids]. If @scheme[#%app], @scheme[#%top], or @scheme[#%datum] appears in @scheme[stop-ids], then application, top-level variable reference, and literal data expressions without the respective explicit form are not diff --git a/collects/typed-scheme/utils/require-contract.ss b/collects/typed-scheme/utils/require-contract.ss index b7f89075ab..266f7e62d1 100644 --- a/collects/typed-scheme/utils/require-contract.ss +++ b/collects/typed-scheme/utils/require-contract.ss @@ -12,7 +12,7 @@ [(_ name expr) (syntax-case (local-expand/capture-lifts #'expr 'expression - (list #'define-values)) + null #;(list #'define-values)) (begin define-values) [(begin (define-values (n) e) e*) #`(begin (define-values (n) e) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 1c91d86728..f7bcb08963 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -247,6 +247,8 @@ static Scheme_Object *read_syntax(Scheme_Object *obj); static Scheme_Object *write_quote_syntax(Scheme_Object *obj); static Scheme_Object *read_quote_syntax(Scheme_Object *obj); +static Scheme_Object *stop_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); + static Scheme_Object *scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec, int app_position); @@ -9795,6 +9797,9 @@ static void *expand_k(void) /* scheme_simplify_stx(obj, scheme_new_stx_simplify_cache()); */ /* too expensive */ } + if (!as_local) + obj = scheme_lift_local_stx_certificates(obj, env); + return obj; } @@ -10109,12 +10114,20 @@ static void update_intdef_chain(Scheme_Object *intdef) } } +static void add_core_stop_form(int pos, Scheme_Object *sym, Scheme_Comp_Env *env) +{ + Scheme_Object *stx; + stx = scheme_datum_to_syntax(sym, scheme_false, scheme_sys_wraps(env), 0, 0); + scheme_set_local_syntax(pos, stx, stop_expander, env); +} + 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 nonempty_stop_list = 0; int bad_sub_env = 0, bad_intdef = 0; Scheme_Object *observer, *catch_lifts_key = NULL; @@ -10226,9 +10239,13 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in if (for_expr) { } else if (SCHEME_TRUEP(argv[2])) { +# define NUM_CORE_EXPR_STOP_FORMS 15 cnt = scheme_stx_proper_list_length(argv[2]); - if (cnt > 0) + if (cnt > 0) { + cnt += NUM_CORE_EXPR_STOP_FORMS; scheme_add_local_syntax(cnt, env); + nonempty_stop_list = 1; + } pos = 0; for (l = argv[2]; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { @@ -10247,6 +10264,24 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in scheme_wrong_type(name, "#f or list of identifier syntax", 2, argc, argv); return NULL; } + + if (cnt > 0) { + add_core_stop_form(pos++, begin_symbol, env); + add_core_stop_form(pos++, scheme_intern_symbol("set!"), env); + add_core_stop_form(pos++, app_symbol, env); + add_core_stop_form(pos++, top_symbol, env); + add_core_stop_form(pos++, lambda_symbol, env); + add_core_stop_form(pos++, scheme_intern_symbol("case-lambda"), env); + add_core_stop_form(pos++, let_values_symbol, env); + add_core_stop_form(pos++, letrec_values_symbol, env); + add_core_stop_form(pos++, scheme_intern_symbol("if"), env); + add_core_stop_form(pos++, scheme_intern_symbol("begin0"), env); + add_core_stop_form(pos++, scheme_intern_symbol("with-continuation-mark"), env); + add_core_stop_form(pos++, letrec_syntaxes_symbol, env); + add_core_stop_form(pos++, scheme_intern_symbol("#%variable-reference"), env); + add_core_stop_form(pos++, scheme_intern_symbol("#%expression"), env); + add_core_stop_form(pos++, quote_symbol, env); + } } /* Report errors related to 3rd argument, finally */ @@ -10367,6 +10402,9 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in l = scheme_add_remove_mark(l, local_mark); } + if (!nonempty_stop_list) + l = scheme_lift_local_stx_certificates(l, env); + if (for_expr) { Scheme_Object *a[2]; SCHEME_EXPAND_OBSERVE_OPAQUE_EXPR(observer, exp_expr); @@ -10374,9 +10412,10 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in a[0] = l; a[1] = exp_expr; return scheme_values(2, a); - } else + } else { SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, l); return l; + } } static Scheme_Object * diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index b033c5061b..6d4bf7f59e 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -176,6 +176,8 @@ THREAD_LOCAL_DECL(static Scheme_Prompt *available_regular_prompt); THREAD_LOCAL_DECL(static Scheme_Dynamic_Wind *available_prompt_dw); THREAD_LOCAL_DECL(static Scheme_Meta_Continuation *available_prompt_mc); THREAD_LOCAL_DECL(static Scheme_Object *cached_beg_stx); +THREAD_LOCAL_DECL(static Scheme_Object *cached_mod_stx); +THREAD_LOCAL_DECL(static Scheme_Object *cached_mod_beg_stx); THREAD_LOCAL_DECL(static Scheme_Object *cached_dv_stx); THREAD_LOCAL_DECL(static Scheme_Object *cached_ds_stx); THREAD_LOCAL_DECL(static int cached_stx_phase); @@ -574,6 +576,8 @@ void scheme_init_fun_places() { REGISTER_SO(cached_beg_stx); + REGISTER_SO(cached_mod_stx); + REGISTER_SO(cached_mod_beg_stx); REGISTER_SO(cached_dv_stx); REGISTER_SO(cached_ds_stx); REGISTER_SO(offstack_cont); @@ -2642,6 +2646,7 @@ cert_with_specials(Scheme_Object *code, Scheme_Object *mark, Scheme_Env *menv, Scheme_Object *orig_code, Scheme_Object *closest_code, Scheme_Comp_Env *cenv, int phase, int deflt, int cadr_deflt) +/* Adds (if mark) or lifts (if not mark) certificates. */ { Scheme_Object *prop; int next_cadr_deflt = 0; @@ -2649,7 +2654,10 @@ cert_with_specials(Scheme_Object *code, Scheme_Object *mark, Scheme_Env *menv, if (SCHEME_STXP(code)) { prop = scheme_stx_property(code, certify_mode_symbol, NULL); if (SAME_OBJ(prop, opaque_symbol)) { - return scheme_stx_cert(code, mark, menv, orig_code, NULL, 1); + if (mark) + return scheme_stx_cert(code, mark, menv, orig_code, NULL, 1); + else + return scheme_stx_lift_active_certs(code); } else if (SAME_OBJ(prop, transparent_symbol)) { cadr_deflt = 0; /* fall through */ @@ -2671,30 +2679,42 @@ cert_with_specials(Scheme_Object *code, Scheme_Object *mark, Scheme_Env *menv, Scheme_Object *name; name = SCHEME_STX_CAR(code); if (SCHEME_STX_SYMBOLP(name)) { - Scheme_Object *beg_stx, *dv_stx, *ds_stx; + Scheme_Object *beg_stx, *mod_stx, *mod_beg_stx, *dv_stx, *ds_stx; if (!phase) { + mod_stx = scheme_module_stx; beg_stx = scheme_begin_stx; + mod_beg_stx = scheme_module_begin_stx; dv_stx = scheme_define_values_stx; ds_stx = scheme_define_syntaxes_stx; } else if (phase == cached_stx_phase) { beg_stx = cached_beg_stx; + mod_stx = cached_mod_stx; + mod_beg_stx = cached_mod_beg_stx; dv_stx = cached_dv_stx; ds_stx = cached_ds_stx; } else { beg_stx = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_begin_stx), scheme_false, scheme_sys_wraps(cenv), 0, 0); + mod_stx = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_module_stx), scheme_false, + scheme_sys_wraps(cenv), 0, 0); + mod_beg_stx = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_module_begin_stx), scheme_false, + scheme_sys_wraps(cenv), 0, 0); dv_stx = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_define_values_stx), scheme_false, scheme_sys_wraps(cenv), 0, 0); ds_stx = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_define_syntaxes_stx), scheme_false, scheme_sys_wraps(cenv), 0, 0); cached_beg_stx = beg_stx; + cached_mod_stx = mod_stx; + cached_mod_beg_stx = mod_beg_stx; cached_dv_stx = dv_stx; cached_ds_stx = ds_stx; cached_stx_phase = phase; } - if (scheme_stx_module_eq(beg_stx, name, phase)) { + if (scheme_stx_module_eq(beg_stx, name, phase) + || scheme_stx_module_eq(mod_stx, name, phase) + || scheme_stx_module_eq(mod_beg_stx, name, phase)) { trans = 1; next_cadr_deflt = 0; } else if (scheme_stx_module_eq(dv_stx, name, phase) @@ -2705,8 +2725,12 @@ cert_with_specials(Scheme_Object *code, Scheme_Object *mark, Scheme_Env *menv, } } - if (!trans) - return scheme_stx_cert(code, mark, menv, orig_code, NULL, 1); + if (!trans) { + if (mark) + return scheme_stx_cert(code, mark, menv, orig_code, NULL, 1); + else + return scheme_stx_lift_active_certs(code); + } } } @@ -2733,7 +2757,18 @@ cert_with_specials(Scheme_Object *code, Scheme_Object *mark, Scheme_Env *menv, } else if (SCHEME_STX_NULLP(code)) return code; - return scheme_stx_cert(code, mark, menv, orig_code, NULL, 1); + if (mark) + return scheme_stx_cert(code, mark, menv, orig_code, NULL, 1); + else + return scheme_stx_lift_active_certs(code); +} + +Scheme_Object *scheme_lift_local_stx_certificates(Scheme_Object *code, + Scheme_Comp_Env *env) +{ + return cert_with_specials(code, NULL, NULL, code, code, + NULL, env->genv->phase, + 0, 0); } Scheme_Object * @@ -2789,6 +2824,15 @@ scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv, mark = scheme_new_mark(); code = scheme_add_remove_mark(code, mark); + { + /* Ensure that source doesn't already have 'certify-mode, in case argument + properties are used for result properties. */ + Scheme_Object *prop; + prop = scheme_stx_property(code, certify_mode_symbol, NULL); + if (SCHEME_TRUEP(prop)) + code = scheme_stx_property(code, certify_mode_symbol, scheme_false); + } + SCHEME_EXPAND_OBSERVE_MACRO_PRE_X(rec[drec].observer, code); { diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index ec968098e2..70586f5c27 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -168,6 +168,7 @@ static Scheme_Object *nominal_id_symbol; /* global read-only syntax */ Scheme_Object *scheme_module_stx; +Scheme_Object *scheme_module_begin_stx; Scheme_Object *scheme_begin_stx; Scheme_Object *scheme_define_values_stx; Scheme_Object *scheme_define_syntaxes_stx; @@ -500,6 +501,7 @@ void scheme_finish_kernel(Scheme_Env *env) scheme_sys_wraps(NULL); REGISTER_SO(scheme_module_stx); + REGISTER_SO(scheme_module_begin_stx); REGISTER_SO(scheme_begin_stx); REGISTER_SO(scheme_define_values_stx); REGISTER_SO(scheme_define_syntaxes_stx); @@ -523,6 +525,7 @@ void scheme_finish_kernel(Scheme_Env *env) w = scheme_sys_wraps0; scheme_module_stx = scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false, w, 0, 0); + scheme_module_begin_stx = scheme_datum_to_syntax(module_begin_symbol, scheme_false, w, 0, 0); scheme_begin_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin"), scheme_false, w, 0, 0); scheme_define_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-values"), scheme_false, w, 0, 0); scheme_define_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-syntaxes"), scheme_false, w, 0, 0); @@ -6098,7 +6101,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, { Scheme_Object *stop; stop = scheme_get_stop_expander(); - scheme_add_local_syntax(20, xenv); + scheme_add_local_syntax(19, xenv); scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv); scheme_set_local_syntax(1, scheme_define_values_stx, stop, xenv); scheme_set_local_syntax(2, scheme_define_syntaxes_stx, stop, xenv); @@ -6114,11 +6117,10 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, scheme_set_local_syntax(12, letrec_values_stx, stop, xenv); scheme_set_local_syntax(13, if_stx, stop, xenv); scheme_set_local_syntax(14, begin0_stx, stop, xenv); - scheme_set_local_syntax(15, set_stx, stop, xenv); - scheme_set_local_syntax(16, with_continuation_mark_stx, stop, xenv); - scheme_set_local_syntax(17, letrec_syntaxes_stx, stop, xenv); - scheme_set_local_syntax(18, var_ref_stx, stop, xenv); - scheme_set_local_syntax(19, expression_stx, stop, xenv); + scheme_set_local_syntax(15, with_continuation_mark_stx, stop, xenv); + scheme_set_local_syntax(16, letrec_syntaxes_stx, stop, xenv); + scheme_set_local_syntax(17, var_ref_stx, stop, xenv); + scheme_set_local_syntax(18, expression_stx, stop, xenv); } first = scheme_null; diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 481687b312..1e0d18b1a2 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -331,6 +331,7 @@ extern Scheme_Object *scheme_date; extern Scheme_Object *scheme_module_stx; extern Scheme_Object *scheme_begin_stx; +extern Scheme_Object *scheme_module_begin_stx; extern Scheme_Object *scheme_define_values_stx; extern Scheme_Object *scheme_define_syntaxes_stx; extern Scheme_Object *scheme_top_stx; @@ -902,11 +903,15 @@ int scheme_stx_certified(Scheme_Object *stx, Scheme_Object *extra_certs, Scheme_Object *modidx, Scheme_Object *home_insp); int scheme_module_protected_wrt(Scheme_Object *home_insp, Scheme_Object *insp); Scheme_Object *scheme_stx_activate_certs(Scheme_Object *stx); +Scheme_Object *scheme_stx_lift_active_certs(Scheme_Object *stx); Scheme_Object *scheme_stx_extract_certs(Scheme_Object *o, Scheme_Object *base_certs); Scheme_Object *scheme_stx_add_inactive_certs(Scheme_Object *o, Scheme_Object *certs); Scheme_Object *scheme_stx_propagate_inactive_certs(Scheme_Object *o, Scheme_Object *orig); +Scheme_Object *scheme_lift_local_stx_certificates(Scheme_Object *code, + struct Scheme_Comp_Env *env); + int scheme_stx_has_more_certs(Scheme_Object *id, Scheme_Object *certs, Scheme_Object *than_id, Scheme_Object *than_certs); diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 66d082de3e..4d59b8dda4 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -103,6 +103,8 @@ THREAD_LOCAL_DECL(static Scheme_Hash_Table *than_id_marks_ht); /* a cache */ THREAD_LOCAL_DECL(static Scheme_Bucket_Table *interned_skip_ribs); static Scheme_Object *no_nested_inactive_certs; +static Scheme_Object *no_nested_active_certs; +static Scheme_Object *no_nested_certs; #ifdef MZ_PRECISE_GC static void register_traversers(void); @@ -200,11 +202,16 @@ typedef struct Scheme_Cert { maybe inactive certs in nested parts - rcons(c1, c2): active certs c1 (maybe NULL), inactive certs c2 (maybe NULL); maybe inactive certs in nested parts - - immutable-rcons(c1, c2): active certs c1 (maybe NULL), inactive certs c2 (maybe NULL); - no inactive certs in nested parts (using the immutable flag as a hack!) */ + Use flags 0x1 and 02 to indicate no inactive or active certs in nested parts */ #define ACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CAR((stx)->certs) : (stx)->certs) : NULL)) #define INACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CDR((stx)->certs) : NULL) : NULL)) -static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp); +static Scheme_Object *stx_strip_certs(Scheme_Object *o, Scheme_Cert **cp, int active); + +#define SCHEME_NO_INACTIVE_SUBS_P(obj) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x1) +#define SCHEME_NO_ACTIVE_SUBS_P(obj) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x2) +#define SCHEME_SET_NO_X_SUBS(obj, flag) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) |= flag) +#define SCHEME_SET_NO_INACTIVE_SUBS(obj) SCHEME_SET_NO_X_SUBS(obj, 0x1) +#define SCHEME_SET_NO_ACTIVE_SUBS(obj) SCHEME_SET_NO_X_SUBS(obj, 0x2) #define SCHEME_RENAME_LEN(vec) ((SCHEME_VEC_SIZE(vec) - 2) >> 1) @@ -619,13 +626,16 @@ void scheme_init_stx(Scheme_Env *env) REGISTER_SO(empty_simplified); empty_simplified = scheme_make_vector(2, scheme_false); - - - REGISTER_SO(no_nested_inactive_certs); + REGISTER_SO(no_nested_active_certs); + REGISTER_SO(no_nested_certs); no_nested_inactive_certs = scheme_make_raw_pair(NULL, NULL); - SCHEME_SET_IMMUTABLE(no_nested_inactive_certs); - + no_nested_active_certs = scheme_make_raw_pair(NULL, NULL); + no_nested_certs = scheme_make_raw_pair(NULL, NULL); + SCHEME_SET_NO_INACTIVE_SUBS(no_nested_inactive_certs); + SCHEME_SET_NO_ACTIVE_SUBS(no_nested_active_certs); + SCHEME_SET_NO_INACTIVE_SUBS(no_nested_certs); + SCHEME_SET_NO_ACTIVE_SUBS(no_nested_certs); scheme_install_type_writer(scheme_free_id_info_type, write_free_id_info_prefix); scheme_install_type_reader2(scheme_free_id_info_type, read_free_id_info_prefix); @@ -2333,12 +2343,16 @@ static void phase_shift_certs(Scheme_Object *o, Scheme_Object *owner_wraps, int /* Even if icerts is NULL, may preserve the pair in ->certs, to indicate no nested inactive certs: */ { - int no_sub = (SCHEME_RPAIRP(((Scheme_Stx *)o)->certs) - && SCHEME_IMMUTABLEP(((Scheme_Stx *)o)->certs)); - if (icerts || no_sub) { + int no_ia_sub = (SCHEME_RPAIRP(((Scheme_Stx *)o)->certs) + && SCHEME_NO_INACTIVE_SUBS_P(((Scheme_Stx *)o)->certs)); + int no_a_sub = (SCHEME_RPAIRP(((Scheme_Stx *)o)->certs) + && SCHEME_NO_ACTIVE_SUBS_P(((Scheme_Stx *)o)->certs)); + if (icerts || no_ia_sub || no_a_sub) { nc = scheme_make_raw_pair((Scheme_Object *)acerts, (Scheme_Object *)icerts); - if (no_sub) - SCHEME_SET_IMMUTABLE(nc); + if (no_ia_sub) + SCHEME_SET_NO_INACTIVE_SUBS(nc); + if (no_a_sub) + SCHEME_SET_NO_ACTIVE_SUBS(nc); } else nc = (Scheme_Object *)acerts; @@ -2859,13 +2873,19 @@ static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Obj if (!active) { pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)orig_certs); res->certs = pr; - if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_IMMUTABLEP(stx->certs)) - SCHEME_SET_IMMUTABLE(pr); + if (stx->certs && SCHEME_RPAIRP(stx->certs)) { + if (SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_INACTIVE_SUBS(pr); + if (SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_ACTIVE_SUBS(pr); + } } else if (stx->certs && SCHEME_RPAIRP(stx->certs)) { pr = scheme_make_raw_pair((Scheme_Object *)orig_certs, SCHEME_CDR(stx->certs)); res->certs = pr; - if (SCHEME_IMMUTABLEP(stx->certs)) - SCHEME_SET_IMMUTABLE(pr); + if (SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_INACTIVE_SUBS(pr); + if (SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_ACTIVE_SUBS(pr); } else res->certs = (Scheme_Object *)orig_certs; stx = res; @@ -2884,7 +2904,6 @@ static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Obj Scheme_Object *scheme_stx_add_inactive_certs(Scheme_Object *o, Scheme_Object *certs) /* Also lifts existing inactive certs to the top. */ { - /* Lift inactive certs*/ o = lift_inactive_certs(o, 0); return add_certs(o, (Scheme_Cert *)certs, NULL, 0); @@ -2968,16 +2987,22 @@ Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env Scheme_Object *pr; pr = scheme_make_raw_pair((Scheme_Object *)cert, SCHEME_CDR(stx->certs)); res->certs = pr; - if (SCHEME_IMMUTABLEP(stx->certs)) - SCHEME_SET_IMMUTABLE(pr); + if (SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_INACTIVE_SUBS(pr); + if (SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_ACTIVE_SUBS(pr); } else res->certs = (Scheme_Object *)cert; } else { Scheme_Object *pr; pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)cert); res->certs = pr; - if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_IMMUTABLEP(stx->certs)) - SCHEME_SET_IMMUTABLE(pr); + if (stx->certs && SCHEME_RPAIRP(stx->certs)) { + if (SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_INACTIVE_SUBS(pr); + if (SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_ACTIVE_SUBS(pr); + } } o = (Scheme_Object *)res; @@ -3170,20 +3195,21 @@ Scheme_Object *scheme_stx_strip_module_context(Scheme_Object *_stx) } #ifdef DO_STACK_CHECK -static Scheme_Object *stx_activate_certs_k(void) +static Scheme_Object *stx_strip_certs_k(void) { Scheme_Thread *p = scheme_current_thread; Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; Scheme_Cert **cp = (Scheme_Cert **)p->ku.k.p2; + int active = p->ku.k.i1; p->ku.k.p1 = NULL; p->ku.k.p2 = NULL; - return stx_activate_certs(o, cp); + return stx_strip_certs(o, cp, active); } #endif -static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp) +static Scheme_Object *stx_strip_certs(Scheme_Object *o, Scheme_Cert **cp, int active) { #ifdef DO_STACK_CHECK { @@ -3195,7 +3221,8 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp) *_cp = *cp; p->ku.k.p1 = (void *)o; p->ku.k.p2 = (void *)_cp; - o = scheme_handle_stack_overflow(stx_activate_certs_k); + p->ku.k.i1 = active; + o = scheme_handle_stack_overflow(stx_strip_certs_k); *cp = *_cp; return o; } @@ -3205,8 +3232,8 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp) if (SCHEME_PAIRP(o)) { Scheme_Object *a, *d; - a = stx_activate_certs(SCHEME_CAR(o), cp); - d = stx_activate_certs(SCHEME_CDR(o), cp); + a = stx_strip_certs(SCHEME_CAR(o), cp, active); + d = stx_strip_certs(SCHEME_CDR(o), cp, active); if (SAME_OBJ(a, SCHEME_CAR(o)) && SAME_OBJ(d, SCHEME_CDR(o))) return o; @@ -3215,7 +3242,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp) return o; } else if (SCHEME_BOXP(o)) { Scheme_Object *c; - c = stx_activate_certs(SCHEME_BOX_VAL(o), cp); + c = stx_strip_certs(SCHEME_BOX_VAL(o), cp, active); if (SAME_OBJ(c, SCHEME_BOX_VAL(o))) return o; o = scheme_box(c); @@ -3226,7 +3253,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp) int size = SCHEME_VEC_SIZE(o), i, j; for (i = 0; i < size; i++) { - e = stx_activate_certs(SCHEME_VEC_ELS(o)[i], cp); + e = stx_strip_certs(SCHEME_VEC_ELS(o)[i], cp, active); if (!SAME_OBJ(e, SCHEME_VEC_ELS(o)[i])) break; } @@ -3241,7 +3268,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp) } SCHEME_VEC_ELS(v2)[i] = e; for (i++; i < size; i++) { - e = stx_activate_certs(SCHEME_VEC_ELS(o)[i], cp); + e = stx_strip_certs(SCHEME_VEC_ELS(o)[i], cp, active); SCHEME_VEC_ELS(v2)[i] = e; } @@ -3255,7 +3282,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp) j = scheme_hash_tree_next(ht, -1); while (j != -1) { scheme_hash_tree_index(ht, j, &key, &val); - e = stx_activate_certs(val, cp); + e = stx_strip_certs(val, cp, active); if (!SAME_OBJ(e, val)) break; j = scheme_hash_tree_next(ht, j); @@ -3277,7 +3304,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp) i = scheme_hash_tree_next(ht, i); while (i != -1) { scheme_hash_tree_index(ht, i, &key, &val); - val = stx_activate_certs(val, cp); + val = stx_strip_certs(val, cp, active); ht2 = scheme_hash_tree_set(ht2, key, val); i = scheme_hash_tree_next(ht, i); } @@ -3289,7 +3316,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp) int i, size = s->stype->num_slots; for (i = 0; i < size; i++) { - e = stx_activate_certs(s->slots[i], cp); + e = stx_strip_certs(s->slots[i], cp, active); if (!SAME_OBJ(e, s->slots[i])) break; } @@ -3301,7 +3328,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp) s->slots[i] = e; for (i++; i < size; i++) { - e = stx_activate_certs(s->slots[i], cp); + e = stx_strip_certs(s->slots[i], cp, active); s->slots[i] = e; } @@ -3309,17 +3336,18 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp) } else if (SCHEME_STXP(o)) { Scheme_Stx *stx = (Scheme_Stx *)o; - if (INACTIVE_CERTS(stx)) { - /* Change inactive certs to active certs. */ + if ((!active && INACTIVE_CERTS(stx)) + || (active && ACTIVE_CERTS(stx))) { Scheme_Object *np, *v; Scheme_Stx *res; Scheme_Cert *certs; - if (SCHEME_IMMUTABLEP(stx->certs)) { - /* No sub-object has other inactive certs */ + if ((!active && SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) + || (active && stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_NO_ACTIVE_SUBS_P(stx->certs))) { + /* No sub-object has other [in]active certs */ v = stx->val; } else { - v = stx_activate_certs(stx->val, cp); + v = stx_strip_certs(stx->val, cp, active); } res = (Scheme_Stx *)scheme_make_stx(v, @@ -3327,53 +3355,90 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp) stx->props); res->wraps = stx->wraps; res->u.lazy_prefix = stx->u.lazy_prefix; - if (!ACTIVE_CERTS(stx)) - np = no_nested_inactive_certs; - else { - np = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), NULL); - SCHEME_SET_IMMUTABLE(np); + if (!active) { + if (!ACTIVE_CERTS(stx)) { + if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) + np = no_nested_certs; + else + np = no_nested_inactive_certs; + } else { + np = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), NULL); + SCHEME_SET_NO_INACTIVE_SUBS(np); + if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_ACTIVE_SUBS(np); + } + } else { + if (!INACTIVE_CERTS(stx)) { + if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) + np = no_nested_certs; + else + np = no_nested_active_certs; + } else { + np = scheme_make_raw_pair(NULL, (Scheme_Object *)INACTIVE_CERTS(stx)); + SCHEME_SET_NO_ACTIVE_SUBS(np); + if (SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_INACTIVE_SUBS(np); + } } res->certs = np; - certs = append_certs(INACTIVE_CERTS(stx), *cp); + certs = append_certs((active ? ACTIVE_CERTS(stx) : INACTIVE_CERTS(stx)), *cp); *cp = certs; return (Scheme_Object *)res; - } else if (stx->certs && SCHEME_RPAIRP(stx->certs) - && SCHEME_IMMUTABLEP(stx->certs)) { - /* Explicit pair, but no inactive certs anywhere in this object. */ + } else if (stx->certs + && SCHEME_RPAIRP(stx->certs) + && (active + ? SCHEME_NO_ACTIVE_SUBS_P(stx->certs) + : SCHEME_NO_INACTIVE_SUBS_P(stx->certs))) { + /* Explicit pair, but no [in]active certs anywhere in this object. */ return (Scheme_Object *)stx; } else { - o = stx_activate_certs(stx->val, cp); + Scheme_Stx *res; + Scheme_Object *prev; + + o = stx_strip_certs(stx->val, cp, active); if (!SAME_OBJ(o, stx->val)) { - Scheme_Stx *res; res = (Scheme_Stx *)scheme_make_stx(o, stx->srcloc, stx->props); res->wraps = stx->wraps; res->u.lazy_prefix = stx->u.lazy_prefix; - if (ACTIVE_CERTS(stx)) { - Scheme_Object *np; - np = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), NULL); - res->certs = np; - SCHEME_SET_IMMUTABLE(np); - } else - res->certs = no_nested_inactive_certs; - - return (Scheme_Object *)res; } else { - /* Record the absence of certificates in sub-parts: */ - if (stx->certs) { - Scheme_Object *np; - np = scheme_make_raw_pair(stx->certs, NULL); - stx->certs = np; - SCHEME_SET_IMMUTABLE(np); - } else - stx->certs = no_nested_inactive_certs; - - return (Scheme_Object *)stx; + /* No new syntax object, but record the absence of certificates in + sub-parts: */ + res = stx; } + + prev = stx->certs; + if (!active) { + if (ACTIVE_CERTS(stx)) { + Scheme_Object *np; + np = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), NULL); + res->certs = np; + SCHEME_SET_NO_INACTIVE_SUBS(np); + if (prev && SCHEME_RPAIRP(prev) && SCHEME_NO_ACTIVE_SUBS_P(prev)) + SCHEME_SET_NO_ACTIVE_SUBS(np); + } else if (prev && SCHEME_RPAIRP(prev) && SCHEME_NO_ACTIVE_SUBS_P(prev)) + res->certs = no_nested_certs; + else + res->certs = no_nested_inactive_certs; + } else { + if (INACTIVE_CERTS(stx)) { + Scheme_Object *np; + np = scheme_make_raw_pair(NULL, (Scheme_Object *)INACTIVE_CERTS(stx)); + res->certs = np; + SCHEME_SET_NO_ACTIVE_SUBS(np); + if (prev && SCHEME_RPAIRP(prev) && SCHEME_NO_INACTIVE_SUBS_P(prev)) + SCHEME_SET_NO_INACTIVE_SUBS(np); + } else if (prev && SCHEME_RPAIRP(prev) && SCHEME_NO_INACTIVE_SUBS_P(prev)) + res->certs = no_nested_certs; + else + res->certs = no_nested_active_certs; + } + + return (Scheme_Object *)res; } } else return o; @@ -3383,9 +3448,7 @@ static Scheme_Object *lift_inactive_certs(Scheme_Object *o, int as_active) { Scheme_Cert *certs = NULL; - o = stx_activate_certs(o, &certs); - /* the inactive certs collected into `certs' - have been stripped from `o' at this point */ + o = stx_strip_certs(o, &certs, 0); if (certs) o = add_certs(o, certs, NULL, as_active); @@ -3398,6 +3461,22 @@ Scheme_Object *scheme_stx_activate_certs(Scheme_Object *o) return lift_inactive_certs(o, 1); } +Scheme_Object *scheme_stx_lift_active_certs(Scheme_Object *o) +{ + Scheme_Cert *certs = NULL; + Scheme_Stx *stx = (Scheme_Stx *)o; + + if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) + return o; + + o = stx_strip_certs(o, &certs, 1); + + if (certs) + o = add_certs(o, certs, NULL, 1); + + return o; +} + int scheme_stx_has_empty_wraps(Scheme_Object *o) { WRAP_POS awl;