Back to index

plt-scheme  4.2.1
env.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 1995-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   libscheme
00022   Copyright (c) 1994 Brent Benson
00023   All rights reserved.
00024 */
00025 
00026 /* This file implements environments (both compile-time and top-level
00027    envionments, a.k.a. namespaces), and also implements much of the
00028    initialization sequence (filling the initial namespace). */
00029 
00030 #include "schpriv.h"
00031 #include "mzrt.h"
00032 #include "schminc.h"
00033 #include "schmach.h"
00034 #include "schexpobs.h"
00035 
00036 #define GLOBAL_TABLE_SIZE 500
00037 #define TABLE_CACHE_MAX_SIZE 2048
00038 
00039 /* #define TIME_STARTUP_PROCESS */
00040 
00041 /* global flags */
00042 int scheme_allow_set_undefined;
00043 void scheme_set_allow_set_undefined(int v) { scheme_allow_set_undefined =  v; }
00044 int scheme_get_allow_set_undefined() { return scheme_allow_set_undefined; }
00045 int scheme_starting_up;
00046 
00047 /* global counters just need to be atomically incremented */
00048 static int intdef_counter      = 0;
00049 static int builtin_ref_counter = 0;
00050 static int env_uid_counter     = 0;
00051 
00052 /* globals READ-ONLY SHARED */
00053 static Scheme_Object *kernel_symbol;
00054 static Scheme_Env    *kernel_env;
00055 
00056 #define MAX_CONST_LOCAL_POS 64
00057 #define MAX_CONST_LOCAL_TYPES 2
00058 #define MAX_CONST_LOCAL_FLAG_VAL 2
00059 #define SCHEME_LOCAL_FLAGS_MASK 0x3
00060 static Scheme_Object *scheme_local[MAX_CONST_LOCAL_POS][MAX_CONST_LOCAL_TYPES][MAX_CONST_LOCAL_FLAG_VAL + 1];
00061 #define MAX_CONST_TOPLEVEL_DEPTH 16
00062 #define MAX_CONST_TOPLEVEL_POS 16
00063 #define SCHEME_TOPLEVEL_FLAGS_MASK 0x3
00064 static Scheme_Object *toplevels[MAX_CONST_TOPLEVEL_DEPTH][MAX_CONST_TOPLEVEL_POS][SCHEME_TOPLEVEL_FLAGS_MASK + 1];
00065 
00066 /* globals THREAD_LOCAL 
00067  * if locked theses are probably sharable*/
00068 static THREAD_LOCAL Scheme_Hash_Table *toplevels_ht;
00069 static THREAD_LOCAL Scheme_Hash_Table *locals_ht[2];
00070 
00071 /* local functions */
00072 static void make_kernel_env(void);
00073 static void init_scheme_local();
00074 static void init_toplevels();
00075 
00076 static Scheme_Env *make_env(Scheme_Env *base, int toplevel_size);
00077 static Scheme_Env *make_empty_inited_env(int toplevel_size);
00078 static Scheme_Env *make_empty_not_inited_env(int toplevel_size);
00079 
00080 static Scheme_Object *namespace_identifier(int, Scheme_Object *[]);
00081 static Scheme_Object *namespace_module_identifier(int, Scheme_Object *[]);
00082 static Scheme_Object *namespace_base_phase(int, Scheme_Object *[]);
00083 static Scheme_Object *namespace_variable_value(int, Scheme_Object *[]);
00084 static Scheme_Object *namespace_set_variable_value(int, Scheme_Object *[]);
00085 static Scheme_Object *namespace_undefine_variable(int, Scheme_Object *[]);
00086 static Scheme_Object *namespace_mapped_symbols(int, Scheme_Object *[]);
00087 static Scheme_Object *namespace_module_registry(int, Scheme_Object *[]);
00088 static Scheme_Object *variable_p(int, Scheme_Object *[]);
00089 static Scheme_Object *variable_module_path(int, Scheme_Object *[]);
00090 static Scheme_Object *variable_namespace(int, Scheme_Object *[]);
00091 static Scheme_Object *variable_top_level_namespace(int, Scheme_Object *[]);
00092 static Scheme_Object *variable_phase(int, Scheme_Object *[]);
00093 static Scheme_Object *now_transforming(int argc, Scheme_Object *argv[]);
00094 static Scheme_Object *local_exp_time_value(int argc, Scheme_Object *argv[]);
00095 static Scheme_Object *local_exp_time_value_one(int argc, Scheme_Object *argv[]);
00096 static Scheme_Object *local_exp_time_name(int argc, Scheme_Object *argv[]);
00097 static Scheme_Object *local_context(int argc, Scheme_Object *argv[]);
00098 static Scheme_Object *local_phase_level(int argc, Scheme_Object *argv[]);
00099 static Scheme_Object *local_make_intdef_context(int argc, Scheme_Object *argv[]);
00100 static Scheme_Object *intdef_context_seal(int argc, Scheme_Object *argv[]);
00101 static Scheme_Object *intdef_context_p(int argc, Scheme_Object *argv[]);
00102 static Scheme_Object *id_intdef_remove(int argc, Scheme_Object *argv[]);
00103 static Scheme_Object *local_introduce(int argc, Scheme_Object *argv[]);
00104 static Scheme_Object *local_module_introduce(int argc, Scheme_Object *argv[]);
00105 static Scheme_Object *local_get_shadower(int argc, Scheme_Object *argv[]);
00106 static Scheme_Object *local_certify(int argc, Scheme_Object *argv[]);
00107 static Scheme_Object *local_module_exports(int argc, Scheme_Object *argv[]);
00108 static Scheme_Object *local_module_definitions(int argc, Scheme_Object *argv[]);
00109 static Scheme_Object *local_module_imports(int argc, Scheme_Object *argv[]);
00110 static Scheme_Object *local_module_expanding_provides(int argc, Scheme_Object *argv[]);
00111 static Scheme_Object *local_lift_expr(int argc, Scheme_Object *argv[]);
00112 static Scheme_Object *local_lift_exprs(int argc, Scheme_Object *argv[]);
00113 static Scheme_Object *local_lift_context(int argc, Scheme_Object *argv[]);
00114 static Scheme_Object *local_lift_end_statement(int argc, Scheme_Object *argv[]);
00115 static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[]);
00116 static Scheme_Object *local_lift_provide(int argc, Scheme_Object *argv[]);
00117 static Scheme_Object *make_introducer(int argc, Scheme_Object *argv[]);
00118 static Scheme_Object *local_make_delta_introduce(int argc, Scheme_Object *argv[]);
00119 static Scheme_Object *make_set_transformer(int argc, Scheme_Object *argv[]);
00120 static Scheme_Object *set_transformer_p(int argc, Scheme_Object *argv[]);
00121 static Scheme_Object *set_transformer_proc(int argc, Scheme_Object *argv[]);
00122 static Scheme_Object *make_rename_transformer(int argc, Scheme_Object *argv[]);
00123 static Scheme_Object *rename_transformer_target(int argc, Scheme_Object *argv[]);
00124 static Scheme_Object *rename_transformer_p(int argc, Scheme_Object *argv[]);
00125 
00126 static Scheme_Object *write_toplevel(Scheme_Object *obj);
00127 static Scheme_Object *read_toplevel(Scheme_Object *obj);
00128 static Scheme_Object *write_variable(Scheme_Object *obj);
00129 static Scheme_Object *read_variable(Scheme_Object *obj);
00130 static Scheme_Object *write_module_variable(Scheme_Object *obj);
00131 static Scheme_Object *read_module_variable(Scheme_Object *obj);
00132 static Scheme_Object *write_local(Scheme_Object *obj);
00133 static Scheme_Object *read_local(Scheme_Object *obj);
00134 static Scheme_Object *read_local_unbox(Scheme_Object *obj);
00135 static Scheme_Object *write_resolve_prefix(Scheme_Object *obj);
00136 static Scheme_Object *read_resolve_prefix(Scheme_Object *obj);
00137 
00138 static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data);
00139 int scheme_is_module_begin_env(Scheme_Comp_Env *env);
00140 
00141 Scheme_Env *scheme_engine_instance_init();
00142 Scheme_Env *scheme_place_instance_init();
00143 static void place_instance_init_pre_kernel();
00144 static Scheme_Env *place_instance_init_post_kernel();
00145 
00146 #ifdef MZ_PRECISE_GC
00147 static void register_traversers(void);
00148 #endif
00149 
00150 typedef Scheme_Object *(*Lazy_Macro_Fun)(Scheme_Object *, int);
00151 
00152 #define ARBITRARY_USE     0x1
00153 #define CONSTRAINED_USE   0x2
00154 #define WAS_SET_BANGED    0x4
00155 #define ONE_ARBITRARY_USE 0x8
00156 /* See also SCHEME_USE_COUNT_MASK */
00157 
00158 typedef struct Compile_Data {
00159   int num_const;
00160   Scheme_Object **const_names;
00161   Scheme_Object **const_vals;
00162   Scheme_Object **const_uids;
00163   int *sealed; /* NULL => already sealed */
00164   int *use;
00165   Scheme_Object *lifts;
00166 } Compile_Data;
00167 
00168 typedef struct Scheme_Full_Comp_Env {
00169   Scheme_Comp_Env base;
00170   Compile_Data data;
00171 } Scheme_Full_Comp_Env;
00172 static void init_compile_data(Scheme_Comp_Env *env);
00173 
00174 /* Precise GC WARNING: this macro produces unaligned pointers: */
00175 #define COMPILE_DATA(e) (&((Scheme_Full_Comp_Env *)e)->data)
00176 
00177 #define SCHEME_NON_SIMPLE_FRAME (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME \
00178                                  | SCHEME_FOR_STOPS | SCHEME_FOR_INTDEF | SCHEME_CAPTURE_LIFTED)
00179 
00180 #define ASSERT_IS_VARIABLE_BUCKET(b) /* if (((Scheme_Object *)b)->type != scheme_variable_type) abort() */
00181 
00182 /*========================================================================*/
00183 /*                             initialization                             */
00184 /*========================================================================*/
00185 
00186 
00187 #ifdef DONT_USE_FOREIGN
00188 static void init_dummy_foreign(Scheme_Env *env)
00189 {
00190   /* Works just well enough that the `mzscheme' module can 
00191      import it (so that attaching `mzscheme' to a namespace 
00192      also attaches `#%foreign'). */
00193   Scheme_Env *menv;
00194   menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
00195   scheme_finish_primitive_module(menv);
00196   scheme_protect_primitive_provide(menv, NULL);
00197 }
00198 #endif
00199 
00200 static void boot_module_resolver()
00201 {
00202   Scheme_Object *boot, *a[2];
00203   a[0] = scheme_make_pair(scheme_intern_symbol("quote"),
00204                           scheme_make_pair(scheme_intern_symbol("#%boot"),
00205                                            scheme_null));
00206   a[1] = scheme_intern_symbol("boot");
00207   boot = scheme_dynamic_require(2, a);
00208   scheme_apply(boot, 0, NULL);
00209 }
00210 
00211 void os_platform_init() {
00212 #ifdef UNIX_LIMIT_STACK
00213   struct rlimit rl;
00214 
00215   getrlimit(RLIMIT_STACK, &rl);
00216   if (rl.rlim_cur > UNIX_LIMIT_STACK) {
00217     rl.rlim_cur = UNIX_LIMIT_STACK;
00218     setrlimit(RLIMIT_STACK, &rl);
00219   }
00220 #endif
00221 #ifdef UNIX_LIMIT_FDSET_SIZE
00222   struct rlimit rl;
00223 
00224   getrlimit(RLIMIT_NOFILE, &rl);
00225   if (rl.rlim_cur > FD_SETSIZE) {
00226     rl.rlim_cur = FD_SETSIZE;
00227     setrlimit(RLIMIT_NOFILE, &rl);
00228   }
00229 #endif
00230 }
00231 
00232 Scheme_Env *scheme_restart_instance() {
00233   Scheme_Env *env;
00234   void *stack_base;
00235   stack_base = (void *) scheme_get_current_os_thread_stack_base();
00236 
00237   /* Reset everything: */
00238   scheme_do_close_managed(NULL, skip_certain_things);
00239   scheme_main_thread = NULL;
00240 
00241   scheme_reset_finalizations();
00242   scheme_init_stack_check();
00243 #ifndef MZ_PRECISE_GC
00244   scheme_init_setjumpup();
00245 #endif
00246   scheme_reset_overflow();
00247 
00248   scheme_make_thread(stack_base);
00249   scheme_init_error_escape_proc(NULL);
00250   scheme_init_module_resolver();
00251 
00252   env = scheme_make_empty_env();
00253   scheme_install_initial_module_set(env);
00254   scheme_set_param(scheme_current_config(), MZCONFIG_ENV, (Scheme_Object *)env); 
00255 
00256   scheme_init_port_config();
00257   scheme_init_port_fun_config();
00258   scheme_init_error_config();
00259 #ifndef NO_SCHEME_EXNS
00260   scheme_init_exn_config();
00261 #endif
00262 
00263   boot_module_resolver();
00264 
00265   return env;
00266 }
00267 
00268 Scheme_Env *scheme_basic_env()
00269 {
00270   Scheme_Env *env;
00271 
00272   if (scheme_main_thread) {
00273     return scheme_restart_instance();
00274   }
00275   
00276   env = scheme_engine_instance_init();
00277   
00278   return env;
00279 }
00280 
00281 static void init_toplevel_local_offsets_hashtable_caches()
00282 {
00283   REGISTER_SO(toplevels_ht);
00284   REGISTER_SO(locals_ht[0]);
00285   REGISTER_SO(locals_ht[1]);
00286 
00287   {
00288     Scheme_Hash_Table *ht;
00289     toplevels_ht = scheme_make_hash_table_equal();
00290     ht = scheme_make_hash_table(SCHEME_hash_ptr);
00291     locals_ht[0] = ht;
00292     ht = scheme_make_hash_table(SCHEME_hash_ptr);
00293     locals_ht[1] = ht;
00294   }
00295 }
00296 
00297 /* READ-ONLY GLOBAL structures ONE-TIME initialization */
00298 Scheme_Env *scheme_engine_instance_init() {
00299   Scheme_Env *env;
00300   void *stack_base;
00301   stack_base = (void *) scheme_get_current_os_thread_stack_base();
00302 
00303   os_platform_init();
00304 
00305 #ifdef TIME_STARTUP_PROCESS
00306   printf("#if 0\nengine_instance_init @ %ld\n", scheme_get_process_milliseconds());
00307 #endif
00308 
00309   scheme_starting_up = 1;
00310  
00311   scheme_init_portable_case();
00312   init_scheme_local();
00313   init_toplevels();
00314 
00315   scheme_init_true_false();
00316 
00317 #ifdef MZ_PRECISE_GC
00318   scheme_register_traversers();
00319   register_traversers();
00320   scheme_init_hash_key_procs();
00321 #endif
00322 
00323   scheme_init_getenv(); /* checks PLTNOJIT */
00324 
00325 #ifdef WINDOWS_PROCESSES
00326   /* Must be called before first scheme_make_thread() */
00327   scheme_init_thread_memory();
00328 #endif
00329 
00330 #ifndef MZ_PRECISE_GC
00331   scheme_init_ephemerons();
00332 #endif
00333 
00334 /* These calls must be made here so that they allocate out of the master GC */
00335   scheme_init_symbol_table();
00336   scheme_init_module_path_table();
00337   scheme_init_type();
00338 #ifndef DONT_USE_FOREIGN
00339   scheme_init_foreign_globals();
00340 #endif
00341 
00342 #if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES)
00343   GC_switch_out_master_gc();
00344   spawn_master_scheme_place();
00345 #endif
00346   
00347   place_instance_init_pre_kernel(stack_base);
00348   make_kernel_env();
00349   scheme_init_parameterization_readonly_globals();
00350   env = place_instance_init_post_kernel();
00351 
00352   return env;
00353 }
00354 
00355 static void place_instance_init_pre_kernel(void *stack_base) {
00356 
00357 #ifdef TIME_STARTUP_PROCESS
00358   printf("place_init @ %ld\n", scheme_get_process_milliseconds());
00359 #endif
00360   scheme_set_current_os_thread_stack_base(stack_base);
00361 
00362 #ifndef MZ_PRECISE_GC
00363   scheme_init_setjumpup();
00364 #endif
00365 
00366   scheme_init_stack_check();
00367   scheme_init_overflow();
00368 
00369   init_toplevel_local_offsets_hashtable_caches();
00370 
00371 
00372 #ifdef TIME_STARTUP_PROCESS
00373   printf("pre-process @ %ld\n", scheme_get_process_milliseconds());
00374 #endif
00375 
00376   scheme_make_thread(stack_base);
00377 
00378   scheme_init_module_resolver();
00379 
00380 #ifdef TIME_STARTUP_PROCESS
00381   printf("process @ %ld\n", scheme_get_process_milliseconds());
00382 #endif
00383 }
00384 
00385 static Scheme_Env *place_instance_init_post_kernel() {
00386   Scheme_Env *env;
00387   /* error handling and buffers */
00388   /* this check prevents initializing orig ports twice for the first initial
00389    * place.  The kernel initializes orig_ports early. */
00390   if (!scheme_orig_stdout_port) {
00391     scheme_init_port_places();
00392   }
00393   scheme_init_error_escape_proc(NULL);
00394   scheme_init_print_buffers_places();
00395   scheme_init_eval_places();
00396   scheme_init_regexp_places();
00397   scheme_init_stx_places();
00398 
00399   env = scheme_make_empty_env();
00400   scheme_set_param(scheme_current_config(), MZCONFIG_ENV, (Scheme_Object *)env); 
00401  
00402   /*initialize config */
00403   scheme_init_port_config();
00404   scheme_init_port_fun_config();
00405   scheme_init_error_config();
00406 #ifndef NO_SCHEME_EXNS
00407   scheme_init_exn_config();
00408 #endif
00409 
00410   scheme_init_memtrace(env);
00411 #ifndef NO_TCP_SUPPORT
00412   scheme_init_network(env);
00413 #endif
00414   scheme_init_parameterization(env);
00415   scheme_init_expand_observe(env);
00416   scheme_init_place(env);
00417 
00418 #ifndef DONT_USE_FOREIGN
00419   scheme_init_foreign(env);
00420 #else
00421   init_dummy_foreign(env);
00422 #endif
00423 
00424   scheme_add_embedded_builtins(env);
00425 
00426   boot_module_resolver();
00427 
00428   scheme_save_initial_module_set(env);
00429 
00430 
00431   scheme_starting_up = 0;
00432 
00433   --scheme_current_thread->suspend_break; /* created with breaks suspended */
00434 
00435 #ifdef TIME_STARTUP_PROCESS
00436   printf("done @ %ld\n#endif\n", scheme_get_process_milliseconds());
00437 #endif
00438 
00439   return env;
00440 }
00441 
00442 Scheme_Env *scheme_place_instance_init(void *stack_base) {
00443   place_instance_init_pre_kernel(stack_base);
00444   return place_instance_init_post_kernel();
00445 }
00446 
00447 static void make_kernel_env(void)
00448 {
00449   Scheme_Env *env;
00450 #ifdef TIME_STARTUP_PROCESS
00451   long startt;
00452 #endif
00453 
00454   env = make_empty_inited_env(GLOBAL_TABLE_SIZE);
00455 
00456   scheme_set_param(scheme_current_config(), MZCONFIG_ENV, 
00457                  (Scheme_Object *)env);
00458 
00459   REGISTER_SO(kernel_env);
00460   kernel_env = env;
00461 
00462   scheme_defining_primitives = 1;
00463   builtin_ref_counter = 0;
00464 
00465 #ifdef TIME_STARTUP_PROCESS
00466    printf("init @ %ld\n", scheme_get_process_milliseconds());
00467 # define MZTIMEIT(n, f) (MARK_START_TIME(), f, DONE_TIME(n))
00468 # define MARK_START_TIME() startt = scheme_get_process_milliseconds()
00469 # define DONE_TIME(n) (printf(#n ": %ld\n", (long)(scheme_get_process_milliseconds() - startt)))
00470 #else
00471 # define MZTIMEIT(n, f) f
00472 # define MARK_START_TIME() 
00473 # define DONE_TIME(n) 
00474 #endif
00475 
00476   /* The ordering of the first few init calls is important, so add to
00477      the end of the list, not the beginning. */
00478   MZTIMEIT(symbol-type, scheme_init_symbol_type(env));
00479   MZTIMEIT(fun, scheme_init_fun(env));
00480   MZTIMEIT(symbol, scheme_init_symbol(env));
00481   MZTIMEIT(list, scheme_init_list(env));
00482   MZTIMEIT(number, scheme_init_number(env));
00483   MZTIMEIT(numarith, scheme_init_numarith(env));
00484   MZTIMEIT(numcomp, scheme_init_numcomp(env));
00485   MZTIMEIT(numstr, scheme_init_numstr(env));
00486   MZTIMEIT(stx, scheme_init_stx(env));
00487   MZTIMEIT(module, scheme_init_module(env));
00488   MZTIMEIT(port, scheme_init_port(env));
00489   MZTIMEIT(portfun, scheme_init_port_fun(env));
00490   MZTIMEIT(string, scheme_init_string(env));
00491   MZTIMEIT(vector, scheme_init_vector(env));
00492   MZTIMEIT(char, scheme_init_char(env));
00493   MZTIMEIT(bool, scheme_init_bool(env));
00494   MZTIMEIT(syntax, scheme_init_syntax(env));
00495   MZTIMEIT(eval, scheme_init_eval(env));
00496   MZTIMEIT(error, scheme_init_error(env));
00497   MZTIMEIT(struct, scheme_init_struct(env));
00498 #ifndef NO_SCHEME_EXNS
00499   MZTIMEIT(exn, scheme_init_exn(env));
00500 #endif
00501   MZTIMEIT(process, scheme_init_thread(env));
00502   MZTIMEIT(reduced, scheme_init_reduced_proc_struct(env));
00503 #ifndef NO_SCHEME_THREADS
00504   MZTIMEIT(sema, scheme_init_sema(env));
00505 #endif
00506   MZTIMEIT(read, scheme_init_read(env));
00507   MZTIMEIT(print, scheme_init_print(env));
00508   MZTIMEIT(file, scheme_init_file(env));
00509   MZTIMEIT(dynamic-extension, scheme_init_dynamic_extension(env));
00510 #ifndef NO_REGEXP_UTILS
00511   MZTIMEIT(regexp, scheme_regexp_initialize(env));
00512 #endif
00513 
00514   MARK_START_TIME();
00515 
00516   GLOBAL_PRIM_W_ARITY("namespace-symbol->identifier", namespace_identifier, 1, 2, env);
00517   GLOBAL_PRIM_W_ARITY("namespace-module-identifier", namespace_module_identifier, 0, 1, env);
00518   GLOBAL_PRIM_W_ARITY("namespace-base-phase", namespace_base_phase, 0, 1, env);
00519   GLOBAL_PRIM_W_ARITY("namespace-variable-value", namespace_variable_value, 1, 4, env);
00520   GLOBAL_PRIM_W_ARITY("namespace-set-variable-value!", namespace_set_variable_value, 2, 4, env);
00521   GLOBAL_PRIM_W_ARITY("namespace-undefine-variable!", namespace_undefine_variable, 1, 2, env);
00522   GLOBAL_PRIM_W_ARITY("namespace-mapped-symbols", namespace_mapped_symbols, 0, 1, env);
00523   GLOBAL_PRIM_W_ARITY("namespace-module-registry", namespace_module_registry, 1, 1, env);
00524 
00525   GLOBAL_PRIM_W_ARITY("variable-reference?", variable_p, 1, 1, env);
00526   GLOBAL_PRIM_W_ARITY("variable-reference->resolved-module-path", variable_module_path, 1, 1, env);
00527   GLOBAL_PRIM_W_ARITY("variable-reference->empty-namespace", variable_namespace, 1, 1, env);
00528   GLOBAL_PRIM_W_ARITY("variable-reference->namespace", variable_top_level_namespace, 1, 1, env);
00529   GLOBAL_PRIM_W_ARITY("variable-reference->phase", variable_phase, 1, 1, env);
00530 
00531   GLOBAL_PRIM_W_ARITY("syntax-transforming?", now_transforming, 0, 0, env);
00532   GLOBAL_PRIM_W_ARITY("syntax-local-value", local_exp_time_value, 1, 3, env);
00533   GLOBAL_PRIM_W_ARITY("syntax-local-value/immediate", local_exp_time_value_one, 1, 3, env);
00534   GLOBAL_PRIM_W_ARITY("syntax-local-name", local_exp_time_name, 0, 0, env);
00535   GLOBAL_PRIM_W_ARITY("syntax-local-context", local_context, 0, 0, env);
00536   GLOBAL_PRIM_W_ARITY("syntax-local-phase-level", local_phase_level, 0, 0, env);
00537   GLOBAL_PRIM_W_ARITY("syntax-local-make-definition-context", local_make_intdef_context, 0, 1, env);
00538   GLOBAL_PRIM_W_ARITY("internal-definition-context-seal", intdef_context_seal, 1, 1, env);
00539   GLOBAL_PRIM_W_ARITY("internal-definition-context?", intdef_context_p, 1, 1, env);
00540   GLOBAL_PRIM_W_ARITY("identifier-remove-from-definition-context", id_intdef_remove, 2, 2, env);
00541   GLOBAL_PRIM_W_ARITY("syntax-local-get-shadower", local_get_shadower, 1, 1, env);
00542   GLOBAL_PRIM_W_ARITY("syntax-local-introduce", local_introduce, 1, 1, env);
00543   GLOBAL_PRIM_W_ARITY("make-syntax-introducer", make_introducer, 0, 1, env);
00544   GLOBAL_PRIM_W_ARITY("syntax-local-make-delta-introducer", local_make_delta_introduce, 1, 1, env);
00545   GLOBAL_PRIM_W_ARITY("syntax-local-certifier", local_certify, 0, 1, env);
00546 
00547   GLOBAL_PRIM_W_ARITY("syntax-local-module-exports", local_module_exports, 1, 1, env);
00548   GLOBAL_PRIM_W_ARITY("syntax-local-module-defined-identifiers", local_module_definitions, 0, 0, env);
00549   GLOBAL_PRIM_W_ARITY("syntax-local-module-required-identifiers", local_module_imports, 2, 2, env);
00550   GLOBAL_PRIM_W_ARITY("syntax-local-transforming-module-provides?", local_module_expanding_provides, 0, 0, env);
00551 
00552   GLOBAL_PRIM_W_ARITY("make-set!-transformer", make_set_transformer, 1, 1, env);
00553   GLOBAL_PRIM_W_ARITY("set!-transformer?", set_transformer_p, 1, 1, env);
00554   GLOBAL_PRIM_W_ARITY("set!-transformer-procedure", set_transformer_proc, 1, 1, env);
00555 
00556   GLOBAL_PRIM_W_ARITY("make-rename-transformer", make_rename_transformer, 1, 2, env);
00557   GLOBAL_PRIM_W_ARITY("rename-transformer?", rename_transformer_p, 1, 1, env);
00558   GLOBAL_PRIM_W_ARITY("rename-transformer-target", rename_transformer_target, 1, 1, env);
00559 
00560   GLOBAL_PRIM_W_ARITY("syntax-local-lift-expression", local_lift_expr, 1, 1, env);
00561   GLOBAL_PRIM_W_ARITY("syntax-local-lift-values-expression", local_lift_exprs, 2, 2, env);
00562   GLOBAL_PRIM_W_ARITY("syntax-local-lift-context", local_lift_context, 0, 0, env);
00563   GLOBAL_PRIM_W_ARITY("syntax-local-lift-module-end-declaration", local_lift_end_statement, 1, 1, env);
00564   GLOBAL_PRIM_W_ARITY("syntax-local-lift-require", local_lift_require, 2, 2, env);
00565   GLOBAL_PRIM_W_ARITY("syntax-local-lift-provide", local_lift_provide, 1, 1, env);
00566 
00567   {
00568     Scheme_Object *sym;
00569     sym = scheme_intern_symbol("mzscheme");
00570     scheme_current_thread->name = sym;
00571   }
00572 
00573   DONE_TIME(env);
00574 
00575   scheme_install_type_writer(scheme_toplevel_type, write_toplevel);
00576   scheme_install_type_reader(scheme_toplevel_type, read_toplevel);
00577   scheme_install_type_writer(scheme_variable_type, write_variable);
00578   scheme_install_type_reader(scheme_variable_type, read_variable);
00579   scheme_install_type_writer(scheme_module_variable_type, write_module_variable);
00580   scheme_install_type_reader(scheme_module_variable_type, read_module_variable);
00581   scheme_install_type_writer(scheme_local_type, write_local);
00582   scheme_install_type_reader(scheme_local_type, read_local);
00583   scheme_install_type_writer(scheme_local_unbox_type, write_local);
00584   scheme_install_type_reader(scheme_local_unbox_type, read_local_unbox);
00585   scheme_install_type_writer(scheme_resolve_prefix_type, write_resolve_prefix);
00586   scheme_install_type_reader(scheme_resolve_prefix_type, read_resolve_prefix);
00587 
00588   REGISTER_SO(kernel_symbol);
00589   kernel_symbol = scheme_intern_symbol("#%kernel");
00590 
00591   MARK_START_TIME();
00592 
00593   scheme_finish_kernel(env);
00594 
00595 #if USE_COMPILED_STARTUP
00596   if (builtin_ref_counter != EXPECTED_PRIM_COUNT) {
00597     printf("Primitive count %d doesn't match expected count %d\n"
00598           "Turn off USE_COMPILED_STARTUP in src/schminc.h\n",
00599           builtin_ref_counter, EXPECTED_PRIM_COUNT);
00600     exit(1);
00601   }
00602 #endif
00603    
00604   scheme_defining_primitives = 0;
00605 }
00606 
00607 int scheme_is_kernel_env(Scheme_Env *env) {
00608   return (env == kernel_env);
00609 }
00610 
00611 Scheme_Env *scheme_get_kernel_env() {
00612   return kernel_env;
00613 }
00614 
00615 static void init_scheme_local() 
00616 {
00617   int i, k, cor;
00618 
00619 #ifndef USE_TAGGED_ALLOCATION
00620   GC_CAN_IGNORE Scheme_Local *all;
00621 
00622   all = (Scheme_Local *)scheme_malloc_eternal(sizeof(Scheme_Local) * 3 * 2 * MAX_CONST_LOCAL_POS);
00623 # ifdef MEMORY_COUNTING_ON
00624   scheme_misc_count += sizeof(Scheme_Local) * 3 * 2 * MAX_CONST_LOCAL_POS;
00625 # endif    
00626 #endif
00627 
00628   for (i = 0; i < MAX_CONST_LOCAL_POS; i++) {
00629     for (k = 0; k < 2; k++) {
00630       for (cor = 0; cor < 3; cor++) {
00631         Scheme_Object *v;
00632 
00633 #ifndef USE_TAGGED_ALLOCATION
00634         v = (Scheme_Object *)(all++);
00635 #else
00636         v = (Scheme_Object *)scheme_malloc_eternal_tagged(sizeof(Scheme_Local));
00637 #endif
00638         v->type = k + scheme_local_type;
00639         SCHEME_LOCAL_POS(v) = i;
00640         SCHEME_LOCAL_FLAGS(v) = cor;
00641 
00642         scheme_local[i][k][cor] = v;
00643       }
00644     }
00645   }
00646 }
00647 
00648 static void init_toplevels()
00649 {
00650   int i, k, cnst;
00651 
00652 #ifndef USE_TAGGED_ALLOCATION
00653   GC_CAN_IGNORE Scheme_Toplevel *all;
00654 
00655   all = (Scheme_Toplevel *)scheme_malloc_eternal(sizeof(Scheme_Toplevel) 
00656       * MAX_CONST_TOPLEVEL_DEPTH 
00657       * MAX_CONST_TOPLEVEL_POS
00658       * (SCHEME_TOPLEVEL_FLAGS_MASK + 1));
00659 # ifdef MEMORY_COUNTING_ON
00660   scheme_misc_count += (sizeof(Scheme_Toplevel) 
00661       * MAX_CONST_TOPLEVEL_DEPTH 
00662       * MAX_CONST_TOPLEVEL_POS
00663       * (SCHEME_TOPLEVEL_FLAGS_MASK + 1));
00664 # endif
00665 #endif
00666 
00667   for (i = 0; i < MAX_CONST_TOPLEVEL_DEPTH; i++) {
00668     for (k = 0; k < MAX_CONST_TOPLEVEL_POS; k++) {
00669       for (cnst = 0; cnst <= SCHEME_TOPLEVEL_FLAGS_MASK; cnst++) {
00670         Scheme_Toplevel *v;
00671 
00672 #ifndef USE_TAGGED_ALLOCATION
00673         v = (all++);
00674 #else
00675         v = (Scheme_Toplevel *)scheme_malloc_eternal_tagged(sizeof(Scheme_Toplevel));
00676 #endif
00677         v->iso.so.type = scheme_toplevel_type;
00678         v->depth = i;
00679         v->position = k;
00680         SCHEME_TOPLEVEL_FLAGS(v) = cnst;
00681 
00682         toplevels[i][k][cnst] = (Scheme_Object *)v;
00683       }
00684     }
00685   }
00686 }
00687 
00688 
00689 /* Shutdown procedure for resetting a namespace: */
00690 static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data)
00691 {
00692   if ((o == scheme_orig_stdin_port)
00693       || (o == scheme_orig_stdout_port)
00694       || (o == scheme_orig_stderr_port))
00695     return;
00696 
00697   /* f is NULL for threads */
00698   if (f)
00699     f(o, data);
00700 }
00701 
00702 /*========================================================================*/
00703 /*                        namespace constructors                          */
00704 /*========================================================================*/
00705 
00706 void scheme_prepare_env_renames(Scheme_Env *env, int kind)
00707 {
00708   if (!env->rename_set) {
00709     Scheme_Object *rns;
00710 
00711     rns = scheme_make_module_rename_set(kind, NULL);
00712     env->rename_set = rns;
00713   }
00714 }
00715 
00716 Scheme_Env *scheme_make_empty_env(void)
00717 {
00718   Scheme_Env *e;
00719 
00720   e = make_empty_inited_env(7);
00721 
00722   return e;
00723 }
00724 
00725 Scheme_Env *make_empty_inited_env(int toplevel_size)
00726 {
00727   Scheme_Env *env;
00728   Scheme_Object *vector;
00729   Scheme_Hash_Table* hash_table;
00730 
00731   env = make_env(NULL, toplevel_size);
00732 
00733   vector = scheme_make_vector(5, scheme_false);
00734   hash_table = scheme_make_hash_table(SCHEME_hash_ptr);
00735   SCHEME_VEC_ELS(vector)[0] = (Scheme_Object *)hash_table;
00736   env->modchain = vector;
00737 
00738   hash_table = scheme_make_hash_table(SCHEME_hash_ptr);
00739   env->module_registry = hash_table;
00740   env->module_registry->iso.so.type = scheme_module_registry_type;
00741 
00742   hash_table = scheme_make_hash_table(SCHEME_hash_ptr);
00743   env->export_registry = hash_table;
00744   env->label_env = NULL;
00745 
00746   return env;
00747 }
00748 
00749 Scheme_Env *make_empty_not_inited_env(int toplevel_size)
00750 {
00751   Scheme_Env *e;
00752 
00753   e = make_env(NULL, toplevel_size);
00754 
00755   return e;
00756 }
00757 
00758 static Scheme_Env *make_env(Scheme_Env *base, int toplevel_size)
00759 {
00760   Scheme_Env *env;
00761   Scheme_Bucket_Table *bucket_table;
00762 
00763   env = MALLOC_ONE_TAGGED(Scheme_Env);
00764   env->so.type = scheme_namespace_type;
00765 
00766   bucket_table = scheme_make_bucket_table(toplevel_size, SCHEME_hash_ptr);
00767   env->toplevel = bucket_table;
00768   env->toplevel->with_home = 1;
00769 
00770   bucket_table = scheme_make_bucket_table(7, SCHEME_hash_ptr);
00771   env->syntax = bucket_table;
00772 
00773   if (base) {
00774     env->modchain = base->modchain;
00775     env->module_registry = base->module_registry;
00776     env->export_registry = base->export_registry;
00777     env->label_env = base->label_env;
00778   } else {
00779     env->modchain = NULL;
00780     env->module_registry = NULL;
00781     env->export_registry = NULL;
00782     env->label_env = NULL;
00783   }
00784 
00785   return env;
00786 }
00787 
00788 Scheme_Env *
00789 scheme_new_module_env(Scheme_Env *env, Scheme_Module *m, int new_exp_module_tree)
00790 {
00791   Scheme_Env *menv;
00792 
00793   menv = make_env(env, 7);
00794 
00795   menv->module = m;
00796 
00797   scheme_prepare_label_env(env);
00798   menv->label_env = env->label_env;
00799 
00800   if (new_exp_module_tree) {
00801     Scheme_Object *p;
00802     Scheme_Hash_Table *modules;
00803 
00804     modules = scheme_make_hash_table(SCHEME_hash_ptr);
00805     p = scheme_make_vector(5, scheme_false);
00806     SCHEME_VEC_ELS(p)[0] = (Scheme_Object *)modules;
00807     menv->modchain = p;
00808   }
00809 
00810   if (SAME_OBJ(env, env->exp_env)) {
00811     /* label phase */
00812     menv->exp_env = menv;
00813     menv->template_env = menv;
00814   }
00815 
00816   return menv;
00817 }
00818 
00819 void scheme_prepare_exp_env(Scheme_Env *env)
00820 {
00821   if (!env->exp_env) {
00822     Scheme_Env *eenv;
00823     Scheme_Object *modchain;
00824 
00825     scheme_prepare_label_env(env);
00826 
00827     eenv = make_empty_not_inited_env(7);
00828     eenv->phase = env->phase + 1;
00829     eenv->mod_phase = env->mod_phase + 1;
00830 
00831     eenv->module = env->module;
00832     eenv->module_registry = env->module_registry;
00833     eenv->export_registry = env->export_registry;
00834     eenv->insp = env->insp;
00835 
00836     modchain = SCHEME_VEC_ELS(env->modchain)[1];
00837     if (SCHEME_FALSEP(modchain)) {
00838       Scheme_Hash_Table *next_modules;
00839 
00840       next_modules = scheme_make_hash_table(SCHEME_hash_ptr);
00841       modchain = scheme_make_vector(5, scheme_false);
00842       SCHEME_VEC_ELS(modchain)[0] = (Scheme_Object *)next_modules;
00843       SCHEME_VEC_ELS(env->modchain)[1] = modchain;
00844       SCHEME_VEC_ELS(modchain)[2] = env->modchain;
00845     }
00846     eenv->modchain = modchain;
00847 
00848     env->exp_env = eenv;
00849     eenv->template_env = env;
00850     eenv->label_env = env->label_env;
00851 
00852     scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL);
00853     eenv->rename_set = env->rename_set;
00854 
00855     if (env->disallow_unbound)
00856       eenv->disallow_unbound = 1;
00857   }
00858 }
00859 
00860 void scheme_prepare_template_env(Scheme_Env *env)
00861 {
00862   if (!env->template_env) {
00863     Scheme_Env *eenv;
00864     Scheme_Object *modchain;
00865 
00866     scheme_prepare_label_env(env);
00867 
00868     eenv = make_empty_not_inited_env(7);
00869     eenv->phase = env->phase - 1;
00870     eenv->mod_phase = env->mod_phase - 1;
00871 
00872     eenv->module = env->module;
00873     eenv->module_registry = env->module_registry;
00874     eenv->export_registry = env->export_registry;
00875     eenv->insp = env->insp;
00876 
00877     modchain = SCHEME_VEC_ELS(env->modchain)[2];
00878     if (SCHEME_FALSEP(modchain)) {
00879       Scheme_Hash_Table *prev_modules;
00880 
00881       prev_modules = scheme_make_hash_table(SCHEME_hash_ptr);
00882       modchain = scheme_make_vector(5, scheme_false);
00883       SCHEME_VEC_ELS(modchain)[0] = (Scheme_Object *)prev_modules;
00884       SCHEME_VEC_ELS(env->modchain)[2] = modchain;
00885       SCHEME_VEC_ELS(modchain)[1] = env->modchain;
00886     }
00887     eenv->modchain = modchain;
00888 
00889     scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL);
00890     eenv->rename_set = env->rename_set;
00891 
00892     env->template_env = eenv;
00893     eenv->exp_env = env;       
00894     eenv->label_env = env->label_env;
00895 
00896     if (env->disallow_unbound)
00897       eenv->disallow_unbound = 1;
00898   }
00899 }
00900 
00901 void scheme_prepare_label_env(Scheme_Env *env)
00902 {
00903   if (!env->label_env) {
00904     Scheme_Env *lenv;
00905     Scheme_Object *modchain;
00906     Scheme_Hash_Table *prev_modules;
00907 
00908     lenv = make_empty_not_inited_env(7);
00909     lenv->phase = 0;
00910     lenv->mod_phase = 0;
00911 
00912     lenv->module = env->module;
00913     lenv->module_registry = env->module_registry;
00914     lenv->export_registry = env->export_registry;
00915     lenv->insp = env->insp;
00916 
00917     modchain = scheme_make_vector(5, scheme_false);    
00918     prev_modules = scheme_make_hash_table(SCHEME_hash_ptr);
00919     SCHEME_VEC_ELS(modchain)[0] = (Scheme_Object *)prev_modules;
00920     SCHEME_VEC_ELS(modchain)[2] = modchain;
00921     SCHEME_VEC_ELS(modchain)[1] = modchain;
00922     lenv->modchain = modchain;
00923 
00924     env->label_env = lenv;
00925 
00926     lenv->exp_env = lenv;
00927     lenv->label_env = lenv;
00928     lenv->template_env = lenv;
00929   }
00930 }
00931 
00932 Scheme_Env *scheme_copy_module_env(Scheme_Env *menv, Scheme_Env *ns, Scheme_Object *modchain, int clone_phase)
00933 {
00934   /* New env should have the same syntax and globals table, but it lives in
00935      a different namespace. */
00936   Scheme_Env *menv2;
00937   Scheme_Bucket_Table *bucket_table;
00938 
00939   scheme_prepare_label_env(ns);
00940 
00941   menv2 = MALLOC_ONE_TAGGED(Scheme_Env);
00942   menv2->so.type = scheme_namespace_type;
00943 
00944   menv2->module = menv->module;
00945   menv2->module_registry = ns->module_registry;
00946   menv2->export_registry = ns->export_registry;
00947   menv2->insp = menv->insp;
00948 
00949   if (menv->phase < clone_phase)
00950     menv2->syntax = menv->syntax;
00951   else {
00952     bucket_table = scheme_make_bucket_table(7, SCHEME_hash_ptr);
00953     menv2->syntax = bucket_table;
00954   }
00955 
00956   menv2->phase = menv->phase;
00957   menv2->mod_phase = menv->mod_phase;
00958   menv2->link_midx = menv->link_midx;
00959   if (menv->phase <= clone_phase) {
00960     menv2->running = menv->running;
00961     menv2->ran = menv->ran;
00962   }
00963   if (menv->phase < clone_phase)
00964     menv2->et_running = menv->et_running;
00965 
00966   menv2->require_names = menv->require_names;
00967   menv2->et_require_names = menv->et_require_names;
00968 
00969   if (menv->phase <= clone_phase) {
00970     menv2->toplevel = menv->toplevel;
00971   } else {
00972     bucket_table = scheme_make_bucket_table(7, SCHEME_hash_ptr);
00973     menv2->toplevel = bucket_table;
00974     menv2->toplevel->with_home = 1;
00975   }
00976   
00977   menv2->modchain = modchain;
00978 
00979   if (SAME_OBJ(menv->exp_env, menv)) {
00980     /* label phase */
00981     menv2->exp_env = menv2;
00982     menv2->template_env = menv2;
00983   } else if (menv->phase < clone_phase) {
00984     if (!SCHEME_NULLP(menv2->module->et_requires)) {
00985       /* We'll need the next link in the modchain: */
00986       modchain = SCHEME_VEC_ELS(modchain)[1];
00987       if (SCHEME_FALSEP(modchain)) {
00988         Scheme_Hash_Table *next_modules;
00989       
00990         next_modules = scheme_make_hash_table(SCHEME_hash_ptr);
00991         modchain = scheme_make_vector(5, scheme_false);
00992         SCHEME_VEC_ELS(modchain)[0] = (Scheme_Object *)next_modules;
00993         SCHEME_VEC_ELS(menv2->modchain)[1] = modchain;
00994         SCHEME_VEC_ELS(modchain)[2] = menv2->modchain;
00995       }
00996     }
00997 
00998     if (menv->exp_env) {
00999       /* Share for-syntax bindings, too: */
01000       scheme_prepare_exp_env(menv2);
01001       menv2->exp_env->toplevel = menv->exp_env->toplevel;
01002     }
01003   }
01004    
01005   scheme_prepare_label_env(ns);
01006   menv2->label_env = ns->label_env;
01007 
01008   return menv2;
01009 }
01010 
01011 Scheme_Bucket_Table *scheme_clone_toplevel(Scheme_Bucket_Table *ht, Scheme_Env *home)
01012 {
01013   Scheme_Bucket_Table *r;
01014   Scheme_Bucket **bs;
01015   int i;
01016 
01017   r = scheme_make_bucket_table(ht->size, SCHEME_hash_ptr);
01018   if (home)
01019     r->with_home = 1;
01020 
01021   bs = ht->buckets;
01022 
01023   for (i = ht->size; i--; ) {
01024     Scheme_Bucket *b = bs[i];
01025     if (b && b->val) {
01026       Scheme_Object *name = (Scheme_Object *)b->key;
01027       Scheme_Object *val = (Scheme_Object *)b->val;
01028 
01029       b = scheme_bucket_from_table(r, (const char *)name);
01030       b->val = val;
01031       if (home) {
01032         ASSERT_IS_VARIABLE_BUCKET(b);
01033        ((Scheme_Bucket_With_Home *)b)->home = home;
01034       }
01035     }
01036   }
01037 
01038   return r;
01039 }
01040 
01041 void scheme_clean_dead_env(Scheme_Env *env)
01042 {
01043   Scheme_Object *modchain, *next;
01044 
01045   if (env->exp_env) {
01046     env->exp_env->template_env = NULL;
01047     scheme_clean_dead_env(env->exp_env);
01048     env->exp_env = NULL;
01049   }
01050   if (env->template_env) {
01051     env->template_env->exp_env = NULL;
01052     scheme_clean_dead_env(env->template_env);
01053     env->template_env = NULL;
01054   }
01055 
01056   env->modvars = NULL;
01057   
01058   modchain = env->modchain;
01059   env->modchain = NULL;
01060   while (modchain && !SCHEME_VECTORP(modchain)) {
01061     next = SCHEME_VEC_ELS(modchain)[1];
01062     SCHEME_VEC_ELS(modchain)[1] = scheme_void;
01063     modchain = next;
01064   }
01065 }
01066 
01067 /*========================================================================*/
01068 /*                           namespace bindings                           */
01069 /*========================================================================*/
01070 
01071 /********** Lookup **********/
01072 
01073 Scheme_Object *
01074 scheme_lookup_global(Scheme_Object *symbol, Scheme_Env *env)
01075 {
01076   Scheme_Bucket *b;
01077     
01078   b = scheme_bucket_or_null_from_table(env->toplevel, (char *)symbol, 0);
01079   if (b) {
01080     ASSERT_IS_VARIABLE_BUCKET(b);
01081     if (!((Scheme_Bucket_With_Home *)b)->home)
01082       ((Scheme_Bucket_With_Home *)b)->home = env;
01083     return (Scheme_Object *)b->val;
01084   }
01085 
01086   return NULL;
01087 }
01088 
01089 Scheme_Bucket *
01090 scheme_global_bucket(Scheme_Object *symbol, Scheme_Env *env)
01091 {
01092   Scheme_Bucket *b;
01093     
01094   b = scheme_bucket_from_table(env->toplevel, (char *)symbol);
01095   ASSERT_IS_VARIABLE_BUCKET(b);
01096   if (!((Scheme_Bucket_With_Home *)b)->home)
01097     ((Scheme_Bucket_With_Home *)b)->home = env;
01098     
01099   return b;
01100 }
01101 
01102 Scheme_Bucket *
01103 scheme_global_keyword_bucket(Scheme_Object *symbol, Scheme_Env *env)
01104 {
01105   Scheme_Bucket *b;
01106     
01107   b = scheme_bucket_from_table(env->syntax, (char *)symbol);
01108     
01109   return b;
01110 }
01111 
01112 /********** Set **********/
01113 
01114 void
01115 scheme_do_add_global_symbol(Scheme_Env *env, Scheme_Object *sym, 
01116                          Scheme_Object *obj, 
01117                          int valvar, int constant)
01118 {
01119   if (valvar) {
01120     Scheme_Bucket *b;
01121     b = scheme_bucket_from_table(env->toplevel, (const char *)sym);
01122     b->val = obj;
01123     ASSERT_IS_VARIABLE_BUCKET(b);
01124     ((Scheme_Bucket_With_Home *)b)->home = env;
01125     if (constant && scheme_defining_primitives) {
01126       ((Scheme_Bucket_With_Flags *)b)->id = builtin_ref_counter++;
01127       ((Scheme_Bucket_With_Flags *)b)->flags |= (GLOB_HAS_REF_ID | GLOB_IS_CONST);
01128     }
01129   } else
01130     scheme_add_to_table(env->syntax, (const char *)sym, obj, constant);
01131 }
01132 
01133 void
01134 scheme_add_global(const char *name, Scheme_Object *obj, Scheme_Env *env)
01135 {
01136   scheme_do_add_global_symbol(env, scheme_intern_symbol(name), obj, 1, 0);
01137 }
01138 
01139 void
01140 scheme_add_global_symbol(Scheme_Object *sym, Scheme_Object *obj, Scheme_Env *env)
01141 {
01142   scheme_do_add_global_symbol(env, sym, obj, 1, 0);
01143 }
01144 
01145 void
01146 scheme_add_global_constant(const char *name, Scheme_Object *obj, 
01147                         Scheme_Env *env)
01148 {
01149   scheme_do_add_global_symbol(env, scheme_intern_symbol(name), obj, 1, 1);
01150 }
01151 
01152 void
01153 scheme_add_global_constant_symbol(Scheme_Object *name, Scheme_Object *obj, 
01154                               Scheme_Env *env)
01155 {
01156   scheme_do_add_global_symbol(env, name, obj, 1, 1);
01157 }
01158 
01159 void
01160 scheme_add_global_keyword(const char *name, Scheme_Object *obj, 
01161                        Scheme_Env *env)
01162 {
01163   scheme_do_add_global_symbol(env, scheme_intern_symbol(name), obj, 0, 0);
01164 }
01165 
01166 void
01167 scheme_add_global_keyword_symbol(Scheme_Object *name, Scheme_Object *obj, 
01168                              Scheme_Env *env)
01169 {
01170   scheme_do_add_global_symbol(env, name, obj, 0, 0);
01171 }
01172 
01173 void scheme_shadow(Scheme_Env *env, Scheme_Object *n, int stxtoo)
01174 {
01175   Scheme_Object *rn;
01176 
01177   if (env->rename_set) {
01178     rn = scheme_get_module_rename_from_set(env->rename_set,
01179                                            scheme_make_integer(env->phase),
01180                                            0);
01181     if (rn) {
01182       scheme_remove_module_rename(rn, n);
01183       if (env->module) {
01184         scheme_extend_module_rename(rn,
01185                                     env->module->self_modidx,
01186                                     n, n,
01187                                     env->module->self_modidx,
01188                                     n,
01189                                     env->mod_phase,
01190                                     NULL,
01191                                     NULL,
01192                                     NULL,
01193                                     0);
01194       }
01195     }
01196   } else
01197     rn = NULL;
01198 
01199   if (stxtoo) {
01200     if (!env->module || rn) {
01201       if (!env->shadowed_syntax) {
01202        Scheme_Hash_Table *ht;
01203        ht = scheme_make_hash_table(SCHEME_hash_ptr);
01204        env->shadowed_syntax = ht;
01205       }
01206       
01207       scheme_hash_set(env->shadowed_syntax, n, scheme_true);
01208     }
01209   } else {
01210     if (env->shadowed_syntax)
01211       scheme_hash_set(env->shadowed_syntax, n, NULL);
01212 
01213     if (rn) {
01214       /* If the syntax binding is a rename transformer, need to install 
01215          a mapping. */
01216       Scheme_Object *v;
01217       v = scheme_lookup_in_table(env->syntax, (const char *)n);
01218       if (v) {
01219         v = SCHEME_PTR_VAL(v);
01220         if (scheme_is_binding_rename_transformer(v)) {
01221           scheme_install_free_id_rename(n, 
01222                                         scheme_rename_transformer_id(v), 
01223                                         rn, 
01224                                         scheme_make_integer(env->phase));
01225         }
01226       }
01227     }
01228   }
01229 }
01230 
01231 /********** Auxilliary tables **********/
01232 
01233 Scheme_Object **scheme_make_builtin_references_table(void)
01234 {
01235   Scheme_Bucket_Table *ht;
01236   Scheme_Object **t;
01237   Scheme_Bucket **bs;
01238   Scheme_Env *kenv;
01239   long i;
01240 
01241   t = MALLOC_N(Scheme_Object *, (builtin_ref_counter + 1));
01242 #ifdef MEMORY_COUNTING_ON
01243   scheme_misc_count += sizeof(Scheme_Object *) * (builtin_ref_counter + 1);
01244 #endif
01245 
01246   kenv = scheme_get_kernel_env();
01247 
01248   ht = kenv->toplevel;
01249 
01250   bs = ht->buckets;
01251 
01252   for (i = ht->size; i--; ) {
01253     Scheme_Bucket *b = bs[i];
01254     if (b && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_HAS_REF_ID))
01255       t[((Scheme_Bucket_With_Ref_Id *)b)->id] = (Scheme_Object *)b->val;
01256   }
01257 
01258   return t;
01259 }
01260 
01261 Scheme_Hash_Table *scheme_map_constants_to_globals(void)
01262 {
01263   Scheme_Bucket_Table *ht;
01264   Scheme_Hash_Table*result;
01265   Scheme_Bucket **bs;
01266   Scheme_Env *kenv;
01267   long i;
01268   
01269   kenv = scheme_get_kernel_env();
01270 
01271   ht = kenv->toplevel;
01272   bs = ht->buckets;
01273 
01274   result = scheme_make_hash_table(SCHEME_hash_ptr);
01275 
01276   for (i = ht->size; i--; ) {
01277     Scheme_Bucket *b = bs[i];
01278     if (b && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONST)) {
01279       scheme_hash_set(result, b->val, (Scheme_Object *)b);
01280     }
01281   }
01282 
01283   return result;
01284 }
01285 
01286 /*========================================================================*/
01287 /*        compile-time env, constructors and simple queries               */
01288 /*========================================================================*/
01289 
01290 static void init_compile_data(Scheme_Comp_Env *env)
01291 {
01292   Compile_Data *data;
01293   int i, c, *use;
01294 
01295   c = env->num_bindings;
01296   if (c)
01297     use = MALLOC_N_ATOMIC(int, c);
01298   else
01299     use = NULL;
01300 
01301   data = COMPILE_DATA(env);
01302 
01303   data->use = use;
01304   for (i = 0; i < c; i++) {
01305     use[i] = 0;
01306   }
01307 }
01308 
01309 Scheme_Comp_Env *scheme_new_compilation_frame(int num_bindings, int flags,
01310                                          Scheme_Comp_Env *base, Scheme_Object *certs)
01311 {
01312   Scheme_Comp_Env *frame;
01313   int count;
01314   
01315   count = num_bindings;
01316 
01317   frame = (Scheme_Comp_Env *)MALLOC_ONE_RT(Scheme_Full_Comp_Env);
01318 #ifdef MZTAG_REQUIRED
01319   frame->type = scheme_rt_comp_env;
01320 #endif
01321 
01322   {
01323     Scheme_Object **vals;
01324     vals = MALLOC_N(Scheme_Object *, count);
01325     frame->values = vals;
01326   }
01327 
01328   frame->certs = certs;
01329   frame->num_bindings = num_bindings;
01330   frame->flags = flags | (base->flags & SCHEME_NO_RENAME);
01331   frame->next = base;
01332   frame->genv = base->genv;
01333   frame->insp = base->insp;
01334   frame->prefix = base->prefix;
01335   frame->in_modidx = base->in_modidx;
01336 
01337   if (flags & SCHEME_NON_SIMPLE_FRAME)
01338     frame->skip_depth = 0;
01339   else if (base->next)
01340     frame->skip_depth = base->skip_depth + 1;
01341   else
01342     frame->skip_depth = 0;
01343 
01344   init_compile_data(frame);
01345 
01346   return frame;
01347 }
01348 
01349 Scheme_Comp_Env *scheme_new_comp_env(Scheme_Env *genv, Scheme_Object *insp, int flags)
01350 {
01351   Scheme_Comp_Env *e;
01352   Comp_Prefix *cp;
01353 
01354   if (!insp)
01355     insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
01356 
01357   e = (Scheme_Comp_Env *)MALLOC_ONE_RT(Scheme_Full_Comp_Env);
01358 #ifdef MZTAG_REQUIRED
01359   e->type = scheme_rt_comp_env;
01360 #endif
01361   e->num_bindings = 0;
01362   e->next = NULL;
01363   e->genv = genv;
01364   e->insp = insp;
01365   e->flags = flags;
01366   init_compile_data(e);
01367 
01368   cp = MALLOC_ONE_RT(Comp_Prefix);
01369 #ifdef MZTAG_REQUIRED
01370   cp->type = scheme_rt_comp_prefix;
01371 #endif
01372 
01373   e->prefix = cp;
01374 
01375   return e;
01376 }
01377 
01378 Scheme_Comp_Env *scheme_new_expand_env(Scheme_Env *genv, Scheme_Object *insp, int flags)
01379 {
01380   Scheme_Comp_Env *e;
01381 
01382   e = scheme_new_comp_env(genv, insp, flags);
01383   e->prefix = NULL;
01384 
01385   return e;
01386 }
01387 
01388 int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env)
01389 {
01390   Scheme_Comp_Env *se;
01391 
01392   for (se = stx_env; NOT_SAME_OBJ(se, env); se = se->next) {
01393     if (!(se->flags & SCHEME_FOR_INTDEF))
01394       break;
01395   }
01396   return SAME_OBJ(se, env);
01397 }
01398 
01399 int scheme_used_ever(Scheme_Comp_Env *env, int which)
01400 {
01401   Compile_Data *data = COMPILE_DATA(env);
01402 
01403   return !!data->use[which];
01404 }
01405 
01406 int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which)
01407 {
01408   Compile_Data *data = COMPILE_DATA(env);
01409 
01410   return !!(data->use[which] & WAS_SET_BANGED);
01411 }
01412 
01413 void
01414 scheme_add_compilation_binding(int index, Scheme_Object *val, Scheme_Comp_Env *frame)
01415 {
01416   if ((index >= frame->num_bindings) || (index < 0))
01417     scheme_signal_error("internal error: scheme_add_binding: "
01418                      "index out of range: %d", index);
01419   
01420   frame->values[index] = val;
01421   frame->skip_table = NULL;
01422 }
01423 
01424 void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data, 
01425                                  Scheme_Object *end_stmts, Scheme_Object *context_key, 
01426                                  Scheme_Object *requires, Scheme_Object *provides)
01427 {
01428   Scheme_Lift_Capture_Proc *pp;
01429   Scheme_Object *vec;
01430   
01431   pp = (Scheme_Lift_Capture_Proc *)scheme_malloc_atomic(sizeof(Scheme_Lift_Capture_Proc));
01432   *pp = cp;
01433 
01434   vec = scheme_make_vector(8, NULL);
01435   SCHEME_VEC_ELS(vec)[0] = scheme_null;
01436   SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)pp;
01437   SCHEME_VEC_ELS(vec)[2] = data;
01438   SCHEME_VEC_ELS(vec)[3] = end_stmts;
01439   SCHEME_VEC_ELS(vec)[4] = context_key;
01440   SCHEME_VEC_ELS(vec)[5] = (requires ? requires : scheme_false);
01441   SCHEME_VEC_ELS(vec)[6] = scheme_null; /* accumulated requires */
01442   SCHEME_VEC_ELS(vec)[7] = provides;
01443 
01444   COMPILE_DATA(env)->lifts = vec;
01445 }
01446 
01447 void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Comp_Env *env)
01448 {
01449   while (orig_env) {
01450     if ((COMPILE_DATA(orig_env)->lifts)
01451         && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(orig_env)->lifts)[5]))
01452       break;
01453     orig_env = orig_env->next;
01454   }
01455   
01456   if (orig_env) {
01457     Scheme_Object *vec, *p;
01458 
01459     p = scheme_make_raw_pair(NULL, (Scheme_Object *)orig_env);
01460 
01461     vec = scheme_make_vector(8, NULL);
01462     SCHEME_VEC_ELS(vec)[0] = scheme_false;
01463     SCHEME_VEC_ELS(vec)[1] = scheme_void;
01464     SCHEME_VEC_ELS(vec)[2] = scheme_void;
01465     SCHEME_VEC_ELS(vec)[3] = scheme_false;
01466     SCHEME_VEC_ELS(vec)[4] = scheme_false;
01467     SCHEME_VEC_ELS(vec)[5] = p; /* (rcons NULL env) => continue with env */
01468     SCHEME_VEC_ELS(vec)[6] = scheme_null;
01469     SCHEME_VEC_ELS(vec)[7] = scheme_false;
01470 
01471     COMPILE_DATA(env)->lifts = vec;
01472   }
01473 }
01474 
01475 Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env)
01476 {
01477   return scheme_reverse(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0]);
01478 }
01479 
01480 Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env)
01481 {
01482   return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3];
01483 }
01484 
01485 Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env)
01486 {
01487   return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6];
01488 }
01489 
01490 Scheme_Object *scheme_frame_get_provide_lifts(Scheme_Comp_Env *env)
01491 {
01492   return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7];
01493 }
01494 
01495 void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env)
01496 {
01497   Scheme_Object **ns, **vs;
01498   
01499   if (cnt) {
01500     ns = MALLOC_N(Scheme_Object *, cnt);
01501     vs = MALLOC_N(Scheme_Object *, cnt);
01502 
01503     COMPILE_DATA(env)->num_const = cnt;
01504     COMPILE_DATA(env)->const_names = ns;
01505     COMPILE_DATA(env)->const_vals = vs;
01506 
01507   }
01508 }
01509 
01510 void scheme_set_local_syntax(int pos,
01511                           Scheme_Object *name, Scheme_Object *val,
01512                           Scheme_Comp_Env *env)
01513 {
01514   COMPILE_DATA(env)->const_names[pos] = name;
01515   COMPILE_DATA(env)->const_vals[pos] = val;
01516   env->skip_table = NULL;
01517 }
01518 
01519 Scheme_Comp_Env *
01520 scheme_add_compilation_frame(Scheme_Object *vals, Scheme_Comp_Env *env, int flags, Scheme_Object *certs)
01521 {
01522   Scheme_Comp_Env *frame;
01523   int len, i, count;
01524   
01525   len = scheme_stx_list_length(vals);
01526   count = len;
01527 
01528   frame = scheme_new_compilation_frame(count, flags, env, certs);
01529 
01530   for (i = 0; i < len ; i++) {
01531     if (SCHEME_STX_SYMBOLP(vals))
01532       frame->values[i] = vals;
01533     else {
01534       Scheme_Object *a;
01535       a = SCHEME_STX_CAR(vals);
01536       frame->values[i] = a;
01537       vals = SCHEME_STX_CDR(vals);
01538     }
01539   }
01540   
01541   init_compile_data(frame);
01542 
01543   return frame;
01544 }
01545 
01546 Scheme_Comp_Env *scheme_no_defines(Scheme_Comp_Env *env)
01547 {
01548   if (scheme_is_toplevel(env)
01549       || scheme_is_module_env(env)
01550       || scheme_is_module_begin_env(env)
01551       || (env->flags & SCHEME_INTDEF_FRAME))
01552     return scheme_new_compilation_frame(0, 0, env, NULL);
01553   else
01554     return env;
01555 }
01556 
01557 Scheme_Comp_Env *scheme_require_renames(Scheme_Comp_Env *env)
01558 {
01559   if (env->flags & SCHEME_NO_RENAME) {
01560     env = scheme_new_compilation_frame(0, 0, env, NULL);
01561     env->flags -= SCHEME_NO_RENAME;
01562   }
01563 
01564   return env;
01565 }
01566 
01567 int scheme_is_toplevel(Scheme_Comp_Env *env)
01568 {
01569   return !env->next || (env->flags & SCHEME_TOPLEVEL_FRAME);
01570 }
01571 
01572 int scheme_is_module_env(Scheme_Comp_Env *env)
01573 {
01574   return !!(env->flags & SCHEME_MODULE_BEGIN_FRAME); /* name is backwards compared to symbol! */
01575 }
01576 
01577 int scheme_is_module_begin_env(Scheme_Comp_Env *env)
01578 {
01579   return !!(env->flags & SCHEME_MODULE_FRAME); /* name is backwards compared to symbol! */
01580 }
01581 
01582 Scheme_Comp_Env *scheme_extend_as_toplevel(Scheme_Comp_Env *env)
01583 {
01584   if (scheme_is_toplevel(env))
01585     return env;
01586   else
01587     return scheme_new_compilation_frame(0, SCHEME_TOPLEVEL_FRAME, env, NULL);
01588 }
01589 
01590 static Scheme_Object *make_toplevel(mzshort depth, int position, int resolved, int flags)
01591 {
01592   Scheme_Toplevel *tl;
01593   Scheme_Object *v, *pr;
01594 
01595   /* Important: non-resolved can't be cached, because the ISCONST
01596      field is modified to track mutated module-level variables. But
01597      the value for a specific toplevel is cached in the environment
01598      layer. */
01599 
01600   if (resolved) {
01601     if ((depth < MAX_CONST_TOPLEVEL_DEPTH)
01602        && (position < MAX_CONST_TOPLEVEL_POS))
01603       return toplevels[depth][position][flags];
01604 
01605     pr = (flags
01606          ? scheme_make_pair(scheme_make_integer(position),
01607                           scheme_make_integer(flags))
01608          : scheme_make_integer(position));
01609     pr = scheme_make_pair(scheme_make_integer(depth), pr);
01610     v = scheme_hash_get_atomic(toplevels_ht, pr);
01611     if (v)
01612       return v;
01613   } else
01614     pr = NULL;
01615 
01616   tl = (Scheme_Toplevel *)scheme_malloc_atomic_tagged(sizeof(Scheme_Toplevel));
01617   tl->iso.so.type = (resolved ? scheme_toplevel_type : scheme_compiled_toplevel_type);
01618   tl->depth = depth;
01619   tl->position = position;
01620   SCHEME_TOPLEVEL_FLAGS(tl) = flags;
01621 
01622   if (resolved) {
01623     if (toplevels_ht->count > TABLE_CACHE_MAX_SIZE) {
01624       toplevels_ht = scheme_make_hash_table_equal();
01625     }
01626     scheme_hash_set_atomic(toplevels_ht, pr, (Scheme_Object *)tl);
01627   }
01628 
01629   return (Scheme_Object *)tl;
01630 }
01631 
01632 Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env,
01633                                             Scheme_Compile_Info *rec, int drec)
01634 {
01635   Comp_Prefix *cp = env->prefix;
01636   Scheme_Hash_Table *ht;
01637   Scheme_Object *o;
01638 
01639   if (rec && rec[drec].dont_mark_local_use) {
01640     /* Make up anything; it's going to be ignored. */
01641     return make_toplevel(0, 0, 0, 0);
01642   }
01643 
01644   ht = cp->toplevels;
01645   if (!ht) {
01646     ht = scheme_make_hash_table(SCHEME_hash_ptr);
01647     cp->toplevels = ht;
01648   }
01649 
01650   o = scheme_hash_get(ht, var);
01651   if (o)
01652     return o;
01653 
01654   o = make_toplevel(0, cp->num_toplevels, 0, 0);
01655 
01656   cp->num_toplevels++;
01657   scheme_hash_set(ht, var, o);
01658 
01659   return o;
01660 }
01661 
01662 Scheme_Object *scheme_toplevel_to_flagged_toplevel(Scheme_Object *_tl, int flags)
01663 {
01664   Scheme_Toplevel *tl = (Scheme_Toplevel *)_tl;
01665   return make_toplevel(tl->depth, tl->position, 0, flags);
01666 }
01667 
01668 Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env, 
01669                                         Scheme_Compile_Info *rec, int drec)
01670 {
01671   Comp_Prefix *cp = env->prefix;
01672   Scheme_Local *l;
01673   Scheme_Object *o;
01674   int pos;
01675 
01676   if (rec && rec[drec].dont_mark_local_use) {
01677     /* Make up anything; it's going to be ignored. */
01678     l = (Scheme_Local *)scheme_malloc_atomic_tagged(sizeof(Scheme_Local));
01679     l->iso.so.type = scheme_compiled_quote_syntax_type;
01680     l->position = 0;
01681 
01682     return (Scheme_Object *)l;
01683   }
01684 
01685   if (!cp->stxes) {
01686     Scheme_Hash_Table *ht;
01687     ht = scheme_make_hash_table(SCHEME_hash_ptr);
01688     cp->stxes = ht;
01689   }
01690 
01691   pos = cp->num_stxes;
01692 
01693   l = (Scheme_Local *)scheme_malloc_atomic_tagged(sizeof(Scheme_Local));
01694   l->iso.so.type = scheme_compiled_quote_syntax_type;
01695   l->position = pos;
01696 
01697   cp->num_stxes++;
01698   o = (Scheme_Object *)l;
01699   
01700   scheme_hash_set(cp->stxes, var, o);
01701 
01702   return o;
01703 }
01704 
01705 /*========================================================================*/
01706 /*                     compile-time env, lookup bindings                  */
01707 /*========================================================================*/
01708 
01709 static Scheme_Object *alloc_local(short type, int pos)
01710 {
01711   Scheme_Object *v;
01712 
01713   v = (Scheme_Object *)scheme_malloc_atomic_tagged(sizeof(Scheme_Local));
01714   v->type = type;
01715   SCHEME_LOCAL_POS(v) = pos;
01716 
01717   return (Scheme_Object *)v;
01718 }
01719 
01720 Scheme_Object *scheme_make_local(Scheme_Type type, int pos, int flags)
01721 {
01722   int k;
01723   Scheme_Object *v, *key;
01724 
01725   k = type - scheme_local_type;
01726   
01727   /* Helper for reading bytecode: make sure flags is a valid value */
01728   switch (flags) {
01729   case 0:
01730   case SCHEME_LOCAL_CLEAR_ON_READ:
01731   case SCHEME_LOCAL_OTHER_CLEARS:
01732     break;
01733   default:
01734     flags  = SCHEME_LOCAL_OTHER_CLEARS;
01735     break;
01736   }
01737 
01738   if (pos < MAX_CONST_LOCAL_POS) {
01739     return scheme_local[pos][k][flags];
01740   }
01741 
01742   key = scheme_make_integer(pos);
01743   if (flags) {
01744     key = scheme_make_pair(scheme_make_integer(flags), key);
01745   }
01746 
01747   v = scheme_hash_get(locals_ht[k], key);
01748   if (v)
01749     return v;
01750 
01751   v = alloc_local(type, pos);
01752   SCHEME_LOCAL_FLAGS(v) = flags;
01753 
01754   if (locals_ht[k]->count > TABLE_CACHE_MAX_SIZE) {
01755     Scheme_Hash_Table *ht;
01756     ht = scheme_make_hash_table(SCHEME_hash_ptr);
01757     locals_ht[k] = ht;
01758   }
01759 
01760   scheme_hash_set(locals_ht[k], key, v);
01761 
01762   return v;
01763 }
01764 
01765 static Scheme_Object *force_lazy_macro(Scheme_Object *val, long phase)
01766 {
01767   Lazy_Macro_Fun f = (Lazy_Macro_Fun)SCHEME_PTR1_VAL(val);
01768   Scheme_Object *data = SCHEME_PTR2_VAL(val);
01769   return f(data, phase);
01770 }
01771 
01772 static Scheme_Local *get_frame_loc(Scheme_Comp_Env *frame,
01773                                int i, int j, int p, int flags)
01774 /* Generates a Scheme_Local record for a static distance coodinate, and also
01775    marks the variable as used for closures. */
01776 {
01777   int cnt, u;
01778 
01779   u = COMPILE_DATA(frame)->use[i];
01780   
01781   u |= (((flags & (SCHEME_APP_POS | SCHEME_SETTING | SCHEME_REFERENCING))
01782         ? CONSTRAINED_USE
01783         : ((u & (ARBITRARY_USE | ONE_ARBITRARY_USE)) ? ARBITRARY_USE : ONE_ARBITRARY_USE))
01784        | ((flags & (SCHEME_SETTING | SCHEME_REFERENCING | SCHEME_LINKING_REF))
01785           ? WAS_SET_BANGED
01786           : 0));
01787 
01788   cnt = ((u & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT);
01789   if (cnt < SCHEME_USE_COUNT_INF)
01790     cnt++;
01791   u -= (u & SCHEME_USE_COUNT_MASK);
01792   u |= (cnt << SCHEME_USE_COUNT_SHIFT);
01793   
01794   COMPILE_DATA(frame)->use[i] = u;
01795 
01796   return (Scheme_Local *)scheme_make_local(scheme_local_type, p + i, 0);
01797 }
01798 
01799 Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modidx, 
01800                                       Scheme_Object *stxsym, Scheme_Object *insp,
01801                                       int pos, int mod_phase)
01802 {
01803   Scheme_Object *val;
01804   Scheme_Hash_Table *ht;
01805 
01806   if (!env->modvars) {
01807     ht = scheme_make_hash_table(SCHEME_hash_ptr);
01808     env->modvars = ht;
01809   }
01810 
01811   stxsym = SCHEME_STX_SYM(stxsym);
01812 
01813   ht = (Scheme_Hash_Table *)scheme_hash_get(env->modvars, modidx);
01814 
01815   if (!ht) {
01816     ht = scheme_make_hash_table(SCHEME_hash_ptr);
01817     scheme_hash_set(env->modvars, modidx, (Scheme_Object *)ht);
01818   }
01819 
01820   /* Loop for inspector-specific hash table, maybe: */
01821   while (1) {
01822     
01823     val = scheme_hash_get(ht, stxsym);
01824     
01825     if (!val) {
01826       Module_Variable *mv;
01827       
01828       mv = MALLOC_ONE_TAGGED(Module_Variable);
01829       mv->so.type = scheme_module_variable_type;
01830       
01831       mv->modidx = modidx;
01832       mv->sym = stxsym;
01833       mv->insp = insp;
01834       mv->pos = pos;
01835       mv->mod_phase = mod_phase;
01836       
01837       val = (Scheme_Object *)mv;
01838       
01839       scheme_hash_set(ht, stxsym, val);
01840       
01841       break;
01842     } else {
01843       /* Check that inspector is the same. */
01844       Module_Variable *mv = (Module_Variable *)val;
01845       
01846       if (!SAME_OBJ(mv->insp, insp)) {
01847        /* Need binding for a different inspector. Try again. */
01848        val = scheme_hash_get(ht, insp);
01849        if (!val) {
01850          Scheme_Hash_Table *ht2;
01851          /* Make a table for this specific inspector */
01852          ht2 = scheme_make_hash_table(SCHEME_hash_ptr);
01853          scheme_hash_set(ht, insp, (Scheme_Object *)ht2);
01854          ht = ht2;
01855          /* loop... */
01856        } else
01857          ht = (Scheme_Hash_Table *)val;
01858       } else
01859        break;
01860     }
01861   }
01862 
01863   return val;
01864 }
01865 
01866 Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, 
01867                                 int mode, /* -1, 0 => lookup; 2, 3 => define
01868                                              -1 and 3 => use temp table
01869                                              1 would mean define if no match; not currently used */
01870                                 Scheme_Object *phase, int *_skipped)
01871 /* The `env' argument can actually be a hash table. */
01872 {
01873   Scheme_Object *marks = NULL, *sym, *map, *l, *a, *amarks, *m, *best_match, *cm, *abdg;
01874   int best_match_skipped, ms, one_mark;
01875   Scheme_Hash_Table *marked_names, *temp_marked_names, *dest_marked_names;
01876 
01877   sym = SCHEME_STX_SYM(id);
01878 
01879   if (_skipped)
01880     *_skipped = -1;
01881 
01882   if (SCHEME_HASHTP((Scheme_Object *)env)) {
01883     marked_names = (Scheme_Hash_Table *)env;
01884     temp_marked_names = NULL;
01885   } else {
01886     /* If there's no table and we're not defining, bail out fast */
01887     if ((mode <= 0) && !env->rename_set)
01888       return sym;
01889     marked_names = scheme_get_module_rename_marked_names(env->rename_set,
01890                                                          phase ? phase : scheme_make_integer(env->phase),
01891                                                          0);
01892     temp_marked_names = env->temp_marked_names;
01893   }
01894 
01895   if (mode > 0) {
01896     /* If we're defining, see if we need to create a table.  Getting
01897        marks is relatively expensive, but we only do this once per
01898        definition. */
01899     if (!bdg)
01900       bdg = scheme_stx_moduleless_env(id);
01901     marks = scheme_stx_extract_marks(id);
01902     if (SCHEME_NULLP(marks) && SCHEME_FALSEP(bdg))
01903       return sym;
01904   }
01905 
01906   if (!marked_names) {
01907     scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL);
01908     marked_names = scheme_get_module_rename_marked_names(env->rename_set,
01909                                                          phase ? phase : scheme_make_integer(env->phase),
01910                                                          1);
01911   }
01912   if (!temp_marked_names && (mode > 2)) {
01913     /* The "temp" marked name table is used to correlate marked module
01914        requires with similarly marked provides. We don't go through
01915        the normal rename table because (for efficiency) the marks in
01916        this case are handled more directly in the shared_pes module
01917        renamings. */
01918     temp_marked_names = scheme_make_hash_table(SCHEME_hash_ptr);
01919     env->temp_marked_names = temp_marked_names;
01920   }
01921   
01922   map = scheme_hash_get(marked_names, sym);
01923   if (!map && ((mode < 0) || (mode > 2)) && temp_marked_names)
01924     map = scheme_hash_get(temp_marked_names, sym);
01925 
01926   if (!map) {
01927     /* If we're not defining, we can bail out before extracting marks. */
01928     if (mode <= 0)
01929       return sym;
01930     else
01931       map = scheme_null;
01932   }
01933 
01934   if (!bdg) {
01935     /* We need lexical binding, if any, too: */
01936     bdg = scheme_stx_moduleless_env(id);
01937   }
01938 
01939   if (!marks) {
01940     /* We really do need the marks. Get them. */
01941     marks = scheme_stx_extract_marks(id);
01942     if (SCHEME_NULLP(marks) && SCHEME_FALSEP(bdg))
01943       return sym;
01944   }
01945 
01946   best_match = NULL;
01947   best_match_skipped = scheme_list_length(marks);
01948   if (best_match_skipped == 1) {
01949     /* A mark list of length 1 is the common case.
01950        Since the list is otherwise marshaled into .zo, etc.,
01951        simplify by extracting just the mark: */
01952     marks = SCHEME_CAR(marks);
01953     one_mark = 1;
01954   } else
01955     one_mark = 0;
01956 
01957   if (!SCHEME_TRUEP(bdg))
01958     bdg = NULL;
01959 
01960   /* Find a mapping that matches the longest tail of marks */
01961   for (l = map; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
01962     a = SCHEME_CAR(l);
01963     amarks = SCHEME_CAR(a);
01964 
01965     if (SCHEME_VECTORP(amarks)) {
01966       abdg = SCHEME_VEC_ELS(amarks)[1];
01967       amarks = SCHEME_VEC_ELS(amarks)[0];
01968     } else
01969       abdg = NULL;
01970 
01971     if (SAME_OBJ(abdg, bdg)) {
01972       if (mode > 0) {
01973        if (scheme_equal(amarks, marks)) {
01974          best_match = SCHEME_CDR(a);
01975          break;
01976        }
01977       } else {
01978         if (!SCHEME_PAIRP(marks)) {
01979          /* To be better than nothing, could only match exactly: */
01980          if (scheme_equal(amarks, marks)
01981               || SCHEME_NULLP(amarks)) {
01982            best_match = SCHEME_CDR(a);
01983            best_match_skipped = 0;
01984          }
01985        } else {
01986          /* amarks can match a tail of marks: */
01987          for (m = marks, ms = 0; 
01988               SCHEME_PAIRP(m) && (ms < best_match_skipped);
01989               m = SCHEME_CDR(m), ms++) {
01990 
01991            cm = m;
01992            if (!SCHEME_PAIRP(amarks)) {
01993              /* If we're down to the last element
01994                of marks, then extract it to try to
01995                match the symbol amarks. */
01996              if (SCHEME_NULLP(SCHEME_CDR(m)))
01997               cm = SCHEME_CAR(m);
01998            }
01999   
02000            if (scheme_equal(amarks, cm)) {
02001              best_match = SCHEME_CDR(a);
02002              best_match_skipped = ms;
02003              break;
02004            }
02005          }
02006        }
02007       }
02008     }
02009   }
02010 
02011   if (!best_match) {
02012     if (mode <= 0) {
02013       return sym;
02014     }
02015 
02016     /* Last chance before making up a new name. If we're processing a
02017        module body generated by `expand', then we picked a name last
02018        time around. We can't pick a new name now, otherwise
02019        "redundant" module renamings wouldn't be redundant. (See
02020        simpify in stxobj.c.) So check for a context-determined
02021        existing rename. */
02022     if (!SCHEME_HASHTP((Scheme_Object *)env) && env->module && (mode < 2)) {
02023       Scheme_Object *mod, *nm = id;
02024       mod = scheme_stx_module_name(NULL, &nm, scheme_make_integer(env->phase), NULL, NULL, NULL, 
02025                                    NULL, NULL, NULL, NULL, NULL);
02026       if (mod /* must refer to env->module, otherwise there would
02027                have been an error before getting here */
02028          && NOT_SAME_OBJ(nm, sym))
02029        /* It has a rename already! */
02030        best_match = nm;
02031     }
02032 
02033     /* Adding a definition. We "gensym" here in a sense; actually, we
02034        use a symbol table that's in parallel to the normal table, so
02035        that we get the same parallel-symbol when unmarshalling
02036        code. We use a counter attached to the environment. Normally,
02037        this counter just increments, but if a module is re-expanded,
02038        then the counter starts at 0 for the re-expand, and we may
02039        re-pick an existing name. To avoid re-picking the same name,
02040        double-check for a mapping in the environment by inspecting the
02041        renames attached to id. In the top-level environment, it's
02042        still possible to get a collision, because separately compiled
02043        code might be loaded into the same environment (which is just
02044        too bad). */
02045     if (!best_match) {
02046       char onstack[50], *buf;
02047       int len;
02048 
02049       while (1) {
02050        env->id_counter++;
02051        len = SCHEME_SYM_LEN(sym);
02052        if (len <= 35)
02053          buf = onstack;
02054        else
02055          buf = scheme_malloc_atomic(len + 15);
02056        memcpy(buf, SCHEME_SYM_VAL(sym), len);
02057        
02058        /* The dot here is significant; it might gets stripped away when
02059           printing the symbol */
02060        sprintf(buf + len, ".%d", env->id_counter);
02061        
02062        best_match = scheme_intern_exact_parallel_symbol(buf, strlen(buf));
02063 
02064        if (!scheme_stx_parallel_is_used(best_match, id)) {
02065          /* Also check environment's rename tables. This last check
02066             includes the temp table. It also turns out to matter for
02067             compiling in `module->namespace' contexts, because no
02068             renaming is added after expansion to record the rename
02069             table. */
02070          if (!scheme_tl_id_is_sym_used(marked_names, best_match)
02071               && (!temp_marked_names
02072                   || !scheme_tl_id_is_sym_used(temp_marked_names, best_match))) {
02073            /* Ok, no matches, so this name is fine. */
02074            break;
02075          }
02076        }
02077 
02078        /* Otherwise, increment counter and try again... */
02079       }
02080     }
02081     if (bdg) {
02082       a = scheme_make_vector(2, NULL);
02083       SCHEME_VEC_ELS(a)[0] = marks;
02084       SCHEME_VEC_ELS(a)[1] = bdg;
02085       marks = a;
02086     }
02087     a = scheme_make_pair(marks, best_match);
02088     map = scheme_make_pair(a, map);
02089     
02090     dest_marked_names = ((mode < 0) || (mode > 2)) ? temp_marked_names : marked_names;
02091     scheme_hash_set(dest_marked_names, sym, map);
02092     {
02093       Scheme_Hash_Table *rev_ht;
02094       rev_ht = (Scheme_Hash_Table *)scheme_hash_get(dest_marked_names, scheme_false);
02095       if (rev_ht) {
02096         scheme_hash_set(rev_ht, best_match, scheme_true);
02097       }
02098     }
02099   } else {
02100     if (_skipped)
02101       *_skipped = best_match_skipped;
02102   }
02103 
02104   return best_match;
02105 }
02106 
02107 int scheme_tl_id_is_sym_used(Scheme_Hash_Table *marked_names, Scheme_Object *sym)
02108 {
02109   int i;
02110   Scheme_Object *l, *a;
02111   Scheme_Hash_Table *rev_ht;
02112 
02113   if (!marked_names)
02114     return 0;
02115 
02116   if (!marked_names->count)
02117     return 0;
02118 
02119   rev_ht = (Scheme_Hash_Table *)scheme_hash_get(marked_names, scheme_false);
02120 
02121   if (!rev_ht) {
02122     rev_ht = scheme_make_hash_table(SCHEME_hash_ptr);
02123 
02124     for (i = marked_names->size; i--; ) {
02125       l = marked_names->vals[i];
02126       if (l) {
02127         for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
02128           a = SCHEME_CAR(l);
02129           scheme_hash_set(rev_ht, SCHEME_CDR(a), scheme_true);
02130         }
02131       }
02132       scheme_hash_set(marked_names, scheme_false, (Scheme_Object *)rev_ht);
02133     }
02134   }
02135 
02136   if (scheme_hash_get(rev_ht, sym))
02137     return 1;
02138 
02139   return 0;
02140 }
02141 
02142 static Scheme_Object *make_uid()
02143 {
02144   char name[20];
02145 
02146   sprintf(name, "env%d", env_uid_counter++);
02147   return scheme_make_symbol(name); /* uninterned! */
02148 }
02149 
02150 Scheme_Object *scheme_env_frame_uid(Scheme_Comp_Env *env)
02151 {
02152   if (env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME | SCHEME_CAPTURE_LIFTED))
02153     return NULL;
02154 
02155   if (!env->uid) {
02156     Scheme_Object *sym;
02157     sym = make_uid();
02158     env->uid = sym;
02159   }
02160   return env->uid;
02161 }
02162 
02163 static void make_env_renames(Scheme_Comp_Env *env, int rcount, int rstart, int rstart_sec, int force_multi,
02164                           Scheme_Object *stx)
02165 {
02166   Scheme_Object *rnm;
02167   Scheme_Object *uid = NULL;
02168   int i, pos;
02169 
02170   if (env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME | SCHEME_CAPTURE_LIFTED))
02171     return;
02172 
02173   scheme_env_frame_uid(env);
02174 
02175   if (force_multi) {
02176     if (env->num_bindings && !env->uids) {
02177       Scheme_Object **uids;
02178       uids = MALLOC_N(Scheme_Object *, env->num_bindings);
02179       env->uids = uids;
02180     }
02181     if (COMPILE_DATA(env)->num_const && !COMPILE_DATA(env)->const_uids) {
02182       Scheme_Object **cuids;
02183       cuids = MALLOC_N(Scheme_Object *, COMPILE_DATA(env)->num_const);
02184       COMPILE_DATA(env)->const_uids = cuids;
02185     }
02186     if (env->uid && !SCHEME_FALSEP(env->uid)) {
02187       uid = env->uid;
02188       env->uid = scheme_false;
02189     }
02190   }
02191 
02192   if (!uid) {
02193     if (env->uid && SCHEME_TRUEP(env->uid)) {
02194       /* single-uid mode (at least for now) */
02195       uid = env->uid;
02196     } else {
02197       /* multi-uid mode */
02198       if (!rstart_sec)
02199        uid = COMPILE_DATA(env)->const_uids[rstart];
02200       else
02201        uid = env->uids[rstart];
02202       if (!uid)
02203        uid = make_uid();
02204     }
02205   }
02206   
02207   rnm = scheme_make_rename(uid, rcount);
02208   pos = 0;
02209 
02210   if (!rstart_sec) {
02211     for (i = rstart; (i < COMPILE_DATA(env)->num_const) && (pos < rcount); i++, pos++) {
02212       if (COMPILE_DATA(env)->const_uids)
02213        COMPILE_DATA(env)->const_uids[i] = uid;
02214       scheme_set_rename(rnm, pos, COMPILE_DATA(env)->const_names[i]);
02215     }
02216     rstart = 0;
02217   }
02218   for (i = rstart; pos < rcount; i++, pos++) {
02219     if (env->uids)
02220       env->uids[i] = uid;
02221     scheme_set_rename(rnm, pos, env->values[i]);
02222   }
02223 
02224   if (SCHEME_RIBP(stx))
02225     scheme_add_rib_rename(stx, rnm);
02226   
02227   if (env->renames) {
02228     if (SCHEME_PAIRP(env->renames) || SCHEME_NULLP(env->renames))
02229       rnm = scheme_make_pair(rnm, env->renames);
02230     else
02231       rnm = scheme_make_pair(rnm, scheme_make_pair(env->renames, scheme_null));
02232   }
02233   env->renames = rnm;
02234 }
02235 
02236 Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env, 
02237                                   Scheme_Comp_Env *upto)
02238 {
02239   if (!SCHEME_STXP(stx) && !SCHEME_RIBP(stx)) {
02240     scheme_signal_error("internal error: not syntax or rib");
02241     return NULL;
02242   }
02243 
02244   if (SCHEME_RIBP(stx)) {
02245     GC_CAN_IGNORE int *s;
02246     s = scheme_stx_get_rib_sealed(stx);
02247     COMPILE_DATA(env)->sealed = s;
02248   }
02249 
02250   while (env != upto) {
02251     if (!(env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME 
02252                         | SCHEME_CAPTURE_LIFTED | SCHEME_INTDEF_SHADOW))) {
02253       int i, count;
02254       
02255       /* How many slots filled in the frame so far?  This can change
02256         due to the style of let* compilation, which generates a
02257         rename record after each binding set. The "const" bindings
02258         are always all in place before we generate any renames in
02259         that case. However, the "const" bindings can grow by
02260         themselves before non-const bindings are installed. */
02261       count = COMPILE_DATA(env)->num_const;
02262       for (i = env->num_bindings; i--; ) {
02263        if (env->values[i])
02264          count++;
02265       }
02266       
02267       if (count) {
02268        Scheme_Object *l;
02269 
02270        if (!env->renames || (env->rename_var_count != count)) {
02271          /* Need to create lexical renaming record(s). We create
02272             multiple records as necessary to avoid uids that contain
02273             more than one variable with the same symbol name.
02274 
02275             This is complicated, because we don't want to allocate a
02276             hash table in the common case of a binding set with a few
02277             names. It's also complicated by incremental rename
02278             building: if env->rename_var_count is not zero, we've
02279             done this before for a subset of `values' (and there are
02280             no consts in that case). In the incremental case, we have
02281             a dup_check hash table left from the previous round. */
02282          Scheme_Hash_Table *ht;
02283          Scheme_Object *name;
02284          int rcount = 0, rstart, rstart_sec = 0, vstart;
02285          
02286          /* rstart is where the to-be-created rename table starts
02287             (saved from last time around, or initially zero).
02288             vstart is where we start looking for new dups.
02289             rstart_sec is TRUE when the new frame starts in the
02290             non-constant area. */
02291          rstart = env->rename_rstart;
02292          if (env->renames) {
02293            /* Incremental mode. Drop the most recent (first) rename
02294                table, because we'll recreate it: */
02295            if (SCHEME_PAIRP(env->renames))
02296              env->renames = SCHEME_CDR(env->renames);
02297            else
02298              env->renames = NULL;
02299            if (SCHEME_RIBP(stx))
02300              scheme_drop_first_rib_rename(stx);
02301            vstart = env->rename_var_count;
02302            rstart_sec = 1;
02303            /* We already know that the first rcount
02304               are distinct (from the last iteration) */
02305            rcount = vstart - rstart;
02306          } else
02307            vstart = 0;
02308 
02309          /* Create or find the hash table: */
02310          if (env->dup_check)
02311            ht = env->dup_check;
02312          else if (env->num_bindings + COMPILE_DATA(env)->num_const > 10)
02313            ht = scheme_make_hash_table(SCHEME_hash_ptr);
02314          else
02315            ht = NULL;
02316 
02317          if (rcount > 16) {
02318            /* Instead of n^2 growth for the rename, just close the current
02319               one off and start fresh. */
02320            make_env_renames(env, rcount, rstart, rstart_sec, 1, stx);
02321            rcount = 0;
02322            rstart = vstart;
02323            rstart_sec = 1;
02324            if (ht) {
02325              /* Flush the table for a new set: */
02326              ht = scheme_make_hash_table(SCHEME_hash_ptr);
02327            }
02328          }
02329          
02330          /* Check for dups among the statics, and build a rename for
02331              each dup-free set. */
02332 
02333          /* First: constants. */
02334          if (!rstart_sec) {
02335            if (COMPILE_DATA(env)->num_const) {
02336              /* Start at the beginning, always. */
02337              for (i = 0; i < COMPILE_DATA(env)->num_const; i++) {
02338               int found = 0;
02339               name = SCHEME_STX_VAL(COMPILE_DATA(env)->const_names[i]);
02340               if (ht) {
02341                 if (scheme_hash_get(ht, name))
02342                   found = 1;
02343                 else
02344                   scheme_hash_set(ht, name, scheme_true);
02345               } else {
02346                 int j;
02347                 for (j = rstart; j < i; j++) {
02348                   if (SAME_OBJ(name, SCHEME_STX_VAL(COMPILE_DATA(env)->const_names[j]))) {
02349                     found = 1;
02350                     break;
02351                   }
02352                 }
02353               }
02354 
02355               if (found) {
02356                 make_env_renames(env, rcount, rstart, rstart_sec, 1, stx);
02357                 rcount = 1;
02358                 rstart = i;
02359                 if (ht) {
02360                   /* Flush the table for a new set: */
02361                   ht = scheme_make_hash_table(SCHEME_hash_ptr);
02362                   scheme_hash_set(ht, name, scheme_true);
02363                 }
02364               } else
02365                 rcount++;
02366              }
02367            } else 
02368              rstart_sec = 1;
02369          }
02370 
02371          for (i = vstart; (i < env->num_bindings) && env->values[i]; i++) {
02372            int found = 0;
02373            name = SCHEME_STX_VAL(env->values[i]);
02374 
02375            if (ht) {
02376              if (scheme_hash_get(ht, name))
02377               found = 1;
02378              else
02379               scheme_hash_set(ht, name, scheme_true);
02380            } else {
02381              int j;
02382              if (!rstart_sec) {
02383               /* Look in consts, first: */
02384               for (j = rstart; j < COMPILE_DATA(env)->num_const; j++) {
02385                 if (SAME_OBJ(name, SCHEME_STX_VAL(COMPILE_DATA(env)->const_names[j]))) {
02386                   found = 1;
02387                   break;
02388                 }
02389               }
02390 
02391               j = 0;
02392              } else
02393               j = rstart;
02394 
02395              if (!found) {
02396               for (; j < i; j++) {
02397                 if (SAME_OBJ(name, SCHEME_STX_VAL(env->values[j]))) {
02398                   found = 1;
02399                   break;
02400                 }
02401               }
02402              }
02403            }
02404 
02405            if (found) {
02406              make_env_renames(env, rcount, rstart, rstart_sec, 1, stx);
02407              rcount = 1;
02408              rstart = i;
02409              rstart_sec = 1;
02410              if (ht) {
02411               /* Flush the table for a new set: */
02412               ht = scheme_make_hash_table(SCHEME_hash_ptr);
02413               scheme_hash_set(ht, name, scheme_true);
02414              }
02415            } else
02416              rcount++;
02417          }
02418          
02419          make_env_renames(env, rcount, rstart, rstart_sec, 0, stx);
02420 
02421          env->rename_var_count = count;
02422          env->rename_rstart = rstart;
02423          if (count < env->num_bindings) {
02424            /* save for next time around: */
02425            env->dup_check = ht;
02426          } else { 
02427            /* drop a saved table if there; we're done with all increments */
02428            env->dup_check = NULL;
02429          }
02430        }
02431 
02432        if (SCHEME_STXP(stx)) {
02433          for (l = env->renames; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
02434            stx = scheme_add_rename(stx, SCHEME_CAR(l));
02435          }
02436          if (!SCHEME_NULLP(l))
02437            stx = scheme_add_rename(stx, l);
02438        }
02439       }
02440     } else if (env->flags & SCHEME_INTDEF_SHADOW) {
02441       /* Just extract existing uids from identifiers, and don't need to
02442          add renames to syntax objects. */
02443       if (!env->uids) {
02444         Scheme_Object **uids, *uid;
02445         int i;
02446         
02447         uids = MALLOC_N(Scheme_Object *, env->num_bindings);
02448         env->uids = uids;
02449         
02450         for (i = env->num_bindings; i--; ) {
02451           uid = scheme_stx_moduleless_env(env->values[i]);
02452           if (SCHEME_FALSEP(uid))
02453             scheme_signal_error("intdef shadow binding is #f for %d/%s",
02454                                 SCHEME_TYPE(env->values[i]),
02455                                 scheme_write_to_string(SCHEME_STX_VAL(env->values[i]), 
02456                                                        NULL));
02457           env->uids[i] = uid;
02458         }
02459       }
02460     }
02461 
02462     env = env->next;
02463   }
02464 
02465   return stx;
02466 }
02467 
02468 void scheme_seal_env_renames(Scheme_Comp_Env *env)
02469 {
02470   env->dup_check = NULL;
02471 }
02472 
02473 /*********************************************************************/
02474 
02475 void create_skip_table(Scheme_Comp_Env *start_frame)
02476 {
02477   Scheme_Comp_Env *end_frame, *frame;
02478   int depth, dj = 0, dp = 0, i;
02479   Scheme_Hash_Table *table;
02480   int stride = 0;
02481 
02482   depth = start_frame->skip_depth;
02483 
02484   /* Find frames to be covered by the skip table.
02485      The theory here is the same as the `mapped' table
02486      in Scheme_Cert (see stxobj.c) */
02487   for (end_frame = start_frame->next;
02488        end_frame && ((depth & end_frame->skip_depth) != end_frame->skip_depth);
02489        end_frame = end_frame->next) {
02490     stride++;
02491   }
02492 
02493   table = scheme_make_hash_table(SCHEME_hash_ptr);
02494   
02495   for (frame = start_frame; frame != end_frame; frame = frame->next) {
02496     if (frame->flags & SCHEME_LAMBDA_FRAME)
02497       dj++;
02498     dp += frame->num_bindings;
02499     for (i = frame->num_bindings; i--; ) {
02500       if (frame->values[i]) {
02501        scheme_hash_set(table, SCHEME_STX_VAL(frame->values[i]), scheme_true);
02502       }
02503     }
02504     for (i = COMPILE_DATA(frame)->num_const; i--; ) {
02505       scheme_hash_set(table, SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i]), scheme_true);
02506     }
02507   }
02508 
02509   scheme_hash_set(table, scheme_make_integer(0), (Scheme_Object *)end_frame);
02510   scheme_hash_set(table, scheme_make_integer(1), scheme_make_integer(dj));
02511   scheme_hash_set(table, scheme_make_integer(2), scheme_make_integer(dp));
02512 
02513   start_frame->skip_table = table;
02514 }
02515 
02516 /*********************************************************************/
02517 /* 
02518 
02519    scheme_lookup_binding() is the main resolver of lexical, module,
02520    and top-level bindings. Depending on the value of `flags', it can
02521    return a value whose type tag is:
02522 
02523      scheme_macro_type (id was bound to syntax),
02524 
02525      scheme_macro_set_type (id was bound to a set!-transformer),
02526 
02527      scheme_macro_id_type (id was bound to a rename-transformer),
02528 
02529      scheme_local_type (id was lexical),
02530 
02531      scheme_variable_type (id is a global or module-bound variable),
02532      or
02533 
02534      scheme_module_variable_type (id is a module-bound variable).
02535 
02536 */
02537 
02538 Scheme_Object *
02539 scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
02540                     Scheme_Object *certs, Scheme_Object *in_modidx,
02541                     Scheme_Env **_menv, int *_protected,
02542                       Scheme_Object **_lexical_binding_id)
02543 {
02544   Scheme_Comp_Env *frame;
02545   int j = 0, p = 0, modpos, skip_stops = 0, module_self_reference = 0;
02546   Scheme_Bucket *b;
02547   Scheme_Object *val, *modidx, *modname, *src_find_id, *find_global_id, *mod_defn_phase;
02548   Scheme_Object *find_id_sym = NULL, *rename_insp = NULL;
02549   Scheme_Env *genv;
02550   long phase;
02551 
02552   /* Need to know the phase being compiled */
02553   phase = env->genv->phase;
02554 
02555   /* Walk through the compilation frames */
02556   for (frame = env; frame->next != NULL; frame = frame->next) {
02557     int i;
02558     Scheme_Object *uid;
02559 
02560     while (1) {
02561       if (frame->skip_table) {
02562        if (!scheme_hash_get(frame->skip_table, SCHEME_STX_VAL(find_id))) {
02563          /* Skip ahead. 0 maps to frame, 1 maps to j delta, and 2 maps to p delta */
02564          val = scheme_hash_get(frame->skip_table, scheme_make_integer(1));
02565          j += SCHEME_INT_VAL(val);
02566          val = scheme_hash_get(frame->skip_table, scheme_make_integer(2));
02567          p += SCHEME_INT_VAL(val);
02568          frame = (Scheme_Comp_Env *)scheme_hash_get(frame->skip_table, scheme_make_integer(0));
02569        } else
02570          break;
02571       } else if (frame->skip_depth && !(frame->skip_depth & 0x1F)) {
02572        /* We're some multiple of 32 frames deep. Build a skip table and try again. */
02573        create_skip_table(frame);
02574       } else
02575        break;
02576     }
02577     
02578     if (frame->flags & SCHEME_LAMBDA_FRAME)
02579       j++;
02580 
02581     if (!skip_stops || !(frame->flags & SCHEME_FOR_STOPS)) {
02582       if (frame->flags & SCHEME_FOR_STOPS)
02583        skip_stops = 1;
02584 
02585       uid = scheme_env_frame_uid(frame);
02586 
02587       if (!find_id_sym 
02588           && (frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME))
02589         find_id_sym = scheme_stx_get_module_eq_sym(find_id, scheme_make_integer(phase));
02590 
02591       for (i = frame->num_bindings; i--; ) {
02592        if (frame->values[i]) {
02593          if (frame->uids) 
02594            uid = frame->uids[i];
02595           if (SAME_OBJ(SCHEME_STX_VAL(find_id), SCHEME_STX_VAL(frame->values[i]))
02596              && (scheme_stx_env_bound_eq(find_id, frame->values[i], uid, scheme_make_integer(phase))
02597                 || ((frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)
02598                     && scheme_stx_module_eq2(find_id, frame->values[i], scheme_make_integer(phase), find_id_sym))
02599                 || ((frame->flags & SCHEME_CAPTURE_LIFTED)
02600                     && scheme_stx_bound_eq(find_id, frame->values[i], scheme_make_integer(phase))))) {
02601            /* Found a lambda-, let-, etc. bound variable: */
02602            /* First, check certs (don't bind with fewer certs): */
02603            if (!(flags & SCHEME_NO_CERT_CHECKS) 
02604               && !(frame->flags & (SCHEME_CAPTURE_WITHOUT_RENAME | SCHEME_CAPTURE_LIFTED))) {
02605              if (scheme_stx_has_more_certs(find_id, certs, frame->values[i], frame->certs)) {
02606               scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id,
02607                                 "reference is more certified than binding");
02608               return NULL;
02609              }
02610            }
02611            /* Looks ok; return a lexical reference */
02612             if (_lexical_binding_id) {
02613               if (!(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME))
02614                 val = scheme_stx_remove_extra_marks(find_id, frame->values[i],
02615                                                     ((frame->flags & SCHEME_CAPTURE_LIFTED)
02616                                                      ? NULL
02617                                                      : uid));
02618               else
02619                 val = find_id;
02620               *_lexical_binding_id = val;
02621             }
02622            if (flags & SCHEME_DONT_MARK_USE)
02623              return scheme_make_local(scheme_local_type, 0, 0);
02624            else
02625              return (Scheme_Object *)get_frame_loc(frame, i, j, p, flags);
02626          }
02627        }
02628       }
02629 
02630       for (i = COMPILE_DATA(frame)->num_const; i--; ) {
02631        int issame;
02632        if (frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)
02633          issame = scheme_stx_module_eq2(find_id, COMPILE_DATA(frame)->const_names[i], 
02634                                          scheme_make_integer(phase), find_id_sym);
02635         else {
02636          if (COMPILE_DATA(frame)->const_uids) uid = COMPILE_DATA(frame)->const_uids[i];
02637          issame = (SAME_OBJ(SCHEME_STX_VAL(find_id), 
02638                           SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i]))
02639                   && scheme_stx_env_bound_eq(find_id, COMPILE_DATA(frame)->const_names[i], uid, 
02640                                                scheme_make_integer(phase)));
02641        }
02642       
02643        if (issame) {
02644          if (!(flags & SCHEME_NO_CERT_CHECKS) 
02645              && !(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) {
02646            if (scheme_stx_has_more_certs(find_id, certs, COMPILE_DATA(frame)->const_names[i], frame->certs)) {
02647              scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id,
02648                               "reference is more certified than binding");
02649              return NULL;
02650            }
02651          }
02652 
02653           if (_lexical_binding_id) {
02654             if (!(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME))
02655               val = scheme_stx_remove_extra_marks(find_id, COMPILE_DATA(frame)->const_names[i],
02656                                                   ((frame->flags & SCHEME_CAPTURE_LIFTED)
02657                                                    ? NULL
02658                                                    : uid));
02659             else
02660               val = find_id;
02661             *_lexical_binding_id = val;
02662           }
02663 
02664          val = COMPILE_DATA(frame)->const_vals[i];
02665        
02666          if (!val) {
02667             scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id,
02668                                 "identifier used out of context");
02669            return NULL;
02670          }
02671 
02672          if (SCHEME_FALSEP(val)) {
02673            /* Corresponds to a run-time binding (but will be replaced later
02674               through a renaming to a different binding) */
02675             if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL)
02676               return scheme_make_local(scheme_local_type, 0, 0);
02677             return NULL;
02678          }
02679 
02680          if (!(flags & SCHEME_ENV_CONSTANTS_OK)) {
02681            if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type))
02682              return val;
02683            else if (SAME_TYPE(SCHEME_TYPE(val), scheme_lazy_macro_type))
02684              return force_lazy_macro(val, phase);
02685            else
02686              scheme_wrong_syntax(scheme_set_stx_string, NULL, find_id,
02687                               "local syntax identifier cannot be mutated");
02688            return NULL;
02689          }
02690 
02691          return val;
02692        }
02693       }
02694     }
02695 
02696     p += frame->num_bindings;
02697   }
02698 
02699   src_find_id = find_id;
02700   modidx = scheme_stx_module_name(NULL, &find_id, scheme_make_integer(phase), NULL, NULL, &mod_defn_phase, 
02701                                   NULL, NULL, NULL, NULL, &rename_insp);
02702 
02703   /* Used out of context? */
02704   if (SAME_OBJ(modidx, scheme_undefined)) {
02705     if (SCHEME_STXP(find_id)) {
02706       /* Looks like lexically bound, but double-check that it's not bound via a tl_id: */
02707       find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL, NULL);
02708       if (!SAME_OBJ(find_global_id, SCHEME_STX_VAL(find_id)))
02709         modidx = NULL; /* yes, it is bound */
02710     }
02711     
02712     if (modidx) {
02713       if (!(flags & SCHEME_OUT_OF_CONTEXT_OK)) {
02714         scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id,
02715                             "identifier used out of context");
02716       }
02717       if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL)
02718         return scheme_make_local(scheme_local_type, 0, 0);
02719       return NULL;
02720     }
02721   }
02722 
02723   if (modidx) {
02724     /* If it's an access path, resolve it: */
02725     modname = scheme_module_resolve(modidx, 1);
02726 
02727     if (env->genv->module && SAME_OBJ(modname, env->genv->module->modname)) {
02728       modidx = NULL;
02729       modname = NULL;
02730       genv = env->genv;
02731       /* So we can distinguish between unbound identifiers in a module
02732         and references to top-level definitions: */
02733       module_self_reference = 1;
02734     } else {
02735       genv = scheme_module_access(modname, env->genv, SCHEME_INT_VAL(mod_defn_phase));
02736 
02737       if (!genv) {
02738        if (env->genv->phase) {
02739          /* The failure might be due a laziness in required-syntax
02740             execution. Force all laziness at the prior level 
02741             and try again. */
02742          scheme_module_force_lazy(env->genv, 1);
02743          genv = scheme_module_access(modname, env->genv, SCHEME_INT_VAL(mod_defn_phase));
02744        }
02745 
02746        if (!genv) {
02747          scheme_wrong_syntax("require", NULL, src_find_id, 
02748                               "namespace mismatch; reference (phase %d) to a module"
02749                               " %D that is not available (phase level %d)", 
02750                            env->genv->phase, modname, SCHEME_INT_VAL(mod_defn_phase));
02751          return NULL;
02752        }
02753       }
02754     }
02755   } else {
02756     genv = env->genv;
02757     modname = NULL;
02758 
02759     if (genv->module && genv->disallow_unbound) {
02760       /* Free identifier. Maybe don't continue. */
02761       if (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) {
02762         scheme_wrong_syntax(((flags & SCHEME_SETTING) 
02763                           ? scheme_set_stx_string
02764                           : scheme_var_ref_string),
02765                          NULL, src_find_id, "unbound identifier in module");
02766        return NULL;
02767       }
02768       if (flags & SCHEME_NULL_FOR_UNBOUND)
02769        return NULL;
02770     }
02771   }
02772 
02773   if (_menv && genv->module)
02774     *_menv = genv;
02775   
02776   if (!modname && SCHEME_STXP(find_id))
02777     find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL, NULL);
02778   else
02779     find_global_id = find_id;
02780 
02781   /* Try syntax table: */
02782   if (modname) {
02783     val = scheme_module_syntax(modname, env->genv, find_id);
02784     if (val && !(flags & SCHEME_NO_CERT_CHECKS))
02785       scheme_check_accessible_in_module(genv, env->insp, in_modidx, 
02786                                    find_id, src_find_id, certs, NULL, rename_insp,
02787                                         -2, 0, 
02788                                    NULL, NULL,
02789                                         env->genv, NULL);
02790   } else {
02791     /* Only try syntax table if there's not an explicit (later)
02792        variable mapping: */
02793     if (genv->shadowed_syntax 
02794        && scheme_hash_get(genv->shadowed_syntax, find_global_id))
02795       val = NULL;
02796     else
02797       val = scheme_lookup_in_table(genv->syntax, (const char *)find_global_id);
02798   }
02799   
02800   if (val) {
02801     if (SAME_TYPE(SCHEME_TYPE(val), scheme_lazy_macro_type))
02802       return force_lazy_macro(val, phase);
02803     return val;
02804   }
02805 
02806   if (modname) {
02807     Scheme_Object *pos;
02808     if (flags & SCHEME_NO_CERT_CHECKS) 
02809       pos = 0;
02810     else
02811       pos = scheme_check_accessible_in_module(genv, env->insp, in_modidx, 
02812                                          find_id, src_find_id, certs, NULL, rename_insp, -1, 1,
02813                                          _protected, NULL, env->genv, NULL);
02814     modpos = SCHEME_INT_VAL(pos);
02815   } else
02816     modpos = -1;
02817 
02818   if (modname && (flags & SCHEME_SETTING)) {
02819     if (SAME_OBJ(src_find_id, find_id) || SAME_OBJ(SCHEME_STX_SYM(src_find_id), find_id))
02820       find_id = NULL;
02821     scheme_wrong_syntax(scheme_set_stx_string, find_id, src_find_id, "cannot mutate module-required identifier");
02822     return NULL;
02823   }
02824 
02825   if (!modname && (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) 
02826       && (genv->module && genv->disallow_unbound)) {
02827     /* Check for set! of unbound identifier: */    
02828     if (!scheme_lookup_in_table(genv->toplevel, (const char *)find_global_id)) {
02829       scheme_wrong_syntax(((flags & SCHEME_SETTING) 
02830                           ? scheme_set_stx_string
02831                           : scheme_var_ref_string), 
02832                        NULL, src_find_id, "unbound identifier in module");
02833       return NULL;
02834     }
02835   }
02836 
02837   if (!modname && (flags & SCHEME_NULL_FOR_UNBOUND)) {
02838     if (module_self_reference) {
02839       /* Since the module has a rename for this id, it's certainly defined. */
02840       if (!(flags & SCHEME_RESOLVE_MODIDS)) {
02841        /* This is the same thing as #%top handling in compile mode. But
02842           for expand mode, it prevents wrapping the identifier with #%top. */
02843        /* Don't need a pos, because the symbol's gensym-ness (if any) will be
02844           preserved within the module. */
02845        return scheme_hash_module_variable(genv, genv->module->self_modidx, find_id, 
02846                                       genv->module->insp,
02847                                       -1, genv->mod_phase);
02848       }
02849     } else
02850       return NULL;
02851   }
02852 
02853   /* Used to have `&& !SAME_OBJ(modidx, modname)' below, but that was a bad
02854      idea, because it causes module instances to be preserved. */
02855   if (modname && !(flags & SCHEME_RESOLVE_MODIDS) 
02856       && (!scheme_is_kernel_modname(modname) || (flags & SCHEME_REFERENCING))) {
02857     /* Create a module variable reference, so that idx is preserved: */
02858     return scheme_hash_module_variable(env->genv, modidx, find_id, 
02859                                    genv->module->insp,
02860                                    modpos, SCHEME_INT_VAL(mod_defn_phase));
02861   }
02862 
02863   if (!modname && (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) && genv->module) {
02864     /* Need to return a variable reference in this case, too. */
02865     return scheme_hash_module_variable(env->genv, genv->module->self_modidx, find_global_id, 
02866                                    genv->module->insp,
02867                                    modpos, genv->mod_phase);
02868   }
02869 
02870   b = scheme_bucket_from_table(genv->toplevel, (char *)find_global_id);
02871 
02872   if ((flags & SCHEME_ELIM_CONST) && b && b->val 
02873       && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONST)
02874       && !(flags & SCHEME_GLOB_ALWAYS_REFERENCE))
02875     return (Scheme_Object *)b->val;
02876 
02877   ASSERT_IS_VARIABLE_BUCKET(b);
02878   if (!((Scheme_Bucket_With_Home *)b)->home)
02879     ((Scheme_Bucket_With_Home *)b)->home = genv;
02880   
02881   return (Scheme_Object *)b;
02882 }
02883 
02884 int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count)
02885 {
02886   int *v, i;
02887   
02888   v = MALLOC_N_ATOMIC(int, count);
02889   memcpy(v, COMPILE_DATA(frame)->use + start, sizeof(int) * count);
02890 
02891   for (i = count; i--; ) {
02892     int old;
02893     old = v[i];
02894     v[i] = 0;
02895     if (old & (ARBITRARY_USE | ONE_ARBITRARY_USE | CONSTRAINED_USE)) {
02896       v[i] |= SCHEME_WAS_USED;
02897       if (!(old & (ARBITRARY_USE | WAS_SET_BANGED))) {
02898         if (old & ONE_ARBITRARY_USE)
02899           v[i] |= SCHEME_WAS_APPLIED_EXCEPT_ONCE;
02900         else
02901           v[i] |= SCHEME_WAS_ONLY_APPLIED;
02902       }
02903     }
02904     if (old & WAS_SET_BANGED)
02905       v[i] |= SCHEME_WAS_SET_BANGED;
02906     v[i] |= (old & SCHEME_USE_COUNT_MASK);
02907   }
02908 
02909   return v;
02910 }
02911 
02912 /*========================================================================*/
02913 /*                          syntax-checking utils                         */
02914 /*========================================================================*/
02915 
02916 void scheme_check_identifier(const char *formname, Scheme_Object *id, 
02917                           const char *where, Scheme_Comp_Env *env,
02918                           Scheme_Object *form)
02919 {
02920   if (!where)
02921     where = "";
02922 
02923   if (!SCHEME_STX_SYMBOLP(id))
02924     scheme_wrong_syntax(formname, form ? id : NULL, 
02925                      form ? form : id, 
02926                      "not an identifier%s", where);
02927 }
02928 
02929 void scheme_begin_dup_symbol_check(DupCheckRecord *r, Scheme_Comp_Env *env)
02930 {
02931   r->phase = env->genv->phase;
02932   r->count = 0;
02933 }
02934 
02935 void scheme_dup_symbol_check(DupCheckRecord *r, const char *where,
02936                           Scheme_Object *symbol, char *what, 
02937                           Scheme_Object *form)
02938 {
02939   int i;
02940 
02941   if (r->count <= 5) {
02942     for (i = 0; i < r->count; i++) {
02943       if (scheme_stx_bound_eq(symbol, r->syms[i], scheme_make_integer(r->phase)))
02944        scheme_wrong_syntax(where, symbol, form,
02945                          "duplicate %s name", what);
02946     }
02947 
02948     if (r->count < 5) {
02949       r->syms[r->count++] = symbol;
02950       return;
02951     } else {
02952       Scheme_Hash_Table *ht;
02953       ht = scheme_make_hash_table(SCHEME_hash_bound_id);
02954       r->ht = ht;
02955       for (i = 0; i < r->count; i++) {
02956        scheme_hash_set(ht, r->syms[i], scheme_true);
02957       }
02958       r->count++;
02959     }
02960   }
02961 
02962   if (scheme_hash_get(r->ht, symbol)) {
02963     scheme_wrong_syntax(where, symbol, form,
02964                      "duplicate %s name", what);
02965   }
02966 
02967   scheme_hash_set(r->ht, symbol, scheme_true);
02968 }
02969 
02970 int scheme_check_context(Scheme_Env *env, Scheme_Object *name, Scheme_Object *ok_modidx)
02971 {
02972   Scheme_Object *mod, *id = name;
02973 
02974   mod = scheme_stx_source_module(id, 0);
02975 
02976   if (mod && SCHEME_TRUEP(mod) && NOT_SAME_OBJ(ok_modidx, mod)) {
02977     return 1;
02978   } else {
02979     mod = scheme_stx_module_name(NULL, &id, scheme_make_integer(env->phase), NULL, NULL, NULL, 
02980                                  NULL, NULL, NULL, NULL, NULL);
02981     if (SAME_OBJ(mod, scheme_undefined))
02982       return 1;
02983   }
02984   
02985   return 0;
02986 }
02987 
02988 /*========================================================================*/
02989 /*                 compile-time env for optimization                      */
02990 /*========================================================================*/
02991 
02992 Optimize_Info *scheme_optimize_info_create()
02993 {
02994   Optimize_Info *info;
02995 
02996   info = MALLOC_ONE_RT(Optimize_Info);
02997 #ifdef MZTAG_REQUIRED
02998   info->type = scheme_rt_optimize_info;
02999 #endif
03000   info->inline_fuel = 16;
03001   
03002   return info;
03003 }
03004 
03005 static void register_transitive_use(Optimize_Info *info, int pos, int j);
03006 
03007 static void register_stat_dist(Optimize_Info *info, int i, int j)
03008 {
03009   if (!info->stat_dists) {
03010     int k, *ia;
03011     char **ca;
03012     ca = MALLOC_N(char*, info->new_frame);
03013     info->stat_dists = ca;
03014     ia = MALLOC_N_ATOMIC(int, info->new_frame);
03015     info->sd_depths = ia;
03016     for (k = info->new_frame; k--; ) {
03017       info->sd_depths[k] = 0;
03018     }
03019   }
03020   
03021   if (info->sd_depths[i] <= j) {
03022     char *naya, *a;
03023     int k;
03024     
03025     naya = MALLOC_N_ATOMIC(char, (j + 1));
03026     for (k = j + 1; k--; ) {
03027       naya[k] = 0;
03028     }
03029     a = info->stat_dists[i];
03030     for (k = info->sd_depths[i]; k--; ) {
03031       naya[k] = a[k];
03032     }
03033     
03034     info->stat_dists[i] = naya;
03035     info->sd_depths[i] = j + 1;
03036   }
03037 
03038   if (info->transitive_use && info->transitive_use[i]) {
03039     /* We're using a procedure that we weren't sure would be used.
03040        Transitively mark everything that the procedure uses --- unless
03041        a transitive accumulation is in effect, in which case we
03042        don't for this one now, leaving it to be triggered when
03043        the one we're accumulating is triggered. */
03044     if (!info->transitive_use_pos) {
03045       mzshort *map = info->transitive_use[i];
03046       int len = info->transitive_use_len[i];
03047       int k;
03048 
03049       info->transitive_use[i] = NULL;
03050 
03051       for (k = 0; k < len; k++) {
03052         register_transitive_use(info, map[k], 0);
03053       }
03054     }
03055   }
03056 
03057   info->stat_dists[i][j] = 1;
03058 }
03059 
03060 static Scheme_Object *transitive_k(void)
03061 {
03062   Scheme_Thread *p = scheme_current_thread;
03063   Optimize_Info *info = (Optimize_Info *)p->ku.k.p1;
03064 
03065   p->ku.k.p1 = NULL;
03066 
03067   register_transitive_use(info, p->ku.k.i1, p->ku.k.i2);
03068 
03069   return scheme_false;
03070 }
03071 
03072 static void register_transitive_use(Optimize_Info *info, int pos, int j)
03073 {
03074 #ifdef DO_STACK_CHECK
03075 # include "mzstkchk.h"
03076   {
03077     Scheme_Thread *p = scheme_current_thread;
03078 
03079     p->ku.k.p1 = (void *)info;
03080     p->ku.k.i1 = pos;
03081     p->ku.k.i2 = j;
03082 
03083     scheme_handle_stack_overflow(transitive_k);
03084 
03085     return;
03086   }
03087 #endif
03088 
03089   while (info) {
03090     if (info->flags & SCHEME_LAMBDA_FRAME)
03091       j++;
03092     if (pos < info->new_frame)
03093       break;
03094     pos -= info->new_frame;
03095     info = info->next;
03096   }
03097 
03098   if (info->sd_depths[pos] <= j) {
03099     scheme_signal_error("bad transitive position depth: %d vs. %d",
03100                         info->sd_depths[pos], j);
03101   }
03102 
03103   register_stat_dist(info, pos, j);
03104 }
03105 
03106 void scheme_env_make_closure_map(Optimize_Info *info, mzshort *_size, mzshort **_map)
03107 {
03108   /* A closure map lists the captured variables for a closure; the
03109      indices are resolved two new indicies in the second phase of
03110      compilation. */
03111   Optimize_Info *frame;
03112   int i, j, pos = 0, lpos = 0, tu;
03113   mzshort *map, size;
03114 
03115   /* Count vars used by this closure (skip args): */
03116   j = 1;
03117   for (frame = info->next; frame; frame = frame->next) {
03118     if (frame->flags & SCHEME_LAMBDA_FRAME)
03119       j++;
03120 
03121     if (frame->stat_dists) {
03122       for (i = 0; i < frame->new_frame; i++) {
03123        if (frame->sd_depths[i] > j) {
03124          if (frame->stat_dists[i][j]) {
03125            pos++;
03126          }
03127        }
03128       }
03129     }
03130   }
03131 
03132   size = pos;
03133   *_size = size;
03134   map = MALLOC_N_ATOMIC(mzshort, size);
03135   *_map = map;
03136 
03137   if (info->next && info->next->transitive_use_pos) {
03138     info->next->transitive_use[info->next->transitive_use_pos - 1] = map;
03139     info->next->transitive_use_len[info->next->transitive_use_pos - 1] = size;
03140     tu = 1;
03141   } else
03142     tu = 0;
03143 
03144   /* Build map, unmarking locals and marking deeper in parent frame */
03145   j = 1; pos = 0;
03146   for (frame = info->next; frame; frame = frame->next) {
03147     if (frame->flags & SCHEME_LAMBDA_FRAME)
03148       j++;
03149 
03150     if (frame->stat_dists) {
03151       for (i = 0; i < frame->new_frame; i++) {
03152        if (frame->sd_depths[i] > j) {
03153          if (frame->stat_dists[i][j]) {
03154            map[pos++] = lpos;
03155            frame->stat_dists[i][j] = 0; /* This closure's done with these vars... */
03156             if (!tu)
03157               frame->stat_dists[i][j - 1] = 1; /* ... but ensure previous keeps */
03158          }
03159        }
03160        lpos++;
03161       }
03162     } else
03163       lpos += frame->new_frame;
03164   }
03165 }
03166 
03167 int scheme_env_uses_toplevel(Optimize_Info *frame)
03168 {
03169   int used;
03170 
03171   used = frame->used_toplevel;
03172   
03173   if (used) {
03174     /* Propagate use to an enclosing lambda, if any: */
03175     frame = frame->next;
03176     while (frame) {
03177       if (frame->flags & SCHEME_LAMBDA_FRAME) {
03178        frame->used_toplevel = 1;
03179        break;
03180       }
03181       frame = frame->next;
03182     }
03183   }
03184 
03185   return used;
03186 }
03187 
03188 void scheme_optimize_info_used_top(Optimize_Info *info)
03189 {
03190   while (info) {
03191     if (info->flags & SCHEME_LAMBDA_FRAME) {
03192       info->used_toplevel = 1;
03193       break;
03194     }
03195     info = info->next;
03196   }
03197 }
03198 
03199 void scheme_optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *value, int single_use)
03200 {
03201   /* A raw-pair `value' is an indicator for whether a letrec-bound
03202      variable is ready. */
03203   Scheme_Object *p;
03204 
03205   p = scheme_make_vector(4, NULL);
03206   SCHEME_VEC_ELS(p)[0] = info->consts;
03207   SCHEME_VEC_ELS(p)[1] = scheme_make_integer(pos);
03208   SCHEME_VEC_ELS(p)[2] = value;
03209   SCHEME_VEC_ELS(p)[3] = (single_use ? scheme_true : scheme_false);
03210 
03211   info->consts = p;
03212 }
03213 
03214 void scheme_optimize_mutated(Optimize_Info *info, int pos)
03215 /* pos must be in immediate frame */
03216 {
03217   if (!info->use) {
03218     char *use;
03219     use = (char *)scheme_malloc_atomic(info->new_frame);
03220     memset(use, 0, info->new_frame);
03221     info->use = use;
03222   }
03223   info->use[pos] = 1;
03224 }
03225 
03226 Scheme_Object *scheme_optimize_reverse(Optimize_Info *info, int pos, int unless_mutated)
03227 /* pos is in new-frame counts, and we want to produce an old-frame reference if
03228    it's not mutated */
03229 {
03230   int delta = 0;
03231 
03232   while (1) {
03233     if (pos < info->new_frame)
03234       break;
03235     pos -= info->new_frame;
03236     delta += info->original_frame;
03237     info = info->next;
03238   }
03239 
03240   if (unless_mutated)
03241     if (info->use && info->use[pos])
03242       return NULL;
03243 
03244   return scheme_make_local(scheme_local_type, pos + delta, 0);
03245 }
03246 
03247 int scheme_optimize_is_used(Optimize_Info *info, int pos)
03248 /* pos must be in immediate frame */
03249 {
03250   int i;
03251 
03252   if (info->stat_dists) {
03253     for (i = info->sd_depths[pos]; i--; ) {
03254       if (info->stat_dists[pos][i])
03255        return 1;
03256     }
03257   }
03258 
03259   return 0;
03260 }
03261 
03262 int scheme_optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos)
03263 {
03264   int j, i;
03265 
03266   if (info->stat_dists) {
03267     for (i = start_pos; i < end_pos; i++) {
03268       for (j = info->sd_depths[i]; j--; ) {
03269         if (info->stat_dists[i][j])
03270           return 1;
03271       }
03272     }
03273   }
03274 
03275   if (info->transitive_use) {
03276     for (i = info->new_frame; i--; ) {
03277       if (info->transitive_use[i]) {
03278         for (j = info->transitive_use_len[i]; j--; ) {
03279           if ((info->transitive_use[i][j] >= start_pos)
03280               && (info->transitive_use[i][j] < end_pos))
03281             return 1;
03282         }
03283       }
03284     }
03285   }
03286 
03287   return 0;
03288 }
03289 
03290 static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int j, int *closure_offset, int *single_use, int *not_ready)
03291 {
03292   Scheme_Object *p, *n;
03293   int delta = 0;
03294 
03295   while (info) {
03296     if (info->flags & SCHEME_LAMBDA_FRAME)
03297       j++;
03298     if (pos < info->original_frame)
03299       break;
03300     pos -= info->original_frame;
03301     delta += info->new_frame;
03302     info = info->next;
03303   }
03304 
03305   p = info->consts;
03306   while (p) {
03307     n = SCHEME_VEC_ELS(p)[1];
03308     if (SCHEME_INT_VAL(n) == pos) {
03309       n = SCHEME_VEC_ELS(p)[2];
03310       if (SCHEME_RPAIRP(n)) {
03311         /* This was a letrec-bound identifier that may or may not be ready,
03312            but which wasn't replaced with more information. */
03313         if (not_ready)
03314           *not_ready = SCHEME_TRUEP(SCHEME_CAR(n));
03315         break;
03316       }
03317       if (single_use)
03318         *single_use = SCHEME_TRUEP(SCHEME_VEC_ELS(p)[3]);
03319       if (SAME_TYPE(SCHEME_TYPE(n), scheme_compiled_unclosed_procedure_type)) {
03320        if (!closure_offset)
03321          break;
03322        else {
03323          *closure_offset = delta;
03324        }
03325       } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_compiled_toplevel_type)) {
03326         /* Ok */
03327       } else if (closure_offset) {
03328         /* Inlining can deal procdures and top-levels, but not other things. */
03329         return NULL;
03330       } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_local_type)) {
03331        int pos;
03332 
03333        pos = SCHEME_LOCAL_POS(n);
03334        if (info->flags & SCHEME_LAMBDA_FRAME)
03335          j--; /* because it will get re-added on recur */
03336 
03337        /* Marks local as used; we don't expect to get back
03338           a value, because chaining would normally happen on the 
03339           propagate-call side. Chaining there also means that we 
03340           avoid stack overflow here. */
03341         if (single_use) {
03342           if (!*single_use)
03343             single_use = NULL;
03344         }
03345        n = do_optimize_info_lookup(info, pos, j, NULL, single_use, NULL);
03346 
03347        if (!n) {
03348          /* Return shifted reference to other local: */
03349          delta += scheme_optimize_info_get_shift(info, pos);
03350          n = scheme_make_local(scheme_local_type, pos + delta, 0);
03351        }
03352       }
03353       return n;
03354     }
03355     p = SCHEME_VEC_ELS(p)[0];
03356   }
03357 
03358   if (!closure_offset)
03359     register_stat_dist(info, pos, j);
03360   
03361   return NULL;
03362 }
03363 
03364 Scheme_Object *scheme_optimize_info_lookup(Optimize_Info *info, int pos, int *closure_offset, int *single_use)
03365 {
03366   return do_optimize_info_lookup(info, pos, 0, closure_offset, single_use, NULL);
03367 }
03368 
03369 int scheme_optimize_info_is_ready(Optimize_Info *info, int pos)
03370 {
03371   int closure_offset, single_use, ready = 1;
03372   
03373   do_optimize_info_lookup(info, pos, 0, &closure_offset, &single_use, &ready);
03374 
03375   return ready;
03376 }
03377 
03378 Optimize_Info *scheme_optimize_info_add_frame(Optimize_Info *info, int orig, int current, int flags)
03379 {
03380   Optimize_Info *naya;
03381 
03382   naya = scheme_optimize_info_create();
03383   naya->flags = (short)flags;
03384   naya->next = info;
03385   naya->original_frame = orig;
03386   naya->new_frame = current;
03387   naya->inline_fuel = info->inline_fuel;
03388   naya->letrec_not_twice = info->letrec_not_twice;
03389   naya->enforce_const = info->enforce_const;
03390   naya->top_level_consts = info->top_level_consts;
03391   naya->context = info->context;
03392 
03393   return naya;
03394 }
03395 
03396 int scheme_optimize_info_get_shift(Optimize_Info *info, int pos)
03397 {
03398   int delta = 0;
03399 
03400   while (info) {
03401     if (pos < info->original_frame)
03402       break;
03403     pos -= info->original_frame;
03404     delta += (info->new_frame - info->original_frame);
03405     info = info->next;
03406   }
03407 
03408   if (!info)
03409     *(long *)0x0 = 1;
03410 
03411   return delta;
03412 }
03413 
03414 void scheme_optimize_info_done(Optimize_Info *info)
03415 {
03416   info->next->size += info->size;
03417 }
03418 
03419 
03420   
03421 
03422 /*========================================================================*/
03423 /*                    compile-time env for resolve                        */
03424 /*========================================================================*/
03425 
03426 /* See eval.c for information about the compilation phases. */
03427 
03428 Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify)
03429 {
03430   Resolve_Prefix *rp;
03431   Scheme_Object **tls, **stxes, *simplify_cache, *m;
03432   Scheme_Hash_Table *ht;
03433   int i;
03434 
03435   rp = MALLOC_ONE_TAGGED(Resolve_Prefix);
03436   rp->so.type = scheme_resolve_prefix_type;
03437   rp->num_toplevels = cp->num_toplevels;
03438   rp->num_stxes = cp->num_stxes;
03439   
03440   if (rp->num_toplevels)
03441     tls = MALLOC_N(Scheme_Object*, rp->num_toplevels);
03442   else
03443     tls = NULL;
03444   if (rp->num_stxes)
03445     stxes = MALLOC_N(Scheme_Object*, rp->num_stxes);
03446   else
03447     stxes = NULL;
03448 
03449   rp->toplevels = tls;
03450   rp->stxes = stxes;
03451 
03452   ht = cp->toplevels;
03453   if (ht) {
03454     for (i = 0; i < ht->size; i++) {
03455       if (ht->vals[i]) {
03456         m = ht->keys[i];
03457         if (SAME_TYPE(SCHEME_TYPE(m), scheme_module_variable_type)) {
03458           if (SCHEME_FALSEP(((Scheme_Modidx *)((Module_Variable *)m)->modidx)->base)
03459               && SCHEME_FALSEP(((Scheme_Modidx *)((Module_Variable *)m)->modidx)->path)) {
03460             /* Reduce self-referece to just a symbol: */
03461             m = ((Module_Variable *)m)->sym;
03462           }
03463         }
03464        tls[SCHEME_TOPLEVEL_POS(ht->vals[i])] = m;
03465       }
03466     }
03467   }
03468 
03469   if (simplify)
03470     simplify_cache = scheme_new_stx_simplify_cache();
03471   else
03472     simplify_cache = NULL;  
03473 
03474   ht = cp->stxes;
03475   if (ht) {
03476     for (i = 0; i < ht->size; i++) {
03477       if (ht->vals[i]) {
03478        scheme_simplify_stx(ht->keys[i], simplify_cache);
03479        stxes[SCHEME_LOCAL_POS(ht->vals[i])] = ht->keys[i];
03480       }
03481     }
03482   }
03483 
03484   return rp;
03485 }
03486 
03487 Resolve_Prefix *scheme_remap_prefix(Resolve_Prefix *rp, Resolve_Info *ri)
03488 {
03489   /* Rewrite stxes list based on actual uses at resolve pass.
03490      If we have no lifts, we can just srop unused stxes.
03491      Otherwise, if any stxes go unused, we just have to replace them
03492      with NULL. */
03493   int i, cnt;
03494   Scheme_Object **new_stxes, *v;
03495 
03496   if (!rp->num_stxes)
03497     return rp;
03498 
03499   if (rp->num_lifts)
03500     cnt = rp->num_stxes;
03501   else
03502     cnt = ri->stx_map->count;
03503 
03504   new_stxes = MALLOC_N(Scheme_Object *, cnt);
03505 
03506   for (i = 0; i < rp->num_stxes; i++) {
03507     if (ri->stx_map)
03508       v = scheme_hash_get(ri->stx_map, scheme_make_integer(i));
03509     else
03510       v = NULL;
03511     if (v) {
03512       new_stxes[SCHEME_INT_VAL(v)]  = rp->stxes[i];
03513     }
03514   }
03515 
03516   rp->stxes = new_stxes;
03517   rp->num_stxes = cnt;
03518 
03519   return rp;
03520 }
03521 
03522 Resolve_Info *scheme_resolve_info_create(Resolve_Prefix *rp)
03523 {
03524   Resolve_Info *naya;
03525   Scheme_Object *b;
03526   Scheme_Hash_Table *ht;
03527 
03528   naya = MALLOC_ONE_RT(Resolve_Info);
03529 #ifdef MZTAG_REQUIRED
03530   naya->type = scheme_rt_resolve_info;
03531 #endif
03532   naya->prefix = rp;
03533   naya->count = 0;
03534   naya->next = NULL;
03535   naya->toplevel_pos = -1;
03536 
03537   ht = scheme_make_hash_table(SCHEME_hash_ptr);
03538   naya->stx_map = ht;
03539 
03540   b = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT);
03541   naya->use_jit = SCHEME_TRUEP(b);
03542 
03543   return naya;
03544 }
03545 
03546 Resolve_Info *scheme_resolve_info_extend(Resolve_Info *info, int size, int oldsize, int mapc)
03547      /* size = number of appended items in run-time frame */
03548      /* oldisze = number of appended items in original compile-time frame */
03549      /* mapc = mappings that will be installed */
03550 {
03551   Resolve_Info *naya;
03552 
03553   naya = MALLOC_ONE_RT(Resolve_Info);
03554 #ifdef MZTAG_REQUIRED
03555   naya->type = scheme_rt_resolve_info;
03556 #endif
03557   naya->prefix = info->prefix;
03558   naya->stx_map = info->stx_map;
03559   naya->next = info;
03560   naya->use_jit = info->use_jit;
03561   naya->enforce_const = info->enforce_const;
03562   naya->size = size;
03563   naya->oldsize = oldsize;
03564   naya->count = mapc;
03565   naya->pos = 0;
03566   naya->toplevel_pos = -1;
03567   naya->lifts = info->lifts;
03568 
03569   if (mapc) {
03570     int i, *ia;
03571     mzshort *sa;
03572 
03573     sa = MALLOC_N_ATOMIC(mzshort, mapc);
03574     naya->old_pos = sa;
03575     sa = MALLOC_N_ATOMIC(mzshort, mapc);
03576     naya->new_pos = sa;
03577     ia = MALLOC_N_ATOMIC(int, mapc);
03578     naya->flags = ia;
03579 
03580     /* necessary? added when changed allocation to atomic */
03581     for (i = mapc; i--; ) {
03582       naya->old_pos[i] = 0;
03583       naya->new_pos[i] = 0;
03584       naya->flags[i] = 0;
03585     }
03586   }
03587 
03588   return naya;
03589 }
03590 
03591 void scheme_resolve_info_add_mapping(Resolve_Info *info, int oldp, int newp, int flags, Scheme_Object *lifted)
03592 {
03593   if (info->pos == info->count) {
03594     scheme_signal_error("internal error: add_mapping: "
03595                      "too many: %d", info->pos);
03596   }
03597 
03598   info->old_pos[info->pos] = oldp;
03599   info->new_pos[info->pos] = newp;
03600   info->flags[info->pos] = flags;
03601   if (lifted) {
03602     if (!info->lifted) {
03603       Scheme_Object **lifteds;
03604       lifteds = MALLOC_N(Scheme_Object*, info->count);
03605       info->lifted = lifteds;
03606     }
03607     info->lifted[info->pos] = lifted;
03608   }
03609   
03610   info->pos++;
03611 }
03612 
03613 void scheme_resolve_info_adjust_mapping(Resolve_Info *info, int oldp, int newp, int flags, Scheme_Object *lifted)
03614 {
03615   int i;
03616 
03617   for (i = info->pos; i--; ) {
03618     if (info->old_pos[i] == oldp) {
03619       info->new_pos[i] = newp;
03620       info->flags[i] = flags;
03621       if (lifted) {
03622         info->lifted[i] = lifted;
03623       }
03624       return;
03625     }
03626   }
03627       
03628   scheme_signal_error("internal error: adjust_mapping: "
03629                       "couldn't find: %d", oldp);
03630 }
03631 
03632 void scheme_resolve_info_set_toplevel_pos(Resolve_Info *info, int pos)
03633 {
03634   info->toplevel_pos = pos;
03635 }
03636 
03637 static int resolve_info_lookup(Resolve_Info *info, int pos, int *flags, Scheme_Object **_lifted, int convert_shift)
03638 {
03639   Resolve_Info *orig_info = info;
03640   int i, offset = 0, orig = pos;
03641 
03642   if (_lifted)
03643     *_lifted = NULL;
03644 
03645   while (info) {
03646     for (i = info->pos; i--; ) {
03647       int oldp = info->old_pos[i];
03648       if (pos == oldp) {
03649        if (flags)
03650          *flags = info->flags[i];
03651         if (info->lifted && (info->lifted[i])) {
03652           int skip, shifted;
03653           Scheme_Object *lifted, *tl, **ca;
03654 
03655           if (!_lifted)
03656             scheme_signal_error("unexpected lifted binding");
03657 
03658           lifted = info->lifted[i];
03659 
03660           if (SCHEME_RPAIRP(lifted)) {
03661             tl = SCHEME_CAR(lifted);
03662             ca = (Scheme_Object **)SCHEME_CDR(lifted);
03663             if (convert_shift)
03664               shifted = SCHEME_INT_VAL(ca[0]) + convert_shift - 1;
03665             else
03666               shifted = 0;
03667           } else {
03668             tl = lifted;
03669             shifted = 0;
03670             ca = NULL;
03671           }
03672 
03673           if (SAME_TYPE(SCHEME_TYPE(tl), scheme_toplevel_type)) {
03674             skip = scheme_resolve_toplevel_pos(orig_info);
03675             tl = make_toplevel(skip + shifted, 
03676                                SCHEME_TOPLEVEL_POS(tl),
03677                                1,
03678                                SCHEME_TOPLEVEL_CONST);
03679           }
03680 
03681           if (SCHEME_RPAIRP(lifted)) {
03682             int sz, i;
03683             mzshort *posmap, *boxmap;
03684             Scheme_Object *vec, *loc;
03685             sz = SCHEME_INT_VAL(ca[0]);
03686             posmap = (mzshort *)ca[1];
03687             boxmap = (mzshort *)ca[3];
03688             vec = scheme_make_vector(sz + 1, NULL);
03689             for (i = 0; i < sz; i++) {
03690               loc = scheme_make_local(scheme_local_type,
03691                                       posmap[i] + offset + shifted,
03692                                       0);
03693               if (boxmap) {
03694                 if (boxmap[i / BITS_PER_MZSHORT] & ((mzshort)1 << (i & (BITS_PER_MZSHORT - 1))))
03695                   loc = scheme_box(loc);
03696               }
03697               SCHEME_VEC_ELS(vec)[i+1] = loc;
03698             }
03699             SCHEME_VEC_ELS(vec)[0] = ca[2];
03700             lifted = scheme_make_raw_pair(tl, vec);
03701           } else
03702             lifted = tl;
03703           
03704           *_lifted = lifted;
03705            
03706            return 0;
03707         } else
03708           return info->new_pos[i] + offset;
03709       }
03710     }
03711 
03712     if (info->in_proc) {
03713       scheme_signal_error("internal error: scheme_resolve_info_lookup: "
03714                           "searching past procedure");
03715     }
03716 
03717     pos -= info->oldsize;
03718     offset += info->size;
03719     info = info->next;
03720   }
03721 
03722   scheme_signal_error("internal error: scheme_resolve_info_lookup: "
03723                     "variable %d not found", orig);
03724 
03725   return 0;
03726 }
03727 
03728 Scheme_Object *scheme_resolve_generate_stub_lift()
03729 {
03730   return make_toplevel(0, 0, 1, SCHEME_TOPLEVEL_CONST);
03731 }
03732 
03733 int scheme_resolve_info_flags(Resolve_Info *info, int pos, Scheme_Object **lifted)
03734 {
03735   int flags;
03736 
03737   resolve_info_lookup(info, pos, &flags, lifted, 0);
03738 
03739   return flags;
03740 }
03741 
03742 int scheme_resolve_info_lookup(Resolve_Info *info, int pos, int *flags, Scheme_Object **lifted, int convert_shift)
03743 {
03744   return resolve_info_lookup(info, pos, flags, lifted, convert_shift);
03745 }
03746 
03747 int scheme_resolve_toplevel_pos(Resolve_Info *info)
03748 {
03749   int pos = 0;
03750 
03751   while (info && (info->toplevel_pos < 0)) {
03752     if (info->in_proc) {
03753       scheme_signal_error("internal error: scheme_resolve_toplevel_pos: "
03754                           "searching past procedure");
03755     }
03756     pos += info->size;
03757     info = info->next;
03758   }
03759 
03760   if (!info)
03761     return pos;
03762   else
03763     return info->toplevel_pos + pos;
03764 }
03765 
03766 int scheme_resolve_is_toplevel_available(Resolve_Info *info)
03767 {
03768   while (info) {
03769     if (info->toplevel_pos >= 0)
03770       return 1;
03771     if (info->in_proc)
03772       return 0;
03773     info = info->next;
03774   }
03775 
03776   return 0;
03777 }
03778 
03779 int scheme_resolve_quote_syntax_offset(int i, Resolve_Info *info)
03780 {
03781   Scheme_Hash_Table *ht;
03782   Scheme_Object *v;
03783 
03784   ht = info->stx_map;
03785 
03786   v = scheme_hash_get(ht, scheme_make_integer(i));
03787   if (!v) {
03788     v = scheme_make_integer(ht->count);
03789     scheme_hash_set(ht, scheme_make_integer(i), v);
03790   }
03791 
03792   return SCHEME_INT_VAL(v);
03793 }
03794 
03795 int scheme_resolve_quote_syntax_pos(Resolve_Info *info)
03796 {
03797   return info->prefix->num_toplevels;
03798 }
03799 
03800 Scheme_Object *scheme_resolve_toplevel(Resolve_Info *info, Scheme_Object *expr, int keep_ready)
03801 {
03802   int skip;
03803 
03804   skip = scheme_resolve_toplevel_pos(info);
03805 
03806   return make_toplevel(skip + SCHEME_TOPLEVEL_DEPTH(expr), /* depth is 0 (normal) or 1 (exp-time) */
03807                      SCHEME_TOPLEVEL_POS(expr),
03808                      1,
03809                      SCHEME_TOPLEVEL_FLAGS(expr) & (SCHEME_TOPLEVEL_CONST
03810                                                       | (keep_ready 
03811                                                          ? SCHEME_TOPLEVEL_READY
03812                                                          : 0)));
03813 }
03814 
03815 Scheme_Object *scheme_shift_toplevel(Scheme_Object *expr, int delta)
03816 {
03817   return make_toplevel(SCHEME_TOPLEVEL_DEPTH(expr) + delta,
03818                      SCHEME_TOPLEVEL_POS(expr),
03819                      1,
03820                      SCHEME_TOPLEVEL_FLAGS(expr) & SCHEME_TOPLEVEL_FLAGS_MASK);
03821 }
03822 
03823 Scheme_Object *scheme_resolve_invent_toplevel(Resolve_Info *info)
03824 {
03825   int skip, pos;
03826   Scheme_Object *count;
03827 
03828   skip = scheme_resolve_toplevel_pos(info);
03829 
03830   count = SCHEME_VEC_ELS(info->lifts)[1];
03831   pos = (SCHEME_INT_VAL(count)
03832          + info->prefix->num_toplevels 
03833          + info->prefix->num_stxes
03834          + (info->prefix->num_stxes ? 1 : 0));
03835   count = scheme_make_integer(SCHEME_INT_VAL(count) + 1);
03836   SCHEME_VEC_ELS(info->lifts)[1] = count;
03837 
03838   return make_toplevel(skip,
03839                      pos,
03840                      1,
03841                        SCHEME_TOPLEVEL_CONST);
03842 }
03843 
03844 Scheme_Object *scheme_resolve_invented_toplevel_to_defn(Resolve_Info *info, Scheme_Object *tl)
03845 {
03846   return make_toplevel(0,
03847                        SCHEME_TOPLEVEL_POS(tl),
03848                        1,
03849                        SCHEME_TOPLEVEL_CONST);
03850 }
03851 
03852 int scheme_resolving_in_procedure(Resolve_Info *info)
03853 {
03854   while (info) {
03855     if (info->in_proc)
03856       return 1;
03857     info = info->next;
03858   }
03859   return 0;
03860 }
03861 
03862 
03863 
03864 /*========================================================================*/
03865 /*                             run-time "stack"                           */
03866 /*========================================================================*/
03867 
03868 Scheme_Object *scheme_make_envunbox(Scheme_Object *value)
03869 {
03870   Scheme_Object *obj;
03871 
03872   obj = (Scheme_Object *)scheme_malloc_envunbox(sizeof(Scheme_Object*));
03873   SCHEME_ENVBOX_VAL(obj) = value;
03874 
03875   return obj;
03876 }
03877 
03878 /*========================================================================*/
03879 /*             run-time and expansion-time Scheme interface               */
03880 /*========================================================================*/
03881 
03882 static Scheme_Object *
03883 namespace_identifier(int argc, Scheme_Object *argv[])
03884 {
03885   Scheme_Object *obj;
03886   Scheme_Env *genv;
03887 
03888   if (!SCHEME_SYMBOLP(argv[0]))
03889     scheme_wrong_type("namespace-symbol->identifier", "symbol", 0, argc, argv);
03890   if ((argc > 1) && !SCHEME_NAMESPACEP(argv[1]))
03891     scheme_wrong_type("namespace-symbol->identifier", "namespace", 1, argc, argv);
03892 
03893   if (argc > 1)
03894     genv = (Scheme_Env *)argv[1];
03895   else
03896     genv = scheme_get_env(NULL);
03897 
03898   obj = argv[0];
03899   obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 1, 0);
03900 
03901   /* Renamings: */
03902   if (genv->rename_set)
03903     obj = scheme_add_rename(obj, genv->rename_set);
03904 
03905   return obj;
03906 }
03907 
03908 static Scheme_Object *
03909 namespace_module_identifier(int argc, Scheme_Object *argv[])
03910 {
03911   Scheme_Env *genv;
03912   Scheme_Object *phase;
03913 
03914   if (argc > 0) {
03915     if (SCHEME_NAMESPACEP(argv[0])) {
03916       genv = (Scheme_Env *)argv[0];
03917       phase = scheme_make_integer(genv->phase);
03918     } else if (SCHEME_FALSEP(argv[0])) {
03919       phase = scheme_false;
03920     } else if (SCHEME_INTP(argv[0]) || SCHEME_BIGNUMP(argv[0])) {
03921       phase = argv[0];
03922     } else {
03923       scheme_wrong_type("namespace-module-identifier", "namespace, #f, or exact integer", 0, argc, argv);
03924       return NULL;
03925     }
03926   } else {
03927     genv = scheme_get_env(NULL);
03928     phase = scheme_make_integer(genv->phase);
03929   }
03930 
03931   return scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false, 
03932                                 scheme_sys_wraps_phase(phase), 0, 0);
03933 }
03934 
03935 static Scheme_Object *
03936 namespace_base_phase(int argc, Scheme_Object *argv[])
03937 {
03938   Scheme_Env *genv;
03939 
03940   if ((argc > 0) && !SCHEME_NAMESPACEP(argv[0]))
03941     scheme_wrong_type("namespace-base-phase", "namespace", 0, argc, argv);
03942 
03943   if (argc)
03944     genv = (Scheme_Env *)argv[0];
03945   else
03946     genv = scheme_get_env(NULL);
03947 
03948   return scheme_make_integer(genv->phase);
03949 }
03950 
03951 static Scheme_Object *
03952 namespace_variable_value(int argc, Scheme_Object *argv[])
03953 {
03954   Scheme_Object *v, *id = NULL;
03955   Scheme_Env *genv;
03956   int use_map;
03957 
03958   if (!SCHEME_SYMBOLP(argv[0]))
03959     scheme_wrong_type("namespace-variable-value", "symbol", 0, argc, argv);
03960   use_map = ((argc > 1) ? SCHEME_TRUEP(argv[1]) : 1);
03961   if ((argc > 2) && SCHEME_TRUEP(argv[2])
03962       && !scheme_check_proc_arity(NULL, 0, 2, argc, argv))
03963     scheme_wrong_type("namespace-variable-value", "procedure (arity 0) or #f", 1, argc, argv);
03964   if ((argc > 3) && !SCHEME_NAMESPACEP(argv[3]))
03965     scheme_wrong_type("namespace-variable-value", "namespace", 3, argc, argv);
03966 
03967   if (argc > 3)
03968     genv = (Scheme_Env *)argv[3];
03969   else
03970     genv = scheme_get_env(NULL);
03971 
03972   if (!use_map)
03973     v = scheme_lookup_global(argv[0], genv);
03974   else {
03975     Scheme_Full_Comp_Env inlined_e;
03976 
03977     scheme_prepare_env_renames(genv, mzMOD_RENAME_TOPLEVEL);
03978     scheme_prepare_compile_env(genv);
03979 
03980     id = scheme_make_renamed_stx(argv[0], genv->rename_set);
03981 
03982     inlined_e.base.num_bindings = 0;
03983     inlined_e.base.next = NULL;
03984     inlined_e.base.genv = genv;
03985     inlined_e.base.flags = SCHEME_TOPLEVEL_FRAME;
03986     init_compile_data((Scheme_Comp_Env *)&inlined_e);
03987     inlined_e.base.prefix = NULL;
03988 
03989     v = scheme_lookup_binding(id, (Scheme_Comp_Env *)&inlined_e, SCHEME_RESOLVE_MODIDS, NULL, NULL, NULL, NULL, NULL);
03990     if (v) {
03991       if (!SAME_TYPE(SCHEME_TYPE(v), scheme_variable_type)) {
03992        use_map = -1;
03993        v = NULL;
03994       } else
03995        v = (Scheme_Object *)(SCHEME_VAR_BUCKET(v))->val;
03996     }
03997   }
03998   
03999   if (!v) {
04000     if ((argc > 2) && SCHEME_TRUEP(argv[2]))
04001       return _scheme_tail_apply(argv[2], 0, NULL);
04002     else if (use_map == -1) {
04003       scheme_wrong_syntax("namespace-variable-value", NULL, id, "bound to syntax");
04004       return NULL;
04005     } else {
04006       scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, argv[0],
04007                      "namespace-variable-value: %S is not defined",
04008                      argv[0]);
04009       return NULL;
04010     }
04011   }
04012 
04013   return v;
04014 }
04015 
04016 static Scheme_Object *
04017 namespace_set_variable_value(int argc, Scheme_Object *argv[])
04018 {
04019   Scheme_Env *env;
04020   Scheme_Bucket *bucket;
04021 
04022   if (!SCHEME_SYMBOLP(argv[0]))
04023     scheme_wrong_type("namespace-set-variable-value!", "symbol", 0, argc, argv);
04024   if ((argc > 3) && !SCHEME_NAMESPACEP(argv[3]))
04025     scheme_wrong_type("namespace-set-variable-value!", "namespace", 3, argc, argv);
04026 
04027   if (argc > 3)
04028     env = (Scheme_Env *)argv[3];
04029   else
04030     env = scheme_get_env(NULL);
04031 
04032   bucket = scheme_global_bucket(argv[0], env);
04033   
04034   scheme_set_global_bucket("namespace-set-variable-value!", bucket, argv[1], 1);
04035   
04036   if ((argc > 2) && SCHEME_TRUEP(argv[2])) {
04037     scheme_shadow(env, argv[0], 1);
04038   }
04039 
04040   return scheme_void;
04041 }
04042 
04043 static Scheme_Object *
04044 namespace_undefine_variable(int argc, Scheme_Object *argv[])
04045 {
04046   Scheme_Env *env;
04047   Scheme_Bucket *bucket;
04048 
04049   if (!SCHEME_SYMBOLP(argv[0]))
04050     scheme_wrong_type("namespace-undefine-variable!", "symbol", 0, argc, argv);
04051   if ((argc > 1) && !SCHEME_NAMESPACEP(argv[1]))
04052     scheme_wrong_type("namespace-undefine-variable!", "namespace", 1, argc, argv);
04053 
04054   if (argc > 1)
04055     env = (Scheme_Env *)argv[1];
04056   else
04057     env = scheme_get_env(NULL);
04058 
04059   if (scheme_lookup_global(argv[0], env)) {
04060     bucket = scheme_global_bucket(argv[0], env);
04061     scheme_set_global_bucket("namespace-undefine-variable!", 
04062                              bucket,
04063                              NULL,
04064                              0);
04065     bucket->val = NULL;
04066   } else {
04067     scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, argv[0],
04068                    "namespace-undefine-variable!: %S is not defined",
04069                    argv[0]);
04070   }
04071 
04072   return scheme_void;
04073 }
04074 
04075 static Scheme_Object *
04076 namespace_mapped_symbols(int argc, Scheme_Object *argv[])
04077 {
04078   Scheme_Object *l;
04079   Scheme_Env *env;
04080   Scheme_Hash_Table *mapped;
04081   Scheme_Bucket_Table *ht;
04082   Scheme_Bucket **bs;
04083   int i, j;
04084 
04085   if ((argc > 0) && !SCHEME_NAMESPACEP(argv[0]))
04086     scheme_wrong_type("namespace-mapped-symbols", "namespace", 0, argc, argv);
04087 
04088   if (argc)
04089     env = (Scheme_Env *)argv[0];
04090   else
04091     env = scheme_get_env(NULL);
04092   
04093   mapped = scheme_make_hash_table(SCHEME_hash_ptr);
04094 
04095   for (j = 0; j < 2; j++) {
04096     if (j)
04097       ht = env->syntax;
04098     else
04099       ht = env->toplevel;
04100 
04101     bs = ht->buckets;
04102     for (i = ht->size; i--; ) {
04103       Scheme_Bucket *b = bs[i];
04104       if (b && b->val) {
04105        scheme_hash_set(mapped, (Scheme_Object *)b->key, scheme_true);
04106       }
04107     }
04108   }
04109 
04110   if (env->rename_set)
04111     scheme_list_module_rename(env->rename_set, mapped);
04112 
04113   l = scheme_null;
04114   for (i = mapped->size; i--; ) {
04115     if (mapped->vals[i])
04116       l = scheme_make_pair(mapped->keys[i], l);
04117   }
04118 
04119   return l;
04120 }
04121 
04122 static Scheme_Object *namespace_module_registry(int argc, Scheme_Object **argv)
04123 {
04124   if (!SCHEME_NAMESPACEP(argv[0]))
04125     scheme_wrong_type("namespace-module-registry", "namespace", 0, argc, argv);
04126 
04127   return (Scheme_Object *)((Scheme_Env *)argv[0])->module_registry;
04128 }
04129 
04130 static Scheme_Object *do_variable_namespace(const char *who, int tl, int argc, Scheme_Object *argv[])
04131 {
04132   Scheme_Object *v;
04133   Scheme_Env *env;
04134   int ph;
04135 
04136   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_global_ref_type))
04137     env = NULL;
04138   else {
04139     v = SCHEME_PTR_VAL(argv[0]);
04140     env = ((Scheme_Bucket_With_Home *)v)->home;
04141   }
04142 
04143   if (!env)
04144     scheme_wrong_type(who, 
04145                       "variable-reference", 
04146                       0, argc, argv);
04147 
04148   ph = env->phase;
04149   if (tl == 2) {
04150     return scheme_make_integer(ph);
04151   } else if (tl) {
04152     /* return env directly; need to set up  */
04153     if (!env->phase)
04154       scheme_prep_namespace_rename(env);
04155   } else {
04156     /* new namespace: */
04157     Scheme_Env *new_env;
04158     new_env = make_env(env, 0);
04159     new_env->phase = env->phase;
04160     env = new_env;
04161   }
04162 
04163   return (Scheme_Object *)env;
04164 }
04165 
04166 static Scheme_Object *variable_namespace(int argc, Scheme_Object *argv[])
04167 {
04168   return do_variable_namespace("variable-reference->empty-namespace", 0, argc, argv);
04169 }
04170 
04171 static Scheme_Object *variable_top_level_namespace(int argc, Scheme_Object *argv[])
04172 {
04173   return do_variable_namespace("variable-reference->namespace", 1, argc, argv);
04174 }
04175 
04176 static Scheme_Object *variable_phase(int argc, Scheme_Object *argv[])
04177 {
04178   return do_variable_namespace("variable-reference->phase", 2, argc, argv);
04179 }
04180 
04181 static Scheme_Object *variable_p(int argc, Scheme_Object *argv[])
04182 {
04183   Scheme_Env *env;
04184 
04185   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_global_ref_type))
04186     env = NULL;
04187   else
04188     env = ((Scheme_Bucket_With_Home *)SCHEME_PTR_VAL(argv[0]))->home;
04189 
04190   return env ? scheme_true : scheme_false;
04191 }
04192 
04193 static Scheme_Object *variable_module_path(int argc, Scheme_Object *argv[])
04194 {
04195   Scheme_Env *env;
04196 
04197   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_global_ref_type))
04198     env = NULL;
04199   else
04200     env = ((Scheme_Bucket_With_Home *)SCHEME_PTR_VAL(argv[0]))->home;
04201 
04202   if (!env)
04203     scheme_wrong_type("variable-reference->resolved-module-path", "variable-reference", 0, argc, argv);
04204 
04205   if (env->module)
04206     return env->module->modname;
04207   else
04208     return scheme_false;
04209 }
04210 
04211 static Scheme_Object *
04212 now_transforming(int argc, Scheme_Object *argv[])
04213 {
04214   return (scheme_current_thread->current_local_env
04215          ? scheme_true
04216          : scheme_false);
04217 }
04218 
04219 static Scheme_Object *
04220 do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int recur)
04221 {
04222   Scheme_Object *v, *sym, *a[2];
04223   Scheme_Env *menv;
04224   Scheme_Comp_Env *env;
04225   int renamed = 0;
04226 
04227   env = scheme_current_thread->current_local_env;
04228   if (!env)
04229     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
04230                    "%s: not currently transforming",
04231                      name);
04232 
04233   sym = argv[0];
04234 
04235   if (!(SCHEME_STXP(sym) && SCHEME_SYMBOLP(SCHEME_STX_VAL(sym))))
04236     scheme_wrong_type(name, "syntax identifier", 0, argc, argv);
04237 
04238   if (argc > 1) {
04239     scheme_check_proc_arity2(name, 0, 1, argc, argv, 1);
04240     if ((argc > 2)
04241         && SCHEME_TRUEP(argv[2])) { 
04242       Scheme_Comp_Env *stx_env;
04243       if (!SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[2])))
04244        scheme_wrong_type(name, "internal-definition context or #f", 2, argc, argv);
04245       stx_env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(argv[2]);
04246       if (!scheme_is_sub_env(stx_env, env)) {
04247        scheme_raise_exn(MZEXN_FAIL_CONTRACT, "%s: transforming context does "
04248                       "not match given internal-definition context",
04249                          name);
04250       }
04251       env = stx_env;
04252     }
04253   }
04254 
04255   if (scheme_current_thread->current_local_mark)
04256     sym = scheme_add_remove_mark(sym, scheme_current_thread->current_local_mark);
04257 
04258   menv = NULL;
04259 
04260   sym = scheme_stx_activate_certs(sym);
04261 
04262   while (1) {
04263     v = scheme_lookup_binding(sym, env,
04264                            (SCHEME_NULL_FOR_UNBOUND
04265                             + SCHEME_RESOLVE_MODIDS
04266                             + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
04267                             + SCHEME_OUT_OF_CONTEXT_OK + SCHEME_ELIM_CONST),
04268                            scheme_current_thread->current_local_certs, 
04269                            scheme_current_thread->current_local_modidx, 
04270                            &menv, NULL, NULL);
04271     
04272     /* Deref globals */
04273     if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_variable_type))
04274       v = (Scheme_Object *)(SCHEME_VAR_BUCKET(v))->val;
04275     
04276     if (!v || NOT_SAME_TYPE(SCHEME_TYPE(v), scheme_macro_type)) {
04277       if ((argc > 1) && SCHEME_TRUEP(argv[1]))
04278        return _scheme_tail_apply(argv[1], 0, NULL);
04279       else
04280        scheme_arg_mismatch(name,
04281                          (renamed 
04282                           ? "not defined as syntax (after renaming): "
04283                           : "not defined as syntax: "),
04284                          argv[0]);
04285     }
04286     
04287     v = SCHEME_PTR_VAL(v);
04288     if (scheme_is_rename_transformer(v)) {
04289       sym = scheme_rename_transformer_id(v);
04290       sym = scheme_stx_cert(sym, scheme_false, menv, sym, NULL, 1);
04291       renamed = 1;
04292       menv = NULL;
04293       SCHEME_USE_FUEL(1);
04294       if (!recur) {
04295         a[0] = v;
04296         a[1] = sym;
04297         return scheme_values(2, a);
04298       }
04299     } else if (!recur) {
04300       a[0] = v;
04301       a[1] = scheme_false;
04302       return scheme_values(2, a);
04303     } else
04304       return v;
04305   }
04306 }
04307 
04308 static Scheme_Object *
04309 local_exp_time_value(int argc, Scheme_Object *argv[])
04310 {
04311   return do_local_exp_time_value("syntax-local-value", argc, argv, 1);
04312 }
04313 
04314 static Scheme_Object *
04315 local_exp_time_value_one(int argc, Scheme_Object *argv[])
04316 {
04317   return do_local_exp_time_value("syntax-local-value/immediate", argc, argv, 0);
04318 }
04319 
04320 static Scheme_Object *
04321 local_exp_time_name(int argc, Scheme_Object *argv[])
04322 {
04323   Scheme_Object *sym;
04324 
04325   sym = scheme_current_thread->current_local_name;
04326   if (!sym)
04327     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
04328                    "syntax-local-name: not currently transforming");
04329 
04330   return sym;
04331 }
04332 
04333 static Scheme_Object *
04334 local_context(int argc, Scheme_Object *argv[])
04335 {
04336   Scheme_Comp_Env *env;
04337 
04338   env = scheme_current_thread->current_local_env;
04339   if (!env)
04340     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
04341                    "syntax-local-context: not currently transforming");
04342 
04343   if (env->flags & SCHEME_INTDEF_FRAME) {
04344     if (!env->intdef_name) {
04345       Scheme_Object *sym, *pr, *prev = NULL;
04346       Scheme_Comp_Env *lenv = env;
04347       char buf[22];
04348       while (1) {
04349        if (env->flags & SCHEME_FOR_INTDEF) 
04350          lenv = lenv->next;
04351        else {
04352          sprintf(buf, "internal-define%d", intdef_counter++);
04353          sym = scheme_make_symbol(buf); /* uninterned! */
04354          pr = scheme_make_pair(sym, scheme_null);
04355          lenv->intdef_name = pr;
04356          if (prev)
04357            SCHEME_CDR(prev) = pr;
04358          if (lenv->next->flags & SCHEME_INTDEF_FRAME) {
04359            if (lenv->next->intdef_name) {
04360              SCHEME_CDR(pr) = lenv->next->intdef_name;
04361              break;
04362            } else {
04363              prev = pr;
04364              lenv = lenv->next;
04365              /* Go again to continue building the list */
04366            }
04367          } else
04368            break;
04369        }
04370       }
04371     }
04372     return env->intdef_name;
04373   } else if (scheme_is_module_env(env))
04374     return scheme_intern_symbol("module");
04375   else if (scheme_is_module_begin_env(env))
04376     return scheme_intern_symbol("module-begin");
04377   else if (scheme_is_toplevel(env))
04378     return scheme_intern_symbol("top-level");
04379   else
04380     return scheme_intern_symbol("expression");
04381 }
04382 
04383 static Scheme_Object *
04384 local_phase_level(int argc, Scheme_Object *argv[])
04385 {
04386   Scheme_Thread *p = scheme_current_thread;
04387   int phase;
04388 
04389   phase = (p->current_local_env
04390            ? p->current_local_env->genv->phase
04391            : 0);
04392 
04393   return scheme_make_integer(phase);
04394 }
04395 
04396 static Scheme_Object *
04397 local_make_intdef_context(int argc, Scheme_Object *argv[])
04398 {
04399   Scheme_Comp_Env *env, *senv;
04400   Scheme_Object *c, *rib;
04401   void **d;
04402 
04403   d = MALLOC_N(void*, 3);
04404 
04405   env = scheme_current_thread->current_local_env;
04406   if (!env)
04407     scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-make-definition-context: not currently transforming");
04408   
04409   if (argc && SCHEME_TRUEP(argv[0])) {
04410     if (!SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[0])))
04411       scheme_wrong_type("syntax-local-bind-syntaxes", "internal-definition context or #f", 0, argc, argv);
04412     senv = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[0]))[0];
04413     if (!scheme_is_sub_env(senv, env)) {
04414       scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-make-definition-context: transforming context does "
04415                        "not match given internal-definition context");
04416     }
04417     env = senv;
04418     d[1] = argv[0];
04419   }
04420   d[0] = env;
04421 
04422   rib = scheme_make_rename_rib();
04423 
04424   c = scheme_alloc_object();
04425   c->type = scheme_intdef_context_type;
04426   SCHEME_PTR1_VAL(c) = d;
04427   SCHEME_PTR2_VAL(c) = rib;
04428 
04429   return c;
04430 }
04431 
04432 static Scheme_Object *
04433 intdef_context_p(int argc, Scheme_Object *argv[])
04434 {
04435   return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_intdef_context_type)
04436           ? scheme_true
04437           : scheme_false);
04438 }
04439 
04440 static Scheme_Object *intdef_context_seal(int argc, Scheme_Object *argv[])
04441 {
04442   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_intdef_context_type))
04443     scheme_wrong_type("internal-definition-context-seal", 
04444                       "internal-definition context", 0, argc, argv);
04445   
04446   scheme_stx_seal_rib(SCHEME_PTR2_VAL(argv[0]));
04447   return scheme_void;
04448 }
04449 
04450 static Scheme_Object *
04451 id_intdef_remove(int argc, Scheme_Object *argv[])
04452 {
04453   Scheme_Object *l, *res, *skips;
04454 
04455   if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0])))
04456     scheme_wrong_type("identifier-remove-from-definition-context", 
04457                       "syntax identifier", 0, argc, argv);
04458   
04459   l = argv[1];
04460   if (!SAME_TYPE(SCHEME_TYPE(l), scheme_intdef_context_type)) {
04461     while (SCHEME_PAIRP(l)) {
04462       if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(l)), scheme_intdef_context_type))
04463         break;
04464       l = SCHEME_CDR(l);
04465     }
04466     if (!SCHEME_NULLP(l))
04467       scheme_wrong_type("identifier-remove-from-definition-context", 
04468                         "internal-definition context or list of internal-definition contexts", 
04469                         1, argc, argv);
04470   }
04471 
04472   l = argv[1];
04473   if (SAME_TYPE(SCHEME_TYPE(l), scheme_intdef_context_type))
04474     l = scheme_make_pair(l, scheme_null);
04475 
04476   res = argv[0];
04477   skips = scheme_null;
04478 
04479   while (SCHEME_PAIRP(l)) {
04480     res = scheme_stx_id_remove_rib(res, SCHEME_PTR2_VAL(SCHEME_CAR(l)));
04481     skips = scheme_make_pair(SCHEME_PTR2_VAL(SCHEME_CAR(l)), skips);
04482     l = SCHEME_CDR(l);
04483   }
04484 
04485   if (scheme_stx_ribs_matter(res, skips)) {
04486     /* Removing ribs leaves the binding for this identifier in limbo, because
04487        the rib that binds it depends on the removed ribs. Invent in inaccessible
04488        identifier. */
04489     res = scheme_add_remove_mark(res, scheme_new_mark());
04490   }
04491   
04492   return res;
04493 }
04494 
04495 static Scheme_Object *
04496 local_introduce(int argc, Scheme_Object *argv[])
04497 {
04498   Scheme_Comp_Env *env;
04499   Scheme_Object *s;
04500 
04501   env = scheme_current_thread->current_local_env;
04502   if (!env)
04503     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
04504                    "syntax-local-introduce: not currently transforming");
04505 
04506   s = argv[0];
04507   if (!SCHEME_STXP(s))
04508     scheme_wrong_type("syntax-local-introduce", "syntax", 0, argc, argv);
04509 
04510   if (scheme_current_thread->current_local_mark)
04511     s = scheme_add_remove_mark(s, scheme_current_thread->current_local_mark);
04512 
04513   return s;
04514 }
04515 
04516 static Scheme_Object *
04517 local_module_introduce(int argc, Scheme_Object *argv[])
04518 {
04519   Scheme_Comp_Env *env;
04520   Scheme_Object *s, *v;
04521 
04522   env = scheme_current_thread->current_local_env;
04523   if (!env)
04524     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
04525                    "syntax-local-module-introduce: not currently transforming");
04526 
04527   s = argv[0];
04528   if (!SCHEME_STXP(s))
04529     scheme_wrong_type("syntax-local-module-introduce", "syntax", 0, argc, argv);
04530 
04531   v = scheme_stx_source_module(s, 0);
04532   if (SCHEME_FALSEP(v)) {
04533     if (env->genv->rename_set)
04534       s = scheme_add_rename(s, env->genv->rename_set);
04535     if (env->genv->post_ex_rename_set)
04536       s = scheme_add_rename(s, env->genv->post_ex_rename_set);
04537   }
04538 
04539   return s;
04540 }
04541 
04542 static Scheme_Object *
04543 local_get_shadower(int argc, Scheme_Object *argv[])
04544 {
04545   Scheme_Comp_Env *env, *frame;
04546   Scheme_Object *sym, *esym, *sym_marks = NULL, *orig_sym, *uid = NULL, *env_marks;
04547 
04548   env = scheme_current_thread->current_local_env;
04549   if (!env)
04550     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
04551                    "syntax-local-get-shadower: not currently transforming");
04552 
04553   sym = argv[0];
04554   orig_sym = sym;
04555 
04556   if (!(SCHEME_STXP(sym) && SCHEME_SYMBOLP(SCHEME_STX_VAL(sym))))
04557     scheme_wrong_type("syntax-local-get-shadower", "syntax identifier", 0, argc, argv);
04558 
04559   sym_marks = scheme_stx_extract_marks(sym);
04560 
04561   /* Walk backward through the frames, looking for a renaming binding
04562      with the same marks as the given identifier, sym. Skip over
04563      unsealed ribs, though. When we find a match, rename the given
04564      identifier so that it matches frame. */
04565   for (frame = env; frame->next != NULL; frame = frame->next) {
04566     int i;
04567 
04568     for (i = frame->num_bindings; i--; ) {
04569       if (frame->values[i]) {
04570        if (SAME_OBJ(SCHEME_STX_VAL(sym), SCHEME_STX_VAL(frame->values[i])))  {
04571          esym = frame->values[i];
04572          env_marks = scheme_stx_extract_marks(esym);
04573          if (scheme_equal(env_marks, sym_marks)) {
04574            sym = esym;
04575            if (frame->uids)
04576              uid = frame->uids[i];
04577            else
04578              uid = frame->uid;
04579            break;
04580          }
04581        }
04582       }
04583     }
04584     if (uid)
04585       break;
04586 
04587     if (!COMPILE_DATA(frame)->sealed || *COMPILE_DATA(frame)->sealed) {
04588       for (i = COMPILE_DATA(frame)->num_const; i--; ) {
04589         if (!(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) {
04590           if (SAME_OBJ(SCHEME_STX_VAL(sym), 
04591                        SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i]))) {
04592             esym = COMPILE_DATA(frame)->const_names[i];
04593             env_marks = scheme_stx_extract_marks(esym);
04594             if (scheme_equal(env_marks, sym_marks)) { /* This used to have 1 || --- why? */
04595               sym = esym;
04596               if (COMPILE_DATA(frame)->const_uids)
04597                 uid = COMPILE_DATA(frame)->const_uids[i];
04598               else
04599                 uid = frame->uid;
04600               break;
04601             }
04602          }
04603        }
04604       }
04605     }
04606     if (uid)
04607       break;
04608   }
04609 
04610   if (!uid) {
04611     /* No lexical shadower, but strip module context, if any */
04612     sym = scheme_stx_strip_module_context(sym);
04613     /* Add current module context, if any */
04614     sym = local_module_introduce(1, &sym);
04615     return sym;
04616   }
04617 
04618   {
04619     Scheme_Object *rn, *result;
04620 
04621     result = scheme_datum_to_syntax(SCHEME_STX_VAL(sym), orig_sym, sym, 0, 0);
04622     ((Scheme_Stx *)result)->props = ((Scheme_Stx *)orig_sym)->props;
04623     
04624     rn = scheme_make_rename(uid, 1);
04625     scheme_set_rename(rn, 0, result);
04626 
04627     result = scheme_add_rename(result, rn);
04628 
04629     return result;
04630   }
04631 }
04632 
04633 static Scheme_Object *
04634 introducer_proc(void *mark, int argc, Scheme_Object *argv[])
04635 {
04636   Scheme_Object *s;
04637 
04638   s = argv[0];
04639   if (!SCHEME_STXP(s))
04640     scheme_wrong_type("syntax-introducer", "syntax", 0, argc, argv);
04641 
04642   return scheme_add_remove_mark(s, (Scheme_Object *)mark);
04643 }
04644 
04645 static Scheme_Object *
04646 make_introducer(int argc, Scheme_Object *argv[])
04647 {
04648   Scheme_Object *mark;
04649 
04650   mark = scheme_new_mark();
04651 
04652   return scheme_make_closed_prim_w_arity(introducer_proc, mark,
04653                                     "syntax-introducer", 1, 1);
04654 }
04655 
04656 static Scheme_Object *
04657 delta_introducer_proc(void *_i_plus_m, int argc, Scheme_Object *argv[])
04658 {
04659   Scheme_Object *p = (Scheme_Object *)_i_plus_m, *l, *v, *a[1];
04660   const char *who = "delta introducer attached to a rename transformer";
04661 
04662   v = argv[0];
04663   if (!SCHEME_STXP(v) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(v))) {
04664     scheme_wrong_type(who, "identifier", 0, argc, argv);
04665   }
04666   
04667   /* Apply mapping functions: */
04668   l = SCHEME_CDR(p);
04669   while (SCHEME_PAIRP(l)) {
04670     a[0] = v;
04671     v = _scheme_apply(SCHEME_CAR(l), 1, a);
04672     l = SCHEME_CDR(l);
04673   }
04674 
04675   /* Apply delta-introducing functions: */
04676   l = SCHEME_CAR(p);
04677   while (SCHEME_PAIRP(l)) {
04678     a[0] = v;
04679     v = _scheme_apply(SCHEME_CAR(l), 1, a);
04680     if (!SCHEME_STXP(v) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(v))) {
04681       a[0] = v;
04682       scheme_wrong_type(who, "identifier", -1, -1, a);
04683     }
04684     l = SCHEME_CDR(l);
04685   }
04686 
04687   return v;
04688 }
04689 
04690 static Scheme_Object *
04691 local_make_delta_introduce(int argc, Scheme_Object *argv[])
04692 {
04693   Scheme_Object *sym, *binder, *introducer, *a[2], *v;
04694   Scheme_Object *introducers = scheme_null, *mappers = scheme_null;
04695   int renamed = 0;
04696   Scheme_Comp_Env *env;
04697   Scheme_Object *certs;
04698 
04699   env = scheme_current_thread->current_local_env;
04700   if (!env)
04701     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
04702                    "syntax-local-make-delta-introducer: not currently transforming");
04703 
04704   if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0])))
04705     scheme_wrong_type("syntax-local-make-delta-introducer", "syntax identifier", 0, argc, argv);
04706 
04707   sym = argv[0];
04708 
04709   sym = scheme_stx_activate_certs(sym);
04710 
04711   certs = scheme_current_thread->current_local_certs;
04712 
04713   while (1) {
04714     binder = NULL;
04715 
04716     v = scheme_lookup_binding(sym, env,
04717                            (SCHEME_NULL_FOR_UNBOUND
04718                             + SCHEME_RESOLVE_MODIDS
04719                             + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
04720                             + SCHEME_OUT_OF_CONTEXT_OK + SCHEME_ELIM_CONST),
04721                            certs, 
04722                            scheme_current_thread->current_local_modidx, 
04723                            NULL, NULL, &binder);
04724     
04725     /* Deref globals */
04726     if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_variable_type))
04727       v = (Scheme_Object *)(SCHEME_VAR_BUCKET(v))->val;
04728     
04729     if (!v || NOT_SAME_TYPE(SCHEME_TYPE(v), scheme_macro_type)) {
04730       scheme_arg_mismatch("syntax-local-make-delta-introducer",
04731                           (renamed 
04732                            ? "not defined as syntax (after renaming): "
04733                            : "not defined as syntax: "),
04734                           argv[0]);
04735     }
04736 
04737     if (!binder) {
04738       /* Not a lexical biding. Tell make-syntax-delta-introducer to
04739          use module-binding information. */
04740       binder = scheme_false;
04741     }
04742 
04743     a[0] = sym;
04744     a[1] = binder;
04745     introducer = scheme_syntax_make_transfer_intro(2, a);
04746     introducers = scheme_make_pair(introducer, introducers);
04747     
04748     v = SCHEME_PTR_VAL(v);
04749     if (scheme_is_rename_transformer(v)) {
04750       certs = scheme_stx_extract_certs(sym, certs);
04751 
04752       sym = scheme_rename_transformer_id(v);
04753       sym = scheme_stx_activate_certs(sym);
04754 
04755       v = SCHEME_PTR2_VAL(v);
04756       if (!SCHEME_FALSEP(v))
04757         mappers = scheme_make_pair(v, mappers);
04758 
04759       renamed = 1;
04760       SCHEME_USE_FUEL(1);
04761     } else {
04762       /* that's the end of the chain */
04763       mappers = scheme_reverse(mappers);
04764       return scheme_make_closed_prim_w_arity(delta_introducer_proc, 
04765                                              scheme_make_pair(introducers, mappers),
04766                                              "syntax-delta-introducer", 1, 1);
04767     }
04768   }
04769 }
04770 
04771 static Scheme_Object *
04772 certifier(void *_data, int argc, Scheme_Object **argv)
04773 {
04774   Scheme_Object *s, **cert_data = (Scheme_Object **)_data;
04775   Scheme_Object *mark = scheme_false;
04776 
04777   s = argv[0];
04778   if (!SCHEME_STXP(s))
04779     scheme_wrong_type("certifier", "syntax", 0, argc, argv);
04780 
04781   if (argc > 2) {
04782     if (SCHEME_TRUEP(argv[2])) {
04783       if (SCHEME_CLSD_PRIMP(argv[2])
04784          && (((Scheme_Closed_Primitive_Proc *)argv[2])->prim_val == introducer_proc))
04785        mark = (Scheme_Object *)((Scheme_Closed_Primitive_Proc *)argv[2])->data;
04786       else {
04787        scheme_wrong_type("certifier", 
04788                        "procedure from make-syntax-introducer or #f", 
04789                        2, argc, argv);
04790        return NULL;
04791       }
04792     }
04793   }
04794 
04795   if (cert_data[0] || cert_data[1] || cert_data[2]) {
04796     int as_active = SCHEME_TRUEP(cert_data[3]);
04797     s = scheme_stx_cert(s, mark, 
04798                      (Scheme_Env *)(cert_data[1] ? cert_data[1] : cert_data[2]),
04799                      cert_data[0],
04800                      ((argc > 1) && SCHEME_TRUEP(argv[1])) ? argv[1] : NULL,
04801                      as_active);
04802     if (cert_data[1] && cert_data[2] && !SAME_OBJ(cert_data[1], cert_data[2])) {
04803       /* Have module we're expanding, in addition to module that bound
04804         the expander. */
04805       s = scheme_stx_cert(s, mark, (Scheme_Env *)cert_data[2],
04806                        NULL,
04807                        ((argc > 1) && SCHEME_TRUEP(argv[1])) ? argv[1] : NULL,
04808                        as_active);
04809     }
04810   }
04811 
04812   return s;
04813 }
04814 
04815 static Scheme_Object *
04816 local_certify(int argc, Scheme_Object *argv[])
04817 {
04818   Scheme_Object **cert_data;
04819   Scheme_Env *menv;
04820   int active = 0;
04821 
04822   if (!scheme_current_thread->current_local_env)
04823     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
04824                    "syntax-local-certifier: not currently transforming");
04825   menv = scheme_current_thread->current_local_menv;
04826 
04827   if (argc)
04828     active = SCHEME_TRUEP(argv[0]);
04829 
04830   cert_data = MALLOC_N(Scheme_Object*, 4);
04831   cert_data[0] = scheme_current_thread->current_local_certs;
04832   /* Module that bound the macro we're now running: */
04833   cert_data[1] = (Scheme_Object *)((menv && menv->module) ? menv : NULL);
04834   /* Module that we're currently expanding: */
04835   menv = scheme_current_thread->current_local_env->genv;
04836   cert_data[2] = (Scheme_Object *)((menv && menv->module) ? menv : NULL);
04837   cert_data[3] = (active ? scheme_true : scheme_false);
04838 
04839   return scheme_make_closed_prim_w_arity(certifier,
04840                                     cert_data,
04841                                     "certifier",
04842                                     1, 3);
04843 }
04844 
04845 static Scheme_Object *
04846 local_module_exports(int argc, Scheme_Object *argv[])
04847 {
04848   Scheme_Comp_Env *env;
04849 
04850   env = scheme_current_thread->current_local_env;
04851   
04852   if (!env)
04853     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
04854                    "syntax-local-module-exports: not currently transforming");
04855 
04856   return scheme_module_exported_list(argv[0], env->genv);
04857 }
04858 
04859 static Scheme_Object *
04860 local_module_definitions(int argc, Scheme_Object *argv[])
04861 {
04862   Scheme_Object *a[2];
04863 
04864   if (!scheme_current_thread->current_local_env
04865       || !scheme_current_thread->current_local_bindings)
04866     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
04867                    "syntax-local-module-defined-identifiers: not currently transforming module provides");
04868   
04869   a[0] = SCHEME_CDR(scheme_current_thread->current_local_bindings);
04870   a[1] = SCHEME_CDR(a[0]);
04871   a[0] = SCHEME_CAR(a[0]);
04872 
04873   return scheme_values(2, a);
04874 }
04875 
04876 static Scheme_Object *
04877 local_module_imports(int argc, Scheme_Object *argv[])
04878 {
04879   if (!scheme_current_thread->current_local_env
04880       || !scheme_current_thread->current_local_bindings)
04881     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
04882                    "syntax-local-module-required-identifiers: not currently transforming module provides");
04883 
04884   if (SCHEME_TRUEP(argv[0]) && !scheme_is_module_path(argv[0]))
04885     scheme_wrong_type("syntax-local-module-required-identifiers", "module-path or #f", 0, argc, argv);
04886   
04887   if (!SCHEME_FALSEP(argv[1]) 
04888       && !SAME_OBJ(scheme_true, argv[1])
04889       && !SCHEME_INTP(argv[1])
04890       && !SCHEME_BIGNUMP(argv[1]))
04891     scheme_wrong_type("syntax-local-module-required-identifiers", "exact integer, #f, or #t", 1, argc, argv);
04892   
04893   return scheme_module_imported_list(scheme_current_thread->current_local_env->genv,
04894                                      scheme_current_thread->current_local_bindings,
04895                                      argv[0],
04896                                      argv[1]);
04897 }
04898 
04899 static Scheme_Object *
04900 local_module_expanding_provides(int argc, Scheme_Object *argv[])
04901 {
04902   if (scheme_current_thread->current_local_env
04903       && scheme_current_thread->current_local_bindings)
04904     return scheme_true;
04905   else
04906     return scheme_false;
04907 }
04908 
04909 static Scheme_Object *
04910 do_local_lift_expr(const char *who, int stx_pos, int argc, Scheme_Object *argv[])
04911 {
04912   Scheme_Env *menv;
04913   Scheme_Comp_Env *env, *orig_env;
04914   Scheme_Object *id, *ids, *rev_ids, *local_mark, *expr, *data, *vec, *id_sym;
04915   Scheme_Lift_Capture_Proc cp;  
04916   Scheme_Object *orig_expr;
04917   int count;
04918   char buf[24];
04919 
04920   if (stx_pos) {
04921     if (SCHEME_INTP(argv[0])) {
04922       count = SCHEME_INT_VAL(argv[0]);
04923     } else if (SCHEME_BIGNUMP(argv[0])) {
04924       if (SCHEME_BIGPOS(argv[0]))
04925         scheme_raise_out_of_memory(NULL, NULL);
04926       count = -1;
04927     } else
04928       count = -1;
04929 
04930     if (count < 0)
04931       scheme_wrong_type(who, "exact nonnegative integer", 0, argc, argv);
04932   } else
04933     count = 1;
04934 
04935   expr = argv[stx_pos];
04936   if (!SCHEME_STXP(expr))
04937     scheme_wrong_type(who, "syntax", stx_pos, argc, argv);
04938 
04939   env = orig_env = scheme_current_thread->current_local_env;
04940   local_mark = scheme_current_thread->current_local_mark;
04941 
04942   if (!env)
04943     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
04944                    "%s: not currently transforming",
04945                      who);
04946 
04947   while (env && !COMPILE_DATA(env)->lifts) {
04948     env = env->next;
04949   }
04950 
04951   if (env)
04952     if (SCHEME_FALSEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0]))
04953       env = NULL;
04954 
04955   if (!env)
04956     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
04957                    "syntax-local-lift-expression: no lift target");
04958   
04959   expr = scheme_add_remove_mark(expr, local_mark);
04960 
04961   /* We don't really need a new symbol each time, since the mark
04962      will generate new bindings. But lots of things work better or faster
04963      when different bindings have different symbols. Use env->genv->id_counter
04964      to help keep name generation deterministic within a module. */
04965   rev_ids = scheme_null;
04966   while (count--) {
04967     sprintf(buf, "lifted.%d", env->genv->id_counter++);
04968     id_sym = scheme_intern_exact_parallel_symbol(buf, strlen(buf));
04969 
04970     id = scheme_datum_to_syntax(id_sym, scheme_false, scheme_false, 0, 0);
04971     id = scheme_add_remove_mark(id, scheme_new_mark());
04972 
04973     rev_ids = scheme_make_pair(id, rev_ids);
04974   }
04975   ids = scheme_reverse(rev_ids);
04976 
04977   vec = COMPILE_DATA(env)->lifts;
04978   cp = *(Scheme_Lift_Capture_Proc *)SCHEME_VEC_ELS(vec)[1];
04979   data = SCHEME_VEC_ELS(vec)[2];
04980 
04981   menv = scheme_current_thread->current_local_menv;
04982 
04983   expr = scheme_stx_cert(expr, scheme_false, 
04984                       (menv && menv->module) ? menv : NULL,
04985                       scheme_current_thread->current_local_certs, 
04986                       NULL, 1);
04987 
04988   expr = scheme_stx_activate_certs(expr);
04989   orig_expr = expr;
04990 
04991   expr = cp(data, &ids, expr, orig_env);
04992 
04993   expr = scheme_make_pair(expr, SCHEME_VEC_ELS(vec)[0]);
04994   SCHEME_VEC_ELS(vec)[0] = expr;
04995 
04996   rev_ids = scheme_null;
04997   for (; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) {
04998     id = SCHEME_CAR(ids);
04999     SCHEME_EXPAND_OBSERVE_LOCAL_LIFT(scheme_get_expand_observe(), id, orig_expr);
05000     id = scheme_add_remove_mark(id, local_mark);
05001     rev_ids = scheme_make_pair(id, rev_ids);
05002   }
05003   ids = scheme_reverse(rev_ids);
05004 
05005   return ids;
05006 }
05007 
05008 static Scheme_Object *
05009 local_lift_expr(int argc, Scheme_Object *argv[])
05010 {
05011   Scheme_Object *ids;
05012   ids = do_local_lift_expr("syntax-local-lift-expression", 0, argc, argv);
05013   return SCHEME_CAR(ids);
05014 }
05015 
05016 static Scheme_Object *
05017 local_lift_exprs(int argc, Scheme_Object *argv[])
05018 {
05019   return do_local_lift_expr("syntax-local-lift-values-expression", 1, argc, argv);
05020 }
05021 
05022 static Scheme_Object *
05023 local_lift_context(int argc, Scheme_Object *argv[])
05024 {
05025   Scheme_Comp_Env *env;
05026 
05027   env = scheme_current_thread->current_local_env;
05028 
05029   if (!env)
05030     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
05031                    "syntax-local-lift-context: not currently transforming");
05032 
05033   while (env && !COMPILE_DATA(env)->lifts) {
05034     env = env->next;
05035   }
05036 
05037   if (!env)
05038     return scheme_false;
05039   
05040   return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[4];
05041 }
05042 
05043 static Scheme_Object *
05044 local_lift_end_statement(int argc, Scheme_Object *argv[])
05045 {
05046   Scheme_Comp_Env *env;
05047   Scheme_Object *local_mark, *expr, *pr;
05048   Scheme_Object *orig_expr;
05049 
05050   expr = argv[0];
05051   if (!SCHEME_STXP(expr))
05052     scheme_wrong_type("syntax-local-lift-module-end-declaration", "syntax", 0, argc, argv);
05053 
05054   env = scheme_current_thread->current_local_env;
05055   local_mark = scheme_current_thread->current_local_mark;
05056 
05057   if (!env)
05058     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
05059                    "syntax-local-lift-module-end-declaration: not currently transforming");
05060 
05061   while (env) {
05062     if ((COMPILE_DATA(env)->lifts)
05063         && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3]))
05064       break;
05065     env = env->next;
05066   }
05067 
05068   if (!env)
05069     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
05070                    "syntax-local-lift-module-end-declaration: not currently transforming"
05071                      " a run-time expression in a module declaration");
05072   
05073   expr = scheme_add_remove_mark(expr, local_mark);
05074   orig_expr = expr;
05075 
05076   pr = scheme_make_pair(expr, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3]);
05077   SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3] = pr;
05078 
05079   SCHEME_EXPAND_OBSERVE_LIFT_STATEMENT(scheme_get_expand_observe(), orig_expr);
05080   
05081   return scheme_void;
05082 }
05083 
05084 static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[])
05085 {
05086   Scheme_Comp_Env *env;
05087   Scheme_Object *local_mark, *mark, *data, *pr, *form;
05088   long phase;
05089 
05090   if (!SCHEME_STXP(argv[1]))
05091     scheme_wrong_type("syntax-local-lift-require", "syntax", 1, argc, argv);
05092 
05093   env = scheme_current_thread->current_local_env;
05094   local_mark = scheme_current_thread->current_local_mark;
05095   phase = env->genv->phase;
05096 
05097   if (!env)
05098     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
05099                    "syntax-local-lift-require: not currently transforming");
05100 
05101   data = NULL;
05102 
05103   while (env) {
05104     if (COMPILE_DATA(env)->lifts
05105         && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[5])) {
05106       data = SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[5];
05107       if (SCHEME_RPAIRP(data)
05108           && !SCHEME_CAR(data)) {
05109         env = (Scheme_Comp_Env *)SCHEME_CDR(data);
05110       } else
05111         break;
05112     } else
05113       env = env->next;
05114   }
05115 
05116   if (!env)
05117     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
05118                    "syntax-local-lift-requires: could not find target context");
05119 
05120   
05121   mark = scheme_new_mark();
05122 
05123   if (SCHEME_RPAIRP(data))
05124     form = scheme_parse_lifted_require(argv[0], phase, mark, SCHEME_CAR(data));
05125   else
05126     form = scheme_toplevel_require_for_expand(argv[0], phase, env, mark);
05127   
05128   pr = scheme_make_pair(form, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6]);
05129   SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6] = pr;
05130 
05131   form = argv[1];
05132   form = scheme_add_remove_mark(form, local_mark);
05133   form = scheme_add_remove_mark(form, mark);
05134   form = scheme_add_remove_mark(form, local_mark);
05135 
05136   return form;
05137 }
05138 
05139 static Scheme_Object *local_lift_provide(int argc, Scheme_Object *argv[])
05140 {
05141   Scheme_Comp_Env *env;
05142   Scheme_Object *pr, *form, *local_mark;
05143 
05144   form = argv[0];
05145   if (!SCHEME_STXP(form))
05146     scheme_wrong_type("syntax-local-lift-provide", "syntax", 1, argc, argv);
05147 
05148   env = scheme_current_thread->current_local_env;
05149   local_mark = scheme_current_thread->current_local_mark;
05150 
05151   if (!env)
05152     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
05153                    "syntax-local-lift-provide: not currently transforming");
05154 
05155   while (env) {
05156     if (COMPILE_DATA(env)->lifts
05157         && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7])) {
05158       break;
05159     } else
05160       env = env->next;
05161   }
05162 
05163   if (!env)
05164     scheme_raise_exn(MZEXN_FAIL_CONTRACT, 
05165                    "syntax-local-lift-provide: not expanding in a module run-time body");
05166   
05167   form = scheme_add_remove_mark(form, local_mark);
05168   form = scheme_datum_to_syntax(scheme_make_pair(scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), 
05169                                                                         scheme_false, scheme_sys_wraps(env), 
05170                                                                         0, 0),
05171                                                  scheme_make_pair(form, scheme_null)),
05172                                 form, scheme_false, 0, 0);
05173 
05174   pr = scheme_make_pair(form, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7]);
05175   SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7] = pr;
05176 
05177   return scheme_void;
05178 }
05179 
05180 static Scheme_Object *
05181 make_set_transformer(int argc, Scheme_Object *argv[])
05182 {
05183   Scheme_Object *v;
05184 
05185   scheme_check_proc_arity("make-set!-transformer", 1, 0, argc, argv);
05186 
05187   v = scheme_alloc_small_object();
05188   v->type = scheme_set_macro_type;
05189   SCHEME_PTR_VAL(v) = argv[0];
05190 
05191   return v;
05192 }
05193 
05194 static Scheme_Object *
05195 set_transformer_p(int argc, Scheme_Object *argv[])
05196 {
05197   return (scheme_is_set_transformer(argv[0])
05198          ? scheme_true
05199          : scheme_false);
05200 }
05201 
05202 static Scheme_Object *
05203 set_transformer_proc(int argc, Scheme_Object *argv[])
05204 {
05205   if (!scheme_is_set_transformer(argv[0]))
05206     scheme_wrong_type("set!-transformer-procedure", "set!-transformer", 1, argc, argv);
05207 
05208   return scheme_set_transformer_proc(argv[0]);
05209 }
05210 
05211 static Scheme_Object *
05212 make_rename_transformer(int argc, Scheme_Object *argv[])
05213 {
05214   Scheme_Object *v;
05215 
05216   if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0])))
05217     scheme_wrong_type("make-rename-transformer", "syntax identifier", 0, argc, argv);
05218 
05219   if (argc > 1)
05220     scheme_check_proc_arity("make-rename-transformer", 1, 1, argc, argv);
05221   
05222   v = scheme_alloc_object();
05223   v->type = scheme_id_macro_type;
05224   SCHEME_PTR1_VAL(v) = argv[0];
05225   SCHEME_PTR2_VAL(v) = ((argc > 1) ? argv[1] : scheme_false);
05226 
05227   return v;
05228 }
05229 
05230 static Scheme_Object *
05231 rename_transformer_target(int argc, Scheme_Object *argv[])
05232 {
05233   if (!scheme_is_rename_transformer(argv[0]))
05234     scheme_wrong_type("rename-transformer-target", "rename transformer", 0, argc, argv);
05235 
05236   return scheme_rename_transformer_id(argv[0]);
05237 }
05238 
05239 static Scheme_Object *
05240 rename_transformer_p(int argc, Scheme_Object *argv[])
05241 {
05242   return (scheme_is_rename_transformer(argv[0])
05243          ? scheme_true
05244          : scheme_false);
05245 }
05246 
05247 
05248 /*========================================================================*/
05249 /*                    [un]marshalling variable reference                  */
05250 /*========================================================================*/
05251 
05252 static Scheme_Object *write_toplevel(Scheme_Object *obj)
05253 {
05254   int pos, flags;
05255   Scheme_Object *pr;
05256 
05257   pos = SCHEME_TOPLEVEL_POS(obj);
05258   flags = (SCHEME_TOPLEVEL_FLAGS(obj) & SCHEME_TOPLEVEL_FLAGS_MASK);
05259 
05260   pr = (flags
05261        ? scheme_make_pair(scheme_make_integer(pos),
05262                         scheme_make_integer(flags))
05263        : scheme_make_integer(pos));
05264 
05265   return scheme_make_pair(scheme_make_integer(SCHEME_TOPLEVEL_DEPTH(obj)),
05266                        pr);
05267 }
05268 
05269 static Scheme_Object *read_toplevel(Scheme_Object *obj)
05270 {
05271   int pos, depth, flags;
05272 
05273   if (!SCHEME_PAIRP(obj)) return NULL;
05274 
05275   depth = SCHEME_INT_VAL(SCHEME_CAR(obj));
05276   obj = SCHEME_CDR(obj);
05277 
05278   if (SCHEME_PAIRP(obj)) {
05279     pos = SCHEME_INT_VAL(SCHEME_CAR(obj));
05280     flags = SCHEME_INT_VAL(SCHEME_CDR(obj)) & SCHEME_TOPLEVEL_FLAGS_MASK;
05281   } else {
05282     pos = SCHEME_INT_VAL(obj);
05283     flags = 0;
05284   }
05285 
05286   return make_toplevel(depth, pos, 1, flags);
05287 }
05288 
05289 static Scheme_Object *write_variable(Scheme_Object *obj)
05290   /* #%kernel references are handled in print.c, instead */
05291 {
05292   Scheme_Object *sym;
05293   Scheme_Env *home;
05294   Scheme_Module *m;
05295     
05296   sym = (Scheme_Object *)(SCHEME_VAR_BUCKET(obj))->key;
05297     
05298   home = ((Scheme_Bucket_With_Home *)obj)->home;
05299   m = home->module;
05300     
05301   /* If we get a writeable variable (instead of a module variable),
05302      it must be a reference to a module referenced directly by its
05303      a symbolic name (i.e., no path). */
05304     
05305   if (m) {
05306     sym = scheme_make_pair(m->modname, sym);
05307     if (home->mod_phase)
05308       sym = scheme_make_pair(scheme_make_integer(home->mod_phase), sym);
05309   }
05310 
05311   return sym;
05312 }
05313 
05314 static Scheme_Object *read_variable(Scheme_Object *obj)
05315   /* #%kernel references are handled in read.c, instead */
05316 {
05317   Scheme_Env *env;
05318 
05319   env = scheme_get_env(NULL);
05320 
05321   if (!SCHEME_SYMBOLP(obj)) return NULL;
05322 
05323   return (Scheme_Object *)scheme_global_bucket(obj, env);
05324 }
05325 
05326 static Scheme_Object *write_module_variable(Scheme_Object *obj)
05327 {
05328   scheme_signal_error("module variables should have been handled in print.c");
05329   return NULL;
05330 }
05331 
05332 static Scheme_Object *read_module_variable(Scheme_Object *obj)
05333 {
05334   scheme_signal_error("module variables should have been handled in read.c");
05335   return NULL;
05336 }
05337 
05338 static Scheme_Object *write_local(Scheme_Object *obj)
05339 {
05340   return scheme_make_integer(SCHEME_LOCAL_POS(obj));
05341 }
05342 
05343 static Scheme_Object *do_read_local(Scheme_Type t, Scheme_Object *obj)
05344 {
05345   int n, flags;
05346 
05347   if (SCHEME_PAIRP(obj)) {
05348     flags = SCHEME_INT_VAL(SCHEME_CAR(obj));
05349     obj = SCHEME_CDR(obj);
05350   } else
05351     flags = 0;
05352 
05353   n = SCHEME_INT_VAL(obj);
05354 
05355   return scheme_make_local(t, n, flags);
05356 }
05357 
05358 static Scheme_Object *read_local(Scheme_Object *obj)
05359 {
05360   return do_read_local(scheme_local_type, obj);
05361 }
05362 
05363 static Scheme_Object *read_local_unbox(Scheme_Object *obj)
05364 {
05365   return do_read_local(scheme_local_unbox_type, obj);
05366 }
05367 
05368 static Scheme_Object *write_resolve_prefix(Scheme_Object *obj)
05369 {
05370   Resolve_Prefix *rp = (Resolve_Prefix *)obj;
05371   Scheme_Object *tv, *sv, *ds;
05372   int i;
05373 
05374   i = rp->num_toplevels;
05375   tv = scheme_make_vector(i, NULL);
05376   while (i--) {
05377     SCHEME_VEC_ELS(tv)[i] = rp->toplevels[i];
05378   }
05379 
05380   i = rp->num_stxes;
05381   sv = scheme_make_vector(i, NULL);
05382   while (i--) {
05383     if (rp->stxes[i]) {
05384       if (SCHEME_INTP(rp->stxes[i])) {
05385         /* Need to foce this object, so we can write it.
05386            This should only happen if we're writing back 
05387            code loaded from bytecode. */
05388         scheme_load_delayed_syntax(rp, i);
05389       }
05390 
05391       ds = scheme_alloc_small_object();
05392       ds->type = scheme_delay_syntax_type;
05393       SCHEME_PTR_VAL(ds) = rp->stxes[i];
05394     } else
05395       ds = scheme_false;
05396     SCHEME_VEC_ELS(sv)[i] = ds;
05397   }
05398 
05399   return scheme_make_pair(scheme_make_integer(rp->num_lifts), scheme_make_pair(tv, sv));
05400 }
05401 
05402 static Scheme_Object *read_resolve_prefix(Scheme_Object *obj)
05403 {
05404   Resolve_Prefix *rp;
05405   Scheme_Object *tv, *sv, **a, *stx;
05406   int i;
05407 
05408   if (!SCHEME_PAIRP(obj)) return NULL;
05409 
05410   i = SCHEME_INT_VAL(SCHEME_CAR(obj));
05411   if (i < 0) return NULL;
05412 
05413   obj = SCHEME_CDR(obj);
05414   if (!SCHEME_PAIRP(obj)) return NULL;
05415 
05416   tv = SCHEME_CAR(obj);
05417   sv = SCHEME_CDR(obj);
05418 
05419   if (!SCHEME_VECTORP(tv)) return NULL;
05420   if (!SCHEME_VECTORP(sv)) return NULL;
05421 
05422   rp = MALLOC_ONE_TAGGED(Resolve_Prefix);
05423   rp->so.type = scheme_resolve_prefix_type;
05424   rp->num_toplevels = SCHEME_VEC_SIZE(tv);
05425   rp->num_stxes = SCHEME_VEC_SIZE(sv);
05426   rp->num_lifts = i;
05427 
05428   i = rp->num_toplevels;
05429   a = MALLOC_N(Scheme_Object *, i);
05430   while (i--) {
05431     a[i] = SCHEME_VEC_ELS(tv)[i];
05432   }
05433   rp->toplevels = a;
05434   
05435   i = rp->num_stxes;
05436   a = MALLOC_N(Scheme_Object *, i);
05437   while (i--) {
05438     stx = SCHEME_VEC_ELS(sv)[i];
05439     if (SCHEME_FALSEP(stx)) {
05440       stx = NULL;
05441     } else if (SCHEME_RPAIRP(stx)) {
05442       struct Scheme_Load_Delay *d;
05443       Scheme_Object *pr;
05444       d = (struct Scheme_Load_Delay *)SCHEME_CDR(stx);
05445       stx = SCHEME_CAR(stx);
05446       pr = rp->delay_info_rpair;
05447       if (!pr) {
05448         pr = scheme_make_raw_pair(scheme_make_integer(0), (Scheme_Object *)d);
05449         rp->delay_info_rpair = pr;
05450       }
05451       SCHEME_CAR(pr) = scheme_make_integer(SCHEME_INT_VAL(SCHEME_CAR(pr)) + 1);
05452     } else {
05453       if (!SCHEME_STXP(stx)) return NULL;
05454     }
05455     a[i] = stx;
05456   }
05457   rp->stxes = a;
05458 
05459   return (Scheme_Object *)rp;
05460 }
05461 
05462 /*========================================================================*/
05463 /*                         precise GC traversers                          */
05464 /*========================================================================*/
05465 
05466 #ifdef MZ_PRECISE_GC
05467 
05468 START_XFORM_SKIP;
05469 
05470 #define MARKS_FOR_ENV_C
05471 #include "mzmark.c"
05472 
05473 static void register_traversers(void)
05474 {
05475   GC_REG_TRAV(scheme_rt_comp_env, mark_comp_env);
05476   GC_REG_TRAV(scheme_rt_resolve_info, mark_resolve_info);
05477   GC_REG_TRAV(scheme_rt_optimize_info, mark_optimize_info);
05478   GC_REG_TRAV(scheme_rt_sfs_info, mark_sfs_info);
05479 }
05480 
05481 END_XFORM_SKIP;
05482 
05483 #endif