#include "schpriv.h"

#include "schminc.h"

#include "schmach.h"

#include "schexpobs.h"

#ifdef MZ_USE_FUTURES

# include "future.h"

#define GLOBAL_TABLE_SIZE 500

SHARED_OK int scheme_allow_set_undefined;

void scheme_set_allow_set_undefined(int v) { scheme_allow_set_undefined = v; }

int scheme_get_allow_set_undefined() { return scheme_allow_set_undefined; }

THREAD_LOCAL_DECL(int scheme_starting_up);

Scheme_Object *scheme_varref_const_p_proc;

READ_ONLY static Scheme_Object *kernel_symbol;

READ_ONLY static Scheme_Env *kernel_env;

READ_ONLY static Scheme_Env *unsafe_env;

READ_ONLY static Scheme_Env *flfxnum_env;

READ_ONLY static Scheme_Env *extfl_env;

READ_ONLY static Scheme_Env *futures_env;

THREAD_LOCAL_DECL(static int builtin_ref_counter);

THREAD_LOCAL_DECL(static int intdef_counter);

THREAD_LOCAL_DECL(static Scheme_Bucket_Table *literal_string_table);

THREAD_LOCAL_DECL(static Scheme_Bucket_Table *literal_number_table);

static void make_kernel_env(void);

static Scheme_Env *make_env(Scheme_Env *base, int toplevel_size);

static Scheme_Env *make_empty_inited_env(int toplevel_size);

static Scheme_Env *make_empty_not_inited_env(int toplevel_size);

static Scheme_Object *namespace_identifier(int, Scheme_Object *[]);

static Scheme_Object *namespace_module_identifier(int, Scheme_Object *[]);

static Scheme_Object *namespace_base_phase(int, Scheme_Object *[]);

static Scheme_Object *namespace_variable_value(int, Scheme_Object *[]);

static Scheme_Object *namespace_set_variable_value(int, Scheme_Object *[]);

static Scheme_Object *namespace_undefine_variable(int, Scheme_Object *[]);

static Scheme_Object *namespace_mapped_symbols(int, Scheme_Object *[]);

static Scheme_Object *namespace_module_registry(int, Scheme_Object *[]);

static Scheme_Object *variable_p(int, Scheme_Object *[]);

static Scheme_Object *variable_modidx(int, Scheme_Object *[]);

static Scheme_Object *variable_module_path(int, Scheme_Object *[]);

static Scheme_Object *variable_module_source(int, Scheme_Object *[]);

static Scheme_Object *variable_namespace(int, Scheme_Object *[]);

static Scheme_Object *variable_top_level_namespace(int, Scheme_Object *[]);

static Scheme_Object *variable_phase(int, Scheme_Object *[]);

static Scheme_Object *variable_base_phase(int, Scheme_Object *[]);

static Scheme_Object *variable_inspector(int, Scheme_Object *[]);

static Scheme_Object *variable_const_p(int, Scheme_Object *[]);

static Scheme_Object *now_transforming(int argc, Scheme_Object *argv[]);

