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

change expand and local-expand to lift certificates

Browse Source 
svn: r17439
This commit is contained in:
Matthew Flatt 2009-12-30 17:27:38 +00:00
parent e9be5c92fe
commit e68aabd67a
9 changed files with 286 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/scribblings/guide/certificates.scrbl
View File

@ -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

21
collects/scribblings/reference/stx-certs.scrbl
View File

@ -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?]

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

@ -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

2
collects/typed-scheme/utils/require-contract.ss
View File

@ -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)

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

@ -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 *

56
src/mzscheme/src/fun.c
View File

@ -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);
{

14
src/mzscheme/src/module.c
View File

@ -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;

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

@ -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);

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

@ -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;