Back to index

plt-scheme  4.2.1
module.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 /* This file implements the first-order, top-level module system. An
00023    initiantiated module is implemented essentially as a namespace. The
00024    bindings at the top level of a module are namespace top-level
00025    bindings. */
00026 
00027 #include "schpriv.h"
00028 #include "mzrt.h"
00029 #include "schmach.h"
00030 #include "schexpobs.h"
00031 
00032 /* globals */
00033 Scheme_Object *scheme_sys_wraps0;
00034 Scheme_Object *scheme_sys_wraps1;
00035 Scheme_Object *(*scheme_module_demand_hook)(int, Scheme_Object **);
00036 
00037 #ifdef MZ_USE_PLACES
00038 mzrt_mutex *modpath_table_mutex;
00039 #else
00040 # define mzrt_mutex_lock(l) /* empty */
00041 # define mzrt_mutex_unlock(l) /* empty */
00042 #endif
00043 
00044 /* locals */
00045 static Scheme_Object *current_module_name_resolver(int argc, Scheme_Object *argv[]);
00046 static Scheme_Object *current_module_name_prefix(int argc, Scheme_Object *argv[]);
00047 static Scheme_Object *dynamic_require_for_syntax(int argc, Scheme_Object *argv[]);
00048 static Scheme_Object *namespace_require(int argc, Scheme_Object *argv[]);
00049 static Scheme_Object *namespace_require_copy(int argc, Scheme_Object *argv[]);
00050 static Scheme_Object *namespace_require_constant(int argc, Scheme_Object *argv[]);
00051 static Scheme_Object *namespace_require_etonly(int argc, Scheme_Object *argv[]);
00052 static Scheme_Object *namespace_attach_module(int argc, Scheme_Object *argv[]);
00053 static Scheme_Object *namespace_unprotect_module(int argc, Scheme_Object *argv[]);
00054 static Scheme_Object *module_compiled_p(int argc, Scheme_Object *argv[]);
00055 static Scheme_Object *module_compiled_name(int argc, Scheme_Object *argv[]);
00056 static Scheme_Object *module_compiled_imports(int argc, Scheme_Object *argv[]);
00057 static Scheme_Object *module_compiled_exports(int argc, Scheme_Object *argv[]);
00058 static Scheme_Object *module_compiled_lang_info(int argc, Scheme_Object *argv[]);
00059 static Scheme_Object *module_to_namespace(int argc, Scheme_Object *argv[]);
00060 static Scheme_Object *module_to_lang_info(int argc, Scheme_Object *argv[]);
00061 
00062 static Scheme_Object *module_path_index_p(int argc, Scheme_Object *argv[]);
00063 static Scheme_Object *module_path_index_resolve(int argc, Scheme_Object *argv[]);
00064 static Scheme_Object *module_path_index_split(int argc, Scheme_Object *argv[]);
00065 static Scheme_Object *module_path_index_join(int argc, Scheme_Object *argv[]);
00066 
00067 static Scheme_Object *is_module_path(int argc, Scheme_Object **argv);
00068 
00069 static Scheme_Object *resolved_module_path_p(int argc, Scheme_Object *argv[]);
00070 static Scheme_Object *make_resolved_module_path(int argc, Scheme_Object *argv[]);
00071 static Scheme_Object *resolved_module_path_name(int argc, Scheme_Object *argv[]);
00072 
00073 static Scheme_Object *module_export_protected_p(int argc, Scheme_Object **argv);
00074 
00075 /* syntax */
00076 static Scheme_Object *module_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00077 static Scheme_Object *module_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00078 static Scheme_Object *module_begin_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00079 static Scheme_Object *module_begin_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00080 static Scheme_Object *require_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00081 static Scheme_Object *require_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00082 static Scheme_Object *provide_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec);
00083 static Scheme_Object *provide_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec);
00084 
00085 static Scheme_Object *module_execute(Scheme_Object *data);
00086 static Scheme_Object *top_level_require_execute(Scheme_Object *data);
00087 
00088 static Scheme_Object *module_jit(Scheme_Object *data);
00089 static Scheme_Object *top_level_require_jit(Scheme_Object *data);
00090 
00091 static Scheme_Object *module_optimize(Scheme_Object *data, Optimize_Info *info);
00092 static Scheme_Object *module_resolve(Scheme_Object *data, Resolve_Info *info);
00093 static Scheme_Object *module_sfs(Scheme_Object *data, SFS_Info *info);
00094 static Scheme_Object *top_level_require_optimize(Scheme_Object *data, Optimize_Info *info);
00095 static Scheme_Object *top_level_require_resolve(Scheme_Object *data, Resolve_Info *info);
00096 static Scheme_Object *top_level_require_sfs(Scheme_Object *data, SFS_Info *info);
00097 
00098 static void module_validate(Scheme_Object *data, Mz_CPort *port, 
00099                             char *stack, Validate_TLS tls,
00100                             int depth, int letlimit, int delta, 
00101                          int num_toplevels, int num_stxes, int num_lifts,
00102                             struct Validate_Clearing *vc, int tailpos);
00103 static void top_level_require_validate(Scheme_Object *data, Mz_CPort *port, 
00104                                        char *stack, Validate_TLS tls,
00105                                        int depth, int letlimit, int delta, 
00106                                    int num_toplevels, int num_stxes, int num_lifts,
00107                                        struct Validate_Clearing *vc, int tailpos);
00108 
00109 static Scheme_Object *write_module(Scheme_Object *obj);
00110 static Scheme_Object *read_module(Scheme_Object *obj);
00111 
00112 static Scheme_Module *module_load(Scheme_Object *modname, Scheme_Env *env, const char *who);
00113 
00114 static void run_module(Scheme_Env *menv, int set_ns);
00115 static void run_module_exptime(Scheme_Env *menv, int set_ns);
00116 
00117 static void eval_exptime(Scheme_Object *names, int count,
00118                          Scheme_Object *expr, 
00119                          Scheme_Env *genv, Scheme_Comp_Env *env,
00120                          Resolve_Prefix *rp, int let_depth, int shift,
00121                          Scheme_Bucket_Table *syntax, int for_stx,
00122                          Scheme_Object *certs,
00123                          Scheme_Object *free_id_rename_rn);
00124 
00125 static Scheme_Module_Exports *make_module_exports();
00126 
00127 #define cons scheme_make_pair
00128 
00129 
00130 /* global read-only kernel stuff */
00131 static Scheme_Object *kernel_modname;
00132 static Scheme_Object *kernel_symbol;
00133 static Scheme_Object *kernel_modidx;
00134 static Scheme_Module *kernel;
00135 
00136 /* global read-only symbols */
00137 static Scheme_Object *module_symbol;
00138 static Scheme_Object *module_begin_symbol;
00139 static Scheme_Object *prefix_symbol;
00140 static Scheme_Object *only_symbol;
00141 static Scheme_Object *rename_symbol;
00142 static Scheme_Object *all_except_symbol;
00143 static Scheme_Object *prefix_all_except_symbol;
00144 static Scheme_Object *all_from_symbol;
00145 static Scheme_Object *all_from_except_symbol;
00146 static Scheme_Object *all_defined_symbol;
00147 static Scheme_Object *all_defined_except_symbol;
00148 static Scheme_Object *prefix_all_defined_symbol;
00149 static Scheme_Object *prefix_all_defined_except_symbol;
00150 static Scheme_Object *struct_symbol;
00151 static Scheme_Object *protect_symbol;
00152 static Scheme_Object *expand_symbol;
00153 static Scheme_Object *for_syntax_symbol;
00154 static Scheme_Object *for_template_symbol;
00155 static Scheme_Object *for_label_symbol;
00156 static Scheme_Object *for_meta_symbol;
00157 static Scheme_Object *just_meta_symbol;
00158 static Scheme_Object *quote_symbol;
00159 static Scheme_Object *lib_symbol;
00160 static Scheme_Object *planet_symbol;
00161 static Scheme_Object *file_symbol;
00162 static Scheme_Object *module_name_symbol;
00163 static Scheme_Object *nominal_id_symbol;
00164 
00165 /* global read-only syntax */
00166 Scheme_Object *scheme_module_stx;
00167 Scheme_Object *scheme_begin_stx;
00168 Scheme_Object *scheme_define_values_stx;
00169 Scheme_Object *scheme_define_syntaxes_stx;
00170 Scheme_Object *scheme_top_stx;
00171 static Scheme_Object *modbeg_syntax;
00172 static Scheme_Object *define_for_syntaxes_stx;
00173 static Scheme_Object *require_stx;
00174 static Scheme_Object *provide_stx;
00175 static Scheme_Object *set_stx;
00176 static Scheme_Object *app_stx;
00177 static Scheme_Object *lambda_stx;
00178 static Scheme_Object *case_lambda_stx;
00179 static Scheme_Object *let_values_stx;
00180 static Scheme_Object *letrec_values_stx;
00181 static Scheme_Object *if_stx;
00182 static Scheme_Object *begin0_stx;
00183 static Scheme_Object *set_stx;
00184 static Scheme_Object *with_continuation_mark_stx;
00185 static Scheme_Object *letrec_syntaxes_stx;
00186 static Scheme_Object *var_ref_stx;
00187 static Scheme_Object *expression_stx;
00188 
00189 static Scheme_Env *initial_modules_env;
00190 static int num_initial_modules;
00191 static Scheme_Object **initial_modules;
00192 static Scheme_Object *initial_renames;
00193 static Scheme_Bucket_Table *initial_toplevel;
00194 
00195 static Scheme_Object *empty_self_modidx;
00196 static Scheme_Object *empty_self_modname;
00197 
00198 static THREAD_LOCAL Scheme_Bucket_Table *starts_table;
00199 
00200 /* caches */
00201 static THREAD_LOCAL Scheme_Modidx *modidx_caching_chain;
00202 static THREAD_LOCAL Scheme_Object *global_shift_cache;
00203 #define GLOBAL_SHIFT_CACHE_SIZE 40
00204 #ifdef USE_SENORA_GC
00205 # define SHIFT_CACHE_NULL scheme_false
00206 # define SHIFT_CACHE_NULLP(x) SCHEME_FALSEP(x)
00207 #else
00208 # define SHIFT_CACHE_NULL NULL
00209 # define SHIFT_CACHE_NULLP(x) !(x)
00210 #endif
00211 
00212 static Scheme_Bucket_Table *modpath_table;
00213 #define SCHEME_MODNAMEP(obj)  SAME_TYPE(SCHEME_TYPE(obj), scheme_resolved_module_path_type)
00214 
00215 typedef void (*Check_Func)(Scheme_Object *prnt_name, Scheme_Object *name, 
00216                            Scheme_Object *nominal_modname, Scheme_Object *nominal_export,
00217                         Scheme_Object *modname, Scheme_Object *srcname, int exet,
00218                         int isval, void *data, Scheme_Object *e, Scheme_Object *form, 
00219                            Scheme_Object *err_src, Scheme_Object *mark_src,
00220                            Scheme_Object *to_phase, Scheme_Object *src_phase_index,
00221                            Scheme_Object *nominal_export_phase, Scheme_Object *in_insp);
00222 static void parse_requires(Scheme_Object *form,
00223                            Scheme_Object *base_modidx,
00224                            Scheme_Env *env,
00225                            Scheme_Module *for_m,
00226                            Scheme_Object *rns, Scheme_Object *post_ex_rns,
00227                            Check_Func ck, void *data,
00228                            Scheme_Object *redef_modname,
00229                            int unpack_kern, int copy_vars, int can_save_marshal, 
00230                            int eval_exp, int eval_run,
00231                            int *all_simple);
00232 static void parse_provides(Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e,
00233                            Scheme_Hash_Table *all_provided,
00234                            Scheme_Hash_Table *all_reprovided,
00235                            Scheme_Object *self_modidx,
00236                            Scheme_Object **_all_defs_out, 
00237                            Scheme_Object **_et_all_defs_out, 
00238                            Scheme_Hash_Table *tables,
00239                            Scheme_Object *all_defs, Scheme_Object *all_et_defs,
00240                            Scheme_Comp_Env *cenv, Scheme_Compile_Info *rec, int drec,
00241                            Scheme_Object **_expanded);
00242 static int compute_reprovides(Scheme_Hash_Table *all_provided,
00243                               Scheme_Hash_Table *all_reprovided, 
00244                               Scheme_Module *mod_for_requires,
00245                               Scheme_Hash_Table *tables,
00246                               Scheme_Env *genv, 
00247                               Scheme_Object *all_rt_defs, Scheme_Object *all_rt_defs_out, 
00248                               Scheme_Object *all_et_defs, Scheme_Object *all_et_defs_out, 
00249                               const char *matching_form,
00250                               Scheme_Object *all_mods, Scheme_Object *all_phases);
00251 static char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables,
00252                                     Scheme_Module_Exports *me,
00253                                     Scheme_Env *genv,
00254                                     Scheme_Object *form,
00255                                     char **_phase1_protects);
00256 static Scheme_Object **compute_indirects(Scheme_Env *genv, 
00257                                          Scheme_Module_Phase_Exports *pt,
00258                                          int *_count,
00259                                          int vars);
00260 static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx, 
00261                          int eval_exp, int eval_run, long base_phase, Scheme_Object *cycle_list);
00262 static void eval_module_body(Scheme_Env *menv, Scheme_Env *env);
00263 
00264 static Scheme_Object *do_namespace_require(Scheme_Env *env, int argc, Scheme_Object *argv[], 
00265                                            int copy, int etonly);
00266 
00267 static Scheme_Object *default_module_resolver(int argc, Scheme_Object **argv);
00268 
00269 static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, char *exps, char *exets,
00270                            Scheme_Object **exsnoms, Scheme_Object **exinsps,
00271                         int start, int count, int do_uninterned);
00272 
00273 #define MODCHAIN_TABLE(p) ((Scheme_Hash_Table *)(SCHEME_VEC_ELS(p)[0]))
00274 #define MODCHAIN_AVAIL(p, n) (SCHEME_VEC_ELS(p)[3+n])
00275 
00276 /**********************************************************************/
00277 /*                           initialization                           */
00278 /**********************************************************************/
00279 
00280 void scheme_init_module(Scheme_Env *env)
00281 {
00282   scheme_register_syntax(MODULE_EXPD, 
00283                       module_optimize,
00284                       module_resolve, module_sfs, module_validate, 
00285                       module_execute, module_jit, 
00286                       NULL, NULL, -1);
00287   scheme_register_syntax(REQUIRE_EXPD, 
00288                       top_level_require_optimize,
00289                       top_level_require_resolve, top_level_require_sfs, top_level_require_validate, 
00290                       top_level_require_execute, top_level_require_jit, 
00291                       NULL, NULL, 2);
00292 
00293   scheme_add_global_keyword("module", 
00294                          scheme_make_compiled_syntax(module_syntax, 
00295                                                  module_expand),
00296                          env);
00297 
00298   REGISTER_SO(modbeg_syntax);
00299   modbeg_syntax = scheme_make_compiled_syntax(module_begin_syntax, 
00300                                          module_begin_expand);
00301 
00302   scheme_add_global_keyword("#%module-begin", 
00303                          modbeg_syntax,
00304                          env);
00305 
00306   scheme_add_global_keyword("#%require", 
00307                          scheme_make_compiled_syntax(require_syntax, 
00308                                                  require_expand), 
00309                          env);
00310   scheme_add_global_keyword("#%provide", 
00311                          scheme_make_compiled_syntax(provide_syntax, 
00312                                                  provide_expand), 
00313                          env);
00314 
00315 #ifdef MZ_USE_PLACES
00316   mzrt_mutex_create(&modpath_table_mutex);
00317 #endif
00318 
00319   REGISTER_SO(quote_symbol);
00320   REGISTER_SO(file_symbol);
00321   REGISTER_SO(lib_symbol);
00322   REGISTER_SO(planet_symbol);
00323   quote_symbol = scheme_intern_symbol("quote");
00324   file_symbol = scheme_intern_symbol("file");
00325   lib_symbol = scheme_intern_symbol("lib");
00326   planet_symbol = scheme_intern_symbol("planet");
00327 
00328   REGISTER_SO(kernel_symbol);
00329   REGISTER_SO(kernel_modname);
00330   REGISTER_SO(kernel_modidx);
00331   kernel_symbol = scheme_intern_symbol("#%kernel");
00332   kernel_modname = scheme_intern_resolved_module_path(kernel_symbol);
00333   kernel_modidx = scheme_make_modidx(scheme_make_pair(quote_symbol,
00334                                                       scheme_make_pair(kernel_symbol, 
00335                                                                        scheme_null)),
00336                                      scheme_false, kernel_modname);
00337 
00338   REGISTER_SO(module_symbol);
00339   REGISTER_SO(module_begin_symbol);
00340   module_symbol = scheme_intern_symbol("module");
00341   module_begin_symbol = scheme_intern_symbol("#%module-begin");
00342 
00343   scheme_install_type_writer(scheme_module_type, write_module);
00344   scheme_install_type_reader(scheme_module_type, read_module);
00345 
00346   GLOBAL_PARAMETER("current-module-name-resolver",  current_module_name_resolver, MZCONFIG_CURRENT_MODULE_RESOLVER, env);
00347   GLOBAL_PARAMETER("current-module-declare-name",   current_module_name_prefix,   MZCONFIG_CURRENT_MODULE_NAME,     env);
00348 
00349   GLOBAL_PRIM_W_ARITY("dynamic-require",                  scheme_dynamic_require,     2, 3, env);
00350   GLOBAL_PRIM_W_ARITY("dynamic-require-for-syntax",       dynamic_require_for_syntax, 2, 3, env);
00351   GLOBAL_PRIM_W_ARITY("namespace-require",                namespace_require,          1, 1, env);
00352   GLOBAL_PRIM_W_ARITY("namespace-attach-module",          namespace_attach_module,    2, 3, env);
00353   GLOBAL_PRIM_W_ARITY("namespace-unprotect-module",       namespace_unprotect_module, 2, 3, env);
00354   GLOBAL_PRIM_W_ARITY("namespace-require/copy",           namespace_require_copy,     1, 1, env);
00355   GLOBAL_PRIM_W_ARITY("namespace-require/constant",       namespace_require_constant, 1, 1, env);
00356   GLOBAL_PRIM_W_ARITY("namespace-require/expansion-time", namespace_require_etonly,   1, 1, env);
00357   GLOBAL_PRIM_W_ARITY("compiled-module-expression?",      module_compiled_p,          1, 1, env);
00358   GLOBAL_PRIM_W_ARITY("module-compiled-name",             module_compiled_name,       1, 1, env);
00359   GLOBAL_PRIM_W_ARITY("module-compiled-imports",          module_compiled_imports,    1, 1, env);
00360   GLOBAL_PRIM_W_ARITY2("module-compiled-exports",         module_compiled_exports,    1, 1, 2, 2, env);
00361   GLOBAL_PRIM_W_ARITY("module-compiled-language-info",    module_compiled_lang_info,  1, 1, env);
00362   GLOBAL_FOLDING_PRIM("module-path-index?",               module_path_index_p,        1, 1, 1, env); 
00363   GLOBAL_PRIM_W_ARITY("module-path-index-resolve",        module_path_index_resolve,  1, 1, env); 
00364   GLOBAL_PRIM_W_ARITY2("module-path-index-split",         module_path_index_split,    1, 1, 2, 2, env); 
00365   GLOBAL_PRIM_W_ARITY("module-path-index-join",           module_path_index_join,     2, 2, env);
00366   GLOBAL_FOLDING_PRIM("resolved-module-path?",            resolved_module_path_p,     1, 1, 1, env);
00367   GLOBAL_PRIM_W_ARITY("make-resolved-module-path",        make_resolved_module_path,  1, 1, env);
00368   GLOBAL_PRIM_W_ARITY("resolved-module-path-name",        resolved_module_path_name,  1, 1, env);
00369   GLOBAL_PRIM_W_ARITY("module-provide-protected?",        module_export_protected_p,  2, 2, env);
00370   GLOBAL_PRIM_W_ARITY("module->namespace",                module_to_namespace,        1, 1, env);
00371   GLOBAL_PRIM_W_ARITY("module->language-info",            module_to_lang_info,        1, 1, env);
00372   GLOBAL_PRIM_W_ARITY("module-path?",                     is_module_path,             1, 1, env);
00373 }
00374 
00375 void scheme_init_module_resolver(void)
00376 {
00377   Scheme_Object *o;
00378   Scheme_Config *config;
00379 
00380   REGISTER_SO(starts_table);
00381   starts_table = scheme_make_weak_equal_table();
00382 
00383   config = scheme_current_config();
00384 
00385   o = scheme_make_prim_w_arity(default_module_resolver,
00386                             "default-module-name-resolver",
00387                             1, 4);
00388  
00389   scheme_set_param(config, MZCONFIG_CURRENT_MODULE_RESOLVER, o);
00390 
00391   scheme_set_param(config, MZCONFIG_CURRENT_MODULE_NAME, scheme_false);
00392 }
00393 
00394 void scheme_finish_kernel(Scheme_Env *env)
00395 {
00396   /* When this function is called, the initial namespace has all the
00397      primitive bindings for syntax and procedures. This function fills
00398      in the module wrapper for #%kernel. */
00399   Scheme_Bucket_Table *ht;
00400   int i, j, count, syntax_start = 0;
00401   Scheme_Bucket **bs;
00402   Scheme_Object **exs, *w, *rn;
00403   Scheme_Object *insp;
00404 
00405   REGISTER_SO(kernel);
00406 
00407   kernel = MALLOC_ONE_TAGGED(Scheme_Module);
00408   kernel->so.type = scheme_module_type;
00409 
00410   insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
00411   
00412   env->module = kernel;
00413   env->insp = insp;
00414 
00415   kernel->modname = kernel_modname;
00416   kernel->requires = scheme_null;
00417   kernel->et_requires = scheme_null;
00418   kernel->tt_requires = scheme_null;
00419   kernel->dt_requires = scheme_null;
00420   kernel->other_requires = NULL;
00421 
00422   kernel->insp = insp;
00423   
00424   /* Provide all syntax and variables: */
00425   count = 0;
00426   for (j = 0; j < 2; j++) {
00427     if (!j)
00428       ht = env->toplevel;
00429     else {
00430       ht = env->syntax;
00431       syntax_start = count;
00432     }
00433 
00434     bs = ht->buckets;
00435     for (i = ht->size; i--; ) {
00436       Scheme_Bucket *b = bs[i];
00437       if (b && b->val)
00438        count++;
00439     }
00440   }
00441 
00442   exs = MALLOC_N(Scheme_Object *, count);
00443   count = 0;
00444   for (j = 0; j < 2; j++) {
00445     if (!j)
00446       ht = env->toplevel;
00447     else
00448       ht = env->syntax;
00449 
00450     bs = ht->buckets;
00451     for (i = ht->size; i--; ) {
00452       Scheme_Bucket *b = bs[i];
00453       if (b && b->val)
00454        exs[count++] = (Scheme_Object *)b->key;
00455     }
00456   }
00457  
00458   kernel->no_cert = 1;
00459 
00460   {
00461     Scheme_Module_Exports *me;
00462     me = make_module_exports();
00463     kernel->me = me;
00464   }
00465 
00466   kernel->me->rt->provides = exs;
00467   kernel->me->rt->provide_srcs = NULL;
00468   kernel->me->rt->provide_src_names = exs;
00469   kernel->me->rt->num_provides = count;
00470   kernel->me->rt->num_var_provides = syntax_start;
00471 
00472   env->running = 1;
00473   env->et_running = 1;
00474   env->attached = 1;
00475 
00476   /* Since this is the first module rename, it's registered as
00477      the kernel module rename: */
00478   rn = scheme_make_module_rename(scheme_make_integer(0), mzMOD_RENAME_NORMAL, NULL);
00479   for (i = kernel->me->rt->num_provides; i--; ) {
00480     scheme_extend_module_rename(rn, kernel_modidx, exs[i], exs[i], kernel_modidx, exs[i], 
00481                                 0, scheme_make_integer(0), NULL, NULL, 0);
00482   }
00483   scheme_seal_module_rename(rn, STX_SEAL_ALL);
00484 
00485   scheme_sys_wraps(NULL);
00486 
00487   REGISTER_SO(scheme_module_stx);
00488   REGISTER_SO(scheme_begin_stx);
00489   REGISTER_SO(scheme_define_values_stx);
00490   REGISTER_SO(scheme_define_syntaxes_stx);
00491   REGISTER_SO(define_for_syntaxes_stx);
00492   REGISTER_SO(require_stx);
00493   REGISTER_SO(provide_stx);
00494   REGISTER_SO(set_stx);
00495   REGISTER_SO(app_stx);
00496   REGISTER_SO(scheme_top_stx);
00497   REGISTER_SO(lambda_stx);
00498   REGISTER_SO(case_lambda_stx);
00499   REGISTER_SO(let_values_stx);
00500   REGISTER_SO(letrec_values_stx);
00501   REGISTER_SO(if_stx);
00502   REGISTER_SO(begin0_stx);
00503   REGISTER_SO(set_stx);
00504   REGISTER_SO(with_continuation_mark_stx);
00505   REGISTER_SO(letrec_syntaxes_stx);
00506   REGISTER_SO(var_ref_stx);
00507   REGISTER_SO(expression_stx);
00508 
00509   w = scheme_sys_wraps0;
00510   scheme_module_stx = scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false, w, 0, 0);
00511   scheme_begin_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin"), scheme_false, w, 0, 0);
00512   scheme_define_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-values"), scheme_false, w, 0, 0);
00513   scheme_define_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-syntaxes"), scheme_false, w, 0, 0);
00514   define_for_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("define-values-for-syntax"), scheme_false, w, 0, 0);
00515   require_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%require"), scheme_false, w, 0, 0);
00516   provide_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), scheme_false, w, 0, 0);
00517   set_stx = scheme_datum_to_syntax(scheme_intern_symbol("set!"), scheme_false, w, 0, 0);
00518   app_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%app"), scheme_false, w, 0, 0);
00519   scheme_top_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%top"), scheme_false, w, 0, 0);
00520   lambda_stx = scheme_datum_to_syntax(scheme_intern_symbol("lambda"), scheme_false, w, 0, 0);
00521   case_lambda_stx = scheme_datum_to_syntax(scheme_intern_symbol("case-lambda"), scheme_false, w, 0, 0);
00522   let_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("let-values"), scheme_false, w, 0, 0);
00523   letrec_values_stx = scheme_datum_to_syntax(scheme_intern_symbol("letrec-values"), scheme_false, w, 0, 0);
00524   if_stx = scheme_datum_to_syntax(scheme_intern_symbol("if"), scheme_false, w, 0, 0);
00525   begin0_stx = scheme_datum_to_syntax(scheme_intern_symbol("begin0"), scheme_false, w, 0, 0);
00526   set_stx = scheme_datum_to_syntax(scheme_intern_symbol("set!"), scheme_false, w, 0, 0);
00527   with_continuation_mark_stx = scheme_datum_to_syntax(scheme_intern_symbol("with-continuation-mark"), scheme_false, w, 0, 0);
00528   letrec_syntaxes_stx = scheme_datum_to_syntax(scheme_intern_symbol("letrec-syntaxes+values"), scheme_false, w, 0, 0);
00529   var_ref_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%variable-reference"), scheme_false, w, 0, 0);
00530   expression_stx = scheme_datum_to_syntax(scheme_intern_symbol("#%expression"), scheme_false, w, 0, 0);
00531 
00532   REGISTER_SO(prefix_symbol);
00533   REGISTER_SO(only_symbol);
00534   REGISTER_SO(rename_symbol);
00535   REGISTER_SO(all_except_symbol);
00536   REGISTER_SO(prefix_all_except_symbol);
00537   REGISTER_SO(all_from_symbol);
00538   REGISTER_SO(all_from_except_symbol);
00539   REGISTER_SO(all_defined_symbol);
00540   REGISTER_SO(all_defined_except_symbol);
00541   REGISTER_SO(prefix_all_defined_symbol);
00542   REGISTER_SO(prefix_all_defined_except_symbol);
00543   REGISTER_SO(struct_symbol);
00544   REGISTER_SO(protect_symbol);
00545   REGISTER_SO(expand_symbol);
00546   REGISTER_SO(for_syntax_symbol);
00547   REGISTER_SO(for_template_symbol);
00548   REGISTER_SO(for_label_symbol);
00549   REGISTER_SO(for_meta_symbol);
00550   REGISTER_SO(just_meta_symbol);
00551   prefix_symbol = scheme_intern_symbol("prefix");
00552   only_symbol = scheme_intern_symbol("only");
00553   rename_symbol = scheme_intern_symbol("rename");
00554   all_except_symbol = scheme_intern_symbol("all-except");
00555   prefix_all_except_symbol = scheme_intern_symbol("prefix-all-except");
00556   all_from_symbol = scheme_intern_symbol("all-from");
00557   all_from_except_symbol = scheme_intern_symbol("all-from-except");
00558   all_defined_symbol = scheme_intern_symbol("all-defined");
00559   all_defined_except_symbol = scheme_intern_symbol("all-defined-except");
00560   prefix_all_defined_symbol = scheme_intern_symbol("prefix-all-defined");
00561   prefix_all_defined_except_symbol = scheme_intern_symbol("prefix-all-defined-except");
00562   struct_symbol = scheme_intern_symbol("struct");
00563   protect_symbol = scheme_intern_symbol("protect");
00564   expand_symbol = scheme_intern_symbol("expand");
00565   for_syntax_symbol = scheme_intern_symbol("for-syntax");
00566   for_template_symbol = scheme_intern_symbol("for-template");
00567   for_label_symbol = scheme_intern_symbol("for-label");
00568   for_meta_symbol = scheme_intern_symbol("for-meta");
00569   just_meta_symbol = scheme_intern_symbol("just-meta");
00570 
00571   REGISTER_SO(module_name_symbol);
00572   module_name_symbol = scheme_intern_symbol("enclosing-module-name");
00573 
00574   REGISTER_SO(nominal_id_symbol);
00575   nominal_id_symbol = scheme_intern_symbol("nominal-id");
00576 }
00577 
00578 int scheme_is_kernel_modname(Scheme_Object *modname)
00579 {
00580   return SAME_OBJ(modname, kernel_modname);
00581 }
00582 
00583 Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env)
00584 {
00585   long phase;
00586 
00587   if (!env)
00588     phase = 0;
00589   else if (SCHEME_INTP((Scheme_Object *)env))
00590     phase = SCHEME_INT_VAL((Scheme_Object *)env);
00591   else
00592     phase = env->genv->phase;
00593 
00594   return scheme_sys_wraps_phase(scheme_make_integer(phase));
00595 }
00596 
00597 Scheme_Object *scheme_sys_wraps_phase(Scheme_Object *phase)
00598 {
00599   Scheme_Object *rn, *w;
00600   long p;
00601 
00602   if (SCHEME_INTP(phase))
00603     p = SCHEME_INT_VAL(phase);
00604   else
00605     p = -1;
00606 
00607   if ((p == 0) && scheme_sys_wraps0)
00608     return scheme_sys_wraps0;
00609   if ((p == 1) && scheme_sys_wraps1)
00610     return scheme_sys_wraps1;
00611 
00612   rn = scheme_make_module_rename(phase, mzMOD_RENAME_NORMAL, NULL);
00613 
00614   /* Add a module mapping for all kernel provides: */
00615   scheme_extend_module_rename_with_shared(rn, kernel_modidx, 
00616                                           kernel->me->rt,
00617                                           scheme_make_integer(p),
00618                                           scheme_make_integer(0),
00619                                           scheme_null,
00620                                           1);
00621 
00622   scheme_seal_module_rename(rn, STX_SEAL_ALL);
00623 
00624   w = scheme_datum_to_syntax(kernel_symbol, scheme_false, scheme_false, 0, 0);
00625   w = scheme_add_rename(w, rn);
00626   if (p == 0) {
00627     REGISTER_SO(scheme_sys_wraps0);
00628     scheme_sys_wraps0 = w;
00629   }
00630   if (p == 1) {
00631     REGISTER_SO(scheme_sys_wraps1);
00632     scheme_sys_wraps1 = w;
00633   }
00634 
00635   return w;
00636 }
00637 
00638 void scheme_save_initial_module_set(Scheme_Env *env)
00639 /* Can be called multiple times! */
00640 {
00641   int i, c, count;
00642   Scheme_Hash_Table *ht;
00643        
00644   if (!initial_modules_env) {
00645     REGISTER_SO(initial_modules_env);
00646   }
00647   initial_modules_env = env;
00648   
00649   ht = env->module_registry;
00650   c = ht->size;
00651 
00652   count = 0;
00653   for (i = 0; i < c; i++) {
00654     if (ht->vals[i])
00655       count++;
00656   }
00657 
00658   num_initial_modules = count;
00659   
00660   if (!initial_modules) {
00661     REGISTER_SO(initial_modules);
00662   }
00663   initial_modules = MALLOC_N(Scheme_Object *, count);
00664 
00665   count = 0;
00666   for (i = 0; i < c; i++) {
00667     if (ht->vals[i]) {
00668       initial_modules[count++] = ht->keys[i];
00669     }
00670   }
00671 
00672   /* Clone renames: */
00673   if (!initial_renames) {
00674     REGISTER_SO(initial_renames);
00675   }
00676   initial_renames = scheme_make_module_rename(scheme_make_integer(0), 
00677                                               mzMOD_RENAME_NORMAL, 
00678                                               NULL);
00679   scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL);
00680   scheme_append_module_rename(scheme_get_module_rename_from_set(env->rename_set, 
00681                                                                 scheme_make_integer(0),
00682                                                                 1),
00683                               initial_renames, 
00684                               1);
00685   
00686   /* Clone variable bindings: */
00687   if (!initial_toplevel) {
00688      REGISTER_SO(initial_toplevel);
00689   }
00690   initial_toplevel = scheme_clone_toplevel(env->toplevel, NULL);
00691 }
00692 
00693 void scheme_install_initial_module_set(Scheme_Env *env)
00694 {
00695   int i;
00696   Scheme_Object *a[3];
00697   Scheme_Module *m;
00698 
00699   /* Copy over module declarations and instances: */
00700   for (i = 0; i < num_initial_modules; i++) {
00701     a[0] = (Scheme_Object *)initial_modules_env;
00702     a[1] = initial_modules[i];
00703     a[2] = (Scheme_Object *)env;
00704 
00705     /* Make sure module is running: */
00706     m = (Scheme_Module *)scheme_hash_get(initial_modules_env->module_registry, a[1]);
00707     start_module(m, initial_modules_env, 0, a[1], 0, 1, 0, scheme_null);
00708 
00709     namespace_attach_module(3, a);
00710   }
00711 
00712   /* Copy renamings: */
00713   scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL);
00714   scheme_append_module_rename(initial_renames, 
00715                               scheme_get_module_rename_from_set(env->rename_set, 
00716                                                                 scheme_make_integer(0),
00717                                                                 1),
00718                               1);
00719 
00720   /* Copy toplevel: */
00721   {
00722     Scheme_Bucket_Table *tl;
00723     tl = scheme_clone_toplevel(initial_toplevel, env);
00724     env->toplevel = tl;
00725   }
00726 }
00727 
00728 /**********************************************************************/
00729 /*                             parameters                             */
00730 /**********************************************************************/
00731 
00732 static Scheme_Object *default_module_resolver(int argc, Scheme_Object **argv)
00733 {
00734   Scheme_Object *p = argv[0];
00735 
00736   if (argc == 1)
00737     return scheme_void; /* ignore notify */
00738 
00739   if (SCHEME_PAIRP(p)
00740       && SAME_OBJ(SCHEME_CAR(p), quote_symbol)
00741       && SCHEME_PAIRP(SCHEME_CDR(p))
00742       && SCHEME_SYMBOLP(SCHEME_CAR(SCHEME_CDR(p)))
00743       && SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(p))))
00744     return scheme_intern_resolved_module_path(SCHEME_CAR(SCHEME_CDR(p)));
00745 
00746   scheme_arg_mismatch("default-module-name-resolver", 
00747                     "the kernel's resolver works only on `quote' forms; given: ", 
00748                     p);
00749   return NULL;
00750 }
00751 
00752 static Scheme_Object *check_resolver(int argc, Scheme_Object **argv)
00753 {
00754   if (scheme_check_proc_arity(NULL, 1, 0, argc, argv)
00755       && scheme_check_proc_arity(NULL, 3, 0, argc, argv)
00756       && scheme_check_proc_arity(NULL, 4, 0, argc, argv))
00757     return argv[0];
00758 
00759   scheme_wrong_type("current-module-name-resolver", "procedure of arity 1, 3, and 4", 0, argc, argv);
00760 
00761   return NULL;
00762 }
00763 
00764 static Scheme_Object *
00765 current_module_name_resolver(int argc, Scheme_Object *argv[])
00766 {
00767   return scheme_param_config("current-module-name-resolver",
00768                           scheme_make_integer(MZCONFIG_CURRENT_MODULE_RESOLVER),
00769                           argc, argv,
00770                           -1, check_resolver, "procedure of arity 1, 3, and 4", 1);
00771 }
00772 
00773 static Scheme_Object *prefix_p(int argc, Scheme_Object **argv)
00774 {
00775   Scheme_Object *o = argv[0];
00776   
00777   if (SCHEME_FALSEP(o) || (SCHEME_MODNAMEP(o)))
00778     return o;
00779 
00780   return NULL;
00781 }
00782 
00783 static Scheme_Object *
00784 current_module_name_prefix(int argc, Scheme_Object *argv[])
00785 {
00786   return scheme_param_config("current-module-declared-name",
00787                           scheme_make_integer(MZCONFIG_CURRENT_MODULE_NAME),
00788                           argc, argv,
00789                           -1, prefix_p, "resolved-module-path or #f", 1);
00790 }
00791 
00792 /**********************************************************************/
00793 /*                            procedures                              */
00794 /**********************************************************************/
00795 
00796 int scheme_module_protected_wrt(Scheme_Object *home_insp, Scheme_Object *insp)
00797 {
00798   if (!insp)
00799     return 1;
00800   if (SAME_OBJ(insp, scheme_true))
00801     return 0;
00802   return !scheme_is_subinspector(home_insp, insp);
00803 }
00804 
00805 static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[],
00806                                    Scheme_Env *env,
00807                                    int get_bucket, 
00808                                    int phase, int mod_phase, int indirect_ok,
00809                                    int fail_with_error,
00810                                    int position)
00811 {
00812   Scheme_Object *modname, *modidx;
00813   Scheme_Object *name, *srcname, *srcmname, *fail_thunk;
00814   Scheme_Module *m, *srcm;
00815   Scheme_Env *menv, *lookup_env = NULL;
00816   int i, count, protected = 0;
00817   const char *errname;
00818   long base_phase;
00819 
00820   modname = argv[0];
00821   name = argv[1];
00822   if (argc > 2)
00823     fail_thunk = argv[2];
00824   else
00825     fail_thunk = NULL;
00826 
00827   errname = (phase 
00828             ? ((phase < 0)
00829               ? "dynamic-require-for-template" 
00830               : "dynamic-require-for-syntax" )
00831             : "dynamic-require");
00832 
00833   if (SCHEME_TRUEP(name) && !SCHEME_SYMBOLP(name) && !SCHEME_VOIDP(name)) {
00834     scheme_wrong_type(errname, "symbol, #f, or void", 1, argc, argv);
00835     return NULL;
00836   }
00837 
00838   if (fail_thunk)
00839     scheme_check_proc_arity(errname, 0, 2, argc, argv);
00840 
00841   if (SAME_TYPE(SCHEME_TYPE(modname), scheme_module_index_type))
00842     modidx = modname;
00843   else
00844     modidx = scheme_make_modidx(modname, scheme_false, scheme_false);
00845 
00846   modname = scheme_module_resolve(modidx, 1);
00847   base_phase = env->phase;
00848 
00849   if (phase == 1) {
00850     scheme_prepare_exp_env(env);
00851     if (mod_phase)
00852       lookup_env = env->exp_env;
00853     else
00854       env = env->exp_env;
00855   }
00856 
00857   scheme_prepare_compile_env(env);
00858 
00859   m = module_load(modname, env, errname);
00860   srcm = m;
00861 
00862   srcmname = NULL;
00863   srcname = NULL;
00864 
00865   if (SCHEME_SYMBOLP(name)) {
00866     if (mod_phase) {
00867       srcname = name;
00868       srcmname = modname;
00869     } else {
00870       /* Before starting, check whether the name is provided */
00871       count = srcm->me->rt->num_provides;
00872       if (position >= 0) {
00873        if (position < srcm->me->rt->num_var_provides) {
00874          i = position;
00875          if ((SCHEME_SYM_LEN(name) == SCHEME_SYM_LEN(srcm->me->rt->provide_src_names[i]))
00876              && !memcmp(SCHEME_SYM_VAL(name), SCHEME_SYM_VAL(srcm->me->rt->provide_src_names[i]), SCHEME_SYM_LEN(name))) {
00877            name = srcm->me->rt->provides[i];
00878          } else {
00879            i = count; /* not found */
00880            indirect_ok = 0; /* don't look further */
00881          }
00882        } else {
00883          position -= srcm->me->rt->num_var_provides;
00884          i = count;
00885        }
00886       } else {
00887        for (i = 0; i < count; i++) {
00888          if (SAME_OBJ(name, srcm->me->rt->provides[i])) {
00889            if (i < srcm->me->rt->num_var_provides) {
00890              break;
00891            } else {
00892              if (fail_with_error) {
00893                 if (!phase) {
00894                   /* Evaluate id in a fresh namespace */
00895                   Scheme_Object *a[3], *ns;
00896                   start_module(m, env, 0, modidx, 0, 1, base_phase, scheme_null);
00897                   a[0] = scheme_intern_symbol("empty");
00898                   ns = scheme_make_namespace(1, a);
00899                   a[0] = (Scheme_Object *)env;
00900                   a[1] = srcm->modname;
00901                   a[2] = ns;
00902                   namespace_attach_module(3, a);
00903                   a[0] = scheme_make_pair(scheme_intern_symbol("only"),
00904                                           scheme_make_pair(srcm->modname,
00905                                                            scheme_make_pair(name,
00906                                                                             scheme_null)));
00907                   do_namespace_require((Scheme_Env *)ns, 1, a, 0, 0);
00908                   return scheme_eval(name, (Scheme_Env *)ns);
00909                 } else {
00910                   scheme_raise_exn(MZEXN_FAIL_CONTRACT,
00911                                    "%s: name is provided as syntax: %V by module: %V",
00912                                    errname,
00913                                    name, srcm->modname);
00914                 }
00915               }
00916              return NULL;
00917            }
00918          }
00919        }
00920       }
00921 
00922       if (i < count) {
00923        if (srcm->provide_protects)
00924          protected = srcm->provide_protects[i];
00925        srcmname = (srcm->me->rt->provide_srcs ? srcm->me->rt->provide_srcs[i] : scheme_false);
00926        if (SCHEME_FALSEP(srcmname))
00927          srcmname = srcm->modname;
00928        else {
00929          srcmname = scheme_modidx_shift(srcmname, srcm->me->src_modidx, srcm->self_modidx);
00930          srcmname = scheme_module_resolve(srcmname, 1);
00931        }
00932        srcname = srcm->me->rt->provide_src_names[i];
00933       }
00934 
00935       if (i == count) {
00936        if (indirect_ok) {
00937          /* Try indirect provides: */
00938          srcm = m;
00939          count = srcm->num_indirect_provides;
00940          if (position >= 0) {
00941            i = position;
00942            if ((i < srcm->num_indirect_provides)
00943               && (SCHEME_SYM_LEN(name) == SCHEME_SYM_LEN(srcm->indirect_provides[i]))
00944               && !memcmp(SCHEME_SYM_VAL(name), SCHEME_SYM_VAL(srcm->indirect_provides[i]), SCHEME_SYM_LEN(name))) {
00945              name = srcm->indirect_provides[i];
00946              srcname = name;
00947              srcmname = srcm->modname;
00948              if (srcm->provide_protects)
00949               protected = srcm->provide_protects[i];
00950            } else
00951              i = count; /* not found */
00952          } else {
00953            for (i = 0; i < count; i++) {
00954              if (SAME_OBJ(name, srcm->indirect_provides[i])) {
00955               srcname = name;
00956               srcmname = srcm->modname;
00957               if (srcm->provide_protects)
00958                 protected = srcm->provide_protects[i];
00959               break;
00960              }
00961            }
00962          }
00963        }
00964 
00965        if (i == count) {
00966          if (fail_with_error) {
00967             if (fail_thunk)
00968               return scheme_tail_apply(fail_thunk, 0, NULL);
00969            scheme_raise_exn(MZEXN_FAIL_CONTRACT,
00970                           "%s: name is not provided: %V by module: %V",
00971                           errname,
00972                           name, srcm->modname);
00973           }
00974          return NULL;
00975        }
00976       }
00977     }
00978   }
00979 
00980   if (SCHEME_VOIDP(name))
00981     start_module(m, env, 0, modidx, 1, 0, base_phase, scheme_null);
00982   else
00983     start_module(m, env, 0, modidx, 0, 1, base_phase, scheme_null);
00984 
00985   if (SCHEME_SYMBOLP(name)) {
00986     Scheme_Bucket *b;
00987 
00988     menv = scheme_module_access(srcmname, lookup_env ? lookup_env : env, mod_phase);
00989 
00990     if (protected) {
00991       Scheme_Object *insp;
00992       insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
00993       if (scheme_module_protected_wrt(menv->insp, insp))
00994        scheme_raise_exn(MZEXN_FAIL_CONTRACT,
00995                       "%s: name is protected: %V from module: %V",
00996                       errname,
00997                       name, srcm->modname);
00998     }
00999 
01000     if (!menv || !menv->toplevel) {
01001       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01002                        "%s: module initialization failed: %V",
01003                        errname,
01004                        srcm->modname);
01005     }
01006     
01007     b = scheme_bucket_from_table(menv->toplevel, (const char *)srcname);
01008     if (!((Scheme_Bucket_With_Home *)b)->home)
01009       ((Scheme_Bucket_With_Home *)b)->home = menv;
01010 
01011     if (get_bucket)
01012       return (Scheme_Object *)b;
01013     else {
01014       if (!b->val) {
01015         if (!menv->ran)
01016           run_module(menv, 1);
01017       }
01018       if (!b->val && fail_with_error) {
01019         if (fail_thunk)
01020           return scheme_tail_apply(fail_thunk, 0, NULL);
01021        scheme_unbound_global(b);
01022       }
01023       return b->val;
01024     }
01025   } else
01026     return scheme_void;
01027 }
01028 
01029 Scheme_Object *scheme_dynamic_require(int argc, Scheme_Object *argv[])
01030 {
01031   if (scheme_module_demand_hook) {
01032     Scheme_Object *r;
01033     r = scheme_module_demand_hook(argc, argv);
01034     if (r) return r;
01035   }
01036 
01037   return _dynamic_require(argc, argv, scheme_get_env(NULL), 0, 0, 0, 0, 1, -1);
01038 }
01039 
01040 static Scheme_Object *dynamic_require_for_syntax(int argc, Scheme_Object *argv[])
01041 {
01042   return _dynamic_require(argc, argv, scheme_get_env(NULL), 0, 1, 0, 0, 1, -1);
01043 }
01044 
01045 static Scheme_Object *do_namespace_require(Scheme_Env *env, int argc, Scheme_Object *argv[], 
01046                                            int copy, int etonly)
01047 {
01048   Scheme_Object *form, *rns;
01049 
01050   if (!env)
01051     env = scheme_get_env(NULL);
01052   scheme_prepare_exp_env(env);
01053 
01054   form = scheme_datum_to_syntax(scheme_make_pair(require_stx,
01055                                            scheme_make_pair(argv[0], scheme_null)),
01056                             scheme_false, scheme_false, 1, 0);
01057 
01058   rns = scheme_make_module_rename_set(mzMOD_RENAME_TOPLEVEL, NULL);
01059 
01060   parse_requires(form, scheme_false, env, NULL,
01061                  rns, NULL,
01062                  NULL /* ck */, NULL /* data */,
01063                  NULL, 
01064                  1, copy, 0, 
01065                  etonly ? 1 : -1, !etonly,
01066                  NULL);
01067 
01068   scheme_append_rename_set_to_env(rns, env);
01069 
01070   return scheme_void;
01071 }
01072 
01073 static Scheme_Object *namespace_require(int argc, Scheme_Object *argv[])
01074 {
01075   return do_namespace_require(NULL, argc, argv, 0, 0);
01076 }
01077 
01078 Scheme_Object *scheme_namespace_require(Scheme_Object *r)
01079 {
01080   Scheme_Object *a[1];
01081   a[0] = r;
01082   return namespace_require(1, a);
01083 }
01084 
01085 static Scheme_Object *namespace_require_copy(int argc, Scheme_Object *argv[])
01086 {
01087   return do_namespace_require(NULL, argc, argv, 1, 0);
01088 }
01089 
01090 static Scheme_Object *namespace_require_constant(int argc, Scheme_Object *argv[])
01091 {
01092   return do_namespace_require(NULL, argc, argv, 2, 0);
01093 }
01094 
01095 static Scheme_Object *namespace_require_etonly(int argc, Scheme_Object *argv[])
01096 {
01097   return do_namespace_require(NULL, argc, argv, 0, 1);
01098 }
01099 
01100 static Scheme_Object *extend_list_depth(Scheme_Object *l, Scheme_Object *n, int with_ht)
01101 {
01102   Scheme_Object *p, *orig;
01103   int k;
01104 
01105   if (!SCHEME_INTP(n))
01106     scheme_raise_out_of_memory(NULL, NULL);
01107 
01108   k = SCHEME_INT_VAL(n);
01109 
01110   if (SCHEME_NULLP(l)) {
01111     if (with_ht)
01112       p = (Scheme_Object *)scheme_make_hash_table(SCHEME_hash_ptr);
01113     else
01114       p = scheme_null;
01115     l = scheme_make_pair(p, scheme_null);
01116   }
01117    
01118   orig = l;
01119   
01120   while (k--) {
01121     if (SCHEME_NULLP(SCHEME_CDR(l))) {
01122       if (with_ht)
01123         p = (Scheme_Object *)scheme_make_hash_table(SCHEME_hash_ptr);
01124       else
01125         p = scheme_null;
01126       p = scheme_make_pair(p, scheme_null);
01127       SCHEME_CDR(l) = p;
01128     }
01129     l = SCHEME_CDR(l);
01130   }
01131 
01132   return orig;
01133 }
01134 
01135 static Scheme_Object *extract_at_depth(Scheme_Object *l, Scheme_Object *n)
01136 {
01137   int k = SCHEME_INT_VAL(n);
01138 
01139   while (k--) {
01140     l = SCHEME_CDR(l);
01141   }
01142 
01143   return SCHEME_CAR(l);
01144 }
01145 
01146 static void set_at_depth(Scheme_Object *l, Scheme_Object *n, Scheme_Object *v)
01147 {
01148   int k = SCHEME_INT_VAL(n);
01149 
01150   while (k--) {
01151     l = SCHEME_CDR(l);
01152   }
01153   
01154   SCHEME_CAR(l) = v;
01155 }
01156 
01157 #if 0
01158 static void check_phase(Scheme_Env *menv, Scheme_Env *env, int phase)
01159 {
01160   if (env && (env->exp_env == env)) {
01161     /* label phase */
01162     return;
01163   }
01164 
01165   if (!menv->module->primitive 
01166       && ((env && (menv->phase != env->phase))
01167           || (!env && (menv->phase != phase)))) {
01168     fprintf(stderr, "phase mismatch\n");
01169   }
01170 }
01171 
01172 static void check_modchain_consistency(Scheme_Hash_Table *ht, int phase)
01173 {
01174   int i;
01175 
01176   for (i = ht->size; i--; ) {
01177     if (ht->vals[i]) {
01178       check_phase((Scheme_Env *)ht->vals[i], NULL, phase);
01179     }
01180   }
01181 }
01182 #else
01183 static void check_phase(Scheme_Env *menv, Scheme_Env *env, int phase) { }
01184 static void check_modchain_consistency(Scheme_Hash_Table *ht, int phase) { }
01185 #endif
01186 
01187 #if 0
01188 # define LOG_ATTACH(x) (x, fflush(stdout))
01189 #else
01190 # define LOG_ATTACH(x) /* nothing */
01191 #endif
01192 
01193 static Scheme_Object *namespace_attach_module(int argc, Scheme_Object *argv[])
01194 {
01195   Scheme_Env *from_env, *to_env, *menv, *menv2;
01196   Scheme_Object *todo, *next_phase_todo, *prev_phase_todo;
01197   Scheme_Object *name, *notifies = scheme_null, *a[1], *resolver;
01198   Scheme_Object *to_modchain, *from_modchain, *l;
01199   Scheme_Hash_Table *checked, *next_checked, *prev_checked;
01200   Scheme_Object *past_checkeds, *future_checkeds, *future_todos, *past_to_modchains, *past_todos;
01201   Scheme_Module *m2;
01202   int same_namespace, set_env_for_notify = 0, phase, orig_phase, max_phase, first_iteration;
01203   int just_declare;
01204   Scheme_Object *nophase_todo;
01205   Scheme_Hash_Table *nophase_checked;
01206 
01207   if (!SCHEME_NAMESPACEP(argv[0]))
01208     scheme_wrong_type("namespace-attach-module", "namespace", 0, argc, argv);
01209   from_env = (Scheme_Env *)argv[0];
01210 
01211   if (argc > 2) {
01212     if (!SCHEME_NAMESPACEP(argv[2]))
01213       scheme_wrong_type("namespace-attach-module", "namespace", 2, argc, argv);
01214     to_env = (Scheme_Env *)argv[2];
01215     set_env_for_notify = 1;
01216   } else
01217     to_env = scheme_get_env(NULL);
01218 
01219   same_namespace = SAME_OBJ(from_env, to_env);
01220 
01221   if (from_env->phase != to_env->phase) {
01222     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01223                      "namespace-attach-module: "
01224                      "source namespace phase: %ld does not match destination namespace phase: %ld",
01225                      (long)from_env->phase, (long)to_env->phase);
01226   }
01227 
01228   name = scheme_module_resolve(scheme_make_modidx(argv[1], scheme_false, scheme_false), 0);
01229 
01230   todo = scheme_make_pair(name, scheme_null);
01231   next_phase_todo = scheme_null;
01232   prev_phase_todo = scheme_null;
01233   nophase_todo = scheme_null;
01234   from_modchain = from_env->modchain;
01235   to_modchain = to_env->modchain;
01236   phase = from_env->phase;
01237   orig_phase = phase;
01238 
01239   checked = NULL;
01240   next_checked = NULL;
01241   prev_checked = NULL;
01242 
01243   past_checkeds = scheme_null;
01244   past_todos = scheme_null;
01245   future_checkeds = scheme_null;
01246   future_todos = scheme_null;
01247   past_to_modchains = scheme_null;
01248 
01249   nophase_checked = scheme_make_hash_table(SCHEME_hash_ptr);
01250 
01251   first_iteration = 1;
01252   max_phase = phase;
01253   just_declare = 0;
01254 
01255   checked = scheme_make_hash_table(SCHEME_hash_ptr);
01256   scheme_hash_set(checked, name, scheme_true);
01257 
01258   /* Check whether todo, or anything it needs, is already declared
01259      incompatibly. Successive iterations of the outer loop explore
01260      successive phases (i.e, for-syntax levels). */
01261   while (!SCHEME_NULLP(todo)) {
01262     if (phase > max_phase)
01263       max_phase = phase;
01264     if (phase < 0) {
01265       /* As soon as we start traversing negative phases, stop transferring
01266          instances (i.e., transfer declarations only). This transfer-only
01267          mode should stick even even if we go back into positive phases. */
01268       just_declare = 1;
01269     }
01270 
01271     if (!checked)
01272       checked = scheme_make_hash_table(SCHEME_hash_ptr);
01273     /* This is just a shortcut: */
01274     if (!next_checked)
01275       next_checked = scheme_make_hash_table(SCHEME_hash_ptr);
01276 
01277     /* This loop iterates through require chains in the same phase */
01278     while (!SCHEME_NULLP(todo)) {
01279       name = SCHEME_CAR(todo);
01280 
01281       todo = SCHEME_CDR(todo);
01282 
01283       if (!scheme_hash_get(checked, name)) {
01284         scheme_signal_error("internal error: module not in `checked' table");
01285       }
01286 
01287       if (!SAME_OBJ(name, kernel_modname)) {
01288        LOG_ATTACH(printf("Check %d %s\n", phase, scheme_write_to_string(name, 0)));
01289 
01290        menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(from_modchain), name);
01291        
01292        if (!menv) {
01293          /* Assert: name == argv[1] */
01294          /* Module at least declared? */
01295          if (scheme_hash_get(from_env->module_registry, name))
01296            scheme_arg_mismatch("namespace-attach-module",
01297                             "module not instantiated (in the source namespace): ",
01298                             name);
01299          else
01300            scheme_arg_mismatch("namespace-attach-module",
01301                             "unknown module (in the source namespace): ",
01302                             name);
01303        }
01304 
01305         /* If to_modchain goes to #f, then our source check has gone
01306           deeper in phases (for-syntax levels) than the target
01307           namespace has ever gone, so there's definitely no conflict
01308           at this level in that case. */
01309        if ((phase >= 0) && SCHEME_TRUEP(to_modchain)) {
01310          menv2 = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(to_modchain), name);
01311          if (menv2) {
01312            if (!SAME_OBJ(menv->toplevel, menv2->toplevel))
01313              m2 = menv2->module;
01314            else
01315              m2 = NULL;
01316          } else {
01317            m2 = (Scheme_Module *)scheme_hash_get(to_env->module_registry, name);
01318            if (m2 && SAME_OBJ(m2, menv->module))
01319              m2 = NULL;
01320          }
01321 
01322           if (m2 && (phase > orig_phase) && SAME_OBJ(menv->module, m2)) {
01323             /* different instance of same module is ok at higher phases */
01324             m2 = NULL;
01325           }
01326          
01327          if (m2) {
01328            char *phase, buf[32], *kind;
01329 
01330            if (!menv->phase)
01331              phase = "";
01332            else if (menv->phase == 1)
01333              phase = " for syntax";
01334            else {
01335              sprintf(buf, " at phase %ld", menv->phase);
01336              phase = buf;
01337            }
01338 
01339             if (SAME_OBJ(menv->module, m2))
01340               kind = "instance of the same module";
01341             else
01342               kind = "module with the same name";
01343 
01344            scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01345                           "namespace-attach-module: "
01346                           "a different %s is already "
01347                           "in the destination namespace%s, for name: %D",
01348                           kind, phase, name);
01349            return NULL;
01350          }
01351        } else
01352          menv2 = NULL;
01353 
01354        if (!menv2 || same_namespace) {
01355          /* Push requires onto the check list: */
01356          l = menv->require_names;
01357          while (!SCHEME_NULLP(l)) {
01358            name = scheme_module_resolve(SCHEME_CAR(l), 0);
01359            if (!scheme_hash_get(checked, name)) {
01360               LOG_ATTACH(printf("Add %d %s (%p)\n", phase, scheme_write_to_string(name, 0), checked));
01361              todo = scheme_make_pair(name, todo);
01362              scheme_hash_set(checked, name, just_declare ? scheme_false : scheme_true);
01363            }
01364            l = SCHEME_CDR(l);
01365          }
01366 
01367           /* was here */
01368 
01369          l = menv->et_require_names;
01370          while (!SCHEME_NULLP(l)) {
01371            name = scheme_module_resolve(SCHEME_CAR(l), 0);
01372            if (!scheme_hash_get(next_checked, name)) {
01373              LOG_ATTACH(printf("Add +%d %s (%p)\n", phase+1, scheme_write_to_string(name, 0), next_checked));
01374              next_phase_todo = scheme_make_pair(name, next_phase_todo);
01375              scheme_hash_set(next_checked, name, just_declare ? scheme_false : scheme_true);
01376            }
01377            l = SCHEME_CDR(l);
01378          }
01379 
01380           l = menv->tt_require_names;
01381           if (l) {
01382             while (!SCHEME_NULLP(l)) {
01383               name = scheme_module_resolve(SCHEME_CAR(l), 0);
01384               if (!prev_checked)
01385                 prev_checked = scheme_make_hash_table(SCHEME_hash_ptr);
01386               if (!scheme_hash_get(prev_checked, name)) {
01387                 LOG_ATTACH(printf("Add -%d %s (%p)\n", phase-1, scheme_write_to_string(name, 0), prev_checked));
01388                 prev_phase_todo = scheme_make_pair(name, prev_phase_todo);
01389                 scheme_hash_set(prev_checked, name, just_declare ? scheme_false : scheme_true);
01390               }
01391               l = SCHEME_CDR(l);
01392             }
01393          }
01394 
01395           if (!same_namespace) {
01396             l = menv->dt_require_names;
01397             if (l) {
01398               while (!SCHEME_NULLP(l)) {
01399                 name = scheme_module_resolve(SCHEME_CAR(l), 0);
01400                 
01401                 if (!scheme_hash_get(nophase_checked, name)) {
01402                   LOG_ATTACH(printf("Add * %s\n", scheme_write_to_string(name, NULL)));
01403                   nophase_todo = scheme_make_pair(name, nophase_todo);
01404                   scheme_hash_set(nophase_checked, name, just_declare ? scheme_false : scheme_true);
01405                 }
01406                 l = SCHEME_CDR(l);
01407               }
01408             }
01409           }
01410 
01411           if (menv->other_require_names) {
01412             Scheme_Hash_Table *oht;
01413             int i;
01414             oht = menv->other_require_names;
01415             for (i = 0; i < oht->size; i++) {
01416               if (oht->vals[i]) {
01417                 Scheme_Object *lphase = oht->keys[i];
01418                 Scheme_Object *l = oht->vals[i], *todos, *checkeds;
01419 
01420                 if (scheme_is_negative(lphase)) {
01421                   lphase = scheme_bin_minus(scheme_make_integer(0), lphase);
01422                   lphase = scheme_bin_minus(lphase, scheme_make_integer(2));
01423                   past_todos = extend_list_depth(past_todos, lphase, 0);
01424                   past_checkeds = extend_list_depth(past_checkeds, lphase, 1);
01425                   todos = past_todos;
01426                   checkeds = past_checkeds;
01427                 } else {
01428                   lphase = scheme_bin_minus(lphase, scheme_make_integer(2));
01429                   future_todos = extend_list_depth(future_todos, lphase, 0);
01430                   future_checkeds = extend_list_depth(future_checkeds, lphase, 1);
01431                   todos = future_todos;
01432                   checkeds = future_checkeds;
01433                 }
01434                 if (todos) {
01435                   Scheme_Object *a_todo;
01436                   Scheme_Hash_Table *a_checked;
01437                   
01438                   a_todo = extract_at_depth(todos, lphase);
01439                   a_checked = (Scheme_Hash_Table *)extract_at_depth(checkeds, lphase);
01440                   
01441                   while (!SCHEME_NULLP(l)) {
01442                     name = scheme_module_resolve(SCHEME_CAR(l), 0);
01443                     if (!scheme_hash_get(a_checked, name)) {
01444                       LOG_ATTACH(printf("Add +%ld %s (%p)\n", 
01445                                         SCHEME_INT_VAL(oht->keys[i]), 
01446                                         scheme_write_to_string(name, 0), a_checked));
01447                       a_todo = scheme_make_pair(name, a_todo);
01448                       scheme_hash_set(a_checked, name, just_declare ? scheme_false : scheme_true);
01449                     }
01450                     l = SCHEME_CDR(l);
01451                   }
01452                   
01453                   set_at_depth(todos, lphase, a_todo);
01454                 }
01455               }
01456             }
01457           }
01458         }
01459       }
01460     }
01461 
01462     do {
01463       if (!SCHEME_PAIRP(next_phase_todo)) {
01464         /* Work on earlier phase */
01465         LOG_ATTACH(printf("prev\n"));
01466        future_todos = cons(next_phase_todo, future_todos);
01467         next_phase_todo = todo;
01468        future_checkeds = cons((Scheme_Object *)next_checked, future_checkeds);
01469        next_checked = checked;
01470        
01471        todo = prev_phase_todo;
01472         checked = prev_checked;
01473 
01474         if (SCHEME_NULLP(past_todos)) {
01475           prev_phase_todo = scheme_null;
01476           prev_checked = NULL;
01477         } else {
01478           prev_phase_todo = SCHEME_CAR(past_todos);
01479          past_todos = SCHEME_CDR(past_todos);
01480           prev_checked = (Scheme_Hash_Table *)SCHEME_CAR(past_checkeds);
01481          past_checkeds = SCHEME_CDR(past_checkeds);
01482         }
01483        
01484        from_modchain = SCHEME_VEC_ELS(from_modchain)[2];
01485         if (phase > 0) {
01486           to_modchain = SCHEME_CAR(past_to_modchains);
01487           past_to_modchains = SCHEME_CDR(past_to_modchains);
01488         }
01489        phase--;
01490       } else {
01491         /* Work on later phase */
01492         LOG_ATTACH(printf("later\n"));
01493         past_todos = cons(prev_phase_todo, past_todos);
01494         prev_phase_todo = todo;
01495        past_checkeds = scheme_make_raw_pair((Scheme_Object *)prev_checked, past_checkeds);
01496        prev_checked = checked;
01497 
01498        todo = next_phase_todo;
01499        checked = next_checked;
01500        
01501        if (SCHEME_NULLP(future_todos)) {
01502          next_phase_todo = scheme_null;
01503          next_checked = NULL;
01504        } else {
01505          next_phase_todo = SCHEME_CAR(future_todos);
01506          future_todos = SCHEME_CDR(future_todos);
01507          next_checked = (Scheme_Hash_Table *)SCHEME_CAR(future_checkeds);
01508          future_checkeds = SCHEME_CDR(future_checkeds);
01509        }
01510        
01511        from_modchain = SCHEME_VEC_ELS(from_modchain)[1];
01512         if (phase >= 0) {
01513           past_to_modchains = cons(to_modchain, past_to_modchains);
01514           if (SCHEME_TRUEP(to_modchain))
01515             to_modchain = SCHEME_VEC_ELS(to_modchain)[1];
01516         }
01517        phase++;
01518       }
01519     } while (SCHEME_NULLP(todo) && (SCHEME_PAIRP(prev_phase_todo)
01520                                 || SCHEME_PAIRP(past_todos)));
01521   }
01522 
01523   LOG_ATTACH(printf("Done phase: %d\n", phase));
01524 
01525   if (SCHEME_PAIRP(nophase_todo) && !from_env->label_env)
01526     scheme_signal_error("internal error: missing label environment");
01527 
01528   /* Recursively process phase-#f modules: */
01529   while (!SCHEME_NULLP(nophase_todo)) {
01530     name = SCHEME_CAR(nophase_todo);
01531     nophase_todo = SCHEME_CDR(nophase_todo);      
01532 
01533     if (!SAME_OBJ(name, kernel_modname)) {
01534       int i;
01535 
01536       menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(from_env->label_env->modchain), name);
01537     
01538       LOG_ATTACH(printf("Check #f %s\n", scheme_write_to_string(name, 0)));
01539     
01540       if (!menv) {
01541         scheme_arg_mismatch("namespace-attach-module",
01542                             "internal error; unknown module (for label): ",
01543                             name);
01544       }
01545     
01546       for (i = -4; 
01547            i < (menv->other_require_names ? menv->other_require_names->size : 0); 
01548            i++) {
01549         switch (i) {
01550         case -4:
01551           l = menv->require_names;
01552           break;
01553         case -3:
01554           l = menv->et_require_names;
01555           break;
01556         case -2:
01557           l = menv->tt_require_names;
01558           break;
01559         case -1:
01560           l = menv->dt_require_names;
01561           break;
01562         default:
01563           l = menv->other_require_names->vals[i];
01564           break;
01565         }
01566       
01567         if (l) {
01568           while (!SCHEME_NULLP(l)) {
01569             name = scheme_module_resolve(SCHEME_CAR(l), 0);
01570             if (!scheme_hash_get(nophase_checked, name)) {
01571               LOG_ATTACH(printf("Add .* %s\n", scheme_write_to_string(name, 0)));
01572               nophase_todo = scheme_make_pair(name, nophase_todo);
01573               scheme_hash_set(nophase_checked, name, scheme_true);
01574             }
01575             l = SCHEME_CDR(l);
01576           }
01577         }
01578       }
01579     }
01580   }
01581   
01582   /* All of the modules that we saw are in the ***_checked hash tables */
01583   if (prev_checked) {
01584     past_checkeds = cons((Scheme_Object *)prev_checked, past_checkeds);
01585   }
01586   if (!checked)
01587     checked = scheme_make_hash_table(SCHEME_hash_ptr);
01588   past_checkeds = cons((Scheme_Object *)checked, past_checkeds);
01589 
01590   if (phase < max_phase) {
01591     past_checkeds = cons((Scheme_Object *)next_checked, past_checkeds);
01592     phase++;
01593   }
01594   while (phase < max_phase) {
01595     next_checked = (Scheme_Hash_Table *)SCHEME_CAR(future_checkeds);
01596     past_checkeds = scheme_make_raw_pair((Scheme_Object *)next_checked, past_checkeds);
01597     
01598     future_checkeds = SCHEME_CDR(future_checkeds);
01599     phase++;
01600   }
01601   /* Now all the modules to check are in the past_checkeds
01602      list of hash tables. */
01603 
01604   /* Transfers phase-#f modules first. */
01605   {
01606     int i;
01607     Scheme_Hash_Table *ht;
01608     
01609     scheme_prepare_label_env(to_env);
01610 
01611     ht = nophase_checked;
01612     for (i = ht->size; i--; ) {
01613       if (ht->vals[i]) {
01614         name = ht->keys[i];
01615         
01616         if (!SAME_OBJ(name, kernel_modname)) {
01617 
01618           LOG_ATTACH(printf("Copying no-phase %s\n", scheme_write_to_string(name, NULL)));
01619           
01620           m2 = (Scheme_Module *)scheme_hash_get(from_env->module_registry, name);
01621           scheme_hash_set(to_env->module_registry, name, (Scheme_Object *)m2);
01622 
01623           menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(from_env->label_env->modchain), name);
01624           menv2 = scheme_copy_module_env(menv, to_env->label_env, to_env->label_env->modchain, menv->phase + 1);
01625           check_phase(menv2, to_env->label_env, 0);
01626           scheme_hash_set(MODCHAIN_TABLE(to_env->label_env->modchain), name, (Scheme_Object *)menv2);
01627 
01628           if (menv->attached)
01629             menv2->attached = 1;
01630 
01631           /* Push name onto notify list: */
01632           if (!same_namespace)
01633             notifies = scheme_make_pair(name, notifies);
01634         }
01635       }
01636     }
01637   }
01638 
01639   /* Get modchain at `phase': */
01640   {
01641     int i;
01642     Scheme_Env *te = to_env;
01643     from_modchain = from_env->modchain;
01644     to_modchain = to_env->modchain;
01645     for (i = from_env->phase; i < phase; i++) {
01646       from_modchain = SCHEME_VEC_ELS(from_modchain)[1];
01647 
01648       scheme_prepare_exp_env(te);
01649       te = te->exp_env;
01650       to_modchain = SCHEME_VEC_ELS(to_modchain)[1];
01651     }
01652   }
01653 
01654   /* Go through that list, this time tranferring module instances. */
01655   /* Again, outer loop iterates through phases. */
01656   while (!SCHEME_NULLP(past_checkeds)) {
01657     /* Inner loop iterates through requires within a phase. */
01658     int i;
01659 
01660     checked = (Scheme_Hash_Table *)SCHEME_CAR(past_checkeds);
01661 
01662     LOG_ATTACH(printf("Copying %d (%p)\n", phase, checked));
01663 
01664     if (phase >= 0)
01665       check_modchain_consistency(MODCHAIN_TABLE(to_modchain), phase);
01666 
01667     for (i = checked->size; i--; ) {
01668       if (checked->vals[i]) {
01669        name = checked->keys[i];
01670         just_declare = SCHEME_FALSEP(checked->vals[i]);
01671 
01672        if (!SAME_OBJ(name, kernel_modname)) {
01673          menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(from_modchain), name);
01674          
01675          LOG_ATTACH(printf("Copy %d %s\n", phase, scheme_write_to_string(name, 0)));
01676 
01677          menv2 = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(to_modchain), name);
01678          if (!menv2) {
01679            /* Clone/copy menv for the new namespace: */
01680             if ((phase >= 0) && !just_declare) {
01681               menv2 = scheme_copy_module_env(menv, to_env, to_modchain, orig_phase);
01682               if (menv->attached)
01683                 menv2->attached = 1;
01684               
01685               check_phase(menv2, NULL, phase);
01686               scheme_hash_set(MODCHAIN_TABLE(to_modchain), name, (Scheme_Object *)menv2);
01687             }
01688            scheme_hash_set(to_env->module_registry, name, (Scheme_Object *)menv->module);
01689            scheme_hash_set(to_env->export_registry, name, (Scheme_Object *)menv->module->me);
01690            
01691            /* Push name onto notify list: */
01692            if (!same_namespace)
01693              notifies = scheme_make_pair(name, notifies);
01694          }
01695        }
01696       }
01697     }
01698     
01699     past_checkeds = SCHEME_CDR(past_checkeds);
01700     from_modchain = SCHEME_VEC_ELS(from_modchain)[2];
01701     if (phase > 0)
01702       to_modchain = SCHEME_VEC_ELS(to_modchain)[2];   
01703     --phase;
01704   }
01705 
01706   /* Notify module name resolver of attached modules: */
01707   {
01708     Scheme_Cont_Frame_Data cframe;
01709     Scheme_Config *config;
01710 
01711     config = scheme_current_config();
01712     
01713     if (set_env_for_notify) {
01714       config = scheme_extend_config(scheme_current_config(),
01715                                 MZCONFIG_ENV,
01716                                 (Scheme_Object *)to_env);
01717   
01718       scheme_push_continuation_frame(&cframe);
01719       scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
01720     }
01721 
01722     resolver = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_RESOLVER);
01723     while (!SCHEME_NULLP(notifies)) {
01724       a[0] = SCHEME_CAR(notifies);
01725 
01726       scheme_apply(resolver, 1, a);
01727       
01728       notifies = SCHEME_CDR(notifies);
01729     }
01730 
01731     if (set_env_for_notify) {
01732       scheme_pop_continuation_frame(&cframe);
01733     }
01734   }
01735 
01736   return scheme_void;
01737 }
01738 
01739 static Scheme_Object *namespace_unprotect_module(int argc, Scheme_Object *argv[])
01740 {
01741   Scheme_Env *to_env, *menv2;
01742   Scheme_Object *name, *to_modchain, *insp, *code_insp;
01743 
01744   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_inspector_type))
01745     scheme_wrong_type("namespace-unprotect-module", "inspector", 0, argc, argv);
01746 
01747   insp = argv[0];
01748   if (argc > 2)
01749     to_env = (Scheme_Env *)argv[2];
01750   else
01751     to_env = scheme_get_env(NULL);
01752 
01753   name = scheme_module_resolve(scheme_make_modidx(argv[1], scheme_false, scheme_false), 0);
01754 
01755   to_modchain = to_env->modchain;
01756 
01757   code_insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
01758 
01759   if (!SAME_OBJ(name, kernel_modname)) {
01760     menv2 = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(to_modchain), name);
01761 
01762     if (!menv2) {
01763       scheme_arg_mismatch("namespace-unprotect-module",
01764                        "module not instantiated (in the target namespace): ",
01765                        name);
01766     }
01767 
01768     if (!scheme_module_protected_wrt(menv2->insp, insp) && !menv2->attached) {
01769       code_insp = scheme_make_inspector(code_insp);
01770       menv2->insp = code_insp;
01771     }
01772   }
01773 
01774   return scheme_void;
01775 }
01776 
01777 static int plain_char(int c)
01778 {
01779   return (((c >= 'a') && (c <= 'z'))
01780           || ((c >= 'A') && (c <= 'Z'))
01781           || ((c >= '0') && (c <= '9'))
01782           || (c == '-')
01783           || (c == '_')
01784           || (c == '+'));
01785 }
01786 
01787 static int ok_hex(int c)
01788 {
01789   return (((c >= 'a') && (c <= 'f'))
01790           || ((c >= '0') && (c <= '9')));
01791 }
01792 
01793 static int ok_escape(int c1, int c2)
01794 {
01795   c1 = (((c1 >= 'a') && (c1 <= 'f'))
01796         ? (c1 - 'a' + 10)
01797         : (c1 - '0'));
01798   c2 = (((c2 >= 'a') && (c2 <= 'f'))
01799         ? (c2 - 'a' + 10)
01800         : (c2 - '0'));
01801 
01802   c1 = (c1 << 4) + c2;
01803   
01804   if (plain_char(c1))
01805     return 0;
01806   else
01807     return 1;
01808 }
01809 
01810 static int ok_path_string(Scheme_Object *obj, int dir_ok, int just_file_ok, int file_end_ok, int for_planet)
01811 {
01812   mzchar *s = SCHEME_CHAR_STR_VAL(obj);
01813   int i = SCHEME_CHAR_STRLEN_VAL(obj), c, start_package_pos = 0, end_package_pos = 0;
01814   int prev_was_slash = 0, saw_slash = !file_end_ok, saw_dot = 0;
01815 
01816   if (!i)
01817     return 0;
01818   if (s[0] == '/')
01819     return 0;
01820   if (s[i - 1] == '/')
01821     return 0;
01822 
01823   if (for_planet) {
01824     /* Must have at least two slashes, and a version spec is allowed between them */
01825     int j, counter = 0, colon1_pos = 0, colon2_pos = 0;
01826     for (j = 0; j < i; j++) {
01827       c = s[j];
01828       if (c == '/') {
01829         counter++;
01830         if (counter == 1)
01831           start_package_pos = j + 1;
01832         else if (counter == 2)
01833           end_package_pos = j;
01834       } else if (c == ':') {
01835         if (counter == 1) {
01836           if (colon2_pos)
01837             return 0;
01838           else if (colon1_pos)
01839             colon2_pos = j;
01840           else
01841             colon1_pos = j;
01842         }
01843       }
01844     }
01845 
01846     if (counter == 1)
01847       end_package_pos = i;
01848 
01849     if (end_package_pos <= start_package_pos)
01850       return 0;
01851 
01852     if (colon1_pos) {
01853       /* Check that the version spec is well-formed, leaving the rest to the loop below */
01854       int colon1_end = (colon2_pos ? colon2_pos : end_package_pos);
01855       
01856       if (colon1_end == (colon1_pos + 1))
01857         return 0;
01858       for (j = colon1_pos + 1; j < colon1_end; j++) {
01859         c = s[j];
01860         if (!((c >= '0') && (c <= '9')))
01861           return 0;
01862       }
01863 
01864       if (colon2_pos) {
01865         colon2_pos++;
01866         c = s[colon2_pos];
01867         if ((c == '<') || (c == '>')) {
01868           if (s[colon2_pos+1] == '=')
01869             colon2_pos += 2;
01870           else
01871             return 0;
01872         } else if (c == '=') {
01873           colon2_pos += 1;
01874         } else {
01875           if ((c >= '0') && (c <= '9')) {
01876             /* check for range: */
01877             for (j = colon2_pos; j < end_package_pos; j++) {
01878               if (s[j] == '-') {
01879                 colon2_pos = j + 1;
01880                 break;
01881               } else if (!((c >= '0') && (c <= '9')))
01882                 return 0;
01883             }
01884           }
01885         }
01886         if (end_package_pos == colon2_pos)
01887           return 0;
01888         
01889         for (j = colon2_pos; j < end_package_pos; j++) {
01890           c = s[j];
01891           if (!((c >= '0') && (c <= '9')))
01892             return 0;
01893         }
01894       }
01895 
01896       /* tell loop below to ignore the version part: */
01897       start_package_pos = colon1_pos;
01898     } else {
01899       /* package must have normal directory syntax */
01900       start_package_pos = end_package_pos = 0;
01901     }
01902   }
01903 
01904   while (i--) {
01905     c = s[i];
01906     if (c == '/') {
01907       saw_slash = 1;
01908       if (prev_was_slash)
01909         return 0;
01910       prev_was_slash = 1;
01911     } else if (c == '.') {
01912       if (s[i+1] && (s[i+1] != '/') && (s[i+1] != '.')) {
01913         if (saw_slash) {
01914           /* can't have suffix on a directory */
01915           return 0;
01916         }
01917         saw_dot = 1;
01918       }
01919       prev_was_slash = 0;
01920     } else {
01921       if (plain_char(c)
01922           || ((c == '%')
01923               && ok_hex(s[i+1])
01924               && ok_hex(s[i+2])
01925               && ok_escape(s[i+1], s[i+2]))) {
01926         prev_was_slash = 0;
01927       } else if ((i < start_package_pos) || (i >= end_package_pos))
01928         return 0;
01929       else {
01930         prev_was_slash = 0;
01931       }
01932     }
01933   }
01934 
01935   if (!just_file_ok) {
01936     if (saw_dot && !saw_slash) {
01937       /* can't have a file name with no directory */
01938       return 0;
01939     }
01940   }
01941 
01942   if (!dir_ok) {
01943     for (i = 0; s[i]; i++) {
01944       if (s[i] == '.') {
01945         if (!s[i+1] || (s[i+1] == '/'))
01946           return 0;
01947         if (s[i+1] == '.')
01948           if (!s[i+2] || (s[i+2] == '/'))
01949             return 0;
01950         while (s[i] == '.') {
01951           i++;
01952         }
01953       }
01954     }
01955   }
01956 
01957   return 1;
01958 }
01959 
01960 static int ok_planet_number(Scheme_Object *a)
01961 {
01962   if (SCHEME_INTP(a)) {
01963     if (SCHEME_INT_VAL(a) >= 0)
01964       return 1;
01965   } else if (SCHEME_BIGNUMP(a)) {
01966     if (SCHEME_BIGPOS(a))
01967       return 1;
01968   }
01969   return 0;
01970 }
01971 
01972 
01973 static int ok_planet_string(Scheme_Object *obj)
01974 {
01975   mzchar *s;
01976   int i, c;
01977 
01978   if (!SCHEME_CHAR_STRINGP(obj))
01979     return 0;
01980 
01981   s  = SCHEME_CHAR_STR_VAL(obj);
01982   i = SCHEME_CHAR_STRLEN_VAL(obj);
01983 
01984   if (!i)
01985     return 0;
01986 
01987   while (i--) {
01988     c = s[i];
01989     if ((c == '%')
01990         && ok_hex(s[i+1])
01991         && ok_hex(s[i+2])
01992         && ok_escape(s[i+1], s[i+2])) {
01993       /* ok */
01994     } else if (plain_char(c) || (c == '.')) {
01995       /* ok */
01996     } else
01997       return 0;
01998   }
01999 
02000   return 1;
02001 }
02002 
02003 int scheme_is_module_path(Scheme_Object *obj)
02004 {
02005   if (SCHEME_CHAR_STRINGP(obj)) {
02006     return ok_path_string(obj, 1, 1, 1, 0);
02007   }
02008 
02009   if (SCHEME_SYMBOLP(obj)) {
02010     obj = scheme_make_sized_offset_utf8_string((char *)(obj),
02011                                                SCHEME_SYMSTR_OFFSET(obj),
02012                                                SCHEME_SYM_LEN(obj));
02013     return ok_path_string(obj, 0, 0, 0, 0);
02014   }
02015 
02016   if (SCHEME_PAIRP(obj)) {
02017     if (SAME_OBJ(SCHEME_CAR(obj), quote_symbol)) {
02018       obj = SCHEME_CDR(obj);
02019       if (SCHEME_PAIRP(obj)) {
02020         if (SCHEME_NULLP(SCHEME_CDR(obj))) {
02021           obj = SCHEME_CAR(obj);
02022           return SCHEME_SYMBOLP(obj);
02023       } else
02024           return 0;
02025       } else
02026         return 0;
02027     } else if (SAME_OBJ(SCHEME_CAR(obj), lib_symbol)) {
02028       obj = SCHEME_CDR(obj);
02029       if (SCHEME_PAIRP(obj)) {
02030         Scheme_Object *a;
02031         int is_first = 1;
02032         while (SCHEME_PAIRP(obj)) {
02033           a = SCHEME_CAR(obj);
02034           if (SCHEME_CHAR_STRINGP(a)) {
02035             if (!ok_path_string(a, 0, is_first, is_first, 0))
02036               return 0;
02037           } else
02038             return 0;
02039           obj = SCHEME_CDR(obj);
02040           is_first = 0;
02041         }
02042         if (SCHEME_NULLP(obj))
02043           return 1;
02044         else
02045           return 0;
02046       } else
02047         return 0;
02048     } else if (SAME_OBJ(SCHEME_CAR(obj), file_symbol)) {
02049       obj = SCHEME_CDR(obj);
02050       if (SCHEME_PAIRP(obj) && SCHEME_NULLP(SCHEME_CDR(obj))) {
02051         int i;
02052         mzchar *s;
02053         obj = SCHEME_CAR(obj);
02054         if (!SCHEME_CHAR_STRINGP(obj))
02055           return 0;
02056         s = SCHEME_CHAR_STR_VAL(obj);
02057         i = SCHEME_CHAR_STRLEN_VAL(obj);
02058         if (!i)
02059           return 0;
02060         while (i--) {
02061           if (!s[i])
02062             return 0;
02063         }
02064         return 1;
02065       }
02066     } else if (SAME_OBJ(SCHEME_CAR(obj), planet_symbol)) {
02067       Scheme_Object *a, *subs;
02068       int len, counter;
02069 
02070       len = scheme_proper_list_length(obj);
02071 
02072       if (len == 2) {
02073         /* Symbolic or string shorthand? */
02074         obj = SCHEME_CDR(obj);
02075         a = SCHEME_CAR(obj);
02076         if (SCHEME_SYMBOLP(a)) {
02077           obj = scheme_make_sized_offset_utf8_string((char *)(a),
02078                                                      SCHEME_SYMSTR_OFFSET(a),
02079                                                      SCHEME_SYM_LEN(a));
02080           return ok_path_string(obj, 0, 0, 0, 1);
02081         } else if (SCHEME_CHAR_STRINGP(a)) {
02082           return ok_path_string(a, 0, 0, 1, 1);
02083         }
02084       }
02085 
02086       if (len < 3)
02087         return 0;
02088       obj = SCHEME_CDR(obj);
02089       a = SCHEME_CAR(obj);
02090       if (!SCHEME_CHAR_STRINGP(a))
02091         return 0;
02092       if (!ok_path_string(a, 0, 1, 1, 0))
02093         return 0;
02094       obj = SCHEME_CDR(obj);
02095       subs = SCHEME_CDR(obj);
02096       obj = SCHEME_CAR(obj);
02097       len = scheme_proper_list_length(obj);
02098       if (len < 2)
02099         return 0;
02100 
02101       a = SCHEME_CAR(obj);
02102       if (!ok_planet_string(a))
02103         return 0;
02104 
02105       obj = SCHEME_CDR(obj);
02106       a = SCHEME_CAR(obj);
02107       if (!ok_planet_string(a))
02108         return 0;
02109 
02110       /* planet allows a major and minor version number: */
02111       counter = 0;
02112       for (obj = SCHEME_CDR(obj); !SCHEME_NULLP(obj); obj = SCHEME_CDR(obj)) {
02113         if (counter == 2)
02114           return 0;
02115         a = SCHEME_CAR(obj);
02116         if (ok_planet_number(a)) {
02117           /* ok */
02118         } else if ((counter == 1) && SCHEME_PAIRP(a)) {
02119           if (scheme_proper_list_length(a) != 2)
02120             return 0;
02121           if (ok_planet_number(SCHEME_CAR(a))) {
02122             if (ok_planet_number(SCHEME_CADR(a))) {
02123               if (scheme_bin_lt_eq(SCHEME_CAR(a), SCHEME_CADR(a))) {
02124                 /* ok */
02125               } else
02126                 return 0;
02127             } else
02128               return 0;
02129           } else if (SCHEME_SYMBOLP(SCHEME_CAR(a))) {
02130             if (SCHEME_SYM_LEN(SCHEME_CAR(a))) {
02131               int c;
02132               c = SCHEME_SYM_VAL(SCHEME_CAR(a))[0];
02133               if ((c == '=') || (c == '+') || (c == '-')) {
02134                 if (!ok_planet_number(SCHEME_CADR(a)))
02135                   return 0;
02136                 /* else ok */
02137               } else
02138                 return 0;
02139             } else
02140               return 0;
02141           } else
02142             return 0;
02143         } else
02144           return 0;
02145         counter++;
02146       }
02147 
02148       for (; !SCHEME_NULLP(subs); subs = SCHEME_CDR(subs)) {
02149         a = SCHEME_CAR(subs);
02150         if (!SCHEME_CHAR_STRINGP(a))
02151           return 0;
02152         if (!ok_path_string(a, 0, 0, 0, 0))
02153           return 0;
02154       }
02155 
02156       return 1;
02157     }
02158   }
02159 
02160   return 0;
02161 }
02162 
02163 static Scheme_Object *is_module_path(int argc, Scheme_Object **argv)
02164 {
02165   return (scheme_is_module_path(argv[0])
02166           ? scheme_true
02167           : scheme_false);
02168 }
02169 
02170 static int do_add_simple_require_renames(Scheme_Object *rn, 
02171                                          Scheme_Hash_Table *required, Scheme_Object *orig_src,
02172                                          Scheme_Module *im, Scheme_Module_Phase_Exports *pt,
02173                                          Scheme_Object *idx,
02174                                          Scheme_Object *marshal_phase_index,
02175                                          Scheme_Object *src_phase_index,
02176                                          int can_override)
02177 {
02178   int i, saw_mb, numvals;
02179   Scheme_Object **exs, **exss, **exsns, *midx, *info, *vec, *nml, *mark_src, **exinsps;
02180   char *exets;
02181   int with_shared = 1;
02182 
02183   saw_mb = 0;
02184 
02185   if (!pt->num_provides)
02186     return 0;
02187 
02188   if (with_shared) {
02189     if (!pt->src_modidx)
02190       pt->src_modidx = im->me->src_modidx;
02191     scheme_extend_module_rename_with_shared(rn, idx, pt, 
02192                                             marshal_phase_index, 
02193                                             scheme_make_integer(0), 
02194                                             scheme_null,
02195                                             1);
02196   }
02197 
02198   mark_src = scheme_rename_to_stx(rn);
02199 
02200   exs = pt->provides;
02201   exsns = pt->provide_src_names;
02202   exss = pt->provide_srcs;
02203   exets = pt->provide_src_phases;
02204   exinsps = pt->provide_insps;
02205   numvals = pt->num_var_provides;
02206   for (i = pt->num_provides; i--; ) {
02207     if (exss && !SCHEME_FALSEP(exss[i]))
02208       midx = scheme_modidx_shift(exss[i], im->me->src_modidx, idx);
02209     else
02210       midx = idx;
02211     if (!with_shared) {
02212       scheme_extend_module_rename(rn, midx, exs[i], exsns[i], idx, exs[i], 
02213                                   exets ? exets[i] : 0, src_phase_index, pt->phase_index, 
02214                                   exinsps ? exinsps[i] : NULL, 1);
02215     }
02216     if (SAME_OBJ(exs[i], module_begin_symbol))
02217       saw_mb = 1;
02218 
02219     if (required) {
02220       vec = scheme_make_vector(10, NULL);
02221       nml = scheme_make_pair(idx, scheme_null);
02222       SCHEME_VEC_ELS(vec)[0] = nml;
02223       SCHEME_VEC_ELS(vec)[1] = midx;
02224       SCHEME_VEC_ELS(vec)[2] = exsns[i];
02225       SCHEME_VEC_ELS(vec)[3] = ((i < numvals) ? scheme_true : scheme_false);
02226       SCHEME_VEC_ELS(vec)[4] = exs[i];
02227       SCHEME_VEC_ELS(vec)[5] = orig_src;
02228       SCHEME_VEC_ELS(vec)[6] = mark_src;
02229       SCHEME_VEC_ELS(vec)[7] = (can_override ? scheme_true : scheme_false);
02230       SCHEME_VEC_ELS(vec)[8] = exets ? scheme_make_integer(exets[i]) : scheme_false;
02231       SCHEME_VEC_ELS(vec)[9] = exinsps ? exinsps[i] : scheme_false;
02232       scheme_hash_set(required, exs[i], vec);
02233     }
02234   }
02235 
02236   if (!with_shared) {
02237     info = cons(idx, cons(marshal_phase_index, 
02238                           cons(scheme_make_integer(0),
02239                                cons(scheme_null, scheme_false))));
02240     scheme_save_module_rename_unmarshal(rn, info);
02241   }
02242 
02243   return saw_mb;
02244 }
02245 
02246 static Scheme_Hash_Table *get_required_from_tables(Scheme_Hash_Table *tables, Scheme_Object *phase)
02247 {
02248   Scheme_Object *vec;
02249 
02250   if (!tables)
02251     return NULL;
02252   
02253   vec = scheme_hash_get(tables, phase);
02254   if (!vec) {
02255     Scheme_Hash_Table *res;
02256     vec = scheme_make_vector(3, NULL);
02257     res = scheme_make_hash_table(SCHEME_hash_ptr);
02258     SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)res;
02259     scheme_hash_set(tables, phase, vec);
02260   }
02261 
02262   return (Scheme_Hash_Table *)SCHEME_VEC_ELS(vec)[1];
02263 }
02264 
02265 static int add_simple_require_renames(Scheme_Object *orig_src,
02266                                       Scheme_Object *rn_set, 
02267                                       Scheme_Hash_Table *tables,
02268                                       Scheme_Module *im, Scheme_Object *idx,
02269                                       Scheme_Object *import_shift /* = src_phase_index */,
02270                                       Scheme_Object *only_export_phase,
02271                                       int can_override)
02272 {
02273   int saw_mb;
02274   Scheme_Object *phase;
02275 
02276   if (im->me->rt
02277       && (!only_export_phase || SAME_OBJ(only_export_phase, scheme_make_integer(0))))
02278     saw_mb = do_add_simple_require_renames(scheme_get_module_rename_from_set(rn_set, import_shift, 1), 
02279                                            get_required_from_tables(tables, import_shift),
02280                                            orig_src, im, im->me->rt, idx,
02281                                            scheme_make_integer(0),
02282                                            import_shift,
02283                                            can_override);
02284   else
02285     saw_mb = 0;
02286   
02287   if (im->me->et
02288       && (!only_export_phase || SAME_OBJ(only_export_phase, scheme_make_integer(1)))) {
02289     if (SCHEME_FALSEP(import_shift))
02290       phase = scheme_false;
02291     else
02292       phase = scheme_bin_plus(scheme_make_integer(1), import_shift);
02293     do_add_simple_require_renames(scheme_get_module_rename_from_set(rn_set, phase, 1), 
02294                                   get_required_from_tables(tables, phase),
02295                                   orig_src, im, im->me->et, idx,
02296                                   scheme_make_integer(1),
02297                                   import_shift,
02298                                   can_override);
02299   }
02300 
02301   if (im->me->dt
02302       && (!only_export_phase || SAME_OBJ(only_export_phase, scheme_false))) {
02303     do_add_simple_require_renames(scheme_get_module_rename_from_set(rn_set, scheme_false, 1), 
02304                                   get_required_from_tables(tables, scheme_false),
02305                                   orig_src, im, im->me->dt, idx,
02306                                   scheme_false,
02307                                   import_shift,
02308                                   can_override);
02309   }
02310 
02311   if (im->me->other_phases) {
02312     Scheme_Object *val, *key;
02313     int i;
02314     for (i = 0; i < im->me->other_phases->size; i++) {
02315       val = im->me->other_phases->vals[i];
02316       if (val) {
02317         key = im->me->other_phases->keys[i];
02318         if (!only_export_phase || scheme_eqv(only_export_phase, key)) {
02319           if (SCHEME_FALSEP(import_shift))
02320             phase = scheme_false;
02321           else
02322             phase = scheme_bin_plus(key, import_shift);
02323           do_add_simple_require_renames(scheme_get_module_rename_from_set(rn_set, phase, 1), 
02324                                         get_required_from_tables(tables, phase),
02325                                         orig_src, im, (Scheme_Module_Phase_Exports *)val, idx,
02326                                         key,
02327                                         import_shift,
02328                                         can_override);
02329         }
02330       }
02331     }
02332   }
02333 
02334   return saw_mb;
02335 }
02336 
02337 void scheme_prep_namespace_rename(Scheme_Env *menv)
02338 {
02339   scheme_prepare_exp_env(menv);
02340   start_module(menv->module, menv, 0, NULL, -1, 1, menv->phase, scheme_null);
02341 
02342   if (!menv->rename_set_ready) {
02343     if (menv->module->rn_stx) {
02344       Scheme_Object *rns;
02345       Scheme_Module *m = menv->module;
02346 
02347       scheme_prepare_env_renames(menv, mzMOD_RENAME_NORMAL);
02348 
02349       if (SAME_OBJ(scheme_true, m->rn_stx)) {
02350        /* Reconstruct renames based on defns and requires. This case is
02351            used only when it's easy to reconstruct: no renames, no for-syntax
02352            definitions, etc. */
02353        int i;
02354        Scheme_Module *im;
02355        Scheme_Object *l, *idx, *one_rn, *shift, *name;
02356 
02357        rns = menv->rename_set;
02358         one_rn = scheme_get_module_rename_from_set(rns, scheme_make_integer(0), 1);
02359 
02360        /* Local, provided: */
02361        for (i = 0; i < m->me->rt->num_provides; i++) {
02362          if (SCHEME_FALSEP(m->me->rt->provide_srcs[i])) {
02363            name = m->me->rt->provide_src_names[i];
02364            scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0, 
02365                                         scheme_make_integer(0), NULL, NULL, 0);
02366          }
02367        }
02368        /* Local, not provided: */
02369        for (i = 0; i < m->num_indirect_provides; i++) {
02370          name = m->indirect_provides[i];
02371          scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0, 
02372                                       scheme_make_integer(0), NULL, NULL, 0);
02373        }
02374         for (i = 0; i < m->num_indirect_syntax_provides; i++) {
02375          name = m->indirect_syntax_provides[i];
02376          scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0, 
02377                                       scheme_make_integer(0), NULL, NULL, 0);
02378        }
02379 
02380         one_rn = scheme_get_module_rename_from_set(rns, scheme_make_integer(1), 1);
02381 
02382        /* Required: */
02383         for (i = -4; i < (menv->other_require_names ? menv->other_require_names->size : 0); i++) {
02384           switch (i) {
02385           case -4:
02386             l = menv->require_names;
02387             shift = scheme_make_integer(0);
02388             break;
02389           case -3:
02390             l = menv->et_require_names;
02391             shift = scheme_make_integer(1);
02392             break;
02393           case -2:
02394             l = menv->tt_require_names;
02395             shift = scheme_make_integer(-1);
02396             break;
02397           case -1:
02398             l = menv->dt_require_names;
02399             shift = scheme_false;
02400             break;
02401           default:
02402             l = menv->other_require_names->vals[i];
02403             shift = menv->other_require_names->keys[i];
02404             break;
02405           }
02406 
02407           if (l) {
02408             /* Do initial import first to get shadowing right: */
02409             l = scheme_reverse(l);
02410             for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
02411               idx = SCHEME_CAR(l);
02412               name = scheme_module_resolve(idx, 0);
02413               
02414               if (SAME_OBJ(name, kernel_modname))
02415                 im = kernel;
02416               else
02417                 im = (Scheme_Module *)scheme_hash_get(menv->module_registry, name);
02418               
02419               add_simple_require_renames(NULL, rns, NULL, im, idx, shift, NULL, 0);
02420             }
02421           }
02422         }
02423        
02424        rns = scheme_rename_to_stx(rns);
02425        m->rn_stx = rns;
02426       } else if (SCHEME_PAIRP(m->rn_stx)) {
02427        /* Delayed shift: */
02428        Scheme_Object *rn_stx, *midx;
02429        rn_stx = SCHEME_CAR(m->rn_stx);
02430        midx = SCHEME_CDR(m->rn_stx);
02431        rns = scheme_stx_to_rename(rn_stx);
02432        rns = scheme_stx_shift_rename_set(rns, midx, m->self_modidx);
02433        rn_stx = scheme_rename_to_stx(rns);
02434        m->rn_stx = rn_stx;
02435       }
02436 
02437       rns = scheme_stx_to_rename(m->rn_stx);
02438       scheme_append_rename_set_to_env(rns, menv);
02439       menv->rename_set_ready = 1;
02440     }
02441   }
02442 }
02443 
02444 Scheme_Object *scheme_module_to_namespace(Scheme_Object *name, Scheme_Env *env)
02445 {
02446   Scheme_Env *menv;
02447   Scheme_Object *modchain;
02448 
02449   name = scheme_module_resolve(scheme_make_modidx(name, scheme_false, scheme_false), 1);
02450 
02451   modchain = env->modchain;
02452   menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(modchain), name);
02453   if (!menv) {
02454     if (scheme_hash_get(env->module_registry, name))
02455       scheme_arg_mismatch("module->namespace",
02456                        "module not instantiated in the current namespace: ",
02457                        name);
02458     else
02459       scheme_arg_mismatch("module->namespace",
02460                        "unknown module in the current namespace: ",
02461                        name);
02462   }
02463 
02464   {
02465     Scheme_Object *insp;
02466     insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
02467     if (scheme_module_protected_wrt(menv->insp, insp) || menv->attached) {
02468       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
02469                      "module->namespace: current code inspector cannot access namespace of module: %D",
02470                      name);
02471     }
02472   }
02473 
02474   scheme_prep_namespace_rename(menv);
02475 
02476   return (Scheme_Object *)menv;
02477 }
02478 
02479 static Scheme_Object *module_to_namespace(int argc, Scheme_Object *argv[])
02480 {
02481   Scheme_Env *env;
02482 
02483   env = scheme_get_env(NULL);
02484 
02485   if (!SCHEME_PATHP(argv[0])
02486       && !scheme_is_module_path(argv[0]))
02487     scheme_wrong_type("module->namespace", "path or module-path", 0, argc, argv);
02488 
02489   return scheme_module_to_namespace(argv[0], env);
02490 }
02491 
02492 static Scheme_Object *module_to_lang_info(int argc, Scheme_Object *argv[])
02493 {
02494   Scheme_Env *env;
02495   Scheme_Object *name;
02496   Scheme_Module *m;
02497 
02498   env = scheme_get_env(NULL);
02499 
02500   if (!SCHEME_PATHP(argv[0])
02501       && !scheme_is_module_path(argv[0]))
02502     scheme_wrong_type("module->language-info", "path or module-path", 0, argc, argv);
02503 
02504   name = scheme_module_resolve(scheme_make_modidx(argv[0], scheme_false, scheme_false), 1);
02505 
02506   env = scheme_get_env(NULL);
02507   m = (Scheme_Module *)scheme_hash_get(env->module_registry, name);
02508 
02509   if (!m)
02510     scheme_arg_mismatch("module->laguage-info",
02511                         "unknown module in the current namespace: ",
02512                         name);
02513 
02514   return (m->lang_info ? m->lang_info : scheme_false);
02515 }
02516 
02517 
02518 static Scheme_Object *module_compiled_p(int argc, Scheme_Object *argv[])
02519 {
02520   Scheme_Module *m;
02521 
02522   m = scheme_extract_compiled_module(argv[0]);
02523       
02524   return (m ? scheme_true : scheme_false);
02525 }
02526 
02527 static Scheme_Object *module_compiled_name(int argc, Scheme_Object *argv[])
02528 {
02529   Scheme_Module *m;
02530 
02531   m = scheme_extract_compiled_module(argv[0]);
02532       
02533   if (m) {
02534     return SCHEME_PTR_VAL(m->modname);
02535   }
02536 
02537   scheme_wrong_type("module-compiled-name", "compiled module declaration", 0, argc, argv);
02538   return NULL;
02539 }
02540 
02541 static Scheme_Object *module_compiled_imports(int argc, Scheme_Object *argv[])
02542 {
02543   Scheme_Module *m;
02544   Scheme_Object *l;
02545   int i;
02546 
02547   m = scheme_extract_compiled_module(argv[0]);
02548 
02549   if (m) {
02550     l = scheme_null;
02551     if (!SCHEME_NULLP(m->requires))
02552       l = scheme_make_pair(scheme_make_pair(scheme_make_integer(0),
02553                                             m->requires),
02554                            l);
02555     if (!SCHEME_NULLP(m->et_requires))
02556       l = scheme_make_pair(scheme_make_pair(scheme_make_integer(1),
02557                                             m->et_requires),
02558                            l);
02559     if (!SCHEME_NULLP(m->tt_requires))
02560       l = scheme_make_pair(scheme_make_pair(scheme_make_integer(-1),
02561                                             m->tt_requires),
02562                            l);
02563     if (!SCHEME_NULLP(m->dt_requires))
02564       l = scheme_make_pair(scheme_make_pair(scheme_false,
02565                                             m->dt_requires),
02566                            l);
02567 
02568     if (m->other_requires) {
02569       for (i = 0; i < m->other_requires->size; i++) {
02570         if (m->other_requires->vals[i]) {
02571           l = scheme_make_pair(scheme_make_pair(m->other_requires->keys[i],
02572                                                 m->other_requires->vals[i]),
02573                                l);
02574         }
02575       }
02576     }
02577     
02578     return l;
02579   }
02580 
02581   scheme_wrong_type("module-compiled-imports", "compiled module declaration", 0, argc, argv);
02582   return NULL;
02583 }
02584 
02585 static Scheme_Object *make_provide_desc(Scheme_Module_Phase_Exports *pt, int i)
02586 {
02587   return scheme_make_pair(pt->provides[i],
02588                           scheme_make_pair((pt->provide_nominal_srcs
02589                                             ? pt->provide_nominal_srcs[i]
02590                                             : scheme_null),
02591                                            scheme_null));
02592 }
02593 
02594 static Scheme_Object *module_compiled_exports(int argc, Scheme_Object *argv[])
02595 {
02596   Scheme_Module *m;
02597   Scheme_Object *a[2];
02598   Scheme_Object *ml, *vl, *val_l, *mac_l;
02599   Scheme_Module_Phase_Exports *pt;
02600   int i, n, k;
02601 
02602   m = scheme_extract_compiled_module(argv[0]);
02603 
02604   if (m) {
02605     val_l = scheme_null;
02606     mac_l = scheme_null;
02607 
02608     for (k = -3; k < (m->me->other_phases ? m->me->other_phases->size : 0); k++) {
02609       switch(k) {
02610       case -3:
02611         pt = m->me->rt;
02612         break;
02613       case -2:
02614         pt = m->me->et;
02615         break;
02616       case -1:
02617         pt = m->me->dt;
02618         break;
02619       default:
02620         pt = (Scheme_Module_Phase_Exports *)m->me->other_phases->vals[k];
02621         break;
02622       }
02623 
02624       if (pt) {
02625         ml = scheme_null;
02626         vl = scheme_null;
02627         n = pt->num_var_provides;
02628         for (i = pt->num_provides - 1; i >= n; --i) {
02629           ml = scheme_make_pair(make_provide_desc(pt, i), ml);
02630         }
02631         for (; i >= 0; --i) {
02632           vl = scheme_make_pair(make_provide_desc(pt, i), vl);
02633         }
02634 
02635         if (!SCHEME_NULLP(vl))
02636           val_l = scheme_make_pair(scheme_make_pair(pt->phase_index, vl), 
02637                                    val_l);
02638 
02639         if (!SCHEME_NULLP(ml))
02640           mac_l = scheme_make_pair(scheme_make_pair(pt->phase_index, ml),
02641                                    mac_l);
02642       }
02643     }
02644     
02645     a[0] = val_l;
02646     a[1] = mac_l;
02647     return scheme_values(2, a);
02648   }
02649 
02650   scheme_wrong_type("module-compiled-exports", "compiled module declaration", 0, argc, argv);
02651   return NULL;
02652 }
02653 
02654 static Scheme_Object *module_compiled_lang_info(int argc, Scheme_Object *argv[])
02655 {
02656   Scheme_Module *m;
02657 
02658   m = scheme_extract_compiled_module(argv[0]);
02659 
02660   if (m) {
02661     return (m->lang_info ? m->lang_info : scheme_false);
02662   }
02663 
02664   scheme_wrong_type("module-compiled-language-info", "compiled module declaration", 0, argc, argv);
02665   return NULL;
02666 }
02667 
02668 static Scheme_Object *module_path_index_p(int argc, Scheme_Object *argv[])
02669 {
02670   return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type)
02671          ? scheme_true
02672          : scheme_false);
02673 }
02674 
02675 static Scheme_Object *module_path_index_resolve(int argc, Scheme_Object *argv[])
02676 {
02677   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type))
02678     scheme_wrong_type("module-path-index-resolve", "module-path-index", 0, argc, argv);
02679 
02680   return scheme_module_resolve(argv[0], 0);
02681 }
02682 
02683 static Scheme_Object *module_path_index_split(int argc, Scheme_Object *argv[])
02684 {
02685   Scheme_Modidx *modidx;
02686   Scheme_Object *a[2];
02687 
02688   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type))
02689     scheme_wrong_type("module-path-index-split", "module-path-index", 0, argc, argv);
02690 
02691   modidx = (Scheme_Modidx *)argv[0];
02692   a[0] = modidx->path;
02693   a[1] = modidx->base;
02694 
02695   return scheme_values(2, a);
02696 }
02697 
02698 static Scheme_Object *module_path_index_join(int argc, Scheme_Object *argv[])
02699 {
02700   if (!SCHEME_PATHP(argv[0])
02701       && !scheme_is_module_path(argv[0])
02702       && !SCHEME_FALSEP(argv[0]))
02703     scheme_wrong_type("module-path-index-join", "module path, path, or #f", 0, argc, argv);
02704 
02705   if (argv[1]) { /* mzc will generate NULL sometimes; see scheme_declare_module(), below */
02706     if (SCHEME_TRUEP(argv[1])
02707        && !SCHEME_MODNAMEP(argv[1])
02708        && !SAME_TYPE(SCHEME_TYPE(argv[1]), scheme_module_index_type))
02709       scheme_wrong_type("module-path-index-join", "module-path-index, resolved-module-path, or #f", 1, argc, argv);
02710 
02711     if (SCHEME_FALSEP(argv[0]) && !SCHEME_FALSEP(argv[1]))
02712       scheme_arg_mismatch("module-path-index-join", 
02713                           "first argument cannot be #f when second argument is not #f: ",
02714                           argv[1]);
02715   }
02716 
02717   return scheme_make_modidx(argv[0], argv[1], scheme_false);
02718 }
02719 
02720 void scheme_init_module_path_table()
02721 {
02722   REGISTER_SO(modpath_table);
02723   modpath_table = scheme_make_weak_equal_table();
02724 }
02725 
02726 Scheme_Object *scheme_intern_resolved_module_path_worker(Scheme_Object *o)
02727 {
02728   Scheme_Object *rmp;
02729   Scheme_Bucket *b;
02730   Scheme_Object *return_value;
02731 
02732   mzrt_mutex_lock(modpath_table_mutex);
02733 
02734   rmp = scheme_alloc_small_object();
02735   rmp->type = scheme_resolved_module_path_type;
02736   SCHEME_PTR_VAL(rmp) = o;
02737 
02738   scheme_start_atomic();
02739   b = scheme_bucket_from_table(modpath_table, (const char *)rmp);
02740   scheme_end_atomic_no_swap();
02741   if (!b->val)
02742     b->val = scheme_true;
02743 
02744   return_value = (Scheme_Object *)HT_EXTRACT_WEAK(b->key);
02745 
02746   mzrt_mutex_unlock(modpath_table_mutex);
02747 
02748   return return_value;
02749 }
02750 
02751 Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o)
02752 {
02753 #if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
02754   void *return_payload;
02755   return_payload = scheme_master_fast_path(1, o);
02756   return (Scheme_Object*) return_payload;
02757 #endif
02758   return scheme_intern_resolved_module_path_worker(o);
02759 }
02760 
02761 static Scheme_Object *resolved_module_path_p(int argc, Scheme_Object *argv[])
02762 {
02763   return (SCHEME_MODNAMEP(argv[0])
02764           ? scheme_true
02765           : scheme_false);
02766 }
02767 
02768 static Scheme_Object *make_resolved_module_path(int argc, Scheme_Object *argv[])
02769 {
02770   if (!SCHEME_SYMBOLP(argv[0])
02771       && (!SCHEME_PATHP(argv[0])
02772           || !scheme_is_complete_path(SCHEME_PATH_VAL(argv[0]),
02773                                       SCHEME_PATH_LEN(argv[0]),
02774                                       SCHEME_PLATFORM_PATH_KIND)))
02775     scheme_wrong_type("make-resolved-module-path", "symbol or complete path", 0, argc, argv);
02776 
02777   return scheme_intern_resolved_module_path(argv[0]);
02778 }
02779 
02780 static Scheme_Object *resolved_module_path_name(int argc, Scheme_Object *argv[])
02781 {
02782   if (!SCHEME_MODNAMEP(argv[0]))
02783     scheme_wrong_type("resolved-module-path-name", "resolved-module-path", 0, argc, argv);
02784 
02785   return SCHEME_PTR_VAL(argv[0]);
02786 }
02787 
02788 
02789 static Scheme_Object *module_export_protected_p(int argc, Scheme_Object **argv)
02790 {
02791   Scheme_Env *env;
02792   Scheme_Object *modname, *mv, *name;
02793   Scheme_Module *m;
02794   int i, count;
02795 
02796   if (!SCHEME_MODNAMEP(argv[0])
02797       && !SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type))
02798     scheme_wrong_type("module-provide-protected?", "resolved-module-path or module-path-index", 0, argc, argv);
02799   if (!SCHEME_SYMBOLP(argv[1]))
02800     scheme_wrong_type("module-provide-protected?", "symbol", 1, argc, argv);
02801 
02802   modname = scheme_module_resolve(argv[0], 1);
02803   name = argv[1];
02804 
02805   env = scheme_get_env(NULL);
02806   if (SAME_OBJ(modname, kernel_modname))
02807     mv = (Scheme_Object *)kernel;
02808   else
02809     mv = scheme_hash_get(env->module_registry, modname);
02810   if (!mv) {
02811     scheme_arg_mismatch("module-provide-protected?",
02812                      "unknown module (in the source namespace): ",
02813                      modname);
02814     return NULL;
02815   }
02816 
02817   m = (Scheme_Module *)mv;
02818 
02819   count = m->me->rt->num_provides;
02820   for (i = 0; i < count; i++) {
02821     if (SAME_OBJ(name, m->me->rt->provides[i])) {
02822       if (m->provide_protects && m->provide_protects[i])
02823        return scheme_true;
02824       else
02825        return scheme_false;
02826     }
02827   }
02828 
02829   return scheme_true;
02830 }
02831 
02832 /**********************************************************************/
02833 /*                       basic module operations                      */
02834 /**********************************************************************/
02835 
02836 Scheme_Object *scheme_make_modidx(Scheme_Object *path, 
02837                               Scheme_Object *base_modidx,
02838                               Scheme_Object *resolved)
02839 {
02840   Scheme_Modidx *modidx;
02841 
02842   if (SCHEME_MODNAMEP(path))
02843     return path;
02844   
02845   if (SCHEME_PAIRP(path)
02846       && SAME_OBJ(SCHEME_CAR(path), quote_symbol)
02847       && SCHEME_PAIRP(SCHEME_CDR(path))
02848       && SAME_OBJ(SCHEME_CADR(path), kernel_symbol)
02849       && SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(path)))
02850       && kernel_modidx)
02851     return kernel_modidx;
02852 
02853   modidx = MALLOC_ONE_TAGGED(Scheme_Modidx);
02854   modidx->so.type = scheme_module_index_type;
02855   modidx->path = path;
02856 
02857   /* base is needed only for relative-path strings
02858      and `file' forms: */
02859   if (SCHEME_CHAR_STRINGP(path)
02860       || (SCHEME_PAIRP(path)
02861           && SAME_OBJ(file_symbol, SCHEME_CAR(path))))
02862     modidx->base = base_modidx;
02863   else
02864     modidx->base = scheme_false;
02865 
02866   modidx->resolved = resolved;
02867   
02868   return (Scheme_Object *)modidx;
02869 }
02870 
02871 int same_modidx(Scheme_Object *a, Scheme_Object *b)
02872 {
02873   if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type))
02874     a = ((Scheme_Modidx *)a)->path;
02875   if (SAME_TYPE(SCHEME_TYPE(b), scheme_module_index_type))
02876     b = ((Scheme_Modidx *)b)->path;
02877 
02878   return scheme_equal(a, b);
02879 }
02880 
02881 int same_resolved_modidx(Scheme_Object *a, Scheme_Object *b)
02882 {
02883   if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type))
02884     a = scheme_module_resolve(a, 1);
02885   if (SAME_TYPE(SCHEME_TYPE(b), scheme_module_index_type))
02886     b = scheme_module_resolve(b, 1);
02887 
02888   return scheme_equal(a, b);
02889 }
02890 
02891 static Scheme_Object *_module_resolve_k(void);
02892 
02893 static Scheme_Object *_module_resolve(Scheme_Object *modidx, Scheme_Object *stx, Scheme_Env *env, int load_it)
02894 {
02895   if (SCHEME_MODNAMEP(modidx) || SCHEME_FALSEP(modidx))
02896     return modidx;
02897 
02898   if (SAME_OBJ(modidx, empty_self_modidx))
02899     return empty_self_modname;
02900 
02901   if (SCHEME_FALSEP(((Scheme_Modidx *)modidx)->resolved)) {
02902     /* Need to resolve access path to a module name: */
02903     Scheme_Object *a[4];
02904     Scheme_Object *name, *base;
02905     
02906     base = ((Scheme_Modidx *)modidx)->base;
02907     if (!SCHEME_FALSEP(base)) {
02908 # include "mzstkchk.h"
02909       {
02910        Scheme_Thread *p = scheme_current_thread;
02911        p->ku.k.p1 = (void *)base;
02912        p->ku.k.p2 = (void *)env;
02913        p->ku.k.i1 = load_it;
02914        base = scheme_handle_stack_overflow(_module_resolve_k);
02915       } else {
02916        base = _module_resolve(base, NULL, env, load_it);
02917       }
02918     }
02919 
02920     if (SCHEME_SYMBOLP(base))
02921       base = scheme_false;
02922 
02923     a[0] = ((Scheme_Modidx *)modidx)->path;
02924     a[1] = base;
02925     a[2] = (stx ? stx : scheme_false);
02926     a[3] = (load_it ? scheme_true : scheme_false);
02927     
02928     if (SCHEME_FALSEP(a[0])) {
02929       scheme_arg_mismatch("module-path-index-resolve",
02930                           "\"self\" index has no resolution: ",
02931                           modidx);
02932     }
02933 
02934 
02935     {
02936       Scheme_Cont_Frame_Data cframe;
02937 
02938       if (env) {
02939         Scheme_Config *config;
02940         
02941         config = scheme_extend_config(scheme_current_config(),
02942                                       MZCONFIG_ENV,
02943                                       (Scheme_Object *)env);
02944         scheme_push_continuation_frame(&cframe);
02945         scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
02946       }
02947 
02948       name = scheme_apply(scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_MODULE_RESOLVER), 4, a);
02949 
02950       if (env) {
02951         scheme_pop_continuation_frame(&cframe);
02952       }
02953     }
02954     
02955     if (!SCHEME_MODNAMEP(name)) {
02956       a[0] = name;
02957       scheme_wrong_type("module name resolver", "resolved-module-path", -1, -1, a);
02958     }
02959 
02960     ((Scheme_Modidx *)modidx)->resolved = name;
02961   }
02962 
02963   return ((Scheme_Modidx *)modidx)->resolved;
02964 }
02965 
02966 static Scheme_Object *_module_resolve_k(void)
02967 {
02968   Scheme_Thread *p = scheme_current_thread;
02969   Scheme_Object *base = (Scheme_Object *)p->ku.k.p1;
02970   Scheme_Env *env = (Scheme_Env *)p->ku.k.p2;
02971 
02972   p->ku.k.p1 = NULL;
02973 
02974   return _module_resolve(base, NULL, env, p->ku.k.i1);
02975 }
02976 
02977 Scheme_Object *scheme_module_resolve(Scheme_Object *modidx, int load_it)
02978 {
02979   return _module_resolve(modidx, NULL, NULL, load_it);
02980 }
02981 
02982 Scheme_Object *module_resolve_in_namespace(Scheme_Object *modidx, Scheme_Env *env, int load_it)
02983 {
02984   return _module_resolve(modidx, NULL, env, load_it);
02985 }
02986 
02987 Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx, 
02988                                Scheme_Object *shift_from_modidx,
02989                                Scheme_Object *shift_to_modidx)
02990 {
02991   Scheme_Object *base;
02992 
02993   if (!shift_to_modidx)
02994     return modidx;
02995 
02996   if (SAME_OBJ(modidx, shift_from_modidx))
02997     return shift_to_modidx;
02998 
02999   if (!SAME_TYPE(SCHEME_TYPE(modidx), scheme_module_index_type))
03000     return modidx;
03001   
03002   /* Need to shift relative part? */
03003   base = ((Scheme_Modidx *)modidx)->base;
03004   if (!SCHEME_FALSEP(base)) {
03005     /* FIXME: depth */
03006     Scheme_Object *sbase;
03007     sbase = scheme_modidx_shift(base, shift_from_modidx, shift_to_modidx);
03008 
03009     if (!SAME_OBJ(base, sbase)) {
03010       /* There was a shift in the relative part. */
03011       Scheme_Modidx *sbm;
03012       int i, c;
03013       Scheme_Object *smodidx, *cvec;
03014 
03015       /* Shift cached? sbase as a modname is rare, but we need at least a little
03016          caching to make other things (e.g., .zo output) compact, so we use
03017          a small global cache in that case. */
03018 
03019       if (SCHEME_MODNAMEP(sbase)) {
03020        sbm = NULL;
03021        cvec = global_shift_cache;
03022       } else {
03023        sbm = (Scheme_Modidx *)sbase;
03024        cvec = sbm->shift_cache;
03025       }
03026 
03027       c = (cvec ? SCHEME_VEC_SIZE(cvec) : 0);
03028       
03029       for (i = 0; i < c; i += 2) {
03030        if (SHIFT_CACHE_NULLP(SCHEME_VEC_ELS(cvec)[i]))
03031          break;
03032        if (SAME_OBJ(modidx, SCHEME_VEC_ELS(cvec)[i]))
03033          return SCHEME_VEC_ELS(cvec)[i + 1];
03034       }
03035       
03036       smodidx = scheme_make_modidx(((Scheme_Modidx *)modidx)->path,
03037                                sbase,
03038                                scheme_false);
03039 
03040       if (!sbm) {
03041        if (!global_shift_cache)
03042          global_shift_cache = scheme_make_vector(GLOBAL_SHIFT_CACHE_SIZE, SHIFT_CACHE_NULL);
03043        for (i = 0; i < (GLOBAL_SHIFT_CACHE_SIZE - 2); i++) {
03044          SCHEME_VEC_ELS(global_shift_cache)[i+2] = SCHEME_VEC_ELS(global_shift_cache)[i];
03045        }
03046        SCHEME_VEC_ELS(global_shift_cache)[0] = modidx;
03047        SCHEME_VEC_ELS(global_shift_cache)[1] = smodidx;
03048       } else {
03049        /* May have GCed: */
03050        if (cvec && !sbm->shift_cache)
03051          sbm->shift_cache = cvec;
03052 
03053        if (i >= c) {
03054          /* Grow cache vector */
03055          Scheme_Object *naya;
03056          int j;
03057            
03058          naya = scheme_make_vector(c + 10, SHIFT_CACHE_NULL);
03059          for (j = 0; j < c; j++) {
03060            SCHEME_VEC_ELS(naya)[j] = SCHEME_VEC_ELS(cvec)[j];
03061          }
03062          if (!sbm->shift_cache) {
03063            sbm->cache_next = modidx_caching_chain;
03064            modidx_caching_chain = sbm;
03065          }
03066 
03067          sbm->shift_cache = naya;
03068        }
03069          
03070        SCHEME_VEC_ELS(sbm->shift_cache)[i] = modidx;
03071        SCHEME_VEC_ELS(sbm->shift_cache)[i+1] = smodidx;
03072       }
03073 
03074       return smodidx;
03075     }
03076   }
03077 
03078   return modidx;
03079 }
03080 
03081 void scheme_clear_modidx_cache(void)
03082 {
03083   Scheme_Modidx *sbm, *next;
03084 
03085   global_shift_cache = NULL;
03086   
03087   for (sbm = modidx_caching_chain; sbm; sbm = next) {
03088     sbm->shift_cache = NULL;
03089     next = sbm->cache_next;
03090     sbm->cache_next = NULL;
03091   }
03092   modidx_caching_chain = NULL;
03093 }
03094 
03095 static Scheme_Module *module_load(Scheme_Object *name, Scheme_Env *env, const char *who)
03096 {
03097   if (name == kernel_modname)
03098     return kernel;
03099   else {
03100     Scheme_Module *m;
03101 
03102     m = (Scheme_Module *)scheme_hash_get(env->module_registry, name);
03103 
03104     if (!m) {
03105       char *mred_note;
03106 
03107       if (!strcmp(SCHEME_SYM_VAL(SCHEME_PTR_VAL(name)), "#%mred-kernel")
03108          && !(scheme_strncmp(scheme_banner(), "Welcome to MzScheme", 19)))
03109        mred_note = "; need to run in mred instead of mzscheme";
03110       else
03111        mred_note = "";
03112 
03113       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
03114                      "%s: unknown module: %D%s",
03115                      who ? who : "require", 
03116                      name, mred_note);
03117       return NULL;
03118     }
03119 
03120     return m;
03121   }
03122 }
03123 
03124 static void setup_accessible_table(Scheme_Module *m)
03125 {
03126   if (!m->accessible) {
03127     Scheme_Module_Phase_Exports *pt;
03128     int j;
03129 
03130     for (j = 0; j < 2; j++) {
03131       if (!j)
03132         pt = m->me->rt;
03133       else
03134         pt = m->me->et;
03135       
03136       if (pt) {
03137         Scheme_Hash_Table *ht;
03138         int i, count, nvp;
03139         
03140         ht = scheme_make_hash_table(SCHEME_hash_ptr);
03141         nvp = pt->num_var_provides;
03142         for (i = 0; i < nvp; i++) {
03143           if (SCHEME_FALSEP(pt->provide_srcs[i])) {
03144             scheme_hash_set(ht, pt->provide_src_names[i], scheme_make_integer(i));
03145           }
03146         }
03147         
03148         if (j == 0) {
03149           count = m->num_indirect_provides;
03150           for (i = 0; i < count; i++) {
03151             scheme_hash_set(ht, m->indirect_provides[i], scheme_make_integer(i + nvp));
03152           }
03153         } else {
03154           count = m->num_indirect_et_provides;
03155           for (i = 0; i < count; i++) {
03156             scheme_hash_set(ht, m->et_indirect_provides[i], scheme_make_integer(i + nvp));
03157           }
03158         }
03159         
03160         /* Add syntax as negative ids: */
03161         count = pt->num_provides;
03162         for (i = nvp; i < count; i++) {
03163           if (SCHEME_FALSEP(pt->provide_srcs[i])) {
03164             scheme_hash_set(ht, pt->provide_src_names[i], scheme_make_integer(-(i+1)));
03165           }
03166         }
03167 
03168         if (!j)
03169           m->accessible = ht;
03170         else
03171           m->et_accessible = ht;
03172       }
03173     }
03174   }
03175 }
03176 
03177 Scheme_Env *scheme_module_access(Scheme_Object *name, Scheme_Env *env, int rev_mod_phase)
03178 {
03179   if ((name == kernel_modname) && !rev_mod_phase)
03180     return scheme_get_kernel_env();
03181   else {
03182     Scheme_Object *chain;
03183     Scheme_Env *menv;
03184 
03185     chain = env->modchain;
03186     if (rev_mod_phase && chain) {
03187       chain = (SCHEME_VEC_ELS(chain))[2];
03188       if (SCHEME_FALSEP(chain))
03189        return NULL;
03190     }
03191 
03192     if (!chain) {
03193       scheme_signal_error("internal error: missing chain for module instances");
03194       return NULL;
03195     }
03196 
03197     menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(chain), name);
03198     
03199     if (rev_mod_phase && menv)
03200       menv = menv->exp_env;
03201 
03202     return menv;
03203   }
03204 }
03205 
03206 static void check_certified(Scheme_Object *stx, Scheme_Object *certs, 
03207                          Scheme_Object *prot_insp, Scheme_Object *insp, 
03208                             Scheme_Object *rename_insp, Scheme_Object *in_modidx,
03209                          Scheme_Env *env, Scheme_Object *symbol,
03210                          int var, int prot, int *_would_complain)
03211 {
03212   int need_cert = 1;
03213   Scheme_Object *midx;
03214 
03215   midx = (env->link_midx ? env->link_midx : env->module->me->src_modidx);
03216     
03217   if (stx)
03218     need_cert = !scheme_stx_certified(stx, certs, prot ? NULL : midx, env->insp);
03219 
03220   if (need_cert && insp)
03221     need_cert = scheme_module_protected_wrt(env->insp, insp);
03222   if (need_cert && rename_insp) {
03223     if (SCHEME_PAIRP(rename_insp)) {
03224       /* First inspector of pair protects second */
03225       if (!prot_insp
03226           || scheme_module_protected_wrt(SCHEME_CAR(rename_insp), prot_insp)) {
03227         rename_insp = NULL;
03228       } else
03229         rename_insp = SCHEME_CDR(rename_insp);
03230     }
03231     if (rename_insp)
03232       need_cert = scheme_module_protected_wrt(env->insp, rename_insp);
03233   }
03234 
03235   if (need_cert && in_modidx && midx) {
03236     /* If we're currently executing a macro expander in this module,
03237        then allow the access under any cirsumstances. This is mostly
03238        useful for syntax-local-value and local-expand. */
03239     in_modidx = scheme_module_resolve(in_modidx, 0);
03240     midx = scheme_module_resolve(midx, 0);
03241     if (SAME_OBJ(in_modidx, midx))
03242       need_cert = 0;
03243   }
03244 
03245   if (need_cert) {
03246     if (_would_complain) {
03247       *_would_complain = 1;
03248     } else {
03249       /* For error, if stx is no more specific than symbol, drop symbol. */
03250       if (stx && SAME_OBJ(SCHEME_STX_SYM(stx), symbol)) {
03251         symbol = stx;
03252         stx = NULL;
03253       }
03254       scheme_wrong_syntax("compile", stx, symbol, 
03255                           "access from an uncertified context to %s %s from module: %D",
03256                           prot ? "protected" : "unexported",
03257                           var ? "variable" : "syntax",
03258                           env->module->modname);
03259     }
03260   }
03261 }
03262 
03263 Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object *prot_insp, Scheme_Object *in_modidx,
03264                                            Scheme_Object *symbol, Scheme_Object *stx,
03265                                            Scheme_Object *certs, Scheme_Object *unexp_insp, 
03266                                                  Scheme_Object *rename_insp,
03267                                            int position, int want_pos, 
03268                                                  int *_protected, int *_unexported,
03269                                                  Scheme_Env *from_env, int *_would_complain)
03270      /* Returns the actual name when !want_pos, needed in case of
03271        uninterned names.  Otherwise, returns a position value on success.
03272        If position < -1, then merely checks for protected syntax.
03273 
03274        Access for protected and unexported names depends on
03275        certifictions in stx+certs, access implied by
03276        {prot_,unexp_}insp, or access implied by in_modidx. For
03277        unexported access, either stx+certs or unexp_insp must be
03278        supplied (not both), and prot_insp should be supplied 
03279         (for protected re-exports of unexported).
03280         For unprotected access, both prot_insp and stx+certs 
03281         should be supplied. In either case, rename_insp
03282         is optionally allowed. */
03283 {
03284   Scheme_Module_Phase_Exports *pt;
03285 
03286   if (!SCHEME_SYMBOLP(symbol))
03287     symbol = scheme_tl_id_sym(env, symbol, NULL, 0, NULL, NULL);
03288 
03289   if (scheme_is_kernel_env(env)
03290       || ((env->module->primitive && !env->module->provide_protects))) {
03291     if (want_pos)
03292       return scheme_make_integer(-1);
03293     else
03294       return symbol;
03295   }
03296 
03297   switch (env->mod_phase) {
03298   case 0:
03299     pt = env->module->me->rt;
03300     break;
03301   case 1:
03302     pt = env->module->me->et;
03303     break;
03304   default:
03305     pt = (Scheme_Module_Phase_Exports *)scheme_hash_get(env->module->me->other_phases,
03306                                                         scheme_make_integer(env->mod_phase));
03307     break;
03308   }
03309 
03310   if (pt) {
03311     if (position >= 0) {
03312       /* Check whether the symbol at `pos' matches the string part of
03313          the expected symbol.  */
03314       Scheme_Object *isym;
03315       int need_cert = 0;
03316 
03317       if (position < pt->num_var_provides) {
03318         if (!pt->provide_srcs
03319             || SCHEME_FALSEP(pt->provide_srcs[position]))
03320           isym = pt->provide_src_names[position];
03321         else
03322           isym = NULL;
03323       } else {
03324         int ipos = position - pt->num_var_provides;
03325         int num_indirect_provides;
03326         Scheme_Object **indirect_provides;
03327 
03328         if (env->mod_phase == 0) {
03329           num_indirect_provides = env->module->num_indirect_provides;
03330           indirect_provides = env->module->indirect_provides;
03331         } else if (env->mod_phase == 1) {
03332           num_indirect_provides = env->module->num_indirect_et_provides;
03333           indirect_provides = env->module->et_indirect_provides;
03334         } else {
03335           num_indirect_provides = 0;
03336           indirect_provides = NULL;
03337         }
03338 
03339         if (ipos < num_indirect_provides) {
03340           isym = indirect_provides[ipos];
03341           need_cert = 1;
03342           if (_protected)
03343             *_protected = 1;
03344         } else
03345           isym = NULL;
03346       }
03347 
03348       if (isym) {
03349         if (SAME_OBJ(isym, symbol)
03350             || (SCHEME_SYM_LEN(isym) == SCHEME_SYM_LEN(symbol)
03351                 && !memcmp(SCHEME_SYM_VAL(isym), SCHEME_SYM_VAL(symbol), SCHEME_SYM_LEN(isym)))) {
03352        
03353           if ((position < pt->num_var_provides)
03354               && scheme_module_protected_wrt(env->insp, prot_insp)) {
03355             char *provide_protects;
03356             
03357             if (env->mod_phase == 0)
03358               provide_protects = env->module->provide_protects;
03359             else if (env->mod_phase == 0)
03360               provide_protects = env->module->et_provide_protects;
03361             else
03362               provide_protects = NULL;
03363             
03364             if (provide_protects
03365                 && provide_protects[position]) {
03366               if (_protected)
03367                 *_protected = 1;
03368               check_certified(stx, certs, prot_insp, prot_insp, rename_insp, in_modidx, env, symbol, 1, 1, _would_complain);
03369             }
03370           }
03371 
03372           if (need_cert)
03373             check_certified(stx, certs, prot_insp, unexp_insp, rename_insp, in_modidx, env, symbol, 1, 0, _would_complain);
03374        
03375           if (want_pos)
03376             return scheme_make_integer(position);
03377           else
03378             return isym;
03379         } 
03380       }
03381       /* failure */
03382     } else {
03383       Scheme_Object *pos;
03384 
03385       if (!env->mod_phase)
03386         pos = scheme_hash_get(env->module->accessible, symbol);
03387       else if (env->mod_phase == 1)
03388         pos = scheme_hash_get(env->module->et_accessible, symbol);
03389       else
03390         pos = NULL;
03391 
03392       if (pos) {
03393         if (position < -1) {
03394           if (SCHEME_INT_VAL(pos) < 0)
03395             pos = scheme_make_integer(-SCHEME_INT_VAL(pos) - 1);
03396           else
03397             pos = NULL;
03398         } else {
03399           if (SCHEME_INT_VAL(pos) < 0)
03400             pos = NULL;
03401         }
03402       }
03403 
03404       if (pos) {
03405         char *provide_protects;
03406 
03407         if (env->mod_phase == 0)
03408           provide_protects = env->module->provide_protects;
03409         else if (env->mod_phase == 1)
03410           provide_protects = env->module->et_provide_protects;
03411         else
03412           provide_protects = NULL;
03413 
03414         if (provide_protects
03415             && (SCHEME_INT_VAL(pos) < pt->num_provides)
03416             && provide_protects[SCHEME_INT_VAL(pos)]) {
03417           if (_protected)
03418             *_protected = 1;
03419           check_certified(stx, certs, prot_insp, prot_insp, rename_insp, in_modidx, env, symbol, 1, 1, _would_complain);
03420         }
03421 
03422         if ((position >= -1) 
03423             && (SCHEME_INT_VAL(pos) >= pt->num_var_provides)) {
03424           /* unexported var -- need cert */
03425           if (_protected)
03426             *_protected = 1;
03427           if (_unexported)
03428             *_unexported = 1;
03429           check_certified(stx, certs, prot_insp, unexp_insp, rename_insp, in_modidx, env, symbol, 1, 0, _would_complain);
03430         }
03431 
03432         if (want_pos)
03433           return pos;
03434         else
03435           return symbol;
03436       }
03437 
03438       if (position < -1) {
03439         /* unexported syntax -- need cert */
03440         if (_unexported)
03441           *_unexported = 1;
03442         check_certified(stx, certs, prot_insp, unexp_insp, rename_insp, in_modidx, env, symbol, 0, 0, _would_complain);
03443         return NULL;
03444       }
03445     }
03446   }
03447 
03448   if (_would_complain) {
03449     *_would_complain = 1;
03450     return NULL;
03451   }
03452 
03453   /* For error, if stx is no more specific than symbol, drop symbol. */
03454   if (stx && SAME_OBJ(SCHEME_STX_SYM(stx), symbol)) {
03455     symbol = stx;
03456     stx = NULL;
03457   }
03458 
03459   {
03460     const char *srcstr;
03461     long srclen;
03462     
03463     if (from_env->module)
03464       srcstr = scheme_display_to_string(from_env->module->modname, &srclen);
03465     else {
03466       srcstr = "";
03467       srclen = 0;
03468     }
03469 
03470     scheme_wrong_syntax("link", stx, symbol, 
03471                         "module mismatch, probably from old bytecode whose dependencies have changed: "
03472                         "variable not provided (directly or indirectly%s) from module: %D%s%t at source phase level: %d",
03473                         (position >= 0) ? " and at the expected position" : "",
03474                         env->module->modname,
03475                         srclen ? " accessed from module: " : "",
03476                         srcstr, srclen,
03477                         env->mod_phase);
03478   }
03479 
03480   return NULL;
03481 }
03482 
03483 int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *varname)
03484 {
03485   Scheme_Module *m;
03486   Scheme_Object *pos;
03487 
03488   if (modname == kernel_modname)
03489     return -1;
03490 
03491   m = module_load(modname, env, NULL);
03492   if (!m || m->primitive)
03493     return -1;
03494 
03495   setup_accessible_table(m);
03496 
03497   pos = scheme_hash_get(m->accessible, varname);
03498   
03499   if (pos && (SCHEME_INT_VAL(pos) >= 0))
03500     return SCHEME_INT_VAL(pos);
03501   else
03502     return -1;
03503 }
03504 
03505 Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *name)
03506 {
03507   if (modname == kernel_modname) {
03508     Scheme_Env *kenv;
03509     kenv = scheme_get_kernel_env();
03510     name = SCHEME_STX_SYM(name);
03511     return scheme_lookup_in_table(kenv->syntax, (char *)name);
03512   } else {
03513     Scheme_Env *menv;
03514     Scheme_Object *val;
03515 
03516     menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), modname);
03517     
03518     if (!menv)
03519       return NULL;
03520 
03521     name = scheme_tl_id_sym(menv, name, NULL, 0, NULL, NULL);
03522 
03523     val = scheme_lookup_in_table(menv->syntax, (char *)name);
03524 
03525     return val;
03526   }
03527 }
03528 
03529 void scheme_module_force_lazy(Scheme_Env *env, int previous)
03530 {
03531   /* not anymore */
03532 }
03533 
03534 XFORM_NONGCING static long make_key(int base_phase, int eval_exp, int eval_run)
03535 {
03536   return ((base_phase << 3) 
03537           | (eval_exp ? ((eval_exp > 0) ? 2 : 4) : 0) 
03538           | (eval_run ? 1 : 0));
03539 }
03540 
03541 static int did_start(Scheme_Object *v, int base_phase, int eval_exp, int eval_run)
03542 {
03543   long key;
03544 
03545   key = make_key(base_phase, eval_exp, eval_run);
03546 
03547   if (!v)
03548     return 0;
03549 
03550   if (scheme_hash_tree_get((Scheme_Hash_Tree *)v, scheme_make_integer(key)))
03551     return 1;
03552 
03553   return 0;
03554 }
03555 
03556 static Scheme_Object *add_start(Scheme_Object *v, int base_phase, int eval_exp, int eval_run)
03557 {
03558   long key;
03559   Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v;
03560   Scheme_Bucket *b;
03561 
03562   if (!ht)
03563     ht = scheme_make_hash_tree(0);
03564 
03565   key = make_key(base_phase, eval_exp, eval_run);
03566 
03567   ht = scheme_hash_tree_set(ht, scheme_make_integer(key), scheme_true);
03568   
03569   b = scheme_bucket_from_table(starts_table, (const char *)ht);
03570   if (!b->val)
03571     b->val = scheme_true;
03572   return (Scheme_Object *)HT_EXTRACT_WEAK(b->key);
03573 }
03574 
03575 #if 0
03576 static int indent = 0;
03577 # define show_indent(d) (indent += d)
03578 static void show(const char *what, Scheme_Env *menv, int v1, int v2, int base_phase)
03579 {
03580   if (menv->phase > 3) return;
03581   if (1 || SCHEME_SYMBOLP(SCHEME_PTR_VAL(menv->module->modname)))
03582     if (1 || SCHEME_SYM_VAL(SCHEME_PTR_VAL(menv->module->modname))[0] != '#') {
03583       int i;
03584       for (i = 0; i < indent; i++) {
03585         fprintf(stderr, " ");
03586       }
03587       fprintf(stderr, "%s \t%s @%ld/%d [%d/%d] %p\n", 
03588               what, scheme_write_to_string(menv->module->modname, NULL), 
03589               menv->phase, base_phase, v1, v2, menv->modchain);
03590     }
03591 }
03592 static void show_done(const char *what, Scheme_Env *menv, int v1, int v2, int base_phase){
03593   show(what, menv, v1, v2, base_phase);
03594 }
03595 #else
03596 # define show_indent(d) /* nothing */
03597 # define show(w, m, v1, v2, bp) /* nothing */
03598 # define show_done(w, m, v1, v2, bp) /* nothing */
03599 #endif
03600 
03601 static void compute_require_names(Scheme_Env *menv, Scheme_Object *phase, 
03602                                   Scheme_Env *load_env, Scheme_Object *syntax_idx)
03603 {
03604   Scheme_Object *np, *midx, *l, *reqs, *req_names;
03605 
03606   if (SAME_OBJ(phase, scheme_make_integer(0))) {
03607     req_names = menv->require_names;
03608     reqs = menv->module->requires;
03609   } else if (SAME_OBJ(phase, scheme_make_integer(1))) {
03610     req_names = menv->et_require_names;
03611     reqs = menv->module->et_requires;
03612   } else if (SAME_OBJ(phase, scheme_make_integer(-1))) {
03613     req_names = menv->tt_require_names;
03614     reqs = menv->module->tt_requires;
03615   } else if (SAME_OBJ(phase, scheme_false)) {
03616     req_names = menv->dt_require_names;
03617     reqs = menv->module->dt_requires;
03618   } else {
03619     if (menv->module->other_requires) {
03620       reqs = scheme_hash_get(menv->module->other_requires, phase);
03621       if (!reqs)
03622         reqs = scheme_null;
03623     } else
03624       reqs = scheme_null;
03625     if (!SCHEME_NULLP(reqs) && !menv->other_require_names) {
03626       Scheme_Hash_Table *ht;
03627       ht = scheme_make_hash_table_equal();
03628       menv->other_require_names = ht;
03629     }
03630     if (menv->other_require_names)
03631       req_names = scheme_hash_get(menv->other_require_names, phase);
03632     else
03633       req_names = NULL;
03634   }
03635 
03636   if (req_names && !SCHEME_NULLP(req_names))
03637     return;
03638 
03639   np = scheme_null;
03640 
03641   for (l = reqs; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
03642     midx = scheme_modidx_shift(SCHEME_CAR(l), 
03643                                menv->module->me->src_modidx, 
03644                                (syntax_idx ? syntax_idx : menv->link_midx));
03645 
03646     if (load_env)
03647       module_load(scheme_module_resolve(midx, 1), load_env, NULL);
03648     
03649     np = cons(midx, np);
03650   }
03651 
03652   if (!SAME_OBJ(np, req_names)) {
03653     if (SAME_OBJ(phase, scheme_make_integer(0))) {
03654       menv->require_names = np;
03655     } else if (SAME_OBJ(phase, scheme_make_integer(1))) {
03656       menv->et_require_names = np;
03657     } else if (SAME_OBJ(phase, scheme_make_integer(-1))) {
03658       menv->tt_require_names = np;
03659     } else if (SAME_OBJ(phase, scheme_false)) {
03660       menv->dt_require_names = np;
03661     } else {
03662       if (menv->other_require_names)
03663         scheme_hash_set(menv->other_require_names, phase, np);
03664     }
03665   }
03666 }
03667 
03668 static void chain_start_module(Scheme_Env *menv, Scheme_Env *env, int eval_exp, int eval_run, 
03669                                long base_phase, Scheme_Object *cycle_list, Scheme_Object *syntax_idx)
03670 {
03671   Scheme_Object *new_cycle_list, *midx, *l;
03672   Scheme_Module *im;
03673 
03674   new_cycle_list = scheme_make_pair(menv->module->modname, cycle_list);
03675   
03676   if (!SCHEME_NULLP(menv->module->dt_requires)) {
03677     compute_require_names(menv, scheme_false, env, syntax_idx);
03678 
03679     scheme_prepare_label_env(menv);
03680 
03681     for (l = menv->dt_require_names; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
03682       midx = SCHEME_CAR(l);
03683     
03684       im = module_load(scheme_module_resolve(midx, 1), env, NULL);
03685 
03686       start_module(im, 
03687                    menv->label_env, 0, 
03688                    midx,
03689                    0, 0, base_phase,
03690                    new_cycle_list);
03691     }
03692   }
03693   
03694   if (!SCHEME_NULLP(menv->module->tt_requires)) {
03695 
03696     compute_require_names(menv, scheme_make_integer(-1), env, syntax_idx);
03697 
03698     scheme_prepare_template_env(menv);
03699 
03700     for (l = menv->tt_require_names; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
03701       midx = SCHEME_CAR(l);
03702     
03703       im = module_load(scheme_module_resolve(midx, 1), env, NULL);
03704 
03705       start_module(im, 
03706                    menv->template_env, 0, 
03707                    midx,
03708                    eval_exp, eval_run, base_phase,
03709                    new_cycle_list);
03710     }
03711   }
03712 
03713   compute_require_names(menv, scheme_make_integer(0), env, syntax_idx);
03714 
03715   for (l = menv->require_names; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
03716     midx = SCHEME_CAR(l);
03717 
03718     im = module_load(scheme_module_resolve(midx, 1), env, NULL);
03719 
03720     start_module(im, env, 0, midx, eval_exp, eval_run, base_phase, new_cycle_list);
03721   }
03722 
03723   scheme_prepare_exp_env(menv);
03724   menv->exp_env->link_midx = menv->link_midx;
03725   
03726   if (!SCHEME_NULLP(menv->module->et_requires)) {
03727     compute_require_names(menv, scheme_make_integer(1), env, syntax_idx);
03728     
03729     for (l = menv->et_require_names; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
03730       midx = SCHEME_CAR(l);
03731       
03732       im = module_load(scheme_module_resolve(midx, 1), env, NULL);
03733       
03734       start_module(im, menv->exp_env, 0, midx, eval_exp, eval_run, base_phase, new_cycle_list);
03735     }
03736   }
03737 
03738   if (menv->module->other_requires) {
03739     int i;
03740     Scheme_Object *phase, *n;
03741     Scheme_Env *menv2;
03742     for (i = 0; i < menv->module->other_requires->size; i++) {
03743       if (menv->module->other_requires->vals[i]) {
03744         phase = menv->module->other_requires->keys[i];
03745 
03746         if (scheme_is_negative(phase)) {
03747           compute_require_names(menv, phase, env, syntax_idx);
03748 
03749           n = phase;
03750           menv2 = menv;
03751           while (scheme_is_negative(n)) {
03752             scheme_prepare_template_env(menv2);
03753             menv2 = menv2->template_env;
03754             n = scheme_bin_plus(n, scheme_make_integer(1));
03755           }
03756 
03757           l = scheme_hash_get(menv->other_require_names, phase);
03758 
03759           for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
03760             midx = SCHEME_CAR(l);
03761 
03762             im = module_load(scheme_module_resolve(midx, 1), env, NULL);
03763 
03764             start_module(im, 
03765                          menv2, 0, 
03766                          midx,
03767                          eval_exp, eval_run, base_phase,
03768                          new_cycle_list);
03769           }
03770         } else {
03771           compute_require_names(menv, phase, env, syntax_idx);
03772 
03773           n = phase;
03774           menv2 = menv;
03775           while (scheme_is_positive(n)) {
03776             scheme_prepare_exp_env(menv2);
03777             menv2->exp_env->link_midx = menv2->link_midx;
03778             menv2 = menv2->exp_env;
03779             n = scheme_bin_minus(n, scheme_make_integer(1));
03780           }
03781 
03782           l = scheme_hash_get(menv->other_require_names, phase);
03783 
03784           for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
03785             midx = SCHEME_CAR(l);
03786             
03787             im = module_load(scheme_module_resolve(midx, 1), env, NULL);
03788             
03789             start_module(im, menv2, 0, midx, eval_exp, eval_run, base_phase, new_cycle_list);
03790           }
03791         }
03792       }
03793     }
03794   }
03795 }
03796 
03797 static Scheme_Env *instantiate_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx)
03798 {
03799   Scheme_Env *menv;
03800 
03801   if (!restart) {
03802     menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname);
03803     if (menv) {
03804       check_phase(menv, env, 0);
03805       return menv;
03806     }
03807   }
03808 
03809   if (m->primitive) {
03810     menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname);
03811     if (!menv) {
03812       menv = m->primitive;
03813       scheme_hash_set(MODCHAIN_TABLE(env->modchain), m->modname, (Scheme_Object *)menv);
03814     }
03815     menv->require_names = scheme_null;
03816     menv->et_require_names = scheme_null;
03817     menv->tt_require_names = scheme_null;
03818     menv->dt_require_names = scheme_null;
03819     return menv;
03820   }
03821 
03822   menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname);
03823   if (!menv || restart) {
03824     Scheme_Object *insp;
03825 
03826     if (!menv) {
03827       /* printf("new %ld %s\n", env->phase, SCHEME_SYM_VAL(m->modname)); */
03828       menv = scheme_new_module_env(env, m, 0);
03829       scheme_hash_set(MODCHAIN_TABLE(env->modchain), m->modname, (Scheme_Object *)menv);
03830       
03831       menv->phase = env->phase;
03832       menv->link_midx = syntax_idx;
03833     } else {
03834       Scheme_Env *env2;
03835 
03836       menv->module = m;
03837       menv->running = 0;
03838       menv->et_running = 0;
03839       menv->ran = 0;
03840       menv->did_starts = NULL;
03841 
03842       for (env2 = menv->exp_env; env2; env2 = env2->exp_env) {
03843         env2->module = m;
03844       }
03845       for (env2 = menv->template_env; env2; env2 = env2->template_env) {
03846         env2->module = m;
03847       }
03848       env2 = menv->label_env;
03849       if (env2)
03850         env2->module = m;
03851     }
03852 
03853     insp = scheme_make_inspector(m->insp);
03854     menv->insp = insp;
03855 
03856     /* These three should be set by various "finish"es, but
03857        we initialize them in case there's an error runing a "finish". */
03858     menv->require_names = scheme_null;
03859     menv->et_require_names = scheme_null;
03860     menv->tt_require_names = scheme_null;
03861     menv->dt_require_names = scheme_null;
03862 
03863     if (env->label_env != env) {
03864       setup_accessible_table(m);
03865 
03866       /* Create provided global variables: */
03867       {
03868         Scheme_Object **exss, **exsns;
03869         int i, count;
03870 
03871         exsns = m->me->rt->provide_src_names;
03872         exss = m->me->rt->provide_srcs;
03873         count = m->me->rt->num_var_provides;
03874 
03875         for (i = 0; i < count; i++) {
03876           if (SCHEME_FALSEP(exss[i]))
03877             scheme_add_to_table(menv->toplevel, (const char *)exsns[i], NULL, 0);
03878         }
03879 
03880         count = m->num_indirect_provides;
03881         exsns = m->indirect_provides;
03882         for (i = 0; i < count; i++) {
03883           scheme_add_to_table(menv->toplevel, (const char *)exsns[i], NULL, 0);
03884         }
03885       }
03886     }
03887   }
03888 
03889   return menv;
03890 }
03891 
03892 static void expstart_module(Scheme_Env *menv, Scheme_Env *env, int restart)
03893 {
03894   if (!restart) {
03895     if (menv && menv->et_running)
03896       return;
03897   }
03898 
03899   if (menv->module->primitive)
03900     return;
03901 
03902   menv->et_running = 1;
03903   if (scheme_starting_up)
03904     menv->attached = 1; /* protect initial modules from redefinition, etc. */
03905 
03906   run_module_exptime(menv, 0);
03907 
03908   return;
03909 }
03910 
03911 static void run_module_exptime(Scheme_Env *menv, int set_ns)
03912 {
03913   int let_depth, for_stx;
03914   Scheme_Object *names, *e;
03915   Resolve_Prefix *rp;
03916   Scheme_Comp_Env *rhs_env;
03917   int i, cnt;
03918   Scheme_Env *exp_env;
03919   Scheme_Bucket_Table *syntax, *for_stx_globals;
03920   Scheme_Cont_Frame_Data cframe;
03921   Scheme_Config *config;
03922   
03923   if (menv->module->primitive)
03924     return;
03925 
03926   if (!SCHEME_VEC_SIZE(menv->module->et_body))
03927     return;
03928 
03929   syntax = menv->syntax;
03930 
03931   exp_env = menv->exp_env;
03932 
03933   if (!exp_env)
03934     return;
03935 
03936   for_stx_globals = exp_env->toplevel;
03937 
03938   if (set_ns) {
03939     config = scheme_extend_config(scheme_current_config(),
03940                                   MZCONFIG_ENV,
03941                                   (Scheme_Object *)menv);
03942     
03943     scheme_push_continuation_frame(&cframe);
03944     scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
03945   }
03946 
03947   rhs_env = scheme_new_comp_env(menv, menv->module->insp, SCHEME_TOPLEVEL_FRAME);
03948 
03949   cnt = SCHEME_VEC_SIZE(menv->module->et_body);
03950   for (i = 0; i < cnt; i++) {
03951     e = SCHEME_VEC_ELS(menv->module->et_body)[i];
03952       
03953     names = SCHEME_VEC_ELS(e)[0];
03954     let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]);
03955     rp = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[3];
03956     for_stx = SCHEME_TRUEP(SCHEME_VEC_ELS(e)[4]);
03957     e = SCHEME_VEC_ELS(e)[1];
03958       
03959     if (SCHEME_SYMBOLP(names))
03960       names = scheme_make_pair(names, scheme_null);
03961 
03962     eval_exptime(names, scheme_list_length(names), e, exp_env, rhs_env,
03963                  rp, let_depth, 1, (for_stx ? for_stx_globals : syntax), for_stx,
03964                  NULL, scheme_false);
03965   }
03966 
03967   if (set_ns) {
03968     scheme_pop_continuation_frame(&cframe);
03969   }
03970 }
03971 
03972 static void do_start_module(Scheme_Module *m, Scheme_Env *menv, Scheme_Env *env, int restart)
03973 {
03974   if (m->primitive) {
03975     menv->running = 1;
03976     menv->ran = 1;
03977     return;
03978   }
03979 
03980   if (menv->running > 0) {
03981     return;
03982   }
03983   
03984   menv->running = 1;
03985 
03986   if (menv->module->prim_body) {
03987     Scheme_Invoke_Proc ivk = menv->module->prim_body;
03988     menv->ran = 1;
03989     ivk(menv, menv->phase, menv->link_midx, m->body);
03990   } else {
03991     eval_module_body(menv, env);
03992   }
03993 }
03994 
03995 static void should_run_for_compile(Scheme_Env *menv)
03996 {
03997   if (!menv->available_next[0]) {
03998     menv->available_next[0] = MODCHAIN_AVAIL(menv->modchain, 0);
03999     MODCHAIN_AVAIL(menv->modchain, 0) = (Scheme_Object *)menv;
04000   }
04001   if (!menv->available_next[1]) {
04002     menv->available_next[1] = MODCHAIN_AVAIL(menv->modchain, 1);
04003     MODCHAIN_AVAIL(menv->modchain, 1) = (Scheme_Object *)menv;
04004   }
04005 }
04006 
04007 static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, 
04008                       Scheme_Object *syntax_idx, int eval_exp, int eval_run, long base_phase,
04009                       Scheme_Object *cycle_list)
04010 {
04011   Scheme_Env *menv;
04012   Scheme_Object *l, *new_cycle_list;
04013   int prep_namespace = 0;
04014 
04015   if (SAME_OBJ(m, kernel))
04016     return;
04017 
04018   for (l = cycle_list; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
04019     if (SAME_OBJ(m->modname, SCHEME_CAR(l))) {
04020       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
04021                      "module: import cycle detected at: %D",
04022                      m->modname);
04023     }
04024   }
04025 
04026   new_cycle_list = scheme_make_pair(m->modname, cycle_list);
04027 
04028   menv = instantiate_module(m, env, restart, syntax_idx);
04029 
04030   check_phase(menv, env, 0);
04031 
04032   show("chck", menv, eval_exp, eval_run, base_phase);
04033 
04034   if (did_start(menv->did_starts, base_phase, eval_exp, eval_run))
04035     return;
04036   
04037   show("strt", menv, eval_exp, eval_run, base_phase);
04038   show_indent(+1);
04039 
04040   {
04041     Scheme_Object *v;
04042     v = add_start(menv->did_starts, base_phase, eval_exp, eval_run);
04043     menv->did_starts = v;
04044   }
04045 
04046   chain_start_module(menv, env, eval_exp, eval_run, base_phase, cycle_list, syntax_idx);
04047 
04048   if (restart) {
04049     if (menv->rename_set_ready) {
04050       menv->rename_set_ready = 0;
04051       prep_namespace = 1;
04052     }
04053   }
04054 
04055   if (env->phase == base_phase) {
04056     if (eval_exp) {
04057       if (eval_exp > 0) {
04058         show("exp=", menv, eval_exp, eval_run, base_phase);
04059         expstart_module(menv, env, restart);
04060       } else {
04061         should_run_for_compile(menv);
04062       }
04063     }
04064     if (eval_run) {
04065       show("run=", menv, eval_exp, eval_run, base_phase);
04066       do_start_module(m, menv, env, restart);
04067     }
04068   } else if (env->phase < base_phase) {
04069     if (env->phase == base_phase - 1) {
04070       if (eval_run) {
04071         show("run-", menv, eval_exp, eval_run, base_phase);
04072         expstart_module(menv, env, restart);
04073       }
04074     }
04075   } else {
04076     /* env->phase > base_phase */
04077     if (eval_exp) {
04078       should_run_for_compile(menv);
04079     }
04080     if (eval_exp > 0) {
04081       if (env->phase == base_phase + 1) {
04082         show("run+", menv, eval_exp, eval_run, base_phase);
04083         do_start_module(m, menv, env, restart);
04084       }
04085     }
04086   }
04087 
04088   show_indent(-1);
04089   show_done("done", menv, eval_exp, eval_run, base_phase);
04090 
04091   if (prep_namespace)
04092     scheme_prep_namespace_rename(menv);
04093 }
04094 
04095 static void do_prepare_compile_env(Scheme_Env *env, int base_phase, int pos)
04096 {
04097   Scheme_Object *v;
04098   Scheme_Env *menv;
04099 
04100   v = MODCHAIN_AVAIL(env->modchain, pos);
04101   if (!SCHEME_FALSEP(v)) {
04102     MODCHAIN_AVAIL(env->modchain, pos) = scheme_false;
04103     while (SCHEME_NAMESPACEP(v)) {
04104       menv = (Scheme_Env *)v;
04105       v = menv->available_next[pos];
04106       menv->available_next[pos] = NULL;
04107       start_module(menv->module, env, 0,
04108                    NULL, 1, 0, base_phase,
04109                    scheme_null);
04110     }
04111   }
04112 }
04113 
04114 void scheme_prepare_compile_env(Scheme_Env *env)
04115 /* We're going to compile expressions at env->phase, so make sure
04116    that env->phase is visited. */
04117 {
04118   do_prepare_compile_env(env, env->phase, 0);
04119 
04120   /* A top-level `require' can introduce in any phase with a
04121      `for-syntax' import whose visit triggers an instantiation.
04122      So, also check for instances at the next phase. */
04123   if (env->exp_env) {
04124     do_prepare_compile_env(env->exp_env, env->phase, 1);
04125   }
04126 }
04127 
04128 static void *eval_module_body_k(void)
04129 {
04130   Scheme_Thread *p = scheme_current_thread;
04131   Scheme_Env *menv, *env;
04132 
04133   menv = (Scheme_Env *)p->ku.k.p1;
04134   env = (Scheme_Env *)p->ku.k.p2;
04135   p->ku.k.p1 = NULL;
04136   p->ku.k.p2 = NULL;
04137 
04138   eval_module_body(menv, env);
04139   
04140   return NULL;
04141 }
04142 
04143 #if 0
04144 # define LOG_RUN_DECLS long start_time
04145 # define LOG_START_RUN(mod) (start_time = scheme_get_process_milliseconds())
04146 # define LOG_END_RUN(mod) (printf("Ran %s [%d msec]\n", \
04147                                   scheme_write_to_string(mod->modname, NULL), \
04148                                   scheme_get_process_milliseconds() - start_time))
04149 #else
04150 # define LOG_RUN_DECLS /* empty */
04151 # define LOG_START_RUN(mod) /* empty */
04152 # define LOG_END_RUN(mod) /* empty */
04153 #endif
04154 
04155 static void eval_module_body(Scheme_Env *menv, Scheme_Env *env)
04156 {
04157   Scheme_Thread *p;
04158   Scheme_Module *m = menv->module;
04159   Scheme_Object *body, **save_runstack;
04160   int depth;
04161   int i, cnt;
04162   Scheme_Cont_Frame_Data cframe;
04163   Scheme_Config *config;
04164   int volatile save_phase_shift;
04165   mz_jmp_buf newbuf, * volatile savebuf;
04166   LOG_RUN_DECLS;
04167 
04168   menv->running = 1;
04169   menv->ran = 1;
04170 
04171   depth = m->max_let_depth + scheme_prefix_depth(m->prefix);
04172   if (!scheme_check_runstack(depth)) {
04173     p = scheme_current_thread;
04174     p->ku.k.p1 = menv;
04175     p->ku.k.p2 = env;
04176     (void)scheme_enlarge_runstack(depth, eval_module_body_k);
04177     return;
04178   }
04179 
04180   LOG_START_RUN(menv->module);
04181 
04182   save_runstack = scheme_push_prefix(menv, m->prefix,
04183                                  m->me->src_modidx, menv->link_midx,
04184                                  0, menv->phase);
04185 
04186   p = scheme_current_thread;
04187   save_phase_shift = p->current_phase_shift;
04188   p->current_phase_shift = menv->phase;
04189   savebuf = p->error_buf;
04190   p->error_buf = &newbuf;
04191 
04192   if (scheme_setjmp(newbuf)) {
04193     Scheme_Thread *p2;
04194     p2 = scheme_current_thread;
04195     p2->error_buf = savebuf;
04196     p2->current_phase_shift = save_phase_shift;
04197     scheme_longjmp(*savebuf, 1);
04198   } else {
04199     if (env && menv->phase) {
04200       config = scheme_extend_config(scheme_current_config(),
04201                                     MZCONFIG_ENV,
04202                                     (Scheme_Object *)env);
04203       
04204       scheme_push_continuation_frame(&cframe);
04205       scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
04206     }
04207 
04208     cnt = SCHEME_VEC_SIZE(m->body);
04209     for (i = 0; i < cnt; i++) {
04210       body = SCHEME_VEC_ELS(m->body)[i];
04211       _scheme_eval_linked_expr_multi(body);
04212     }
04213 
04214     if (scheme_module_demand_hook) {
04215       Scheme_Object *a[1], *val, *sym;
04216       a[0] = menv->module->modname;
04217       sym = scheme_module_demand_hook(1, a);
04218       if (sym) {
04219         val = scheme_lookup_global(sym, menv);
04220         if (val) {
04221           a[0] = val;
04222           val = scheme_module_demand_hook(3, a);
04223           if (val) {
04224             scheme_add_global_symbol(sym, val, menv);
04225           }
04226         }
04227       }
04228     }
04229 
04230     if (env && menv->phase) {
04231       scheme_pop_continuation_frame(&cframe);
04232     }
04233 
04234     p = scheme_current_thread;
04235     p->error_buf = savebuf;
04236     p->current_phase_shift = save_phase_shift;
04237 
04238     scheme_pop_prefix(save_runstack);
04239   }
04240 
04241   LOG_END_RUN(menv->module);
04242 }
04243 
04244 static void run_module(Scheme_Env *menv, int set_ns)
04245 {
04246   Scheme_Cont_Frame_Data cframe;
04247   Scheme_Config *config;
04248 
04249   if (set_ns) {
04250     config = scheme_extend_config(scheme_current_config(),
04251                                   MZCONFIG_ENV,
04252                                   (Scheme_Object *)menv);
04253     
04254     scheme_push_continuation_frame(&cframe);
04255     scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
04256   }
04257   
04258   eval_module_body(menv, NULL);
04259 
04260   if (set_ns) {
04261     scheme_pop_continuation_frame(&cframe);
04262   }
04263   
04264 }
04265 
04266 Scheme_Env *scheme_primitive_module(Scheme_Object *name, Scheme_Env *for_env)
04267 {
04268   Scheme_Module *m;
04269   Scheme_Env *env;
04270   Scheme_Object *prefix, *insp;
04271   Scheme_Config *config;
04272 
04273   m = MALLOC_ONE_TAGGED(Scheme_Module);
04274   m->so.type = scheme_module_type;
04275   
04276   env = scheme_new_module_env(for_env, m, 0);
04277 
04278   config = scheme_current_config();
04279 
04280   prefix = scheme_get_param(config, MZCONFIG_CURRENT_MODULE_NAME);
04281   if (SCHEME_MODNAMEP(prefix))
04282     name = prefix;
04283   else
04284     name = scheme_intern_resolved_module_path(name);
04285   insp = scheme_get_param(config, MZCONFIG_CODE_INSPECTOR);
04286 
04287   m->modname = name;
04288   m->requires = scheme_null;
04289   m->et_requires = scheme_null;
04290   m->tt_requires = scheme_null;
04291   m->dt_requires = scheme_null;
04292   m->primitive = env;
04293   m->insp = insp;
04294 
04295   {
04296     Scheme_Module_Exports *me;
04297     me = make_module_exports();
04298     m->me = me;
04299   }
04300 
04301   scheme_hash_set(for_env->export_registry, m->modname, (Scheme_Object *)m->me);
04302 
04303   insp = scheme_make_inspector(insp);
04304   env->insp = insp;
04305 
04306   scheme_hash_set(for_env->module_registry, m->modname, (Scheme_Object *)m);
04307 
04308   return env;
04309 }
04310 
04311 void scheme_finish_primitive_module(Scheme_Env *env)
04312 {
04313   Scheme_Module *m = env->module;
04314   Scheme_Bucket_Table *ht;
04315   Scheme_Bucket **bs;
04316   Scheme_Object **exs;
04317   int i, count;
04318 
04319   /* Provide all variables: */
04320   count = 0;
04321   ht = env->toplevel;
04322 
04323   bs = ht->buckets;
04324   for (i = ht->size; i--; ) {
04325     Scheme_Bucket *b = bs[i];
04326     if (b && b->val)
04327       count++;
04328   }
04329 
04330   exs = MALLOC_N(Scheme_Object *, count);
04331   count = 0;
04332   for (i = ht->size; i--; ) {
04333     Scheme_Bucket *b = bs[i];
04334     if (b && b->val)
04335       exs[count++] = (Scheme_Object *)b->key;
04336   }
04337  
04338   m->me->rt->provides = exs;
04339   m->me->rt->provide_srcs = NULL;
04340   m->me->rt->provide_src_names = exs;
04341   m->me->rt->num_provides = count;
04342   m->me->rt->num_var_provides = count;
04343 
04344   qsort_provides(exs, NULL, NULL, NULL, NULL, NULL, NULL, 0, count, 1);
04345 
04346   env->running = 1;
04347 }
04348 
04349 void scheme_protect_primitive_provide(Scheme_Env *env, Scheme_Object *name)
04350 {
04351   Scheme_Module *m = env->module;
04352   int i;
04353 
04354   if (!m->provide_protects) {
04355     Scheme_Hash_Table *ht;
04356     char *exps;
04357     ht = scheme_make_hash_table(SCHEME_hash_ptr);
04358     exps = MALLOC_N_ATOMIC(char, m->me->rt->num_provides);
04359     for (i = m->me->rt->num_provides; i--; ) {
04360       exps[i] = 0;
04361       scheme_hash_set(ht, m->me->rt->provides[i], scheme_make_integer(i));
04362     }
04363     m->provide_protects = exps;
04364     m->accessible = ht;
04365   }
04366 
04367   if (name) {
04368     for (i = m->me->rt->num_provides; i--; ) {
04369       if (SAME_OBJ(name, m->me->rt->provides[i])) {
04370        m->provide_protects[i] = 1;
04371        break;
04372       }
04373     }
04374   } else {
04375     /* Protect all */
04376     for (i = m->me->rt->num_provides; i--; ) {
04377       m->provide_protects[i] = 1;
04378     }
04379   }
04380 }
04381 
04382 Scheme_Bucket *scheme_module_bucket(Scheme_Object *modname, Scheme_Object *var, int pos, Scheme_Env *env)
04383 {
04384   Scheme_Object *a[2];
04385 
04386   if (SAME_OBJ(modname, kernel_symbol))
04387     a[0] = ((Scheme_Modidx *)kernel_modidx)->path;
04388   else
04389     a[0] = modname;
04390   a[1] = var;
04391 
04392   return (Scheme_Bucket *)_dynamic_require(2, a, env, 1, 0, 0, 1, 1, pos);
04393 }
04394 
04395 Scheme_Object *scheme_builtin_value(const char *name)
04396 {
04397   Scheme_Object *a[2], *v;
04398 
04399   a[1] = scheme_intern_symbol(name);
04400 
04401   /* Try kernel first: */
04402   a[0] = kernel_modname;
04403   v = _dynamic_require(2, a, scheme_get_env(NULL), 0, 0, 0, 0, 0, -1);
04404   if (v)
04405     return v;
04406 
04407   /* Also try #%utils... */
04408   a[0] = scheme_make_pair(quote_symbol,
04409                           scheme_make_pair(scheme_intern_symbol("#%utils"),
04410                                            scheme_null));
04411   v = _dynamic_require(2, a, initial_modules_env, 0, 0, 0, 0, 0, -1);
04412   if (v)
04413     return v;
04414 
04415   return NULL;
04416 }
04417 
04418 Scheme_Module *scheme_extract_compiled_module(Scheme_Object *o)
04419 {
04420   if (SAME_TYPE(SCHEME_TYPE(o), scheme_compilation_top_type)) {
04421     Scheme_Compilation_Top *c = (Scheme_Compilation_Top *)o;
04422     
04423     if (SAME_TYPE(SCHEME_TYPE(c->code), scheme_syntax_type)
04424        && (SCHEME_PINT_VAL(c->code) == MODULE_EXPD)) {
04425       return (Scheme_Module *)SCHEME_IPTR_VAL(c->code);
04426     }
04427   }
04428 
04429   return NULL;
04430 }
04431 
04432 static Scheme_Module_Exports *make_module_exports()
04433 {
04434   Scheme_Module_Exports *me;
04435   Scheme_Module_Phase_Exports *pt;
04436 
04437   me = MALLOC_ONE_RT(Scheme_Module_Exports);
04438   SET_REQUIRED_TAG(me->type = scheme_rt_module_exports);
04439 
04440   pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports);
04441   pt->so.type = scheme_module_phase_exports_type;
04442   pt->phase_index = scheme_make_integer(0);
04443   me->rt = pt;
04444 
04445   pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports);
04446   pt->so.type = scheme_module_phase_exports_type;
04447   pt->phase_index = scheme_make_integer(1);
04448   me->et = pt;
04449 
04450   pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports);
04451   pt->so.type = scheme_module_phase_exports_type;
04452   pt->phase_index = scheme_false;
04453   me->dt = pt;
04454 
04455   return me;
04456 }
04457 
04458 /**********************************************************************/
04459 /*                          define-syntaxes                           */
04460 /**********************************************************************/
04461 
04462 static void *eval_exptime_k(void)
04463 {
04464   Scheme_Thread *p = scheme_current_thread;
04465   Scheme_Object *names;
04466   int count, for_stx;
04467   Scheme_Object *expr, *certs;
04468   Scheme_Env *genv;
04469   Scheme_Comp_Env *comp_env;
04470   Resolve_Prefix *rp;
04471   int let_depth, shift;
04472   Scheme_Bucket_Table *syntax;
04473   Scheme_Object *free_id_rename_rn;
04474 
04475   names = (Scheme_Object *)p->ku.k.p1;
04476   expr = (Scheme_Object *)p->ku.k.p2;
04477   genv = (Scheme_Env *)SCHEME_CAR((Scheme_Object *)p->ku.k.p3);
04478   comp_env = (Scheme_Comp_Env *)SCHEME_CDR((Scheme_Object *)p->ku.k.p3);
04479   free_id_rename_rn = SCHEME_CAR((Scheme_Object *)p->ku.k.p4);
04480   rp = (Resolve_Prefix *)SCHEME_CAR(SCHEME_CDR((Scheme_Object *)p->ku.k.p4));
04481   syntax = (Scheme_Bucket_Table *)SCHEME_CDR(SCHEME_CDR((Scheme_Object *)p->ku.k.p4));
04482   count = p->ku.k.i1;
04483   let_depth = p->ku.k.i2;
04484   shift = p->ku.k.i3;
04485   for_stx = p->ku.k.i4;
04486   certs = (Scheme_Object *)p->ku.k.p5;
04487 
04488   p->ku.k.p1 = NULL;
04489   p->ku.k.p2 = NULL;
04490   p->ku.k.p3 = NULL;
04491   p->ku.k.p4 = NULL;
04492   p->ku.k.p5 = NULL;
04493 
04494   eval_exptime(names, count, expr, genv, comp_env, rp, let_depth, shift, syntax, for_stx, 
04495                certs, free_id_rename_rn);
04496 
04497   return NULL;
04498 }
04499 
04500 static int is_simple_expr(Scheme_Object *v)
04501 {
04502   Scheme_Type t;
04503 
04504   t = SCHEME_TYPE(v);
04505   if (SAME_TYPE(t, scheme_unclosed_procedure_type))
04506     return 1;
04507 
04508   return 0;
04509 }
04510 
04511 static void eval_exptime(Scheme_Object *names, int count,
04512                          Scheme_Object *expr, 
04513                          Scheme_Env *genv, Scheme_Comp_Env *comp_env,
04514                          Resolve_Prefix *rp,
04515                          int let_depth, int shift, Scheme_Bucket_Table *syntax,
04516                          int for_stx, Scheme_Object *certs,
04517                          Scheme_Object *free_id_rename_rn)
04518 {
04519   Scheme_Object *macro, *vals, *name, **save_runstack;
04520   int i, g, depth;
04521 
04522   depth = let_depth + scheme_prefix_depth(rp);
04523   if (!scheme_check_runstack(depth)) {
04524     Scheme_Thread *p = scheme_current_thread;
04525     p->ku.k.p1 = names;
04526     p->ku.k.p2 = expr;
04527     vals = scheme_make_pair((Scheme_Object *)genv, (Scheme_Object *)comp_env);
04528     p->ku.k.p3 = vals;
04529     vals = scheme_make_pair((Scheme_Object *)rp, (Scheme_Object *)syntax);
04530     vals = scheme_make_pair(free_id_rename_rn, vals);
04531     p->ku.k.p4 = vals;
04532     p->ku.k.i1 = count;
04533     p->ku.k.i2 = let_depth;
04534     p->ku.k.i3 = shift;
04535     p->ku.k.i4 = for_stx;
04536     p->ku.k.p5 = certs;
04537     (void)scheme_enlarge_runstack(depth, eval_exptime_k);
04538     return;
04539   }
04540 
04541   if (SCHEME_TYPE(expr) > _scheme_values_types_) {
04542     vals = expr;
04543   } else {
04544     save_runstack = scheme_push_prefix(genv, rp,
04545                                        (shift ? genv->module->me->src_modidx : NULL), 
04546                                        (shift ? genv->link_midx : NULL), 
04547                                        1, genv->phase);
04548 
04549     if (is_simple_expr(expr)) {
04550       vals = _scheme_eval_linked_expr_multi_wp(expr, scheme_current_thread);
04551     } else {
04552       Scheme_Cont_Frame_Data cframe;
04553       Scheme_Config *config;
04554       Scheme_Dynamic_State dyn_state;
04555 
04556       config = scheme_extend_config(scheme_current_config(),
04557                                     MZCONFIG_ENV,
04558                                     (Scheme_Object *)genv);
04559       scheme_push_continuation_frame(&cframe);
04560       scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
04561     
04562       scheme_set_dynamic_state(&dyn_state, comp_env, NULL, scheme_false, certs, 
04563                          genv, (genv->link_midx ? genv->link_midx : genv->module->me->src_modidx));
04564       vals = scheme_eval_linked_expr_multi_with_dynamic_state(expr, &dyn_state);
04565 
04566       scheme_pop_continuation_frame(&cframe);
04567     }
04568 
04569     scheme_pop_prefix(save_runstack);
04570   }
04571   
04572   if (SAME_OBJ(vals, SCHEME_MULTIPLE_VALUES)) {
04573     g = scheme_current_thread->ku.multiple.count;
04574     if (count == g) {
04575       Scheme_Object **values;
04576 
04577       values = scheme_current_thread->ku.multiple.array;
04578       scheme_current_thread->ku.multiple.array = NULL;
04579       if (SAME_OBJ(values, scheme_current_thread->values_buffer))
04580        scheme_current_thread->values_buffer = NULL;
04581       for (i = 0; i < g; i++, names = SCHEME_CDR(names)) {
04582        name = SCHEME_CAR(names);
04583 
04584        if (!for_stx) {
04585          macro = scheme_alloc_small_object();
04586          macro->type = scheme_macro_type;
04587          SCHEME_PTR_VAL(macro) = values[i];
04588 
04589           if (SCHEME_TRUEP(free_id_rename_rn)
04590               && scheme_is_binding_rename_transformer(values[i]))
04591             scheme_install_free_id_rename(name, scheme_rename_transformer_id(values[i]), free_id_rename_rn, 
04592                                           scheme_make_integer(0));
04593        } else
04594          macro = values[i];
04595        
04596        scheme_add_to_table(syntax, (const char *)name, macro, 0);
04597       }
04598        
04599       return;
04600     }
04601   } else if (SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names))) {
04602     name = SCHEME_CAR(names);
04603 
04604     if (!for_stx) {
04605       macro = scheme_alloc_small_object();
04606       macro->type = scheme_macro_type;
04607       SCHEME_PTR_VAL(macro) = vals;
04608 
04609       if (SCHEME_TRUEP(free_id_rename_rn)
04610           && scheme_is_binding_rename_transformer(vals))
04611         scheme_install_free_id_rename(name, scheme_rename_transformer_id(vals), free_id_rename_rn, 
04612                                       scheme_make_integer(0));
04613     } else
04614       macro = vals;
04615 
04616     scheme_add_to_table(syntax, (const char *)name, macro, 0);
04617       
04618     return;
04619   } else
04620     g = 1;
04621   
04622   if (count)
04623     name = SCHEME_CAR(names);
04624   else
04625     name = NULL;
04626   
04627   {
04628     const char *symname;
04629 
04630     symname = (name ? scheme_symbol_name(name) : "");
04631 
04632     scheme_wrong_return_arity((for_stx ? "define-values-for-syntax" : "define-syntaxes"),
04633                            count, g,
04634                            (g == 1) ? (Scheme_Object **)vals : scheme_current_thread->ku.multiple.array,
04635                            "%s%s%s",
04636                            name ? "defining \"" : "0 names",
04637                            symname,
04638                            name ? ((count == 1) ? "\"" : "\", ...") : "");
04639   }  
04640 }
04641 
04642 /**********************************************************************/
04643 /*                               module                               */
04644 /**********************************************************************/
04645 
04646 static Scheme_Object **declare_insps(int n, Scheme_Object **insps, Scheme_Object *insp)
04647 {
04648   int i;
04649   Scheme_Object **naya, *v;
04650 
04651   for (i = 0; i < n; i++) {
04652     if (insps[i] && SCHEME_PAIRP(insps[i]))
04653       break;
04654   }
04655   if (i >= n)
04656     return insps;
04657   
04658   insp = scheme_make_inspector(insp);
04659 
04660   naya = MALLOC_N(Scheme_Object*, n);
04661   for (i = 0; i < n; i++) {
04662     v = insps[i];
04663     if (v && SCHEME_PAIRP(v)) {
04664       v = cons(insp, SCHEME_CDR(v));
04665     }
04666     naya[i] = v;
04667   }
04668 
04669   return naya;
04670 }
04671 
04672 static Scheme_Object *
04673 module_execute(Scheme_Object *data)
04674 {
04675   Scheme_Module *m;
04676   Scheme_Env *env;
04677   Scheme_Env *old_menv;
04678   Scheme_Object *prefix, *insp, **rt_insps, **et_insps;
04679 
04680   m = MALLOC_ONE_TAGGED(Scheme_Module);
04681   memcpy(m, data, sizeof(Scheme_Module));
04682 
04683   prefix = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_MODULE_NAME);
04684   if (SCHEME_MODNAMEP(prefix)) {
04685     m->modname = prefix;
04686     
04687     if (m->self_modidx) {
04688       if (!SCHEME_SYMBOLP(m->self_modidx)) {
04689        Scheme_Modidx *midx = (Scheme_Modidx *)m->self_modidx;
04690        Scheme_Object *nmidx;
04691 
04692        nmidx = scheme_make_modidx(midx->path, midx->base, m->modname);
04693        m->self_modidx = nmidx;
04694 
04695        if (m->rn_stx && !SAME_OBJ(scheme_true, m->rn_stx)) {
04696          /* Delay the shift: */
04697          Scheme_Object *v;
04698          v = scheme_make_pair(m->rn_stx, (Scheme_Object *)midx);
04699          m->rn_stx = v;
04700        }
04701       }
04702     }
04703   }
04704 
04705   env = scheme_environment_from_dummy(m->dummy);
04706 
04707   if (SAME_OBJ(m->modname, kernel_modname))
04708     old_menv = scheme_get_kernel_env();
04709   else
04710     old_menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname);
04711 
04712   insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
04713   
04714   if (old_menv) {
04715     if (scheme_module_protected_wrt(old_menv->insp, insp) || old_menv->attached) {
04716       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
04717                      "module->namespace: current code inspector cannot re-declare module: %D",
04718                      m->modname);
04719       return NULL;
04720     }
04721   }
04722 
04723   if (m->me->rt->provide_insps)
04724     rt_insps = declare_insps(m->me->rt->num_provides, m->me->rt->provide_insps, insp);
04725   else
04726     rt_insps = NULL;
04727   if (m->me->et->provide_insps)
04728     et_insps = declare_insps(m->me->et->num_provides, m->me->et->provide_insps, insp);
04729   else
04730     et_insps = NULL;
04731 
04732   if (!SAME_OBJ(rt_insps, m->me->rt->provide_insps)
04733       || !SAME_OBJ(et_insps, m->me->et->provide_insps)) {
04734     /* have to clone m->me, etc. */
04735     Scheme_Module_Exports *naya_me;
04736     Scheme_Module_Phase_Exports *pt;
04737 
04738     naya_me = MALLOC_ONE_TAGGED(Scheme_Module_Exports);
04739     memcpy(naya_me, m->me, sizeof(Scheme_Module_Exports));
04740     m->me = naya_me;
04741 
04742     if (!SAME_OBJ(rt_insps, m->me->rt->provide_insps)) {
04743       pt = MALLOC_ONE_TAGGED(Scheme_Module_Phase_Exports);
04744       memcpy(pt, m->me->rt, sizeof(Scheme_Module_Phase_Exports));
04745       m->me->rt = pt;
04746       pt->provide_insps = rt_insps;
04747     }
04748 
04749     if (!SAME_OBJ(rt_insps, m->me->et->provide_insps)) {
04750       pt = MALLOC_ONE_TAGGED(Scheme_Module_Phase_Exports);
04751       memcpy(pt, m->me->et, sizeof(Scheme_Module_Phase_Exports));
04752       m->me->et = pt;
04753       pt->provide_insps = et_insps;
04754     }
04755   }
04756 
04757   m->insp = insp;
04758   scheme_hash_set(env->module_registry, m->modname, (Scheme_Object *)m);
04759   scheme_hash_set(env->export_registry, m->modname, (Scheme_Object *)m->me);
04760 
04761   /* Replacing an already-running or already-syntaxing module? */
04762   if (old_menv) {
04763     start_module(m, env, 1, NULL, old_menv->et_running, old_menv->running, env->phase, scheme_null);
04764   }
04765 
04766   return scheme_void;
04767 }
04768 
04769 static Scheme_Object *rebuild_et_vec(Scheme_Object *naya, Scheme_Object *vec, Resolve_Prefix *rp)
04770 {
04771   Scheme_Object *vec2;
04772   int i;
04773   
04774   i = SCHEME_VEC_SIZE(vec);
04775   vec2 = scheme_make_vector(i, NULL);
04776   while (i--) {
04777     SCHEME_VEC_ELS(vec2)[i] = SCHEME_VEC_ELS(vec)[i];
04778   }
04779   SCHEME_VEC_ELS(vec2)[1] = naya;
04780   SCHEME_VEC_ELS(vec2)[3] = (Scheme_Object *)rp;
04781 
04782   return vec2;
04783 }
04784 
04785 static Scheme_Object *jit_vector(Scheme_Object *orig_l, int in_vec, int jit)
04786 {
04787   Scheme_Object *orig, *naya = NULL;
04788   Resolve_Prefix *orig_rp, *rp;
04789   int i, cnt;
04790 
04791   cnt = SCHEME_VEC_SIZE(orig_l);
04792   for (i = 0; i < cnt; i++) {
04793     orig = SCHEME_VEC_ELS(orig_l)[i];
04794     if (in_vec) {
04795       orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(orig)[3];
04796       rp = scheme_prefix_eval_clone(orig_rp);
04797       orig = SCHEME_VEC_ELS(orig)[1];
04798     } else {
04799       orig_rp = rp = NULL;
04800     }
04801 
04802     if (jit)
04803       naya = scheme_jit_expr(orig);
04804     else
04805       naya = orig;
04806 
04807     if (!SAME_OBJ(orig, naya)
04808         || !SAME_OBJ(orig_rp, rp))
04809       break;
04810   }
04811 
04812   if (i < cnt) {
04813     Scheme_Object *new_l;
04814     int j;
04815     new_l = scheme_make_vector(cnt, NULL);
04816     for (j = 0; j < i; j++) {
04817       SCHEME_VEC_ELS(new_l)[j] = SCHEME_VEC_ELS(orig_l)[j];
04818     }
04819     if (in_vec)
04820       naya = rebuild_et_vec(naya, SCHEME_VEC_ELS(orig_l)[i], rp);
04821     SCHEME_VEC_ELS(new_l)[i] = naya;
04822     for (i++; i < cnt; i++) {
04823       orig = SCHEME_VEC_ELS(orig_l)[i];
04824       if (in_vec) {
04825         orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(orig)[3];
04826         rp = scheme_prefix_eval_clone(orig_rp);
04827         orig = SCHEME_VEC_ELS(orig)[1];        
04828       } else {
04829         orig_rp = rp = NULL;
04830       }
04831 
04832       if (jit)
04833         naya = scheme_jit_expr(orig);
04834       else
04835         naya = orig;
04836 
04837       if (in_vec) {
04838        if (!SAME_OBJ(orig, naya)
04839             || !SAME_OBJ(rp, orig_rp))
04840          naya = rebuild_et_vec(naya, SCHEME_VEC_ELS(orig_l)[i], rp);
04841        else
04842          naya = SCHEME_VEC_ELS(orig_l)[i];
04843       }
04844       SCHEME_VEC_ELS(new_l)[i] = naya;
04845     }
04846     return new_l;
04847   } else
04848     return orig_l;
04849 }
04850 
04851 static Scheme_Object *do_module_clone(Scheme_Object *data, int jit)
04852 {
04853   Scheme_Module *m = (Scheme_Module *)data;
04854   Scheme_Object *l1, *l2;
04855   Resolve_Prefix *rp;
04856   
04857   rp = scheme_prefix_eval_clone(m->prefix);
04858 
04859   if (jit)
04860     l1 = jit_vector(m->body, 0, jit);
04861   else
04862     l1 = m->body;
04863   l2 = jit_vector(m->et_body, 1, jit);
04864 
04865   if (SAME_OBJ(l1, m->body) 
04866       && SAME_OBJ(l2, m->body)
04867       && SAME_OBJ(rp, m->prefix))
04868     return data;
04869   
04870   m = MALLOC_ONE_TAGGED(Scheme_Module);
04871   memcpy(m, data, sizeof(Scheme_Module));
04872   m->body = l1;
04873   m->et_body = l2;
04874   m->prefix = rp;
04875 
04876   return (Scheme_Object *)m;
04877 }
04878 
04879 static Scheme_Object *module_jit(Scheme_Object *data)
04880 {
04881   return do_module_clone(data, 1);
04882 }
04883 
04884 Scheme_Object *scheme_module_eval_clone(Scheme_Object *data)
04885 {
04886   return do_module_clone(data, 0);
04887 }
04888 
04889 static void module_validate(Scheme_Object *data, Mz_CPort *port, 
04890                             char *stack, Validate_TLS tls,
04891                          int depth, int letlimit, int delta, 
04892                          int num_toplevels, int num_stxes, int num_lifts,
04893                             struct Validate_Clearing *vc, int tailpos)
04894 {
04895   Scheme_Module *m;
04896   int i, cnt, let_depth;
04897   Resolve_Prefix *rp;
04898   Scheme_Object *e;
04899 
04900   if (!SAME_TYPE(SCHEME_TYPE(data), scheme_module_type))
04901     scheme_ill_formed_code(port);
04902 
04903   m = (Scheme_Module *)data;
04904 
04905   if (!SCHEME_MODNAMEP(m->modname))
04906     scheme_ill_formed_code(port);
04907 
04908   scheme_validate_code(port, m->body, m->max_let_depth,
04909                        m->prefix->num_toplevels, m->prefix->num_stxes, m->prefix->num_lifts,
04910                        1);
04911   
04912   /* validate exp-time code */
04913   cnt = SCHEME_VEC_SIZE(m->et_body);
04914   for (i = 0; i < cnt; i++) {
04915     e = SCHEME_VEC_ELS(m->et_body)[i];
04916       
04917     let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]);
04918     rp = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[3];
04919     e = SCHEME_VEC_ELS(e)[1];
04920       
04921     scheme_validate_code(port, e, let_depth,
04922                          rp->num_toplevels, rp->num_stxes, rp->num_lifts,
04923                          0);
04924   }
04925 }
04926 
04927 static int set_code_closure_flags(Scheme_Object *clones,
04928                                   int set_flags, int mask_flags,
04929                                   int just_tentative)
04930 {
04931   Scheme_Object *clone, *orig, *first;
04932   Scheme_Closure_Data *data;
04933   int flags = CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS;
04934 
04935   /* The first in a clone pair is the one that is consulted for
04936      references. The second one is the original, and its the one whose
04937      flags are updated by optimization. So consult the original, and set
04938      flags in both. */
04939 
04940   while (clones) {
04941     first = SCHEME_CAR(clones);
04942     clone = SCHEME_CAR(first);
04943     orig = SCHEME_CDR(first);
04944 
04945     data = (Scheme_Closure_Data *)orig;
04946     if (!just_tentative || (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)) {
04947       flags = (flags & SCHEME_CLOSURE_DATA_FLAGS(data));
04948       SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
04949       data = (Scheme_Closure_Data *)clone;
04950       SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
04951     }
04952 
04953     clones = SCHEME_CDR(clones);
04954   }
04955 
04956   return flags;
04957 }
04958 
04959 static Scheme_Object *
04960 module_optimize(Scheme_Object *data, Optimize_Info *info)
04961 {
04962   Scheme_Module *m = (Scheme_Module *)data;
04963   Scheme_Object *e, *vars, *old_context;
04964   int start_simltaneous = 0, i_m, cnt;
04965   Scheme_Object *cl_first = NULL, *cl_last = NULL;
04966   Scheme_Hash_Table *consts = NULL, *ready_table = NULL, *re_consts = NULL;
04967   int cont, next_pos_ready = -1;
04968 
04969   old_context = info->context;
04970   info->context = (Scheme_Object *)m;
04971 
04972   cnt = SCHEME_VEC_SIZE(m->body);
04973   for (i_m = 0; i_m < cnt; i_m++) {
04974     /* Optimize this expression: */
04975     e = scheme_optimize_expr(SCHEME_VEC_ELS(m->body)[i_m], info);
04976     SCHEME_VEC_ELS(m->body)[i_m] = e;
04977 
04978     if (info->enforce_const) {
04979       /* If this expression/definition can't have any side effect
04980         (including raising an exception), then continue the group of
04981         simultaneous definitions: */
04982       if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_syntax_type)
04983          && (SCHEME_PINT_VAL(e) == DEFINE_VALUES_EXPD)) {
04984        int n, cnst = 0, sproc = 0;
04985 
04986        e = (Scheme_Object *)SCHEME_IPTR_VAL(e);
04987 
04988        vars = SCHEME_CAR(e);
04989        e = SCHEME_CDR(e);
04990 
04991        n = scheme_list_length(vars);
04992        cont = scheme_omittable_expr(e, n, -1, 0, info);
04993       
04994         if (n == 1) {
04995           if (scheme_compiled_propagate_ok(e, info))
04996             cnst = 1;
04997           else if (scheme_is_statically_proc(e, info)) {
04998             cnst = 1;
04999             sproc = 1;
05000           }
05001         }
05002 
05003        if (cnst) {
05004          Scheme_Toplevel *tl;
05005 
05006          tl = (Scheme_Toplevel *)SCHEME_CAR(vars);
05007 
05008          if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) {
05009            Scheme_Object *e2;
05010 
05011             if (sproc) {
05012               e2 = scheme_make_noninline_proc(e);
05013             } else if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_unclosed_procedure_type)) {
05014              e2 = scheme_optimize_clone(1, e, info, 0, 0);
05015               if (e2) {
05016                 Scheme_Object *pr;
05017                 pr = scheme_make_raw_pair(scheme_make_raw_pair(e2, e), NULL);
05018                 if (cl_last)
05019                   SCHEME_CDR(cl_last) = pr;
05020                 else
05021                   cl_first = pr;
05022                 cl_last = pr;
05023               } else
05024                 e2 = scheme_make_noninline_proc(e);
05025            } else {
05026              e2 = e;
05027            }
05028 
05029            if (e2) {
05030              int pos;
05031              if (!consts)
05032               consts = scheme_make_hash_table(SCHEME_hash_ptr);
05033              pos = tl->position;
05034              scheme_hash_set(consts, scheme_make_integer(pos), e2);
05035               if (!re_consts)
05036                 re_consts = scheme_make_hash_table(SCHEME_hash_ptr);
05037               scheme_hash_set(re_consts, scheme_make_integer(i_m), 
05038                               scheme_make_integer(pos));
05039            } else {
05040              /* At least mark it as ready */
05041              if (!ready_table) {
05042               ready_table = scheme_make_hash_table(SCHEME_hash_ptr);
05043               if (!consts)
05044                 consts = scheme_make_hash_table(SCHEME_hash_ptr);
05045               scheme_hash_set(consts, scheme_false, (Scheme_Object *)ready_table);
05046              }
05047              scheme_hash_set(ready_table, scheme_make_integer(tl->position), scheme_true);
05048            }
05049          }
05050        } else {
05051          /* The binding is not inlinable/propagatable, but unless it's
05052             set!ed, it is constant after evaluating the definition. We
05053             map the top-level position to indicate constantness. */
05054          Scheme_Object *l, *a;
05055          int pos;
05056 
05057          for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
05058            a = SCHEME_CAR(l);
05059 
05060            /* Test for ISCONST to indicate no set!: */
05061            if (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED)) {
05062              pos = SCHEME_TOPLEVEL_POS(a);
05063 
05064               next_pos_ready = pos;
05065            }
05066          }
05067        }
05068       } else {
05069        cont = scheme_omittable_expr(e, -1, -1, 0, NULL);
05070       }
05071       if (i_m + 1 == cnt)
05072        cont = 0;
05073     } else
05074       cont = 1;
05075 
05076     if (!cont) {
05077       /* If we have new constants, re-optimize to inline: */
05078       if (consts) {
05079         int flags;
05080 
05081        if (!info->top_level_consts) {
05082          info->top_level_consts = consts;
05083        } else {
05084          int i;
05085          for (i = 0; i < consts->size; i++) {
05086            if (consts->vals[i]) {
05087              scheme_hash_set(info->top_level_consts,
05088                            consts->keys[i],
05089                            consts->vals[i]);
05090            }
05091          }
05092        }
05093 
05094         /* Same as in letrec: assume CLOS_SINGLE_RESULT and
05095            CLOS_PRESERVES_MARKS for all, but then assume not for all
05096            if any turn out not (i.e., approximate fix point). */
05097         (void)set_code_closure_flags(cl_first, 
05098                                      CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE, 
05099                                      0xFFFF,
05100                                      0);
05101 
05102        while (1) {
05103          /* Re-optimize this expression. We can optimize anything without
05104              shift-cloning, since there are no local variables in scope. */
05105          e = scheme_optimize_expr(SCHEME_VEC_ELS(m->body)[start_simltaneous], info);
05106          SCHEME_VEC_ELS(m->body)[start_simltaneous] = e;
05107  
05108           if (re_consts) {
05109             /* Install optimized closures into constant table: */
05110             Scheme_Object *rpos;
05111             rpos = scheme_hash_get(re_consts, scheme_make_integer(start_simltaneous));
05112             if (rpos) {
05113               e = (Scheme_Object *)SCHEME_IPTR_VAL(e);
05114               e = SCHEME_CDR(e);
05115               if (!scheme_compiled_propagate_ok(e, info)
05116                   && scheme_is_statically_proc(e, info))
05117                 e = scheme_make_noninline_proc(e);
05118               scheme_hash_set(info->top_level_consts, rpos, e);
05119             }
05120           }
05121 
05122          if (start_simltaneous == i_m)
05123            break;
05124           start_simltaneous++;
05125        }
05126 
05127         flags = set_code_closure_flags(cl_first, 0, 0xFFFF, 0);
05128         (void)set_code_closure_flags(cl_first,
05129                                      (flags & (CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS)), 
05130                                      ~(CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE),
05131                                      1);
05132       }
05133       
05134       cl_last = cl_first = NULL;
05135       consts = NULL;
05136       re_consts = NULL;
05137       start_simltaneous = i_m + 1;
05138     }
05139 
05140     if (next_pos_ready > -1) {
05141       if (!ready_table) {
05142         ready_table = scheme_make_hash_table(SCHEME_hash_ptr);
05143         if (!consts)
05144           consts = scheme_make_hash_table(SCHEME_hash_ptr);
05145         scheme_hash_set(consts, scheme_false, (Scheme_Object *)ready_table);
05146       }
05147       scheme_hash_set(ready_table, scheme_make_integer(next_pos_ready), scheme_true);
05148       next_pos_ready = -1;
05149     }
05150   }
05151 
05152   /* Check one more time for expressions that we can omit: */
05153   {
05154     int can_omit = 0;
05155     for (i_m = 0; i_m < cnt; i_m++) {
05156       /* Optimize this expression: */
05157       e = SCHEME_VEC_ELS(m->body)[i_m];
05158       if (scheme_omittable_expr(e, -1, -1, 0, NULL)) {
05159         can_omit++;
05160       }
05161     }
05162     if (can_omit) {
05163       Scheme_Object *vec;
05164       int j = 0;
05165       vec = scheme_make_vector(cnt - can_omit, NULL);
05166       for (i_m = 0; i_m < cnt; i_m++) {
05167         /* Optimize this expression: */
05168         e = SCHEME_VEC_ELS(m->body)[i_m];
05169         if (!scheme_omittable_expr(e, -1, -1, 0, NULL)) {
05170           SCHEME_VEC_ELS(vec)[j++] = e;
05171         }
05172       }
05173       m->body = vec;
05174     }
05175   }
05176 
05177   info->context = old_context;
05178 
05179   /* Exp-time body was optimized during compilation */
05180 
05181   return scheme_make_syntax_compiled(MODULE_EXPD, data);
05182 }
05183 
05184 static Scheme_Object *
05185 module_resolve(Scheme_Object *data, Resolve_Info *old_rslv)
05186 {
05187   Scheme_Module *m = (Scheme_Module *)data;
05188   Scheme_Object *b, *lift_vec;
05189   Resolve_Prefix *rp;
05190   Resolve_Info *rslv;
05191   int i, cnt;
05192 
05193   rp = scheme_resolve_prefix(0, m->comp_prefix, 1);
05194   m->comp_prefix = NULL;
05195 
05196   b = scheme_resolve_expr(m->dummy, old_rslv);
05197   m->dummy = b;
05198 
05199   rslv = scheme_resolve_info_create(rp);
05200   rslv->enforce_const = old_rslv->enforce_const;
05201   rslv->in_module = 1;
05202   scheme_enable_expression_resolve_lifts(rslv);
05203 
05204   cnt = SCHEME_VEC_SIZE(m->body);
05205   for (i = 0; i < cnt; i++) {
05206     Scheme_Object *e;
05207     e = scheme_resolve_expr(SCHEME_VEC_ELS(m->body)[i], rslv);
05208     SCHEME_VEC_ELS(m->body)[i] = e;
05209   }
05210 
05211   m->max_let_depth = rslv->max_let_depth;
05212 
05213   lift_vec = rslv->lifts;
05214   if (!SCHEME_NULLP(SCHEME_VEC_ELS(lift_vec)[0])) {
05215     b = scheme_append(SCHEME_VEC_ELS(lift_vec)[0], scheme_vector_to_list(m->body));
05216     b = scheme_list_to_vector(b);
05217     m->body = b;
05218   }
05219   rp->num_lifts = SCHEME_INT_VAL(SCHEME_VEC_ELS(lift_vec)[1]);
05220 
05221   rp = scheme_remap_prefix(rp, rslv);
05222 
05223   m->prefix = rp;
05224 
05225   /* Exp-time body was resolved during compilation */
05226 
05227   return scheme_make_syntax_resolved(MODULE_EXPD, data);
05228 }
05229 
05230 static Scheme_Object *
05231 module_sfs(Scheme_Object *data, SFS_Info *old_info)
05232 {
05233   Scheme_Module *m = (Scheme_Module *)data;
05234   Scheme_Object *e, *ex;
05235   SFS_Info *info;
05236   int i, cnt, let_depth;
05237 
05238   if (!old_info->for_mod) {
05239     if (old_info->pass)
05240       return data;
05241 
05242     info = scheme_new_sfs_info(m->max_let_depth);
05243     info->for_mod = 1;
05244     scheme_sfs(scheme_make_syntax_resolved(MODULE_EXPD, data), 
05245                info, 
05246                m->max_let_depth);
05247     return data;
05248   }
05249 
05250   info = old_info;
05251 
05252   cnt = SCHEME_VEC_SIZE(m->body);
05253   scheme_sfs_start_sequence(info, cnt, 0);
05254 
05255   for (i = 0; i < cnt; i++) {
05256     e = scheme_sfs_expr(SCHEME_VEC_ELS(m->body)[i], info, -1);
05257     SCHEME_VEC_ELS(m->body)[i] = e;
05258   }
05259 
05260   if (!info->pass) {
05261     cnt = SCHEME_VEC_SIZE(m->et_body);
05262     for (i = 0; i < cnt; i++) {
05263       e = SCHEME_VEC_ELS(m->et_body)[i];
05264       
05265       let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]);
05266       ex = SCHEME_VEC_ELS(e)[1];
05267       
05268       info = scheme_new_sfs_info(let_depth);
05269       ex = scheme_sfs(ex, info, let_depth);
05270       SCHEME_VEC_ELS(e)[1] = ex;
05271     }
05272   }
05273 
05274   return data;
05275 }
05276 
05277 #if 0
05278 # define LOG_EXPAND_DECLS long start_time
05279 # define LOG_START_EXPAND(mod) (start_time = scheme_get_process_milliseconds())
05280 # define LOG_END_EXPAND(mod) (printf("Expanded/compiled %s [%d msec]\n", \
05281                                      scheme_write_to_string(mod->modname, NULL), \
05282                                      scheme_get_process_milliseconds() - start_time))
05283 #else
05284 # define LOG_EXPAND_DECLS /* empty */
05285 # define LOG_START_EXPAND(mod) /* empty */
05286 # define LOG_END_EXPAND(mod) /* empty */
05287 #endif
05288 
05289 static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, 
05290                             Scheme_Compile_Expand_Info *rec, int drec)
05291 {
05292   Scheme_Object *fm, *nm, *ii, *rn, *et_rn, *iidx, *self_modidx, *rmp, *rn_set;
05293   Scheme_Module *iim;
05294   Scheme_Env *menv, *top_env;
05295   Scheme_Comp_Env *benv;
05296   Scheme_Module *m;
05297   Scheme_Object *mbval, *orig_ii;
05298   int saw_mb, check_mb = 0;
05299   int restore_confusing_name = 0;
05300   LOG_EXPAND_DECLS;
05301 
05302   if (!scheme_is_toplevel(env))
05303     scheme_wrong_syntax(NULL, NULL, form, "illegal use (not at top-level)");
05304 
05305   fm = SCHEME_STX_CDR(form);
05306   if (!SCHEME_STX_PAIRP(fm))
05307     scheme_wrong_syntax(NULL, NULL, form, NULL);
05308   nm = SCHEME_STX_CAR(fm);
05309   if (!SCHEME_STX_SYMBOLP(nm))
05310     scheme_wrong_syntax(NULL, nm, form, "module name is not an identifier");
05311   fm = SCHEME_STX_CDR(fm);
05312   if (!SCHEME_STX_PAIRP(fm))
05313     scheme_wrong_syntax(NULL, NULL, form, NULL);
05314   ii = SCHEME_STX_CAR(fm);
05315   fm = SCHEME_STX_CDR(fm);
05316 
05317   m = MALLOC_ONE_TAGGED(Scheme_Module);
05318   m->so.type = scheme_module_type;
05319 
05320   /* must set before calling new_module_env: */
05321   rmp = SCHEME_STX_VAL(nm);
05322   rmp = scheme_intern_resolved_module_path(rmp);
05323   m->modname = rmp;
05324 
05325   LOG_START_EXPAND(m);
05326 
05327   if (SAME_OBJ(m->modname, kernel_modname)) {
05328     /* Too confusing. Give it a different name while compiling. */
05329     Scheme_Object *k2;
05330     k2 = scheme_intern_resolved_module_path(scheme_make_symbol("#%kernel")); /* uninterned! */
05331     m->modname = k2;
05332     restore_confusing_name = 1;
05333   }
05334 
05335   {
05336     Scheme_Module_Exports *me;
05337     me = make_module_exports();
05338     m->me = me;
05339   }
05340 
05341   top_env = env->genv;
05342   /* Create module env from phase-0 env. This doesn't create bad
05343      sharing, because compile-time module instances for compiling this
05344      module are all fresh instances. */
05345   while (top_env->phase) {
05346     scheme_prepare_template_env(top_env);
05347     top_env = top_env->template_env;
05348   }
05349 
05350   menv = scheme_new_module_env(top_env, m, 1);
05351 
05352   menv->disallow_unbound = 1;
05353   
05354   self_modidx = scheme_make_modidx(scheme_false, scheme_false, m->modname);
05355   m->self_modidx = self_modidx;
05356   m->me->src_modidx = self_modidx;
05357 
05358   m->insp = env->insp;
05359 
05360   m->ii_src = ii;
05361 
05362   orig_ii = ii;
05363   ii = scheme_syntax_to_datum(ii, 0, NULL);
05364 
05365   if (!scheme_is_module_path(ii)) {
05366     scheme_wrong_syntax(NULL, m->ii_src, form, "initial import is not a well-formed module path");
05367   }
05368 
05369   iidx = scheme_make_modidx(ii, 
05370                          self_modidx,
05371                          scheme_false);
05372 
05373   SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);
05374 
05375   /* load the module for the initial require */
05376   iim = module_load(_module_resolve(iidx, m->ii_src, NULL, 1), menv, NULL); 
05377   start_module(iim, menv, 0, iidx, 1, 0, menv->phase, scheme_null);
05378 
05379   {
05380     Scheme_Object *ins;
05381     ins = cons(iidx, scheme_null);
05382     m->requires = ins;
05383     m->et_requires = scheme_null;
05384     m->tt_requires = scheme_null;
05385     m->dt_requires = scheme_null;
05386   }
05387 
05388   scheme_prepare_env_renames(menv, mzMOD_RENAME_NORMAL);
05389 
05390   rn_set = menv->rename_set;
05391   rn = scheme_get_module_rename_from_set(rn_set, scheme_make_integer(0), 1);
05392   et_rn = scheme_get_module_rename_from_set(rn_set, scheme_make_integer(1), 1);
05393 
05394   {
05395     Scheme_Object *insp;
05396     insp = scheme_make_inspector(env->insp);
05397     menv->insp = insp;
05398   }
05399 
05400   scheme_prepare_exp_env(menv);
05401   
05402   /* For each provide in iim, add a module rename to fm */
05403   saw_mb = add_simple_require_renames(NULL, rn_set, NULL, iim, iidx, scheme_make_integer(0), NULL, 1);
05404 
05405   if (rec[drec].comp)
05406     benv = scheme_new_comp_env(menv, env->insp, SCHEME_MODULE_FRAME);
05407   else
05408     benv = scheme_new_expand_env(menv, env->insp, SCHEME_MODULE_FRAME);
05409 
05410   /* If fm isn't a single expression, it certainly needs a
05411      `#%module-begin': */
05412   if (SCHEME_STX_PAIRP(fm) && SCHEME_STX_NULLP(SCHEME_STX_CDR(fm))) {
05413     /* Perhaps expandable... */
05414     fm = SCHEME_STX_CAR(fm);
05415   } else {
05416     fm = scheme_make_pair(scheme_datum_to_syntax(module_begin_symbol, form, scheme_false, 0, 2), 
05417                        fm);
05418     check_mb = 1;
05419   }
05420 
05421   fm = scheme_datum_to_syntax(fm, form, form, 0, 2);
05422 
05423   if (check_mb) {
05424     SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer, fm);
05425   }
05426 
05427   fm = scheme_stx_property(fm, module_name_symbol, SCHEME_PTR_VAL(m->modname));
05428 
05429   if (!empty_self_modidx) {
05430     REGISTER_SO(empty_self_modidx);
05431     REGISTER_SO(empty_self_modname);
05432     empty_self_modidx = scheme_make_modidx(scheme_false, scheme_false, scheme_false);
05433     empty_self_modname = scheme_make_symbol("expanded module"); /* uninterned */
05434     empty_self_modname = scheme_intern_resolved_module_path(empty_self_modname);
05435   }
05436   
05437   /* phase shift to replace self_modidx of previous expansion (if any): */
05438   fm = scheme_stx_phase_shift(fm, 0, empty_self_modidx, self_modidx, NULL);
05439 
05440   fm = scheme_add_rename(fm, rn_set);
05441 
05442   SCHEME_EXPAND_OBSERVE_RENAME_ONE(rec[drec].observer, fm);
05443 
05444   if (!check_mb) {
05445 
05446     fm = scheme_check_immediate_macro(fm, benv, rec, drec, 0, &mbval, NULL, NULL);
05447 
05448     /* If expansion is not the primitive `#%module-begin', add local one: */
05449     if (!SAME_OBJ(mbval, modbeg_syntax)) {
05450       Scheme_Object *mb;
05451       mb = scheme_datum_to_syntax(module_begin_symbol, form, scheme_false, 0, 0);
05452       fm = scheme_make_pair(mb, scheme_make_pair(fm, scheme_null));
05453       fm = scheme_datum_to_syntax(fm, form, form, 0, 2);
05454       fm = scheme_stx_property(fm, module_name_symbol, SCHEME_PTR_VAL(m->modname));
05455       /* Since fm is a newly-created syntax object, we need to re-add renamings: */
05456       fm = scheme_add_rename(fm, rn_set);
05457       
05458       SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer, fm);
05459 
05460       check_mb = 1;
05461     }
05462   }
05463 
05464   if (check_mb && !saw_mb) {
05465     scheme_wrong_syntax(NULL, NULL, form, 
05466                      "no #%%module-begin binding in the module's language");
05467   }
05468 
05469   if (rec[drec].comp) {
05470     Scheme_Object *dummy, *pv;
05471 
05472     dummy = scheme_make_environment_dummy(env);
05473     m->dummy = dummy;
05474     
05475     scheme_compile_rec_done_local(rec, drec);
05476     fm = scheme_compile_expr(fm, benv, rec, drec);
05477 
05478     /* result should be a module body value: */
05479     if (!SAME_OBJ(fm, (Scheme_Object *)m)) {
05480       scheme_wrong_syntax(NULL, NULL, form, "compiled body was not built with #%%module-begin");
05481     }
05482 
05483     if (restore_confusing_name)
05484       m->modname = kernel_modname;
05485 
05486     m->ii_src = NULL;
05487 
05488     pv = scheme_stx_property(form, scheme_intern_symbol("module-language"), NULL);
05489     if (pv && SCHEME_TRUEP(pv)) {
05490       if (SCHEME_VECTORP(pv)
05491           && (3 == SCHEME_VEC_SIZE(pv))
05492           && scheme_is_module_path(SCHEME_VEC_ELS(pv)[0])
05493           && SCHEME_SYMBOLP(SCHEME_VEC_ELS(pv)[1]))
05494         m->lang_info = pv;
05495     }
05496 
05497     fm = scheme_make_syntax_compiled(MODULE_EXPD, (Scheme_Object *)m);
05498   } else {
05499     Scheme_Object *hints, *formname;
05500 
05501     fm = scheme_expand_expr(fm, benv, rec, drec);
05502 
05503     m->ii_src = NULL;
05504 
05505     hints = m->hints;
05506     m->hints = NULL;
05507 
05508     formname = SCHEME_STX_CAR(form);
05509     fm = cons(formname,
05510              cons(nm,
05511                  cons(orig_ii, cons(fm, scheme_null))));
05512 
05513     fm = scheme_datum_to_syntax(fm, form, form, 0, 2);
05514     
05515     if (hints) {
05516       fm = scheme_stx_property(fm, 
05517                             scheme_intern_symbol("module-direct-requires"),
05518                             m->requires);
05519       fm = scheme_stx_property(fm, 
05520                             scheme_intern_symbol("module-direct-for-syntax-requires"),
05521                             m->et_requires);
05522       fm = scheme_stx_property(fm, 
05523                             scheme_intern_symbol("module-direct-for-template-requires"),
05524                             m->tt_requires);
05525       
05526       fm = scheme_stx_property(fm, 
05527                             scheme_intern_symbol("module-variable-provides"),
05528                             SCHEME_CAR(hints));
05529       hints = SCHEME_CDR(hints);
05530       fm = scheme_stx_property(fm, 
05531                             scheme_intern_symbol("module-syntax-provides"),
05532                             SCHEME_CAR(hints));
05533       hints = SCHEME_CDR(hints);
05534       fm = scheme_stx_property(fm, 
05535                             scheme_intern_symbol("module-indirect-provides"),
05536                             SCHEME_CAR(hints));
05537       hints = SCHEME_CDR(hints);
05538       fm = scheme_stx_property(fm, 
05539                             scheme_intern_symbol("module-kernel-reprovide-hint"),
05540                             SCHEME_CAR(hints));
05541       fm = scheme_stx_property(fm, 
05542                             scheme_intern_symbol("module-self-path-index"),
05543                             empty_self_modidx);
05544     }
05545 
05546     /* for future expansion, shift away from self_modidx: */
05547     fm = scheme_stx_phase_shift(fm, 0, self_modidx, empty_self_modidx, NULL);
05548 
05549     /* make self_modidx like the empty modidx */
05550     ((Scheme_Modidx *)self_modidx)->resolved = empty_self_modname;
05551   }
05552 
05553   if (rec[drec].comp || (rec[drec].depth != -2)) {
05554     /* rename tables no longer needed; NULL them out */
05555     menv->rename_set = NULL;
05556     menv->post_ex_rename_set = NULL;
05557   }
05558 
05559   LOG_END_EXPAND(m);
05560 
05561   SCHEME_EXPAND_OBSERVE_RENAME_ONE(rec[drec].observer, fm);
05562   return fm;
05563 }
05564 
05565 static Scheme_Object *
05566 module_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
05567 {
05568   return do_module(form, env, rec, drec);
05569 }
05570 
05571 static Scheme_Object *
05572 module_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
05573 {
05574   SCHEME_EXPAND_OBSERVE_PRIM_MODULE(erec[drec].observer);
05575   if (erec[drec].depth > 0)
05576     erec[drec].depth++;
05577 
05578   return do_module(form, env, erec, drec);
05579 }
05580 
05581 /* For mzc: */
05582 Scheme_Object *scheme_apply_for_syntax_in_env(Scheme_Object *proc, Scheme_Env *env)
05583 {
05584   Scheme_Comp_Env *rhs_env;
05585   Scheme_Dynamic_State dyn_state;
05586 
05587   rhs_env = scheme_new_comp_env(env, NULL, SCHEME_TOPLEVEL_FRAME);
05588 
05589   scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, scheme_false, NULL, 
05590       env, (env->link_midx 
05591         ? env->link_midx 
05592         : (env->module
05593           ? env->module->me->src_modidx
05594           : NULL)));
05595 
05596   return scheme_apply_multi_with_dynamic_state(proc, 0, NULL, &dyn_state);
05597 }
05598 
05599 /**********************************************************************/
05600 /*                          #%module-begin                            */
05601 /**********************************************************************/
05602 
05603 static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, 
05604                                Scheme_Object *nominal_modidx, Scheme_Object *nominal_name,
05605                             Scheme_Object *modidx, Scheme_Object *exname, int exet,
05606                             int isval, void *tables, Scheme_Object *e, Scheme_Object *form, 
05607                                Scheme_Object *err_src, Scheme_Object *mark_src,
05608                                Scheme_Object *phase, Scheme_Object *src_phase_index,
05609                                Scheme_Object *nominal_export_phase, Scheme_Object *in_insp)
05610 {
05611   Scheme_Bucket_Table *toplevel, *syntax;
05612   Scheme_Hash_Table *required;
05613   Scheme_Object *vec, *nml, *tvec;
05614 
05615   tvec = scheme_hash_get((Scheme_Hash_Table *)tables, phase);
05616   if (!tvec) {
05617     required = get_required_from_tables(tables, phase);
05618     toplevel = NULL;
05619     syntax = NULL;
05620   } else {
05621     toplevel = (Scheme_Bucket_Table *)(SCHEME_VEC_ELS(tvec)[0]);
05622     required = (Scheme_Hash_Table *)(SCHEME_VEC_ELS(tvec)[1]);
05623     syntax = (Scheme_Bucket_Table *)(SCHEME_VEC_ELS(tvec)[2]);
05624   }
05625 
05626   /* Check that it's not yet defined: */
05627   if (toplevel) {
05628     if (scheme_lookup_in_table(toplevel, (const char *)name)) {
05629       scheme_wrong_syntax("module", prnt_name, form, "imported identifier already defined");
05630     }
05631   }
05632 
05633   if (!SAME_OBJ(src_phase_index, scheme_make_integer(0))
05634       || !SAME_OBJ(nominal_export_phase, scheme_make_integer(0))
05635       || !SAME_OBJ(nominal_name, prnt_name)) {
05636     nominal_modidx = scheme_make_pair(nominal_modidx,
05637                                       scheme_make_pair(src_phase_index,
05638                                                        scheme_make_pair(nominal_name,
05639                                                                         scheme_make_pair(nominal_export_phase,
05640                                                                                          scheme_null))));
05641   }
05642            
05643   /* Check not required, or required from same module: */
05644   vec = scheme_hash_get(required, name);
05645   if (vec) {
05646     Scheme_Object *srcs;
05647     char *fromsrc = NULL, *fromsrc_colon = "";
05648     long fromsrclen = 0;
05649     
05650     if (same_resolved_modidx(SCHEME_VEC_ELS(vec)[1], modidx)
05651        && SAME_OBJ(SCHEME_VEC_ELS(vec)[2], exname)) {
05652       /* already required, same source; add redundant nominal (for re-provides),
05653          and also add source phase for re-provides. */
05654       nml = scheme_make_pair(nominal_modidx, SCHEME_VEC_ELS(vec)[0]);
05655       SCHEME_VEC_ELS(vec)[0] = nml;
05656       SCHEME_VEC_ELS(vec)[7] = scheme_false;
05657       return; 
05658     }
05659 
05660     if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) {
05661       /* can override */
05662     } else {
05663       /* error: already imported */
05664       srcs = scheme_null;
05665       if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[5])) {
05666         srcs = scheme_make_pair(SCHEME_VEC_ELS(vec)[5], srcs);
05667         /* don't use error_write_to_string_w_max since this is code */
05668         if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC))) {
05669           fromsrc = scheme_write_to_string_w_max(scheme_syntax_to_datum(SCHEME_VEC_ELS(vec)[5], 0, NULL), 
05670                                                  &fromsrclen, 32);
05671           fromsrc_colon = ":";
05672         }
05673       }
05674       
05675       if (!fromsrc) {
05676         fromsrc = "a different source";
05677         fromsrclen = strlen(fromsrc);
05678       }
05679 
05680       if (err_src)
05681         srcs = scheme_make_pair(err_src, srcs);
05682 
05683       scheme_wrong_syntax_with_more_sources("module", prnt_name, err_src, srcs,
05684                                             "identifier already imported from%s %t",
05685                                             fromsrc_colon, fromsrc, fromsrclen);
05686     }
05687   }
05688            
05689   /* Check not syntax: */
05690   if (syntax) {
05691     if (scheme_lookup_in_table(syntax, (const char *)name)) {
05692       scheme_wrong_syntax("module", prnt_name, form, "imported identifier already defined");
05693     }
05694   }
05695 
05696   /* Remember require: */
05697   vec = scheme_make_vector(10, NULL);
05698   nml = scheme_make_pair(nominal_modidx, scheme_null);
05699   SCHEME_VEC_ELS(vec)[0] = nml;
05700   SCHEME_VEC_ELS(vec)[1] = modidx;
05701   SCHEME_VEC_ELS(vec)[2] = exname;
05702   SCHEME_VEC_ELS(vec)[3] = (isval ? scheme_true : scheme_false);
05703   SCHEME_VEC_ELS(vec)[4] = prnt_name;
05704   SCHEME_VEC_ELS(vec)[5] = (err_src ? err_src : scheme_false);
05705   SCHEME_VEC_ELS(vec)[6] = (mark_src ? mark_src : scheme_false);
05706   SCHEME_VEC_ELS(vec)[7] = scheme_false;
05707   SCHEME_VEC_ELS(vec)[8] = scheme_make_integer(exet);
05708   SCHEME_VEC_ELS(vec)[9] = in_insp;
05709   scheme_hash_set(required, name, vec);
05710 }
05711 
05712 static int check_already_required(Scheme_Hash_Table *required, Scheme_Object *name)
05713 {
05714   Scheme_Object *vec;
05715 
05716   vec = scheme_hash_get(required, name);
05717   if (vec) {
05718     if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) {
05719       scheme_hash_set(required, name, NULL);
05720       return 0;
05721     }
05722     return 1;
05723   }
05724 
05725   return 0;
05726 }
05727 
05728 static Scheme_Object *stx_sym(Scheme_Object *name, Scheme_Object *_genv)
05729 {
05730   return scheme_tl_id_sym((Scheme_Env *)_genv, name, NULL, 2, NULL, NULL);
05731 }
05732 
05733 static Scheme_Object *add_a_rename(Scheme_Object *fm, Scheme_Object *post_ex_rn)
05734 {
05735   return scheme_add_rename(fm, post_ex_rn);
05736 }
05737 
05738 static Scheme_Object *add_req(Scheme_Object *imods, Scheme_Object *requires)
05739 {
05740   for (; !SCHEME_NULLP(imods); imods = SCHEME_CDR(imods)) {
05741     Scheme_Object *il, *ilast = NULL;
05742     Scheme_Object *idx = SCHEME_CAR(imods);
05743     
05744     for (il = requires; SCHEME_PAIRP(il); il = SCHEME_CDR(il)) {
05745       if (same_modidx(idx, SCHEME_CAR(il)))
05746        break;
05747       ilast = il;
05748     }
05749     
05750     if (SCHEME_NULLP(il)) {
05751       il = scheme_make_pair(idx, scheme_null);
05752       if (ilast)
05753        SCHEME_CDR(ilast) = il;
05754       else
05755        requires = il;
05756     }
05757   }
05758 
05759   return requires;
05760 }
05761 
05762 static Scheme_Object *add_lifted_defn(Scheme_Object *data, Scheme_Object **_ids, Scheme_Object *expr, Scheme_Comp_Env *_env)
05763 {
05764   Scheme_Comp_Env *env;
05765   Scheme_Object *self_modidx, *rn, *name, *ids, *id, *new_ids = scheme_null;
05766 
05767   env = (Scheme_Comp_Env *)SCHEME_VEC_ELS(data)[0];
05768   self_modidx = SCHEME_VEC_ELS(data)[1];
05769   rn = SCHEME_VEC_ELS(data)[2];
05770 
05771   for (ids = *_ids; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) {
05772     id = SCHEME_CAR(ids);
05773   
05774     name = scheme_tl_id_sym(env->genv, id, scheme_false, 2, NULL, NULL);
05775 
05776     /* Create the bucket, indicating that the name will be defined: */
05777     scheme_add_global_symbol(name, scheme_undefined, env->genv);
05778   
05779     /* Add a renaming: */
05780     scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, NULL, 0);
05781 
05782     id = scheme_add_rename(id, rn);
05783     new_ids = cons(id, new_ids);
05784   }
05785 
05786   new_ids = scheme_reverse(new_ids);
05787   *_ids = new_ids;
05788 
05789   return scheme_make_lifted_defn(scheme_sys_wraps(env), _ids, expr, _env);
05790 }
05791 
05792 static Scheme_Object *make_require_form(Scheme_Object *module_path, long phase, Scheme_Object *mark)
05793 {
05794   Scheme_Object *e = module_path;
05795 
05796   if (phase != 0) {
05797     e = scheme_make_pair(for_meta_symbol,
05798                          scheme_make_pair(scheme_make_integer(phase),
05799                                           scheme_make_pair(e,
05800                                                            scheme_null)));
05801   }
05802   e = scheme_make_pair(require_stx, scheme_make_pair(e, scheme_null));
05803   e = scheme_datum_to_syntax(e, scheme_false, scheme_false, 0, 0);
05804 
05805   e = scheme_add_remove_mark(e, mark);
05806 
05807   return e;
05808 }
05809 
05810 Scheme_Object *scheme_parse_lifted_require(Scheme_Object *module_path,
05811                                            long phase,
05812                                            Scheme_Object *mark,
05813                                            void *data)
05814 {
05815   Scheme_Object *e;
05816   Scheme_Object *base_modidx = (Scheme_Object *)((void **)data)[1];
05817   Scheme_Env *env = (Scheme_Env *)((void **)data)[2];
05818   Scheme_Module *for_m = (Scheme_Module *)((void **)data)[3];
05819   Scheme_Object *rns = (Scheme_Object *)((void **)data)[4];
05820   Scheme_Object *post_ex_rns = (Scheme_Object *)((void **)data)[5];
05821   void *tables = ((void **)data)[6];
05822   Scheme_Object *redef_modname = (Scheme_Object *)((void **)data)[7];
05823   int *all_simple = (int *)((void **)data)[8];
05824 
05825   e = make_require_form(module_path, phase, mark);
05826 
05827   parse_requires(e, base_modidx, env, for_m,
05828                  rns, post_ex_rns,
05829                  check_require_name, tables,
05830                  redef_modname, 
05831                  0, 0, 1, 
05832                  1, 0,
05833                  all_simple);
05834 
05835   return e;
05836 }
05837 
05838 static Scheme_Object *package_require_data(Scheme_Object *base_modidx,
05839                                            Scheme_Env *env,
05840                                            Scheme_Module *for_m,
05841                                            Scheme_Object *rns, Scheme_Object *post_ex_rns,
05842                                            void *data,
05843                                            Scheme_Object *redef_modname,
05844                                            int *all_simple)
05845 {
05846   void **vals;
05847 
05848   vals = MALLOC_N(void*, 9);
05849   vals[0] = NULL; /* this slot is available */
05850   vals[1] = base_modidx;
05851   vals[2] = env;
05852   vals[3] = for_m;
05853   vals[4] = rns;
05854   vals[5] = post_ex_rns;
05855   vals[6] = data;
05856   vals[7] = redef_modname;
05857   vals[8] = all_simple;
05858 
05859   return scheme_make_raw_pair((Scheme_Object *)vals, NULL);
05860 }
05861 
05862 
05863 static void flush_definitions(Scheme_Env *genv)
05864 {
05865   if (genv->syntax) {
05866     Scheme_Bucket_Table *t;
05867     t = scheme_make_bucket_table(7, SCHEME_hash_ptr);
05868     genv->syntax = t;
05869   }
05870   if (genv->toplevel) {
05871     Scheme_Bucket_Table *t;
05872     t = scheme_make_bucket_table(7, SCHEME_hash_ptr);
05873     t->with_home = 1;
05874     genv->toplevel = t;
05875   }
05876 }
05877 
05878 static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, 
05879                                   Scheme_Compile_Expand_Info *rec, int drec)
05880 {
05881   Scheme_Object *fm, *first, *last, *p, *rn_set, *rn, *exp_body, *et_rn, *self_modidx, *prev_p;
05882   Scheme_Comp_Env *xenv, *cenv, *rhs_env;
05883   Scheme_Hash_Table *et_required; /* just to avoid duplicates */
05884   Scheme_Hash_Table *required;    /* name -> (vector nominal-modidx-list modidx srcname var? prntname) */
05885                               /*   first nominal-modidx goes with modidx, rest are for re-provides */
05886   Scheme_Hash_Table *provided;    /* exname -> (cons locname-stx-or-sym protected?) */
05887   Scheme_Hash_Table *all_reprovided; /* phase -> list of (list modidx syntax except-name ...) */
05888   Scheme_Object *all_defs_out;    /* list of (cons protected? (stx-list except-name ...)) */
05889   Scheme_Object *all_et_defs_out;
05890   Scheme_Hash_Table *all_provided; /* phase -> table like `provided' */
05891   Scheme_Object *all_defs;        /* list of stxid; this is almost redundant to the syntax and toplevel
05892                                  tables, but it preserves the original name for exporting */
05893   Scheme_Object *all_et_defs;
05894   Scheme_Object *post_ex_rn, *post_ex_et_rn; /* renames for ids introduced by expansion */
05895   Scheme_Object *post_ex_rn_set; /* phase -> post_ex_rn-like rename */
05896   Scheme_Hash_Table *tables; /* phase -> (vector toplevels requires syntaxes) */
05897   Scheme_Object *lift_data;
05898   Scheme_Object **exis, **et_exis, **exsis;
05899   Scheme_Object *lift_ctx;
05900   Scheme_Object *lifted_reqs = scheme_null, *req_data;
05901   int exicount, et_exicount, exsicount;
05902   char *exps, *et_exps;
05903   int *all_simple_renames;
05904   int maybe_has_lifts = 0;
05905   Scheme_Object *redef_modname;
05906   Scheme_Object *observer;
05907 
05908   if (!(env->flags & SCHEME_MODULE_FRAME))
05909     scheme_wrong_syntax(NULL, NULL, form, "illegal use (not a module body)");
05910 
05911   if (scheme_stx_proper_list_length(form) < 0)
05912     scheme_wrong_syntax(NULL, NULL, form, "bad syntax (" IMPROPER_LIST_FORM ")");
05913 
05914   if (!env->genv->module)
05915     scheme_wrong_syntax(NULL, NULL, form, "not currently transforming a module");
05916 
05917   /* Redefining a module? */
05918   redef_modname = env->genv->module->modname;
05919   if (!scheme_hash_get(env->genv->module_registry, redef_modname))
05920     redef_modname = NULL;
05921 
05922   /* Expand each expression in form up to `begin', `define-values', `define-syntax', 
05923      `require', `provide', `#%app', etc. */
05924   xenv = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME 
05925                                      | SCHEME_MODULE_BEGIN_FRAME
05926                                      | SCHEME_FOR_STOPS), 
05927                                   env, NULL);
05928   {
05929     Scheme_Object *stop;
05930     stop = scheme_get_stop_expander();
05931     scheme_add_local_syntax(20, xenv);
05932     scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv);
05933     scheme_set_local_syntax(1, scheme_define_values_stx, stop, xenv);
05934     scheme_set_local_syntax(2, scheme_define_syntaxes_stx, stop, xenv);
05935     scheme_set_local_syntax(3, define_for_syntaxes_stx, stop, xenv);
05936     scheme_set_local_syntax(4, require_stx, stop, xenv);
05937     scheme_set_local_syntax(5, provide_stx, stop, xenv);
05938     scheme_set_local_syntax(6, set_stx, stop, xenv);
05939     scheme_set_local_syntax(7, app_stx, stop, xenv);
05940     scheme_set_local_syntax(8, scheme_top_stx, stop, xenv);
05941     scheme_set_local_syntax(9, lambda_stx, stop, xenv);
05942     scheme_set_local_syntax(10, case_lambda_stx, stop, xenv);
05943     scheme_set_local_syntax(11, let_values_stx, stop, xenv);
05944     scheme_set_local_syntax(12, letrec_values_stx, stop, xenv);
05945     scheme_set_local_syntax(13, if_stx, stop, xenv);
05946     scheme_set_local_syntax(14, begin0_stx, stop, xenv);
05947     scheme_set_local_syntax(15, set_stx, stop, xenv);
05948     scheme_set_local_syntax(16, with_continuation_mark_stx, stop, xenv);
05949     scheme_set_local_syntax(17, letrec_syntaxes_stx, stop, xenv);
05950     scheme_set_local_syntax(18, var_ref_stx, stop, xenv);
05951     scheme_set_local_syntax(19, expression_stx, stop, xenv);
05952   }
05953 
05954   first = scheme_null;
05955   last = NULL;
05956 
05957   rn_set = env->genv->rename_set;
05958   rn = scheme_get_module_rename_from_set(rn_set, scheme_make_integer(0), 1);
05959   et_rn = scheme_get_module_rename_from_set(rn_set, scheme_make_integer(1), 1);
05960 
05961   required = scheme_make_hash_table(SCHEME_hash_ptr);
05962   et_required = scheme_make_hash_table(SCHEME_hash_ptr);
05963 
05964   tables = scheme_make_hash_table_equal();
05965   {
05966     Scheme_Object *vec;
05967 
05968     vec = scheme_make_vector(3, NULL);
05969     SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->genv->toplevel;
05970     SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)required;
05971     SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)env->genv->syntax;
05972     scheme_hash_set(tables, scheme_make_integer(0), vec);
05973 
05974     vec = scheme_make_vector(3, NULL);
05975     SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->genv->exp_env->toplevel;
05976     SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)et_required;
05977     SCHEME_VEC_ELS(vec)[2] = NULL;
05978     scheme_hash_set(tables, scheme_make_integer(1), vec);
05979   }
05980 
05981   /* Put initial requires into the table:
05982      (This is redundant for the rename set, but we need to fill
05983      the `all_requires' table, etc.) */
05984   {
05985     Scheme_Module *iim;
05986     Scheme_Object *nmidx, *orig_src;
05987 
05988     /* stx src of original import: */
05989     orig_src = env->genv->module->ii_src;
05990     if (!orig_src)
05991       orig_src = scheme_false;
05992     else if (!SCHEME_STXP(orig_src))
05993       orig_src = scheme_false;
05994     
05995     nmidx = SCHEME_CAR(env->genv->module->requires);
05996     iim = module_load(scheme_module_resolve(nmidx, 1), env->genv, NULL);
05997 
05998     add_simple_require_renames(orig_src, rn_set, tables, 
05999                                iim, nmidx,
06000                                scheme_make_integer(0),
06001                                NULL, 1);
06002   }
06003 
06004   {
06005     Scheme_Object *v;
06006     v = scheme_rename_to_stx(rn_set);
06007     env->genv->module->rn_stx = v;
06008   }
06009 
06010   provided = scheme_make_hash_table(SCHEME_hash_ptr);
06011   all_provided = scheme_make_hash_table_equal();
06012   scheme_hash_set(all_provided, scheme_make_integer(0), (Scheme_Object *)provided);
06013 
06014   all_reprovided = scheme_make_hash_table_equal();
06015 
06016   all_defs_out = scheme_null;
06017   all_et_defs_out = scheme_null;
06018 
06019   all_defs = scheme_null;
06020   all_et_defs = scheme_null;
06021 
06022   exp_body = scheme_null;
06023 
06024   self_modidx = env->genv->module->self_modidx;
06025 
06026   post_ex_rn_set = scheme_make_module_rename_set(mzMOD_RENAME_MARKED, rn_set);
06027   post_ex_rn = scheme_get_module_rename_from_set(post_ex_rn_set, scheme_make_integer(0), 1);
06028   post_ex_et_rn = scheme_get_module_rename_from_set(post_ex_rn_set, scheme_make_integer(1), 1);
06029   env->genv->post_ex_rename_set = post_ex_rn_set;
06030 
06031   /* For syntax-local-context, etc., in a d-s RHS: */
06032   rhs_env = scheme_new_comp_env(env->genv, env->insp, SCHEME_TOPLEVEL_FRAME);
06033 
06034   scheme_rec_add_certs(rec, drec, form);
06035 
06036   observer = rec[drec].observer;
06037 
06038   /* It's possible that #%module-begin expansion introduces
06039      marked identifiers for definitions. */
06040   form = scheme_add_rename(form, post_ex_rn_set);
06041   SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, form);
06042 
06043   maybe_has_lifts = 0;
06044   lift_ctx = scheme_generate_lifts_key();
06045 
06046   all_simple_renames = (int *)scheme_malloc_atomic(sizeof(int));
06047   *all_simple_renames = 1;
06048 
06049   req_data = package_require_data(self_modidx, env->genv, env->genv->module,
06050                                   rn_set, post_ex_rn_set,
06051                                   tables,
06052                                   redef_modname, 
06053                                   all_simple_renames);
06054 
06055   /* Pass 1 */
06056 
06057   /* Partially expand all expressions, and process definitions, requires,
06058      and provides. Also, flatten top-level `begin' expressions: */
06059   for (fm = SCHEME_STX_CDR(form); !SCHEME_STX_NULLP(fm); ) {
06060     Scheme_Object *e;
06061     int kind;
06062 
06063     while (1) {
06064       Scheme_Object *fst;
06065 
06066       SCHEME_EXPAND_OBSERVE_NEXT(observer);
06067 
06068       e = SCHEME_STX_CAR(fm);
06069 
06070       p = (maybe_has_lifts 
06071            ? scheme_frame_get_end_statement_lifts(xenv) 
06072            : scheme_null);
06073       prev_p = (maybe_has_lifts 
06074                 ? scheme_frame_get_provide_lifts(xenv) 
06075                 : scheme_null);
06076       scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv), 
06077                                   p, lift_ctx, req_data, prev_p);
06078       maybe_has_lifts = 1;
06079 
06080       {
06081        Scheme_Expand_Info erec1;
06082        erec1.comp = 0;
06083        erec1.depth = -1;
06084        erec1.value_name = scheme_false;
06085        erec1.certs = rec[drec].certs;
06086         erec1.observer = rec[drec].observer;
06087         erec1.pre_unwrapped = 0;
06088         erec1.no_module_cert = 0;
06089         erec1.env_already = 0;
06090         erec1.comp_flags = rec[drec].comp_flags;
06091        e = scheme_expand_expr(e, xenv, &erec1, 0);      
06092       }
06093 
06094       lifted_reqs = scheme_append(scheme_frame_get_require_lifts(xenv), lifted_reqs);
06095 
06096       fst = scheme_frame_get_lifts(xenv);
06097       if (!SCHEME_NULLP(fst)) {
06098        /* Expansion lifted expressions, so add them to
06099           the front and try again. */
06100         *all_simple_renames = 0;
06101        fm = SCHEME_STX_CDR(fm);
06102         e = scheme_add_rename(e, post_ex_rn_set);
06103         fm = scheme_named_map_1(NULL, add_a_rename, fm, post_ex_rn_set);
06104         fm = scheme_make_pair(e, fm);
06105         SCHEME_EXPAND_OBSERVE_RENAME_LIST(observer, fm);
06106        fm = scheme_append(fst, fm);
06107         SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, fst);
06108       } else {
06109        /* No definition lifts added... */
06110        if (SCHEME_STX_PAIRP(e))
06111          fst = SCHEME_STX_CAR(e);
06112        else
06113          fst = NULL;
06114        
06115        if (fst && SCHEME_STX_SYMBOLP(fst) && scheme_stx_module_eq(scheme_begin_stx, fst, 0)) {
06116          fm = SCHEME_STX_CDR(fm);
06117          e = scheme_add_rename(e, post_ex_rn_set);
06118           SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e);
06119          fm = scheme_flatten_begin(e, fm);
06120          SCHEME_EXPAND_OBSERVE_SPLICE(observer, fm);
06121          if (SCHEME_STX_NULLP(fm)) {
06122             e = scheme_frame_get_provide_lifts(xenv);
06123             e = scheme_reverse(e);
06124             fm = scheme_frame_get_end_statement_lifts(xenv);
06125             fm = scheme_reverse(fm);
06126             if (!SCHEME_NULLP(e))
06127               fm = scheme_append(fm, e);
06128             SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, fm);
06129             maybe_has_lifts = 0;
06130             if (SCHEME_NULLP(fm)) {
06131               e = NULL;
06132               break;
06133             }
06134          }
06135        } else
06136           break;
06137       }
06138     }
06139     if (!e) break; /* (begin) expansion at end */
06140 
06141     e = scheme_add_rename(e, post_ex_rn_set);
06142 
06143     SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e);
06144     
06145     if (SCHEME_STX_PAIRP(e)) {
06146       Scheme_Object *fst;
06147 
06148       fst = SCHEME_STX_CAR(e);
06149 
06150       if (SCHEME_STX_SYMBOLP(fst)) {
06151 
06152        Scheme_Object *n;
06153        n = SCHEME_STX_CAR(e);
06154        if (scheme_stx_module_eq(scheme_define_values_stx, fst, 0)) {
06155          /************ define-values *************/
06156          Scheme_Object *vars, *val;
06157 
06158           SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
06159           SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(observer);
06160 
06161          /* Create top-level vars */
06162          scheme_define_parse(e, &vars, &val, 0, env, 1);
06163 
06164          while (SCHEME_STX_PAIRP(vars)) {
06165            Scheme_Object *name, *orig_name;
06166 
06167            name = SCHEME_STX_CAR(vars);
06168 
06169            orig_name = name;
06170 
06171            /* Remember the original: */
06172            all_defs = scheme_make_pair(name, all_defs);
06173            
06174            name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL, NULL);
06175 
06176            /* Check that it's not yet defined: */
06177            if (scheme_lookup_in_table(env->genv->toplevel, (const char *)name)) {
06178              scheme_wrong_syntax("module", orig_name, e, "duplicate definition for identifier");
06179              return NULL;
06180            }
06181 
06182            /* Not required: */
06183            if (check_already_required(required, name)) {
06184              scheme_wrong_syntax("module", orig_name, e, "identifier is already imported");
06185              return NULL;
06186            }
06187 
06188            /* Not syntax: */
06189            if (scheme_lookup_in_table(env->genv->syntax, (const char *)name)) {
06190              scheme_wrong_syntax("module", orig_name, e, "duplicate definition for identifier");
06191              return NULL;
06192            }
06193 
06194            /* Create the bucket, indicating that the name will be defined: */
06195            scheme_add_global_symbol(name, scheme_undefined, env->genv);
06196 
06197            /* Add a renaming: */
06198            if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) {
06199              scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, NULL, 0);
06200               *all_simple_renames = 0;
06201            } else
06202              scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, NULL, 0);
06203 
06204            vars = SCHEME_STX_CDR(vars);
06205          }
06206           
06207           SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
06208          kind = 2;
06209        } else if (scheme_stx_module_eq(scheme_define_syntaxes_stx, fst, 0)
06210                  || scheme_stx_module_eq(define_for_syntaxes_stx, fst, 0)) {
06211          /************ define-syntaxes & define-values-for-syntax *************/
06212          /* Define the macro: */
06213          Scheme_Compile_Info mrec;
06214          Scheme_Object *names, *l, *code, *m, *vec, *boundname;
06215          Resolve_Prefix *rp;
06216          Resolve_Info *ri;
06217          Scheme_Comp_Env *oenv, *eenv;
06218          Optimize_Info *oi;
06219          int count = 0;
06220          int for_stx;
06221           int use_post_ex = 0;
06222 
06223          for_stx = scheme_stx_module_eq(define_for_syntaxes_stx, fst, 0);
06224 
06225           SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
06226           SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(observer);
06227 
06228          scheme_define_parse(e, &names, &code, 1, env, 1);
06229 
06230          if (SCHEME_STX_PAIRP(names) && SCHEME_STX_NULLP(SCHEME_STX_CDR(names)))
06231            boundname = SCHEME_STX_CAR(names);
06232          else
06233            boundname = scheme_false;
06234          
06235          scheme_prepare_exp_env(env->genv);
06236          scheme_prepare_compile_env(env->genv->exp_env);
06237          eenv = scheme_new_comp_env(env->genv->exp_env, env->insp, 0);
06238           scheme_frame_captures_lifts(eenv, NULL, NULL, scheme_false, scheme_false, 
06239                                       req_data, scheme_false);
06240 
06241          oenv = (for_stx ? eenv : env);
06242          
06243          for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
06244            Scheme_Object *name, *orig_name;
06245            name = SCHEME_STX_CAR(l);
06246 
06247            orig_name = name;
06248 
06249             /* Remember the original: */
06250            if (!for_stx)
06251              all_defs = scheme_make_pair(name, all_defs);
06252             else
06253               all_et_defs = scheme_make_pair(name, all_et_defs);
06254            
06255            name = scheme_tl_id_sym(oenv->genv, name, NULL, 2, NULL, NULL);
06256            
06257            if (scheme_lookup_in_table(oenv->genv->syntax, (const char *)name)) {
06258              scheme_wrong_syntax("module", orig_name, e, 
06259                               (for_stx
06260                                ? "duplicate for-syntax definition for identifier"
06261                                : "duplicate definition for identifier"));
06262              return NULL;
06263            }
06264            
06265            /* Check that it's not yet defined: */
06266            if (scheme_lookup_in_table(oenv->genv->toplevel, (const char *)name)) {
06267              scheme_wrong_syntax("module", orig_name, e, 
06268                               (for_stx
06269                                ? "duplicate for-syntax definition for identifier"
06270                                : "duplicate definition for identifier"));
06271              return NULL;
06272            }
06273 
06274            /* Not required: */
06275            if (check_already_required(for_stx ? et_required : required, name)) {
06276              scheme_wrong_syntax("module", orig_name, e, 
06277                               (for_stx
06278                                ? "identifier is already imported for syntax"
06279                                : "identifier is already imported"));
06280              return NULL;
06281            }
06282 
06283            if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) {
06284              scheme_extend_module_rename(for_stx ? post_ex_et_rn : post_ex_rn, self_modidx, name, name, self_modidx, name,
06285                                      for_stx ? 1 : 0, NULL, NULL, NULL, 0);
06286               *all_simple_renames = 0;
06287               use_post_ex = 1;
06288            } else
06289              scheme_extend_module_rename(for_stx ? et_rn : rn, self_modidx, name, name, self_modidx, name,
06290                                      for_stx ? 1 : 0, NULL, NULL, NULL, 0);
06291 
06292            count++;
06293          }
06294 
06295          names = scheme_named_map_1(NULL, stx_sym, names, (Scheme_Object *)oenv->genv);
06296          
06297          mrec.comp = 1;
06298          mrec.dont_mark_local_use = 0;
06299          mrec.resolve_module_ids = 0;
06300           mrec.no_module_cert = 0;
06301          mrec.value_name = NULL;
06302          mrec.certs = rec[drec].certs;
06303           mrec.observer = NULL;
06304           mrec.pre_unwrapped = 0;
06305           mrec.env_already = 0;
06306           mrec.comp_flags = rec[drec].comp_flags;
06307           scheme_rec_add_certs(&mrec, 0, e);
06308 
06309          if (!rec[drec].comp) {
06310            Scheme_Expand_Info erec1;
06311            erec1.comp = 0;
06312            erec1.depth = -1;
06313            erec1.value_name = boundname;
06314            erec1.certs = mrec.certs;
06315             erec1.observer = rec[drec].observer;
06316             erec1.pre_unwrapped = 0;
06317             erec1.no_module_cert = 0;
06318             erec1.env_already = 0;
06319             erec1.comp_flags = rec[drec].comp_flags;
06320            SCHEME_EXPAND_OBSERVE_PHASE_UP(observer);
06321            code = scheme_expand_expr_lift_to_let(code, eenv, &erec1, 0);
06322          }
06323          m = scheme_compile_expr_lift_to_let(code, eenv, &mrec, 0);
06324 
06325           lifted_reqs = scheme_append(scheme_frame_get_require_lifts(eenv), lifted_reqs);
06326 
06327          oi = scheme_optimize_info_create();
06328           oi->context = (Scheme_Object *)env->genv->module;
06329           if (!(rec[drec].comp_flags & COMP_CAN_INLINE))
06330             oi->inline_fuel = -1;
06331          m = scheme_optimize_expr(m, oi);
06332          
06333          /* Simplify only in compile mode; it is too slow in expand mode. */
06334          rp = scheme_resolve_prefix(1, eenv->prefix, rec[drec].comp);
06335          ri = scheme_resolve_info_create(rp);
06336           scheme_enable_expression_resolve_lifts(ri);
06337          m = scheme_resolve_expr(m, ri);
06338           m = scheme_merge_expression_resolve_lifts(m, rp, ri);
06339           rp = scheme_remap_prefix(rp, ri);
06340 
06341          /* Add code with names and lexical depth to exp-time body: */
06342          vec = scheme_make_vector(5, NULL);
06343          SCHEME_VEC_ELS(vec)[0] = ((SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names)))
06344                                     ? SCHEME_CAR(names)
06345                                     : names);
06346          SCHEME_VEC_ELS(vec)[1] = m;
06347          SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(ri->max_let_depth);
06348          SCHEME_VEC_ELS(vec)[3] = (Scheme_Object *)rp;
06349          SCHEME_VEC_ELS(vec)[4] = (for_stx ? scheme_true : scheme_false);
06350          exp_body = scheme_make_pair(vec, exp_body);
06351 
06352           m = scheme_sfs(m, NULL, ri->max_let_depth);
06353          if (ri->use_jit)
06354            m = scheme_jit_expr(m);
06355           rp = scheme_prefix_eval_clone(rp);
06356        
06357          eval_exptime(names, count, m, eenv->genv, rhs_env, rp, ri->max_let_depth, 0, 
06358                        (for_stx ? env->genv->exp_env->toplevel : env->genv->syntax), for_stx,
06359                        rec[drec].certs, 
06360                        for_stx ? scheme_false : (use_post_ex ? post_ex_rn : rn));
06361           
06362          if (rec[drec].comp)
06363            e = NULL;
06364          else {
06365            m = SCHEME_STX_CDR(e);
06366            m = SCHEME_STX_CAR(m);
06367            m = scheme_make_pair(SCHEME_CAR(fst),
06368                              scheme_make_pair(m, scheme_make_pair(code, scheme_null)));
06369            e = scheme_datum_to_syntax(m, e, e, 0, 2);
06370          }
06371           
06372           SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
06373          kind = 0;
06374        } else if (scheme_stx_module_eq(require_stx, fst, 0)) { 
06375          /************ require *************/
06376           SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
06377           SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE(observer);
06378 
06379          /* Adds requires to renamings and required modules to requires lists: */
06380          parse_requires(e, self_modidx, env->genv, env->genv->module,
06381                          rn_set, post_ex_rn_set,
06382                          check_require_name, tables,
06383                          redef_modname, 
06384                          0, 0, 1, 
06385                          1, 0,
06386                          all_simple_renames);
06387 
06388          if (rec[drec].comp)
06389            e = NULL;
06390 
06391           SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
06392          kind = 0;
06393        } else if (scheme_stx_module_eq(provide_stx, fst, 0)) {
06394          /************ provide *************/
06395           /* remember it for the second pass */
06396           kind = 3;
06397        } else {
06398          kind = 1;
06399         }
06400       } else
06401        kind = 1;
06402     } else
06403       kind = 1;
06404 
06405     if (e) {
06406       p = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(kind)), scheme_null);
06407       if (last)
06408        SCHEME_CDR(last) = p;
06409       else
06410        first = p;
06411       last = p;
06412     }
06413 
06414     fm = SCHEME_STX_CDR(fm);
06415 
06416     /* If we're out of declarations, check for lifted-to-end: */
06417     if (SCHEME_STX_NULLP(fm) && maybe_has_lifts) {
06418       e = scheme_frame_get_provide_lifts(xenv);
06419       e = scheme_reverse(e);
06420       fm = scheme_frame_get_end_statement_lifts(xenv);
06421       fm = scheme_reverse(fm);
06422       if (!SCHEME_NULLP(e))
06423         fm = scheme_append(fm, e);
06424       SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, fm);
06425       maybe_has_lifts = 0;
06426     }
06427   }
06428   /* first =  a list of (cons semi-expanded-expression kind) */
06429 
06430   /* Bound names will not be re-bound at this point: */
06431   if (rec[drec].comp || (rec[drec].depth != -2)) {
06432     scheme_seal_module_rename_set(rn_set, STX_SEAL_BOUND);
06433   }
06434   scheme_seal_module_rename_set(post_ex_rn_set, STX_SEAL_BOUND);
06435 
06436   /* Pass 2 */
06437   SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer);
06438   
06439   if (rec[drec].comp) {
06440     /* Module manages its own prefix. That's how we get
06441        multiple instantiation of a module with "dynamic linking". */
06442     cenv = scheme_new_comp_env(env->genv, env->insp, SCHEME_TOPLEVEL_FRAME);
06443   } else
06444     cenv = scheme_extend_as_toplevel(env);
06445 
06446   lift_data = scheme_make_vector(3, NULL);
06447   SCHEME_VEC_ELS(lift_data)[0] = (Scheme_Object *)cenv;
06448   SCHEME_VEC_ELS(lift_data)[1] = self_modidx;
06449   SCHEME_VEC_ELS(lift_data)[2] = rn;
06450 
06451   maybe_has_lifts = 0;
06452 
06453   prev_p = NULL;
06454   for (p = first; !SCHEME_NULLP(p); ) {
06455     Scheme_Object *e, *l, *ll;
06456     int kind;
06457 
06458     e = SCHEME_CAR(p);
06459     kind = SCHEME_INT_VAL(SCHEME_CDR(e));
06460     e = SCHEME_CAR(e);
06461     
06462     SCHEME_EXPAND_OBSERVE_NEXT(observer);
06463 
06464     if (kind == 3) {
06465       Scheme_Object *fst;
06466 
06467       fst = SCHEME_STX_CAR(e);
06468 
06469       if (scheme_stx_module_eq(provide_stx, fst, 0)) {
06470         /************ provide *************/
06471         /* Add provides to table: */
06472         Scheme_Object *ex;
06473 
06474         SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
06475         SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(observer);
06476       
06477         ex = e;
06478   
06479         parse_provides(form, fst, e, 
06480                        all_provided, all_reprovided,
06481                        self_modidx,
06482                        &all_defs_out, &all_et_defs_out,
06483                        tables,
06484                        all_defs, all_et_defs, cenv, rec, drec,
06485                        &ex);
06486         
06487         e = ex;
06488 
06489         SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
06490       }
06491       if (!rec[drec].comp) {
06492         SCHEME_CAR(p) = e;
06493         prev_p = p;
06494         p = SCHEME_CDR(p);
06495       } else {
06496         p = SCHEME_CDR(p);
06497         if (!prev_p)
06498           first = p;
06499         else
06500           SCHEME_CDR(prev_p) = p;
06501       }
06502     } else if (kind) {
06503       Scheme_Comp_Env *nenv;
06504 
06505       l = (maybe_has_lifts 
06506            ? scheme_frame_get_end_statement_lifts(cenv) 
06507            : scheme_null);
06508       ll = (maybe_has_lifts 
06509             ? scheme_frame_get_provide_lifts(cenv) 
06510             : scheme_null);
06511       scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx, req_data, ll);
06512       maybe_has_lifts = 1;
06513 
06514       if (kind == 2)
06515         nenv = cenv;
06516       else
06517         nenv = scheme_new_compilation_frame(0, 0, cenv, NULL);
06518 
06519       if (rec[drec].comp) {
06520        Scheme_Compile_Info crec1;
06521        scheme_init_compile_recs(rec, drec, &crec1, 1);
06522        crec1.resolve_module_ids = 0;
06523        e = scheme_compile_expr(e, nenv, &crec1, 0);
06524       } else {
06525        Scheme_Expand_Info erec1;
06526        scheme_init_expand_recs(rec, drec, &erec1, 1);
06527        erec1.value_name = scheme_false;
06528        e = scheme_expand_expr(e, nenv, &erec1, 0);
06529       }
06530 
06531       lifted_reqs = scheme_append(scheme_frame_get_require_lifts(cenv), lifted_reqs);
06532       
06533       l = scheme_frame_get_lifts(cenv);
06534       if (SCHEME_NULLP(l)) {
06535        /* No lifts - continue normally */
06536        SCHEME_CAR(p) = e;
06537        prev_p = p;
06538        p = SCHEME_CDR(p);
06539       } else {
06540        /* Lifts - insert them and try again */
06541         *all_simple_renames = 0;
06542         SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, scheme_copy_list(l));
06543        e = scheme_make_pair(e, scheme_make_integer(0)); /* don't re-compile/-expand */
06544        SCHEME_CAR(p) = e;
06545        for (ll = l; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) {
06546          e = scheme_make_pair(SCHEME_CAR(ll), scheme_make_integer(2));
06547          SCHEME_CAR(ll) = e;
06548        }
06549        p = scheme_append(l, p);
06550        if (prev_p) {
06551          SCHEME_CDR(prev_p) = p;
06552        } else {
06553          first = p;
06554        }
06555       }
06556     } else {
06557       SCHEME_CAR(p) = e;
06558       prev_p = p;
06559       p = SCHEME_CDR(p);
06560     }
06561 
06562     /* If we're out of declarations, check for lifted-to-end: */
06563     if (SCHEME_NULLP(p) && maybe_has_lifts) {
06564       int expr_cnt;
06565       e = scheme_frame_get_provide_lifts(cenv);
06566       e = scheme_reverse(e);
06567       p = scheme_frame_get_end_statement_lifts(cenv);
06568       p = scheme_reverse(p);
06569       expr_cnt = scheme_list_length(p);
06570       if (!SCHEME_NULLP(e))
06571         p = scheme_append(p, e);
06572       SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, p);
06573       for (ll = p; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) {
06574         e = scheme_make_pair(SCHEME_CAR(ll), (expr_cnt > 0) ? scheme_make_integer(1) : scheme_make_integer(3));
06575         SCHEME_CAR(ll) = e;
06576         expr_cnt--;
06577       }
06578       maybe_has_lifts = 0;
06579       if (prev_p) {
06580         SCHEME_CDR(prev_p) = p;
06581       } else {
06582         first = p;
06583       }
06584     }
06585   }
06586   /* first = a list of expanded/compiled expressions */
06587 
06588   /* If compiling, drop expressions that are constants: */
06589   if (rec[drec].comp) {
06590     Scheme_Object *prev = NULL, *next;
06591     for (p = first; !SCHEME_NULLP(p); p = next) {
06592       next = SCHEME_CDR(p);
06593       if (scheme_omittable_expr(SCHEME_CAR(p), -1, -1, 0, NULL)) {
06594        if (prev)
06595          SCHEME_CDR(prev) = next;
06596        else
06597          first = next;
06598       } else
06599        prev = p;
06600     }
06601   }
06602 
06603   if (rec[drec].comp || (rec[drec].depth != -2)) {
06604     scheme_seal_module_rename_set(rn_set, STX_SEAL_ALL);
06605   }
06606   scheme_seal_module_rename_set(post_ex_rn_set, STX_SEAL_ALL);
06607 
06608   /* Compute provides for re-provides and all-defs-out: */
06609   (void)compute_reprovides(all_provided,
06610                            all_reprovided, 
06611                            env->genv->module, 
06612                            tables,
06613                            env->genv, 
06614                            all_defs, all_defs_out, 
06615                            all_et_defs, all_et_defs_out, 
06616                            "require", NULL, NULL);
06617 
06618   /* Compute provide arrays */
06619   exps = compute_provide_arrays(all_provided, tables,
06620                                 env->genv->module->me,
06621                                 env->genv,
06622                                 form, &et_exps);
06623   
06624   /* Compute indirect provides (which is everything at the top-level): */
06625   exis = compute_indirects(env->genv, env->genv->module->me->rt, &exicount, 1);
06626   exsis = compute_indirects(env->genv, env->genv->module->me->rt, &exsicount, 0);
06627   et_exis = compute_indirects(env->genv->exp_env, env->genv->module->me->et, &et_exicount, 1);
06628 
06629   if (rec[drec].comp || (rec[drec].depth != -2)) {
06630     scheme_clean_dead_env(env->genv);
06631   }
06632 
06633   if (!rec[drec].comp) {
06634     Scheme_Module_Phase_Exports *rt = env->genv->module->me->rt;
06635     int excount = rt->num_provides;
06636     int exvcount = rt->num_var_provides;
06637     Scheme_Object **exsns = rt->provide_src_names;
06638     Scheme_Object **exs = rt->provides;
06639     Scheme_Object **exss = rt->provide_srcs;
06640 
06641     /* Produce annotations (in the form of properties)
06642        for module information:
06643          'module-variable-provides = '(item ...)
06644          'module-syntax-provides = '(item ...)
06645         'module-indirect-provides = '(id ...)
06646          'module-kernel-reprovide-hint = 'kernel-reexport
06647 
06648       item = name
06649            | (ext-id . def-id)
06650            | (modidx ext-id . def-id)
06651      kernel-reexport = #f
06652                      | #t
06653                      | exclusion-id
06654     */
06655     int j;
06656     Scheme_Object *e, *a, *result;
06657 
06658     result = scheme_null;
06659 
06660     /* kernel re-export info (always #f): */
06661     result = scheme_make_pair(scheme_false, result);
06662 
06663     /* Indirect provides */ 
06664     a = scheme_null;
06665     for (j = 0; j < exicount; j++) {
06666       a = scheme_make_pair(exis[j], a);
06667     }
06668     result = scheme_make_pair(a, result);
06669     
06670     /* add syntax and value exports: */
06671     for (j = 0; j < 2; j++) {
06672       int top, i;
06673 
06674       e = scheme_null;
06675 
06676       if (!j) {
06677        i = exvcount;
06678        top = excount;
06679       } else {
06680        i = 0;
06681        top = exvcount;
06682       }
06683       
06684       for (; i < top; i++) {
06685        if (SCHEME_FALSEP(exss[i])
06686            && SAME_OBJ(exs[i], exsns[i]))
06687          a = exs[i];
06688        else {
06689          a = scheme_make_pair(exs[i], exsns[i]);
06690          if (!SCHEME_FALSEP(exss[i])) {
06691            a = scheme_make_pair(exss[i], a);
06692          }
06693        }
06694        e = scheme_make_pair(a, e);
06695       }
06696       result = scheme_make_pair(e, result);
06697     }
06698 
06699     env->genv->module->hints = result;
06700   }
06701 
06702   if (rec[drec].comp) {
06703     Scheme_Object *exp_body_r = scheme_null;
06704     
06705     /* Reverse exp_body */
06706     while (!SCHEME_NULLP(exp_body)) {
06707       exp_body_r = scheme_make_pair(SCHEME_CAR(exp_body),
06708                                 exp_body_r);
06709       exp_body = SCHEME_CDR(exp_body);
06710     }
06711 
06712     first = scheme_list_to_vector(first);
06713     env->genv->module->body = first;
06714     exp_body_r = scheme_list_to_vector(exp_body_r);
06715     env->genv->module->et_body = exp_body_r;
06716 
06717     env->genv->module->provide_protects = exps;
06718     env->genv->module->et_provide_protects = et_exps;
06719 
06720     env->genv->module->indirect_provides = exis;
06721     env->genv->module->num_indirect_provides = exicount;
06722 
06723     if (*all_simple_renames) {
06724       env->genv->module->indirect_syntax_provides = exsis;
06725       env->genv->module->num_indirect_syntax_provides = exsicount;
06726     } else {
06727       env->genv->module->indirect_syntax_provides = NULL;
06728       env->genv->module->num_indirect_syntax_provides = 0;
06729     }
06730 
06731     env->genv->module->et_indirect_provides = et_exis;
06732     env->genv->module->num_indirect_et_provides = et_exicount;
06733 
06734     env->genv->module->comp_prefix = cenv->prefix;
06735 
06736     if (*all_simple_renames) {
06737       env->genv->module->rn_stx = scheme_true;
06738     }
06739 
06740     return (Scheme_Object *)env->genv->module;
06741   } else {
06742     if (rec[drec].depth == -2) {
06743       /* This was a local expand. Flush definitions, because the body expand may start over. */
06744       flush_definitions(env->genv);
06745       if (env->genv->exp_env)
06746         flush_definitions(env->genv->exp_env);
06747     }
06748 
06749     p = SCHEME_STX_CAR(form);
06750 
06751     /* Add lifted requires */
06752     if (!SCHEME_NULLP(lifted_reqs)) {
06753       lifted_reqs = scheme_reverse(lifted_reqs);
06754       first = scheme_append(lifted_reqs, first);
06755     }
06756 
06757     return scheme_datum_to_syntax(cons(p, first), form, form, 0, 2);
06758   }
06759 }
06760 
06761 static Scheme_Object *
06762 module_begin_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
06763 {
06764   return do_module_begin(form, env, rec, drec);
06765 }
06766 
06767 static Scheme_Object *
06768 module_begin_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
06769 {
06770   SCHEME_EXPAND_OBSERVE_PRIM_MODULE_BEGIN(erec[drec].observer);
06771   return do_module_begin(form, env, erec, drec);
06772 }
06773 
06774 static void check_already_provided(Scheme_Hash_Table *provided, Scheme_Object *outname, Scheme_Object *name, 
06775                                    int protected, Scheme_Object *form, Scheme_Object *phase)
06776 {
06777   Scheme_Object *v;
06778 
06779   v = scheme_hash_get(provided, outname);
06780   if (v) {
06781     if (!scheme_stx_module_eq2(SCHEME_CAR(v), name, phase, NULL))
06782       scheme_wrong_syntax("module", outname, form, "identifier already provided (as a different binding)");
06783     
06784     if (protected && SCHEME_FALSEP(SCHEME_CDR(v)))
06785       scheme_wrong_syntax("module", outname, form, "identifier already provided as unprotected");
06786     if (!protected && SCHEME_TRUEP(SCHEME_CDR(v)))
06787       scheme_wrong_syntax("module", outname, form, "identifier already provided as protected");
06788   }
06789 }
06790 
06791 int compute_reprovides(Scheme_Hash_Table *all_provided,
06792                        Scheme_Hash_Table *all_reprovided, 
06793                        Scheme_Module *mod_for_requires,
06794                        Scheme_Hash_Table *tables,
06795                        Scheme_Env *_genv, 
06796                        Scheme_Object *all_rt_defs, Scheme_Object *all_rt_defs_out, 
06797                        Scheme_Object *all_et_defs, Scheme_Object *all_et_defs_out, 
06798                        const char *matching_form,
06799                        Scheme_Object *all_mods, /* a phase list to use for all mods */
06800                        Scheme_Object *all_phases) /* a module-path list for all phases */
06801 {
06802   Scheme_Hash_Table *provided, *required;
06803   Scheme_Object *reprovided, *tvec;
06804   int i, k, z;
06805   Scheme_Object *rx, *provided_list, *phase, *req_phase;
06806   Scheme_Object *all_defs, *all_defs_out;
06807   Scheme_Env *genv;
06808 
06809   if (all_phases) {
06810     /* synthesize all_reprovided for the loop below: */
06811     if (all_mods)
06812       reprovided = scheme_make_pair(scheme_false, scheme_null);
06813     else
06814       reprovided = all_phases;
06815     all_reprovided = scheme_make_hash_table_equal();
06816     if (mod_for_requires->requires
06817         && !SCHEME_NULLP(mod_for_requires->requires))
06818       scheme_hash_set(all_reprovided, scheme_make_integer(0), reprovided);
06819     if (mod_for_requires->et_requires
06820         && !SCHEME_NULLP(mod_for_requires->et_requires))
06821       scheme_hash_set(all_reprovided, scheme_make_integer(1), reprovided);
06822     if (mod_for_requires->tt_requires
06823         && !SCHEME_NULLP(mod_for_requires->tt_requires))
06824       scheme_hash_set(all_reprovided, scheme_make_integer(-1), reprovided);
06825     if (mod_for_requires->dt_requires
06826         && !SCHEME_NULLP(mod_for_requires->dt_requires))
06827       scheme_hash_set(all_reprovided, scheme_false, reprovided);
06828     if (mod_for_requires->other_requires) {
06829       for (z = 0; z < mod_for_requires->other_requires->size; z++) {
06830         if (mod_for_requires->other_requires->vals[z])
06831           scheme_hash_set(all_reprovided, 
06832                           mod_for_requires->other_requires->keys[z],
06833                           reprovided);
06834       }
06835     }
06836   } else if (all_mods) {
06837     reprovided = scheme_make_pair(scheme_false, scheme_null);
06838     all_reprovided = scheme_make_hash_table_equal();
06839     while (SCHEME_PAIRP(all_mods)) {
06840       scheme_hash_set(all_reprovided, SCHEME_CAR(all_mods), reprovided);
06841       all_mods = SCHEME_CDR(all_mods);
06842     }
06843   }
06844 
06845   /* First, check the sanity of the re-provide specifications (unless
06846      we synthesized them): */
06847   if (!all_mods) {
06848     for (z = 0; z < all_reprovided->size; z++) {
06849       if (all_reprovided->vals[z]) {
06850         Scheme_Object *requires;
06851 
06852         reprovided = all_reprovided->vals[z];
06853         phase = all_reprovided->keys[z];
06854 
06855         if (SAME_OBJ(phase, scheme_make_integer(0))) {
06856           requires = mod_for_requires->requires;
06857         } else if (SAME_OBJ(phase, scheme_make_integer(1))) {
06858           requires = mod_for_requires->et_requires;
06859         } else if (SAME_OBJ(phase, scheme_make_integer(-1))) {
06860           requires = mod_for_requires->tt_requires;
06861         } else if (SAME_OBJ(phase, scheme_false)) {
06862           requires = mod_for_requires->dt_requires;
06863         } else {
06864           if (mod_for_requires->other_requires)
06865             requires = scheme_hash_get(mod_for_requires->other_requires, phase);
06866           else
06867             requires = NULL;
06868         }
06869         if (!requires)
06870           requires = scheme_null;
06871         
06872         for (rx = reprovided; !SCHEME_NULLP(rx); rx = SCHEME_CDR(rx)) {
06873           Scheme_Object *midx = SCHEME_CAR(SCHEME_CAR(rx)), *l, *exns;
06874        
06875           for (l = requires; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
06876             if (same_modidx(midx, SCHEME_CAR(l)))
06877               break;
06878           }
06879           if (SCHEME_NULLP(l)) {
06880             /* Didn't require the named module */
06881             if (matching_form) {
06882               Scheme_Object *name;
06883               name = SCHEME_CAR(rx);
06884               name = SCHEME_STX_CDR(name);
06885               name = SCHEME_STX_CAR(name);
06886               scheme_wrong_syntax("module", 
06887                                   SCHEME_MODNAMEP(midx) ? midx : ((Scheme_Modidx *)midx)->path, 
06888                                   name,
06889                                   "cannot provide from a module without a matching `%s'",
06890                                   matching_form);
06891             } else {
06892               return 0;
06893             }
06894           }
06895 
06896           exns = SCHEME_CDR(SCHEME_CDR(SCHEME_CAR(rx)));
06897           for (l = exns; !SCHEME_STX_NULLP(l); l = SCHEME_STX_CDR(l)) {
06898             /* Make sure excluded name was required: */
06899             Scheme_Object *a, *vec = NULL;
06900             a = SCHEME_STX_VAL(SCHEME_STX_CAR(l));
06901 
06902             for (k = 0; k < tables->size; k++) {
06903               if (tables->vals[k]) {
06904                 tvec = tables->vals[k];
06905                 required = (Scheme_Hash_Table *)SCHEME_VEC_ELS(tvec)[1];
06906                 
06907                 if (required)
06908                   vec = scheme_hash_get(required, a);
06909                 else
06910                   vec = NULL;
06911       
06912                 if (vec) {
06913                   /* Check for nominal modidx in list */
06914                   Scheme_Object *nml, *nml_modidx;
06915                   nml = SCHEME_VEC_ELS(vec)[0];
06916                   for (; SCHEME_PAIRP(nml); nml = SCHEME_CDR(nml)) {
06917                     nml_modidx = SCHEME_CAR(nml);
06918                     if (SCHEME_PAIRP(nml_modidx))
06919                       nml_modidx = SCHEME_CAR(nml_modidx);
06920                     if (same_modidx(SCHEME_CAR(SCHEME_CAR(rx)), nml_modidx))
06921                       break;
06922                   }
06923                   if (!SCHEME_PAIRP(nml))
06924                     vec = NULL; /* So it was provided, but not from the indicated module */
06925                 }
06926 
06927                 if (vec)
06928                   break;
06929               }
06930             }
06931             if (!vec) {
06932               a = SCHEME_STX_CAR(l);
06933               scheme_wrong_syntax("module", a, SCHEME_CADR(SCHEME_CAR(rx)),
06934                                   "excluded name was not required from the module");
06935             }
06936           }
06937         }
06938       }
06939     }
06940   }
06941 
06942   /* For each reprovided, walk through requires, check for re-provided bindings: */
06943   for (z = 0; z < all_reprovided->size; z++) {
06944     reprovided = all_reprovided->vals[z];
06945     if (reprovided && !SCHEME_NULLP(reprovided)) {
06946       phase = all_reprovided->keys[z];
06947 
06948       for (k = 0; k < tables->size; k++) {
06949         tvec = tables->vals[k];
06950         if (tvec) {
06951           required = (Scheme_Hash_Table *)SCHEME_VEC_ELS(tvec)[1];
06952           req_phase = tables->keys[k];
06953 
06954           for (i = required->size; i--; ) {
06955             if (required->vals[i]) {
06956               Scheme_Object *nominal_modidx, *name, *modidx, *srcname, *outname, *nml, *orig_nml, *mark_src;
06957               int break_outer = 0;
06958        
06959               name = required->keys[i]; /* internal symbolic name */
06960               orig_nml = SCHEME_VEC_ELS(required->vals[i])[0];
06961               modidx = SCHEME_VEC_ELS(required->vals[i])[1];
06962               srcname = SCHEME_VEC_ELS(required->vals[i])[2];
06963               outname = SCHEME_VEC_ELS(required->vals[i])[4];
06964               mark_src = SCHEME_VEC_ELS(required->vals[i])[6];
06965 
06966               for (rx = reprovided; !SCHEME_NULLP(rx); rx = SCHEME_CDR(rx)) {
06967                 for (nml = orig_nml; SCHEME_PAIRP(nml); nml = SCHEME_CDR(nml)) {
06968                   nominal_modidx = SCHEME_CAR(nml);
06969                   if (SCHEME_PAIRP(nominal_modidx))
06970                     nominal_modidx = SCHEME_CAR(nominal_modidx);
06971                   if (all_mods || same_modidx(SCHEME_CAR(SCHEME_CAR(rx)), nominal_modidx)) {
06972                     Scheme_Object *nml_pi;
06973 
06974                     if (SCHEME_PAIRP(SCHEME_CAR(nml)))
06975                       nml_pi = SCHEME_CADR(SCHEME_CAR(nml));
06976                     else
06977                       nml_pi = scheme_make_integer(0);
06978 
06979                     if (SAME_OBJ(phase, nml_pi)) {
06980                       Scheme_Object *exns, *ree;
06981 
06982                       if (!all_mods) {
06983                         break_outer = 1;
06984                   
06985                         ree = SCHEME_CDR(SCHEME_CAR(rx));
06986 
06987                         exns = SCHEME_CDR(ree);
06988                       } else {
06989                         ree = NULL;
06990                         exns = scheme_null;
06991                       }
06992            
06993                       for (; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) {
06994                         /* Was this name excluded? */
06995                         Scheme_Object *a;
06996                         a = SCHEME_STX_VAL(SCHEME_STX_CAR(exns));
06997                         if (SAME_OBJ(a, name))
06998                           break;
06999                       }
07000 
07001                       if (SCHEME_STX_NULLP(exns)) {
07002                         /* Not excluded, so provide it. */
07003                         if (matching_form) {
07004                           /* Assert: !all_mods */
07005                           provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, req_phase);
07006                           if (!provided) {
07007                             provided = scheme_make_hash_table(SCHEME_hash_ptr);
07008                             scheme_hash_set(all_provided, req_phase, (Scheme_Object *)provided);
07009                           }
07010                           check_already_provided(provided, outname, name, 0, SCHEME_CAR(ree), req_phase);
07011                           scheme_hash_set(provided, outname, scheme_make_pair(name, scheme_false));
07012                         } else {
07013                           if (SCHEME_TRUEP(mark_src)) {
07014                             if (SCHEME_SYM_PARALLELP(name)) {
07015                               /* reverse scheme_tl_id_sym */
07016                               char *s;
07017                               int len;
07018                               len = SCHEME_SYM_LEN(name);
07019                               s = scheme_malloc_atomic(len + 1);
07020                               memcpy(s, SCHEME_SYM_VAL(name), len+1);
07021                               while (len && (s[len] != '.')) {
07022                                 --len;
07023                               }
07024                               s[len] = 0;
07025                               name = scheme_intern_exact_symbol(s, len);
07026                             }
07027                             name = scheme_datum_to_syntax(name, scheme_false, mark_src, 0, 0);
07028                           } else {
07029                             scheme_signal_error("found an import with no lexical context");
07030                           }
07031 
07032                           provided_list = scheme_hash_get(all_provided, req_phase);
07033                           if (!provided_list)
07034                             provided_list = scheme_null;
07035                           provided_list = scheme_make_pair(name, provided_list);
07036                           scheme_hash_set(all_provided, req_phase, provided_list);
07037                         }
07038                       }
07039                     }
07040                   }
07041                   if (break_outer) break;
07042                 }
07043               }
07044             }
07045           }
07046         }
07047       }
07048     }
07049   }
07050 
07051   /* Do all-defined provides */
07052   for (z = 0; z < 2; z++) {
07053     if (!z) {
07054       all_defs = all_rt_defs;
07055       all_defs_out = all_rt_defs_out;
07056       provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, scheme_make_integer(0));
07057       phase = scheme_make_integer(0);
07058       genv = _genv;
07059     } else {
07060       all_defs = all_et_defs;
07061       all_defs_out = all_et_defs_out;
07062       provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, scheme_make_integer(1));
07063       phase = scheme_make_integer(1);
07064       genv = _genv->exp_env;
07065     }
07066 
07067     if (all_defs_out) {
07068       for (; !SCHEME_NULLP(all_defs_out); all_defs_out = SCHEME_CDR(all_defs_out)) {
07069         Scheme_Object *exns, *ree, *ree_kw, *exl, *name, *a, *adl, *exname, *pfx;
07070         int protected;
07071            
07072         ree = SCHEME_CAR(all_defs_out);
07073         protected = SCHEME_TRUEP(SCHEME_CDR(ree));
07074         ree = SCHEME_CAR(ree);
07075         ree_kw = SCHEME_CAR(ree);
07076         ree = SCHEME_CDR(ree);
07077         exl = SCHEME_CAR(ree);
07078         pfx = SCHEME_CDR(ree);
07079 
07080         /* Make sure each excluded name was defined: */
07081         for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) {
07082           a = SCHEME_STX_CAR(exns);
07083           name = scheme_tl_id_sym(genv, a, NULL, 0, NULL, NULL);
07084           if (!scheme_lookup_in_table(genv->toplevel, (const char *)name)
07085               && !scheme_lookup_in_table(genv->syntax, (const char *)name)) {
07086             scheme_wrong_syntax("module", a, ree_kw, "excluded identifier was not defined");
07087           }
07088         }
07089 
07090         for (adl = all_defs; SCHEME_PAIRP(adl); adl = SCHEME_CDR(adl)) {
07091           name = SCHEME_CAR(adl);
07092           exname = SCHEME_STX_SYM(name);
07093           name = scheme_tl_id_sym(genv, name, NULL, 0, NULL, NULL);
07094        
07095           /* Was this one excluded? */
07096           for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) {
07097             a = SCHEME_STX_CAR(exns);
07098             a = scheme_tl_id_sym(genv, a, NULL, 0, NULL, NULL);
07099             if (SAME_OBJ(a, name))
07100               break;
07101           }
07102 
07103           if (SCHEME_STX_NULLP(exns)) {
07104             /* not excluded */
07105          
07106             /* But don't export uninterned: */
07107             if (!SCHEME_SYM_UNINTERNEDP(name)) {
07108               /* Also, check that ree_kw and the identifier have the same
07109                  introduction (in case one or the other was introduced by
07110                  a macro). We perform this check by getting exname's tl_id
07111                  as if it had ree_kw's context, then comparing that result
07112                  to the actual tl_id. */
07113               a = scheme_datum_to_syntax(exname, scheme_false, ree_kw, 0, 0);
07114               a = scheme_tl_id_sym(genv, a, NULL, 0, NULL, NULL);
07115            
07116               if (SAME_OBJ(a, name)) {
07117                 /* Add prefix, if any */
07118                 if (SCHEME_TRUEP(pfx)) {
07119                   exname = scheme_symbol_append(pfx, exname);
07120                 }
07121                 check_already_provided(provided, exname, name, protected, ree_kw, phase);
07122              
07123                 scheme_hash_set(provided, exname, 
07124                                 scheme_make_pair(name, protected ? scheme_true : scheme_false));
07125               }
07126             }
07127           }
07128         }
07129       }
07130     }
07131   }
07132 
07133   return 1;
07134 }
07135 
07136 static Scheme_Object **compute_indirects(Scheme_Env *genv, 
07137                                          Scheme_Module_Phase_Exports *pt,
07138                                          int *_count,
07139                                          int vars)
07140 {
07141   int i, count, j, start, end;
07142   Scheme_Bucket **bs, *b;
07143   Scheme_Object **exsns = pt->provide_src_names, **exis;
07144   int exicount;
07145   Scheme_Bucket_Table *t;
07146 
07147   if (vars) {
07148     start = 0;
07149     end = pt->num_var_provides;
07150   } else {
07151     start = pt->num_var_provides;
07152     end = pt->num_provides;
07153   }
07154 
07155   if (vars)
07156     t = genv->toplevel;
07157   else
07158     t = genv->syntax;
07159     
07160 
07161   if (!t)
07162     count = 0;
07163   else {
07164     bs = t->buckets;
07165     for (count = 0, i = t->size; i--; ) {
07166       b = bs[i];
07167       if (b && b->val)
07168         count++;
07169     }
07170   }
07171 
07172   if (!count) {
07173     *_count = 0;
07174     return NULL;
07175   }
07176   
07177   exis = MALLOC_N(Scheme_Object *, count);
07178 
07179   for (count = 0, i = t->size; i--; ) {
07180     b = bs[i];
07181     if (b && b->val) {
07182       Scheme_Object *name;
07183       
07184       name = (Scheme_Object *)b->key;
07185       
07186       /* If the name is directly provided, no need for indirect... */
07187       for (j = start; j < end; j++) {
07188         if (SAME_OBJ(name, exsns[j]))
07189           break;
07190       }
07191        
07192       if (j == end)
07193         exis[count++] = name;
07194     }
07195   }
07196 
07197   if (!count) {
07198     *_count = 0;
07199     return NULL;
07200   }
07201   
07202   exicount = count;
07203 
07204   qsort_provides(exis, NULL, NULL, NULL, NULL, NULL, NULL, 0, exicount, 1);
07205 
07206   *_count = exicount;
07207   return exis;
07208 }
07209 
07210 Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bindings, Scheme_Object *modpath,
07211                                            Scheme_Object *mode)
07212 {
07213   Scheme_Object *l, *all_mods, *all_phases;
07214   Scheme_Hash_Table *tables, *all_reprovided, *all_provided;
07215   int v, i;
07216 
07217   tables = (Scheme_Hash_Table *)SCHEME_CAR(bindings);
07218   all_reprovided = scheme_make_hash_table_equal();
07219 
07220   if (SCHEME_FALSEP(modpath)) {
07221     if (SAME_OBJ(mode, scheme_true)) {
07222       all_mods = scheme_null; 
07223       all_phases = scheme_null; 
07224     } else {
07225       all_mods = scheme_make_pair(mode, scheme_null);
07226       all_phases = NULL;
07227     }
07228   } else {
07229     Scheme_Object *reprovided;
07230 
07231     reprovided = scheme_make_pair(scheme_make_pair(modpath,
07232                                                    scheme_make_pair(scheme_false,
07233                                                                     scheme_null)),
07234                                   scheme_null);
07235     all_mods = NULL;
07236     if (SAME_OBJ(mode, scheme_true)) {
07237       all_phases = reprovided;
07238     } else {
07239       scheme_hash_set(all_reprovided, mode, reprovided);
07240       all_phases = NULL;
07241     }
07242   }
07243 
07244   /* Receives result: */
07245   all_provided = scheme_make_hash_table_equal();
07246   
07247   v = compute_reprovides(all_provided,
07248                          all_reprovided,
07249                          genv->module, 
07250                          tables,
07251                          genv, 
07252                          NULL, NULL, NULL, NULL, 
07253                          NULL,
07254                          all_mods, all_phases);
07255     
07256   if (!v) {
07257     return scheme_false;
07258   } else {
07259     l = scheme_null;
07260     for (i = 0; i < all_provided->size; i++) {
07261       if (all_provided->vals[i]) {
07262         l = scheme_make_pair(scheme_make_pair(all_provided->keys[i],
07263                                               all_provided->vals[i]),
07264                              l);
07265       }
07266     }
07267 
07268     return l;
07269   }
07270 }
07271 
07272 static Scheme_Object *adjust_for_rename(Scheme_Object *out_name, Scheme_Object *in_name, Scheme_Object *noms)
07273 {
07274   Scheme_Object *first = scheme_null, *last = NULL, *p, *a;
07275 
07276   if (SCHEME_STXP(in_name))
07277     in_name = SCHEME_STX_VAL(in_name);
07278 
07279   if (SAME_OBJ(in_name, out_name))
07280     return noms;
07281 
07282   while (SCHEME_PAIRP(noms)) {
07283     a = SCHEME_CAR(noms);
07284     if (SCHEME_PAIRP(a)) {
07285       /* no change */
07286     } else {
07287       a = scheme_make_pair(a,
07288                            scheme_make_pair(scheme_make_integer(0),
07289                                             scheme_make_pair(in_name,
07290                                                              scheme_make_pair(scheme_make_integer(0),
07291                                                                               scheme_null))));
07292     }
07293 
07294     p = scheme_make_pair(a, scheme_null);
07295     if (last)
07296       SCHEME_CDR(last) = p;
07297     else
07298       first = p;
07299     last = p;
07300 
07301     noms = SCHEME_CDR(noms);
07302   }
07303 
07304   return first;
07305 }
07306 
07307 static Scheme_Object *extract_free_id_name(Scheme_Object *name,
07308                                            Scheme_Object *phase,
07309                                            Scheme_Env *genv,
07310                                            int always,
07311                                            int *_implicit,
07312                                            Scheme_Object **_implicit_src,
07313                                            Scheme_Object **_implicit_src_name,
07314                                            Scheme_Object **_implicit_mod_phase,
07315                                            Scheme_Object **_implicit_nominal_name,
07316                                            Scheme_Object **_implicit_nominal_mod,
07317                                            Scheme_Object **_implicit_insp)
07318 {
07319   *_implicit = 0;
07320 
07321   while (1) { /* loop for free-id=? renaming */
07322     if (SCHEME_STXP(name)) {
07323       if (genv
07324           && (always
07325               || SAME_OBJ(phase, scheme_make_integer(0))
07326               || SAME_OBJ(phase, scheme_make_integer(1))))
07327         name = scheme_tl_id_sym(genv, name, NULL, -1, phase, NULL);
07328       else
07329         name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */
07330     }
07331     
07332     /* Check for free-id=? renaming: */
07333     if (SAME_OBJ(phase, scheme_make_integer(0))) {
07334       Scheme_Object *v2;
07335       v2 = scheme_lookup_in_table(genv->syntax, (const char *)name);
07336       if (v2 && scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(v2))) {
07337         Scheme_Object *name2;
07338         Scheme_Object *mod, *id, *rename_insp = NULL;
07339         Scheme_Object *mod_phase = NULL;
07340 
07341         name2 = scheme_rename_transformer_id(SCHEME_PTR_VAL(v2));
07342         id = name2;
07343 
07344         if (_implicit_mod_phase) mod_phase = *_implicit_mod_phase;
07345         mod = scheme_stx_module_name(NULL, &id, phase, 
07346                                      _implicit_nominal_mod, _implicit_nominal_name,
07347                                      &mod_phase, 
07348                                      NULL, NULL, NULL, NULL, &rename_insp);
07349         if (_implicit_mod_phase) *_implicit_mod_phase = mod_phase;
07350           
07351         if (mod && SAME_TYPE(SCHEME_TYPE(mod), scheme_module_index_type)) {
07352           if (SCHEME_FALSEP(((Scheme_Modidx *)mod)->path)) {
07353             /* keep looking locally */
07354             name = name2;
07355             SCHEME_USE_FUEL(1);
07356           } else {
07357             /* free-id=? equivalence to a name that is not necessarily imported explicitly. */
07358             int would_complain = 0, is_prot = 0, is_unexp = 0;
07359 
<