Back to index

plt-scheme  4.2.1
stxobj.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 2000-2001 Matthew Flatt
00005  
00006     This library is free software; you can redistribute it and/or
00007     modify it under the terms of the GNU Library General Public
00008     License as published by the Free Software Foundation; either
00009     version 2 of the License, or (at your option) any later version.
00010 
00011     This library is distributed in the hope that it will be useful,
00012     but WITHOUT ANY WARRANTY; without even the implied warranty of
00013     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00014     Library General Public License for more details.
00015 
00016     You should have received a copy of the GNU Library General Public
00017     License along with this library; if not, write to the Free
00018     Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
00019     Boston, MA 02110-1301 USA.
00020 */
00021 
00022 #include "schpriv.h"
00023 #include "schmach.h"
00024 
00025 /* The implementation of syntax objects is extremely complex due to
00026    two levels of optimization:
00027 
00028     1. Different kinds of binding are handled in different ways,
00029        because they'll have different usage patterns. For example,
00030        module-level bindings are handled differently than local
00031        bindings, because modules can't be nested.
00032 
00033     2. To save time and space, the data structures involved have lots
00034        of caches, and syntax objects to be marshaled undergo a
00035        simplification pass.
00036 
00037    In addition, the need to marshal syntax objects to bytecode
00038    introduces some other complications. */
00039 
00040 Scheme_Object *scheme_datum_to_syntax_proc;
00041 
00042 static Scheme_Object *syntax_p(int argc, Scheme_Object **argv);
00043 
00044 static Scheme_Object *syntax_to_datum(int argc, Scheme_Object **argv);
00045 static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv);
00046 
00047 static Scheme_Object *syntax_line(int argc, Scheme_Object **argv);
00048 static Scheme_Object *syntax_col(int argc, Scheme_Object **argv);
00049 static Scheme_Object *syntax_pos(int argc, Scheme_Object **argv);
00050 static Scheme_Object *syntax_span(int argc, Scheme_Object **argv);
00051 static Scheme_Object *syntax_src(int argc, Scheme_Object **argv);
00052 static Scheme_Object *syntax_to_list(int argc, Scheme_Object **argv);
00053 
00054 static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv);
00055 static Scheme_Object *syntax_property(int argc, Scheme_Object **argv);
00056 static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv);
00057 static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv);
00058 
00059 static Scheme_Object *bound_eq(int argc, Scheme_Object **argv);
00060 static Scheme_Object *module_eq(int argc, Scheme_Object **argv);
00061 static Scheme_Object *module_trans_eq(int argc, Scheme_Object **argv);
00062 static Scheme_Object *module_templ_eq(int argc, Scheme_Object **argv);
00063 static Scheme_Object *module_label_eq(int argc, Scheme_Object **argv);
00064 static Scheme_Object *module_binding(int argc, Scheme_Object **argv);
00065 static Scheme_Object *module_trans_binding(int argc, Scheme_Object **argv);
00066 static Scheme_Object *module_templ_binding(int argc, Scheme_Object **argv);
00067 static Scheme_Object *module_label_binding(int argc, Scheme_Object **argv);
00068 static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv);
00069 static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv);
00070 
00071 static Scheme_Object *syntax_recertify(int argc, Scheme_Object **argv);
00072 
00073 static Scheme_Object *lift_inactive_certs(Scheme_Object *o, int as_active);
00074 
00075 static Scheme_Object *write_free_id_info_prefix(Scheme_Object *obj);
00076 static Scheme_Object *read_free_id_info_prefix(Scheme_Object *obj);
00077 
00078 static Scheme_Object *source_symbol; /* uninterned! */
00079 static Scheme_Object *share_symbol; /* uninterned! */
00080 static Scheme_Object *origin_symbol;
00081 static Scheme_Object *lexical_symbol;
00082 static Scheme_Object *protected_symbol;
00083 static Scheme_Object *nominal_id_symbol;
00084 
00085 static THREAD_LOCAL Scheme_Object *nominal_ipair_cache;
00086 
00087 static THREAD_LOCAL Scheme_Object *mark_id = scheme_make_integer(0);
00088 static THREAD_LOCAL Scheme_Object *current_rib_timestamp = scheme_make_integer(0);
00089 
00090 static Scheme_Stx_Srcloc *empty_srcloc;
00091 
00092 static Scheme_Object *empty_simplified;
00093 
00094 static Scheme_Hash_Table *empty_hash_table;
00095 static THREAD_LOCAL Scheme_Hash_Table *quick_hash_table;
00096 
00097 static THREAD_LOCAL Scheme_Object *last_phase_shift;
00098 
00099 static THREAD_LOCAL Scheme_Object *unsealed_dependencies;
00100 
00101 static THREAD_LOCAL Scheme_Hash_Table *id_marks_ht; /* a cache */
00102 static THREAD_LOCAL Scheme_Hash_Table *than_id_marks_ht; /* a cache */
00103 
00104 static THREAD_LOCAL Scheme_Bucket_Table *interned_skip_ribs;
00105 
00106 static Scheme_Object *no_nested_inactive_certs;
00107 
00108 #ifdef MZ_PRECISE_GC
00109 static void register_traversers(void);
00110 #endif
00111 
00112 static int includes_mark(Scheme_Object *wraps, Scheme_Object *mark);
00113 static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks);
00114 static struct Scheme_Cert *cons_cert(Scheme_Object *mark, Scheme_Object *modidx, 
00115                                  Scheme_Object *insp, Scheme_Object *key, 
00116                                  struct Scheme_Cert *next_cert);
00117 static void phase_shift_certs(Scheme_Object *o, Scheme_Object *owner_wraps, int len);
00118 static void preemptive_chunk(Scheme_Stx *stx);
00119 
00120 #define CONS scheme_make_pair
00121 #define ICONS scheme_make_pair
00122 
00123 #define HAS_SUBSTX(obj) (SCHEME_PAIRP(obj) || SCHEME_VECTORP(obj) || SCHEME_BOXP(obj) || prefab_p(obj) || SCHEME_HASHTRP(obj))
00124 
00125 XFORM_NONGCING static int prefab_p(Scheme_Object *o)
00126 {
00127   if (SCHEME_STRUCTP(o)) {
00128     if (((Scheme_Structure *)o)->stype->prefab_key)
00129       if (MZ_OPT_HASH_KEY(&((Scheme_Structure *)o)->stype->iso) & STRUCT_TYPE_ALL_IMMUTABLE)
00130         return 1;
00131   }
00132   return 0;
00133 }
00134 
00135 #define STX_KEY(stx) MZ_OPT_HASH_KEY(&(stx)->iso)
00136 
00137 typedef struct Module_Renames {
00138   Scheme_Object so; /* scheme_rename_table_type */
00139   char kind, needs_unmarshal;
00140   char sealed; /* 1 means bound won't change; 2 means unbound won't change, either */
00141   Scheme_Object *phase;
00142   Scheme_Object *set_identity;
00143   Scheme_Hash_Table *ht; /* localname ->  modidx  OR
00144                                           (cons modidx exportname) OR
00145                                           (cons modidx nominal_modidx) OR
00146                                           (list* modidx exportname nominal_modidx_plus_phase nominal_exportname) OR
00147                                           (list* modidx mod-phase exportname nominal_modidx_plus_phase nominal_exportname) OR
00148                                           (cons insp localname)
00149                             nominal_modix_plus_phase -> nominal_modix | (cons nominal_modix import_phase_plus_nominal_phase)
00150                             import_phase_plus_nominal_phase -> import-phase-index | (cons import-phase-index nom-phase) */
00151   Scheme_Hash_Table *nomarshal_ht; /* like ht, but dropped on marshal */
00152   Scheme_Object *shared_pes; /* list of (cons modidx (cons phase_export phase_and_marks))
00153                                   phase_and_marks -> phase-index-int OR
00154                                                      (cons (nonempty-listof mark) phase-index-int)
00155                                 like nomarshal ht, but shared from provider */
00156   Scheme_Hash_Table *marked_names; /* shared with module environment while compiling the module;
00157                                   this table maps a top-level-bound identifier with a non-empty mark
00158                                   set to a gensym created for the binding */
00159   Scheme_Object *unmarshal_info; /* stores some renamings as infomation needed to consult
00160                                 imported modules and restore renames from their exports */
00161   Scheme_Hash_Table *free_id_renames; /* like `ht', but only for free-id=? checking,
00162                                          and targets can also include:
00163                                             id => resolve id (but cache if possible; never appears after simplifying)
00164                                             (box (cons sym #f)) => top-level binding
00165                                             (box (cons sym sym)) => lexical binding */
00166 } Module_Renames;
00167 
00168 typedef struct Module_Renames_Set {
00169   Scheme_Object so; /* scheme_rename_table_set_type */
00170   char kind, sealed;
00171   Scheme_Object *set_identity;
00172   Module_Renames *rt, *et;
00173   Scheme_Hash_Table *other_phases;
00174   Scheme_Object *share_marked_names; /* a Module_Renames_Set */
00175 } Module_Renames_Set;
00176 
00177 typedef struct Scheme_Cert {
00178   Scheme_Inclhash_Object iso;
00179   Scheme_Object *mark;
00180   Scheme_Object *modidx;
00181   Scheme_Object *insp;
00182   Scheme_Object *key;
00183   Scheme_Object *mapped; /* Indicates which mark+key combinations are in
00184                          this chain. The table is created for every 16
00185                          items in the list. For a power of 2, all items
00186                          in the rest of the chain are in the table, and
00187                          the "next" pointer is NULL. For 2^n + 2^m, then
00188                             2^m items are in the table, and so on. Overall, the
00189                          chain's total size if O(n * lg n) for a chain of
00190                          length n, and lookup for a mark+key pair is
00191                          O(lg n). */
00192   int depth;
00193   struct Scheme_Cert *next;
00194 } Scheme_Cert;
00195 
00196 #define CERT_NO_KEY(c) (MZ_OPT_HASH_KEY(&(c)->iso) & 0x1)
00197 #define CERT_SET_NO_KEY(c) (MZ_OPT_HASH_KEY(&(c)->iso) |= 0x1)
00198 
00199 /* Certs encoding:
00200     - NULL: no inactive or active certs; 
00201             maybe inactive certs in nested parts
00202     - rcons(c1, c2): active certs c1 (maybe NULL), inactive certs c2 (maybe NULL); 
00203             maybe inactive certs in nested parts 
00204     - immutable-rcons(c1, c2): active certs c1 (maybe NULL), inactive certs c2 (maybe NULL); 
00205             no inactive certs in nested parts (using the immutable flag as a hack!) */
00206 #define ACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CAR((stx)->certs) : (stx)->certs) : NULL))
00207 #define INACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CDR((stx)->certs) : NULL) : NULL))
00208 static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp);
00209 
00210 #define SCHEME_RENAME_LEN(vec)  ((SCHEME_VEC_SIZE(vec) - 2) >> 1)
00211 
00212 typedef struct Scheme_Lexical_Rib {
00213   Scheme_Object so;
00214   Scheme_Object *rename; /* a vector for a lexical rename */
00215   Scheme_Object *timestamp;
00216   int *sealed;
00217   struct Scheme_Lexical_Rib *next;
00218 } Scheme_Lexical_Rib;
00219 
00220 static Module_Renames *krn;
00221 
00222 #define SCHEME_RENAMESP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rename_table_type))
00223 #define SCHEME_RENAMES_SETP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rename_table_set_type))
00224 
00225 #define SCHEME_MODIDXP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_module_index_type))
00226 #define SCHEME_RIB_DELIMP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rib_delimiter_type))
00227 
00228 #define SCHEME_PRUNEP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_prune_context_type))
00229 
00230 XFORM_NONGCING static int is_member(Scheme_Object *a, Scheme_Object *l)
00231 {
00232   while (SCHEME_PAIRP(l)) {
00233     if (SAME_OBJ(a, SCHEME_CAR(l)))
00234       return 1;
00235     l = SCHEME_CDR(l);
00236   }
00237   return 0;
00238 }
00239 
00240 static int is_rename_inspector_info(Scheme_Object *v)
00241 {
00242   return (SAME_TYPE(SCHEME_TYPE(v), scheme_inspector_type)
00243           || (SCHEME_PAIRP(v)
00244               && SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(v)), scheme_inspector_type)
00245               && SAME_TYPE(SCHEME_TYPE(SCHEME_CDR(v)), scheme_inspector_type)));
00246 }
00247 
00248 /* Wraps:
00249 
00250    A wrap is a list of wrap-elems and wrap-chunks. A wrap-chunk is a
00251    "vector" (a scheme_wrap_chunk_type) of wrap-elems.
00252 
00253    Each wrap-elem has one of several shapes:
00254 
00255    - A wrap-elem <+num> is a mark
00256 
00257    - A wrap-elem <-num> is a certificate-only mark (doesn't conttribute to
00258        id equivalence)
00259 
00260    - A wrap-elem (vector <sym> <ht> <stx> ... <recur-state> ...) is a lexical rename
00261                          env  (sym   var      <var-resolved>:
00262                               ->pos)           void => not yet computed
00263                               or #f            sym => var-resolved is answer to replace #f
00264                                                       for nozero skipped ribs
00265                                                (rlistof (rcons skipped sym)) => generalization of sym
00266                                                (mcons var-resolved next) => depends on unsealed rib,
00267                                                       will be cleared when rib set
00268                                               or:
00269                                                (cons <var-resolved> (cons <id> <phase>)) =>
00270                                                       free-id=? renaming to <id> on match
00271    - A wrap-elem (vector <free-id-renames?> <ht> <sym> ... <sym> ...) is also a lexical rename
00272                                bool               var       resolved: sym or (cons <sym> <bind-info>), 
00273                                                              where <bind-info> is module/lexical binding info:
00274                                                               (cons <sym> #f) => top-level binding
00275                                                               (cons <sym> <sym>) => lexical binding
00276                                                               (free-eq-info ...) => module-binding
00277          where the variables have already been resolved and filtered (no mark
00278          or lexical-env comparison needed with the remaining wraps)
00279 
00280    - A wrap-elem (make-rib vector rib)
00281          is an extensible set of lexical renames; it is the same as
00282          having the vectors inline in place of the rib, except that
00283          new vectors can be added imperatively; simplification turns this
00284         into a vector
00285 
00286    - A wrap-elem (make-rib-delimiter <list-of-rib>)
00287          appears in pairs around rib elements; the deeper is just a
00288          bracket, while the shallow one contains a non-empty list of
00289          ribs; for each environment name defined within the set of
00290          ribs, no rib within the set can build on a binding to that
00291          environment past the end delimiter; this is used by `local-expand'
00292          when given a list of ribs, and simplifcation eliminates
00293          rib delimiters
00294 
00295    - A wrap-elem (make-prune <sym>)
00296          restricts binding information to that relevant for <sym>
00297          as a datum
00298 
00299    - A wrap-elem <rename-table> is a module rename set
00300          the hash table maps renamed syms to modname-srcname pairs
00301 
00302    - A wrap-elem <rename-table-set> is a set of <rename-table>s for
00303          different phases.
00304 
00305    - A wrap-elem <hash-table> is a chain-specific cache; it maps
00306          identifiers to #t, and 0 to a deeper part of the chain; a
00307          resolution for an identifier can safely skip to the deeper
00308          part if the identifer does not have a mapping; this skips
00309          simple lexical renames (not ribs) and marks, only, and it's
00310          inserted into a chain heuristically
00311 
00312    - A wrap-elem (box (vector <num> <midx> <midx> <export-registry>))
00313          is a phase shift by <num>, remapping the first <midx> to the 
00314          second <midx>; the <export-registry> part is for finding
00315          modules to unmarshal import renamings
00316 
00317      [Don't add a pair case, because sometimes we test for element 
00318       versus list-of-element.]
00319 
00320   The lazy_prefix field of a syntax object keeps track of how many of
00321   the first wraps (items and chunks in the list) need to be propagated
00322   to sub-syntax.  */
00323 
00324 #define IS_POSMARK(x) (SCHEME_INTP(x) ? (SCHEME_INT_VAL(x) >= 0) : SCHEME_BIGPOS(x))
00325 #define SCHEME_MARKP(x) (SCHEME_INTP(x) || SCHEME_BIGNUMP(x))
00326 
00327 XFORM_NONGCING static int nom_mod_p(Scheme_Object *p)
00328 {
00329   p = SCHEME_CDR(p);
00330   return !SCHEME_PAIRP(p) && !SCHEME_SYMBOLP(p);
00331 }
00332 
00333 /*========================================================================*/
00334 /*                            wrap chunks                                 */
00335 /*========================================================================*/
00336 
00337 typedef struct {
00338   Scheme_Type type;
00339   mzshort len;
00340   Scheme_Object *a[1];
00341 } Wrap_Chunk;
00342 
00343 #define MALLOC_WRAP_CHUNK(n) (Wrap_Chunk *)scheme_malloc_tagged(sizeof(Wrap_Chunk) + ((n - 1) * sizeof(Scheme_Object *)))
00344 
00345 /* Macros for iterating over the elements of a wrap. */
00346 
00347 typedef struct {
00348   Scheme_Object *l;
00349   Scheme_Object *a;
00350   int is_limb;
00351   int pos;
00352 } Wrap_Pos;
00353 
00354 XFORM_NONGCING static void WRAP_POS_SET_FIRST(Wrap_Pos *w)
00355 {
00356   if (!SCHEME_NULLP(w->l)) {
00357     Scheme_Object *a;
00358     a = SCHEME_CAR(w->l);
00359     if (SCHEME_TYPE(a) == scheme_wrap_chunk_type) {
00360       w->is_limb = 1;
00361       w->pos = 0;
00362       w->a = ((Wrap_Chunk *)a)->a[0];
00363     } else {
00364       w->is_limb = 0;
00365       w->a = a;
00366     }
00367   }
00368 }
00369 
00370 XFORM_NONGCING static MZ_INLINE void DO_WRAP_POS_INC(Wrap_Pos *w)
00371 {
00372   Scheme_Object *a;
00373   if (w->is_limb && (w->pos + 1 < ((Wrap_Chunk *)SCHEME_CAR(w->l))->len)) {
00374     a = SCHEME_CAR(w->l);
00375     w->pos++;
00376     w->a = ((Wrap_Chunk *)a)->a[w->pos];
00377   } else {
00378     w->l = SCHEME_CDR(w->l);
00379     if (!SCHEME_NULLP(w->l)) {
00380       a = SCHEME_CAR(w->l);
00381       if (SCHEME_TYPE(a) == scheme_wrap_chunk_type) {
00382        w->is_limb = 1;
00383        w->pos = 0;
00384        w->a = ((Wrap_Chunk *)a)->a[0];
00385       } else {
00386        w->is_limb = 0;
00387        w->a = a;
00388       }
00389     } else
00390       w->is_limb = 0;
00391   }
00392 }
00393 
00394 #define WRAP_POS Wrap_Pos
00395 #define WRAP_POS_INIT(w, wr) w.l = wr; WRAP_POS_SET_FIRST(&w)
00396 
00397 #define WRAP_POS_INC(w) DO_WRAP_POS_INC(&w)
00398 
00399 #define WRAP_POS_INIT_END(w) (w.l = scheme_null, w.a = NULL, w.is_limb = 0, w.pos = 0)
00400 #define WRAP_POS_END_P(w) SCHEME_NULLP(w.l)
00401 #define WRAP_POS_FIRST(w) w.a
00402 #define WRAP_POS_COPY(w, w2) w.l = (w2).l; w.a = (w2).a; w.is_limb= (w2).is_limb; w.pos = (w2).pos
00403 
00404 /* Walking backwards through one chunk: */
00405 
00406 XFORM_NONGCING static void DO_WRAP_POS_REVINIT(Wrap_Pos *w, Scheme_Object *k)
00407 {
00408   Scheme_Object *a;
00409   a = SCHEME_CAR(k);
00410   if (SCHEME_TYPE(a) == scheme_wrap_chunk_type) {
00411     w->is_limb = 1;
00412     w->l = k;
00413     w->pos = ((Wrap_Chunk *)a)->len - 1;
00414     w->a = ((Wrap_Chunk *)a)->a[w->pos];
00415   } else {
00416     w->l = k;
00417     w->a = a;
00418     w->is_limb = 0;
00419     w->pos = 0;
00420   }
00421 }
00422 
00423 #define WRAP_POS_KEY(w) w.l
00424 #define WRAP_POS_REVINIT(w, k) DO_WRAP_POS_REVINIT(&w, k)
00425 #define WRAP_POS_REVEND_P(w) (w.pos < 0)
00426 #define WRAP_POS_DEC(w) --w.pos; if (w.pos >= 0) w.a = ((Wrap_Chunk *)SCHEME_CAR(w.l))->a[w.pos]
00427 
00428 #define WRAP_POS_PLAIN_TAIL(w) (w.is_limb ? (w.pos ? NULL : w.l) : w.l)
00429 
00430 /*========================================================================*/
00431 /*                           initialization                               */
00432 /*========================================================================*/
00433 
00434 void scheme_init_stx(Scheme_Env *env)
00435 {
00436   Scheme_Object *p;
00437 
00438 #ifdef MZ_PRECISE_GC
00439   register_traversers();
00440 #endif
00441 
00442   p = scheme_make_folding_prim(syntax_p, "syntax?", 1, 1, 1);
00443   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00444   scheme_add_global_constant("syntax?", p, env);
00445 
00446   scheme_add_global_constant("syntax->datum", 
00447                           scheme_make_folding_prim(syntax_to_datum,
00448                                                 "syntax->datum",
00449                                                 1, 1, 1),
00450                           env);
00451   
00452   REGISTER_SO(scheme_datum_to_syntax_proc);
00453   scheme_datum_to_syntax_proc = scheme_make_folding_prim(datum_to_syntax,
00454                                                   "datum->syntax",
00455                                                   2, 5, 1);
00456   scheme_add_global_constant("datum->syntax", 
00457                           scheme_datum_to_syntax_proc,
00458                           env);
00459 
00460   
00461   p = scheme_make_folding_prim(scheme_checked_syntax_e, "syntax-e", 1, 1, 1);
00462   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00463   scheme_add_global_constant("syntax-e", p, env);
00464 
00465   scheme_add_global_constant("syntax-line", 
00466                           scheme_make_folding_prim(syntax_line,
00467                                                 "syntax-line",
00468                                                 1, 1, 1),
00469                           env);
00470   scheme_add_global_constant("syntax-column", 
00471                           scheme_make_folding_prim(syntax_col,
00472                                                 "syntax-column",
00473                                                 1, 1, 1),
00474                           env);
00475   scheme_add_global_constant("syntax-position", 
00476                           scheme_make_folding_prim(syntax_pos,
00477                                                 "syntax-position",
00478                                                 1, 1, 1),
00479                           env);
00480   scheme_add_global_constant("syntax-span", 
00481                           scheme_make_folding_prim(syntax_span,
00482                                                 "syntax-span",
00483                                                 1, 1, 1),
00484                           env);
00485   scheme_add_global_constant("syntax-source", 
00486                           scheme_make_folding_prim(syntax_src,
00487                                                 "syntax-source",
00488                                                 1, 1, 1),
00489                           env);
00490   scheme_add_global_constant("syntax->list", 
00491                           scheme_make_folding_prim(syntax_to_list,
00492                                                 "syntax->list",
00493                                                 1, 1, 1),
00494                           env);
00495 
00496   scheme_add_global_constant("syntax-original?", 
00497                           scheme_make_immed_prim(syntax_original_p,
00498                                               "syntax-original?",
00499                                               1, 1),
00500                           env);
00501   scheme_add_global_constant("syntax-property", 
00502                           scheme_make_immed_prim(syntax_property,
00503                                               "syntax-property",
00504                                               2, 3),
00505                           env);
00506   scheme_add_global_constant("syntax-property-symbol-keys", 
00507                           scheme_make_immed_prim(syntax_property_keys,
00508                                               "syntax-property-symbol-keys",
00509                                               1, 1),
00510                           env);
00511 
00512   scheme_add_global_constant("syntax-track-origin", 
00513                           scheme_make_immed_prim(syntax_track_origin,
00514                                               "syntax-track-origin",
00515                                               3, 3),
00516                           env);
00517 
00518   scheme_add_global_constant("make-syntax-delta-introducer", 
00519                           scheme_make_immed_prim(scheme_syntax_make_transfer_intro,
00520                                               "make-syntax-delta-introducer",
00521                                               2, 3),
00522                           env);
00523 
00524   scheme_add_global_constant("bound-identifier=?", 
00525                           scheme_make_immed_prim(bound_eq,
00526                                               "bound-identifier=?",
00527                                               2, 3),
00528                           env);
00529   scheme_add_global_constant("free-identifier=?", 
00530                           scheme_make_immed_prim(module_eq,
00531                                               "free-identifier=?",
00532                                               2, 3),
00533                           env);
00534   scheme_add_global_constant("free-transformer-identifier=?", 
00535                           scheme_make_immed_prim(module_trans_eq,
00536                                               "free-transformer-identifier=?",
00537                                               2, 2),
00538                           env);
00539   scheme_add_global_constant("free-template-identifier=?", 
00540                           scheme_make_immed_prim(module_templ_eq,
00541                                               "free-template-identifier=?",
00542                                               2, 2),
00543                           env);
00544   scheme_add_global_constant("free-label-identifier=?", 
00545                           scheme_make_immed_prim(module_label_eq,
00546                                               "free-label-identifier=?",
00547                                               2, 2),
00548                           env);
00549 
00550   scheme_add_global_constant("identifier-binding", 
00551                           scheme_make_immed_prim(module_binding,
00552                                               "identifier-binding",
00553                                               1, 2),
00554                           env);
00555   scheme_add_global_constant("identifier-transformer-binding", 
00556                           scheme_make_immed_prim(module_trans_binding,
00557                                               "identifier-transformer-binding",
00558                                               1, 2),
00559                           env);
00560   scheme_add_global_constant("identifier-template-binding", 
00561                           scheme_make_immed_prim(module_templ_binding,
00562                                               "identifier-template-binding",
00563                                               1, 1),
00564                           env);
00565   scheme_add_global_constant("identifier-label-binding", 
00566                           scheme_make_immed_prim(module_label_binding,
00567                                               "identifier-label-binding",
00568                                               1, 1),
00569                           env);
00570   scheme_add_global_constant("identifier-prune-lexical-context", 
00571                           scheme_make_immed_prim(identifier_prune,
00572                                               "identifier-prune-lexical-context",
00573                                               1, 2),
00574                           env);
00575 
00576 
00577   scheme_add_global_constant("syntax-source-module", 
00578                           scheme_make_folding_prim(syntax_src_module,
00579                                                 "syntax-source-module",
00580                                                 1, 1, 1),
00581                           env);
00582 
00583   scheme_add_global_constant("syntax-recertify", 
00584                           scheme_make_immed_prim(syntax_recertify,
00585                                               "syntax-recertify",
00586                                               4, 4),
00587                           env);
00588 
00589   REGISTER_SO(source_symbol);
00590   REGISTER_SO(share_symbol);
00591   REGISTER_SO(origin_symbol);
00592   REGISTER_SO(lexical_symbol);
00593   REGISTER_SO(protected_symbol);
00594   REGISTER_SO(nominal_id_symbol);
00595   source_symbol = scheme_make_symbol("source"); /* not interned! */
00596   share_symbol = scheme_make_symbol("share"); /* not interned! */
00597   origin_symbol = scheme_intern_symbol("origin");
00598   lexical_symbol = scheme_intern_symbol("lexical");
00599   protected_symbol = scheme_intern_symbol("protected");
00600   nominal_id_symbol = scheme_intern_symbol("nominal-id");
00601 
00602   REGISTER_SO(mark_id);
00603 
00604   REGISTER_SO(empty_srcloc);
00605   empty_srcloc = MALLOC_ONE_RT(Scheme_Stx_Srcloc);
00606 #ifdef MZTAG_REQUIRED
00607   empty_srcloc->type = scheme_rt_srcloc;
00608 #endif
00609   empty_srcloc->src = scheme_false;
00610   empty_srcloc->line = -1;
00611   empty_srcloc->col = -1;
00612   empty_srcloc->pos = -1;
00613 
00614   REGISTER_SO(empty_simplified);
00615   empty_simplified = scheme_make_vector(2, scheme_false);
00616 
00617   REGISTER_SO(nominal_ipair_cache);
00618 
00619   REGISTER_SO(quick_hash_table);
00620 
00621   REGISTER_SO(last_phase_shift);
00622 
00623   REGISTER_SO(empty_hash_table);
00624   empty_hash_table = scheme_make_hash_table(SCHEME_hash_ptr);
00625 
00626   REGISTER_SO(no_nested_inactive_certs);
00627   no_nested_inactive_certs = scheme_make_raw_pair(NULL, NULL);
00628   SCHEME_SET_IMMUTABLE(no_nested_inactive_certs);
00629 
00630   REGISTER_SO(unsealed_dependencies);
00631 
00632   scheme_install_type_writer(scheme_free_id_info_type, write_free_id_info_prefix);
00633   scheme_install_type_reader(scheme_free_id_info_type, read_free_id_info_prefix);
00634 }
00635 
00636 void scheme_init_stx_places() {
00637   REGISTER_SO(id_marks_ht);
00638   REGISTER_SO(than_id_marks_ht);
00639   REGISTER_SO(interned_skip_ribs);
00640   interned_skip_ribs = scheme_make_weak_equal_table();
00641 }
00642 
00643 /*========================================================================*/
00644 /*                       stx creation and maintenance                     */
00645 /*========================================================================*/
00646 
00647 Scheme_Object *scheme_make_stx(Scheme_Object *val, 
00648                             Scheme_Stx_Srcloc *srcloc,
00649                             Scheme_Object *props)
00650 {
00651   Scheme_Stx *stx;
00652 
00653   stx = MALLOC_ONE_TAGGED(Scheme_Stx);
00654   stx->iso.so.type = scheme_stx_type;
00655   STX_KEY(stx) = HAS_SUBSTX(val) ? STX_SUBSTX_FLAG : 0;
00656   stx->val = val;
00657   stx->srcloc = srcloc;
00658   stx->wraps = scheme_null;
00659   stx->props = props;
00660 
00661   return (Scheme_Object *)stx;
00662 }
00663 
00664 Scheme_Object *scheme_make_stx_w_offset(Scheme_Object *val, 
00665                                    long line, long col, long pos, long span,
00666                                    Scheme_Object *src,
00667                                    Scheme_Object *props)
00668 {
00669   Scheme_Stx_Srcloc *srcloc;
00670 
00671   srcloc = MALLOC_ONE_RT(Scheme_Stx_Srcloc);
00672 #ifdef MZTAG_REQUIRED
00673   srcloc->type = scheme_rt_srcloc;
00674 #endif
00675   srcloc->src = src;
00676   srcloc->line = line;
00677   srcloc->col = col;
00678   srcloc->pos = pos;
00679   srcloc->span = span;
00680    
00681   return scheme_make_stx(val, srcloc, props);
00682 }
00683 
00684 Scheme_Object *scheme_make_renamed_stx(Scheme_Object *sym, 
00685                                    Scheme_Object *rn)
00686 {
00687   Scheme_Object *stx;
00688 
00689   stx = scheme_make_stx(sym, empty_srcloc, NULL);
00690 
00691   if (rn) {
00692     rn = scheme_make_pair(rn, scheme_null);
00693     ((Scheme_Stx *)stx)->wraps = rn;
00694   }
00695 
00696   return stx;
00697 }
00698 
00699 Scheme_Object *scheme_stx_track(Scheme_Object *naya, 
00700                             Scheme_Object *old,
00701                             Scheme_Object *origin)
00702      /* Maintain properties for an expanded expression */
00703 {
00704   Scheme_Stx *nstx = (Scheme_Stx *)naya;
00705   Scheme_Stx *ostx = (Scheme_Stx *)old;
00706   Scheme_Object *ne, *oe, *e1, *e2;
00707   Scheme_Object *certs;
00708   Scheme_Object *wraps, *modinfo_cache;
00709   long lazy_prefix;
00710 
00711   if (nstx->props) {
00712     if (SAME_OBJ(nstx->props, STX_SRCTAG)) {
00713       /* Retain 'source tag. */
00714       ne = ICONS(ICONS(source_symbol, scheme_true), scheme_null);
00715     } else
00716       ne = nstx->props;
00717   } else
00718     ne = scheme_null;
00719   
00720   if (ostx->props) {
00721     if (SAME_OBJ(ostx->props, STX_SRCTAG)) {
00722       /* Drop 'source, add 'origin. */
00723       oe = NULL;
00724     } else {
00725       Scheme_Object *p, *a;
00726       int mod = 0, add = 1;
00727 
00728       oe = ostx->props;
00729 
00730       /* Drop 'source and 'share, add 'origin if not there */
00731       for (p = oe; SCHEME_PAIRP(p); p = SCHEME_CDR(p)) {
00732        a = SCHEME_CAR(SCHEME_CAR(p));
00733        if (SAME_OBJ(a, source_symbol) || SAME_OBJ(a, share_symbol))
00734          mod = 1;
00735        else if (SAME_OBJ(a, origin_symbol))
00736          mod = 1;
00737       }
00738 
00739       if (mod) {
00740        Scheme_Object *first = scheme_null, *last = NULL;
00741 
00742        for (; SCHEME_PAIRP(oe); oe = SCHEME_CDR(oe)) {
00743          a = SCHEME_CAR(SCHEME_CAR(oe));
00744          if (!SAME_OBJ(a, source_symbol) && !SAME_OBJ(a, share_symbol)) {
00745            if (!SAME_OBJ(a, origin_symbol)) {
00746              p = ICONS(SCHEME_CAR(oe), scheme_null);
00747            } else {
00748              p = ICONS(ICONS(a, ICONS(origin, 
00749                                    SCHEME_CDR(SCHEME_CAR(oe)))),
00750                      scheme_null);
00751              add = 0;
00752            }
00753 
00754            if (last)
00755              SCHEME_CDR(last) = p;
00756            else
00757              first = p;
00758            last = p;
00759          }
00760        }
00761 
00762        oe = first;
00763       } 
00764       if (add) {
00765        oe = ICONS(ICONS(origin_symbol, 
00766                       ICONS(origin, scheme_null)),
00767                 oe);
00768       }
00769     }
00770   } else {
00771     /* Add 'origin. */
00772     oe = NULL;
00773   }
00774 
00775   if (!oe)
00776     oe = ICONS(ICONS(origin_symbol, 
00777                    ICONS(origin, scheme_null)),
00778              scheme_null);
00779 
00780   /* Merge ne and oe (ne takes precedence). */
00781   
00782   /* First, check for overlap: */
00783   for (e1 = ne; SCHEME_PAIRP(e1); e1 = SCHEME_CDR(e1)) {
00784     Scheme_Object *a;
00785     a = SCHEME_CAR(SCHEME_CAR(e1));
00786     for (e2 = oe; SCHEME_PAIRP(e2); e2 = SCHEME_CDR(e2)) {
00787       if (SAME_OBJ(SCHEME_CAR(SCHEME_CAR(e2)), a)) {
00788        break;
00789       }
00790     }
00791     if (!SCHEME_NULLP(e1))
00792       break;
00793   }
00794 
00795   if (SCHEME_NULLP(e1)) {
00796     /* Can just append props info (probably the common case). */
00797     if (!SCHEME_NULLP(oe))
00798       ne = scheme_append(ne, oe);
00799   } else {
00800     /* Have to perform an actual merge: */
00801     Scheme_Object *first = scheme_null, *last = NULL, *p;
00802 
00803     for (e1 = ne; SCHEME_PAIRP(e1); e1 = SCHEME_CDR(e1)) {
00804       Scheme_Object *a, *v;
00805       a = SCHEME_CAR(SCHEME_CAR(e1));
00806       v = SCHEME_CDR(SCHEME_CAR(e1));
00807       for (e2 = oe; SCHEME_PAIRP(e2); e2 = SCHEME_CDR(e2)) {
00808        if (SAME_OBJ(SCHEME_CAR(SCHEME_CAR(e2)), a)) {
00809          v = ICONS(v, SCHEME_CDR(SCHEME_CAR(e2)));
00810          break;
00811        }
00812       }
00813 
00814       p = ICONS(ICONS(a, v), scheme_null);
00815       if (last)
00816        SCHEME_CDR(last) = p;
00817       else
00818        first = p;
00819       last = p;
00820     }
00821 
00822     for (e1 = oe; SCHEME_PAIRP(e1); e1 = SCHEME_CDR(e1)) {
00823       Scheme_Object *a, *v;
00824       a = SCHEME_CAR(SCHEME_CAR(e1));
00825       v = SCHEME_CDR(SCHEME_CAR(e1));
00826       for (e2 = ne; SCHEME_PAIRP(e2); e2 = SCHEME_CDR(e2)) {
00827        if (SAME_OBJ(SCHEME_CAR(SCHEME_CAR(e2)), a)) {
00828          v = NULL;
00829          break;
00830        }
00831       }
00832 
00833       if (v) {
00834        p = ICONS(ICONS(a, v), scheme_null);
00835        if (last)
00836          SCHEME_CDR(last) = p;
00837        else
00838          first = p;
00839        last = p;
00840       }
00841     }
00842 
00843     ne = first;
00844   }
00845 
00846   /* Clone nstx, keeping wraps, changing props to ne */
00847 
00848   wraps = nstx->wraps;
00849   if (STX_KEY(nstx) & STX_SUBSTX_FLAG) {
00850     modinfo_cache = NULL;
00851     lazy_prefix = nstx->u.lazy_prefix;
00852   } else {
00853     modinfo_cache = nstx->u.modinfo_cache;
00854     lazy_prefix = 0;
00855   }
00856 
00857   certs = nstx->certs;
00858 
00859   nstx = (Scheme_Stx *)scheme_make_stx(nstx->val, nstx->srcloc, ne);
00860 
00861   nstx->wraps = wraps;
00862   if (modinfo_cache)
00863     nstx->u.modinfo_cache = modinfo_cache;
00864   else
00865     nstx->u.lazy_prefix = lazy_prefix;
00866 
00867   nstx->certs = certs;
00868 
00869   return (Scheme_Object *)nstx;
00870 }
00871 
00872 /******************** chain cache ********************/
00873 
00874 static int maybe_add_chain_cache(Scheme_Stx *stx)
00875 {
00876   WRAP_POS awl;
00877   Scheme_Object *p;
00878   int skipable = 0, pos = 1;
00879 
00880   WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps);
00881 
00882   while (!WRAP_POS_END_P(awl)) {
00883     /* Skip over renames, cancelled marks, and negative marks: */
00884     p = WRAP_POS_FIRST(awl);
00885     if (SCHEME_VECTORP(p)) {
00886       skipable++;
00887     } else if (SCHEME_NUMBERP(p) || SCHEME_SYMBOLP(p)) {
00888       /* ok to skip, but don<'t count toward needing a cache */
00889     } else if (SCHEME_HASHTP(p)) {
00890       /* Hack: we store the depth of the table in the chain
00891         in the `size' fields, at least until the table is initialized: */
00892       Scheme_Hash_Table *ht2 = (Scheme_Hash_Table *)p;
00893       if (!ht2->count)
00894        pos = ht2->size;
00895       else {
00896        p = scheme_hash_get(ht2, scheme_make_integer(2));
00897        pos = SCHEME_INT_VAL(p);
00898       }
00899       pos++;
00900       break;
00901     } else
00902       break;
00903     WRAP_POS_INC(awl);
00904   }
00905 
00906   if (skipable >= 32) {
00907     /* Insert a cache placeholder. We'll fill it if
00908        it's ever used in resolve_env(). */
00909     Scheme_Hash_Table *ht;
00910 
00911     ht = scheme_make_hash_table(SCHEME_hash_ptr);
00912 
00913     ht->size = pos;
00914 
00915     p = scheme_make_pair((Scheme_Object *)ht, stx->wraps);
00916     stx->wraps = p;
00917     
00918     if (STX_KEY(stx) & STX_SUBSTX_FLAG)
00919       stx->u.lazy_prefix++;
00920 
00921     return 1;
00922   }
00923 
00924   return 0;
00925 }
00926 
00927 static void set_wraps_to_skip(Scheme_Hash_Table *ht, WRAP_POS *wraps)
00928 {
00929   Scheme_Object *v;
00930 
00931   v = scheme_hash_get(ht, scheme_make_integer(0));
00932   wraps->l = v;
00933   v = scheme_hash_get(ht, scheme_make_integer(1));
00934   if (SCHEME_TRUEP(v)) {
00935     wraps->pos = SCHEME_INT_VAL(v);
00936     wraps->is_limb = 1;
00937     wraps->a = ((Wrap_Chunk *)SCHEME_CAR(wraps->l))->a[wraps->pos];
00938   } else {
00939     wraps->is_limb = 0;
00940     if (!SCHEME_NULLP(wraps->l))
00941       wraps->a = SCHEME_CAR(wraps->l);
00942   }
00943 }
00944 
00945 static void fill_chain_cache(Scheme_Object *wraps)
00946 {
00947   int pos, max_depth, limit;
00948   Scheme_Hash_Table *ht;
00949   Scheme_Object *p, *id;
00950   WRAP_POS awl;
00951 
00952   ht = (Scheme_Hash_Table *)SCHEME_CAR(wraps);
00953 
00954   p = scheme_hash_get(ht, scheme_make_integer(5));
00955   if (p) {
00956     limit = SCHEME_INT_VAL(p);
00957 
00958     /* Extend the chain cache to deeper: */
00959     set_wraps_to_skip(ht, &awl);
00960 
00961     p = scheme_hash_get(ht, scheme_make_integer(2));
00962     pos = SCHEME_INT_VAL(p);
00963 
00964     scheme_hash_set(ht, scheme_make_integer(5), NULL);
00965   } else {
00966     pos = ht->size;
00967     ht->size = 0;
00968 
00969     wraps = SCHEME_CDR(wraps);
00970 
00971     WRAP_POS_INIT(awl, wraps);
00972 
00973     limit = 4;
00974   }
00975 
00976   /* Limit how much of the cache we build, in case we never
00977      reuse this cache: */
00978   max_depth = limit;
00979 
00980   while (!WRAP_POS_END_P(awl)) {
00981     if (!(max_depth--)) {
00982       limit *= 2;
00983       scheme_hash_set(ht, scheme_make_integer(5), scheme_make_integer(limit));
00984       break;
00985     }
00986 
00987     p = WRAP_POS_FIRST(awl);
00988     if (SCHEME_VECTORP(p)) {
00989       int i, len;
00990       len = SCHEME_RENAME_LEN(p);
00991       for (i = 0; i < len; i++) {
00992        id = SCHEME_VEC_ELS(p)[i+2];
00993        if (SCHEME_STXP(id))
00994          id = SCHEME_STX_VAL(id);
00995        scheme_hash_set(ht, id, scheme_true);
00996       }
00997     } else if (SCHEME_NUMBERP(p) || SCHEME_SYMBOLP(p)) {
00998       /* ok to skip */
00999     } else if (SCHEME_HASHTP(p)) {
01000       /* Hack: we store the depth of the table in the chain
01001         in the `size' fields, at least until the table is initialized: */
01002       Scheme_Hash_Table *ht2 = (Scheme_Hash_Table *)p;
01003       int pos2;
01004       if (!ht2->count)
01005        pos2 = ht2->size;
01006       else {
01007        p = scheme_hash_get(ht2, scheme_make_integer(2));
01008        pos2 = SCHEME_INT_VAL(p);
01009       }
01010       /* The theory here is the same as the `mapped' table:
01011         every power of two covers the whole range, etc. */
01012       if ((pos & pos2) == pos2)
01013        break;
01014     } else
01015       break;
01016     WRAP_POS_INC(awl);
01017   }
01018 
01019   /* Record skip destination: */
01020   scheme_hash_set(ht, scheme_make_integer(0), awl.l);
01021   if (!awl.is_limb) {
01022     scheme_hash_set(ht, scheme_make_integer(1), scheme_false);
01023   } else {
01024     scheme_hash_set(ht, scheme_make_integer(1), scheme_make_integer(awl.pos));
01025   }
01026   scheme_hash_set(ht, scheme_make_integer(2), scheme_make_integer(pos));
01027 }
01028 
01029 /******************** marks ********************/
01030 
01031 Scheme_Object *scheme_new_mark()
01032 {
01033   mark_id = scheme_add1(1, &mark_id);
01034   return mark_id;
01035 }
01036 
01037 static Scheme_Object *negate_mark(Scheme_Object *n)
01038 {
01039   return scheme_bin_minus(scheme_make_integer(0), n);
01040 }
01041 
01042 Scheme_Object *scheme_add_remove_mark(Scheme_Object *o, Scheme_Object *m)
01043 {
01044   Scheme_Stx *stx = (Scheme_Stx *)o;
01045   Scheme_Object *wraps;
01046   Scheme_Object *certs;
01047   long lp;
01048 
01049   if (STX_KEY(stx) & STX_SUBSTX_FLAG)
01050     lp = stx->u.lazy_prefix;
01051   else
01052     lp = 1;
01053 
01054   wraps = stx->wraps;
01055   if (SCHEME_PAIRP(wraps)
01056       && SAME_OBJ(m, SCHEME_CAR(wraps))
01057       && lp) {
01058     --lp;
01059     wraps = SCHEME_CDR(wraps);
01060   } else {
01061     if (maybe_add_chain_cache(stx))
01062       lp++;
01063     wraps = stx->wraps;
01064     lp++;
01065     wraps = CONS(m, wraps);
01066   }
01067 
01068   certs = stx->certs;
01069   stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props);
01070   stx->wraps = wraps;
01071   stx->certs = certs;
01072 
01073   if (STX_KEY(stx) & STX_SUBSTX_FLAG)
01074     stx->u.lazy_prefix = lp;
01075   /* else cache should stay zeroed */
01076 
01077   return (Scheme_Object *)stx;
01078 }
01079 
01080 /******************** lexical renames ********************/
01081 
01082 #define RENAME_HT_THRESHOLD 15
01083 
01084 Scheme_Object *scheme_make_rename(Scheme_Object *newname, int c)
01085 {
01086   Scheme_Object *v;
01087   int i;
01088 
01089   v = scheme_make_vector((2 * c) + 2, NULL);
01090   SCHEME_VEC_ELS(v)[0] = newname;
01091   if (c > RENAME_HT_THRESHOLD) {
01092     Scheme_Hash_Table *ht;
01093     ht = scheme_make_hash_table(SCHEME_hash_ptr);
01094     SCHEME_VEC_ELS(v)[1] = (Scheme_Object *)ht;
01095   } else 
01096     SCHEME_VEC_ELS(v)[1] = scheme_false;
01097 
01098   for (i = 0; i < c; i++) {
01099     SCHEME_VEC_ELS(v)[2 + c + i] = scheme_void;
01100   }
01101 
01102   return v;
01103 }
01104 
01105 static void maybe_install_rename_hash_table(Scheme_Object *v)
01106 {
01107   if (SCHEME_VEC_SIZE(v) > ((2 * RENAME_HT_THRESHOLD) + 2)) {
01108     Scheme_Hash_Table *ht;
01109     int i;
01110 
01111     ht = scheme_make_hash_table(SCHEME_hash_ptr);
01112     MZ_OPT_HASH_KEY(&(ht->iso)) |= 0x1;
01113     for (i = (SCHEME_VEC_SIZE(v) - 2) >> 1; i--; ) {
01114       scheme_hash_set(ht, SCHEME_VEC_ELS(v)[i + 2], scheme_make_integer(i));
01115     }
01116     SCHEME_VEC_ELS(v)[1] = (Scheme_Object *)ht;
01117   }
01118 }
01119 
01120 void scheme_set_rename(Scheme_Object *rnm, int pos, Scheme_Object *oldname)
01121 {
01122   /* Every added name must be symbolicly distinct! */
01123 
01124   SCHEME_VEC_ELS(rnm)[2 + pos] = oldname;
01125 
01126   /* Add ht mapping, if there's a hash table: */
01127   if (!SCHEME_FALSEP(SCHEME_VEC_ELS(rnm)[1])) {
01128     Scheme_Hash_Table *ht;
01129     ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(rnm)[1];
01130     if (scheme_hash_get(ht, SCHEME_STX_VAL(oldname)))
01131       pos = -1; /* -1 means multiple entries matching a name */
01132     scheme_hash_set(ht, SCHEME_STX_VAL(oldname), scheme_make_integer(pos));
01133   }
01134 }
01135 
01136 Scheme_Object *scheme_make_rename_rib()
01137 {
01138   Scheme_Lexical_Rib *rib;
01139   int *sealed;
01140 
01141   rib = MALLOC_ONE_TAGGED(Scheme_Lexical_Rib);
01142   rib->so.type = scheme_lexical_rib_type;
01143   rib->timestamp = current_rib_timestamp;
01144 
01145   sealed = (int *)scheme_malloc_atomic(sizeof(int));
01146   *sealed = 0;
01147   rib->sealed = sealed;
01148 
01149   current_rib_timestamp = scheme_add1(1, &current_rib_timestamp);
01150 
01151   return (Scheme_Object *)rib;
01152 }
01153 
01154 void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename)
01155 {
01156   Scheme_Lexical_Rib *rib, *naya;
01157   Scheme_Object *next;
01158 
01159   naya = MALLOC_ONE_TAGGED(Scheme_Lexical_Rib);
01160   naya->so.type = scheme_lexical_rib_type;
01161   naya->rename = rename;
01162 
01163   rib = (Scheme_Lexical_Rib *)ro;
01164   naya->next = rib->next;
01165   rib->next = naya;
01166 
01167   naya->timestamp = rib->timestamp;
01168   naya->sealed = rib->sealed;
01169 
01170   while (unsealed_dependencies) {
01171     next = SCHEME_CDR(unsealed_dependencies);
01172     SCHEME_CAR(unsealed_dependencies) = NULL;
01173     SCHEME_CDR(unsealed_dependencies) = NULL;    
01174     unsealed_dependencies = next;
01175   }
01176 }
01177 
01178 void scheme_drop_first_rib_rename(Scheme_Object *ro)
01179 {
01180   Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)ro;
01181   rib->next = rib->next->next;
01182 }
01183 
01184 void scheme_stx_seal_rib(Scheme_Object *rib)
01185 {
01186   *((Scheme_Lexical_Rib *)rib)->sealed = 1;
01187 }
01188 
01189 int *scheme_stx_get_rib_sealed(Scheme_Object *rib)
01190 {
01191   return ((Scheme_Lexical_Rib *)rib)->sealed;
01192 }
01193 
01194 Scheme_Object *scheme_stx_id_remove_rib(Scheme_Object *stx, Scheme_Object *ro)
01195 {
01196   Scheme_Object *v;
01197   int count = 0, rib_count = 0;
01198   WRAP_POS awl;
01199   Wrap_Chunk *wc;
01200   Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)ro, *rib2;
01201 
01202   WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps);
01203   while (!WRAP_POS_END_P(awl)) {
01204     count++;
01205     v = WRAP_POS_FIRST(awl);
01206     if (SCHEME_RIBP(v)) {
01207       rib2 = (Scheme_Lexical_Rib *)v;
01208       if (SAME_OBJ(rib2->timestamp, rib->timestamp))
01209         rib_count++;
01210     }
01211     WRAP_POS_INC(awl);
01212   }
01213 
01214   if (!rib_count)
01215     return stx;
01216 
01217   count -= rib_count;
01218 
01219   wc = MALLOC_WRAP_CHUNK(count);
01220   wc->type = scheme_wrap_chunk_type;
01221   wc->len = count;
01222 
01223   count = 0;
01224   WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps);
01225   while (!WRAP_POS_END_P(awl)) {
01226     v = WRAP_POS_FIRST(awl);
01227     if (SCHEME_RIBP(v)) {
01228       rib2 = (Scheme_Lexical_Rib *)v;
01229       if (SAME_OBJ(rib2->timestamp, rib->timestamp))
01230         v = NULL;
01231     }
01232     if (v) {
01233       wc->a[count++] = v;
01234     }
01235     WRAP_POS_INC(awl);
01236   }
01237 
01238   v = scheme_make_pair((Scheme_Object *)wc, scheme_null);
01239 
01240   stx = scheme_add_rename(stx, scheme_make_integer(0));
01241   ((Scheme_Stx *)stx)->wraps = v;
01242   
01243   return stx;
01244 }
01245 
01246 static Scheme_Object *make_prune_context(Scheme_Object *a)
01247 {
01248   Scheme_Object *p;
01249 
01250   p = scheme_alloc_small_object();
01251   p->type = scheme_prune_context_type;
01252   SCHEME_BOX_VAL(p) = a;
01253 
01254   return p;
01255 }
01256 
01257 /******************** module renames ********************/
01258 
01259 static int same_phase(Scheme_Object *a, Scheme_Object *b)
01260 {
01261   if (SAME_OBJ(a, b))
01262     return 1;
01263   else if (SCHEME_INTP(a) || SCHEME_INTP(b)
01264            || SCHEME_FALSEP(a) || SCHEME_FALSEP(b))
01265     return 0;
01266   else
01267     return scheme_eqv(a, b);
01268 }
01269 
01270 Scheme_Object *scheme_make_module_rename_set(int kind, Scheme_Object *share_marked_names)
01271 {
01272   Module_Renames_Set *mrns;
01273   Scheme_Object *mk;
01274 
01275   if (share_marked_names)
01276     mk = ((Module_Renames_Set *)share_marked_names)->set_identity;
01277   else
01278     mk = scheme_new_mark();
01279 
01280   mrns = MALLOC_ONE_TAGGED(Module_Renames_Set);
01281   mrns->so.type = scheme_rename_table_set_type;
01282   mrns->kind = kind;
01283   mrns->share_marked_names = share_marked_names;
01284   mrns->set_identity = mk;
01285 
01286   return (Scheme_Object *)mrns;
01287 }
01288 
01289 void scheme_add_module_rename_to_set(Scheme_Object *set, Scheme_Object *rn)
01290 {
01291   Module_Renames_Set *mrns = (Module_Renames_Set *)set;
01292   Module_Renames *mrn = (Module_Renames *)rn;
01293 
01294   mrn->set_identity = mrns->set_identity;
01295 
01296   if (same_phase(mrn->phase, scheme_make_integer(0)))
01297     mrns->rt = mrn;
01298   else if (same_phase(mrn->phase, scheme_make_integer(1)))
01299     mrns->et = mrn;
01300   else {
01301     Scheme_Hash_Table *ht;
01302     ht = mrns->other_phases;
01303     if (!ht) {
01304       ht = scheme_make_hash_table_equal();
01305       mrns->other_phases = ht;
01306     }
01307     scheme_hash_set(ht, mrn->phase, (Scheme_Object *)mrn);
01308   }
01309 }
01310 
01311 Scheme_Object *scheme_get_module_rename_from_set(Scheme_Object *set, Scheme_Object *phase, int create)
01312 {
01313   Module_Renames_Set *mrns = (Module_Renames_Set *)set;
01314   Module_Renames *mrn;
01315 
01316   if (same_phase(phase, scheme_make_integer(0)))
01317     mrn = mrns->rt;
01318   else if (same_phase(phase, scheme_make_integer(1)))
01319     mrn = mrns->et;
01320   else if (mrns->other_phases)
01321     mrn = (Module_Renames *)scheme_hash_get(mrns->other_phases, phase);
01322   else
01323     mrn = NULL;
01324 
01325   if (!mrn && create) {
01326     Scheme_Hash_Table *marked_names;
01327 
01328     if (mrns->share_marked_names)
01329       marked_names = scheme_get_module_rename_marked_names(mrns->share_marked_names, phase, 1);
01330     else
01331       marked_names = NULL;
01332 
01333     mrn = (Module_Renames *)scheme_make_module_rename(phase, mrns->kind, marked_names);
01334 
01335     scheme_add_module_rename_to_set(set, (Scheme_Object *)mrn);
01336   }
01337 
01338   return (Scheme_Object *)mrn;
01339 }
01340 
01341 Scheme_Hash_Table *scheme_get_module_rename_marked_names(Scheme_Object *set, Scheme_Object *phase, int create)
01342 {
01343   Scheme_Object *rn;
01344 
01345   rn = scheme_get_module_rename_from_set(set, phase, create);
01346   if (!rn)
01347     return NULL;
01348 
01349   if (((Module_Renames *)rn)->marked_names)
01350     return ((Module_Renames *)rn)->marked_names;
01351 
01352   if (create) {
01353     Scheme_Hash_Table *ht;
01354     ht = scheme_make_hash_table(SCHEME_hash_ptr);
01355     ((Module_Renames *)rn)->marked_names = ht;
01356     return ht;
01357   }
01358 
01359   return NULL;
01360 }
01361 
01362 Scheme_Object *scheme_make_module_rename(Scheme_Object *phase, int kind, Scheme_Hash_Table *marked_names)
01363 {
01364   Module_Renames *mr;
01365   Scheme_Hash_Table *ht;
01366   Scheme_Object *mk;
01367 
01368   mk = scheme_new_mark();
01369 
01370   mr = MALLOC_ONE_TAGGED(Module_Renames);
01371   mr->so.type = scheme_rename_table_type;
01372 
01373   ht = scheme_make_hash_table(SCHEME_hash_ptr);
01374 
01375   mr->ht = ht;
01376   mr->phase = phase;
01377   mr->kind = kind;
01378   mr->set_identity = mk;
01379   mr->marked_names = marked_names;
01380   mr->shared_pes = scheme_null;
01381   mr->unmarshal_info = scheme_null;
01382 
01383   if (!krn) {
01384     REGISTER_SO(krn);
01385     krn = mr;
01386   }
01387 
01388   return (Scheme_Object *)mr;
01389 }
01390 
01391 void scheme_seal_module_rename(Scheme_Object *rn, int level)
01392 {
01393   ((Module_Renames *)rn)->sealed = level;
01394 }
01395 
01396 void scheme_seal_module_rename_set(Scheme_Object *_rns, int level)
01397 {
01398   Module_Renames_Set *rns = (Module_Renames_Set *)_rns;
01399   
01400   rns->sealed = level;
01401   if (rns->rt)
01402     rns->rt->sealed = level;
01403   if (rns->et)
01404     rns->et->sealed = level;
01405   if (rns->other_phases) {
01406     int i;
01407     for (i = 0; i < rns->other_phases->size; i++) {
01408       if (rns->other_phases->vals[i]) {
01409         ((Module_Renames *)rns->other_phases->vals[i])->sealed = level;
01410       }
01411     }
01412   }
01413 }
01414 
01415 static void check_not_sealed(Module_Renames *mrn)
01416 {
01417   if (mrn->sealed >= STX_SEAL_ALL)
01418     scheme_signal_error("internal error: attempt to change sealed module rename");
01419 }
01420 
01421 static Scheme_Object *phase_to_index(Scheme_Object *phase)
01422 {
01423   return phase;
01424 }
01425 
01426 Scheme_Object *scheme_extend_module_rename(Scheme_Object *mrn,
01427                                            Scheme_Object *modname,     /* actual source module */
01428                                            Scheme_Object *localname,   /* name in local context */
01429                                            Scheme_Object *exname,      /* name in definition context  */
01430                                            Scheme_Object *nominal_mod, /* nominal source module */
01431                                            Scheme_Object *nominal_ex,  /* nominal import before local renaming */
01432                                            int mod_phase,              /* phase of source defn */
01433                                            Scheme_Object *src_phase_index, /* nominal import phase */
01434                                            Scheme_Object *nom_phase,   /* nominal export phase */
01435                                            Scheme_Object *insp,        /* inspector for re-export */
01436                                            int mode)         /* 1 => can be reconstructed from unmarshal info
01437                                                                 2 => free-id=? renaming
01438                                                                 3 => return info */
01439 {
01440   Scheme_Object *elem;
01441   Scheme_Object *phase_index;
01442 
01443   if (mode != 3)
01444     check_not_sealed((Module_Renames *)mrn);
01445 
01446   phase_index = phase_to_index(((Module_Renames *)mrn)->phase);
01447   if (!src_phase_index)
01448     src_phase_index = phase_index;
01449   if (!nom_phase)
01450     nom_phase = scheme_make_integer(mod_phase);
01451 
01452   if (SAME_OBJ(modname, nominal_mod)
01453       && SAME_OBJ(exname, nominal_ex)
01454       && !mod_phase
01455       && same_phase(src_phase_index, phase_index)
01456       && same_phase(nom_phase, scheme_make_integer(mod_phase))) {
01457     if (SAME_OBJ(localname, exname))
01458       elem = modname;
01459     else
01460       elem = CONS(modname, exname);
01461   } else if (SAME_OBJ(exname, nominal_ex)
01462             && SAME_OBJ(localname, exname)
01463             && !mod_phase
01464              && same_phase(src_phase_index, phase_index)
01465              && same_phase(nom_phase, scheme_make_integer(mod_phase))) {
01466     /* It's common that a sequence of similar mappings shows up,
01467        e.g., '(#%kernel . mzscheme) */
01468     if (nominal_ipair_cache
01469        && SAME_OBJ(SCHEME_CAR(nominal_ipair_cache), modname)
01470        && SAME_OBJ(SCHEME_CDR(nominal_ipair_cache), nominal_mod))
01471       elem = nominal_ipair_cache;
01472     else {
01473       elem = ICONS(modname, nominal_mod);
01474       nominal_ipair_cache = elem;
01475     }
01476   } else {
01477     if (same_phase(nom_phase, scheme_make_integer(mod_phase))) {
01478       if (same_phase(src_phase_index, phase_index))
01479         elem = nominal_mod;
01480       else
01481         elem = CONS(nominal_mod, src_phase_index);
01482     } else {
01483       elem = CONS(nominal_mod, CONS(src_phase_index, nom_phase));
01484     }
01485     elem = CONS(exname, CONS(elem, nominal_ex));
01486     if (mod_phase)
01487       elem = CONS(scheme_make_integer(mod_phase), elem);
01488     elem = CONS(modname, elem);
01489   }
01490 
01491   if (insp)
01492     elem = CONS(insp, elem);
01493   
01494   if (mode == 1) {
01495     if (!((Module_Renames *)mrn)->nomarshal_ht) {
01496       Scheme_Hash_Table *ht;
01497       ht = scheme_make_hash_table(SCHEME_hash_ptr);
01498       ((Module_Renames *)mrn)->nomarshal_ht = ht;
01499     }
01500     scheme_hash_set(((Module_Renames *)mrn)->nomarshal_ht, localname, elem);
01501   } else if (mode == 2) {
01502     scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, localname, elem);
01503   } else if (mode == 3) {
01504     return elem;
01505   } else
01506     scheme_hash_set(((Module_Renames *)mrn)->ht, localname, elem);
01507 
01508   return NULL;
01509 }
01510 
01511 void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *modidx, 
01512                                              Scheme_Module_Phase_Exports *pt, 
01513                                              Scheme_Object *unmarshal_phase_index,
01514                                              Scheme_Object *src_phase_index,
01515                                              Scheme_Object *marks,
01516                                              int save_unmarshal)
01517 {
01518   Module_Renames *mrn = (Module_Renames *)rn;
01519   Scheme_Object *pr, *index_plus_marks;
01520 
01521   check_not_sealed(mrn);
01522 
01523   if (SCHEME_PAIRP(marks))
01524     index_plus_marks = scheme_make_pair(marks, src_phase_index);
01525   else
01526     index_plus_marks = src_phase_index;
01527 
01528   pr = scheme_make_pair(scheme_make_pair(modidx, 
01529                                          scheme_make_pair((Scheme_Object *)pt,
01530                                                           index_plus_marks)),
01531                         mrn->shared_pes);
01532   mrn->shared_pes = pr;
01533 
01534   if (save_unmarshal) {
01535     pr = scheme_make_pair(scheme_make_pair(modidx, 
01536                                            scheme_make_pair(unmarshal_phase_index,
01537                                                             index_plus_marks)),
01538                           mrn->unmarshal_info);
01539     mrn->unmarshal_info = pr;
01540   }
01541 }
01542 
01543 void scheme_save_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info)
01544 {
01545   Scheme_Object *l;
01546 
01547   l = scheme_make_pair(info, ((Module_Renames *)rn)->unmarshal_info);
01548   ((Module_Renames *)rn)->unmarshal_info = l;
01549 }
01550 
01551 static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest,
01552                                 Scheme_Object *old_midx, Scheme_Object *new_midx,
01553                                     int do_pes, int do_unm)
01554 {
01555   Scheme_Hash_Table *ht, *hts, *drop_ht;
01556   Scheme_Object *v;
01557   int i, t;
01558 
01559   check_not_sealed((Module_Renames *)dest);
01560 
01561   if (do_pes) {
01562     if (!SCHEME_NULLP(((Module_Renames *)src)->shared_pes)) {
01563       Scheme_Object *first = NULL, *last = NULL, *pr, *l;
01564       for (l = ((Module_Renames *)src)->shared_pes; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
01565         pr = scheme_make_pair(SCHEME_CAR(l), scheme_null);
01566         if (last)
01567           SCHEME_CDR(last) = pr;
01568         else
01569           first = pr;
01570         last = pr;
01571       }
01572       SCHEME_CDR(last) = ((Module_Renames *)dest)->shared_pes;
01573       ((Module_Renames *)dest)->shared_pes = first;
01574     }
01575   }
01576 
01577   if (do_unm) {
01578     if (!SCHEME_NULLP(((Module_Renames *)src)->unmarshal_info)) {
01579       Scheme_Object *first = NULL, *last = NULL, *pr, *l;
01580       for (l = ((Module_Renames *)src)->unmarshal_info; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
01581         pr = scheme_make_pair(SCHEME_CAR(l), scheme_null);
01582         if (last)
01583           SCHEME_CDR(last) = pr;
01584         else
01585           first = pr;
01586         last = pr;
01587       }
01588       SCHEME_CDR(last) = ((Module_Renames *)dest)->unmarshal_info;
01589       ((Module_Renames *)dest)->unmarshal_info = first;
01590 
01591       ((Module_Renames *)dest)->needs_unmarshal = 1;
01592     }
01593   }
01594 
01595   for (t = 0; t < 2; t++) {
01596     if (!t) {
01597       ht = ((Module_Renames *)dest)->ht;
01598       hts = ((Module_Renames *)src)->ht;
01599       drop_ht = ((Module_Renames *)dest)->nomarshal_ht;
01600     } else {
01601       hts = ((Module_Renames *)src)->nomarshal_ht;
01602       if (!hts)
01603        break;
01604       ht = ((Module_Renames *)dest)->nomarshal_ht;
01605       if (!ht) {
01606        ht = scheme_make_hash_table(SCHEME_hash_ptr);
01607        ((Module_Renames *)dest)->nomarshal_ht = ht;
01608       }
01609       drop_ht = ((Module_Renames *)dest)->ht;
01610     }
01611   
01612     /* Mappings in src overwrite mappings in dest: */
01613 
01614     for (i = hts->size; i--; ) {
01615       if (hts->vals[i]) {
01616        v = hts->vals[i];
01617        if (old_midx) {
01618           Scheme_Object *insp = NULL;
01619 
01620           if (SCHEME_PAIRP(v) && is_rename_inspector_info(SCHEME_CAR(v))) {
01621             insp = SCHEME_CAR(v);
01622             v = SCHEME_CDR(v);
01623           } else
01624             insp = NULL;
01625 
01626          /* Shift the modidx part */
01627          if (SCHEME_PAIRP(v)) {
01628            if (SCHEME_PAIRP(SCHEME_CDR(v))) {
01629              /* (list* modidx [mod-phase] exportname nominal_modidx+index nominal_exportname) */
01630              Scheme_Object *midx1, *midx2;
01631              int mod_phase;
01632              midx1 = SCHEME_CAR(v);
01633              v = SCHEME_CDR(v);
01634              if (SCHEME_INTP(SCHEME_CAR(v))) {
01635               mod_phase = SCHEME_INT_VAL(SCHEME_CAR(v));
01636               v = SCHEME_CDR(v);
01637              } else
01638               mod_phase = 0;
01639              midx2 = SCHEME_CAR(SCHEME_CDR(v));
01640              midx1 = scheme_modidx_shift(midx1, old_midx, new_midx);
01641               if (SCHEME_PAIRP(midx2)) {
01642                 midx2 = scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(midx2), old_midx, new_midx),
01643                                          SCHEME_CDR(midx2));
01644               } else {
01645                 midx2 = scheme_modidx_shift(midx2, old_midx, new_midx);
01646               }
01647              v = CONS(SCHEME_CAR(v), CONS(midx2, SCHEME_CDR(SCHEME_CDR(v))));
01648              if (mod_phase)
01649               v = CONS(scheme_make_integer(mod_phase), v);
01650              v = CONS(midx1, v);
01651            } else if (nom_mod_p(v)) {
01652              /* (cons modidx nominal_modidx) */
01653              v = ICONS(scheme_modidx_shift(SCHEME_CAR(v), old_midx, new_midx),
01654                      scheme_modidx_shift(SCHEME_CDR(v), old_midx, new_midx));
01655            } else {
01656              /* (cons modidx exportname) */
01657              v = CONS(scheme_modidx_shift(SCHEME_CAR(v), old_midx, new_midx),
01658                      SCHEME_CDR(v));
01659            }
01660          } else {
01661            /* modidx */
01662            v = scheme_modidx_shift(v, old_midx, new_midx);
01663          }
01664 
01665           if (insp)
01666             v = CONS(insp, v);
01667        }
01668        scheme_hash_set(ht, hts->keys[i], v);
01669        if (drop_ht)
01670          scheme_hash_set(drop_ht, hts->keys[i], NULL);
01671       }
01672     }
01673   }
01674 
01675   /* Need to share marked names: */
01676 
01677   if (((Module_Renames *)src)->marked_names) {
01678     ((Module_Renames *)dest)->marked_names = ((Module_Renames *)src)->marked_names;
01679   }
01680 }
01681 
01682 void scheme_append_module_rename(Scheme_Object *src, Scheme_Object *dest, int do_unm)
01683 {
01684   do_append_module_rename(src, dest, NULL, NULL, 1, do_unm);
01685 }
01686 
01687 void scheme_append_rename_set_to_env(Scheme_Object *_mrns, Scheme_Env *env)
01688 {
01689   Module_Renames_Set *mrns = (Module_Renames_Set *)_mrns;
01690   Scheme_Object *mrns2;
01691   int i;
01692 
01693   scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL);
01694   mrns2 = env->rename_set;
01695 
01696   if (mrns->rt) {
01697     scheme_append_module_rename((Scheme_Object *)mrns->rt, 
01698                                 scheme_get_module_rename_from_set(mrns2, scheme_make_integer(0), 1),
01699                                 1);
01700   }
01701   if (mrns->et) {
01702     scheme_append_module_rename((Scheme_Object *)mrns->et, 
01703                                 scheme_get_module_rename_from_set(mrns2, scheme_make_integer(1), 1),
01704                                 1);
01705   }
01706   if (mrns->other_phases) {
01707     for (i = 0; i < mrns->other_phases->size; i++) {
01708       if (mrns->other_phases->vals[i]) {
01709         scheme_append_module_rename(mrns->other_phases->vals[i],
01710                                     scheme_get_module_rename_from_set(mrns2, 
01711                                                                       mrns->other_phases->keys[i],
01712                                                                       1),
01713                                     1);
01714       }
01715     }
01716   }
01717 }
01718 
01719 void scheme_remove_module_rename(Scheme_Object *mrn,
01720                              Scheme_Object *localname)
01721 {
01722   check_not_sealed((Module_Renames *)mrn);
01723   scheme_hash_set(((Module_Renames *)mrn)->ht, localname, NULL);
01724   if (((Module_Renames *)mrn)->nomarshal_ht)
01725     scheme_hash_set(((Module_Renames *)mrn)->nomarshal_ht, localname, NULL);
01726   if (((Module_Renames *)mrn)->free_id_renames)
01727     scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, localname, NULL);
01728 }
01729 
01730 void scheme_list_module_rename(Scheme_Object *set, Scheme_Hash_Table *ht)
01731 {
01732   /* Put every name mapped by src into ht: */
01733   Scheme_Object *pr;
01734   Scheme_Hash_Table *hts;
01735   int i, t;
01736   Scheme_Module_Phase_Exports *pt;
01737   Module_Renames *src;
01738 
01739   if (SCHEME_RENAMES_SETP(set))
01740     src = ((Module_Renames_Set *)set)->rt;
01741   else
01742     src = (Module_Renames *)set;
01743 
01744   if (!src)
01745     return;
01746 
01747   for (t = 0; t < 2; t++) {
01748     if (!t)
01749       hts = src->ht;
01750     else {
01751       hts = src->nomarshal_ht;
01752     }
01753 
01754     if (hts) {
01755       for (i = hts->size; i--; ) {
01756         if (hts->vals[i]) {
01757           scheme_hash_set(ht, hts->keys[i], scheme_false);
01758         }
01759       }
01760     }
01761   }
01762 
01763   for (pr = src->shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) {
01764     pt = (Scheme_Module_Phase_Exports *)SCHEME_CADR(SCHEME_CAR(pr));
01765     for (i = pt->num_provides; i--; ) {
01766       scheme_hash_set(ht, pt->provides[i], scheme_false);
01767     }
01768   }
01769 }
01770 
01771 
01772 Scheme_Object *scheme_rename_to_stx(Scheme_Object *mrn)
01773 {
01774   Scheme_Object *stx;
01775   stx = scheme_make_stx(scheme_false, empty_srcloc, NULL); 
01776   return scheme_add_rename(stx, mrn);
01777 }
01778 
01779 Scheme_Object *scheme_stx_to_rename(Scheme_Object *stx)
01780 {
01781   Scheme_Object *rns = NULL, *v;
01782   WRAP_POS wl;
01783   
01784   WRAP_POS_INIT(wl, ((Scheme_Stx *)stx)->wraps);
01785   while (!WRAP_POS_END_P(wl)) {
01786     v = WRAP_POS_FIRST(wl);
01787     if (SCHEME_RENAMES_SETP(v)) {
01788       if (rns)
01789         scheme_signal_error("can't convert syntax to rename (two sets)");
01790       rns = v;
01791     } else if (SCHEME_RENAMESP(v)) {
01792       if (!rns)
01793         rns = scheme_make_module_rename_set(((Module_Renames *)v)->kind, NULL);
01794       scheme_add_module_rename_to_set(rns, v);
01795     } else {
01796       scheme_signal_error("can't convert syntax to rename (non-rename in wrap)");
01797     }
01798     WRAP_POS_INC(wl);
01799   }
01800 
01801   if (!rns)
01802     scheme_signal_error("can't convert syntax to rename (empty)");
01803 
01804   return rns;
01805 }
01806 
01807 Scheme_Object *scheme_stx_shift_rename(Scheme_Object *mrn, 
01808                                    Scheme_Object *old_midx, Scheme_Object *new_midx)
01809 {
01810   Scheme_Object *nmrn, *a, *l, *nl;
01811 
01812   nmrn = scheme_make_module_rename(((Module_Renames *)mrn)->phase, 
01813                                    mzMOD_RENAME_NORMAL, 
01814                                    NULL);
01815 
01816   /* use "append" to copy most info: */
01817   do_append_module_rename(mrn, nmrn, old_midx, new_midx, 0, 0);
01818 
01819   /* Manually copy unmarshal_infos, where we have to shift anyway: */
01820 
01821   l = ((Module_Renames *)mrn)->unmarshal_info;
01822   nl = scheme_null;
01823   while (!SCHEME_NULLP(l)) {
01824     a = SCHEME_CAR(l);
01825     nl = scheme_make_pair(scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(a), old_midx, new_midx),
01826                                       SCHEME_CDR(a)),
01827                        nl);
01828     l = SCHEME_CDR(l);
01829   }
01830   ((Module_Renames *)nmrn)->unmarshal_info = nl;
01831 
01832   l = ((Module_Renames *)mrn)->shared_pes;
01833   nl = scheme_null;
01834   while (!SCHEME_NULLP(l)) {
01835     a = SCHEME_CAR(l);
01836     nl = scheme_make_pair(scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(a), old_midx, new_midx),
01837                                       SCHEME_CDR(a)),
01838                        nl);
01839     l = SCHEME_CDR(l);
01840   }
01841   ((Module_Renames *)nmrn)->shared_pes = nl;
01842 
01843   if (((Module_Renames *)mrn)->needs_unmarshal) {
01844     ((Module_Renames *)nmrn)->needs_unmarshal = 1;
01845   }  
01846 
01847   return nmrn;
01848 }
01849 
01850 Scheme_Object *scheme_stx_shift_rename_set(Scheme_Object *_mrns, 
01851                                            Scheme_Object *old_midx, Scheme_Object *new_midx)
01852 {
01853   Module_Renames_Set *mrns = (Module_Renames_Set *)_mrns;
01854   Scheme_Object *mrn, *mrns2;
01855   int i;
01856 
01857   mrns2 = scheme_make_module_rename_set(mrns->kind, NULL);
01858   if (mrns->rt) {
01859     mrn = scheme_stx_shift_rename((Scheme_Object *)mrns->rt, old_midx, new_midx);
01860     scheme_add_module_rename_to_set(mrns2, mrn);
01861   }
01862   if (mrns->et) {
01863     mrn = scheme_stx_shift_rename((Scheme_Object *)mrns->et, old_midx, new_midx);
01864     scheme_add_module_rename_to_set(mrns2, mrn);
01865   }
01866   if (mrns->other_phases) {
01867     for (i = 0; i < mrns->other_phases->size; i++) {
01868       if (mrns->other_phases->vals[i]) {
01869         mrn = scheme_stx_shift_rename(mrns->other_phases->vals[i], old_midx, new_midx);
01870         scheme_add_module_rename_to_set(mrns2, mrn);
01871       }
01872     }
01873   }
01874 
01875   return (Scheme_Object *)mrns2;
01876 }
01877 
01878 
01879 Scheme_Hash_Table *scheme_module_rename_marked_names(Scheme_Object *rn)
01880 {
01881   return ((Module_Renames *)rn)->marked_names;
01882 }
01883 
01884 static void unmarshal_rename(Module_Renames *mrn,
01885                           Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to,
01886                           Scheme_Hash_Table *export_registry)
01887 {
01888   Scheme_Object *l;
01889   int sealed;
01890 
01891   mrn->needs_unmarshal = 0;
01892 
01893   sealed = mrn->sealed;
01894   if (sealed)
01895     mrn->sealed = 0;
01896     
01897   l = scheme_reverse(mrn->unmarshal_info);
01898   for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
01899     scheme_do_module_rename_unmarshal((Scheme_Object *)mrn, SCHEME_CAR(l),
01900                                   modidx_shift_from, modidx_shift_to,
01901                                   export_registry);
01902   }
01903 
01904   if (sealed)
01905     mrn->sealed = sealed;
01906 }
01907 
01908 /******************** wrap manipulations ********************/
01909 
01910 Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename)
01911 {
01912   Scheme_Stx *stx = (Scheme_Stx *)o;
01913   Scheme_Object *wraps;
01914   Scheme_Object *certs;
01915   long lp;
01916 
01917   if (STX_KEY(stx) & STX_SUBSTX_FLAG)
01918     preemptive_chunk(stx);
01919 
01920   /* relative order matters: chunk first, so that chunking
01921      doesn't immediately throw away a chain cache */
01922 
01923   maybe_add_chain_cache(stx);
01924 
01925   wraps = CONS(rename, stx->wraps);
01926   if (STX_KEY(stx) & STX_SUBSTX_FLAG)
01927     lp = stx->u.lazy_prefix + 1;
01928   else
01929     lp = 0;
01930 
01931   certs = stx->certs;
01932   stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props);
01933   stx->wraps = wraps;
01934   stx->certs = certs;
01935 
01936   stx->u.lazy_prefix = lp; /* same as zeroing cache if no SUBSTX */
01937 
01938   if (stx->certs)
01939     phase_shift_certs((Scheme_Object *)stx, stx->wraps, 1);
01940   
01941   return (Scheme_Object *)stx;
01942 }
01943 
01944 void scheme_load_delayed_syntax(struct Resolve_Prefix *rp, long i)
01945 {
01946   Scheme_Object *stx;
01947   int c;
01948 
01949   stx = scheme_load_delayed_code(SCHEME_INT_VAL(rp->stxes[i]),
01950                                  (struct Scheme_Load_Delay *)SCHEME_CDR(rp->delay_info_rpair));
01951   rp->stxes[i] = stx;
01952   c = SCHEME_INT_VAL(SCHEME_CAR(rp->delay_info_rpair));
01953   --c;
01954   SCHEME_CAR(rp->delay_info_rpair) = scheme_make_integer(c);
01955   if (!c) {
01956     SCHEME_CDR(rp->delay_info_rpair) = NULL;
01957     rp->delay_info_rpair = NULL;
01958   } 
01959 }
01960 
01961 Scheme_Object *scheme_delayed_rename(Scheme_Object **o, long i)
01962 {
01963   Scheme_Object *rename;
01964   Resolve_Prefix *rp;
01965 
01966   rename = o[0];
01967 
01968   if (!rename) return scheme_false; /* happens only with corrupted .zo! */
01969 
01970   rp = (Resolve_Prefix *)o[1];
01971 
01972   if (SCHEME_INTP(rp->stxes[i]))
01973     scheme_load_delayed_syntax(rp, i);
01974 
01975   return scheme_add_rename(rp->stxes[i], rename);
01976 }
01977 
01978 Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib)
01979 {
01980 #if 0
01981   WRAP_POS wl;
01982 
01983   /* Shortcut: there's a good chance that o already has the renaming rib */
01984   WRAP_POS_INIT(wl, ((Scheme_Stx *)o)->wraps);
01985   if (!WRAP_POS_END_P(wl)) {
01986     if (SAME_OBJ(rib, WRAP_POS_FIRST(wl))) {
01987       return o;
01988     }
01989   }
01990 #endif
01991 
01992   return scheme_add_rename(o, rib);
01993 }
01994 
01995 Scheme_Object *scheme_add_rib_delimiter(Scheme_Object *o, Scheme_Object *ribs)
01996 {
01997   Scheme_Object *s;
01998 
01999   s = scheme_alloc_small_object();
02000   s->type = scheme_rib_delimiter_type;
02001   SCHEME_BOX_VAL(s) = ribs;
02002 
02003   return scheme_add_rename(o, s);
02004 }
02005 
02006 static int is_in_rib_delim(Scheme_Object *envname, Scheme_Object *rib_delim)
02007 {
02008   Scheme_Object *l = SCHEME_BOX_VAL(rib_delim);
02009   Scheme_Lexical_Rib *rib;
02010 
02011   while (!SCHEME_NULLP(l)) {
02012     rib = (Scheme_Lexical_Rib *)SCHEME_CAR(l);
02013     while (rib) {
02014       if (rib->rename && SAME_OBJ(envname, SCHEME_VEC_ELS(rib->rename)[0]))
02015         return 1;
02016       rib = rib->next;
02017     }
02018     l = SCHEME_CDR(l);
02019   }
02020   return 0;
02021 }
02022 
02023 static Scheme_Hash_Table *make_recur_table()
02024 {
02025   if (quick_hash_table) {
02026     GC_CAN_IGNORE Scheme_Hash_Table *t;
02027     t = quick_hash_table;
02028     quick_hash_table = NULL;
02029     return t;
02030   } else
02031     return scheme_make_hash_table(SCHEME_hash_ptr);
02032 }
02033 
02034 static void release_recur_table(Scheme_Hash_Table *free_id_recur)
02035 {
02036   if (!free_id_recur->size && !quick_hash_table) {
02037     quick_hash_table = free_id_recur;
02038   }
02039 }
02040 
02041 static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn,
02042                                                      Scheme_Object *id, 
02043                                                      Scheme_Object *orig_id,
02044                                                      int *_sealed,
02045                                                      Scheme_Hash_Table *free_id_recur)
02046 {
02047   Scheme_Object *result;
02048   Scheme_Object *modname;
02049   Scheme_Object *nominal_modidx;
02050   Scheme_Object *nominal_name, *nom2;
02051   Scheme_Object *mod_phase;
02052   Scheme_Object *src_phase_index;
02053   Scheme_Object *nominal_src_phase;
02054   Scheme_Object *lex_env;
02055   Scheme_Object *rename_insp;
02056 
02057   if (scheme_hash_get(free_id_recur, id)) {
02058     return id;
02059   }
02060   scheme_hash_set(free_id_recur, id, id);
02061   
02062   nom2 = scheme_stx_property(orig_id, nominal_id_symbol, NULL);
02063 
02064   modname = scheme_stx_module_name(free_id_recur,
02065                                    &orig_id, ((Module_Renames *)mrn)->phase, &nominal_modidx,
02066                                    &nominal_name,
02067                                    &mod_phase, 
02068                                    &src_phase_index,
02069                                    &nominal_src_phase,
02070                                    &lex_env,
02071                                    _sealed,
02072                                    &rename_insp);
02073  
02074   if (SCHEME_SYMBOLP(nom2))
02075     nominal_name = nom2;
02076   
02077   if (!modname)
02078     result = scheme_box(CONS(SCHEME_STX_VAL(orig_id), scheme_false));
02079   else if (SAME_OBJ(modname, scheme_undefined))
02080     result = scheme_box(CONS(SCHEME_STX_VAL(orig_id), lex_env));
02081   else
02082     result = scheme_extend_module_rename(mrn,
02083                                          modname,
02084                                          id,                 /* name in local context */
02085                                          orig_id,            /* name in definition context  */
02086                                          nominal_modidx,     /* nominal source module */
02087                                          nominal_name,       /* nominal import before local renaming */
02088                                          SCHEME_INT_VAL(mod_phase), /* phase of source defn */
02089                                          src_phase_index,    /* nominal import phase */
02090                                          nominal_src_phase,  /* nominal export phase */
02091                                          rename_insp,
02092                                          3);
02093 
02094   if (*_sealed) {
02095     /* cache the result */
02096     scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, id, result);
02097   }
02098 
02099   return result;
02100 }
02101 
02102 void scheme_install_free_id_rename(Scheme_Object *id, 
02103                                    Scheme_Object *orig_id,
02104                                    Scheme_Object *rename_rib,
02105                                    Scheme_Object *phase)
02106 {
02107   Scheme_Object *v = NULL, *env, *r_id;
02108   Scheme_Lexical_Rib *rib = NULL;
02109 
02110   if (rename_rib && (SCHEME_RENAMESP(rename_rib) || SCHEME_RENAMES_SETP(rename_rib))) {
02111     /* Install a Module_Rename-level free-id=? rename, instead of at
02112        the level of a lexical-rename. In this case, id is a symbol instead
02113        of an identifier. */
02114     Module_Renames *rn;
02115 
02116     if (SCHEME_RENAMES_SETP(rename_rib))
02117       rename_rib = scheme_get_module_rename_from_set(rename_rib, phase, 1);
02118     rn = (Module_Renames *)rename_rib;
02119 
02120     if (!rn->free_id_renames) {
02121       Scheme_Hash_Table *ht;
02122       ht = scheme_make_hash_table(SCHEME_hash_ptr);
02123       rn->free_id_renames = ht;
02124     }
02125 
02126     scheme_hash_set(rn->free_id_renames, id, orig_id);
02127 
02128     return;
02129   }
02130 
02131   env = scheme_stx_moduleless_env(id);
02132 
02133   if (rename_rib) {
02134     rib = (Scheme_Lexical_Rib *)rename_rib;
02135   } else {
02136     WRAP_POS wl;
02137     
02138     WRAP_POS_INIT(wl, ((Scheme_Stx *)id)->wraps);
02139     while (!WRAP_POS_END_P(wl)) {
02140       v = WRAP_POS_FIRST(wl);
02141       if (SCHEME_VECTORP(v) && SAME_OBJ(SCHEME_VEC_ELS(v)[0], env)) {
02142         break;
02143       } if (SCHEME_RIBP(v)) {
02144         rib = (Scheme_Lexical_Rib *)v;
02145         while (rib) {
02146           if (rib->rename) {
02147             v = rib->rename;
02148             if (SCHEME_VECTORP(v) && SAME_OBJ(SCHEME_VEC_ELS(v)[0], env))
02149               break;
02150             v = NULL;
02151           }
02152           rib = rib->next;
02153         }
02154       } else
02155         v = NULL;
02156       WRAP_POS_INC(wl);
02157     }
02158   }
02159 
02160   while (v || rib) {
02161     if (!v) {
02162       while (rib) {
02163         if (rib->rename) {
02164           v = rib->rename;
02165           if (SCHEME_VECTORP(v) && SAME_OBJ(SCHEME_VEC_ELS(v)[0], env))
02166             break;
02167           v = NULL;
02168         }
02169         rib = rib->next;
02170       }
02171     }
02172     
02173     if (v) {
02174       int i, sz;
02175     
02176       sz = SCHEME_RENAME_LEN(v);
02177       for (i = 0; i < sz; i++) {
02178         r_id = SCHEME_VEC_ELS(v)[i+2];
02179         if (SAME_OBJ(SCHEME_STX_SYM(r_id), SCHEME_STX_VAL(id))) {
02180           /* Install rename: */
02181           env = SCHEME_VEC_ELS(v)[i+sz+2];
02182           if (SCHEME_PAIRP(env)) env = SCHEME_CAR(env);
02183           env = CONS(env, CONS(orig_id, phase));
02184           SCHEME_VEC_ELS(v)[i+sz+2] = env;
02185           return;
02186         }
02187       }
02188     }
02189 
02190     v = NULL;
02191     if (rib) rib = rib->next;
02192   }
02193 }
02194 
02195 Scheme_Object *scheme_stx_phase_shift_as_rename(long shift, Scheme_Object *old_midx, Scheme_Object *new_midx,
02196                                           Scheme_Hash_Table *export_registry)
02197 {
02198   if (shift || new_midx || export_registry) {
02199     Scheme_Object *vec;
02200     
02201     if (last_phase_shift
02202        && ((vec = SCHEME_BOX_VAL(last_phase_shift)))
02203        && (SCHEME_VEC_ELS(vec)[0] == scheme_make_integer(shift))
02204        && (SCHEME_VEC_ELS(vec)[1] == (new_midx ? old_midx : scheme_false))
02205        && (SCHEME_VEC_ELS(vec)[2] == (new_midx ? new_midx : scheme_false))
02206        && (SCHEME_VEC_ELS(vec)[3] == (export_registry ? (Scheme_Object *)export_registry : scheme_false))) {
02207       /* use the old one */
02208     } else {
02209       vec = scheme_make_vector(4, NULL);
02210       SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(shift);
02211       SCHEME_VEC_ELS(vec)[1] = (new_midx ? old_midx : scheme_false);
02212       SCHEME_VEC_ELS(vec)[2] = (new_midx ? new_midx : scheme_false);
02213       SCHEME_VEC_ELS(vec)[3] = (export_registry ? (Scheme_Object *)export_registry : scheme_false);
02214 
02215       last_phase_shift = scheme_box(vec);
02216     }
02217     
02218     return last_phase_shift;
02219   } else
02220     return NULL;
02221 }
02222 
02223 Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, long shift,
02224                                   Scheme_Object *old_midx, Scheme_Object *new_midx,
02225                                   Scheme_Hash_Table *export_registry)
02226 /* Shifts the phase on a syntax object in a module. A 0 shift might be
02227    used just to re-direct relative module paths. new_midx might be
02228    NULL to shift without redirection. And so on. */
02229 {
02230   Scheme_Object *ps;
02231 
02232   ps = scheme_stx_phase_shift_as_rename(shift, old_midx, new_midx, export_registry);
02233   if (ps)
02234     return scheme_add_rename(stx, ps);  
02235   else
02236     return stx;
02237 }
02238 
02239 void scheme_clear_shift_cache(void)
02240 {
02241   last_phase_shift = NULL;
02242 }
02243 
02244 static void phase_shift_certs(Scheme_Object *o, Scheme_Object *owner_wraps, int len)
02245      /* Mutates o to change its certs, in the case that the first len
02246        elements of owner_wraps includes any phase-shifting (i.e.,
02247        modidx-shifting) elements. */
02248 {
02249   Scheme_Object *l, *a, *modidx_shift_to = NULL, *modidx_shift_from = NULL, *vec, *src, *dest;
02250   int i, j, cnt;
02251 
02252   for (i = 0, l = owner_wraps; i < len; i++, l = SCHEME_CDR(l)) {
02253     a = SCHEME_CAR(l);
02254     if (SAME_TYPE(SCHEME_TYPE(a), scheme_wrap_chunk_type)) {
02255       cnt = ((Wrap_Chunk *)a)->len;
02256       for (j = 0; j < cnt; j++) {
02257        if (SCHEME_BOXP(((Wrap_Chunk *)a)->a[j])) {
02258          vec = SCHEME_BOX_VAL(((Wrap_Chunk *)a)->a[j]);
02259          src = SCHEME_VEC_ELS(vec)[1];
02260          dest = SCHEME_VEC_ELS(vec)[2];
02261          if (!modidx_shift_to) {
02262            modidx_shift_to = dest;
02263          } else if (!SAME_OBJ(modidx_shift_from, dest)) {
02264            modidx_shift_to = scheme_modidx_shift(dest,
02265                                             modidx_shift_from,
02266                                             modidx_shift_to);
02267          }
02268          modidx_shift_from = src;
02269        }
02270       }
02271     } else if (SCHEME_BOXP(a)) {
02272       vec = SCHEME_BOX_VAL(a);
02273       src = SCHEME_VEC_ELS(vec)[1];
02274       dest = SCHEME_VEC_ELS(vec)[2];
02275       if (!modidx_shift_to) {
02276        modidx_shift_to = dest;
02277       } else if (!SAME_OBJ(modidx_shift_from, dest)) {
02278        modidx_shift_to = scheme_modidx_shift(dest,
02279                                          modidx_shift_from,
02280                                          modidx_shift_to);
02281       }
02282       modidx_shift_from = src;
02283     }
02284   }
02285 
02286   if (modidx_shift_from) {
02287     Scheme_Cert *certs, *acerts, *icerts, *first = NULL, *last = NULL, *c;
02288     Scheme_Object *nc;
02289     int i;
02290 
02291     acerts = ACTIVE_CERTS(((Scheme_Stx *)o));
02292     icerts = INACTIVE_CERTS(((Scheme_Stx *)o));
02293     
02294     /* Clone certs list, phase-shifting each cert */
02295     for (i = 0; i < 2; i++) {
02296       certs = (i ? acerts : icerts);
02297       first = last = NULL;
02298       while (certs) {
02299        a = scheme_modidx_shift(certs->modidx, modidx_shift_from, modidx_shift_to);
02300        c = cons_cert(certs->mark, a, certs->insp, certs->key, NULL);
02301        c->mapped = certs->mapped;
02302        c->depth = certs->depth;
02303        if (first)
02304          last->next = c;
02305        else
02306          first = c;
02307        last = c;
02308        certs = certs->next;
02309       }
02310       if (i)
02311        acerts = first;
02312       else
02313        icerts = first;
02314     }
02315 
02316     /* Even if icerts is NULL, may preserve the pair in ->certs, 
02317        to indicate no nested inactive certs: */
02318     {
02319       int no_sub = (SCHEME_RPAIRP(((Scheme_Stx *)o)->certs)
02320                     && SCHEME_IMMUTABLEP(((Scheme_Stx *)o)->certs));
02321       if (icerts || no_sub) {
02322         nc = scheme_make_raw_pair((Scheme_Object *)acerts, (Scheme_Object *)icerts);
02323         if (no_sub)
02324           SCHEME_SET_IMMUTABLE(nc);
02325       } else
02326         nc = (Scheme_Object *)acerts;
02327       
02328       ((Scheme_Stx *)o)->certs = nc;
02329     }
02330   }
02331 }
02332 
02333 static Scheme_Object *make_chunk(int len, Scheme_Object *owner_wraps)
02334 /* Result is a single wrap element (possibly a chunk) or a list
02335    of elements in reverse order. */
02336 {
02337   Wrap_Chunk *wc;
02338   Scheme_Object *l, *a, *max_chunk_start_list = NULL, *ml;
02339   int i, count = 0, j, max_chunk_size = 0, max_chunk_start_pos = 0;
02340 
02341   if (len > 1) {
02342     for (i = 0, l = owner_wraps; i < len; i++, l = SCHEME_CDR(l)) {
02343       a = SCHEME_CAR(l);
02344       if (SAME_TYPE(SCHEME_TYPE(a), scheme_wrap_chunk_type)) {
02345        j = ((Wrap_Chunk *)a)->len;
02346        if (j > max_chunk_size) {
02347          max_chunk_start_list = l;
02348          max_chunk_start_pos = i;
02349          max_chunk_size = j;
02350        }
02351        count += j;
02352       } else if (SCHEME_NUMBERP(a)) {
02353        if ((i >= len-1) || !SAME_OBJ(a, SCHEME_CADR(l)))
02354          count++;
02355        else {
02356          /* Skip canceling marks */
02357          i++;
02358          l = SCHEME_CDR(l);
02359        }
02360       } else if (SCHEME_HASHTP(a)) {
02361        /* Don't propagate chain-specific table */
02362       } else
02363        count++;
02364     }
02365 
02366     if ((max_chunk_size > 8) && ((max_chunk_size * 2) > count)) {
02367       /* It's not worth copying a big existing chunk into
02368         a new chunk. First copy over the part before new chunk,
02369         then the new chunk, and finally the rest. */
02370       Scheme_Object *ml2;
02371       if (max_chunk_start_pos) {
02372        ml = make_chunk(max_chunk_start_pos, owner_wraps);
02373        if (!SCHEME_PAIRP(ml) && !SCHEME_NULLP(ml))
02374          ml = scheme_make_pair(ml, scheme_null);
02375       } else
02376        ml = scheme_null;
02377       ml = scheme_make_pair(SCHEME_CAR(max_chunk_start_list), ml);
02378       if (max_chunk_start_pos + 1 < len) {
02379        ml2 = make_chunk(len - 1 - max_chunk_start_pos, 
02380                       SCHEME_CDR(max_chunk_start_list));
02381        if (!SCHEME_NULLP(ml2)) {
02382          if (SCHEME_PAIRP(ml2))
02383            ml = scheme_append(ml2, ml);
02384          else
02385            ml = scheme_make_pair(ml2, ml);
02386        }
02387       }
02388     } else {
02389       if (!count) {
02390        ml = scheme_null; /* everything disappeared! */
02391       } else {
02392        wc = MALLOC_WRAP_CHUNK(count);
02393        wc->type = scheme_wrap_chunk_type;
02394        wc->len = count;
02395        
02396        ml = NULL; /* to make compiler happy */
02397 
02398        j = 0;
02399        for (i = 0, l = owner_wraps; i < len; i++, l = SCHEME_CDR(l)) {
02400          a = SCHEME_CAR(l);
02401          if (SAME_TYPE(SCHEME_TYPE(a), scheme_wrap_chunk_type)) {
02402            int k, cl = ((Wrap_Chunk *)a)->len;
02403            for (k = 0; k < cl; k++) {
02404              wc->a[j++] = ((Wrap_Chunk *)a)->a[k];
02405            }
02406          }  else if (SCHEME_NUMBERP(a)) {
02407            if ((i >= len-1) || !SAME_OBJ(a, SCHEME_CADR(l)))
02408              wc->a[j++] = a;
02409            else {
02410              /* Skip canceling marks */
02411              i++;
02412              l= SCHEME_CDR(l);
02413            }
02414          } else if (SCHEME_HASHTP(a)) {
02415            /* Skip chain-specific table */
02416          } else
02417            wc->a[j++] = a;
02418        }
02419 
02420        if (count == 1) /* in case mark removal left only one */
02421          ml = wc->a[0];
02422        else
02423          ml = (Scheme_Object *)wc;
02424       }
02425     }
02426   } else {
02427     ml = SCHEME_CAR(owner_wraps);
02428     if (SCHEME_HASHTP(ml))
02429       return scheme_null;
02430   }
02431 
02432   return ml;
02433 }
02434 
02435 #define PREEMPTIVE_CHUNK_THRESHOLD 32
02436 
02437 static void preemptive_chunk(Scheme_Stx *stx)
02438 {
02439   int wl_count;
02440   int new_count;
02441   Scheme_Object *here_wraps, *ml;
02442 
02443   /* If the lazy prefix is long, transform it into a chunk. Probably,
02444      some syntax object derived from this one will be unpacked, and
02445      then the lazy prefix will need to be pushed down.
02446 
02447      This chunking fights somewhat with the chain-cache heuristic,
02448      since a chain cache can't be included in a chunk. Still, the
02449      combination seems to work better than either alone for deeply
02450      nested scopes.
02451 
02452      It might also interact badly with simplication or marshaling,
02453      since it decreases chain sharing. This is seems unlikely to
02454      matter, since deeply nested syntax information will be expensive
02455      in any case, and nodes in the wraps are still shared. */
02456 
02457   wl_count = stx->u.lazy_prefix;
02458 
02459   if (wl_count > PREEMPTIVE_CHUNK_THRESHOLD) {
02460     /* Chunk it */
02461     here_wraps = stx->wraps;
02462 
02463     ml = make_chunk(wl_count, here_wraps);
02464     
02465     if (SCHEME_PAIRP(ml) || SCHEME_NULLP(ml)) {
02466       new_count = scheme_list_length(ml);
02467       if (new_count == 1)
02468        ml = SCHEME_CAR(ml);
02469     } else {
02470       new_count = 1;
02471     }
02472 
02473     while (wl_count--) {
02474       here_wraps = SCHEME_CDR(here_wraps);
02475     }
02476     wl_count = new_count;
02477 
02478     if (new_count == 1)
02479       here_wraps = scheme_make_pair(ml, here_wraps);
02480     else {
02481       while (new_count--) {
02482        here_wraps = scheme_make_pair(SCHEME_CAR(ml), here_wraps);
02483        ml = SCHEME_CDR(ml);
02484       }
02485     }
02486 
02487     stx->wraps = here_wraps;
02488     stx->u.lazy_prefix = wl_count;
02489   }
02490 }
02491 
02492 static Scheme_Object *propagate_wraps(Scheme_Object *o, 
02493                                   int len, Scheme_Object **_ml,
02494                                   Scheme_Object *owner_wraps)
02495 {
02496   int i;
02497   Scheme_Object *ml, *a;
02498 
02499   /* Would adding the wraps generate a list equivalent to owner_wraps?
02500      If so, use owner_wraps directly. But if len is too big, then it
02501      takes too long to check, and so it's better to start chunking. */
02502   if (len < 128) {
02503     Scheme_Stx *stx = (Scheme_Stx *)o;
02504     Scheme_Object *p1 = owner_wraps;
02505     Scheme_Object *certs;
02506 
02507     /* Find list after |wl| items in owner_wraps: */
02508     for (i = 0; i < len; i++) {
02509       p1 = SCHEME_CDR(p1);
02510     }
02511     /* p1 is the list after wl... */
02512     
02513     if (SAME_OBJ(stx->wraps, p1)) {
02514       /* So, we can use owner_wraps directly instead of building
02515         new wraps. */
02516       long lp;
02517 
02518       if (STX_KEY(stx) & STX_SUBSTX_FLAG)
02519        lp = stx->u.lazy_prefix + len;
02520       else
02521        lp = 0;
02522 
02523       certs = stx->certs;
02524       stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props);
02525       stx->wraps = owner_wraps;
02526       stx->u.lazy_prefix = lp; /* same as zeroing cache if no SUBSTX */
02527       stx->certs = certs;
02528 
02529       if (stx->certs)
02530        phase_shift_certs((Scheme_Object *)stx, owner_wraps, len);
02531 
02532       return (Scheme_Object *)stx;
02533     }
02534   }
02535 
02536   ml = *_ml;
02537   if (!ml) {
02538     ml = make_chunk(len, owner_wraps);
02539     *_ml = ml;
02540   }
02541 
02542   if (SCHEME_PAIRP(ml)) {
02543     while (SCHEME_PAIRP(ml)) {
02544       a = SCHEME_CAR(ml);
02545       if (SCHEME_NUMBERP(a)) {
02546        o = scheme_add_remove_mark(o, a);
02547       } else {
02548        o = scheme_add_rename(o, a);
02549       }
02550       ml = SCHEME_CDR(ml);
02551     }
02552   } else if (SCHEME_NUMBERP(ml))
02553     o = scheme_add_remove_mark(o, ml);
02554   else if (SCHEME_NULLP(ml)) {
02555     /* nothing to add */
02556   } else
02557     o = scheme_add_rename(o, ml);
02558 
02559   if (((Scheme_Stx *)o)->certs)
02560     phase_shift_certs(o, owner_wraps, len);
02561 
02562   return o;
02563 }
02564 
02565 int scheme_stx_certified(Scheme_Object *stx, Scheme_Object *extra_certs, 
02566                       Scheme_Object *home_modidx, Scheme_Object *home_insp)
02567 {
02568   Scheme_Cert *certs = ACTIVE_CERTS((Scheme_Stx *)stx);
02569   Scheme_Object *cert_modidx, *a, *b;
02570 
02571   do {
02572     while (certs) {
02573       if (!scheme_module_protected_wrt(home_insp, certs->insp)) {
02574        if (home_modidx) {
02575          if (SCHEME_FALSEP(certs->modidx))
02576            cert_modidx = home_modidx;
02577          else
02578            cert_modidx = certs->modidx;
02579          
02580          a = scheme_module_resolve(home_modidx, 0);
02581          b = scheme_module_resolve(cert_modidx, 0);
02582        } else
02583          a = b = NULL;
02584        
02585        if (SAME_OBJ(a, b)) {
02586          /* Found a certification. Does this identifier have the
02587             associated mark? */
02588          if (includes_mark(((Scheme_Stx *)stx)->wraps, certs->mark))
02589            return 1;
02590        }
02591       }
02592       certs = certs->next;
02593     }
02594     if (extra_certs) {
02595       certs = (Scheme_Cert *)extra_certs;
02596       extra_certs = NULL;
02597     }
02598   } while (certs);
02599 
02600   return 0;
02601 }
02602 
02603 static Scheme_Cert *cons_cert(Scheme_Object *mark, Scheme_Object *modidx, 
02604                            Scheme_Object *insp, Scheme_Object *key, 
02605                            Scheme_Cert *next_cert)
02606 {
02607   Scheme_Cert *cert;
02608 
02609   cert = MALLOC_ONE_RT(Scheme_Cert);
02610   cert->iso.so.type = scheme_certifications_type;
02611   cert->mark = mark;
02612   cert->modidx = modidx;
02613   cert->insp = insp;
02614   cert->key = key;
02615   cert->next = next_cert;
02616   cert->depth = (next_cert ? next_cert->depth + 1 : 1);
02617 
02618   if (!key && (!next_cert || CERT_NO_KEY(next_cert))) {
02619     CERT_SET_NO_KEY(cert);
02620   }
02621 
02622   return cert;
02623 }
02624 
02625 #ifdef DO_STACK_CHECK
02626 static void make_mapped(Scheme_Cert *cert);
02627 static Scheme_Object *make_mapped_k(void)
02628 {
02629   Scheme_Thread *p = scheme_current_thread;
02630   Scheme_Cert *cert = (Scheme_Cert *)p->ku.k.p1;
02631 
02632   p->ku.k.p1 = NULL;
02633 
02634   make_mapped(cert);
02635 
02636   return scheme_void;
02637 }
02638 #endif
02639 
02640 static void make_mapped(Scheme_Cert *cert)
02641 {
02642   Scheme_Cert *stop, *c2;
02643   Scheme_Object *pr;
02644   Scheme_Hash_Table *ht;
02645 
02646   if (cert->mapped)
02647     return;
02648 
02649 #ifdef DO_STACK_CHECK
02650   {
02651 # include "mzstkchk.h"
02652     {
02653       Scheme_Thread *p = scheme_current_thread;
02654       p->ku.k.p1 = (void *)cert;
02655       scheme_handle_stack_overflow(make_mapped_k);
02656       return;
02657     }
02658   }
02659 #endif
02660   SCHEME_USE_FUEL(1);
02661 
02662   if (cert->depth == 16) {
02663     stop = NULL;
02664   } else {
02665     for (stop = cert->next; 
02666         stop && ((stop->depth & cert->depth) != stop->depth); 
02667         stop = stop->next) {
02668     }
02669     if (stop)
02670       make_mapped(stop);
02671   }
02672 
02673   /* Check whether an `eq?' table will work: */
02674   for (c2 = cert; c2 != stop; c2 = c2->next) {
02675     if (c2->key)
02676       break;
02677     if (!SCHEME_INTP(c2->mark))
02678       break;
02679   }
02680 
02681   if (c2 == stop)
02682     ht = scheme_make_hash_table(SCHEME_hash_ptr);
02683   else
02684     ht = scheme_make_hash_table_equal();
02685 
02686   pr = scheme_make_raw_pair((Scheme_Object *)ht, (Scheme_Object *)stop);
02687   cert->mapped = pr;
02688 
02689   for (; cert != stop; cert = cert->next) {
02690     if (cert->key)
02691       pr = scheme_make_pair(cert->mark, cert->key);
02692     else
02693       pr = cert->mark;
02694     scheme_hash_set_atomic(ht, pr, scheme_true);
02695   }
02696 }
02697 
02698 static int cert_in_chain(Scheme_Object *mark, Scheme_Object *key, Scheme_Cert *cert)
02699 {
02700   Scheme_Object *hkey = key ? NULL : mark;
02701   Scheme_Hash_Table *ht;
02702 
02703   while (cert) {
02704     if (!(cert->depth & 0xF)) {
02705       make_mapped(cert);
02706 
02707       ht = (Scheme_Hash_Table *)SCHEME_CAR(cert->mapped);
02708       cert = (Scheme_Cert *)SCHEME_CDR(cert->mapped);
02709 
02710       if (!hkey)
02711        hkey = scheme_make_pair(mark, key);
02712 
02713       if (scheme_hash_get_atomic(ht, hkey))
02714        return 1;
02715     } else if (SAME_OBJ(cert->mark, mark)
02716               && SAME_OBJ(cert->key, key)) {
02717       return 1;
02718     } else
02719       cert = cert->next;
02720   }
02721 
02722   return 0;
02723 }
02724 
02725 static Scheme_Cert *append_certs(Scheme_Cert *a, Scheme_Cert *b)
02726 {
02727   Scheme_Cert *c;
02728 
02729   if (!a) return b;
02730   if (!b) return a;
02731   
02732   if (a->depth < b->depth) {
02733     c = a;
02734     a = b;
02735     b = c;
02736   }
02737 
02738   c = a;
02739   if (b->depth > (a->depth >> 1)) {
02740     /* There's a good chance that b shares a tail with a, 
02741        so check for that, and b is large enough relative to
02742        a that it's worth iterating down to b's depth in a: */
02743     while (c->depth > b->depth) {
02744       c = c->next;
02745     }
02746   }
02747 
02748   for (; b; b = b->next) {
02749     if (b == c) break;
02750     if (!cert_in_chain(b->mark, b->key, a))
02751       a = cons_cert(b->mark, b->modidx, b->insp, b->key, a);
02752     c = c->next;
02753   }
02754 
02755   return a;
02756 }
02757 
02758 static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Object *use_key, int active)
02759 {
02760   Scheme_Cert *orig_certs, *cl, *now_certs, *next_certs, *check_tail;
02761   Scheme_Stx *stx = (Scheme_Stx *)o, *res;
02762   Scheme_Object *pr;
02763   int shortcut;
02764 
02765   if (!stx->certs) {
02766     if (!certs)
02767       return (Scheme_Object *)stx;
02768 
02769     if (use_key) {
02770       for (cl = certs; cl; cl = cl->next) {
02771        if (!SAME_OBJ(cl->key, use_key))
02772          break;
02773       }
02774     } else
02775       cl = NULL;
02776 
02777     if (!cl) {
02778       res = (Scheme_Stx *)scheme_make_stx(stx->val, 
02779                                      stx->srcloc,
02780                                      stx->props);
02781       res->wraps = stx->wraps;
02782       res->u.lazy_prefix = stx->u.lazy_prefix;
02783       if (active)
02784        res->certs = (Scheme_Object *)certs;
02785       else {
02786        pr = scheme_make_raw_pair(NULL, (Scheme_Object *)certs);
02787        res->certs = pr;
02788       }
02789       return (Scheme_Object *)res;
02790     }
02791   }
02792 
02793   if (active)
02794     orig_certs = ACTIVE_CERTS(stx);
02795   else
02796     orig_certs = INACTIVE_CERTS(stx);
02797   now_certs = orig_certs;
02798 
02799   shortcut = 0;
02800   if (now_certs && certs && !use_key && CERT_NO_KEY(certs)) {
02801     if (now_certs->depth < certs->depth) {
02802       /* We can add now_certs onto certs, instead of the other
02803          way around. */
02804       now_certs = certs;
02805       certs = orig_certs;
02806     }
02807   }
02808 
02809   check_tail = now_certs;
02810   if (check_tail && certs
02811       && (certs->depth  > (check_tail->depth >> 1))) {
02812     while (check_tail->depth > certs->depth) {
02813       check_tail = check_tail->next;
02814     }
02815   }
02816   
02817   for (; certs; certs = next_certs) {
02818     next_certs = certs->next;
02819     if (check_tail && (check_tail->depth > certs->depth))
02820       check_tail = check_tail->next;
02821     if (SAME_OBJ(certs, check_tail)) {
02822       /* tails match --- no need to keep checking */
02823       break;
02824     }
02825     if (!cert_in_chain(certs->mark, use_key, now_certs)) {
02826       if (!now_certs && !use_key && (shortcut || CERT_NO_KEY(certs))) {
02827         now_certs = certs;
02828         next_certs = NULL;
02829       } else {
02830         now_certs = cons_cert(certs->mark, certs->modidx, certs->insp, use_key, 
02831                               now_certs);
02832       }
02833     }
02834   }
02835 
02836   if (!SAME_OBJ(now_certs, orig_certs)) {
02837     res = (Scheme_Stx *)scheme_make_stx(stx->val, 
02838                                         stx->srcloc,
02839                                         stx->props);
02840     res->wraps = stx->wraps;
02841     res->u.lazy_prefix = stx->u.lazy_prefix;
02842     if (!active) {
02843       pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)orig_certs);
02844       res->certs = pr;
02845       if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_IMMUTABLEP(stx->certs))
02846         SCHEME_SET_IMMUTABLE(pr);
02847     } else if (stx->certs && SCHEME_RPAIRP(stx->certs)) {
02848       pr = scheme_make_raw_pair((Scheme_Object *)orig_certs, SCHEME_CDR(stx->certs));
02849       res->certs = pr;
02850       if (SCHEME_IMMUTABLEP(stx->certs))
02851         SCHEME_SET_IMMUTABLE(pr);
02852     } else
02853       res->certs = (Scheme_Object *)orig_certs;
02854     stx = res;
02855 
02856     if (!active) {
02857       SCHEME_CDR(stx->certs) = (Scheme_Object *)now_certs;
02858     } else if (stx->certs && SCHEME_RPAIRP(stx->certs))
02859       SCHEME_CAR(stx->certs) = (Scheme_Object *)now_certs;
02860     else
02861       stx->certs = (Scheme_Object *)now_certs;
02862   }
02863 
02864   return (Scheme_Object *)stx;
02865 }
02866 
02867 Scheme_Object *scheme_stx_add_inactive_certs(Scheme_Object *o, Scheme_Object *certs)
02868   /* Also lifts existing inactive certs to the top. */
02869 {
02870   /* Lift inactive certs*/
02871   o = lift_inactive_certs(o, 0);
02872 
02873   return add_certs(o, (Scheme_Cert *)certs, NULL, 0);
02874 }
02875 
02876 Scheme_Object *scheme_stx_propagate_inactive_certs(Scheme_Object *o, Scheme_Object *orig)
02877 {
02878   Scheme_Cert *certs;
02879 
02880   certs = INACTIVE_CERTS((Scheme_Stx *)orig);
02881 
02882   if (certs)
02883     return scheme_stx_add_inactive_certs(o, (Scheme_Object *)certs);
02884   else
02885     return o;
02886 }
02887 
02888 Scheme_Object *scheme_stx_extract_certs(Scheme_Object *o, Scheme_Object *base_certs)
02889 {
02890   return (Scheme_Object *)append_certs((Scheme_Cert *)base_certs,
02891                                        ACTIVE_CERTS((Scheme_Stx *)o));
02892 }
02893 
02894 Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env *menv, 
02895                             Scheme_Object *plus_stx_or_certs, Scheme_Object *key, 
02896                             int active)
02897      /* If `name' is module-bound, add the module's certification.
02898        Also copy any certifications from plus_stx.
02899        If active and mark is non-NULL, make inactive certificates active.
02900         Existing inactive are lifted when adding from plus_stx_or_certs. */
02901 {
02902   if (mark && active) {
02903     o = scheme_stx_activate_certs(o);
02904   }
02905 
02906   if (plus_stx_or_certs) {
02907     Scheme_Cert *certs;
02908     if (SCHEME_STXP(plus_stx_or_certs))
02909       certs = ACTIVE_CERTS((Scheme_Stx *)plus_stx_or_certs);
02910     else
02911       certs = (Scheme_Cert *)plus_stx_or_certs;
02912     if (certs) {
02913       if (!active)
02914         o = lift_inactive_certs(o, 0);
02915       o = add_certs(o, certs, key, active);
02916     }
02917     /* Also copy over inactive certs, if any */
02918     if (SCHEME_STXP(plus_stx_or_certs)) {
02919       o = lift_inactive_certs(o, 0);
02920       o = add_certs(o, INACTIVE_CERTS((Scheme_Stx *)plus_stx_or_certs), key, 0);
02921     }
02922   }
02923 
02924   if (menv && !menv->module->no_cert) {
02925     Scheme_Stx *stx = (Scheme_Stx *)o, *res;
02926     Scheme_Cert *cert;
02927 
02928     res = (Scheme_Stx *)scheme_make_stx(stx->val, 
02929                                    stx->srcloc,
02930                                    stx->props);
02931     res->wraps = stx->wraps;
02932     res->u.lazy_prefix = stx->u.lazy_prefix;
02933 
02934     if (SCHEME_FALSEP(mark)) {
02935       /* Need to invent a certificate-only mark and apply it */
02936       mark = scheme_new_mark();
02937       mark = negate_mark(mark);
02938       res = (Scheme_Stx *)scheme_add_remove_mark((Scheme_Object *)res, mark);
02939     }
02940 
02941     if (active)
02942       cert = ACTIVE_CERTS(stx);
02943     else
02944       cert = INACTIVE_CERTS(stx);
02945 
02946     cert = cons_cert(mark, menv->link_midx ? menv->link_midx : menv->module->me->src_modidx, 
02947                      menv->module->insp, key, cert);
02948 
02949     if (active) {
02950       if (stx->certs && SCHEME_RPAIRP(stx->certs)) {
02951        Scheme_Object *pr;
02952        pr = scheme_make_raw_pair((Scheme_Object *)cert, SCHEME_CDR(stx->certs));
02953        res->certs = pr;
02954         if (SCHEME_IMMUTABLEP(stx->certs))
02955           SCHEME_SET_IMMUTABLE(pr);
02956       } else
02957        res->certs = (Scheme_Object *)cert;
02958     } else {
02959       Scheme_Object *pr;
02960       pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)cert);
02961       res->certs = pr;
02962       if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_IMMUTABLEP(stx->certs))
02963         SCHEME_SET_IMMUTABLE(pr);
02964     }
02965     
02966     o = (Scheme_Object *)res;
02967   }
02968 
02969   return o;
02970 }
02971 
02972 Scheme_Object *scheme_stx_content(Scheme_Object *o)
02973      /* Propagates wraps while getting a syntax object's content. */
02974 {
02975   Scheme_Stx *stx = (Scheme_Stx *)o;
02976 
02977   /* The fast-past tests are duplicated in jit.c. */
02978 
02979   if ((STX_KEY(stx) & STX_SUBSTX_FLAG) && stx->u.lazy_prefix) {
02980     Scheme_Object *v = stx->val, *result;
02981     Scheme_Object *here_wraps;
02982     Scheme_Object *ml = NULL;
02983     int wl_count = 0;
02984 
02985     here_wraps = stx->wraps;
02986     wl_count = stx->u.lazy_prefix;
02987     stx->u.lazy_prefix = 0;
02988 
02989     if (SCHEME_PAIRP(v)) {
02990       Scheme_Object *last = NULL, *first = NULL;
02991 
02992       while (SCHEME_PAIRP(v)) {
02993        Scheme_Object *p;
02994        result = propagate_wraps(SCHEME_CAR(v), wl_count, &ml, here_wraps);
02995        p = scheme_make_pair(result, scheme_null);
02996        if (last)
02997          SCHEME_CDR(last) = p;
02998        else
02999          first = p;
03000        last = p;
03001        v = SCHEME_CDR(v);
03002       }
03003       if (!SCHEME_NULLP(v)) {
03004        result = propagate_wraps(v, wl_count, &ml, here_wraps);
03005        if (last)
03006          SCHEME_CDR(last) = result;
03007        else
03008          first = result;
03009       }
03010       v = first;
03011     } else if (SCHEME_BOXP(v)) {
03012       result = propagate_wraps(SCHEME_BOX_VAL(v), wl_count, &ml, here_wraps);
03013       v = scheme_box(result);
03014     } else if (SCHEME_VECTORP(v)) {
03015       Scheme_Object *v2;
03016       int size = SCHEME_VEC_SIZE(v), i;
03017       
03018       v2 = scheme_make_vector(size, NULL);
03019       
03020       for (i = 0; i < size; i++) {
03021        result = propagate_wraps(SCHEME_VEC_ELS(v)[i], wl_count, &ml, here_wraps);
03022        SCHEME_VEC_ELS(v2)[i] = result;
03023       }
03024       
03025       v = v2;
03026     } else if (SCHEME_HASHTRP(v)) {
03027       Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v, *ht2;
03028       Scheme_Object *key, *val;
03029       int i;
03030 
03031       ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht) & 0x3);
03032 
03033       i = scheme_hash_tree_next(ht, -1);
03034       while (i != -1) {
03035         scheme_hash_tree_index(ht, i, &key, &val);
03036         val = propagate_wraps(val, wl_count, &ml, here_wraps);
03037         ht2 = scheme_hash_tree_set(ht2, key, val);
03038         i = scheme_hash_tree_next(ht, i);
03039       }
03040 
03041       v = (Scheme_Object *)ht2;
03042     } else if (prefab_p(v)) {
03043       Scheme_Structure *s = (Scheme_Structure *)v;
03044       Scheme_Object *r;
03045       int size, i;
03046 
03047       s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s);
03048       
03049       size = s->stype->num_slots;
03050       for (i = 0; i < size; i++) {
03051         r = propagate_wraps(s->slots[i], wl_count, &ml, here_wraps);
03052         s->slots[i] = r;
03053       }
03054 
03055       v = (Scheme_Object *)s;
03056     }
03057 
03058     stx->val = v;
03059   }
03060 
03061   return stx->val;
03062 }
03063 
03064 Scheme_Object *scheme_stx_extract_marks(Scheme_Object *stx)
03065 /* Does not include negative marks */
03066 {
03067   WRAP_POS awl;
03068   Scheme_Object *acur_mark, *p, *marks = scheme_null;
03069 
03070   WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps);
03071 
03072   while (1) {
03073     /* Skip over renames, immediately-canceled marks, and negative marks: */
03074     acur_mark = NULL;
03075     while (1) {
03076       if (WRAP_POS_END_P(awl))
03077        break;
03078       p = WRAP_POS_FIRST(awl);
03079       if (SCHEME_NUMBERP(p) && IS_POSMARK(p)) {
03080        if (acur_mark) {
03081          if (SAME_OBJ(acur_mark, p)) {
03082            acur_mark = NULL;
03083            WRAP_POS_INC(awl);
03084          } else
03085            break;
03086        } else {
03087          acur_mark = p;
03088          WRAP_POS_INC(awl);
03089        }
03090       } else {
03091        WRAP_POS_INC(awl);
03092       }
03093     }
03094 
03095     if (acur_mark) {
03096       if (SCHEME_PAIRP(marks) && SAME_OBJ(acur_mark, SCHEME_CAR(marks)))
03097         marks = SCHEME_CDR(marks);
03098       else
03099         marks = scheme_make_pair(acur_mark, marks);
03100     }
03101 
03102     if (WRAP_POS_END_P(awl))
03103       return scheme_reverse(marks);
03104   }
03105 }
03106 
03107 Scheme_Object *scheme_stx_strip_module_context(Scheme_Object *_stx)
03108 {
03109   Scheme_Stx *stx = (Scheme_Stx *)_stx;
03110   WRAP_POS awl;
03111   int mod_ctx_count = 0, skipped = 0;
03112   Scheme_Object *v;
03113   Wrap_Chunk *chunk;
03114 
03115   /* Check for module context, first: */
03116   WRAP_POS_INIT(awl, stx->wraps);
03117   while (!WRAP_POS_END_P(awl)) {
03118     v = WRAP_POS_FIRST(awl);
03119     if (SCHEME_RENAMESP(v) || SCHEME_BOXP(v) || SCHEME_RENAMES_SETP(v)) {
03120       mod_ctx_count++;
03121     }
03122     WRAP_POS_INC(awl);
03123     skipped++;
03124   }
03125   
03126   if (!mod_ctx_count)
03127     return _stx;
03128 
03129   if (mod_ctx_count == skipped) {
03130     /* Everything was a module context? An unlikely but easy case. */
03131     return scheme_make_stx(stx->val, stx->srcloc, stx->props);
03132   } else {
03133     /* Copy everything else into a new chunk. */
03134     chunk = MALLOC_WRAP_CHUNK((skipped - mod_ctx_count));
03135     chunk->type = scheme_wrap_chunk_type;
03136     chunk->len = skipped - mod_ctx_count;
03137     skipped = 0;
03138     WRAP_POS_INIT(awl, stx->wraps);
03139     while (!WRAP_POS_END_P(awl)) {
03140       v = WRAP_POS_FIRST(awl);
03141       if (!SCHEME_RENAMESP(v) && !SCHEME_BOXP(v) && !SCHEME_RENAMES_SETP(v)) {
03142        chunk->a[skipped] = v;
03143        skipped++;
03144       }
03145       WRAP_POS_INC(awl);
03146     }
03147 
03148     stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props);
03149     v = scheme_make_pair((Scheme_Object *)chunk, scheme_null);
03150     stx->wraps = v;
03151     return (Scheme_Object *)stx;
03152   }
03153 }
03154 
03155 #ifdef DO_STACK_CHECK
03156 static Scheme_Object *stx_activate_certs_k(void)
03157 {
03158   Scheme_Thread *p = scheme_current_thread;
03159   Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
03160   Scheme_Cert **cp = (Scheme_Cert **)p->ku.k.p2;
03161 
03162   p->ku.k.p1 = NULL;
03163   p->ku.k.p2 = NULL;
03164 
03165   return stx_activate_certs(o, cp);
03166 }
03167 #endif
03168 
03169 static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp)
03170 {
03171 #ifdef DO_STACK_CHECK
03172   {
03173 # include "mzstkchk.h"
03174     {
03175       Scheme_Thread *p = scheme_current_thread;
03176       Scheme_Cert **_cp;
03177       _cp = MALLOC_N(Scheme_Cert*, 1);
03178       *_cp = *cp;
03179       p->ku.k.p1 = (void *)o;
03180       p->ku.k.p2 = (void *)_cp;
03181       o = scheme_handle_stack_overflow(stx_activate_certs_k);
03182       *cp = *_cp;
03183       return o;
03184     }
03185   }
03186 #endif
03187   SCHEME_USE_FUEL(1);
03188 
03189   if (SCHEME_PAIRP(o)) {
03190     Scheme_Object *a, *d;
03191     a = stx_activate_certs(SCHEME_CAR(o), cp);
03192     d = stx_activate_certs(SCHEME_CDR(o), cp);
03193     if (SAME_OBJ(a, SCHEME_CAR(o))
03194        && SAME_OBJ(d, SCHEME_CDR(o)))
03195       return o;
03196     return ICONS(a, d);
03197   } else if (SCHEME_NULLP(o)) {
03198     return o;
03199   } else if (SCHEME_BOXP(o)) {
03200     Scheme_Object *c;
03201     c = stx_activate_certs(SCHEME_BOX_VAL(o), cp);
03202     if (SAME_OBJ(c, SCHEME_BOX_VAL(o)))
03203       return o;
03204     o = scheme_box(c);
03205     SCHEME_SET_IMMUTABLE(o);
03206     return o;
03207   } else if (SCHEME_VECTORP(o)) {
03208     Scheme_Object *e = NULL, *v2;
03209     int size = SCHEME_VEC_SIZE(o), i, j;
03210     
03211     for (i = 0; i < size; i++) {
03212       e = stx_activate_certs(SCHEME_VEC_ELS(o)[i], cp);
03213       if (!SAME_OBJ(e, SCHEME_VEC_ELS(o)[i]))
03214        break;
03215     }
03216 
03217     if (i == size)
03218       return o;
03219 
03220     v2 = scheme_make_vector(size, NULL);
03221     
03222     for (j = 0; j < i; j++) {
03223       SCHEME_VEC_ELS(v2)[j] = SCHEME_VEC_ELS(o)[j];
03224     }
03225     SCHEME_VEC_ELS(v2)[i] = e;
03226     for (i++; i < size; i++) {
03227       e = stx_activate_certs(SCHEME_VEC_ELS(o)[i], cp);
03228       SCHEME_VEC_ELS(v2)[i] = e;
03229     }
03230 
03231     SCHEME_SET_IMMUTABLE(v2);
03232     return v2;
03233   } else if (SCHEME_HASHTRP(o)) {
03234     Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)o, *ht2;
03235     Scheme_Object *key = NULL, *val, *e, *jkey;
03236     int i, j;
03237     
03238     j = scheme_hash_tree_next(ht, -1);
03239     while (j != -1) {
03240       scheme_hash_tree_index(ht, j, &key, &val);
03241       e = stx_activate_certs(val, cp);
03242       if (!SAME_OBJ(e, val))
03243         break;
03244       j = scheme_hash_tree_next(ht, j);
03245     }
03246 
03247     if (j == -1)
03248       return o;
03249     jkey = key;
03250 
03251     ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht) & 0x3);
03252     
03253     i = scheme_hash_tree_next(ht, -1);
03254     while (i != j) {
03255       scheme_hash_tree_index(ht, i, &key, &val);
03256       ht2 = scheme_hash_tree_set(ht2, key, val);
03257       i = scheme_hash_tree_next(ht, i);
03258     }
03259     ht2 = scheme_hash_tree_set(ht2, key, e);
03260     i = scheme_hash_tree_next(ht, i);
03261     while (i != -1) {
03262       scheme_hash_tree_index(ht, i, &key, &val);
03263       val = stx_activate_certs(val, cp);
03264       ht2 = scheme_hash_tree_set(ht2, key, val);
03265       i = scheme_hash_tree_next(ht, i);
03266     }
03267     
03268     return (Scheme_Object *)ht2;
03269   } else if (prefab_p(o)) {
03270     Scheme_Object *e = NULL;
03271     Scheme_Structure *s = (Scheme_Structure *)o;
03272     int i, size = s->stype->num_slots;
03273 
03274     for (i = 0; i < size; i++) {
03275       e = stx_activate_certs(s->slots[i], cp);
03276       if (!SAME_OBJ(e, s->slots[i]))
03277        break;
03278     }
03279 
03280     if (i == size)
03281       return o;
03282 
03283     s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s);
03284     s->slots[i] = e;
03285     
03286     for (i++; i < size; i++) {
03287       e = stx_activate_certs(s->slots[i], cp);
03288       s->slots[i] = e;
03289     }
03290     
03291     return (Scheme_Object *)s;
03292   } else if (SCHEME_STXP(o)) {
03293     Scheme_Stx *stx = (Scheme_Stx *)o;
03294 
03295     if (INACTIVE_CERTS(stx)) {
03296       /* Change inactive certs to active certs. */
03297       Scheme_Object *np, *v;
03298       Scheme_Stx *res;
03299       Scheme_Cert *certs;
03300 
03301       if (SCHEME_IMMUTABLEP(stx->certs)) {
03302         /* No sub-object has other inactive certs */
03303         v = stx->val;
03304       } else {
03305         v = stx_activate_certs(stx->val, cp);
03306       }
03307 
03308       res = (Scheme_Stx *)scheme_make_stx(v, 
03309                                      stx->srcloc,
03310                                      stx->props);
03311       res->wraps = stx->wraps;
03312       res->u.lazy_prefix = stx->u.lazy_prefix;
03313       if (!ACTIVE_CERTS(stx))
03314         np = no_nested_inactive_certs;
03315       else {
03316         np = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), NULL);
03317         SCHEME_SET_IMMUTABLE(np);
03318       }
03319       res->certs = np;
03320 
03321       certs = append_certs(INACTIVE_CERTS(stx), *cp);
03322       *cp = certs;
03323 
03324       return (Scheme_Object *)res;
03325     } else if (stx->certs && SCHEME_RPAIRP(stx->certs) 
03326                && SCHEME_IMMUTABLEP(stx->certs)) {
03327       /* Explicit pair, but no inactive certs anywhere in this object. */
03328       return (Scheme_Object *)stx;
03329     } else {
03330       o = stx_activate_certs(stx->val, cp);
03331 
03332       if (!SAME_OBJ(o, stx->val)) {
03333        Scheme_Stx *res;
03334        res = (Scheme_Stx *)scheme_make_stx(o, 
03335                                        stx->srcloc,
03336                                        stx->props);
03337        res->wraps = stx->wraps;
03338        res->u.lazy_prefix = stx->u.lazy_prefix;
03339        if (ACTIVE_CERTS(stx)) {
03340          Scheme_Object *np;
03341          np = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), NULL);
03342          res->certs = np;
03343           SCHEME_SET_IMMUTABLE(np);
03344        } else
03345          res->certs = no_nested_inactive_certs;
03346 
03347        return (Scheme_Object *)res;
03348       } else {
03349        /* Record the absence of certificates in sub-parts: */
03350        if (stx->certs) {
03351          Scheme_Object *np;
03352          np = scheme_make_raw_pair(stx->certs, NULL);
03353          stx->certs = np;
03354           SCHEME_SET_IMMUTABLE(np);
03355        } else
03356          stx->certs = no_nested_inactive_certs;
03357         
03358        return (Scheme_Object *)stx;
03359       }
03360     }
03361   } else
03362     return o;
03363 }
03364 
03365 static Scheme_Object *lift_inactive_certs(Scheme_Object *o, int as_active)
03366 {
03367   Scheme_Cert *certs = NULL;
03368 
03369   o = stx_activate_certs(o, &certs);
03370   /* the inactive certs collected into `certs'
03371      have been stripped from `o' at this point */
03372 
03373   if (certs)
03374     o = add_certs(o, certs, NULL, as_active);
03375 
03376   return o;
03377 }
03378 
03379 Scheme_Object *scheme_stx_activate_certs(Scheme_Object *o)
03380 {
03381   return lift_inactive_certs(o, 1);
03382 }
03383 
03384 int scheme_stx_has_empty_wraps(Scheme_Object *o)
03385 {
03386   WRAP_POS awl;
03387   Scheme_Object *mark = NULL, *v;
03388 
03389   WRAP_POS_INIT(awl, ((Scheme_Stx *)o)->wraps);
03390   while (!WRAP_POS_END_P(awl)) {
03391     v = WRAP_POS_FIRST(awl);
03392     if (mark) {
03393       if (!SAME_OBJ(mark, v))
03394         return 0;
03395       mark = NULL;
03396     } else
03397       mark = v;
03398     WRAP_POS_INC(awl);
03399   }
03400 
03401   return !mark;
03402 }
03403 
03404 /*========================================================================*/
03405 /*                           stx comparison                               */
03406 /*========================================================================*/
03407 
03408 /* If no marks and no rename with this set's tag,
03409    then it was an unmarked-but-actually-introduced id. */
03410 
03411 static Scheme_Object *check_floating_id(Scheme_Object *stx)
03412 {
03413   /* If `a' has a mzMOD_RENAME_MARKED rename with no following
03414      mzMOD_RENAME_NORMAL using the same set tag, and if there are no
03415      marks after the mzMOD_RENAME_MARKED rename, then we've hit a
03416      corner case: an identifier that was introduced by macro expansion
03417      but marked so that it appears to be original. To ensure that it
03418      gets a generated symbol in the MOD_RENAME_MARKED table, give it a
03419      "floating" binding: scheme_void. This is a rare case, and it more
03420      likely indicates a buggy macro than anything else. */
03421   WRAP_POS awl;
03422   Scheme_Object *cur_mark = NULL, *searching_identity = NULL, *a;
03423   int no_mark_means_floating = 0;
03424 
03425   WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps);
03426   
03427   while (!WRAP_POS_END_P(awl)) {
03428 
03429     a = WRAP_POS_FIRST(awl);
03430     
03431     if (SCHEME_RENAMESP(a)
03432         || SCHEME_RENAMES_SETP(a)) {
03433       int kind;
03434       Scheme_Object *set_identity;
03435 
03436       if (SCHEME_RENAMESP(a)) {
03437         Module_Renames *mrn = (Module_Renames *)a;
03438         
03439         kind = mrn->kind;
03440         set_identity = mrn->set_identity;
03441       } else {
03442         Module_Renames_Set *mrns = (Module_Renames_Set *)a;
03443 
03444         kind = mrns->kind;
03445         set_identity = mrns->set_identity;
03446       }
03447 
03448       if (SAME_OBJ(set_identity, searching_identity))
03449         searching_identity = NULL;
03450 
03451       if (searching_identity)
03452         no_mark_means_floating = 1;
03453 
03454       if (kind == mzMOD_RENAME_MARKED)
03455         searching_identity = set_identity;
03456       else
03457         searching_identity = NULL;
03458         
03459     } else if (SCHEME_MARKP(a)) {
03460       if (SAME_OBJ(a, cur_mark))
03461         cur_mark = 0;
03462       else {
03463         if (cur_mark) {
03464           no_mark_means_floating = 0;
03465           searching_identity = NULL;
03466         }
03467         cur_mark = a;
03468       }
03469     }
03470 
03471     WRAP_POS_INC(awl);
03472   }
03473 
03474   if (cur_mark) {
03475     no_mark_means_floating = 0;
03476     searching_identity = NULL;
03477   }
03478 
03479   if (searching_identity || no_mark_means_floating)
03480     return scheme_void;
03481 
03482   return scheme_false;
03483 }
03484 
03485 #define EXPLAIN_RESOLVE 0
03486 #if EXPLAIN_RESOLVE
03487 int scheme_explain_resolves = 0;
03488 # define EXPLAIN(x) if (scheme_explain_resolves) { x; }
03489 #else
03490 # define EXPLAIN(x) /* empty */
03491 #endif
03492 
03493 static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env)
03494 /* Compares the marks in two wraps lists. A result of 2 means that the
03495    result depended on a barrier env. For a rib-based renaming, we need
03496    to check only up to the rib, and the barrier effect important for
03497    when a rib-based renaming is layered with another renaming (such as
03498    when an internal-definition-base local-expand is used to form a new
03499    set of bindings, as in the unit form); simplification cleans up the
03500    layers, so that we only need to check in ribs. */
03501 {
03502   WRAP_POS awl;
03503   WRAP_POS bwl;
03504   Scheme_Object *acur_mark, *bcur_mark;
03505 # define FAST_STACK_SIZE 4
03506   Scheme_Object *a_mark_stack_fast[FAST_STACK_SIZE], *b_mark_stack_fast[FAST_STACK_SIZE];
03507   Scheme_Object **a_mark_stack = a_mark_stack_fast, **b_mark_stack = b_mark_stack_fast, **naya;
03508   int a_mark_cnt = 0, a_mark_size = FAST_STACK_SIZE, b_mark_cnt = 0, b_mark_size = FAST_STACK_SIZE;
03509   int used_barrier = 0;
03510 
03511   WRAP_POS_COPY(awl, *_awl);
03512   WRAP_POS_COPY(bwl, *_bwl);
03513 
03514   /* A simple way to compare marks would be to make two lists of
03515      marks.  The loop below attempts to speed up that process by
03516      discovering common and canceled marks early, so they can be
03517      omitted from the lists. The "stack" arrays accumulate the parts
03518      of the list that can't be skipped that way. */
03519 
03520   while (1) {
03521     /* Skip over renames and canceled marks: */
03522     acur_mark = NULL;
03523     while (1) { /* loop for canceling stack */
03524       /* this loop handles immediately canceled marks */
03525       while (1) {
03526         if (WRAP_POS_END_P(awl))
03527           break;
03528         if (SCHEME_NUMBERP(WRAP_POS_FIRST(awl)) && IS_POSMARK(WRAP_POS_FIRST(awl))) {
03529           if (acur_mark) {
03530             if (SAME_OBJ(acur_mark, WRAP_POS_FIRST(awl))) {
03531               acur_mark = NULL;
03532               WRAP_POS_INC(awl);
03533             } else
03534               break;
03535           } else {
03536             acur_mark = WRAP_POS_FIRST(awl);
03537             WRAP_POS_INC(awl);
03538           }
03539         } else if (SCHEME_RIBP(WRAP_POS_FIRST(awl))) {
03540           if (SCHEME_FALSEP(barrier_env)) {
03541             WRAP_POS_INC(awl);
03542           } else {
03543             /* See if the barrier environment is in this rib. */
03544             Scheme_Lexical_Rib *rib;
03545             rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(awl);
03546             for (rib = rib->next; rib; rib = rib->next) {
03547               if (SAME_OBJ(SCHEME_VEC_ELS(rib->rename)[0], barrier_env))
03548                 break;
03549             }
03550             if (!rib) {
03551               WRAP_POS_INC(awl);
03552             } else {
03553               WRAP_POS_INIT_END(awl);
03554               used_barrier = 1;
03555             }
03556           }
03557         } else {
03558           WRAP_POS_INC(awl);
03559         }
03560       }
03561       /* Maybe cancel a mark on the stack */
03562       if (acur_mark && a_mark_cnt) {
03563         if (SAME_OBJ(acur_mark, a_mark_stack[a_mark_cnt - 1])) {
03564           --a_mark_cnt;
03565           if (a_mark_cnt) {
03566             acur_mark = a_mark_stack[a_mark_cnt - 1];
03567             --a_mark_cnt;
03568             break;
03569           } else
03570             acur_mark = NULL;
03571         } else
03572           break;
03573       } else
03574         break;
03575     }
03576 
03577     bcur_mark = NULL;
03578     while (1) { /* loop for canceling stack */
03579       while (1) {
03580         if (WRAP_POS_END_P(bwl))
03581           break;
03582         if (SCHEME_NUMBERP(WRAP_POS_FIRST(bwl)) && IS_POSMARK(WRAP_POS_FIRST(bwl))) {
03583           if (bcur_mark) {
03584             if (SAME_OBJ(bcur_mark, WRAP_POS_FIRST(bwl))) {
03585               bcur_mark = NULL;
03586               WRAP_POS_INC(bwl);
03587             } else
03588               break;
03589           } else {
03590             bcur_mark = WRAP_POS_FIRST(bwl);
03591             WRAP_POS_INC(bwl);
03592           }
03593         } else if (SCHEME_RIBP(WRAP_POS_FIRST(bwl))) {
03594           if (SCHEME_FALSEP(barrier_env)) {
03595             WRAP_POS_INC(bwl);
03596           } else {
03597             /* See if the barrier environment is in this rib. */
03598             Scheme_Lexical_Rib *rib;
03599             rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(bwl);
03600             for (rib = rib->next; rib; rib = rib->next) {
03601               if (SAME_OBJ(SCHEME_VEC_ELS(rib->rename)[0], barrier_env))
03602                 break;
03603             }
03604             if (!rib) {
03605               WRAP_POS_INC(bwl);
03606             } else {
03607               WRAP_POS_INIT_END(bwl);
03608               used_barrier = 1;
03609             }
03610           }
03611         } else {
03612           WRAP_POS_INC(bwl);
03613         }
03614       }
03615       /* Maybe cancel a mark on the stack */
03616       if (bcur_mark && b_mark_cnt) {
03617         if (SAME_OBJ(bcur_mark, b_mark_stack[b_mark_cnt - 1])) {
03618           --b_mark_cnt;
03619           if (b_mark_cnt) {
03620             bcur_mark = b_mark_stack[b_mark_cnt - 1];
03621             --b_mark_cnt;
03622             break;
03623           } else
03624             bcur_mark = NULL;
03625         } else
03626           break;
03627       } else
03628         break;
03629     }
03630 
03631     /* Same mark? */
03632     if (a_mark_cnt || b_mark_cnt || !SAME_OBJ(acur_mark, bcur_mark)) {
03633       /* Not the same, so far; push onto stacks in case they're
03634          cancelled later */
03635       if (acur_mark) {
03636         if (a_mark_cnt >= a_mark_size) {
03637           a_mark_size *= 2;
03638           naya = MALLOC_N(Scheme_Object*, a_mark_size);
03639           memcpy(naya, a_mark_stack, sizeof(Scheme_Object *)*a_mark_cnt);
03640           a_mark_stack = naya;
03641         }
03642         a_mark_stack[a_mark_cnt++] = acur_mark;
03643       }
03644       if (bcur_mark) {
03645         if (b_mark_cnt >= b_mark_size) {
03646           b_mark_size *= 2;
03647           naya = MALLOC_N(Scheme_Object*, b_mark_size);
03648           memcpy(naya, b_mark_stack, sizeof(Scheme_Object *)*b_mark_cnt);
03649           b_mark_stack = naya;
03650         }
03651         b_mark_stack[b_mark_cnt++] = bcur_mark;
03652       }
03653     }
03654 
03655     /* Done if both reached the end: */
03656     if (WRAP_POS_END_P(awl) && WRAP_POS_END_P(bwl)) {
03657       EXPLAIN(fprintf(stderr, "    %d vs. %d marks\n", a_mark_cnt, b_mark_cnt));
03658       if (a_mark_cnt == b_mark_cnt) {
03659         while (a_mark_cnt--) {
03660           if (!SAME_OBJ(a_mark_stack[a_mark_cnt], b_mark_stack[a_mark_cnt]))
03661             return 0;
03662         }
03663         return used_barrier + 1;
03664       } else
03665         return 0;
03666     }
03667   }
03668 }
03669 
03670 static int includes_mark(Scheme_Object *wraps, Scheme_Object *mark)
03671 /* Checks for positive or negative (certificate-only) mark.
03672    FIXME: canceling marks are detected only when they're immediately
03673    canceling (i.e., no canceled marks in between). */
03674 {
03675   WRAP_POS awl;
03676   Scheme_Object *acur_mark;
03677 
03678   WRAP_POS_INIT(awl, wraps);
03679 
03680   while (1) {
03681     /* Skip over renames and cancelled marks: */
03682     acur_mark = NULL;
03683     while (1) {
03684       if (WRAP_POS_END_P(awl))
03685        break;
03686       if (SCHEME_NUMBERP(WRAP_POS_FIRST(awl))) {
03687        if (acur_mark) {
03688          if (SAME_OBJ(acur_mark, WRAP_POS_FIRST(awl))) {
03689            acur_mark = NULL;
03690            WRAP_POS_INC(awl);
03691          } else
03692            break;
03693        } else {
03694          acur_mark = WRAP_POS_FIRST(awl);
03695          WRAP_POS_INC(awl);
03696        }
03697       } else {
03698        WRAP_POS_INC(awl);
03699       }
03700     }
03701 
03702     /* Same mark? */
03703     if (SAME_OBJ(acur_mark, mark))
03704       return 1;
03705 
03706     if (WRAP_POS_END_P(awl))
03707       return 0;
03708   }
03709 }
03710 
03711 static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks)
03712 /* Adds both positive and negative marks to marks table. This may add too many
03713    marks, because it detects only immediately canceling marks. */
03714 {
03715   WRAP_POS awl;
03716   Scheme_Object *acur_mark;
03717 
03718   WRAP_POS_INIT(awl, wraps);
03719 
03720   while (1) {
03721     /* Skip over renames and cancelled marks: */
03722     acur_mark = NULL;
03723     while (1) {
03724       if (WRAP_POS_END_P(awl))
03725        break;
03726       if (SCHEME_NUMBERP(WRAP_POS_FIRST(awl))) {
03727        if (acur_mark) {
03728          if (SAME_OBJ(acur_mark, WRAP_POS_FIRST(awl))) {
03729            acur_mark = NULL;
03730            WRAP_POS_INC(awl);
03731          } else
03732            break;
03733        } else {
03734          acur_mark = WRAP_POS_FIRST(awl);
03735          WRAP_POS_INC(awl);
03736        }
03737       } else {
03738        WRAP_POS_INC(awl);
03739       }
03740     }
03741 
03742     if (acur_mark)
03743       scheme_hash_set(marks, acur_mark, scheme_true);
03744     else
03745       return;
03746   }
03747 }
03748 
03749 static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme_Object **marks_cache, int depth, 
03750                                 int *_skipped)
03751 {
03752   int l1, l2;
03753   Scheme_Object *m1, *m2;
03754 
03755   p = SCHEME_CDR(p); /* skip modidx */
03756   p = SCHEME_CDR(p); /* skip phase_export */
03757   if (SCHEME_PAIRP(p)) {
03758     /* has marks */
03759     int skip = 0;
03760     
03761     EXPLAIN(fprintf(stderr, "%d       has marks\n", depth));
03762 
03763     m1 = SCHEME_CAR(p);
03764     if (*marks_cache)
03765       m2 = *marks_cache;
03766     else {
03767       EXPLAIN(fprintf(stderr, "%d       extract marks\n", depth));
03768       m2 = scheme_stx_extract_marks(orig_id);
03769       *marks_cache = m2;
03770     }
03771 
03772     l1 = scheme_list_length(m1);
03773     l2 = scheme_list_length(m2);
03774 
03775     if (l2 < l1) return -1; /* no match */
03776 
03777     while (l2 > l1) {
03778       m2 = SCHEME_CDR(m2);
03779       l2--;
03780       skip++;
03781     }
03782 
03783     if (scheme_equal(m1, m2)) {
03784       if (_skipped ) *_skipped = skip;
03785       return l1; /* matches */
03786     } else
03787       return -1; /* no match */
03788   } else {
03789     if (_skipped) *_skipped = -1;
03790     return 0; /* match empty mark set */
03791   }
03792 }
03793 
03794 static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes, 
03795                                         Scheme_Object *glob_id, Scheme_Object *orig_id,
03796                                         Scheme_Object **get_names, int get_orig_name,
03797                                         int depth,
03798                                         int *_skipped)
03799 {
03800   Scheme_Object *pr, *idx, *pos, *src, *best_match = NULL;
03801   Scheme_Module_Phase_Exports *pt;
03802   Scheme_Hash_Table *ht;
03803   int i, phase, best_match_len = -1, skip = 0;
03804   Scheme_Object *marks_cache = NULL;
03805 
03806   for (pr = shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) {
03807     pt = (Scheme_Module_Phase_Exports *)SCHEME_CADR(SCHEME_CAR(pr));
03808 
03809     EXPLAIN(fprintf(stderr, "%d     pes table\n", depth));
03810 
03811     if (!pt->ht) {
03812       /* Lookup table (which is created lazily) not yet created, so do that now... */
03813       EXPLAIN(fprintf(stderr, "%d     {create lookup}\n", depth));
03814       ht = scheme_make_hash_table(SCHEME_hash_ptr);
03815       for (i = pt->num_provides; i--; ) {
03816         scheme_hash_set(ht, pt->provides[i], scheme_make_integer(i));
03817       }
03818       pt->ht = ht;
03819     }
03820 
03821     pos = scheme_hash_get(pt->ht, glob_id);
03822     if (pos) {
03823       /* Found it, maybe. Check marks. */
03824       int mark_len;
03825       EXPLAIN(fprintf(stderr, "%d     found %p\n", depth, pos));
03826       mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache, depth, &skip);
03827       if (mark_len > best_match_len) {
03828         /* Marks match and improve on previously found match. Build suitable rename: */
03829         best_match_len = mark_len;
03830         if (_skipped) *_skipped = skip;
03831         
03832         idx = SCHEME_CAR(SCHEME_CAR(pr));
03833 
03834         i = SCHEME_INT_VAL(pos);
03835 
03836         if (get_orig_name)
03837           best_match = pt->provide_src_names[i];
03838         else {
03839           if (pt->provide_srcs)
03840             src = pt->provide_srcs[i];
03841           else
03842             src = scheme_false;
03843 
03844           if (get_names) {
03845             /* If module bound, result is module idx, and get_names[0] is set to source name,
03846                get_names[1] is set to the nominal source module, get_names[2] is set to
03847                the nominal source module's export, get_names[3] is set to the phase of
03848                the source definition, get_names[4] is set to the module import phase index,
03849                and get_names[5] is set to the nominal export phase */
03850 
03851             if (pt->provide_src_phases)
03852               phase = pt->provide_src_phases[i];
03853             else
03854               phase = 0;
03855 
03856             get_names[0] = pt->provide_src_names[i];
03857             get_names[1] = idx;
03858             get_names[2] = glob_id;
03859             get_names[3] = scheme_make_integer(phase);
03860             get_names[4] = SCHEME_CDR(SCHEME_CDR(SCHEME_CAR(pr)));
03861             if (SCHEME_PAIRP(get_names[4])) /* skip over marks, if any */
03862               get_names[4] = SCHEME_CDR(get_names[4]);
03863             get_names[5] = pt->phase_index;
03864             get_names[6] = (pt->provide_insps ? pt->provide_insps[i] : NULL);
03865           }
03866 
03867           if (SCHEME_FALSEP(src)) {
03868             src = idx;
03869           } else {
03870             src = scheme_modidx_shift(src, pt->src_modidx, idx);
03871           }
03872 
03873           best_match = src;
03874         }
03875       }
03876     }
03877   }
03878 
03879   return best_match;
03880 }
03881 
03882 static Module_Renames *extract_renames(Module_Renames_Set *mrns, Scheme_Object *phase)
03883 {
03884   if (SAME_OBJ(phase, scheme_make_integer(0)))
03885     return mrns->rt;
03886   else if (SAME_OBJ(phase, scheme_make_integer(1)))
03887     return mrns->et;
03888   else if (mrns->other_phases)
03889     return (Module_Renames *)scheme_hash_get(mrns->other_phases, phase);
03890   else
03891     return NULL;
03892 }
03893 
03894 static int nonempty_rib(Scheme_Lexical_Rib *rib)
03895 {
03896   rib = rib->next;
03897 
03898   while (rib) {
03899     if (SCHEME_RENAME_LEN(rib->rename))
03900       return 1;
03901     rib = rib->next;
03902   }
03903 
03904   return 0;
03905 }
03906 
03907 static int in_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs)
03908 {
03909   if (!skip_ribs)
03910     return 0;
03911   
03912   if (scheme_hash_tree_get((Scheme_Hash_Tree *)skip_ribs, timestamp))
03913     return 1;
03914   
03915   return 0;
03916 }
03917 
03918 static Scheme_Object *add_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs)
03919 {
03920   if (in_skip_set(timestamp, skip_ribs))
03921     return skip_ribs;
03922   
03923   if (!skip_ribs)
03924     skip_ribs = (Scheme_Object *)scheme_make_hash_tree(1);
03925   
03926   skip_ribs = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)skip_ribs, timestamp, scheme_true);
03927 
03928   {
03929     Scheme_Bucket *b;
03930     scheme_start_atomic();
03931     b = scheme_bucket_from_table(interned_skip_ribs, (const char *)skip_ribs);
03932     scheme_end_atomic_no_swap();
03933     if (!b->val)
03934       b->val = scheme_true;
03935 
03936     skip_ribs = (Scheme_Object *)HT_EXTRACT_WEAK(b->key);
03937   }
03938 
03939   return skip_ribs;
03940 }
03941 
03942 XFORM_NONGCING static int same_skipped_ribs(Scheme_Object *a, Scheme_Object *b)
03943 {
03944   return SAME_OBJ(a, b);
03945 }
03946 
03947 XFORM_NONGCING static Scheme_Object *filter_cached_env(Scheme_Object *other_env, Scheme_Object *skip_ribs)
03948 {
03949   Scheme_Object *p;
03950 
03951   if (SCHEME_PAIRP(other_env)) {
03952     /* paired with free-id=? rename */
03953     other_env = SCHEME_CAR(other_env);
03954   }
03955 
03956   if (SCHEME_MPAIRP(other_env)) {
03957     other_env = SCHEME_CAR(other_env);
03958     if (!other_env) 
03959       return scheme_void;
03960   }
03961 
03962   if (SCHEME_RPAIRP(other_env)) {
03963     while (other_env) {
03964       p = SCHEME_CAR(other_env);
03965       if (same_skipped_ribs(SCHEME_CAR(p), skip_ribs)) {
03966         return SCHEME_CDR(p);
03967       }
03968       other_env = SCHEME_CDR(other_env);
03969     }
03970     return scheme_void;
03971   } else if (!skip_ribs)
03972     return other_env;
03973   else
03974     return scheme_void;
03975 }
03976 
03977 static Scheme_Object *extend_cached_env(Scheme_Object *orig, Scheme_Object *other_env, Scheme_Object *skip_ribs,
03978                                         int depends_on_unsealed_rib)
03979 {
03980   Scheme_Object *in_mpair = NULL;
03981   Scheme_Object *free_id_rename = NULL;
03982 
03983   if (SCHEME_PAIRP(orig)) {
03984     free_id_rename = SCHEME_CDR(orig);
03985     orig = SCHEME_CAR(orig);
03986   }
03987 
03988   if (SCHEME_MPAIRP(orig)) {
03989     in_mpair = orig;
03990     orig = SCHEME_CAR(orig);
03991     if (!depends_on_unsealed_rib && !orig) {
03992       /* no longer depends on unsealed rib: */
03993       in_mpair = NULL;
03994       orig = scheme_void;
03995     } else {
03996       /* (some) still depends on unsealed rib: */
03997       if (!orig) {
03998         /* re-register in list of dependencies */
03999         SCHEME_CDR(in_mpair) = unsealed_dependencies;
04000         unsealed_dependencies = in_mpair;
04001         orig = scheme_void;
04002       }
04003     }
04004   } else if (depends_on_unsealed_rib) {
04005     /* register dependency: */
04006     in_mpair = scheme_make_mutable_pair(NULL, unsealed_dependencies);
04007     unsealed_dependencies = in_mpair;
04008   }
04009 
04010   if (SCHEME_VOIDP(orig) && !skip_ribs) {
04011     orig = other_env;
04012   } else {
04013     if (!SCHEME_RPAIRP(orig))
04014       orig = scheme_make_raw_pair(scheme_make_raw_pair(NULL, orig), NULL);
04015 
04016     orig = scheme_make_raw_pair(scheme_make_raw_pair(skip_ribs, other_env), orig);
04017   }
04018 
04019   if (in_mpair) {
04020     SCHEME_CAR(in_mpair) = orig;
04021     orig = in_mpair;
04022   }
04023 
04024   if (free_id_rename) {
04025     orig = CONS(orig, free_id_rename);
04026   }
04027 
04028   return orig;
04029 }
04030 
04031 static void extract_lex_range(Scheme_Object *rename, Scheme_Object *a, int *_istart, int *_iend)
04032 {
04033   int istart, iend, c;
04034 
04035   c = SCHEME_RENAME_LEN(rename);
04036 
04037   if (!SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1])) {
04038     void *pos;
04039     pos = scheme_hash_get((Scheme_Hash_Table *)(SCHEME_VEC_ELS(rename)[1]), a);
04040     if (pos) {
04041       istart = SCHEME_INT_VAL(pos);
04042       if (istart < 0) {
04043         /* -1 indicates multiple slots matching this name. */
04044         istart = 0;
04045         iend = c;
04046       } else
04047         iend = istart + 1;
04048     } else {
04049       istart = 0;
04050       iend = 0;
04051     }
04052   } else {
04053     istart = 0;
04054     iend = c;
04055   }
04056 
04057   *_istart = istart;
04058   *_iend = iend;
04059 }
04060 
04061 /* This needs to be a multiple of 4: */
04062 #define QUICK_STACK_SIZE 16
04063 
04064 /* Although resolve_env may call itself recursively, the recursion
04065    depth is bounded (by the fact that modules can't be nested,
04066    etc.). */
04067 
04068 static Scheme_Object *resolve_env(WRAP_POS *_wraps,
04069                                   Scheme_Object *a, Scheme_Object *orig_phase, 
04070                                   int w_mod, Scheme_Object **get_names,
04071                                   Scheme_Object *skip_ribs, int *_binding_marks_skipped,
04072                                   int *_depends_on_unsealed_rib, int depth, 
04073                                   Scheme_Hash_Table *free_id_recur)
04074 /* Module binding ignored if w_mod is 0.
04075    If module bound, result is module idx, and get_names[0] is set to source name,
04076      get_names[1] is set to the nominal source module, get_names[2] is set to
04077      the nominal source module's export, get_names[3] is set to the phase of
04078      the source definition, and get_names[4] is set to the nominal import phase index,
04079      and get_names[5] is set to the nominal export phase; get_names[6] is set to
04080      an inspector/pair if one applies for a re-export of a protected or unexported, NULL or 
04081      #f otherwise.
04082    If lexically bound, result is env id, and a get_names[0] is set to scheme_undefined;
04083      get_names[1] is set if a free-id=? rename provides a different name for the bindig.
04084    If neither, result is #f and get_names[0] is either unchanged or NULL; get_names[1]
04085      is set if a free-id=? rename provides a different name. */
04086 {
04087   WRAP_POS wraps;
04088   Scheme_Object *o_rename_stack = scheme_null, *recur_skip_ribs = skip_ribs;
04089   Scheme_Object *mresult = scheme_false, *mresult_insp;
04090   Scheme_Object *modidx_shift_to = NULL, *modidx_shift_from = NULL;
04091   Scheme_Object *rename_stack[QUICK_STACK_SIZE], *rib_delim = scheme_false;
04092   int stack_pos = 0, no_lexical = 0;
04093   int is_in_module = 0, skip_other_mods = 0, floating_checked = 0;
04094   Scheme_Lexical_Rib *rib = NULL, *did_rib = NULL;
04095   Scheme_Object *phase = orig_phase;
04096   Scheme_Object *bdg = NULL, *floating = NULL;
04097   Scheme_Hash_Table *export_registry = NULL;
04098   int mresult_skipped = -1;
04099   int depends_on_unsealed_rib = 0, mresult_depends_unsealed = 0;
04100 
04101   EXPLAIN(fprintf(stderr, "%d Resolving %s [skips: %s]:\n", depth, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)),
04102                   scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL)));
04103 
04104   if (_wraps) {
04105     WRAP_POS_COPY(wraps, *_wraps);
04106     WRAP_POS_INC(wraps);
04107   } else
04108     WRAP_POS_INIT(wraps, ((Scheme_Stx *)a)->wraps);
04109   
04110   while (1) {
04111     if (WRAP_POS_END_P(wraps)) {
04112       /* See rename case for info on rename_stack: */
04113       Scheme_Object *result, *result_free_rename, *key, *rd;
04114       int did_lexical = 0;
04115 
04116       EXPLAIN(fprintf(stderr, "%d Rename...\n", depth));
04117 
04118       result = scheme_false;
04119       result_free_rename = scheme_false;
04120       rib_delim = scheme_null;
04121       while (!SCHEME_NULLP(o_rename_stack)) {
04122        key = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[0];
04123        if (SAME_OBJ(key, result)) {
04124           EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0)));
04125          did_lexical = 1;
04126           rd = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[3];
04127           if (SCHEME_TRUEP(rd) && !SAME_OBJ(rd, rib_delim) && is_in_rib_delim(result, rd)) {
04128             /* not a match, due to rib delimiter */
04129           } else {
04130             result = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[1];
04131             result_free_rename = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[2];
04132             rib_delim = rd;
04133           }
04134        } else {
04135           EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0)));
04136           if (SAME_OBJ(key, scheme_true)) {
04137             /* marks a module-level renaming that overrides lexical renaming */
04138             did_lexical = 0;
04139           }
04140         }
04141        o_rename_stack = SCHEME_CDR(o_rename_stack);
04142       }
04143       while (stack_pos) {
04144        key = rename_stack[stack_pos - 1];
04145        if (SAME_OBJ(key, result)) {
04146           EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0)));
04147           rd = rename_stack[stack_pos - 4];
04148           if (SCHEME_TRUEP(rd) && !SAME_OBJ(rd, rib_delim) && is_in_rib_delim(result, rd)) {
04149             /* not a match, due to rib delimiter */
04150           } else {
04151             result = rename_stack[stack_pos - 2];
04152             result_free_rename = rename_stack[stack_pos - 3];
04153             rib_delim = rd;
04154             did_lexical = 1;
04155           }
04156        } else {
04157           EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0)));
04158           if (SAME_OBJ(key, scheme_true)) {
04159             /* marks a module-level renaming that overrides lexical renaming */
04160             did_lexical = 0;
04161           }
04162         }
04163        stack_pos -= 4;
04164       }
04165       if (!did_lexical) {
04166        result = mresult;
04167         if (_binding_marks_skipped)
04168           *_binding_marks_skipped = mresult_skipped;
04169         if (mresult_depends_unsealed)
04170           depends_on_unsealed_rib = 1;
04171       } else {
04172         if (free_id_recur && !SCHEME_VOIDP(result_free_rename)) {
04173           Scheme_Object *orig;
04174           int rib_dep = 0;
04175           orig = result_free_rename;
04176           result_free_rename = SCHEME_VEC_ELS(orig)[0];
04177           if (SCHEME_PAIRP(result_free_rename) && SCHEME_STXP(SCHEME_CAR(result_free_rename))) {
04178             phase = SCHEME_CDR(result_free_rename);
04179             if (!SCHEME_FALSEP(SCHEME_VEC_ELS(orig)[1]))
04180               phase = scheme_bin_plus(phase, SCHEME_VEC_ELS(orig)[1]);
04181             if (get_names)
04182               get_names[1] = NULL;
04183             result = SCHEME_CAR(result_free_rename);
04184             if (!scheme_hash_get(free_id_recur, result)) {
04185               scheme_hash_set(free_id_recur, result, scheme_true);
04186               result = resolve_env(NULL, result, phase,
04187                                    w_mod, get_names,
04188                                    NULL, _binding_marks_skipped,
04189                                    &rib_dep, depth + 1, free_id_recur);
04190             }
04191             if (get_names && !get_names[1])
04192               if (SCHEME_FALSEP(result) || SAME_OBJ(scheme_undefined, get_names[0]))
04193                 get_names[1] = SCHEME_STX_VAL(SCHEME_CAR(result_free_rename));
04194           } else if (SCHEME_PAIRP(result_free_rename) && SCHEME_SYMBOLP(SCHEME_CDR(result_free_rename))) {
04195             if (get_names)
04196               get_names[1] = SCHEME_CAR(result_free_rename);
04197             result = SCHEME_CDR(result_free_rename);
04198             if (get_names)
04199               get_names[0] = scheme_undefined;
04200           } else if (SAME_OBJ(SCHEME_TYPE(result_free_rename), scheme_free_id_info_type)) {
04201             result = SCHEME_VEC_ELS(result_free_rename)[0];
04202             if (get_names) {
04203               get_names[0] = SCHEME_VEC_ELS(result_free_rename)[1];
04204               get_names[1] = SCHEME_VEC_ELS(result_free_rename)[2];
04205               get_names[2] = SCHEME_VEC_ELS(result_free_rename)[3];
04206               get_names[3] = SCHEME_VEC_ELS(result_free_rename)[4];
04207               get_names[4] = SCHEME_VEC_ELS(result_free_rename)[5];
04208               get_names[5] = SCHEME_VEC_ELS(result_free_rename)[6];
04209               get_names[6] = SCHEME_VEC_ELS(result_free_rename)[7];
04210             }
04211           } else {
04212             if (get_names)
04213               get_names[1] = SCHEME_CAR(result_free_rename);
04214             result = scheme_false;
04215           }
04216           if (rib_dep)
04217             depends_on_unsealed_rib = 1;
04218           if (SAME_TYPE(SCHEME_TYPE(result), scheme_module_index_type))
04219             result = scheme_modidx_shift(result, SCHEME_VEC_ELS(orig)[2], SCHEME_VEC_ELS(orig)[3]);
04220         } else {
04221           if (get_names) {
04222             get_names[0] = scheme_undefined;
04223             get_names[1] = NULL;
04224           }
04225         }
04226       }
04227 
04228       if (_depends_on_unsealed_rib)
04229         *_depends_on_unsealed_rib = depends_on_unsealed_rib;
04230 
04231       EXPLAIN(fprintf(stderr, "%d Result: %s\n", depth, scheme_write_to_string(result, 0)));
04232 
04233       return result;
04234     } else if ((SCHEME_RENAMESP(WRAP_POS_FIRST(wraps)) 
04235                 || SCHEME_RENAMES_SETP(WRAP_POS_FIRST(wraps)))
04236                && w_mod) {
04237       /* Module rename: */
04238       Module_Renames *mrn;
04239       int skipped;
04240 
04241       EXPLAIN(fprintf(stderr, "%d Rename/set\n", depth));
04242        
04243       if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps))) {
04244         mrn = (Module_Renames *)WRAP_POS_FIRST(wraps);
04245       } else {
04246         /* Extract the relevant phase, if available */
04247         Module_Renames_Set *mrns = (Module_Renames_Set *)WRAP_POS_FIRST(wraps);
04248 
04249         if (mrns->kind != mzMOD_RENAME_TOPLEVEL)
04250          is_in_module = 1;
04251 
04252         mrn = extract_renames(mrns, phase);
04253       }
04254 
04255       if (mrn && (!is_in_module || (mrn->kind != mzMOD_RENAME_TOPLEVEL)) 
04256           && !skip_other_mods) {
04257        if (mrn->kind != mzMOD_RENAME_TOPLEVEL)
04258          is_in_module = 1;
04259 
04260         if (same_phase(phase, mrn->phase)) {
04261          Scheme_Object *rename, *nominal = NULL, *glob_id;
04262           int get_names_done;
04263 
04264           EXPLAIN(fprintf(stderr, "%d  use rename %p %d\n", depth, mrn->phase, mrn->kind));
04265 
04266          if (mrn->needs_unmarshal) {
04267             EXPLAIN(fprintf(stderr, "%d  {unmarshal}\n", depth));
04268            unmarshal_rename(mrn, modidx_shift_from, modidx_shift_to, export_registry);
04269           }
04270 
04271           if (mrn->marked_names) {
04272            /* Resolve based on rest of wraps: */
04273             EXPLAIN(fprintf(stderr, "%d  tl_id_sym\n", depth));
04274            if (!bdg) {
04275               EXPLAIN(fprintf(stderr, "%d   get bdg\n", depth));
04276              bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1, NULL);
04277               if (SCHEME_FALSEP(bdg)) {
04278                 if (!floating_checked) {
04279                   floating = check_floating_id(a);
04280                   floating_checked = 1;
04281                 }
04282                 bdg = floating;
04283               }
04284             }
04285            /* Remap id based on marks and rest-of-wraps resolution: */
04286            glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL, &skipped);
04287          
04288            if (SCHEME_TRUEP(bdg)
04289               && !SAME_OBJ(glob_id, SCHEME_STX_VAL(a))) {
04290              /* Even if this module doesn't match, the lex-renamed id
04291                has been top-level bound in its scope, so ignore all
04292                lexical renamings.  (If the id was further renamed, then
04293                the further renaming would show up in bdg, and bdg wouldn't
04294                have matched in marked_names.) */
04295              no_lexical = 1;
04296              stack_pos = 0;
04297              o_rename_stack = scheme_null;
04298            }
04299          } else {
04300             skipped = -1;
04301            glob_id = SCHEME_STX_VAL(a);
04302           }
04303 
04304           EXPLAIN(fprintf(stderr, "%d  search %s\n", depth, scheme_write_to_string(glob_id, 0)));
04305 
04306           if (free_id_recur && mrn->free_id_renames) {
04307             rename = scheme_hash_get(mrn->free_id_renames, glob_id);
04308             if (rename && SCHEME_STXP(rename)) {
04309               int sealed;
04310               rename = extract_module_free_id_binding((Scheme_Object *)mrn,
04311                                                       glob_id, 
04312                                                       rename,
04313                                                       &sealed,
04314                                                       free_id_recur);
04315               if (!sealed)
04316                 mresult_depends_unsealed = 1;
04317             }
04318           } else
04319             rename = NULL;
04320           if (!rename)
04321             rename = scheme_hash_get(mrn->ht, glob_id);
04322          if (!rename && mrn->nomarshal_ht)
04323            rename = scheme_hash_get(mrn->nomarshal_ht, glob_id);
04324           get_names_done = 0;
04325           if (!rename) {
04326             EXPLAIN(fprintf(stderr, "%d    in pes\n", depth));
04327             rename = search_shared_pes(mrn->shared_pes, glob_id, a, get_names, 0, depth, &skipped);
04328             if (rename)
04329               get_names_done = 1;
04330           }
04331 
04332           EXPLAIN(fprintf(stderr, "%d  search result: %p\n", depth, rename));
04333                 
04334          if (rename) {
04335             if (mrn->sealed < STX_SEAL_BOUND)
04336               mresult_depends_unsealed = 1;
04337 
04338            if (mrn->kind == mzMOD_RENAME_MARKED) {
04339               /* One job of a mzMOD_RENAME_MARKED renamer is to replace any
04340                  binding that might have come from the identifier in its source
04341                  module, instead of the module where it was eventually bound
04342                  (after being introduced by a macro in the source module). */
04343              skip_other_mods = 1;
04344             }
04345 
04346            /* match; set mresult, which is used in the case of no lexical capture: */
04347             mresult_skipped = skipped;
04348 
04349             mresult_insp = NULL;
04350             
04351             if (SCHEME_BOXP(rename)) {
04352               /* This should only happen for mappings from free_id_renames */
04353               mresult = SCHEME_BOX_VAL(rename);
04354               if (get_names) {
04355                 if (SCHEME_FALSEP(SCHEME_CDR(mresult)))
04356                   get_names[0] = NULL;
04357                 else
04358                   get_names[0] = scheme_undefined;
04359                 get_names[1] = SCHEME_CAR(mresult);
04360               }
04361               mresult = SCHEME_CDR(mresult);
04362             } else {
04363               if (SCHEME_PAIRP(rename)) {
04364                 mresult = SCHEME_CAR(rename);
04365                 if (is_rename_inspector_info(mresult)) {
04366                   mresult_insp = mresult;
04367                   rename = SCHEME_CDR(rename);
04368                   mresult = SCHEME_CAR(rename);
04369                 }
04370               } else
04371                 mresult = rename;
04372            
04373               if (modidx_shift_from)
04374                 mresult = scheme_modidx_shift(mresult,
04375                                               modidx_shift_from,
04376                                               modidx_shift_to);
04377 
04378               if (get_names) {
04379                 int no_shift = 0;
04380 
04381                 if (!get_names_done) {
04382                   if (SCHEME_PAIRP(rename)) {
04383                     if (nom_mod_p(rename)) {
04384                       /* (cons modidx nominal_modidx) case */
04385                       get_names[0] = glob_id;
04386                       get_names[1] = SCHEME_CDR(rename);
04387                       get_names[2] = get_names[0];
04388                     } else {
04389                       rename = SCHEME_CDR(rename);
04390                       if (SCHEME_PAIRP(rename)) {
04391                         /* (list* modidx [mod-phase] exportname nominal_modidx nominal_exportname) case */
04392                         if (SCHEME_INTP(SCHEME_CAR(rename))
04393                             || SCHEME_FALSEP(SCHEME_CAR(rename))) {
04394                           get_names[3] = SCHEME_CAR(rename);
04395                           rename = SCHEME_CDR(rename);
04396                         }
04397                         get_names[0] = SCHEME_CAR(rename);
04398                         get_names[1] = SCHEME_CADR(rename);
04399                         if (SCHEME_PAIRP(get_names[1])) {
04400                           get_names[4] = SCHEME_CDR(get_names[1]);
04401                           get_names[1] = SCHEME_CAR(get_names[1]);
04402                           if (SCHEME_PAIRP(get_names[4])) {
04403                             get_names[5] = SCHEME_CDR(get_names[4]);
04404                             get_names[4] = SCHEME_CAR(get_names[4]);
04405                           } else {
04406                             get_names[5] = get_names[3];
04407                           }
04408                         }
04409                         get_names[2] = SCHEME_CDDR(rename);
04410                       } else {
04411                         /* (cons modidx exportname) case */
04412                         get_names[0] = rename;
04413                         get_names[2] = NULL; /* finish below */
04414                       }
04415                     }
04416                   } else {
04417                     get_names[0] = glob_id;
04418                     get_names[2] = NULL; /* finish below */
04419                   }
04420 
04421                   if (!get_names[2]) {
04422                     get_names[2] = get_names[0];
04423                     if (nominal)
04424                       get_names[1] = nominal;
04425                     else {
04426                       no_shift = 1;
04427                       get_names[1] = mresult;
04428                     }
04429                   }
04430                   if (!get_names[4]) {
04431                     GC_CAN_IGNORE Scheme_Object *pi;
04432                     pi = phase_to_index(mrn->phase);
04433                     get_names[4] = pi;
04434                   }
04435                   if (!get_names[5]) {
04436                     get_names[5] = get_names[3];
04437                   }
04438                   get_names[6] = mresult_insp;
04439                 }
04440 
04441                 if (modidx_shift_from && !no_shift) {
04442                   Scheme_Object *nom;
04443                   nom = get_names[1];
04444                   nom = scheme_modidx_shift(nom,
04445                                             modidx_shift_from,
04446                                             modidx_shift_to);
04447                   get_names[1] = nom;
04448                 }
04449               }
04450             }
04451           } else {
04452             if (mrn->sealed < STX_SEAL_ALL)
04453               mresult_depends_unsealed = 1;
04454            mresult = scheme_false;
04455             mresult_skipped = -1;
04456            if (get_names)
04457              get_names[0] = NULL;
04458          }
04459        }
04460       }
04461     } else if (SCHEME_BOXP(WRAP_POS_FIRST(wraps)) && w_mod) {
04462       /* Phase shift */
04463       Scheme_Object *vec, *n, *dest, *src;
04464       
04465       EXPLAIN(fprintf(stderr, "%d phase shift\n", depth));
04466 
04467       vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(wraps));
04468       n = SCHEME_VEC_ELS(vec)[0];
04469       if (SCHEME_TRUEP(phase))
04470         phase = scheme_bin_minus(phase, n);
04471      
04472       src = SCHEME_VEC_ELS(vec)[1];
04473       dest = SCHEME_VEC_ELS(vec)[2];
04474 
04475       /* If src is #f, shift is just for phase; no redirection */
04476 
04477       if (!SCHEME_FALSEP(src)) {
04478        if (!modidx_shift_to) {
04479          modidx_shift_to = dest;
04480        } else if (!SAME_OBJ(modidx_shift_from, dest)) {
04481          modidx_shift_to = scheme_modidx_shift(dest,
04482                                           modidx_shift_from,
04483                                           modidx_shift_to);
04484        }
04485        
04486        modidx_shift_from = src;
04487       }
04488 
04489       {
04490        Scheme_Object *er;
04491        er = SCHEME_VEC_ELS(vec)[3];
04492        if (SCHEME_TRUEP(er))
04493          export_registry = (Scheme_Hash_Table *)er;
04494       }
04495     } else if (rib || (SCHEME_VECTORP(WRAP_POS_FIRST(wraps))
04496                      && !no_lexical)) {
04497       /* Lexical rename: */
04498       Scheme_Object *rename, *renamed;
04499       int ri, c, istart, iend;
04500       Scheme_Lexical_Rib *is_rib;
04501 
04502       if (rib) {
04503        rename = rib->rename;
04504        is_rib = rib;
04505        rib = rib->next;
04506       } else {
04507        rename = WRAP_POS_FIRST(wraps);
04508        is_rib = NULL;
04509         did_rib = NULL;
04510       }
04511 
04512       EXPLAIN(fprintf(stderr, "%d lexical rename (%d) %d %s%s\n", depth, is_rib ? 1 : 0,
04513                       SCHEME_VEC_SIZE(rename), 
04514                       SCHEME_SYMBOLP(SCHEME_VEC_ELS(rename)[0]) ? SCHEME_SYM_VAL(SCHEME_VEC_ELS(rename)[0]) : "<simp>",
04515                       SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1]) ? "" : " hash"));
04516 
04517       c = SCHEME_RENAME_LEN(rename);
04518 
04519       /* Get index from hash table, if there is one: */
04520       extract_lex_range(rename, SCHEME_STX_VAL(a), &istart, &iend);
04521 
04522       for (ri = istart; ri < iend; ri++) {
04523        renamed = SCHEME_VEC_ELS(rename)[2+ri];
04524        if (SAME_OBJ(SCHEME_STX_VAL(a), SCHEME_STX_SYM(renamed))) {
04525          int same;
04526 
04527          {
04528            Scheme_Object *other_env, *envname, *free_id_rename;
04529 
04530            if (SCHEME_SYMBOLP(renamed)) {
04531              /* Simplified table */
04532              other_env = scheme_false;
04533              envname = SCHEME_VEC_ELS(rename)[2+c+ri];
04534               if (SCHEME_PAIRP(envname)) {
04535                 free_id_rename = SCHEME_CDR(envname);
04536                 envname = SCHEME_CAR(envname);
04537               } else
04538                 free_id_rename = scheme_void;
04539              same = 1;
04540               no_lexical = 1; /* simplified table always has final result */
04541               EXPLAIN(fprintf(stderr, "%d Targes %s <- %s %p\n", depth,
04542                               scheme_write_to_string(envname, 0),
04543                               scheme_write_to_string(other_env, 0),
04544                               free_id_rename));
04545            } else {
04546              envname = SCHEME_VEC_ELS(rename)[0];
04547              other_env = SCHEME_VEC_ELS(rename)[2+c+ri];
04548               if (SCHEME_PAIRP(other_env))
04549                 free_id_rename = SCHEME_CDR(other_env);
04550               else
04551                 free_id_rename = scheme_void;
04552               other_env = filter_cached_env(other_env, recur_skip_ribs);
04553               
04554              if (SCHEME_VOIDP(other_env)) {
04555                 int rib_dep = 0;
04556               SCHEME_USE_FUEL(1);
04557               other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1, NULL);
04558               {
04559                   Scheme_Object *e;
04560                   e = extend_cached_env(SCHEME_VEC_ELS(rename)[2+c+ri], other_env, recur_skip_ribs,
04561                                         (is_rib && !(*is_rib->sealed)) || rib_dep);
04562                   SCHEME_VEC_ELS(rename)[2+c+ri] = e;
04563                 }
04564                 if (rib_dep)
04565                   depends_on_unsealed_rib = 1;
04566               SCHEME_USE_FUEL(1);
04567              }
04568 
04569               EXPLAIN(fprintf(stderr, "%d Target %s <- %s (%d)\n", depth,
04570                               scheme_write_to_string(envname, 0),
04571                               scheme_write_to_string(other_env, 0),
04572                               nom_mod_p(rename)));
04573 
04574              {
04575               WRAP_POS w2;
04576               WRAP_POS_INIT(w2, ((Scheme_Stx *)renamed)->wraps);
04577               same = same_marks(&w2, &wraps, other_env);
04578                 if (!same)
04579                   EXPLAIN(fprintf(stderr, "%d Different marks\n", depth));
04580              }
04581            }
04582            
04583            if (same) {
04584              /* If it turns out that we're going to return
04585                other_env, then return envname instead. 
04586                It's tempting to try to compare envname to the
04587                top element of the stack and combine the two
04588                mappings, but the intermediate name may be needed
04589                (for other_env values that don't come from this stack). */
04590               if (free_id_recur && !SCHEME_VOIDP(free_id_rename)) {
04591                 /* Need to remember phase ad shifts for free-id=? rename: */
04592                 Scheme_Object *vec;
04593                 vec = scheme_make_vector(4, NULL);
04594                 SCHEME_VEC_ELS(vec)[0] = free_id_rename;
04595                 SCHEME_VEC_ELS(vec)[1] = phase; 
04596                 SCHEME_VEC_ELS(vec)[2] = modidx_shift_from;
04597                 SCHEME_VEC_ELS(vec)[3] = modidx_shift_to;
04598                 free_id_rename = vec;
04599               }
04600              if (stack_pos < QUICK_STACK_SIZE) {
04601               rename_stack[stack_pos++] = rib_delim;
04602               rename_stack[stack_pos++] = free_id_rename;
04603               rename_stack[stack_pos++] = envname;
04604               rename_stack[stack_pos++] = other_env;
04605              } else {
04606                 Scheme_Object *vec;
04607                 vec = scheme_make_vector(4, NULL);
04608                 SCHEME_VEC_ELS(vec)[0] = other_env;
04609                 SCHEME_VEC_ELS(vec)[1] = envname;
04610                 SCHEME_VEC_ELS(vec)[2] = free_id_rename;
04611                 SCHEME_VEC_ELS(vec)[3] = rib_delim;
04612               o_rename_stack = CONS(vec, o_rename_stack);
04613              }
04614               if (is_rib) {
04615                 /* skip future instances of the same rib;
04616                    used to skip the rest of the current rib, too, but 
04617                    that's wrong in the case that the same symbolic 
04618                    name with multiple binding contexts is re-bound 
04619                    in a rib */
04620                 skip_ribs = add_skip_set(is_rib->timestamp, skip_ribs);
04621               }
04622            }
04623 
04624            break;
04625          }
04626        }
04627       }
04628     } else if (SCHEME_RIBP(WRAP_POS_FIRST(wraps)) && !no_lexical) {
04629       /* Lexical-rename rib. Splice in the names. */
04630       rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(wraps);
04631       EXPLAIN(fprintf(stderr, "%d Rib: %p...\n", depth, rib));
04632       if (skip_ribs) {
04633        if (in_skip_set(rib->timestamp, skip_ribs)) {
04634           EXPLAIN(fprintf(stderr, "%d Skip rib\n", depth));
04635          rib = NULL;
04636         }
04637       }
04638       if (rib) {
04639         if (!*rib->sealed)
04640           depends_on_unsealed_rib = 1;
04641         if (nonempty_rib(rib)) {
04642           if (SAME_OBJ(did_rib, rib)) {
04643             EXPLAIN(fprintf(stderr, "%d Did rib\n", depth));
04644             rib = NULL;
04645           } else {
04646             recur_skip_ribs = add_skip_set(rib->timestamp, recur_skip_ribs);
04647             did_rib = rib;
04648             rib = rib->next; /* First rib record has no rename */
04649           }
04650         } else
04651           rib = NULL;
04652       }
04653     } else if (SCHEME_RIB_DELIMP(WRAP_POS_FIRST(wraps))) {
04654       rib_delim = WRAP_POS_FIRST(wraps);
04655       if (SCHEME_NULLP(SCHEME_BOX_VAL(rib_delim)))
04656         rib_delim = scheme_false;
04657       did_rib = NULL;
04658     } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))) {
04659       EXPLAIN(fprintf(stderr, "%d mark %p\n", depth, WRAP_POS_FIRST(wraps)));
04660       did_rib = NULL;
04661     } else if (SCHEME_HASHTP(WRAP_POS_FIRST(wraps))) {
04662       Scheme_Hash_Table *ht = (Scheme_Hash_Table *)WRAP_POS_FIRST(wraps);
04663 
04664       EXPLAIN(fprintf(stderr, "%d forwarding table...\n", depth));
04665 
04666       did_rib = NULL;
04667 
04668       if (!ht->count 
04669          /* Table isn't finished if 5 is mapped to a limit: */
04670          || scheme_hash_get(ht, scheme_make_integer(5))) {
04671        fill_chain_cache(wraps.l);
04672       }
04673 
04674       if (!scheme_hash_get(ht, SCHEME_STX_VAL(a))) {
04675         EXPLAIN(fprintf(stderr, "%d   forwarded\n", depth));
04676        set_wraps_to_skip(ht, &wraps);
04677 
04678        continue; /* <<<<< ------ */
04679       }
04680     } else if (SCHEME_PRUNEP(WRAP_POS_FIRST(wraps))) {
04681       if (!is_member(SCHEME_STX_VAL(a), SCHEME_BOX_VAL(WRAP_POS_FIRST(wraps)))) {
04682         /* Doesn't match pruned-to sym; already produce #f */
04683         return scheme_false;
04684       }
04685     }
04686 
04687     if (!rib)
04688       WRAP_POS_INC(wraps);
04689   }
04690 }
04691 
04692 static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_phase, 
04693                                           Scheme_Hash_Table *free_id_recur)
04694      /* Gets a module source name under the assumption that the identifier
04695        is not lexically renamed. This is used as a quick pre-test for
04696        free-identifier=?. We do have to look at lexical renames to check for
04697         equivalences installed on detection of make-rename-transformer, but at least
04698         we can normally cache the result. */
04699 {
04700   WRAP_POS wraps;
04701   Scheme_Object *result, *result_from;
04702   int is_in_module = 0, skip_other_mods = 0, sealed = STX_SEAL_ALL, floating_checked = 0;
04703   int no_lexical = !free_id_recur;
04704   Scheme_Object *phase = orig_phase;
04705   Scheme_Object *bdg = NULL, *floating = NULL;
04706 
04707   if (!free_id_recur
04708       && SAME_OBJ(phase, scheme_make_integer(0))
04709       && ((Scheme_Stx *)a)->u.modinfo_cache)
04710     return ((Scheme_Stx *)a)->u.modinfo_cache;
04711 
04712   WRAP_POS_INIT(wraps, ((Scheme_Stx *)a)->wraps);
04713 
04714   result = NULL;
04715 
04716   while (1) {
04717     if (WRAP_POS_END_P(wraps)) {
04718       int can_cache = (sealed >= STX_SEAL_ALL);
04719 
04720       if (result)
04721         can_cache = (sealed >= STX_SEAL_BOUND); /* If it becomes bound, it can't become unbound. */
04722 
04723       if (!result)
04724        result = SCHEME_STX_VAL(a);
04725       
04726       if (can_cache && SAME_OBJ(orig_phase, scheme_make_integer(0)) && !free_id_recur)
04727         ((Scheme_Stx *)a)->u.modinfo_cache = result;
04728  
04729       return result;
04730     } else if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps))
04731                || SCHEME_RENAMES_SETP(WRAP_POS_FIRST(wraps))) {
04732       Module_Renames *mrn;
04733 
04734       if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps))) {
04735         mrn = (Module_Renames *)WRAP_POS_FIRST(wraps);
04736       } else {
04737         /* Extract the relevant phase, if available */
04738         Module_Renames_Set *mrns = (Module_Renames_Set *)WRAP_POS_FIRST(wraps);
04739 
04740         if (mrns->kind != mzMOD_RENAME_TOPLEVEL)
04741          is_in_module = 1;
04742         
04743         if ((!is_in_module || (mrns->kind != mzMOD_RENAME_TOPLEVEL))
04744             && !skip_other_mods) {
04745           if (mrns->sealed < sealed)
04746             sealed = mrns->sealed;
04747         }
04748 
04749         mrn = extract_renames(mrns, phase);
04750       }
04751 
04752       if (mrn && (!is_in_module || (mrn->kind != mzMOD_RENAME_TOPLEVEL)) 
04753           && !skip_other_mods) {
04754        if (mrn->kind != mzMOD_RENAME_TOPLEVEL)
04755          is_in_module = 1;
04756 
04757        if (same_phase(phase, mrn->phase)) {
04758          /* Module rename: */
04759          Scheme_Object *rename, *glob_id;
04760 
04761           if (mrn->sealed < sealed)
04762             sealed = mrn->sealed;
04763           
04764          if (mrn->needs_unmarshal) {
04765            /* Use resolve_env to trigger unmarshal, so that we
04766               don't have to implement top/from shifts here: */
04767            resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL, NULL, 0, NULL);
04768          }
04769 
04770          if (mrn->marked_names) {
04771            /* Resolve based on rest of wraps: */
04772            if (!bdg)
04773              bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL, NULL, 0, NULL);
04774             if (SCHEME_FALSEP(bdg))  {
04775               if (!floating_checked) {
04776                 floating = check_floating_id(a);
04777                 floating_checked = 1;
04778               }
04779               bdg = floating;
04780             }
04781            /* Remap id based on marks and rest-of-wraps resolution: */
04782            glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL, NULL);
04783 
04784             if (SCHEME_TRUEP(bdg)
04785               && !SAME_OBJ(glob_id, SCHEME_STX_VAL(a))) {
04786              /* See "Even if this module doesn't match, the lex-renamed id" in resolve_env() */
04787              no_lexical = 1;
04788            }
04789          } else
04790            glob_id = SCHEME_STX_VAL(a);
04791 
04792           if (free_id_recur && mrn->free_id_renames) {
04793             rename = scheme_hash_get(mrn->free_id_renames, glob_id);
04794             if (rename && SCHEME_STXP(rename)) {
04795               int sealed;
04796               rename = extract_module_free_id_binding((Scheme_Object *)mrn,
04797                                                       glob_id, 
04798                                                       rename,
04799                                                       &sealed,
04800                                                       free_id_recur);
04801               if (!sealed)
04802                 sealed = 0;
04803             }
04804           } else
04805             rename = NULL;
04806           if (!rename)
04807             rename = scheme_hash_get(mrn->ht, glob_id);
04808          if (!rename && mrn->nomarshal_ht)
04809            rename = scheme_hash_get(mrn->nomarshal_ht, glob_id);
04810 
04811           if (!rename)
04812             result = search_shared_pes(mrn->shared_pes, glob_id, a, NULL, 1, 0, NULL);
04813          else {
04814            /* match; set result: */
04815            if (mrn->kind == mzMOD_RENAME_MARKED)
04816              skip_other_mods = 1;
04817             if (SCHEME_BOXP(rename)) {
04818               /* only happens with free_id_renames */
04819               rename = SCHEME_BOX_VAL(rename);
04820               result = SCHEME_CAR(rename);
04821             } else if (SCHEME_PAIRP(rename)) {
04822              if (nom_mod_p(rename)) {
04823               result = glob_id;
04824              } else {
04825               result = SCHEME_CDR(rename);
04826               if (SCHEME_PAIRP(result))
04827                 result = SCHEME_CAR(result);
04828              }
04829            } else
04830              result = glob_id;
04831          }
04832 
04833           result_from = WRAP_POS_FIRST(wraps);
04834        }
04835       }
04836     } else if (SCHEME_BOXP(WRAP_POS_FIRST(wraps))) {
04837       /* Phase shift */
04838       Scheme_Object *n, *vec;
04839       vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(wraps));
04840       n = SCHEME_VEC_ELS(vec)[0];
04841       if (SCHEME_TRUEP(phase))
04842         phase = scheme_bin_minus(phase, n);
04843     } else if (!no_lexical
04844                && (SCHEME_VECTORP(WRAP_POS_FIRST(wraps))
04845                    || SCHEME_RIBP(WRAP_POS_FIRST(wraps)))) {
04846       /* Lexical rename */
04847       Scheme_Object *rename, *renamed, *renames;
04848       Scheme_Lexical_Rib *rib;
04849       int ri, istart, iend;
04850 
04851       rename = WRAP_POS_FIRST(wraps);
04852       if (SCHEME_RIBP(rename)) {
04853         rib = ((Scheme_Lexical_Rib *)rename)->next;
04854         rename = NULL;
04855       } else {
04856         rib = NULL;
04857         if (SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[0])) {
04858           /* No free-id=? renames here. */
04859           rename = NULL;
04860         }
04861       }
04862 
04863       do {
04864         if (rib) {
04865           if (!*rib->sealed) sealed = 0;
04866           rename = rib->rename;
04867           rib = rib->next;
04868         }
04869 
04870         if (rename) {
04871           int c = SCHEME_RENAME_LEN(rename);
04872 
04873           /* Get index from hash table, if there is one: */
04874           if (!SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1])) {
04875             void *pos;
04876             pos = scheme_hash_get((Scheme_Hash_Table *)(SCHEME_VEC_ELS(rename)[1]), SCHEME_STX_VAL(a));
04877             if (pos) {
04878               istart = SCHEME_INT_VAL(pos);
04879               if (istart < 0) {
04880                 /* -1 indicates multiple slots matching this name. */
04881                 istart = 0;
04882                 iend = c;
04883               } else
04884                 iend = istart + 1;
04885             } else {
04886               istart = 0;
04887               iend = 0;
04888             }
04889           } else {
04890             istart = 0;
04891             iend = c;
04892           }
04893 
04894           for (ri = istart; ri < iend; ri++) {
04895             renamed = SCHEME_VEC_ELS(rename)[2+ri];
04896             if (SAME_OBJ(SCHEME_STX_VAL(a), SCHEME_STX_SYM(renamed))) {
04897               /* Check for free-id mapping: */
04898               renames = SCHEME_VEC_ELS(rename)[2 + ri + c];
04899               if (SCHEME_PAIRP(renames)) {
04900                 /* Has a relevant-looking free-id mapping. 
04901                    Give up on the "fast" traversal. */
04902                 Scheme_Object *modname, *names[7];
04903                 int rib_dep;
04904 
04905                 names[0] = NULL;
04906                 names[1] = NULL;
04907                 names[3] = scheme_make_integer(0);
04908                 names[4] = NULL;
04909                 names[5] = NULL;
04910                 names[6] = NULL;
04911 
04912                 modname = resolve_env(NULL, a, orig_phase, 1, names, NULL, NULL, &rib_dep, 0, free_id_recur);
04913                 if (rib_dep)
04914                   sealed = 0;
04915 
04916                 if (!SCHEME_FALSEP(modname)
04917                     && !SAME_OBJ(names[0], scheme_undefined)) {
04918                   result = names[0];
04919                 } else {
04920                   result = names[1]; /* can be NULL or alternate name */
04921                 }
04922                 
04923                 WRAP_POS_INIT_END(wraps);
04924                 rib = NULL;
04925                 break;
04926               }
04927             }
04928           }
04929         }
04930       } while (rib);
04931     } else if (SCHEME_PRUNEP(WRAP_POS_FIRST(wraps))) {
04932       if (!is_member(SCHEME_STX_VAL(a), SCHEME_BOX_VAL(WRAP_POS_FIRST(wraps)))) {
04933         /* Doesn't match pruned-to sym, so no binding */
04934         return SCHEME_STX_VAL(a);
04935       }
04936     }
04937     
04938     /* Keep looking: */
04939     if (!WRAP_POS_END_P(wraps))
04940       WRAP_POS_INC(wraps);
04941   }
04942 }
04943 
04944 int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym)
04945 {
04946   Scheme_Object *bsym;
04947   Scheme_Hash_Table *free_id_recur;
04948 
04949   if (!a || !b)
04950     return (a == b);
04951 
04952   if (SCHEME_STXP(b)) {
04953     if (!asym)
04954       free_id_recur = make_recur_table();
04955     else
04956       free_id_recur = NULL;
04957     bsym = get_module_src_name(b, phase, free_id_recur);
04958     if (!asym)
04959       release_recur_table(free_id_recur);
04960   } else
04961     bsym = b;
04962   if (!asym) {
04963     if (SCHEME_STXP(a)) {
04964       free_id_recur = make_recur_table();
04965       asym = get_module_src_name(a, phase, free_id_recur);
04966       release_recur_table(free_id_recur);
04967     } else
04968       asym = a;
04969   }
04970 
04971   /* Same name? */
04972   if (!SAME_OBJ(asym, bsym))
04973     return 0;
04974 
04975   if ((a == asym) || (b == bsym))
04976     return 1;
04977 
04978   free_id_recur = make_recur_table();
04979   a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur);
04980   release_recur_table(free_id_recur);
04981 
04982   free_id_recur = make_recur_table();
04983   b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur);
04984   release_recur_table(free_id_recur);
04985 
04986   if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type))
04987     a = scheme_module_resolve(a, 0);
04988   if (SAME_TYPE(SCHEME_TYPE(b), scheme_module_index_type))
04989     b = scheme_module_resolve(b, 0);
04990 
04991   /* Same binding environment? */
04992   return SAME_OBJ(a, b);
04993 }
04994 
04995 int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, long phase)
04996 {
04997   return scheme_stx_module_eq2(a, b, scheme_make_integer(phase), NULL);
04998 }
04999 
05000 Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase)
05001 {
05002   if (SCHEME_STXP(a))
05003     return get_module_src_name(a, phase, NULL);
05004   else
05005     return a;
05006 }
05007 
05008 Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *free_id_recur,
05009                                       Scheme_Object **a, Scheme_Object *phase, 
05010                                   Scheme_Object **nominal_modidx,    /* how it was imported */
05011                                   Scheme_Object **nominal_name,      /* imported as name */
05012                                   Scheme_Object **mod_phase,         /* original defn phase level */
05013                                       Scheme_Object **src_phase_index,   /* phase level of import from nominal modidx */ 
05014                                       Scheme_Object **nominal_src_phase, /* phase level of export from nominal modidx */
05015                                       Scheme_Object **lex_env,
05016                                       int *_sealed,
05017                                       Scheme_Object **insp)
05018      /* If module bound, result is module idx, and a is set to source name.
05019        If lexically bound, result is scheme_undefined, a is unchanged,
05020            and nominal_name is NULL or a free_id=? renamed id.
05021        If neither, result is NULL, a is unchanged, and
05022            and nominal_name is NULL or a free_id=? renamed id. */
05023 {
05024   if (SCHEME_STXP(*a)) {
05025     Scheme_Object *modname, *names[7];
05026     int rib_dep;
05027 
05028     names[0] = NULL;
05029     names[1] = NULL;
05030     names[3] = scheme_make_integer(0);
05031     names[4] = NULL;
05032     names[5] = NULL;
05033     names[6] = NULL;
05034 
05035     modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, _sealed ? &rib_dep : NULL, 0, free_id_recur);
05036     
05037     if (_sealed) *_sealed = !rib_dep;
05038 
05039     if (names[0]) {
05040       if (SAME_OBJ(names[0], scheme_undefined)) {
05041         if (lex_env)
05042           *lex_env = modname;
05043         if (nominal_name)
05044           *nominal_name = names[1];
05045         return scheme_undefined;
05046       } else {
05047        *a = names[0];
05048        if (nominal_modidx)
05049          *nominal_modidx = names[1];
05050        if (nominal_name)
05051          *nominal_name = names[2];
05052        if (mod_phase)
05053          *mod_phase = names[3];
05054         if (src_phase_index)
05055          *src_phase_index = names[4];
05056        if (nominal_src_phase)
05057          *nominal_src_phase = names[5];
05058         if (insp)
05059           *insp = names[6];
05060        return modname;
05061       }
05062     } else {
05063       if (nominal_name) *nominal_name = names[1];
05064       return NULL;
05065     }
05066   } else {
05067     if (nominal_name) *nominal_name = NULL;
05068     if (_sealed) *_sealed = 1;
05069     return NULL;
05070   }
05071 }
05072 
05073 int scheme_stx_ribs_matter(Scheme_Object *a, Scheme_Object *skip_ribs)
05074 {
05075   Scheme_Object *m1, *m2, *skips = NULL;
05076 
05077   while (SCHEME_PAIRP(skip_ribs)) {
05078     skips = add_skip_set(((Scheme_Lexical_Rib *)SCHEME_CAR(skip_ribs))->timestamp,
05079                          skips);
05080     skip_ribs = SCHEME_CDR(skip_ribs);
05081   }
05082 
05083   m1 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, NULL, NULL, NULL, 0, NULL);
05084   m2 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, skips, NULL, NULL, 0, NULL);
05085 
05086   return !SAME_OBJ(m1, m2);
05087 }
05088 
05089 Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a)
05090   /* Returns either false, a lexical-rename symbol, or void for "floating" */
05091 {
05092   if (SCHEME_STXP(a)) {
05093     Scheme_Object *r;
05094 
05095     r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL, NULL, 0, NULL);
05096 
05097     if (SCHEME_FALSEP(r))
05098       r = check_floating_id(a);
05099 
05100     if (r)
05101       return r;
05102   }
05103   return scheme_false;
05104 }
05105 
05106 int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, Scheme_Object *phase)
05107      /* If uid is given, it's the environment for b. */
05108 {
05109   Scheme_Object *asym, *bsym, *ae, *be;
05110 
05111   if (!a || !b)
05112     return (a == b);
05113 
05114   if (SCHEME_STXP(a))
05115     asym = SCHEME_STX_VAL(a);
05116   else
05117     asym = a;
05118   if (SCHEME_STXP(b))
05119     bsym = SCHEME_STX_VAL(b);
05120   else
05121     bsym = b;
05122 
05123   /* Same name? */
05124   if (!SAME_OBJ(asym, bsym))
05125     return 0;
05126 
05127   ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL, NULL, 0, NULL);
05128   /* No need to module_resolve ae, because we ignored module renamings. */
05129 
05130   if (uid)
05131     be = uid;
05132   else {
05133     be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL, NULL, 0, NULL);
05134     /* No need to module_resolve be, because we ignored module renamings. */
05135   }
05136 
05137   /* Same binding environment? */
05138   if (!SAME_OBJ(ae, be))
05139     return 0;
05140 
05141   /* Same marks? (If not lexically bound, ignore mark barriers.) */
05142   if (!uid) {
05143     WRAP_POS aw;
05144     WRAP_POS bw;
05145     WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps);
05146     WRAP_POS_INIT(bw, ((Scheme_Stx *)b)->wraps);
05147     if (!same_marks(&aw, &bw, ae))
05148       return 0;
05149   }
05150 
05151   return 1;
05152 }
05153 
05154 int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase)
05155 {
05156   return scheme_stx_env_bound_eq(a, b, NULL, phase);
05157 }
05158 
05159 #if EXPLAIN_RESOLVE
05160 Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a)
05161 {
05162   scheme_explain_resolves++;
05163   a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0, NULL);
05164   --scheme_explain_resolves;
05165   return a;
05166 }
05167 #endif
05168 
05169 Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve)
05170 {
05171   /* Inspect the wraps to look for a self-modidx shift: */
05172   WRAP_POS w;
05173   Scheme_Object *srcmod = scheme_false, *chain_from = NULL;
05174 
05175   WRAP_POS_INIT(w, ((Scheme_Stx *)stx)->wraps);
05176 
05177   while (!WRAP_POS_END_P(w)) {
05178     if (SCHEME_BOXP(WRAP_POS_FIRST(w))) {
05179       /* Phase shift:  */
05180       Scheme_Object *vec, *dest, *src;
05181 
05182       vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(w));
05183       
05184       src = SCHEME_VEC_ELS(vec)[1];
05185       dest = SCHEME_VEC_ELS(vec)[2];
05186 
05187       /* If src is #f, shift is just for phase; no redirection */
05188       if (!SCHEME_FALSEP(src)) {
05189         
05190         if (!chain_from) {
05191           srcmod = dest;
05192         } else if (!SAME_OBJ(chain_from, dest)) {
05193           srcmod = scheme_modidx_shift(dest,
05194                                        chain_from,
05195                                        srcmod);
05196         }
05197         
05198         chain_from = src;
05199       }
05200     }
05201 
05202     WRAP_POS_INC(w);
05203   }
05204 
05205   if (SCHEME_TRUEP(srcmod) && resolve)
05206     srcmod = scheme_module_resolve(srcmod, 0);
05207 
05208   return srcmod;
05209 }
05210 
05211 int scheme_stx_parallel_is_used(Scheme_Object *sym, Scheme_Object *stx)
05212 {
05213   /* Inspect the wraps to look for a binding: */
05214   WRAP_POS w;
05215 
05216   WRAP_POS_INIT(w, ((Scheme_Stx *)stx)->wraps);
05217 
05218   while (!WRAP_POS_END_P(w)) {
05219     if (SCHEME_RENAMESP(WRAP_POS_FIRST(w))) {
05220       /* Module rename. For simplicity, we look at all renames, even
05221         if they're in the wrong phase, or for the wrong module,
05222         etc. */
05223       Module_Renames *mrn = (Module_Renames *)WRAP_POS_FIRST(w);
05224       
05225       if (scheme_tl_id_is_sym_used(mrn->marked_names, sym))
05226        return 1;
05227     } else if (SCHEME_RENAMES_SETP(WRAP_POS_FIRST(w))) {
05228       Module_Renames_Set *mrns = (Module_Renames_Set *)WRAP_POS_FIRST(w);
05229       int i;
05230       
05231       if (mrns->rt && scheme_tl_id_is_sym_used(mrns->rt->marked_names, sym))
05232        return 1;
05233       if (mrns->et && scheme_tl_id_is_sym_used(mrns->et->marked_names, sym))
05234        return 1;
05235 
05236       if (mrns->other_phases) {
05237         for (i = 0; i < mrns->other_phases->size; i++) {
05238           if (mrns->other_phases->vals[i])
05239             scheme_tl_id_is_sym_used(((Module_Renames *)mrns->other_phases->vals[i])->marked_names, 
05240                                      sym);
05241         }
05242       }
05243     }
05244     WRAP_POS_INC(w);
05245   }
05246   
05247   return 0;
05248 }
05249 
05250 int scheme_stx_has_more_certs(Scheme_Object *id, Scheme_Object *id_certs,
05251                            Scheme_Object *than_id, Scheme_Object *than_id_certs)
05252   /* There's a good chance that certs is an extension of than_certs. */
05253 {
05254   int i, j;
05255   Scheme_Cert *certs, *t_certs;
05256   Scheme_Hash_Table *ht, *t_ht = NULL;
05257 
05258   if ((!id_certs || SAME_OBJ(id_certs, than_id_certs))
05259       && !ACTIVE_CERTS((Scheme_Stx *)id))
05260     return 0;
05261 
05262   if (id_marks_ht) {
05263     ht = id_marks_ht;
05264     id_marks_ht = NULL;
05265   } else
05266     ht = scheme_make_hash_table(SCHEME_hash_ptr);
05267   add_all_marks(((Scheme_Stx *)id)->wraps, ht);
05268 
05269   for (i = 0; i < 2; i++) {
05270     if (i)
05271       certs = ACTIVE_CERTS((Scheme_Stx *)id);
05272     else
05273       certs = (Scheme_Cert *)id_certs;
05274     while (certs && !SAME_OBJ(certs, (Scheme_Cert *)than_id_certs)) {
05275       if (scheme_hash_get(ht, certs->mark)) {
05276        /* Found a relevant certificate in id */
05277        if (!t_ht) {
05278          if (than_id_marks_ht) {
05279            t_ht = than_id_marks_ht;
05280            than_id_marks_ht = NULL;
05281          } else
05282            t_ht = scheme_make_hash_table(SCHEME_hash_ptr);
05283          add_all_marks(((Scheme_Stx *)than_id)->wraps, t_ht);
05284        }
05285        if (scheme_hash_get(t_ht, certs->mark)) {
05286          /* than_id has the same mark */
05287          for (j = 0; j < 2; j++) {
05288            if (j)
05289              t_certs = ACTIVE_CERTS((Scheme_Stx *)than_id);
05290            else
05291              t_certs = (Scheme_Cert *)than_id_certs;
05292            while (t_certs) {
05293              if (SAME_OBJ(t_certs->mark, certs->mark))
05294               break;
05295              t_certs = t_certs->next;
05296            }
05297            if (t_certs)
05298              break;
05299          }
05300          if (j == 2) {
05301            scheme_reset_hash_table(ht, NULL);
05302            id_marks_ht = ht;
05303            scheme_reset_hash_table(t_ht, NULL);
05304            than_id_marks_ht = t_ht;
05305            return 1;
05306          }
05307        }
05308       }
05309       certs = certs->next;
05310     }
05311   }
05312 
05313   scheme_reset_hash_table(ht, NULL);
05314   id_marks_ht = ht;
05315   if (t_ht) {
05316     scheme_reset_hash_table(t_ht, NULL);
05317     than_id_marks_ht = t_ht;
05318   }
05319 
05320   return 0;
05321 }
05322 
05323 Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *a, Scheme_Object *relative_to,
05324                                              Scheme_Object *uid)
05325 {
05326   WRAP_POS aw;
05327   WRAP_POS bw;
05328 
05329   WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps);
05330   WRAP_POS_INIT(bw, ((Scheme_Stx *)relative_to)->wraps);
05331 
05332   if (!same_marks(&aw, &bw, scheme_false)) {
05333     Scheme_Object *wraps = ((Scheme_Stx *)relative_to)->wraps;
05334     if (uid) {
05335       /* Add a rename record: */
05336       Scheme_Object *rn;
05337       rn = scheme_make_rename(uid, 1);
05338       scheme_set_rename(rn, 0, relative_to);
05339       wraps = scheme_make_pair(rn, wraps);
05340     }
05341 
05342     {
05343       Scheme_Stx *stx = (Scheme_Stx *)a;
05344       Scheme_Object *certs;
05345       certs = stx->certs;
05346       stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props);
05347       stx->wraps = wraps;
05348       stx->certs = certs;
05349       a = (Scheme_Object *)stx;
05350     }
05351    }
05352 
05353   return a;
05354 }
05355 
05356 /*========================================================================*/
05357 /*                           stx and lists                                */
05358 /*========================================================================*/
05359 
05360 int scheme_stx_list_length(Scheme_Object *list)
05361 {
05362   int len;
05363 
05364   if (SCHEME_STXP(list))
05365     list = SCHEME_STX_VAL(list);
05366 
05367   len = 0;
05368   while (!SCHEME_NULLP(list)) {
05369     if (SCHEME_STXP(list))
05370       list = SCHEME_STX_VAL(list);
05371     if (SCHEME_PAIRP(list)) {
05372       len++;
05373       list = SCHEME_CDR(list);
05374     } else {
05375       if (!SCHEME_NULLP(list))
05376        len++;
05377       break;
05378     }
05379   }
05380 
05381   return len;
05382 }
05383 
05384 int scheme_stx_proper_list_length(Scheme_Object *list)
05385 {
05386   int len;
05387   Scheme_Object *turtle;
05388 
05389   if (SCHEME_STXP(list))
05390     list = SCHEME_STX_VAL(list);
05391 
05392   len = 0;
05393   turtle = list;
05394   while (SCHEME_PAIRP(list)) {
05395     len++;
05396 
05397     list = SCHEME_CDR(list);
05398     if (SCHEME_STXP(list))
05399       list = SCHEME_STX_VAL(list);
05400 
05401     if (!SCHEME_PAIRP(list))
05402       break;
05403     len++;
05404     list = SCHEME_CDR(list);
05405     if (SCHEME_STXP(list))
05406       list = SCHEME_STX_VAL(list);
05407 
05408     if (SAME_OBJ(turtle, list))
05409       break;
05410 
05411     turtle = SCHEME_CDR(turtle);
05412     if (SCHEME_STXP(turtle))
05413       turtle = SCHEME_STX_VAL(turtle);
05414 
05415   }
05416   
05417   if (SCHEME_NULLP(list))
05418     return len;
05419 
05420   return -1;
05421 }
05422 
05423 #ifdef DO_STACK_CHECK
05424 static Scheme_Object *flatten_syntax_list_k(void)
05425 {
05426   Scheme_Thread *p = scheme_current_thread;
05427   Scheme_Object *l = (Scheme_Object *)p->ku.k.p1;
05428   int *r = (int *)p->ku.k.p2;
05429 
05430   p->ku.k.p1 = NULL;
05431   p->ku.k.p2 = NULL;
05432 
05433   return scheme_flatten_syntax_list(l, r);
05434 }
05435 #endif
05436 
05437 Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist)
05438 {
05439   Scheme_Object *l = lst, *lflat, *first, *last;
05440 
05441   /* Check whether the list ends in a null: */
05442   while (SCHEME_PAIRP(l)) {
05443     l = SCHEME_CDR(l);
05444   }
05445 
05446   if (SCHEME_NULLP(l)) {
05447     /* Yes. We're done: */
05448     if (islist)
05449       *islist = 1;
05450     return lst;
05451   }
05452 
05453   if (islist)
05454     *islist = 0;
05455 
05456   lflat = NULL;
05457 
05458   /* Is it a syntax object, possibly with a list? */
05459   if (SCHEME_STXP(l)) {
05460     l = scheme_stx_content(l);
05461     if (SCHEME_NULLP(l) || SCHEME_PAIRP(l)) {
05462       int lislist;
05463 
05464       lflat = NULL;
05465 
05466 #ifdef DO_STACK_CHECK
05467       {
05468 # include "mzstkchk.h"
05469        {
05470          Scheme_Thread *p = scheme_current_thread;
05471          int *r;
05472 
05473          r = (int *)scheme_malloc_atomic(sizeof(int));
05474 
05475          p->ku.k.p1 = (void *)l;
05476          p->ku.k.p2 = (void *)r;
05477 
05478          lflat = scheme_handle_stack_overflow(flatten_syntax_list_k);
05479 
05480          lislist = *r;
05481        }
05482       }
05483 #endif
05484 
05485       if (!lflat)
05486        lflat = scheme_flatten_syntax_list(l, &lislist);
05487 
05488       if (!lislist) {
05489        /* Not a list. Can't flatten this one. */
05490        return lst;
05491       }
05492     } else {
05493       /* Not a syntax list. No chance of flattening. */
05494       return lst;
05495     }
05496   } else {
05497     /* No. No chance of flattening, then. */
05498     return lst;
05499   }
05500 
05501   /* Need to flatten, end with lflat */
05502 
05503   if (islist)
05504     *islist = 1;
05505 
05506   first = last = NULL;
05507   for (l = lst; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
05508     Scheme_Object *p;
05509     p = scheme_make_pair(SCHEME_CAR(l), scheme_null);
05510     if (last)
05511       SCHEME_CDR(last) = p;
05512     else
05513       first = p;
05514     last = p;
05515   }
05516 
05517   if (last)
05518     SCHEME_CDR(last) = lflat;
05519   else
05520     first = lflat;
05521 
05522   return first;
05523 }
05524 
05525 /*========================================================================*/
05526 /*                            wraps->datum                                */
05527 /*========================================================================*/
05528 
05529 /* Used for marshaling syntax objects. Note that we build a reverse
05530    list for wraps. (Unmarshaler will reverse it back.) 
05531 
05532    The wraps->datum tools are also used to simplify syntax object (to
05533    minimize the occupied space among a set of objects). */
05534 
05535 #define EXPLAIN_SIMP 0
05536 #if EXPLAIN_SIMP
05537 #define EXPLAIN_S(x) if (explain_simp) x
05538 static int explain_simp = 0;
05539 static void print_skips(Scheme_Object *skips)
05540 {
05541   while (skips) {
05542     fprintf(stderr, "  skip %s\n", scheme_write_to_string(SCHEME_CAR(skips), NULL));
05543     skips = SCHEME_CDR(skips);
05544   }
05545 }
05546 #else
05547 #define EXPLAIN_S(x) /* empty */
05548 #endif
05549 
05550 static Scheme_Object *extract_free_id_info(Scheme_Object *id)
05551 {
05552   Scheme_Object *bind;
05553   Scheme_Object *nominal_modidx;
05554   Scheme_Object *nominal_name, *nom2;
05555   Scheme_Object *mod_phase;
05556   Scheme_Object *src_phase_index;
05557   Scheme_Object *nominal_src_phase;
05558   Scheme_Object *lex_env = NULL;
05559   Scheme_Object *vec, *phase, *insp;
05560   Scheme_Hash_Table *free_id_recur;
05561 
05562   phase = SCHEME_CDR(id);
05563   id = SCHEME_CAR(id);
05564 
05565   nom2 = scheme_stx_property(id, nominal_id_symbol, NULL);
05566 
05567   free_id_recur = make_recur_table();
05568   bind = scheme_stx_module_name(free_id_recur, 
05569                                 &id, phase, &nominal_modidx, &nominal_name,
05570                                 &mod_phase, &src_phase_index, &nominal_src_phase,
05571                                 &lex_env, NULL, &insp);
05572   release_recur_table(free_id_recur);
05573 
05574   if (SCHEME_SYMBOLP(nom2))
05575     nominal_name = nom2;
05576   if (!nominal_name)
05577     nominal_name = SCHEME_STX_VAL(id);
05578 
05579   if (!bind)
05580     return CONS(nominal_name, scheme_false);
05581   else if (SAME_OBJ(bind, scheme_undefined))
05582     return CONS(nominal_name, lex_env);
05583   else {
05584     vec = scheme_make_vector(8, NULL);
05585     vec->type = scheme_free_id_info_type;
05586     SCHEME_VEC_ELS(vec)[0] = bind;
05587     SCHEME_VEC_ELS(vec)[1] = id;
05588     SCHEME_VEC_ELS(vec)[2] = nominal_modidx;
05589     SCHEME_VEC_ELS(vec)[3] = nominal_name;
05590     SCHEME_VEC_ELS(vec)[4] = mod_phase;
05591     SCHEME_VEC_ELS(vec)[5] = src_phase_index;
05592     SCHEME_VEC_ELS(vec)[6] = nominal_src_phase;
05593     SCHEME_VEC_ELS(vec)[7] = (insp ? insp : scheme_false);
05594     return vec;
05595   }
05596 }
05597 
05598 static int not_in_rename(Scheme_Object *constrain_to_syms, Scheme_Object *rename)
05599 {
05600   int istart, iend, ri;
05601   Scheme_Object *renamed, *s;
05602 
05603   while (SCHEME_PAIRP(constrain_to_syms)) {
05604   
05605     s = SCHEME_CAR(constrain_to_syms);
05606     extract_lex_range(rename, s, &istart, &iend);
05607     
05608     for (ri = istart; ri < iend; ri++) {
05609       renamed = SCHEME_VEC_ELS(rename)[2+ri];
05610       if (SAME_OBJ(renamed, s))
05611         return 0;
05612     }
05613 
05614     constrain_to_syms = SCHEME_CDR(constrain_to_syms);
05615   }
05616   
05617   return 1;
05618 }
05619 
05620 static int not_in_rib(Scheme_Object *constrain_to_syms, Scheme_Lexical_Rib *rib)
05621 {
05622   for (rib = rib->next; rib; rib = rib->next) {
05623     if (!not_in_rename(constrain_to_syms, rib->rename))
05624       return 0;
05625   }
05626   return 1;
05627 }
05628 
05629 #define EXPLAIN_R(x) /* empty */
05630 
05631 static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_cache, 
05632                                            Scheme_Object *stx_datum)
05633 {
05634   WRAP_POS w, prev, w2;
05635   Scheme_Object *stack = scheme_null, *key, *old_key, *prec_ribs, *prev_prec_ribs;
05636   Scheme_Object *ribs_stack = scheme_null, *rib_delim = scheme_false, *constrain_to_syms = NULL;
05637   Scheme_Object *v, *v2, *v2l, *v2rdl, *stx, *name, *svl, *end_mutable = NULL, **v2_rib_delims = NULL, *svrdl;
05638   Scheme_Lexical_Rib *did_rib = NULL;
05639   Scheme_Hash_Table *skip_ribs_ht = NULL, *prev_skip_ribs_ht;
05640   int copy_on_write, no_rib_mutation = 1, rib_count = 0;
05641   long size, vsize, psize, i, j, pos;
05642 
05643   /* Although it makes no sense to simplify the rename table itself,
05644      we can simplify it in the context of a particular wrap suffix.
05645      (But don't mutate the wrap list, because that will stomp on
05646      tables that might be needed by a propoagation.)
05647 
05648      A lex_cache maps wrap starts within `w' to lists of simplified
05649      tables. This helps avoid re-simplifying when the result is
05650      clearly going to be the same. A lex_cache is read and modified by
05651      this function, only.
05652 
05653      In addition to depending on the rest of the wraps, a resolved
05654      binding can depend on preceding wraps due to rib skipping. For
05655      now, simplifications that depend on preceding wraps are not
05656      cached (though individual computed renamings are cached to save
05657      space).
05658 
05659      The simplification stragegy mostly works inside out: since later
05660      renames depend on earlier renames, we simplify the earlier ones
05661      first, and then collapse to a flattened rename while working
05662      outward. This also lets us track shared tails in some common
05663      cases.
05664      
05665      A catch with the inside-out approach has to do with ribs (again).
05666      Preceding ribs determine the recur_skip_ribs set, so we can
05667      simply track that as we recur into the wraps initially to build
05668      our worklist. However, whether we process a rib at all (on the
05669      way out in the second pass) for a given id depends on whether any
05670      preceding instance of the same rib (i.e., further out) matches
05671      the symbol and marks. So, we have to compute that summary as we
05672      go in. */
05673 
05674   if (SCHEME_SYMBOLP(stx_datum)) {
05675     /* Search for prunings */
05676     WRAP_POS_INIT(w, wraps);
05677     old_key = NULL;
05678     prec_ribs = NULL;
05679     while (!WRAP_POS_END_P(w)) {
05680       if (SCHEME_VECTORP(WRAP_POS_FIRST(w))
05681           || SCHEME_RIBP(WRAP_POS_FIRST(w))) {
05682         /* Lexical rename --- maybe an already-simplified point  */
05683         key = WRAP_POS_KEY(w);
05684         if (!SAME_OBJ(key, old_key)) {
05685           v = scheme_hash_get(lex_cache, key);
05686           if (v && SCHEME_HASHTP(v)) {
05687             v = scheme_hash_get((Scheme_Hash_Table *)v, prec_ribs ? prec_ribs : scheme_false);
05688           } else if (prec_ribs)
05689             v = NULL;
05690         } else
05691           v = NULL;
05692         old_key = key;
05693 
05694         if (v) {
05695           /* Tables here are already simplified. */
05696           break;
05697         }
05698 
05699         if (SCHEME_RIBP(WRAP_POS_FIRST(w))) {
05700           Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(w);
05701           if (!nonempty_rib(rib))
05702             prec_ribs = add_skip_set(rib->timestamp, prec_ribs);
05703         }
05704       } else if (SCHEME_PRUNEP(WRAP_POS_FIRST(w))) {
05705         v = SCHEME_BOX_VAL(WRAP_POS_FIRST(w));
05706         if (is_member(stx_datum, v)) {
05707           if (!constrain_to_syms)
05708             constrain_to_syms = v;
05709           else {
05710             v2 = scheme_null;
05711             while (SCHEME_PAIRP(v)) {
05712               if (is_member(SCHEME_CAR(v), constrain_to_syms))
05713                 v2 = scheme_make_pair(SCHEME_CAR(v), v2);
05714               v = SCHEME_CDR(v);
05715             }
05716             constrain_to_syms = v2;
05717           }
05718         } else
05719           constrain_to_syms = scheme_null;
05720       }
05721       WRAP_POS_INC(w);
05722     }
05723   }
05724 
05725   WRAP_POS_INIT(w, wraps);
05726   WRAP_POS_INIT_END(prev);
05727 
05728   old_key = NULL;
05729   prec_ribs = NULL;
05730 
05731   v2l = scheme_null;
05732   v2rdl = NULL;
05733 
05734   EXPLAIN_S(fprintf(stderr, "[in simplify]\n"));
05735 
05736   EXPLAIN_R(printf("Simplifying %p\n", lex_cache));
05737 
05738   while (!WRAP_POS_END_P(w)) {
05739     if (SCHEME_VECTORP(WRAP_POS_FIRST(w))
05740        || SCHEME_RIBP(WRAP_POS_FIRST(w))) {
05741       /* Lexical rename */
05742       key = WRAP_POS_KEY(w);
05743       EXPLAIN_R(printf(" key %p\n", key));
05744       if (!SAME_OBJ(key, old_key)) {
05745         v = scheme_hash_get(lex_cache, key);
05746         if (v && SCHEME_HASHTP(v)) {
05747           v = scheme_hash_get((Scheme_Hash_Table *)v, prec_ribs ? prec_ribs : scheme_false);
05748         } else if (prec_ribs)
05749           v = NULL;
05750       } else
05751        v = NULL;
05752       old_key = key;
05753       prev_prec_ribs = prec_ribs;
05754       prev_skip_ribs_ht = skip_ribs_ht;
05755 
05756       if (v) {
05757        /* Tables here are already simplified. */
05758         v2l = v; /* build on simplify chain extracted from cache */
05759         end_mutable = v2l;
05760        /* No non-simplified table can follow a simplified one */
05761        break;
05762       } else {
05763        int add = 0, skip_this = 0;
05764 
05765        v = WRAP_POS_FIRST(w);
05766        if (SCHEME_RIBP(v)) {
05767          /* A rib certainly isn't simplified yet. */
05768           Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)v;
05769           no_rib_mutation = 0;
05770           add = 1;
05771           if (!*rib->sealed) {
05772             scheme_signal_error("compile: unsealed local-definition context found in fully expanded form");
05773             return NULL;
05774           }
05775           if (SAME_OBJ(did_rib, rib)
05776               || !nonempty_rib(rib)
05777               || (constrain_to_syms && !not_in_rib(constrain_to_syms, rib))) {
05778             skip_this = 1;
05779             if (!nonempty_rib(rib))
05780               prec_ribs = add_skip_set(rib->timestamp, prec_ribs);
05781             EXPLAIN_S(fprintf(stderr, " to skip %p=%s\n", rib, 
05782                               scheme_write_to_string(rib->timestamp, NULL)));
05783           } else {
05784             rib_count++;
05785             did_rib = rib;
05786             prec_ribs = add_skip_set(rib->timestamp, prec_ribs);
05787 
05788             EXPLAIN_S(fprintf(stderr, " down rib %p=%s\n", rib, 
05789                               scheme_write_to_string(rib->timestamp, NULL)));
05790             EXPLAIN_S(print_skips(prec_ribs));
05791           
05792             copy_on_write = 1;
05793 
05794             EXPLAIN_R(printf(" rib %p\n", rib->timestamp));
05795 
05796             /* Compute, per id, whether to skip later instances of rib: */
05797             for (rib = rib->next; rib; rib = rib->next) {
05798               vsize = SCHEME_RENAME_LEN(rib->rename);
05799               for (i = 0; i < vsize; i++) {
05800                 stx = SCHEME_VEC_ELS(rib->rename)[2+i];
05801 
05802                 EXPLAIN_S(fprintf(stderr, "   skip? %s %p=%s %s\n", 
05803                                   scheme_write_to_string(SCHEME_STX_VAL(stx), NULL), 
05804                                   rib,
05805                                   scheme_write_to_string(rib->timestamp, NULL),
05806                                   scheme_write_to_string(SCHEME_VEC_ELS(rib->rename)[0], NULL)));
05807 
05808                 /* already skipped? */
05809                 if ((!constrain_to_syms || is_member(SCHEME_STX_VAL(stx), constrain_to_syms))
05810                     && (!skip_ribs_ht
05811                         || !scheme_hash_get(skip_ribs_ht, scheme_make_pair(SCHEME_STX_VAL(stx), rib->timestamp)))) {
05812                   /* No. Should we skip? */
05813                   Scheme_Object *other_env;
05814                   other_env = SCHEME_VEC_ELS(rib->rename)[2+vsize+i];
05815                   other_env = filter_cached_env(other_env, prec_ribs);
05816                   if (SCHEME_VOIDP(other_env)) {
05817                     int rib_dep;
05818                     other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, NULL);
05819                     if (rib_dep) {
05820                       scheme_signal_error("compile: unsealed local-definition context found in fully expanded form");
05821                       return NULL;
05822                     }
05823                     {
05824                       Scheme_Object *e;
05825                       e = extend_cached_env(SCHEME_VEC_ELS(rib->rename)[2+vsize+i], other_env, prec_ribs, 0);
05826                       SCHEME_VEC_ELS(rib->rename)[2+vsize+i] = e;
05827                     }
05828                   }
05829                   WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps);
05830                   if (same_marks(&w2, &w, other_env)) {
05831                     /* yes, skip */
05832                     EXPLAIN_S(fprintf(stderr, "   skip! %s\n", 
05833                                       scheme_write_to_string(SCHEME_STX_VAL(stx), NULL)));
05834                     if (!skip_ribs_ht)
05835                       skip_ribs_ht = scheme_make_hash_table_equal();
05836                     else if (copy_on_write)
05837                       skip_ribs_ht = scheme_clone_hash_table(skip_ribs_ht);
05838                     copy_on_write = 0;
05839                     scheme_hash_set(skip_ribs_ht, 
05840                                     scheme_make_pair(SCHEME_STX_VAL(stx), rib->timestamp), 
05841                                     scheme_true);
05842                   }
05843                 } else {
05844                   EXPLAIN_S(fprintf(stderr, "   already skipped %s\n", 
05845                                     scheme_write_to_string(SCHEME_STX_VAL(stx), NULL)));
05846                 }
05847               }
05848             }
05849           }
05850        } else {
05851          /* Need to simplify this vector? */
05852          if (SCHEME_VEC_SIZE(v) == 1)
05853            v = SCHEME_VEC_ELS(v)[0];
05854          if ((SCHEME_VEC_SIZE(v) > 2) /* a simplified vec can be empty */
05855              && !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[2])) {
05856            add = 1;
05857 
05858             if (constrain_to_syms) {
05859               /* Maybe pruned so that we don't need to resolve: */
05860               if (not_in_rename(constrain_to_syms, v))
05861                 skip_this = 1;
05862             }
05863           }
05864           EXPLAIN_R(printf(" lex reset\n"));
05865           did_rib = NULL;
05866        }
05867 
05868        if (add) {
05869           if (skip_this) {
05870             ribs_stack = scheme_make_pair(scheme_false, ribs_stack);
05871           } else {
05872             ribs_stack = scheme_make_pair(scheme_make_pair(prec_ribs, 
05873                                                            scheme_make_pair((Scheme_Object *)prev_skip_ribs_ht,
05874                                                                             rib_delim)),
05875                                           ribs_stack);
05876           }
05877           
05878          /* Need to simplify, but do deepest first: */
05879          if (SCHEME_NULLP(stack) || !SAME_OBJ(SCHEME_VEC_ELS(SCHEME_CAR(stack))[0], key)) {
05880             v = scheme_make_vector(2, NULL);
05881             SCHEME_VEC_ELS(v)[0] = key;
05882             SCHEME_VEC_ELS(v)[1] = prev_prec_ribs;
05883            stack = CONS(v, stack);
05884          }
05885        } else {
05886          /* This is already simplified. Remember it and stop, because
05887             no non-simplified table can follow a simplified one. */
05888           WRAP_POS_COPY(prev, w);
05889          break;
05890        }
05891       }
05892     } else if (SCHEME_RIB_DELIMP(WRAP_POS_FIRST(w))) {
05893       rib_delim = WRAP_POS_FIRST(w);
05894       if (SCHEME_NULLP(SCHEME_BOX_VAL(rib_delim)))
05895         rib_delim = scheme_false;
05896       if (rib_count > 1) {
05897         EXPLAIN_R(if (did_rib) printf("       reset delim %d\n", rib_count));
05898         did_rib = NULL;
05899       }
05900       rib_count = 0;
05901     } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(w))) {
05902       v = WRAP_POS_FIRST(w);
05903       WRAP_POS_COPY(w2, w);
05904       WRAP_POS_INC(w2);
05905       if (!WRAP_POS_END_P(w2) && SAME_OBJ(v, WRAP_POS_FIRST(w2))) {
05906         WRAP_POS_INC(w);
05907       } else {
05908         EXPLAIN_R(printf("         reset by mark\n"));
05909         did_rib = NULL;
05910       }
05911     } else {
05912       EXPLAIN_R(if (did_rib) printf("       reset %d\n", SCHEME_TYPE(WRAP_POS_FIRST(w))));
05913       did_rib = NULL;
05914     }
05915 
05916     WRAP_POS_INC(w);
05917   }
05918 
05919   EXPLAIN_R(printf(" ... phase2\n"));
05920 
05921   while (!SCHEME_NULLP(stack)) {
05922     key = SCHEME_CAR(stack);
05923     prev_prec_ribs = SCHEME_VEC_ELS(key)[1];
05924     key = SCHEME_VEC_ELS(key)[0];
05925 
05926     WRAP_POS_REVINIT(w, key);
05927 
05928     while (!WRAP_POS_REVEND_P(w)) {
05929       v = WRAP_POS_FIRST(w);
05930 
05931       if (SCHEME_RIBP(v)
05932          || (SCHEME_VECTORP(v)
05933              && (SCHEME_VEC_SIZE(v) > 2) /* a simplified vec can be empty */
05934              && !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[2]))) {
05935        /* This is the place to simplify: */
05936        Scheme_Lexical_Rib *rib = NULL, *init_rib = NULL;
05937         Scheme_Object *local_ribs;
05938        int ii, vvsize, done_rib_pos = 0;
05939 
05940         rib_delim = scheme_false;
05941 
05942         if (SCHEME_FALSEP(SCHEME_CAR(ribs_stack))) {
05943           EXPLAIN_S(fprintf(stderr, " skip rib %p=%s\n", v, 
05944                             scheme_write_to_string(((Scheme_Lexical_Rib *)v)->timestamp, NULL)));
05945           ribs_stack = SCHEME_CDR(ribs_stack);
05946           vsize = 0;
05947           local_ribs = NULL;
05948         } else {
05949           rib_delim = SCHEME_CAR(ribs_stack);
05950           prec_ribs = SCHEME_CAR(rib_delim);
05951           rib_delim = SCHEME_CDR(rib_delim);
05952           skip_ribs_ht = (Scheme_Hash_Table *)SCHEME_CAR(rib_delim);
05953           rib_delim = SCHEME_CDR(rib_delim);
05954           ribs_stack = SCHEME_CDR(ribs_stack);
05955 
05956           if (SCHEME_RIBP(v)) {
05957             init_rib = (Scheme_Lexical_Rib *)v;
05958             EXPLAIN_S(fprintf(stderr, " up rib %p=%s\n", init_rib, 
05959                               scheme_write_to_string(init_rib->timestamp, NULL)));
05960             EXPLAIN_S(print_skips(prec_ribs));
05961             rib = init_rib->next;
05962             vsize = 0;
05963             local_ribs = NULL;
05964             while (rib) {
05965               /* We need to process the renamings in reverse order: */
05966               local_ribs = scheme_make_raw_pair((Scheme_Object *)rib, local_ribs);
05967               
05968               vsize += SCHEME_RENAME_LEN(rib->rename);
05969               rib = rib->next;
05970             }
05971             if (local_ribs) {
05972               rib = (Scheme_Lexical_Rib *)SCHEME_CAR(local_ribs);
05973               local_ribs = SCHEME_CDR(local_ribs);
05974             }
05975           } else {
05976             vsize = SCHEME_RENAME_LEN(v);
05977             local_ribs = NULL;
05978           }
05979         }
05980 
05981         /* Initial size; may shrink: */
05982        size = vsize;
05983 
05984        v2 = scheme_make_vector(2 + (2 * size), NULL);
05985         v2_rib_delims = MALLOC_N(Scheme_Object *, size);
05986 
05987        pos = 0; /* counter for used slots */
05988 
05989        /* Local vector (different from i when we have a rib) */
05990        ii = 0;
05991        vvsize = vsize;
05992 
05993        for (i = 0; i < vsize; i++) {
05994          if (rib) {
05995            v = rib->rename;
05996            vvsize = SCHEME_RENAME_LEN(v);
05997            while (ii >= vvsize) {
05998              ii = 0;
05999               done_rib_pos = pos;
06000               rib = (Scheme_Lexical_Rib *)SCHEME_CAR(local_ribs);
06001               local_ribs = SCHEME_CDR(local_ribs);
06002              v = rib->rename;
06003              vvsize = SCHEME_RENAME_LEN(v);
06004            }
06005          }
06006          stx = SCHEME_VEC_ELS(v)[2+ii];
06007          name = SCHEME_STX_VAL(stx);
06008          SCHEME_VEC_ELS(v2)[2+pos] = name;
06009 
06010           if ((!constrain_to_syms || is_member(name, constrain_to_syms))
06011               && (!rib
06012                   || !skip_ribs_ht 
06013                   || !scheme_hash_get(skip_ribs_ht, scheme_make_pair(name, rib->timestamp)))) {
06014            /* Either this name is in prev, in which case the answer
06015               must match this rename's target, or this rename's
06016               answer applies. */
06017            Scheme_Object *ok = NULL, *ok_replace = NULL, **ok_replace_rd = NULL;
06018             int ok_replace_index = 0, ok_replace_rd_index = 0;
06019             Scheme_Object *other_env, *free_id_rename, *prev_env, *orig_prev_env;
06020 
06021             if (rib) {
06022               EXPLAIN_S(fprintf(stderr, "   resolve %s %s (%d)\n", 
06023                                 scheme_write_to_string(name, NULL),
06024                                 scheme_write_to_string(rib->timestamp, NULL),
06025                                 done_rib_pos));
06026             }
06027 
06028             other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii];
06029             if (SCHEME_PAIRP(other_env))
06030               free_id_rename = extract_free_id_info(SCHEME_CDR(other_env));
06031             else
06032               free_id_rename = NULL;
06033             other_env = filter_cached_env(other_env, prec_ribs);
06034             if (SCHEME_VOIDP(other_env)) {
06035               int rib_dep;
06036               other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, NULL);
06037               if (rib_dep) {
06038                 scheme_signal_error("compile: unsealed local-definition context found in fully expanded form");
06039                 return NULL;
06040               }
06041               if (!prec_ribs) {
06042                 if (free_id_rename)
06043                   ok = CONS(other_env, free_id_rename);
06044                 else
06045                   ok = other_env;
06046                 SCHEME_VEC_ELS(v)[2+vvsize+ii] = ok;
06047                 ok = NULL;
06048               } else {
06049                 ok = extend_cached_env(SCHEME_VEC_ELS(v)[2+vvsize+ii], other_env, prec_ribs, 0);
06050                 SCHEME_VEC_ELS(v)[2+vvsize+ii] = ok;
06051                 ok = NULL;
06052               }
06053             }
06054 
06055            if (!WRAP_POS_END_P(prev)
06056                 || SCHEME_PAIRP(v2l)) {
06057              WRAP_POS w3;
06058              Scheme_Object *vp, **vrdp;
06059 
06060              /* Check marks (now that we have the correct barriers). */
06061              WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps);
06062              if (!same_marks(&w2, &w, other_env)) {
06063               other_env = NULL;
06064              }
06065 
06066               if (other_env) {
06067                 /* A simplified table needs to have the final answer, so
06068                    fold conversions from the rest of the wraps. In the case
06069                    of ribs, the "rest" can include earlier rib renamings.
06070                    Otherwise, check simplications accumulated in v2l (possibly from a
06071                    previously simplified tail in the same cache). Finally, 
06072                    try prev (from a previously simplified tail in an earlier
06073                    round of simplifying). */
06074                 int rib_found = 0;
06075                 if (done_rib_pos) {
06076                   for (j = 0; j < done_rib_pos; j++) {
06077                     if (SAME_OBJ(SCHEME_VEC_ELS(v2)[2+j], name)) {
06078                       rib_found = 1;
06079                       prev_env = SCHEME_VEC_ELS(v2)[2+size+j];
06080                       orig_prev_env = prev_env;
06081                       if (SCHEME_PAIRP(prev_env)) prev_env = SCHEME_CAR(prev_env);
06082                       if (SAME_OBJ(prev_env, other_env)) {
06083                         if (SCHEME_FALSEP(rib_delim) 
06084                             || SAME_OBJ(v2_rib_delims[j], rib_delim) 
06085                             || !is_in_rib_delim(prev_env, rib_delim)) {
06086                           ok = SCHEME_VEC_ELS(v)[0];
06087                           ok_replace = v2;
06088                           ok_replace_index = 2 + size + j;
06089                           ok_replace_rd = v2_rib_delims;
06090                           if (!free_id_rename && SCHEME_PAIRP(orig_prev_env))
06091                             free_id_rename = SCHEME_CDR(orig_prev_env);
06092                         }
06093                       } else {
06094                         EXPLAIN_S(fprintf(stderr, "    not matching prev rib\n"));
06095                         ok = NULL;
06096                       }
06097                       break;
06098                     }
06099                   }
06100                 }
06101                 if (!rib_found) {
06102                   int passed_mutable = 0;
06103                   WRAP_POS_COPY(w3, prev);
06104                   svl = v2l;
06105                   svrdl = v2rdl;
06106                   for (; SCHEME_PAIRP(svl) || !WRAP_POS_END_P(w3); ) {
06107                     if (SAME_OBJ(svl, end_mutable)) passed_mutable = 1;
06108                     if (SCHEME_PAIRP(svl)) {
06109                       vp = SCHEME_CAR(svl);
06110                       if (svrdl)
06111                         vrdp = (Scheme_Object **)SCHEME_CAR(svrdl);
06112                       else
06113                         vrdp = NULL;
06114                     } else {
06115                       vp = WRAP_POS_FIRST(w3);
06116                       vrdp = NULL;
06117                     }
06118                     if (SCHEME_VECTORP(vp)) {
06119                       psize = SCHEME_RENAME_LEN(vp);
06120                       for (j = 0; j < psize; j++) {
06121                         if (SAME_OBJ(SCHEME_VEC_ELS(vp)[2+j], name)) {
06122                           prev_env = SCHEME_VEC_ELS(vp)[2+psize+j];
06123                           orig_prev_env = prev_env;
06124                           if (SCHEME_PAIRP(prev_env)) prev_env = SCHEME_CAR(prev_env);
06125                           if (SAME_OBJ(prev_env, other_env)
06126                               && (SCHEME_FALSEP(rib_delim) 
06127                                   || (vrdp && (SAME_OBJ(vrdp[j], rib_delim)))
06128                                   || !is_in_rib_delim(prev_env, rib_delim))) {
06129                             ok = SCHEME_VEC_ELS(v)[0];
06130                             if (!free_id_rename && SCHEME_PAIRP(orig_prev_env))
06131                               free_id_rename = SCHEME_CDR(orig_prev_env);
06132                           } else {
06133                             EXPLAIN_S(fprintf(stderr,
06134                                               "    not matching deeper %s\n",
06135                                               scheme_write_to_string(other_env, NULL)));
06136                             ok = NULL; 
06137                             /* Alternate time/space tradeoff: could be
06138                                  SCHEME_VEC_ELS(vp)[2+psize+j],
06139                                  which is the value from prev */
06140                           }
06141                           if (ok && SCHEME_PAIRP(svl) && !passed_mutable
06142                               && (SCHEME_FALSEP(rib_delim) || vrdp)) {
06143                             /* Can overwrite old map, instead
06144                                of adding a new one. */
06145                             ok_replace = vp;
06146                             ok_replace_index = 2 + psize + j;
06147                             ok_replace_rd = vrdp;
06148                             ok_replace_rd_index = j;
06149                           }
06150                           break;
06151                         }
06152                       }
06153                       if (j < psize)
06154                         break;
06155                     }
06156                     if (SCHEME_PAIRP(svl)) {
06157                       svl = SCHEME_CDR(svl);
06158                       if (svrdl) svrdl = SCHEME_CDR(svrdl);
06159                     } else {
06160                       WRAP_POS_INC(w3);
06161                     }
06162                   }
06163                   if (WRAP_POS_END_P(w3) && SCHEME_NULLP(svl) && SCHEME_FALSEP(other_env))
06164                     ok = SCHEME_VEC_ELS(v)[0];
06165                 }
06166               } else
06167                 ok = NULL;
06168            } else {
06169               if (!SCHEME_FALSEP(other_env)) {
06170                 EXPLAIN_S(fprintf(stderr, "    not based on #f\n"));
06171                 ok = NULL;
06172               } else {
06173                 WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps);
06174                 if (same_marks(&w2, &w, scheme_false))
06175                   ok = SCHEME_VEC_ELS(v)[0];
06176                 else {
06177                   EXPLAIN_S(fprintf(stderr, "    not matching marks\n"));
06178                   ok = NULL;
06179                 }
06180               }
06181            }
06182 
06183            if (ok) {
06184               if (free_id_rename)
06185                 ok = CONS(ok, free_id_rename);
06186               if (ok_replace) {
06187                 EXPLAIN_S(fprintf(stderr, "   replace mapping %s\n", 
06188                                   scheme_write_to_string(ok, NULL)));
06189                 SCHEME_VEC_ELS(ok_replace)[ok_replace_index] = ok;
06190                 ok_replace_rd[ok_replace_rd_index] = rib_delim;
06191               } else {
06192                 EXPLAIN_S(fprintf(stderr, "   add mapping %s\n", 
06193                                   scheme_write_to_string(ok, NULL)));
06194                 SCHEME_VEC_ELS(v2)[2+size+pos] = ok;
06195                 v2_rib_delims[pos] = rib_delim;
06196                 pos++;
06197               }
06198            } else {
06199               EXPLAIN_S(fprintf(stderr, "   no mapping %s\n", 
06200                                 scheme_write_to_string(name, NULL)));
06201             }
06202          } else {
06203             EXPLAIN_S(fprintf(stderr, "   skip %s %s %p\n", 
06204                               scheme_write_to_string(name, NULL),
06205                               scheme_write_to_string(rib->timestamp, NULL),
06206                               rib));
06207           }
06208          ii++;
06209        }
06210 
06211         if (!pos)
06212           v2 = empty_simplified;
06213         else {
06214           if (pos != size) {
06215             /* Shrink simplified vector */
06216             v = v2;
06217             v2 = scheme_make_vector(2 + (2 * pos), NULL);
06218             for (i = 0; i < pos; i++) {
06219               SCHEME_VEC_ELS(v2)[2+i] = SCHEME_VEC_ELS(v)[2+i];
06220               SCHEME_VEC_ELS(v2)[2+pos+i] = SCHEME_VEC_ELS(v)[2+size+i];
06221             }
06222           }
06223 
06224           SCHEME_VEC_ELS(v2)[0] = scheme_false;
06225           for (i = 0; i < pos; i++) {
06226             if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(v2)[2+pos+i]))
06227               SCHEME_VEC_ELS(v2)[0] = scheme_true;
06228           }
06229 
06230           SCHEME_VEC_ELS(v2)[1] = scheme_false;
06231           maybe_install_rename_hash_table(v2);
06232 
06233           if (no_rib_mutation) {
06234             /* Sometimes we generate the same simplified lex table, so
06235                look for an equivalent one in the cache. */
06236             v = scheme_hash_get(lex_cache, scheme_true);
06237             if (!v) {
06238               v = (Scheme_Object *)scheme_make_hash_table_equal();
06239               scheme_hash_set(lex_cache, scheme_true, v);
06240             }
06241             svl = scheme_hash_get((Scheme_Hash_Table *)v, v2);
06242             if (svl)
06243               v2 = svl;
06244             else
06245               scheme_hash_set((Scheme_Hash_Table *)v, v2, v2);
06246           }
06247         }
06248 
06249        v2l = CONS(v2, v2l);
06250        v2rdl = scheme_make_raw_pair((Scheme_Object *)v2_rib_delims, v2rdl);
06251       }
06252 
06253       WRAP_POS_DEC(w);
06254     }
06255 
06256     if (!constrain_to_syms) {
06257       v = scheme_hash_get(lex_cache, key);
06258       if (!v && !prev_prec_ribs) {
06259         /* no dependency on ribs, so we can simply cache this result: */
06260         scheme_hash_set(lex_cache, key, v2l);
06261       } else {
06262         Scheme_Hash_Table *ht;
06263         if (v && SCHEME_HASHTP(v))
06264           ht = (Scheme_Hash_Table *)v;
06265         else {
06266           ht = scheme_make_hash_table(SCHEME_hash_ptr);
06267         }
06268         if (v && !SCHEME_HASHTP(v))
06269           scheme_hash_set(ht, scheme_false, v);
06270         scheme_hash_set(ht, prev_prec_ribs ? prev_prec_ribs : scheme_false, v2l);
06271         scheme_hash_set(lex_cache, key, (Scheme_Object *)ht);
06272       }
06273       end_mutable = v2l;
06274     }
06275 
06276     stack = SCHEME_CDR(stack);
06277   }
06278 
06279   EXPLAIN_R(printf(" ... done\n"));
06280 
06281   return v2l;
06282 }
06283 
06284 static Scheme_Object *wraps_to_datum(Scheme_Object *stx_datum,
06285                                      Scheme_Object *w_in, 
06286                                  Scheme_Marshal_Tables *mt,
06287                                      Scheme_Hash_Table *rns,
06288                                  int just_simplify)
06289 {
06290   Scheme_Object *stack, *a, *old_key, *simplifies = scheme_null, *prec_ribs = scheme_null;
06291   WRAP_POS w;
06292   Scheme_Hash_Table *lex_cache, *reverse_map;
06293   int stack_size = 0, specific_to_datum = 0;
06294 
06295   if (!rns)
06296     rns = mt->rns;
06297 
06298   if (just_simplify) {
06299     a = scheme_hash_get(rns, w_in);
06300   } else {
06301     if (mt->same_map) {
06302       a = scheme_hash_get(mt->same_map, w_in);
06303       if (a)
06304         w_in = a;
06305     }
06306     a = scheme_marshal_lookup(mt, w_in);
06307   }
06308   if (a) {
06309     if (just_simplify)
06310       return a;
06311     else {
06312       scheme_marshal_using_key(mt, w_in);
06313       return a;
06314     }
06315   }
06316 
06317   WRAP_POS_INIT(w, w_in);
06318 
06319   stack = scheme_null;
06320 
06321   lex_cache = (Scheme_Hash_Table *)scheme_hash_get(rns, scheme_void);
06322   if (!lex_cache) {
06323     lex_cache = scheme_make_hash_table(SCHEME_hash_ptr);
06324     scheme_hash_set(rns, scheme_void, (Scheme_Object *)lex_cache);
06325   }
06326 
06327   if (!just_simplify)
06328     stx_datum = scheme_false;
06329 
06330   /* Ensures that all lexical tables in w have been simplified */
06331   simplifies = simplify_lex_renames(w_in, lex_cache, stx_datum);
06332 
06333   if (mt)
06334     scheme_marshal_push_refs(mt);
06335 
06336   while (!WRAP_POS_END_P(w)) {
06337     a = WRAP_POS_FIRST(w);
06338     old_key = WRAP_POS_KEY(w);
06339     WRAP_POS_INC(w);
06340     if (SCHEME_NUMBERP(a)) {
06341       /* Mark numbers get parenthesized */
06342       if (!WRAP_POS_END_P(w) && SAME_OBJ(a, WRAP_POS_FIRST(w)))
06343        WRAP_POS_INC(w); /* delete cancelled mark */
06344       else {
06345        if (just_simplify)
06346          stack = CONS(a, stack);
06347        else
06348          stack = CONS(CONS(a, scheme_null), stack);
06349        stack_size++;
06350       }
06351     } else if (SCHEME_VECTORP(a)
06352               || SCHEME_RIBP(a)) {
06353       if (SCHEME_RIBP(a) || (SCHEME_VEC_SIZE(a) > 2)) {
06354 
06355        if (SCHEME_RIBP(a) || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(a)[2])) {
06356          /* a is not a simplified table; need to look it up; if
06357             simplifies is non-null, then we already have found a list
06358             of simplified tables for the current wrap segment. */
06359           if (SCHEME_RIBP(a)) {
06360             if (nonempty_rib((Scheme_Lexical_Rib *)a))
06361               prec_ribs = scheme_make_pair(((Scheme_Lexical_Rib *)a)->timestamp, prec_ribs);
06362           }
06363          a = SCHEME_CAR(simplifies);
06364          /* used up one simplification: */
06365          simplifies = SCHEME_CDR(simplifies);
06366        }
06367          
06368        /* Simplification may have left us with the null table: */
06369        if (SCHEME_VEC_SIZE(a) > 2) {
06370          if (just_simplify) {
06371            stack = CONS(a, stack);
06372          } else {
06373            Scheme_Object *local_key;
06374            
06375            local_key = scheme_marshal_lookup(mt, a);
06376            if (local_key) {
06377               scheme_marshal_using_key(mt, a);
06378               a = local_key;
06379             } else {
06380               a = scheme_marshal_wrap_set(mt, a, a);
06381             }
06382             stack = CONS(a, stack);
06383          }
06384          stack_size++;
06385        }
06386       }
06387       /* else empty simplified vector, which we drop */
06388     } else if (SCHEME_RIB_DELIMP(a)) {
06389       /* simpliciation eliminates the need for rib delimiters */
06390     } else if (SCHEME_RENAMESP(a)
06391                || SCHEME_RENAMES_SETP(a)) {
06392       int which = 0;
06393 
06394       while (1) {
06395         Module_Renames *mrn;
06396         int redundant = 0;
06397       
06398         if (SCHEME_RENAMESP(a))  {
06399           if (!which) {
06400             mrn = (Module_Renames *)a;
06401             which++;
06402           } else
06403             break;
06404         } else {
06405           /* flatten sets */
06406           Module_Renames_Set *s = (Module_Renames_Set *)a;
06407           mrn = NULL;
06408           while (!mrn 
06409                  && (which - 2 < (s->other_phases
06410                                   ? s->other_phases->size
06411                                   : 0))) {
06412             if (!which)
06413               mrn = s->rt;
06414             else if (which == 1)
06415               mrn = s->et;
06416             else
06417               mrn = (Module_Renames *)s->other_phases->vals[which - 2];
06418             which++;
06419           }
06420           if (!mrn
06421               && (which - 2 >= (s->other_phases
06422                                 ? s->other_phases->size
06423                                 : 0)))
06424             break;
06425         }
06426       
06427         if (mrn) {
06428           if (mrn->kind == mzMOD_RENAME_MARKED) {
06429             /* Not useful if there's no marked names. */
06430             redundant = ((mrn->sealed >= STX_SEAL_ALL)
06431                          && (!mrn->marked_names || !mrn->marked_names->count)
06432                          && (!mrn->free_id_renames || !mrn->free_id_renames->count)
06433                          && SCHEME_NULLP(mrn->shared_pes));
06434             if (!redundant) {
06435               /* Otherwise, watch out for multiple instances of the same rename: */
06436               WRAP_POS l;
06437               Scheme_Object *la;
06438        
06439               WRAP_POS_COPY(l,w);
06440          
06441               for (; !WRAP_POS_END_P(l); WRAP_POS_INC(l)) {
06442                 la = WRAP_POS_FIRST(l);
06443                 if (SAME_OBJ(a, la)) {
06444                   redundant = 1;
06445                   break;
06446                 }
06447               }
06448             }
06449           } else {
06450             /* Check for later [non]module rename at the same phase: */
06451             Scheme_Object *phase;
06452             WRAP_POS l;
06453             Scheme_Object *la;
06454        
06455             WRAP_POS_COPY(l,w);
06456 
06457             phase = mrn->phase;
06458 
06459             for (; !WRAP_POS_END_P(l); WRAP_POS_INC(l)) {
06460               la = WRAP_POS_FIRST(l);
06461               if (SCHEME_RENAMESP(la)) {
06462                 Module_Renames *lrn = (Module_Renames *)WRAP_POS_FIRST(l);
06463                 if ((lrn->kind == mrn->kind)
06464                     && (same_phase(lrn->phase, phase))) {
06465                   /* mrn is redundant */
06466                   redundant = 1;
06467                   break;
06468                 }
06469               } else if (SCHEME_RENAMES_SETP(la)) {
06470                 Module_Renames_Set *s = (Module_Renames_Set *)WRAP_POS_FIRST(l);
06471                 if ((s->kind == mrn->kind)
06472                     && extract_renames(s, phase)) {
06473                   redundant = 1;
06474                   break;
06475                 }
06476               } else if (SCHEME_BOXP(la)) {
06477                 if (SCHEME_TRUEP(phase))
06478                   phase = scheme_bin_minus(phase,
06479                                            SCHEME_VEC_ELS(SCHEME_PTR_VAL(WRAP_POS_FIRST(l)))[0]);
06480               }
06481             }
06482           }
06483 
06484           if (!redundant) {
06485             if (just_simplify) {
06486               stack = CONS((Scheme_Object *)mrn, stack);
06487             } else {
06488               if (mrn->free_id_renames) {
06489                 /* resolve all renamings */
06490                 int i;
06491                 Scheme_Object *b;
06492                 for (i = mrn->free_id_renames->size; i--; ) {
06493                   if (mrn->free_id_renames->vals[i]) {
06494                     if (SCHEME_STXP(mrn->free_id_renames->vals[i])) {
06495                       int sealed;
06496                       Scheme_Hash_Table *free_id_recur;
06497                       
06498                       free_id_recur = make_recur_table();
06499                       b = extract_module_free_id_binding((Scheme_Object *)mrn,
06500                                                          mrn->free_id_renames->keys[i],
06501                                                          mrn->free_id_renames->vals[i],
06502                                                          &sealed,
06503                                                          free_id_recur);
06504                       release_recur_table(free_id_recur);
06505                       if (!sealed) {
06506                         scheme_signal_error("write: unsealed local-definition or module context"
06507                                             " found in syntax object");
06508                       }
06509                       scheme_hash_set(mrn->free_id_renames, mrn->free_id_renames->keys[i], b);
06510                     }
06511                   }
06512                 }
06513               }
06514             
06515               if (mrn->kind == mzMOD_RENAME_TOPLEVEL) {
06516                 if (same_phase(mrn->phase, scheme_make_integer(0)))
06517                   stack = CONS(scheme_true, stack);
06518                 else
06519                   stack = CONS(scheme_false, stack);
06520               } else {
06521                 Scheme_Object *local_key;
06522          
06523                 local_key = scheme_marshal_lookup(mt, (Scheme_Object *)mrn);
06524                 if (!local_key) {
06525                   /* Convert hash table to vector, etc.: */
06526                   int i, j, count = 0;
06527                   Scheme_Hash_Table *ht;
06528                   Scheme_Object *l, *fil;
06529            
06530                   ht = mrn->ht;
06531                   count = ht->count;
06532                   l = scheme_make_vector(count * 2, NULL);                  
06533                   for (i = ht->size, j = 0; i--; ) {
06534                     if (ht->vals[i]) {
06535                       SCHEME_VEC_ELS(l)[j++] = ht->keys[i];
06536                       fil = ht->vals[i];
06537                       if (SCHEME_PAIRP(fil) && is_rename_inspector_info(SCHEME_CAR(fil))) {
06538                         /* use 1 or 2 to indicate inspector info */
06539                         if (SCHEME_PAIRP(SCHEME_CAR(fil)))
06540                           fil = CONS(scheme_make_integer(2), SCHEME_CDR(fil));
06541                         else
06542                           fil = CONS(scheme_make_integer(1), SCHEME_CDR(fil));
06543                       }
06544                       SCHEME_VEC_ELS(l)[j++] = fil;
06545                     }
06546                   }
06547 
06548                   ht = mrn->free_id_renames;
06549                   if (ht && ht->count) {
06550                     count = ht->count;
06551                     fil = scheme_make_vector(count * 2, NULL);                  
06552                     for (i = ht->size, j = 0; i--; ) {
06553                       if (ht->vals[i]) {
06554                         SCHEME_VEC_ELS(fil)[j++] = ht->keys[i];
06555                         SCHEME_VEC_ELS(fil)[j++] = ht->vals[i];
06556                       }
06557                     }
06558                   } else
06559                     fil = NULL;
06560 
06561                   if (mrn->marked_names && mrn->marked_names->count) {
06562                     Scheme_Object *d = scheme_null, *p;
06563 
06564                     for (i = mrn->marked_names->size; i--; ) {
06565                       if (mrn->marked_names->vals[i]
06566                           /* #f mapping used to store reverse-map cache: */
06567                           && !SCHEME_FALSEP(mrn->marked_names->keys[i])) {
06568                         p = CONS(mrn->marked_names->keys[i],
06569                                  mrn->marked_names->vals[i]);
06570                         d = CONS(p, d);
06571                       }
06572                     }
06573 
06574                     if (fil)
06575                       fil = CONS(fil, d);
06576                     else
06577                       fil = d;
06578                   } else if (fil)
06579                     fil = CONS(fil, scheme_null);
06580                   else
06581                     fil = scheme_null;
06582                     
06583                   l = CONS(l, fil);
06584                   
06585                   if (SCHEME_PAIRP(mrn->unmarshal_info))
06586                     l = CONS(mrn->unmarshal_info, l); 
06587              
06588                   l = CONS(mrn->set_identity, l);
06589                   l = CONS((mrn->kind == mzMOD_RENAME_MARKED) ? scheme_true : scheme_false, l);
06590                   l = CONS(mrn->phase, l);
06591            
06592                   local_key = scheme_marshal_lookup(mt, a);
06593                   if (local_key)
06594                     scheme_marshal_using_key(mt, a);
06595                   else {
06596                     local_key = scheme_marshal_wrap_set(mt, a, l);
06597                   }
06598                 } else {
06599                   scheme_marshal_using_key(mt, (Scheme_Object *)mrn);
06600                 }
06601                 stack = CONS(local_key, stack);
06602               }
06603             }
06604             stack_size++;
06605           }
06606         }
06607       }
06608     } else if (SCHEME_SYMBOLP(a)) {
06609       /* mark barrier */
06610       stack = CONS(a, stack);
06611       stack_size++;
06612     } else if (SCHEME_HASHTP(a)) {
06613       /* chain-specific cache; drop it */
06614     } else if (SCHEME_PRUNEP(a)) {
06615       if (SCHEME_SYMBOLP(stx_datum)) {
06616         /* Assuming that there are lex renames later, then this chain is
06617            specific to this wrap. */
06618         specific_to_datum = 1;
06619       }
06620       if (!just_simplify)
06621         a = scheme_box(SCHEME_BOX_VAL(a));
06622       stack = CONS(a, stack);
06623       stack_size++;
06624     } else {
06625       /* box, a phase shift */
06626       /* We used to drop a phase shift if there are no following
06627          rename tables. However, the phase shift also identifies
06628          the source module, which can be relevant. So, keep the
06629          phase shift. */
06630       /* Need the phase shift, but drop the export table, if any: */
06631       Scheme_Object *local_key;
06632       Scheme_Object *aa;
06633       
06634       aa = SCHEME_BOX_VAL(a);
06635       if (SCHEME_TRUEP(SCHEME_VEC_ELS(aa)[3])) {
06636         if (mt)
06637           a = scheme_hash_get(mt->shift_map, aa);
06638         else
06639           a = scheme_hash_get(rns, aa);
06640         if (!a) {
06641           a = scheme_make_vector(4, NULL);
06642           SCHEME_VEC_ELS(a)[0] = SCHEME_VEC_ELS(aa)[0];
06643           SCHEME_VEC_ELS(a)[1] = SCHEME_VEC_ELS(aa)[1];
06644           SCHEME_VEC_ELS(a)[2] = SCHEME_VEC_ELS(aa)[2];
06645           SCHEME_VEC_ELS(a)[3] = scheme_false;
06646           a = scheme_box(a);
06647           scheme_hash_set(rns, aa, a);
06648         }
06649       }
06650       
06651       if (!just_simplify) {
06652         local_key = scheme_marshal_lookup(mt, a);
06653         if (local_key) {
06654           scheme_marshal_using_key(mt, a);
06655           a = local_key;
06656         } else {
06657           a = scheme_marshal_wrap_set(mt, a, a);
06658         }
06659       }
06660       
06661       stack = CONS(a, stack);
06662       stack_size++;
06663     }
06664   }
06665 
06666   /* Double-check for equivalent list in table (after simplification): */
06667   if (mt && mt->pass) {
06668     /* No need to check for later passes, since mt->same_map
06669        covers the equivalence. */
06670   } else {
06671     if (mt) {
06672       reverse_map = mt->reverse_map;
06673     } else {
06674       reverse_map = (Scheme_Hash_Table *)scheme_hash_get(rns, scheme_undefined);
06675     }
06676     if (!reverse_map) {
06677       reverse_map = scheme_make_hash_table_equal();
06678       if (mt)
06679         mt->reverse_map = reverse_map;
06680       else
06681         scheme_hash_set(rns, scheme_undefined, (Scheme_Object *)reverse_map);
06682     }
06683     old_key = scheme_hash_get(reverse_map, stack);
06684     if (old_key) {
06685       if (just_simplify) {
06686         return scheme_hash_get(rns, old_key);
06687       } else {
06688         a = scheme_marshal_lookup(mt, old_key);
06689         scheme_marshal_using_key(mt, old_key);
06690         if (!mt->same_map) {
06691           Scheme_Hash_Table *same_map;
06692           same_map = scheme_make_hash_table(SCHEME_hash_ptr);
06693           mt->same_map = same_map;
06694         }
06695         scheme_hash_set(mt->same_map, w_in, old_key);
06696         /* nevermind references that we saw when creating `stack': */
06697         scheme_marshal_pop_refs(mt, 0);
06698         return a;
06699       }
06700     }
06701 
06702     if (!specific_to_datum)
06703       scheme_hash_set(reverse_map, stack, w_in);
06704   }
06705 
06706   /* Convert to a chunk if just simplifying.
06707      (Note that we do this after looking for equivalent stacks.) */
06708   if (just_simplify) {
06709     if (stack_size) {
06710       Wrap_Chunk *wc;
06711       int i;
06712       wc = MALLOC_WRAP_CHUNK(stack_size);
06713       wc->type = scheme_wrap_chunk_type;
06714       wc->len = stack_size;
06715       for (i = stack_size; i--; stack = SCHEME_CDR(stack)) {
06716         wc->a[i] = SCHEME_CAR(stack);
06717       }
06718       stack = CONS((Scheme_Object *)wc, scheme_null);
06719     } else
06720       stack= scheme_null;
06721   }
06722   
06723   if (mt) {
06724     /* preserve references that we saw when creating `stack': */
06725     scheme_marshal_pop_refs(mt, 1);
06726   }
06727 
06728   /* Remember this wrap set: */
06729   if (just_simplify) {
06730     if (!specific_to_datum)
06731       scheme_hash_set(rns, w_in, stack);
06732     return stack;
06733   } else {
06734     return scheme_marshal_wrap_set(mt, w_in, stack);
06735   }
06736 }
06737 
06738 /*========================================================================*/
06739 /*                           syntax->datum                                */
06740 /*========================================================================*/
06741 
06742 /* This code can convert a syntax object plus its wraps to something
06743    writeable. In that case, the result is a <converted>:
06744 
06745       <converted> = (vector <simple converted> <cert>)
06746                   | <simple converted>
06747       <simple converted> = <simple converted pair> | ...
06748 
06749       <simple converted pair> = (cons (cons <int> (cons <converted> ... <converted>)) <wrap>)
06750                               | (cons (cons <converted> ... null) <wrap>)
06751                               | (cons (cons #t <s-exp>) <wrap>)
06752                                  ; where <s-exp> has no boxes or vectors, and
06753                                  ;  <wrap> is shared in all <s-exp> elements
06754       <simple converted box> = (cons (box <converted>) <wrap>)
06755       <simple converted vector> = (cons (vector <converted> ...) <wrap>)
06756       <simple converted other> = (cons <s-exp> <wrap>)
06757                                  ; where <s-exp> is not a pair, vector, or box
06758 */
06759 
06760 static Scheme_Object *extract_for_common_wrap(Scheme_Object *a, int get_mark, int pair_ok)
06761 {
06762   /* We only share wraps for things constucted with pairs and
06763      atomic (w.r.t. syntax) values, where there are no certificates
06764      on any of the sub-parts. */
06765   Scheme_Object *v;
06766 
06767   if (SCHEME_PAIRP(a)) {
06768     v = SCHEME_CAR(a);
06769 
06770     if (SCHEME_PAIRP(v)) {
06771       if (pair_ok && SAME_OBJ(SCHEME_CAR(v), scheme_true)) {
06772         /* A pair with shared wraps for its elements */
06773         if (get_mark)
06774           return SCHEME_CDR(a);
06775         else
06776           return SCHEME_CDR(v);
06777       }
06778     } else if (!SCHEME_BOXP(v) && !SCHEME_VECTORP(v)) {
06779       /* It's atomic. */
06780       if (get_mark)
06781         return SCHEME_CDR(a);
06782       else
06783         return v;
06784     }
06785   }
06786 
06787   return NULL;
06788 }
06789 
06790 static void lift_common_wraps(Scheme_Object *l, Scheme_Object *common_wraps, int cnt, int tail)
06791 {
06792   Scheme_Object *a;
06793 
06794   while (cnt--) {
06795     a = SCHEME_CAR(l);
06796     a = extract_for_common_wrap(a, 0, 1);
06797     SCHEME_CAR(l) = a;
06798     if (cnt)
06799       l = SCHEME_CDR(l);
06800   }
06801   if (tail) {
06802     a = SCHEME_CDR(l);
06803     a = extract_for_common_wrap(a, 0, 0);
06804     SCHEME_CDR(l) = a;
06805   }
06806 }
06807 
06808 static Scheme_Object *record_certs(Scheme_Object *cert_marks, Scheme_Marshal_Tables *mt)
06809 {
06810   Scheme_Object *v, *local_key;
06811 
06812   if (SCHEME_PAIRP(cert_marks)) {
06813     v = scheme_hash_get(mt->cert_lists, cert_marks);
06814     if (!v) {
06815       scheme_hash_set(mt->cert_lists, cert_marks, cert_marks);
06816       v = cert_marks;
06817     }
06818 
06819     local_key = scheme_marshal_lookup(mt, v);
06820     if (local_key) {
06821       scheme_marshal_using_key(mt, v);
06822       return local_key;
06823     } else {
06824       return scheme_marshal_wrap_set(mt, v, v);
06825     }
06826   } else
06827     return scheme_null;
06828 }
06829 
06830 #ifdef DO_STACK_CHECK
06831 static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, 
06832                                        int with_marks,
06833                                        Scheme_Marshal_Tables *mt);
06834 
06835 static Scheme_Object *syntax_to_datum_k(void)
06836 {
06837   Scheme_Thread *p = scheme_current_thread;
06838   Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
06839   Scheme_Marshal_Tables *mt = (Scheme_Marshal_Tables *)p->ku.k.p3;
06840 
06841   p->ku.k.p1 = NULL;
06842   p->ku.k.p3 = NULL;
06843 
06844   return syntax_to_datum_inner(o, p->ku.k.i1, mt);
06845 }
06846 #endif
06847 
06848 static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, 
06849                                        int with_marks,
06850                                        Scheme_Marshal_Tables *mt)
06851 {
06852   Scheme_Stx *stx = (Scheme_Stx *)o;
06853   Scheme_Object *v, *result, *converted_wraps = NULL;
06854 
06855 #ifdef DO_STACK_CHECK
06856   {
06857 # include "mzstkchk.h"
06858     {
06859       Scheme_Thread *p = scheme_current_thread;
06860       p->ku.k.p1 = (void *)o;
06861       p->ku.k.i1 = with_marks;
06862       p->ku.k.p3 = (void *)mt;
06863       return scheme_handle_stack_overflow(syntax_to_datum_k);
06864     }
06865   }
06866 #endif
06867   SCHEME_USE_FUEL(1);
06868 
06869   if (with_marks) {
06870     /* Propagate wraps: */
06871     scheme_stx_content((Scheme_Object *)stx);
06872   }
06873 
06874   v = stx->val;
06875   
06876   if (SCHEME_PAIRP(v)) {
06877     Scheme_Object *first = NULL, *last = NULL, *p, *common_wraps = NULL;
06878     int cnt = 0;
06879     
06880     while (SCHEME_PAIRP(v)) {
06881       Scheme_Object *a;
06882 
06883       cnt++;
06884 
06885       a = syntax_to_datum_inner(SCHEME_CAR(v), with_marks, mt);
06886 
06887       p = CONS(a, scheme_null);
06888       
06889       if (last)
06890        SCHEME_CDR(last) = p;
06891       else
06892        first = p;
06893       last = p;
06894       v = SCHEME_CDR(v);
06895 
06896       if (with_marks) {
06897         a = extract_for_common_wrap(a, 1, 1);
06898         if (!common_wraps) {
06899           if (a)
06900             common_wraps = a;
06901           else
06902             common_wraps = scheme_false;
06903         } else if (!a || !SAME_OBJ(common_wraps, a))
06904           common_wraps = scheme_false;
06905       }
06906     }
06907     if (!SCHEME_NULLP(v)) {
06908       v = syntax_to_datum_inner(v, with_marks, mt);
06909       SCHEME_CDR(last) = v;
06910 
06911       if (with_marks) {
06912         v = extract_for_common_wrap(v, 1, 0);
06913         if (v && SAME_OBJ(common_wraps, v)) {
06914           converted_wraps = wraps_to_datum(scheme_false, stx->wraps, mt, NULL, 0);
06915           if (SAME_OBJ(common_wraps, converted_wraps))
06916             lift_common_wraps(first, common_wraps, cnt, 1);
06917           else
06918             common_wraps = scheme_false;
06919         } else
06920           common_wraps = scheme_false;
06921       }
06922 
06923       if ((with_marks > 1) && SCHEME_FALSEP(common_wraps)) {
06924        /* v is likely a pair, and v's car might be a pair,
06925           which means that the datum->syntax part
06926           won't be able to detect that v is a "non-pair"
06927           terminal. Therefore, we communicate the
06928           length before the terminal to datum->syntax: */
06929        first = scheme_make_pair(scheme_make_integer(cnt), first);
06930       }
06931     } else if (with_marks && SCHEME_TRUEP(common_wraps)) {
06932       converted_wraps = wraps_to_datum(scheme_false, stx->wraps, mt, NULL, 0);
06933       if (SAME_OBJ(common_wraps, converted_wraps))
06934         lift_common_wraps(first, common_wraps, cnt, 0);
06935       else
06936         common_wraps = scheme_false;
06937     }
06938 
06939     if (with_marks && SCHEME_TRUEP(common_wraps)) {
06940       first = scheme_make_pair(scheme_true, first);
06941     }
06942 
06943     result = first;
06944   } else if (SCHEME_BOXP(v)) {
06945     v = syntax_to_datum_inner(SCHEME_BOX_VAL(v), with_marks, mt);
06946     result = scheme_box(v);
06947     SCHEME_SET_IMMUTABLE(result);
06948   } else if (SCHEME_VECTORP(v)) {
06949     int size = SCHEME_VEC_SIZE(v), i;
06950     Scheme_Object *r, *a;
06951     
06952     r = scheme_make_vector(size, NULL);
06953     
06954     for (i = 0; i < size; i++) {
06955       a = syntax_to_datum_inner(SCHEME_VEC_ELS(v)[i], with_marks, mt);
06956       SCHEME_VEC_ELS(r)[i] = a;
06957     }
06958 
06959     result = r;
06960     SCHEME_SET_IMMUTABLE(result);
06961   } else if (SCHEME_HASHTRP(v)) {
06962     Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v, *ht2;
06963     Scheme_Object *key, *val;
06964     int i;
06965     
06966     ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht) & 0x3);
06967     
06968     i = scheme_hash_tree_next(ht, -1);
06969     while (i != -1) {
06970       scheme_hash_tree_index(ht, i, &key, &val);
06971       val = syntax_to_datum_inner(val, with_marks, mt);
06972       ht2 = scheme_hash_tree_set(ht2, key, val);
06973       i = scheme_hash_tree_next(ht, i);
06974     }
06975     
06976     result = (Scheme_Object *)ht2;
06977   } else if (prefab_p(v)) {
06978     Scheme_Structure *s = (Scheme_Structure *)v;
06979     Scheme_Object *a;
06980     int size = s->stype->num_slots, i;
06981     
06982     s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s);
06983     for (i = 0; i < size; i++) {
06984       a = syntax_to_datum_inner(s->slots[i], with_marks, mt);
06985       s->slots[i] = a;
06986     }
06987 
06988     result = (Scheme_Object *)s;
06989   } else
06990     result = v;
06991 
06992   if (with_marks > 1) {
06993     if (!converted_wraps)
06994       converted_wraps = wraps_to_datum(stx->val, stx->wraps, mt, NULL, 0);
06995     result = CONS(result, converted_wraps);
06996     if (stx->certs) {
06997       Scheme_Object *cert_marks = scheme_null, *icert_marks = scheme_null;
06998       Scheme_Cert *certs;
06999 
07000       certs = ACTIVE_CERTS(stx);
07001       while (certs) {
07002        cert_marks = scheme_make_pair(certs->modidx, cert_marks);
07003        cert_marks = scheme_make_pair(certs->mark, cert_marks);
07004        certs = certs->next;
07005       }
07006       certs = INACTIVE_CERTS(stx);
07007       while (certs) {
07008        icert_marks = scheme_make_pair(certs->modidx, icert_marks);
07009        icert_marks = scheme_make_pair(certs->mark, icert_marks);
07010        certs = certs->next;
07011       }
07012 
07013       if (SCHEME_PAIRP(cert_marks)
07014           || SCHEME_PAIRP(icert_marks)) {
07015         
07016         cert_marks = record_certs(cert_marks, mt);
07017         icert_marks = record_certs(icert_marks, mt);
07018 
07019         v = scheme_make_vector(2, NULL);
07020         SCHEME_VEC_ELS(v)[0] = result;
07021         if (!SCHEME_NULLP(icert_marks)) {
07022           cert_marks = scheme_make_pair(cert_marks, icert_marks);
07023           if (SCHEME_NUMBERP(SCHEME_CAR(cert_marks)))
07024             cert_marks = scheme_make_pair(scheme_false, cert_marks);
07025         }
07026         SCHEME_VEC_ELS(v)[1] = cert_marks;
07027         result = v;
07028       }
07029     }
07030   }
07031 
07032   return result;
07033 }
07034 
07035 Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx, int with_marks,
07036                                   Scheme_Marshal_Tables *mt)
07037 {
07038   Scheme_Object *v;
07039 
07040   if (mt)
07041     scheme_marshal_push_refs(mt);
07042 
07043   v = syntax_to_datum_inner(stx, with_marks, mt);
07044 
07045   if (mt) {
07046     /* A symbol+wrap combination is likely to be used multiple
07047        times. This is a relatively minor optimization in .zo size,
07048        since v is already fairly compact, but it also avoids
07049        allocating extra syntax objects at load time. For consistency,
07050        we try to reuse all combinations. */
07051     Scheme_Hash_Table *top_map;
07052     Scheme_Object *key;
07053     
07054     top_map = mt->top_map;
07055     if (!top_map) {
07056       top_map = scheme_make_hash_table_equal();
07057       mt->top_map = top_map;
07058     }
07059     
07060     key = scheme_hash_get(top_map, v);
07061     if (key) {
07062       scheme_marshal_pop_refs(mt, 0);
07063       v = scheme_marshal_lookup(mt, key);
07064       scheme_marshal_using_key(mt, key);
07065     } else {
07066       scheme_hash_set(top_map, stx, v);
07067       v = scheme_marshal_wrap_set(mt, stx, v);
07068       scheme_marshal_pop_refs(mt, 1);
07069     }
07070   }
07071 
07072   return v;
07073 }
07074 
07075 /*========================================================================*/
07076 /*                            datum->wraps                                */
07077 /*========================================================================*/
07078 
07079 static Scheme_Object *unmarshal_mark(Scheme_Object *_a, Scheme_Unmarshal_Tables *ut)
07080 {
07081   Scheme_Object *n, *a = _a;
07082 
07083   if (SCHEME_INTP(a) && IS_POSMARK(a))
07084     a = scheme_make_integer(-SCHEME_INT_VAL(a));
07085   else if (!SCHEME_NUMBERP(a))
07086     return NULL;
07087   else
07088     a = scheme_intern_symbol(scheme_number_to_string(10, a));
07089   
07090   /* Picked a mapping yet? */
07091   n = scheme_hash_get(ut->rns, a);
07092   if (!n) {
07093     /* Map marshaled mark to a new mark. */
07094     n = scheme_new_mark();
07095     if (!IS_POSMARK(_a)) {
07096       /* Map negative mark to negative mark: */
07097       n = negate_mark(n);
07098     }
07099     scheme_hash_set(ut->rns, a, n);
07100   }
07101   
07102   /* Really a mark? */
07103   if (!SCHEME_NUMBERP(n))
07104     return NULL;
07105 
07106   return n;
07107 }
07108 
07109 #if 0
07110 # define return_NULL return (printf("%d\n", __LINE__), NULL)
07111 #else
07112 # define return_NULL return NULL
07113 #endif
07114 
07115 static int ok_phase(Scheme_Object *o) {
07116   return (SCHEME_INTP(o) || SCHEME_BIGNUMP(o) || SCHEME_FALSEP(o));
07117 }
07118 static int ok_phase_index(Scheme_Object *o) {
07119   return ok_phase(o);
07120 }
07121 
07122 static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Table *ht, int lex_ok)
07123 {
07124   int count, i;
07125   Scheme_Object *key, *p0, *p;
07126 
07127   if (!SCHEME_VECTORP(a)) return_NULL;
07128   count = SCHEME_VEC_SIZE(a);
07129   if (count & 0x1) return_NULL;
07130 
07131   for (i = 0; i < count; i+= 2) {
07132     key = SCHEME_VEC_ELS(a)[i];
07133     p0 = SCHEME_VEC_ELS(a)[i+1];
07134        
07135     if (!SCHEME_SYMBOLP(key)) return_NULL;
07136 
07137     p = p0;
07138     if (SCHEME_PAIRP(p) && SCHEME_INTP(SCHEME_CAR(p))) {
07139       /* reconstruct inspector info */
07140       Scheme_Object *insp;
07141       insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
07142       if (!SAME_OBJ(scheme_make_integer(1), SCHEME_CAR(p))) {
07143         insp = CONS(scheme_make_inspector(insp), insp);
07144       }
07145       p = SCHEME_CDR(p0);
07146       p0 = CONS(insp, p);
07147     }
07148 
07149     if (SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)) {
07150       /* Ok */
07151     } else if (SCHEME_PAIRP(p)) {
07152       Scheme_Object *midx;
07153 
07154       midx = SCHEME_CAR(p);
07155       if (!SAME_TYPE(SCHEME_TYPE(midx), scheme_module_index_type))
07156         return_NULL;
07157 
07158       if (SCHEME_SYMBOLP(SCHEME_CDR(p))) {
07159         /* Ok */
07160       } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_CDR(p)), scheme_module_index_type)) {
07161         /* Ok */
07162       } else {
07163         Scheme_Object *ap, *bp;
07164 
07165         ap = SCHEME_CDR(p);
07166         if (!SCHEME_PAIRP(ap))
07167           return_NULL;
07168 
07169         /* mod-phase, maybe */
07170         if (SCHEME_INTP(SCHEME_CAR(ap))) {
07171           bp = SCHEME_CDR(ap);
07172         } else
07173           bp = ap;
07174             
07175         /* exportname */
07176         if (!SCHEME_PAIRP(bp))
07177           return_NULL;
07178         ap = SCHEME_CAR(bp);
07179         if (!SCHEME_SYMBOLP(ap))
07180           return_NULL;
07181             
07182         /* nominal_modidx_plus_phase */
07183         bp = SCHEME_CDR(bp);
07184         if (!SCHEME_PAIRP(bp))
07185           return_NULL;
07186         ap = SCHEME_CAR(bp);
07187         if (SAME_TYPE(SCHEME_TYPE(ap), scheme_module_index_type)) {
07188           /* Ok */
07189         } else if (SCHEME_PAIRP(ap)) {
07190           if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(ap)), scheme_module_index_type))
07191             return_NULL;
07192           ap = SCHEME_CDR(ap);
07193           /* import_phase_plus_nominal_phase */
07194           if (SCHEME_PAIRP(ap)) {
07195             if (!ok_phase_index(SCHEME_CAR(ap))) return_NULL;
07196             if (!ok_phase_index(SCHEME_CDR(ap))) return_NULL;
07197           } else if (!ok_phase_index(ap))
07198             return_NULL;
07199         } else
07200           return_NULL;
07201 
07202         /* nominal_exportname */
07203         ap = SCHEME_CDR(bp);
07204         if (!SCHEME_SYMBOLP(ap))
07205           return_NULL;
07206       }
07207     } else if (lex_ok) {
07208       Scheme_Object *ap;
07209       if (!SCHEME_BOXP(p))
07210         return_NULL;
07211       ap = SCHEME_BOX_VAL(p);
07212       if (!SCHEME_PAIRP(ap))
07213         return_NULL;
07214       if (!SCHEME_SYMBOLP(SCHEME_CAR(ap)))
07215         return_NULL;
07216       ap = SCHEME_CDR(ap);
07217       if (!SCHEME_SYMBOLP(ap) && !SCHEME_FALSEP(ap))
07218         return_NULL;
07219     } else
07220       return_NULL;
07221        
07222     scheme_hash_set(ht, key, p0);
07223   }
07224 
07225   return scheme_true;
07226 }
07227 
07228 static Scheme_Object *datum_to_wraps(Scheme_Object *w,
07229                                      Scheme_Unmarshal_Tables *ut)
07230 {
07231   Scheme_Object *a, *wraps_key, *local_key;
07232   int stack_size, decoded;
07233   Wrap_Chunk *wc;
07234 
07235   /* ut->rns maps numbers (table indices) to renaming tables, and negative
07236      numbers (negated fixnum marks) and symbols (interned marks) to marks.*/
07237 
07238   /* This function has to be defensive, since `w' can originate in
07239      untrusted .zo bytecodes. Return NULL for bad wraps. */
07240 
07241   if (SCHEME_INTP(w)) {
07242     wraps_key = w;
07243     w = scheme_unmarshal_wrap_get(ut, wraps_key, &decoded);
07244     if (decoded && (!w || !SCHEME_LISTP(w))) /* list => a wrap, as opposed to a mark, etc. */
07245       return_NULL;
07246     if (decoded)
07247       return w;
07248   } else {
07249     /* not shared */
07250     wraps_key = NULL;
07251   }
07252 
07253   stack_size = scheme_proper_list_length(w);
07254   if (stack_size < 1) {
07255     scheme_unmarshal_wrap_set(ut, wraps_key, scheme_null);
07256     return scheme_null;
07257   } else if (stack_size < 2) {
07258     wc = NULL;
07259   } else {
07260     wc = MALLOC_WRAP_CHUNK(stack_size);
07261     wc->type = scheme_wrap_chunk_type;
07262     wc->len = stack_size;
07263   }
07264 
07265   a = NULL;
07266 
07267   while (!SCHEME_NULLP(w)) {
07268     a = SCHEME_CAR(w);
07269     if (SCHEME_NUMBERP(a)) {
07270       /* Re-use rename table or env rename */
07271       local_key = a;
07272       a = scheme_unmarshal_wrap_get(ut, local_key, &decoded);
07273       if (decoded && (!a || SCHEME_LISTP(a))) /* list => a whole wrap, no good as an element */
07274        return_NULL;
07275     } else  {
07276       /* Not shared */
07277       local_key = NULL;
07278       decoded = 0;
07279     }
07280 
07281     if (decoded) {
07282       /* done */
07283     } else if (SCHEME_PAIRP(a) 
07284               && SCHEME_NULLP(SCHEME_CDR(a))
07285               && SCHEME_NUMBERP(SCHEME_CAR(a))) {
07286       /* Mark */
07287       a = unmarshal_mark(SCHEME_CAR(a), ut);
07288       if (!a) return_NULL;
07289     } else if (SCHEME_VECTORP(a)) {
07290       /* A (simplified) rename table. */
07291       int sz = SCHEME_VEC_SIZE(a), cnt, i, any_free_id_renames = 0;
07292       Scheme_Object *v;
07293 
07294       /* Make sure that it's a well-formed rename table. */
07295       if (sz < 2)
07296        return_NULL;
07297       cnt = (sz - 2) >> 1;
07298       for (i = 0; i < cnt; i++) {
07299        if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(a)[i + 2]))
07300          return_NULL;
07301         v = SCHEME_VEC_ELS(a)[i + cnt + 2];
07302         if (SCHEME_SYMBOLP(v)) {
07303           /* simple target-environment symbol */
07304         } else if (SCHEME_PAIRP(v)) {
07305           /* target-environment symbol paired with free-id=? rename info */
07306           any_free_id_renames = 1;
07307           if (!SCHEME_SYMBOLP(SCHEME_CAR(v)))
07308             return_NULL;
07309           v = SCHEME_CDR(v);
07310           if (SCHEME_PAIRP(v)) {
07311             if (!SCHEME_SYMBOLP(SCHEME_CAR(v)))
07312               return_NULL;
07313             v = SCHEME_CDR(v);
07314             if (!SCHEME_SYMBOLP(v) && !SCHEME_FALSEP(v))
07315               return_NULL;
07316           } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_free_id_info_type)) {
07317             if (!SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[0])
07318                 || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[1])
07319                 || !SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[2])
07320                 || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[3])
07321                 || !ok_phase(SCHEME_VEC_ELS(v)[4])
07322                 || !ok_phase(SCHEME_VEC_ELS(v)[5])
07323                 || !ok_phase(SCHEME_VEC_ELS(v)[6]))
07324               return_NULL;
07325           } else
07326             return_NULL;
07327         } else
07328           return_NULL;
07329       }
07330 
07331       SCHEME_VEC_ELS(a)[0] = (any_free_id_renames ? scheme_true : scheme_false);
07332       
07333       if (!SCHEME_FALSEP(SCHEME_VEC_ELS(a)[1])) {
07334         SCHEME_VEC_ELS(a)[1] = scheme_false;
07335         maybe_install_rename_hash_table(a);
07336       }
07337 
07338       /* It's ok: */
07339       scheme_unmarshal_wrap_set(ut, local_key, a);
07340     } else if (SCHEME_PAIRP(a)) {
07341       /* A rename table:
07342            - ([#t] <phase-num> <kind-num> <set-identity> [unmarshal] #(<table-elem> ...)
07343               . ((<sym> (<marked-list-or-mark> . <target-gensym>) ...) ...)) ; <- marked_names
07344        where a <table-elem> is actually two values, one of:
07345            - <exname> <modname>
07346            - <exname> (<modname> . <defname>)
07347       */
07348       Scheme_Object *mns;
07349       Module_Renames *mrn;
07350       Scheme_Object *p, *key;
07351       int kind;
07352       Scheme_Object *phase, *set_identity;
07353       
07354       if (!SCHEME_PAIRP(a)) return_NULL;
07355       
07356       /* Convert list to rename table: */
07357       
07358       if (SAME_OBJ(SCHEME_CAR(a), scheme_true)) {
07359         scheme_signal_error("leftover plus-kernel");
07360       }
07361 
07362       if (!SCHEME_PAIRP(a)) return_NULL;
07363       phase = SCHEME_CAR(a);
07364       if (!ok_phase(phase)) return_NULL;
07365       a = SCHEME_CDR(a);
07366 
07367       if (!SCHEME_PAIRP(a)) return_NULL;
07368       if (SCHEME_TRUEP(SCHEME_CAR(a)))
07369        kind = mzMOD_RENAME_MARKED;
07370       else
07371        kind = mzMOD_RENAME_NORMAL;
07372       a = SCHEME_CDR(a);
07373 
07374       if (!SCHEME_PAIRP(a)) return_NULL;
07375       set_identity = unmarshal_mark(SCHEME_CAR(a), ut); 
07376       if (!set_identity) return_NULL;
07377       a = SCHEME_CDR(a);
07378 
07379       mrn = (Module_Renames *)scheme_make_module_rename(phase, kind, NULL);
07380       mrn->set_identity = set_identity;
07381 
07382       if (!SCHEME_PAIRP(a)) return_NULL;
07383       mns = SCHEME_CDR(a);
07384       a = SCHEME_CAR(a);
07385 
07386       if (!SCHEME_VECTORP(a)) {
07387        /* Unmarshall info: */
07388        Scheme_Object *ml = a, *mli, *first = scheme_null, *last = NULL, *ai;
07389        while (SCHEME_PAIRP(ml)) {
07390           ai = SCHEME_CAR(ml);
07391          mli = ai;
07392          if (!SCHEME_PAIRP(mli)) return_NULL;
07393 
07394          /* A module path index: */
07395          p = SCHEME_CAR(mli);
07396          if (!(SCHEME_SYMBOLP(p)
07397               || SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)))
07398            return_NULL;
07399          mli = SCHEME_CDR(mli);
07400 
07401           if (!SCHEME_PAIRP(mli)) return_NULL;
07402 
07403           /* A phase/dimension index k */
07404           p = SCHEME_CAR(mli);
07405           if (!ok_phase_index(p))
07406             return_NULL;
07407           
07408           p = SCHEME_CDR(mli);
07409           if (SCHEME_PAIRP(p) && SCHEME_PAIRP(SCHEME_CAR(p))) {
07410             /* list of marks: */
07411             Scheme_Object *m_first = scheme_null, *m_last = NULL, *mp, *after_marks;
07412 
07413             after_marks = SCHEME_CDR(p);
07414             mli = SCHEME_CAR(p);
07415 
07416             while (SCHEME_PAIRP(mli)) {
07417               p = SCHEME_CAR(mli);
07418               p = unmarshal_mark(p, ut); 
07419               if (!p) return_NULL;
07420 
07421               mp = scheme_make_pair(p, scheme_null);
07422               if (m_last)
07423                 SCHEME_CDR(m_last) = mp;
07424               else
07425                 m_first = mp;
07426               m_last = mp;
07427 
07428               mli = SCHEME_CDR(mli);
07429             }
07430 
07431             /* Rebuild for unmarshaled marks: */
07432             ai = scheme_make_pair(SCHEME_CAR(ai),
07433                                   scheme_make_pair(SCHEME_CADR(ai),
07434                                                    scheme_make_pair(m_first, after_marks)));
07435 
07436             if (!SCHEME_NULLP(mli)) return_NULL;
07437             p = after_marks;
07438           }
07439 
07440           if (ok_phase_index(p)) {
07441             /* For a shared table: src-phase-index */
07442           } else {
07443             /* For a non-shared table: (list* src-phase-index exceptions prefix), after k */
07444             mli = p;
07445             if (!SCHEME_PAIRP(mli)) return_NULL;
07446 
07447             p = SCHEME_CAR(mli);
07448             if (!ok_phase_index(p))
07449               return_NULL;
07450             mli = SCHEME_CDR(mli);
07451 
07452             if (!SCHEME_PAIRP(mli)) return_NULL;
07453 
07454             /* A list of symbols: */
07455             p = SCHEME_CAR(mli);
07456             while (SCHEME_PAIRP(p)) {
07457               if (!SCHEME_SYMBOLP(SCHEME_CAR(p))) return_NULL;
07458               p = SCHEME_CDR(p);
07459             }
07460             if (!SCHEME_NULLP(p)) return_NULL;
07461 
07462             /* #f or a symbol: */
07463             p = SCHEME_CDR(mli);
07464             if (!SCHEME_SYMBOLP(p) && !SCHEME_FALSEP(p)) return_NULL;
07465           }
07466 
07467          ml = SCHEME_CDR(ml);
07468 
07469           /* rebuild, in case we converted marks */
07470           p = scheme_make_pair(ai, scheme_null);
07471           if (last)
07472             SCHEME_CDR(last) = p;
07473           else
07474             first = p;
07475           last = p;
07476        }
07477        if (!SCHEME_NULLP(ml)) return_NULL;
07478 
07479        mrn->unmarshal_info = first;
07480        if (SCHEME_PAIRP(first))
07481          mrn->needs_unmarshal = 1;
07482 
07483        if (!SCHEME_PAIRP(mns)) return_NULL;
07484        a = SCHEME_CAR(mns);
07485        mns = SCHEME_CDR(mns);
07486       }
07487 
07488       if (!datum_to_module_renames(a, mrn->ht, 0))
07489         return_NULL;
07490 
07491       /* Extract free-id=? renames, if any */
07492       if (SCHEME_PAIRP(mns) && SCHEME_VECTORP(SCHEME_CAR(mns))) {
07493         Scheme_Hash_Table *ht;
07494         ht = scheme_make_hash_table(SCHEME_hash_ptr);
07495         mrn->free_id_renames = ht;
07496         if (!datum_to_module_renames(SCHEME_CAR(mns), mrn->free_id_renames, 1))
07497           return_NULL;
07498         mns = SCHEME_CDR(mns);
07499       }
07500 
07501       /* Extract the mark-rename table, if any: */
07502       if (SCHEME_PAIRP(mns)) {
07503        Scheme_Hash_Table *ht;
07504        Scheme_Object *ll, *kkey, *kfirst, *klast, *kp;
07505 
07506        ht = scheme_make_hash_table(SCHEME_hash_ptr);
07507        for (; SCHEME_PAIRP(mns); mns = SCHEME_CDR(mns)) {
07508          p = SCHEME_CAR(mns);
07509          if (!SCHEME_PAIRP(p)) return_NULL;
07510          key = SCHEME_CAR(p);
07511          p = SCHEME_CDR(p);
07512          if (!SCHEME_SYMBOLP(key)) return_NULL;
07513          
07514          ll = scheme_null;
07515 
07516          /* Convert marks */
07517          for (; SCHEME_PAIRP(p); p = SCHEME_CDR(p)) {
07518            a = SCHEME_CAR(p);
07519            if (!SCHEME_PAIRP(a))  return_NULL;
07520            kkey = SCHEME_CDR(a);
07521            if (!SCHEME_SYMBOLP(kkey)) return_NULL;
07522 
07523            kfirst = scheme_null;
07524            klast = NULL;
07525            a = SCHEME_CAR(a);
07526            if (SCHEME_MARKP(a)) {
07527              kfirst = unmarshal_mark(a, ut);
07528            } else {
07529               Scheme_Object *bdg = NULL;
07530 
07531               if (SCHEME_VECTORP(a)) {
07532                 if (SCHEME_VEC_SIZE(a) != 2) return_NULL;
07533                 bdg = SCHEME_VEC_ELS(a)[1];
07534                 if (!SCHEME_SYMBOLP(bdg)) return_NULL;
07535                 a = SCHEME_VEC_ELS(a)[0];
07536               }
07537 
07538              for (; SCHEME_PAIRP(a); a = SCHEME_CDR(a)) {
07539               kp = CONS(unmarshal_mark(SCHEME_CAR(a), ut), scheme_null);
07540               if (!klast)
07541                 kfirst = kp;
07542               else
07543                 SCHEME_CDR(klast) = kp;
07544               klast = kp;
07545              }
07546              if (!SCHEME_NULLP(a)) {
07547                 if (bdg && SCHEME_MARKP(a) && SCHEME_NULLP(kfirst))
07548                   kfirst = unmarshal_mark(a, ut);
07549                 else
07550                   return_NULL;
07551               }
07552 
07553               if (bdg) {
07554                 a = scheme_make_vector(2, NULL);
07555                 SCHEME_VEC_ELS(a)[0] = kfirst;
07556                 SCHEME_VEC_ELS(a)[1] = bdg;
07557                 kfirst = a;
07558               }
07559            }
07560 
07561            ll = CONS(CONS(kfirst, kkey), ll);
07562          }
07563          
07564          scheme_hash_set(ht, key, ll);
07565 
07566          if (!SCHEME_NULLP(p)) return_NULL;
07567        }
07568        if (!SCHEME_NULLP(mns)) return_NULL;
07569 
07570        mrn->marked_names = ht;
07571       }
07572 
07573       scheme_unmarshal_wrap_set(ut, local_key, (Scheme_Object *)mrn);
07574 
07575       scheme_seal_module_rename((Scheme_Object *)mrn, STX_SEAL_ALL);
07576 
07577       a = (Scheme_Object *)mrn;
07578     } else if (SAME_OBJ(a, scheme_true)
07579                || SCHEME_FALSEP(a)) {
07580       /* current env rename */
07581       Scheme_Env *env;
07582 
07583       env = scheme_get_env(NULL);
07584       scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL);
07585       a = scheme_get_module_rename_from_set(env->rename_set, 
07586                                             (SCHEME_FALSEP(a) 
07587                                              ? scheme_make_integer(1) 
07588                                              : scheme_make_integer(0)), 
07589                                             1);
07590     } else if (SCHEME_SYMBOLP(a)) {
07591       /* mark barrier */
07592     } else if (SCHEME_BOXP(a)) {
07593       if (SCHEME_PAIRP(SCHEME_BOX_VAL(a))) {
07594         /* prune context */
07595         a = make_prune_context(SCHEME_BOX_VAL(a));
07596       } else {
07597         /* must be a phase shift */
07598         Scheme_Object *vec;
07599         vec = SCHEME_BOX_VAL(a);
07600         if (!SCHEME_VECTORP(vec)) return_NULL;
07601         if (SCHEME_VEC_SIZE(vec) != 4) return_NULL;
07602       }
07603     } else {
07604       return_NULL;
07605     }
07606 
07607     if (wc)
07608       wc->a[--stack_size] = a;
07609 
07610     w = SCHEME_CDR(w);
07611   }
07612 
07613   if (wc)
07614     a = (Scheme_Object *)wc;
07615   a = CONS(a, scheme_null);
07616 
07617   scheme_unmarshal_wrap_set(ut, wraps_key, a);
07618 
07619   return a;
07620 }
07621 
07622 /*========================================================================*/
07623 /*                           datum->syntax                                */
07624 /*========================================================================*/
07625 
07626 
07627 #ifdef DO_STACK_CHECK
07628 static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, 
07629                                        Scheme_Unmarshal_Tables *ut,
07630                                        Scheme_Stx *stx_src,
07631                                        Scheme_Stx *stx_wraps,
07632                                             Scheme_Hash_Table *ht);
07633 
07634 Scheme_Object *cert_marks_to_certs(Scheme_Object *cert_marks, 
07635                                    Scheme_Unmarshal_Tables *ut,
07636                                    Scheme_Stx *stx_wraps, int *bad)
07637 {
07638   /* Need to convert a list of marks to certs */
07639   Scheme_Cert *certs = NULL;
07640   Scheme_Object *a, *b, *insp, *orig = cert_marks;
07641 
07642   if (SCHEME_NUMBERP(cert_marks)) {
07643     /* Re-use rename table or env rename */
07644     int decoded;
07645     a = scheme_unmarshal_wrap_get(ut, cert_marks, &decoded);
07646     if (decoded && !a)
07647       return_NULL;
07648     if (decoded)
07649       return a;
07650     cert_marks = a;
07651   }
07652 
07653   insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
07654 
07655   while (SCHEME_PAIRP(cert_marks)) {
07656     a = SCHEME_CAR(cert_marks);
07657     if (!SCHEME_NUMBERP(a)) {
07658       *bad = 1;
07659       return_NULL;
07660     }
07661     a = unmarshal_mark(a, ut);
07662     if (!a) { *bad = 1; return_NULL; }
07663     
07664     cert_marks = SCHEME_CDR(cert_marks);
07665     if (!SCHEME_PAIRP(cert_marks)) {
07666       *bad = 1;
07667       return_NULL;
07668     }
07669     b = SCHEME_CAR(cert_marks);
07670     if (!SCHEME_SYMBOLP(b)
07671        && !SAME_TYPE(SCHEME_TYPE(b), scheme_module_index_type)) {
07672       *bad = 1;
07673       return_NULL;
07674     }
07675     
07676     if (!cert_in_chain(a, NULL, certs))
07677       certs = cons_cert(a, b, insp, NULL, certs);
07678     
07679     cert_marks = SCHEME_CDR(cert_marks);
07680   }
07681   if (!SCHEME_NULLP(cert_marks)) {
07682     *bad = 1;
07683     return_NULL;
07684   }
07685 
07686   if (SCHEME_NUMBERP(orig)) {
07687     scheme_unmarshal_wrap_set(ut, orig, (Scheme_Object *)certs);
07688   }
07689 
07690   return (Scheme_Object *)certs;
07691 }
07692 
07693 static Scheme_Object *datum_to_syntax_k(void)
07694 {
07695   Scheme_Thread *p = scheme_current_thread;
07696   Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
07697   Scheme_Stx *stx_src = (Scheme_Stx *)p->ku.k.p2;
07698   Scheme_Stx *stx_wraps = (Scheme_Stx *)p->ku.k.p3;
07699   Scheme_Hash_Table *ht = (Scheme_Hash_Table *)p->ku.k.p4;
07700   Scheme_Unmarshal_Tables *ut = (Scheme_Unmarshal_Tables *)p->ku.k.p5;
07701                                        
07702   p->ku.k.p1 = NULL;
07703   p->ku.k.p2 = NULL;
07704   p->ku.k.p3 = NULL;
07705   p->ku.k.p4 = NULL;
07706   p->ku.k.p5 = NULL;
07707 
07708   return datum_to_syntax_inner(o, ut, stx_src, stx_wraps, ht);
07709 }
07710 #endif
07711 
07712 static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, 
07713                                             Scheme_Unmarshal_Tables *ut,
07714                                        Scheme_Stx *stx_src,
07715                                        Scheme_Stx *stx_wraps, /* or rename table, or boxed precomputed wrap */
07716                                        Scheme_Hash_Table *ht)
07717 {
07718   Scheme_Object *result, *wraps, *cert_marks = NULL, *hashed;
07719   int do_not_unpack_wraps = 0;
07720 
07721   if (SCHEME_STXP(o))
07722     return o;
07723 
07724 #ifdef DO_STACK_CHECK
07725   {
07726 # include "mzstkchk.h"
07727     {
07728       Scheme_Thread *p = scheme_current_thread;
07729       p->ku.k.p1 = (void *)o;
07730       p->ku.k.p2 = (void *)stx_src;
07731       p->ku.k.p3 = (void *)stx_wraps;
07732       p->ku.k.p4 = (void *)ht;
07733       p->ku.k.p5 = (void *)ut;
07734       return scheme_handle_stack_overflow(datum_to_syntax_k);
07735     }
07736   }
07737 #endif
07738 
07739   SCHEME_USE_FUEL(1);
07740 
07741   if (ht) {
07742     if (HAS_SUBSTX(o)) {
07743       if (scheme_hash_get(ht, o)) {
07744         /* Graphs disallowed */
07745         return_NULL;
07746       }
07747 
07748       scheme_hash_set(ht, o, scheme_true);
07749       hashed = o;
07750     } else 
07751       hashed = NULL;
07752   } else
07753     hashed = NULL;
07754 
07755   if (ut && !SCHEME_BOXP(stx_wraps)) {
07756     if (SCHEME_VECTORP(o)) {
07757       /* This one has certs */
07758       if (SCHEME_VEC_SIZE(o) == 2) {
07759        cert_marks = SCHEME_VEC_ELS(o)[1];
07760        o = SCHEME_VEC_ELS(o)[0];
07761       } else
07762        return_NULL;
07763     }
07764     if (!SCHEME_PAIRP(o)) 
07765       return_NULL;
07766     wraps = SCHEME_CDR(o);
07767     o = SCHEME_CAR(o);
07768   } else if (SCHEME_BOXP(stx_wraps)) {
07769     /* Shared wraps, to be used directly everywhere: */
07770     wraps = SCHEME_BOX_VAL(stx_wraps);
07771     do_not_unpack_wraps = 1;
07772   } else
07773     wraps = NULL;
07774 
07775   if (SCHEME_PAIRP(o)) {
07776     Scheme_Object *first = NULL, *last = NULL, *p;
07777     
07778     /* Check whether it's all conses with
07779        syntax inside */
07780     p = o;
07781     while (SCHEME_PAIRP(p)) {
07782       if (!SCHEME_STXP(SCHEME_CAR(p)))
07783        break;
07784       p = SCHEME_CDR(p);
07785     }
07786     if (SCHEME_NULLP(p) || SCHEME_STXP(p)) {
07787       result = o;
07788     } else {
07789       int cnt = -1;
07790       Scheme_Stx *sub_stx_wraps = stx_wraps;
07791 
07792       if (wraps && !SCHEME_BOXP(stx_wraps) && SAME_OBJ(SCHEME_CAR(o), scheme_true)) {
07793         /* Resolve wraps now, and then share it with
07794            all nested objects (as indicated by a box
07795            for stx_wraps). */
07796         wraps = datum_to_wraps(wraps, ut);
07797         do_not_unpack_wraps = 1;
07798         sub_stx_wraps = (Scheme_Stx *)scheme_box(wraps);
07799         o = SCHEME_CDR(o);
07800       } else if (wraps && !SCHEME_BOXP(stx_wraps) && SCHEME_INTP(SCHEME_CAR(o))) {
07801        /* First element is the number of items
07802           before a non-null terminal: */
07803        cnt = SCHEME_INT_VAL(SCHEME_CAR(o));
07804        o = SCHEME_CDR(o);
07805       }
07806 
07807       /* Build up a new list while converting elems */
07808       while (SCHEME_PAIRP(o) && cnt) {
07809        Scheme_Object *a;
07810       
07811        if (ht && last) {
07812          if (scheme_hash_get(ht, o)) {
07813             /* cdr is shared. Stop here and let someone else complain. */
07814             break;
07815          }
07816        }
07817 
07818        a = datum_to_syntax_inner(SCHEME_CAR(o), ut, stx_src, sub_stx_wraps, ht);
07819        if (!a) return_NULL;
07820       
07821        p = scheme_make_pair(a, scheme_null);
07822       
07823        if (last)
07824          SCHEME_CDR(last) = p;
07825        else
07826          first = p;
07827        last = p;
07828        o = SCHEME_CDR(o);
07829 
07830        --cnt;
07831       }
07832       if (!SCHEME_NULLP(o)) {
07833        o = datum_to_syntax_inner(o, ut, stx_src, sub_stx_wraps, ht);
07834        if (!o) return_NULL;
07835        SCHEME_CDR(last) = o;
07836       }
07837 
07838       result = first;
07839     }
07840   } else if (SCHEME_BOXP(o)) {
07841     o = datum_to_syntax_inner(SCHEME_PTR_VAL(o), ut, stx_src, stx_wraps, ht);
07842     if (!o) return_NULL;
07843     result = scheme_box(o);
07844     SCHEME_SET_BOX_IMMUTABLE(result);
07845   } else if (SCHEME_VECTORP(o)) {
07846     int size = SCHEME_VEC_SIZE(o), i;
07847     Scheme_Object *a;
07848 
07849     result = scheme_make_vector(size, NULL);
07850     
07851     for (i = 0; i < size; i++) {
07852       a = datum_to_syntax_inner(SCHEME_VEC_ELS(o)[i], ut, stx_src, stx_wraps, ht);
07853       if (!a) return_NULL;
07854       SCHEME_VEC_ELS(result)[i] = a;
07855     }
07856 
07857     SCHEME_SET_VECTOR_IMMUTABLE(result);
07858   } else if (SCHEME_HASHTRP(o)) {
07859