static Scheme_Object *now_transforming_module(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_exp_time_value(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_exp_time_value_one(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_exp_time_name(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_context(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_phase_level(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_make_intdef_context(int argc, Scheme_Object *argv[]);

static Scheme_Object *intdef_context_seal(int argc, Scheme_Object *argv[]);

static Scheme_Object *intdef_context_p(int argc, Scheme_Object *argv[]);

static Scheme_Object *id_intdef_remove(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_introduce(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_module_introduce(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_get_shadower(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_module_exports(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_module_definitions(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_submodules(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_module_imports(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_module_expanding_provides(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_lift_expr(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_lift_exprs(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_lift_context(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_lift_end_statement(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_lift_provide(int argc, Scheme_Object *argv[]);

static Scheme_Object *make_introducer(int argc, Scheme_Object *argv[]);

static Scheme_Object *local_make_delta_introduce(int argc, Scheme_Object *argv[]);

static Scheme_Object *make_set_transformer(int argc, Scheme_Object *argv[]);

static Scheme_Object *set_transformer_p(int argc, Scheme_Object *argv[]);

static Scheme_Object *set_transformer_proc(int argc, Scheme_Object *argv[]);

static Scheme_Object *make_rename_transformer(int argc, Scheme_Object *argv[]);

static Scheme_Object *rename_transformer_target(int argc, Scheme_Object *argv[]);

static Scheme_Object *rename_transformer_p(int argc, Scheme_Object *argv[]);

static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data);

Scheme_Env *scheme_engine_instance_init();

static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thread);

#ifdef MZ_PRECISE_GC

static void register_traversers(void);

typedef Scheme_Object *(*Lazy_Macro_Fun)(Scheme_Object *, int);

static void boot_module_resolver()

{

Scheme_Object *boot, *a[2];

a[0] = scheme_make_pair(scheme_intern_symbol("quote"),

scheme_make_pair(scheme_intern_symbol("#%boot"),

scheme_null));

a[1] = scheme_intern_symbol("boot");

boot = scheme_dynamic_require(2, a);

scheme_apply(boot, 0, NULL);

}

void scheme_seal_parameters()

{

Scheme_Object *seal, *a[2];

a[0] = scheme_make_pair(scheme_intern_symbol("quote"),

scheme_make_pair(scheme_intern_symbol("#%boot"),

scheme_null));

a[1] = scheme_intern_symbol("seal");

seal = scheme_dynamic_require(2, a);

scheme_apply(seal, 0, NULL);

}

void os_platform_init() {

#ifdef UNIX_LIMIT_STACK

struct rlimit rl;

getrlimit(RLIMIT_STACK, &rl);

if (rl.rlim_cur > UNIX_LIMIT_STACK) {

rl.rlim_cur = UNIX_LIMIT_STACK;

setrlimit(RLIMIT_STACK, &rl);

}

#ifdef UNIX_LIMIT_FDSET_SIZE

struct rlimit rl;

getrlimit(RLIMIT_NOFILE, &rl);

if (rl.rlim_cur > FD_SETSIZE) {

rl.rlim_cur = FD_SETSIZE;

setrlimit(RLIMIT_NOFILE, &rl);

}

}

Scheme_Env *scheme_restart_instance() {

Scheme_Env *env;

void *stack_base;

stack_base = (void *) scheme_get_current_os_thread_stack_base();

/* Reset everything: */

scheme_do_close_managed(NULL, skip_certain_things);

scheme_main_thread = NULL;

scheme_reset_finalizations();

scheme_init_stack_check();

#ifndef MZ_PRECISE_GC

scheme_init_setjumpup();

scheme_reset_overflow();

scheme_make_thread(stack_base);

scheme_init_error_escape_proc(NULL);

scheme_init_module_resolver();

env = scheme_make_empty_env();

scheme_install_initial_module_set(env);

scheme_set_param(scheme_current_config(), MZCONFIG_ENV, (Scheme_Object *)env);

scheme_init_port_config();

scheme_init_port_fun_config();

scheme_init_error_config();

scheme_init_logger_config();

scheme_init_exn_config();

boot_module_resolver();

return env;

}

Scheme_Env *scheme_basic_env()

{

Scheme_Env *env;

if (scheme_main_thread) {

return scheme_restart_instance();

}

env = scheme_engine_instance_init();

return env;

}

Scheme_Env *scheme_engine_instance_init()

{

Scheme_Env *env;

void *stack_base;

stack_base = (void *) scheme_get_current_os_thread_stack_base();

os_platform_init();

#ifdef TIME_STARTUP_PROCESS

printf("#if 0\nengine_instance_init @ %" PRIdPTR "\n", scheme_get_process_milliseconds());

#if defined(MZ_LONG_DOUBLE_API_IS_EXTERNAL) || defined(LONG_DOUBLE_STRING_OP_API_IS_EXTERNAL)

scheme_load_long_double_dll();

scheme_starting_up = 1;

scheme_init_finalization();

scheme_init_portable_case();

scheme_init_compenv();

scheme_init_optimize();

scheme_init_resolve();

scheme_init_sfs();

scheme_init_validate();

scheme_init_process_globals();

scheme_init_true_false();

#ifdef MZ_PRECISE_GC

/* scheme_register_traversers(); --- already done in scheme_set_stack_base() */

register_traversers();

scheme_init_hash_key_procs();

scheme_init_getenv(); /* checks PLTNOJIT */

#ifdef WINDOWS_PROCESSES

/* Must be called before first scheme_make_thread() */

scheme_init_thread_memory();

#ifndef MZ_PRECISE_GC

scheme_init_ephemerons();

/* These calls must be made here so that they allocate out of the master GC */

scheme_init_symbol_table();

scheme_init_module_path_table();

scheme_init_type();

scheme_init_custodian_extractors();

#ifndef DONT_USE_FOREIGN

scheme_init_foreign_globals();

make_kernel_env();

scheme_init_logging_once();

scheme_init_compenv_symbol();

#if defined(MZ_PLACES_WAITPID)

scheme_places_start_child_signal_handler();

#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES)

GC_switch_out_master_gc();

scheme_spawn_master_place();

env = place_instance_init(stack_base, 1);

#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES)

{

void *signal_handle;

REGISTER_SO(place_object);

place_object = (Scheme_Place_Object*) scheme_make_place_object();

signal_handle = scheme_get_signal_handle();

GC_set_put_external_event_fd(signal_handle);

place_object->signal_handle = signal_handle;

}

return env;

}

static void init_unsafe(Scheme_Env *env)

{

Scheme_Module_Phase_Exports *pt;

REGISTER_SO(unsafe_env);

unsafe_env = scheme_primitive_module(scheme_intern_symbol("#%unsafe"), env);

scheme_init_unsafe_number(unsafe_env);

scheme_init_unsafe_numarith(unsafe_env);

scheme_init_unsafe_numcomp(unsafe_env);

scheme_init_unsafe_list(unsafe_env);

scheme_init_unsafe_vector(unsafe_env);

scheme_init_extfl_unsafe_number(unsafe_env);

scheme_init_extfl_unsafe_numarith(unsafe_env);

scheme_init_extfl_unsafe_numcomp(unsafe_env);

scheme_finish_primitive_module(unsafe_env);

pt = unsafe_env->module->me->rt;

scheme_populate_pt_ht(pt);

scheme_protect_primitive_provide(unsafe_env, NULL);

unsafe_env->attached = 1;

#if USE_COMPILED_STARTUP

if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_UNSAFE_COUNT)) {

printf("Unsafe count %d doesn't match expected count %d\n",

builtin_ref_counter - EXPECTED_PRIM_COUNT, EXPECTED_UNSAFE_COUNT);

abort();

}

}

static void init_flfxnum(Scheme_Env *env)

{

Scheme_Module_Phase_Exports *pt;

REGISTER_SO(flfxnum_env);

flfxnum_env = scheme_primitive_module(scheme_intern_symbol("#%flfxnum"), env);

scheme_init_flfxnum_number(flfxnum_env);

scheme_init_flfxnum_numarith(flfxnum_env);

scheme_init_flfxnum_numcomp(flfxnum_env);

scheme_finish_primitive_module(flfxnum_env);

pt = flfxnum_env->module->me->rt;

scheme_populate_pt_ht(pt);

scheme_protect_primitive_provide(flfxnum_env, NULL);

flfxnum_env->attached = 1;

#if USE_COMPILED_STARTUP

if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_UNSAFE_COUNT + EXPECTED_FLFXNUM_COUNT)) {

printf("Flfxnum count %d doesn't match expected count %d\n",

builtin_ref_counter - EXPECTED_PRIM_COUNT - EXPECTED_UNSAFE_COUNT,

EXPECTED_FLFXNUM_COUNT);

abort();

}

}

static void init_extfl(Scheme_Env *env)

{

Scheme_Module_Phase_Exports *pt;

REGISTER_SO(extfl_env);

extfl_env = scheme_primitive_module(scheme_intern_symbol("#%extfl"), env);

scheme_init_extfl_number(extfl_env);

scheme_init_extfl_numarith(extfl_env);

scheme_init_extfl_numcomp(extfl_env);

scheme_init_extfl_numstr(extfl_env);

scheme_finish_primitive_module(extfl_env);

pt = extfl_env->module->me->rt;

scheme_populate_pt_ht(pt);

scheme_protect_primitive_provide(extfl_env, NULL);

extfl_env->attached = 1;

#if USE_COMPILED_STARTUP

if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_UNSAFE_COUNT + EXPECTED_FLFXNUM_COUNT + EXPECTED_EXTFL_COUNT)) {

printf("extfl count %d doesn't match expected count %d\n",

builtin_ref_counter - EXPECTED_PRIM_COUNT - EXPECTED_UNSAFE_COUNT - EXPECTED_FLFXNUM_COUNT,

EXPECTED_EXTFL_COUNT);

abort();

}

}

static void init_futures(Scheme_Env *env)

{

Scheme_Module_Phase_Exports *pt;

REGISTER_SO(futures_env);

futures_env = scheme_primitive_module(scheme_intern_symbol("#%futures"), env);

scheme_init_futures(futures_env);

scheme_finish_primitive_module(futures_env);

pt = futures_env->module->me->rt;

scheme_populate_pt_ht(pt);

scheme_protect_primitive_provide(futures_env, NULL);

futures_env->attached = 1;

#if USE_COMPILED_STARTUP

if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_UNSAFE_COUNT + EXPECTED_FLFXNUM_COUNT + EXPECTED_EXTFL_COUNT + EXPECTED_FUTURES_COUNT)) {

printf("Futures count %d doesn't match expected count %d\n",

builtin_ref_counter - EXPECTED_PRIM_COUNT - EXPECTED_UNSAFE_COUNT - EXPECTED_FLFXNUM_COUNT - EXPECTED_EXTFL_COUNT, EXPECTED_FUTURES_COUNT);

abort();

}

}

Scheme_Env *scheme_get_unsafe_env() {

return unsafe_env;

}

Scheme_Env *scheme_get_flfxnum_env() {

return flfxnum_env;

}

Scheme_Env *scheme_get_extfl_env() {

return extfl_env;

}

Scheme_Env *scheme_get_futures_env() {

return futures_env;

}

static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thread) {

Scheme_Env *env;

#ifdef TIME_STARTUP_PROCESS

printf("place_init @ %" PRIdPTR "\n", scheme_get_process_milliseconds());

scheme_set_current_os_thread_stack_base(stack_base);

#ifndef MZ_PRECISE_GC

scheme_init_setjumpup();

scheme_init_stack_check();

scheme_init_overflow();

scheme_init_thread_lwc();

scheme_init_compenv_places();

#ifdef TIME_STARTUP_PROCESS

printf("pre-process @ %" PRIdPTR "\n", scheme_get_process_milliseconds());

scheme_make_thread(stack_base);

#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES)

/* each place now has a local symbol table */

scheme_init_place_local_symbol_table();

{

Scheme_Object *sym;

sym = scheme_intern_symbol("mzscheme");

scheme_current_thread->name = sym;

}

scheme_init_module_resolver();

#ifdef TIME_STARTUP_PROCESS

printf("process @ %" PRIdPTR "\n", scheme_get_process_milliseconds());

/* error handling and buffers */

/* this check prevents initializing orig ports twice for the first initial

scheme_init_fun_places();

scheme_init_port_places();

scheme_init_error_escape_proc(NULL);

scheme_init_print_buffers_places();

scheme_init_thread_places();

scheme_init_string_places();

scheme_init_logger();

scheme_init_eval_places();

scheme_init_compile_places();

scheme_init_regexp_places();

scheme_init_stx_places(initial_main_os_thread);

scheme_init_sema_places();

scheme_init_gmp_places();

scheme_init_kqueue();

scheme_alloc_global_fdset();

scheme_init_file_places();

#ifndef DONT_USE_FOREIGN

scheme_init_foreign_places();

env = scheme_make_empty_env();

scheme_set_param(scheme_current_config(), MZCONFIG_ENV, (Scheme_Object *)env);

/*initialize config */

scheme_init_port_config();

scheme_init_port_fun_config();

scheme_init_error_config();

scheme_init_logger_config();

#ifndef NO_SCHEME_EXNS

scheme_init_exn_config();

scheme_init_error_config();

scheme_init_memtrace(env);

#ifndef NO_TCP_SUPPORT

scheme_init_network(env);

scheme_init_paramz(env);

scheme_init_expand_observe(env);

scheme_init_place(env);

#if defined(MZ_USE_PLACES) && defined(MZ_USE_JIT)

scheme_jit_fill_threadlocal_table();

scheme_init_futures_per_place();

scheme_init_foreign(env);

REGISTER_SO(literal_string_table);

REGISTER_SO(literal_number_table);

literal_string_table = scheme_make_weak_equal_table();

literal_number_table = scheme_make_weak_eqv_table();

scheme_starting_up = 1; /* in case it's not set already */

scheme_add_embedded_builtins(env);

boot_module_resolver();

scheme_save_initial_module_set(env);

scheme_starting_up = 0;

--scheme_current_thread->suspend_break; /* created with breaks suspended */

#ifdef TIME_STARTUP_PROCESS

printf("done @ %" PRIdPTR "\n#endif\n", scheme_get_process_milliseconds());

#if defined(MZ_USE_PLACES)

REGISTER_SO(place_channel_links);

return env;

}

#ifdef MZ_USE_PLACES

Scheme_Env *scheme_place_instance_init(void *stack_base, struct NewGC *parent_gc, intptr_t memory_limit) {

Scheme_Env *env;

# if defined(MZ_PRECISE_GC)

int *signal_fd;

GC_construct_child_gc(parent_gc, memory_limit);

env = place_instance_init(stack_base, 0);

# if defined(MZ_PRECISE_GC)

signal_fd = scheme_get_signal_handle();

GC_set_put_external_event_fd(signal_fd);

scheme_set_can_break(1);

return env;

}

static void force_more_closed(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data)

{

/* no need to shut down threads: */

if (!f || SCHEME_THREADP(o))

return;

f(o, data);

}

static void force_more_closed_after(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data)

{

scheme_run_atexit_closers(o, f, data);

force_more_closed(o, f, data);

}

void scheme_place_instance_destroy(int force)

{

/* run atexit handlers to flush file ports, and also

if (force)

scheme_run_atexit_closers_on_all(force_more_closed);

else

scheme_run_atexit_closers_on_all(force_more_closed_after);

scheme_release_file_descriptor();

scheme_end_futures_per_place();

#if defined(MZ_USE_PLACES)

scheme_kill_green_thread_timer();

scheme_free_place_bi_channels();

#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES)

GC_destruct_child_gc();

scheme_free_all_code();

scheme_free_ghbn_data();

scheme_release_kqueue();

}

static void make_kernel_env(void)

{

Scheme_Env *env;

#ifdef TIME_STARTUP_PROCESS

intptr_t startt;

env = make_empty_inited_env(GLOBAL_TABLE_SIZE);

REGISTER_SO(kernel_env);

kernel_env = env;

scheme_defining_primitives = 1;

builtin_ref_counter = 0;

#ifdef TIME_STARTUP_PROCESS

printf("init @ %" PRIdPTR "\n", scheme_get_process_milliseconds());

# define MZTIMEIT(n, f) (MARK_START_TIME(), f, DONE_TIME(n))

# define MARK_START_TIME() startt = scheme_get_process_milliseconds()

# define DONE_TIME(n) (printf(#n ": %" PRIdPTR "\n", (intptr_t)(scheme_get_process_milliseconds() - startt)))

# define MZTIMEIT(n, f) f

# define MARK_START_TIME() /**/

# define DONE_TIME(n) /**/

/* The ordering of the first few init calls is important, so add to

MZTIMEIT(symbol-type, scheme_init_symbol_type(env));

MZTIMEIT(fun, scheme_init_fun(env));

MZTIMEIT(symbol, scheme_init_symbol(env));

MZTIMEIT(list, scheme_init_list(env));

MZTIMEIT(number, scheme_init_number(env));

MZTIMEIT(numarith, scheme_init_numarith(env));

MZTIMEIT(numcomp, scheme_init_numcomp(env));

MZTIMEIT(numstr, scheme_init_numstr(env));

MZTIMEIT(bignum, scheme_init_bignum());

MZTIMEIT(stx, scheme_init_stx(env));

MZTIMEIT(module, scheme_init_module(env));

MZTIMEIT(port, scheme_init_port(env));

MZTIMEIT(portfun, scheme_init_port_fun(env));

MZTIMEIT(string, scheme_init_string(env));

MZTIMEIT(vector, scheme_init_vector(env));

MZTIMEIT(char, scheme_init_char(env));

MZTIMEIT(bool, scheme_init_bool(env));

MZTIMEIT(syntax, scheme_init_compile(env));

MZTIMEIT(eval, scheme_init_eval(env));

MZTIMEIT(error, scheme_init_error(env));

MZTIMEIT(struct, scheme_init_struct(env));

#ifndef NO_SCHEME_EXNS

MZTIMEIT(exn, scheme_init_exn(env));

MZTIMEIT(process, scheme_init_thread(env));

scheme_init_inspector();

MZTIMEIT(reduced, scheme_init_reduced_proc_struct(env));

#ifndef NO_SCHEME_THREADS

MZTIMEIT(sema, scheme_init_sema(env));

MZTIMEIT(read, scheme_init_read(env));

MZTIMEIT(print, scheme_init_print(env));

MZTIMEIT(file, scheme_init_file(env));

MZTIMEIT(dynamic-extension, scheme_init_dynamic_extension(env));

#ifndef NO_REGEXP_UTILS

MZTIMEIT(regexp, scheme_regexp_initialize(env));

MZTIMEIT(params, scheme_init_parameterization());

MZTIMEIT(futures, scheme_init_futures_once());

MZTIMEIT(places, scheme_init_places_once());

MARK_START_TIME();

GLOBAL_PRIM_W_ARITY("namespace-symbol->identifier", namespace_identifier, 1, 2, env);

GLOBAL_PRIM_W_ARITY("namespace-module-identifier", namespace_module_identifier, 0, 1, env);

GLOBAL_PRIM_W_ARITY("namespace-base-phase", namespace_base_phase, 0, 1, env);

GLOBAL_PRIM_W_ARITY("namespace-variable-value", namespace_variable_value, 1, 4, env);

GLOBAL_PRIM_W_ARITY("namespace-set-variable-value!", namespace_set_variable_value, 2, 4, env);

GLOBAL_PRIM_W_ARITY("namespace-undefine-variable!", namespace_undefine_variable, 1, 2, env);

GLOBAL_PRIM_W_ARITY("namespace-mapped-symbols", namespace_mapped_symbols, 0, 1, env);

GLOBAL_PRIM_W_ARITY("namespace-module-registry", namespace_module_registry, 1, 1, env);

GLOBAL_PRIM_W_ARITY("variable-reference?", variable_p, 1, 1, env);

GLOBAL_PRIM_W_ARITY("variable-reference->module-path-index", variable_modidx, 1, 1, env);

GLOBAL_PRIM_W_ARITY("variable-reference->resolved-module-path", variable_module_path, 1, 1, env);

GLOBAL_PRIM_W_ARITY("variable-reference->module-source", variable_module_source, 1, 1, env);

GLOBAL_PRIM_W_ARITY("variable-reference->empty-namespace", variable_namespace, 1, 1, env);

GLOBAL_PRIM_W_ARITY("variable-reference->namespace", variable_top_level_namespace, 1, 1, env);

GLOBAL_PRIM_W_ARITY("variable-reference->phase", variable_phase, 1, 1, env);

GLOBAL_PRIM_W_ARITY("variable-reference->module-base-phase", variable_base_phase, 1, 1, env);

GLOBAL_PRIM_W_ARITY("variable-reference->module-declaration-inspector", variable_inspector, 1, 1, env);

REGISTER_SO(scheme_varref_const_p_proc);

scheme_varref_const_p_proc = scheme_make_prim_w_arity(variable_const_p,

"variable-reference-constant?",

1, 1);

scheme_add_global_constant("variable-reference-constant?", scheme_varref_const_p_proc, env);

GLOBAL_PRIM_W_ARITY("syntax-transforming?", now_transforming, 0, 0, env);

GLOBAL_PRIM_W_ARITY("syntax-transforming-module-expression?", now_transforming_module, 0, 0, env);

GLOBAL_PRIM_W_ARITY("syntax-local-value", local_exp_time_value, 1, 3, env);

GLOBAL_PRIM_W_ARITY("syntax-local-value/immediate", local_exp_time_value_one, 1, 3, env);

GLOBAL_PRIM_W_ARITY("syntax-local-name", local_exp_time_name, 0, 0, env);

GLOBAL_PRIM_W_ARITY("syntax-local-context", local_context, 0, 0, env);

GLOBAL_PRIM_W_ARITY("syntax-local-phase-level", local_phase_level, 0, 0, env);

GLOBAL_PRIM_W_ARITY("syntax-local-make-definition-context", local_make_intdef_context, 0, 1, env);

GLOBAL_PRIM_W_ARITY("internal-definition-context-seal", intdef_context_seal, 1, 1, env);

GLOBAL_PRIM_W_ARITY("internal-definition-context?", intdef_context_p, 1, 1, env);

GLOBAL_PRIM_W_ARITY("identifier-remove-from-definition-context", id_intdef_remove, 2, 2, env);

GLOBAL_PRIM_W_ARITY("syntax-local-get-shadower", local_get_shadower, 1, 1, env);

GLOBAL_PRIM_W_ARITY("syntax-local-introduce", local_introduce, 1, 1, env);

GLOBAL_PRIM_W_ARITY("make-syntax-introducer", make_introducer, 0, 1, env);

GLOBAL_PRIM_W_ARITY("syntax-local-make-delta-introducer", local_make_delta_introduce, 1, 1, env);

GLOBAL_PRIM_W_ARITY("syntax-local-module-exports", local_module_exports, 1, 1, env);

GLOBAL_PRIM_W_ARITY("syntax-local-module-defined-identifiers", local_module_definitions, 0, 0, env);

GLOBAL_PRIM_W_ARITY("syntax-local-submodules", local_submodules, 0, 0, env);

GLOBAL_PRIM_W_ARITY("syntax-local-module-required-identifiers", local_module_imports, 2, 2, env);

GLOBAL_PRIM_W_ARITY("syntax-local-transforming-module-provides?", local_module_expanding_provides, 0, 0, env);

GLOBAL_PRIM_W_ARITY("make-set!-transformer", make_set_transformer, 1, 1, env);

GLOBAL_PRIM_W_ARITY("set!-transformer?", set_transformer_p, 1, 1, env);

GLOBAL_PRIM_W_ARITY("set!-transformer-procedure", set_transformer_proc, 1, 1, env);

GLOBAL_PRIM_W_ARITY("make-rename-transformer", make_rename_transformer, 1, 2, env);

GLOBAL_PRIM_W_ARITY("rename-transformer?", rename_transformer_p, 1, 1, env);

GLOBAL_PRIM_W_ARITY("rename-transformer-target", rename_transformer_target, 1, 1, env);

GLOBAL_PRIM_W_ARITY("syntax-local-lift-expression", local_lift_expr, 1, 1, env);

GLOBAL_PRIM_W_ARITY("syntax-local-lift-values-expression", local_lift_exprs, 2, 2, env);

GLOBAL_PRIM_W_ARITY("syntax-local-lift-context", local_lift_context, 0, 0, env);

GLOBAL_PRIM_W_ARITY("syntax-local-lift-module-end-declaration", local_lift_end_statement, 1, 1, env);

GLOBAL_PRIM_W_ARITY("syntax-local-lift-require", local_lift_require, 2, 2, env);

GLOBAL_PRIM_W_ARITY("syntax-local-lift-provide", local_lift_provide, 1, 1, env);

DONE_TIME(env);

register_network_evts();

REGISTER_SO(kernel_symbol);

kernel_symbol = scheme_intern_symbol("#%kernel");

MARK_START_TIME();

scheme_finish_kernel(env);

#if USE_COMPILED_STARTUP

if (builtin_ref_counter != EXPECTED_PRIM_COUNT) {

printf("Primitive count %d doesn't match expected count %d\n"

"Turn off USE_COMPILED_STARTUP in src/schminc.h\n",

builtin_ref_counter, EXPECTED_PRIM_COUNT);

abort();

}

init_unsafe(env);

init_flfxnum(env);

init_extfl(env);

init_futures(env);

scheme_init_print_global_constants();

scheme_init_variable_references_constants();

scheme_defining_primitives = 0;

}

int scheme_is_kernel_env(Scheme_Env *env) {

return (env == kernel_env);

}

Scheme_Env *scheme_get_kernel_env() {

return kernel_env;

}

static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data)

{

if ((o == scheme_orig_stdin_port)

|| (o == scheme_orig_stdout_port)

|| (o == scheme_orig_stderr_port))

return;

/* f is NULL for threads */

if (f)

f(o, data);

}

void scheme_prepare_env_renames(Scheme_Env *env, int kind)

{

if (!env->rename_set) {

Scheme_Object *rns, *insp;

insp = env->access_insp;

if (!insp)

insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);

rns = scheme_make_module_rename_set(kind, NULL, insp);

env->rename_set = rns;

}

}

Scheme_Env *scheme_make_empty_env(void)

{

Scheme_Env *e;

e = make_empty_inited_env(7);

return e;

}

Scheme_Env *make_empty_inited_env(int toplevel_size)

{

Scheme_Env *env;

Scheme_Object *vector;

Scheme_Hash_Table* hash_table;

Scheme_Module_Registry *reg;

env = make_env(NULL, toplevel_size);

vector = scheme_make_vector(5, scheme_false);

hash_table = scheme_make_hash_table(SCHEME_hash_ptr);

SCHEME_VEC_ELS(vector)[0] = (Scheme_Object *)hash_table;

env->modchain = vector;

reg = MALLOC_ONE_TAGGED(Scheme_Module_Registry);

reg->so.type = scheme_module_registry_type;

env->module_registry = reg;

hash_table = scheme_make_hash_table(SCHEME_hash_ptr);

reg->loaded = hash_table;

hash_table = scheme_make_hash_table(SCHEME_hash_ptr);

reg->exports = hash_table;

env->label_env = NULL;

return env;

}

Scheme_Env *make_empty_not_inited_env(int toplevel_size)

{

Scheme_Env *e;

e = make_env(NULL, toplevel_size);

return e;

}

static Scheme_Env *make_env(Scheme_Env *base, int toplevel_size)

{

Scheme_Env *env;

Scheme_Bucket_Table *bucket_table;

env = MALLOC_ONE_TAGGED(Scheme_Env);

env->so.type = scheme_namespace_type;

bucket_table = scheme_make_bucket_table(toplevel_size, SCHEME_hash_ptr);

env->toplevel = bucket_table;

env->toplevel->with_home = 1;

bucket_table = scheme_make_bucket_table(7, SCHEME_hash_ptr);

env->syntax = bucket_table;

if (base) {

env->modchain = base->modchain;

env->module_registry = base->module_registry;

env->module_pre_registry = base->module_pre_registry;

env->label_env = base->label_env;

} else {

env->modchain = NULL;

env->module_registry = NULL;

env->module_pre_registry = NULL;

env->label_env = NULL;

}

return env;

}

Scheme_Env *

scheme_new_module_env(Scheme_Env *env, Scheme_Module *m, int new_exp_module_tree)

{

Scheme_Env *menv;

Scheme_Module_Registry *reg;

menv = make_env(env, 7);

if (new_exp_module_tree && !menv->module_pre_registry) {

/* pre_registry is for declarations to be used by submodules */

reg = MALLOC_ONE_TAGGED(Scheme_Module_Registry);

reg->so.type = scheme_module_registry_type;

menv->module_pre_registry = reg;

}

menv->module = m;

scheme_prepare_label_env(env);

menv->label_env = env->label_env;

menv->instance_env = env;

if (new_exp_module_tree) {

Scheme_Object *p;

Scheme_Hash_Table *modules;

modules = scheme_make_hash_table(SCHEME_hash_ptr);

p = scheme_make_vector(5, scheme_false);

SCHEME_VEC_ELS(p)[0] = (Scheme_Object *)modules;

menv->modchain = p;

}

if (SAME_OBJ(env, env->exp_env)) {

/* label phase */

menv->exp_env = menv;

menv->template_env = menv;

}

return menv;

}

void scheme_prepare_exp_env(Scheme_Env *env)

{

if (!env->exp_env) {

Scheme_Env *eenv;

Scheme_Object *modchain;

scheme_prepare_label_env(env);

eenv = make_empty_not_inited_env(7);

eenv->phase = env->phase + 1;

eenv->mod_phase = env->mod_phase + 1;

eenv->module = env->module;

eenv->module_registry = env->module_registry;

eenv->module_pre_registry = env->module_pre_registry;

eenv->access_insp = env->access_insp;

eenv->guard_insp = env->guard_insp;

modchain = SCHEME_VEC_ELS(env->modchain)[1];

if (SCHEME_FALSEP(modchain)) {

Scheme_Hash_Table *next_modules;

next_modules = scheme_make_hash_table(SCHEME_hash_ptr);

modchain = scheme_make_vector(5, scheme_false);

SCHEME_VEC_ELS(modchain)[0] = (Scheme_Object *)next_modules;

SCHEME_VEC_ELS(env->modchain)[1] = modchain;

SCHEME_VEC_ELS(modchain)[2] = env->modchain;

}

eenv->modchain = modchain;

env->exp_env = eenv;

eenv->template_env = env;

eenv->label_env = env->label_env;

eenv->instance_env = env->instance_env;

scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL);

eenv->rename_set = env->rename_set;

if (env->disallow_unbound)

eenv->disallow_unbound = env->disallow_unbound;

}

}

void scheme_prepare_template_env(Scheme_Env *env)

{

if (!env->template_env) {

Scheme_Env *eenv;

Scheme_Object *modchain;

scheme_prepare_label_env(env);

eenv = make_empty_not_inited_env(7);

eenv->phase = env->phase - 1;

eenv->mod_phase = env->mod_phase - 1;

eenv->module = env->module;

eenv->module_registry = env->module_registry;

eenv->module_pre_registry = env->module_pre_registry;