change expand and local-expand to lift certificates

svn: r17439

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

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,
+ @item{If the result has no @scheme['certify-mode] property value, but
-          but its datum is a pair, and if the syntax object
+          its datum is a pair, and if the syntax object corresponding
-          corresponding to the @scheme[car] of the pair is an
+          to the @scheme[car] of the pair is an identifier bound to
-          identifier bound to @scheme[begin], then the certificate is
+          @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?]

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

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)

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 *

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)
+      if (!trans) {
-	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);
+      }
     }
   }
 
@@ -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);
 
     {

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(15, with_continuation_mark_stx, stop, xenv);
-    scheme_set_local_syntax(16, with_continuation_mark_stx, stop, xenv);
+    scheme_set_local_syntax(16, letrec_syntaxes_stx, stop, xenv);
-    scheme_set_local_syntax(17, letrec_syntaxes_stx, stop, xenv);
+    scheme_set_local_syntax(17, var_ref_stx, stop, xenv);
-    scheme_set_local_syntax(18, var_ref_stx, stop, xenv);
+    scheme_set_local_syntax(18, expression_stx, stop, xenv);
-    scheme_set_local_syntax(19, expression_stx, stop, xenv);
   }
 
   first = scheme_null;

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

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); 
+    Use flags 0x1 and 02 to indicate no inactive or active certs in nested parts */
-            no inactive certs in nested parts (using the immutable flag as a hack!) */
 #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)
+      int no_ia_sub = (SCHEME_RPAIRP(((Scheme_Stx *)o)->certs)
-                    && SCHEME_IMMUTABLEP(((Scheme_Stx *)o)->certs));
+                       && SCHEME_NO_INACTIVE_SUBS_P(((Scheme_Stx *)o)->certs));
-      if (icerts || no_sub) {
+      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)
+        if (no_ia_sub)
-          SCHEME_SET_IMMUTABLE(nc);
+          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))
+      if (stx->certs && SCHEME_RPAIRP(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 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))
+      if (SCHEME_NO_INACTIVE_SUBS_P(stx->certs))
-        SCHEME_SET_IMMUTABLE(pr);
+        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))
+        if (SCHEME_NO_INACTIVE_SUBS_P(stx->certs))
-          SCHEME_SET_IMMUTABLE(pr);
+          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))
+      if (stx->certs && SCHEME_RPAIRP(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);
+      }
     }
     
     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);
+    a = stx_strip_certs(SCHEME_CAR(o), cp, active);
-    d = stx_activate_certs(SCHEME_CDR(o), cp);
+    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)) {
+    if ((!active && INACTIVE_CERTS(stx))
-      /* Change inactive certs to active certs. */
+        || (active && ACTIVE_CERTS(stx))) {
       Scheme_Object *np, *v;
       Scheme_Stx *res;
       Scheme_Cert *certs;
 
-      if (SCHEME_IMMUTABLEP(stx->certs)) {
+      if ((!active && SCHEME_NO_INACTIVE_SUBS_P(stx->certs))
-        /* No sub-object has other inactive 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))
+      if (!active) {
-        np = no_nested_inactive_certs;
+        if (!ACTIVE_CERTS(stx)) {
-      else {
+          if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_NO_ACTIVE_SUBS_P(stx->certs))
-        np = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), NULL);
+            np = no_nested_certs;
-        SCHEME_SET_IMMUTABLE(np);
+          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) 
+    } else if (stx->certs 
-               && SCHEME_IMMUTABLEP(stx->certs)) {
+               && SCHEME_RPAIRP(stx->certs) 
-      /* Explicit pair, but no inactive certs anywhere in this object. */
+               && (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: */
+        /* No new syntax object, but record the absence of certificates in 
-	if (stx->certs) {
+           sub-parts: */
-	  Scheme_Object *np;
+        res = stx;
-	  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;
       }
+
+      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);
+  o = stx_strip_certs(o, &certs, 0);
-  /* the inactive certs collected into `certs'
-     have been stripped from `o' at this point */
 
   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;