#include "schpriv.h"

#include "schrunst.h"

#include "schexpobs.h"

#ifdef MZ_USE_FUTURES

# include "future.h"

#ifdef USE_STACKAVAIL

#include <malloc.h>

#ifdef UNIX_FIND_STACK_BOUNDS

#include <signal.h>

#include <sys/time.h>

#include <sys/resource.h>

#ifdef WINDOWS_FIND_STACK_BOUNDS

#include <windows.h>

#ifdef BEOS_FIND_STACK_BOUNDS

# include <be/kernel/OS.h>

#ifdef OSKIT_FIXED_STACK_BOUNDS

# include <oskit/machine/base_stack.h>

#include "schmach.h"

#ifdef MACOS_STACK_LIMIT

#include <Memory.h>

#endif

#ifdef MZ_USE_FUTURES

# include "future.h"

#ifdef MZ_USE_JIT

# define INIT_JIT_ON 1

# define INIT_JIT_ON 0

SHARED_OK int scheme_startup_use_jit = INIT_JIT_ON;

void scheme_set_startup_use_jit(int v) { scheme_startup_use_jit = v; }

SHARED_OK static int valdiate_compile_result = 0;

THREAD_LOCAL_DECL(volatile int scheme_fuel_counter);

#ifdef USE_STACK_BOUNDARY_VAR

THREAD_LOCAL_DECL(uintptr_t scheme_stack_boundary);

THREAD_LOCAL_DECL(uintptr_t volatile scheme_jit_stack_boundary);

THREAD_LOCAL_DECL(int scheme_continuation_application_count);

THREAD_LOCAL_DECL(static int generate_lifts_count);

THREAD_LOCAL_DECL(int scheme_overflow_count);

THREAD_LOCAL_DECL(Scheme_Prefix *scheme_prefix_finalize);

int scheme_get_overflow_count() { return scheme_overflow_count; }

READ_ONLY Scheme_Object *scheme_eval_waiting;

READ_ONLY Scheme_Object *scheme_multiple_values;

ROSYM static Scheme_Object *app_symbol;

ROSYM static Scheme_Object *datum_symbol;

ROSYM static Scheme_Object *top_symbol;

ROSYM static Scheme_Object *top_level_symbol;

ROSYM static Scheme_Object *define_values_symbol;

ROSYM static Scheme_Object *letrec_values_symbol;

ROSYM static Scheme_Object *lambda_symbol;

ROSYM static Scheme_Object *unknown_symbol;

ROSYM static Scheme_Object *void_link_symbol;

ROSYM static Scheme_Object *quote_symbol;

ROSYM static Scheme_Object *letrec_syntaxes_symbol;

ROSYM static Scheme_Object *begin_symbol;

ROSYM static Scheme_Object *let_values_symbol;

ROSYM static Scheme_Object *internal_define_symbol;

ROSYM static Scheme_Object *module_symbol;

ROSYM static Scheme_Object *module_begin_symbol;

ROSYM static Scheme_Object *expression_symbol;

ROSYM Scheme_Object *scheme_stack_dump_key;

READ_ONLY static Scheme_Object *zero_rands_ptr; /* &zero_rands_ptr is dummy rands pointer */

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

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

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

static Scheme_Object *expand(int argc, Scheme_Object **argv);

static Scheme_Object *local_expand(int argc, Scheme_Object **argv);

static Scheme_Object *local_expand_expr(int argc, Scheme_Object **argv);

static Scheme_Object *local_expand_catch_lifts(int argc, Scheme_Object **argv);

static Scheme_Object *local_transformer_expand(int argc, Scheme_Object **argv);

static Scheme_Object *local_transformer_expand_catch_lifts(int argc, Scheme_Object **argv);

static Scheme_Object *local_eval(int argc, Scheme_Object **argv);

static Scheme_Object *expand_once(int argc, Scheme_Object **argv);

static Scheme_Object *expand_to_top_form(int argc, Scheme_Object **argv);

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

static Scheme_Object *current_eval(int argc, Scheme_Object *[]);

static Scheme_Object *current_compile(int argc, Scheme_Object *[]);

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

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

static Scheme_Object *expand_stx(int argc, Scheme_Object **argv);

static Scheme_Object *expand_stx_once(int argc, Scheme_Object **argv);

static Scheme_Object *expand_stx_to_top_form(int argc, Scheme_Object **argv);

static Scheme_Object *top_introduce_stx(int argc, Scheme_Object **argv);

static Scheme_Object *allow_set_undefined(int argc, Scheme_Object **argv);

static Scheme_Object *compile_module_constants(int argc, Scheme_Object **argv);

static Scheme_Object *use_jit(int argc, Scheme_Object **argv);

static Scheme_Object *disallow_inline(int argc, Scheme_Object **argv);

static Scheme_Object *_eval_compiled_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env);

void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object *alt_full);

#ifdef MZ_PRECISE_GC

static void mark_pruned_prefixes(struct NewGC *gc);

#define cons(x,y) scheme_make_pair(x,y)

typedef void (*DW_PrePost_Proc)(void *);

#ifdef MZ_PRECISE_GC

static void register_traversers(void);

#define icons scheme_make_pair

scheme_init_eval (Scheme_Env *env)

{

#ifdef MZ_PRECISE_GC

register_traversers();

#ifdef MZ_EVAL_WAITING_CONSTANT

scheme_eval_waiting = MZ_EVAL_WAITING_CONSTANT;

REGISTER_SO(scheme_eval_waiting);

scheme_eval_waiting = scheme_alloc_eternal_object();

scheme_eval_waiting->type = scheme_eval_waiting_type;

#ifdef MZ_EVAL_WAITING_CONSTANT

scheme_multiple_values = MZ_MULTIPLE_VALUES_CONSTANT;

REGISTER_SO(scheme_multiple_values);

scheme_multiple_values = scheme_alloc_eternal_object();

scheme_multiple_values->type = scheme_multiple_values_type;

REGISTER_SO(define_values_symbol);

REGISTER_SO(letrec_values_symbol);

REGISTER_SO(lambda_symbol);

REGISTER_SO(unknown_symbol);

REGISTER_SO(void_link_symbol);

REGISTER_SO(quote_symbol);

REGISTER_SO(letrec_syntaxes_symbol);

REGISTER_SO(begin_symbol);

REGISTER_SO(let_values_symbol);

define_values_symbol = scheme_intern_symbol("define-values");

letrec_values_symbol = scheme_intern_symbol("letrec-values");

let_values_symbol = scheme_intern_symbol("let-values");

lambda_symbol = scheme_intern_symbol("lambda");

unknown_symbol = scheme_intern_symbol("unknown");

void_link_symbol = scheme_intern_symbol("-v");

quote_symbol = scheme_intern_symbol("quote");

letrec_syntaxes_symbol = scheme_intern_symbol("letrec-syntaxes+values");

begin_symbol = scheme_intern_symbol("begin");

REGISTER_SO(module_symbol);

REGISTER_SO(module_begin_symbol);

REGISTER_SO(internal_define_symbol);

REGISTER_SO(expression_symbol);

REGISTER_SO(top_level_symbol);

module_symbol = scheme_intern_symbol("module");

module_begin_symbol = scheme_intern_symbol("module-begin");

internal_define_symbol = scheme_intern_symbol("internal-define");

expression_symbol = scheme_intern_symbol("expression");

top_level_symbol = scheme_intern_symbol("top-level");

REGISTER_SO(app_symbol);

REGISTER_SO(datum_symbol);

REGISTER_SO(top_symbol);

app_symbol = scheme_intern_symbol("#%app");

datum_symbol = scheme_intern_symbol("#%datum");

top_symbol = scheme_intern_symbol("#%top");

REGISTER_SO(scheme_stack_dump_key);

scheme_stack_dump_key = scheme_make_symbol("stk"); /* uninterned! */

GLOBAL_PRIM_W_ARITY2("eval", eval, 1, 2, 0, -1, env);

GLOBAL_PRIM_W_ARITY2("eval-syntax", eval_stx, 1, 2, 0, -1, env);

GLOBAL_PRIM_W_ARITY("compile", compile, 1, 1, env);

GLOBAL_PRIM_W_ARITY("compile-syntax", compile_stx, 1, 1, env);

GLOBAL_PRIM_W_ARITY("compiled-expression?", compiled_p, 1, 1, env);

GLOBAL_PRIM_W_ARITY("expand", expand, 1, 1, env);

GLOBAL_PRIM_W_ARITY("expand-syntax", expand_stx, 1, 1, env);

GLOBAL_PRIM_W_ARITY("local-expand", local_expand, 3, 4, env);

GLOBAL_PRIM_W_ARITY2("syntax-local-expand-expression", local_expand_expr, 1, 1, 2, 2, env);

GLOBAL_PRIM_W_ARITY("syntax-local-bind-syntaxes", local_eval, 3, 3, env);

GLOBAL_PRIM_W_ARITY("local-expand/capture-lifts", local_expand_catch_lifts, 3, 5, env);

GLOBAL_PRIM_W_ARITY("local-transformer-expand", local_transformer_expand, 3, 4, env);

GLOBAL_PRIM_W_ARITY("local-transformer-expand/capture-lifts", local_transformer_expand_catch_lifts, 3, 5, env);

GLOBAL_PRIM_W_ARITY("expand-once", expand_once, 1, 1, env);

GLOBAL_PRIM_W_ARITY("expand-syntax-once", expand_stx_once, 1, 1, env);

GLOBAL_PRIM_W_ARITY("expand-to-top-form", expand_to_top_form, 1, 1, env);

GLOBAL_PRIM_W_ARITY("expand-syntax-to-top-form", expand_stx_to_top_form, 1, 1, env);

GLOBAL_PRIM_W_ARITY("namespace-syntax-introduce", top_introduce_stx, 1, 1, env);

GLOBAL_PRIM_W_ARITY("break-enabled", enable_break, 0, 1, env);

GLOBAL_PARAMETER("current-eval", current_eval, MZCONFIG_EVAL_HANDLER, env);

GLOBAL_PARAMETER("current-compile", current_compile, MZCONFIG_COMPILE_HANDLER, env);

GLOBAL_PARAMETER("compile-allow-set!-undefined", allow_set_undefined, MZCONFIG_ALLOW_SET_UNDEFINED, env);

GLOBAL_PARAMETER("compile-enforce-module-constants", compile_module_constants, MZCONFIG_COMPILE_MODULE_CONSTS, env);

GLOBAL_PARAMETER("eval-jit-enabled", use_jit, MZCONFIG_USE_JIT, env);

GLOBAL_PARAMETER("compile-context-preservation-enabled", disallow_inline, MZCONFIG_DISALLOW_INLINE, env);

if (getenv("PLT_VALIDATE_COMPILE")) {

/* Enables validation of bytecode as it is generated,

valdiate_compile_result = 1;

}

}

void scheme_init_eval_places()

{

#ifdef MZ_PRECISE_GC

scheme_prefix_finalize = (Scheme_Prefix *)0x1; /* 0x1 acts as a sentenel */

GC_set_post_propagate_hook(mark_pruned_prefixes);

#ifdef DEBUG_CHECK_STACK_FRAME_SIZE

(void)scheme_do_eval(SCHEME_TAIL_CALL_WAITING, 0, NULL, 0);

}

XFORM_NONGCING static void ignore_result(Scheme_Object *v)

{

if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {

scheme_current_thread->ku.multiple.array = NULL;

}

}

void scheme_ignore_result(Scheme_Object *v)

{

ignore_result(v);

}

Scheme_Object *

scheme_handle_stack_overflow(Scheme_Object *(*k)(void))

{

/* "Stack overflow" means running out of C-stack space. The other

Scheme_Thread *p = scheme_current_thread;

Scheme_Overflow *overflow;

Scheme_Overflow_Jmp *jmp;

scheme_about_to_move_C_stack();

p->overflow_k = k;

scheme_overflow_count++;

overflow = MALLOC_ONE_RT(Scheme_Overflow);

#ifdef MZTAG_REQUIRED

overflow->type = scheme_rt_overflow;

/* push old overflow */

overflow->prev = scheme_current_thread->overflow;

p->overflow = overflow;

overflow->stack_start = p->stack_start;

jmp = MALLOC_ONE_RT(Scheme_Overflow_Jmp);

#ifdef MZTAG_REQUIRED

jmp->type = scheme_rt_overflow_jmp;

overflow->jmp = jmp;

scheme_init_jmpup_buf(&overflow->jmp->cont);

scheme_zero_unneeded_rands(scheme_current_thread); /* for GC */

if (scheme_setjmpup(&overflow->jmp->cont, overflow->jmp, p->stack_start)) {

p = scheme_current_thread;

overflow = p->overflow;

p->overflow = overflow->prev;

p->error_buf = overflow->jmp->savebuf;

if (p->meta_prompt) {

/* When unwinding a stack overflow, we need to fix up

Scheme_Prompt *meta_prompt;

meta_prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);

memcpy(meta_prompt, p->meta_prompt, sizeof(Scheme_Prompt));

meta_prompt->stack_boundary = p->stack_start;

p->meta_prompt = meta_prompt;

}

if (!overflow->jmp->captured) /* reset if not captured in a continuation */

scheme_reset_jmpup_buf(&overflow->jmp->cont);

if (!scheme_overflow_reply) {

/* No reply value means we should continue some escape. */

if (p->cjs.jumping_to_continuation

&& p->cjs.is_escape) {

/* Jump directly to prompt: */

Scheme_Prompt *prompt = (Scheme_Prompt *)p->cjs.jumping_to_continuation;

scheme_longjmp(*prompt->prompt_buf, 1);

} else if (p->cjs.jumping_to_continuation

&& SCHEME_CONTP(p->cjs.jumping_to_continuation)) {

Scheme_Cont *c = (Scheme_Cont *)p->cjs.jumping_to_continuation;

p->cjs.jumping_to_continuation = NULL;

scheme_longjmpup(&c->buf_ptr->buf);

} else {

/* Continue normal escape: */

scheme_longjmp(scheme_error_buf, 1);

}

} else {

Scheme_Object *reply = scheme_overflow_reply;

scheme_overflow_reply = NULL;

return reply;

}

} else {

p->stack_start = scheme_overflow_stack_start;

scheme_longjmpup(&scheme_overflow_jmp->cont);

}

return NULL; /* never gets here */

}

#ifdef LINUX_FIND_STACK_BASE

static uintptr_t adjust_stack_base(uintptr_t bnd) {

if (bnd == scheme_get_primordial_thread_stack_base()) {

/* The address `base' might be far from the actual stack base

FILE *f;

char *buf;

f = fopen("/proc/self/maps", "r");

if (f) {

buf = malloc(256);

while (fgets(buf, 256, f)) {

int len;

len = strlen(buf);

if ((len > 8) && !strcmp("[stack]\n", buf + len - 8)) {

uintptr_t p = 0;

int i;

/* find separator: */

for (i = 0; buf[i]; i++) {

if (buf[i] == '-') {

i++;

break;

}

}

/* parse number after separator: */

for (; buf[i]; i++) {

if ((buf[i] >= '0') && (buf[i] <= '9')) {

p = (p << 4) | (buf[i] - '0');

} else if ((buf[i] >= 'a') && (buf[i] <= 'f')) {

p = (p << 4) | (buf[i] - 'a' + 10);

} else if ((buf[i] >= 'A') && (buf[i] <= 'F')) {

p = (p << 4) | (buf[i] - 'A' + 10);

} else

break;

}

/* printf("%p vs. %p: %d\n", (void*)bnd, (void*)p, p - bnd); */

return p;

}

}

free(buf);

fclose(f);

}

}

return bnd;

}

#ifdef WINDOWS_FIND_STACK_BOUNDS

intptr_t find_exe_stack_size()

{

intptr_t sz = WINDOWS_DEFAULT_STACK_SIZE;

wchar_t *fn;

DWORD len = 1024;

/* Try to read the executable to find out the initial

fn = (wchar_t *)malloc(sizeof(wchar_t) * len);

if (GetModuleFileNameW(NULL, fn, len) < len) {

HANDLE fd;

fd = CreateFileW(fn,

GENERIC_READ,

FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,

NULL,

OPEN_EXISTING,

0,

NULL);

if (fd != INVALID_HANDLE_VALUE) {

int pos;

short kind;

DWORD got;

/* Skip DOS stub */

if (SetFilePointer(fd, 0x3C, NULL, FILE_BEGIN)

!= INVALID_SET_FILE_POINTER) {

if (ReadFile(fd, &pos, sizeof(int), &got, NULL)

&& (got == sizeof(int))) {

/* Read offset to header */

if (SetFilePointer(fd, pos + 20 + 4, NULL, FILE_BEGIN)

!= INVALID_SET_FILE_POINTER) {

/* Check magic number */

if (ReadFile(fd, &kind, sizeof(short), &got, NULL)

&& (got == sizeof(short))) {

/* Two possible magic numbers: PE32 or PE32+: */

if ((kind == 0x10b) || (kind == 0x20b)) {

/* Skip to PE32[+] header's stack reservation value: */

if (SetFilePointer(fd, pos + 20 + 4 + 72, NULL, FILE_BEGIN)

!= INVALID_SET_FILE_POINTER) {

mzlonglong lsz;

if (kind == 0x10b) {

/* PE32: 32-bit stack size: */

int ssz;

if (ReadFile(fd, &ssz, sizeof(int), &got, NULL)

&& (got == sizeof(int))) {

sz = ssz;

}

} else {

/* PE32+: 64-bit stack size: */

mzlonglong lsz;

if (ReadFile(fd, &lsz, sizeof(mzlonglong), &got, NULL)

&& (got == sizeof(mzlonglong))) {

sz = lsz;

}

}

}

}

}

}

}

}

CloseHandle(fd);

}

}

free(fn);

return sz;

}

void scheme_init_stack_check()

/* Finds the C stack limit --- platform-specific. */

{

int *v, stack_grows_up;

uintptr_t deeper;

#ifdef UNIX_FIND_STACK_BOUNDS

struct rlimit rl;

deeper = scheme_get_deeper_address();

stack_grows_up = (deeper > (uintptr_t)&v);

#ifdef STACK_GROWS_UP

if (!stack_grows_up) {

if (scheme_console_printf)

scheme_console_printf("Stack grows DOWN, not UP.\n");

else

printf("Stack grows DOWN, not UP.\n");

exit(1);

}

#ifdef STACK_GROWS_DOWN

if (stack_grows_up) {

if (scheme_console_printf)

scheme_console_printf("Stack grows UP, not DOWN.\n");

else

printf("Stack grows UP, not DOWN.\n");

exit(1);

}

#ifdef USE_STACK_BOUNDARY_VAR

if (!scheme_stack_boundary) {

# ifdef ASSUME_FIXED_STACK_SIZE

scheme_stack_boundary = scheme_get_current_os_thread_stack_base();

if (stack_grows_up)

scheme_stack_boundary += (FIXED_STACK_SIZE - STACK_SAFETY_MARGIN);

else

scheme_stack_boundary += (STACK_SAFETY_MARGIN - FIXED_STACK_SIZE);

# ifdef WINDOWS_FIND_STACK_BOUNDS

scheme_stack_boundary = scheme_get_current_os_thread_stack_base();

{

intptr_t sz;

sz = find_exe_stack_size();

scheme_stack_boundary += (STACK_SAFETY_MARGIN - sz);

}

# ifdef MACOS_FIND_STACK_BOUNDS

scheme_stack_boundary = (uintptr_t)&v + STACK_SAFETY_MARGIN - StackSpace();

# ifdef PALMOS_FIND_STACK_BOUNDS

{

Ptr s, e;

SysGetStackInfo(Ptr &s, &e);

scheme_stack_boundary = (uintptr_t)e + STACK_SAFETY_MARGIN;

}

# ifdef BEOS_FIND_STACK_BOUNDS

{

thread_info info;

get_thread_info(find_thread(NULL), &info);

scheme_stack_boundary = (uintptr_t)info.stack_base + STACK_SAFETY_MARGIN;

}

# ifdef OSKIT_FIXED_STACK_BOUNDS

scheme_stack_boundary = (uintptr_t)base_stack_start + STACK_SAFETY_MARGIN;

# ifdef UNIX_FIND_STACK_BOUNDS

getrlimit(RLIMIT_STACK, &rl);

{

uintptr_t bnd, lim;

bnd = (uintptr_t)scheme_get_current_os_thread_stack_base();

# ifdef LINUX_FIND_STACK_BASE

bnd = adjust_stack_base(bnd);

lim = (uintptr_t)rl.rlim_cur;

# ifdef UNIX_STACK_MAXIMUM

if (lim > UNIX_STACK_MAXIMUM)

lim = UNIX_STACK_MAXIMUM;

if (stack_grows_up)

bnd += (lim - STACK_SAFETY_MARGIN);

else

bnd += (STACK_SAFETY_MARGIN - lim);

scheme_stack_boundary = bnd;

}

}

#ifdef USE_STACK_BOUNDARY_VAR

scheme_jit_stack_boundary = scheme_stack_boundary;

}

int scheme_check_runstack(intptr_t size)

/* Checks whether the Scheme stack has `size' room left */

{

return ((MZ_RUNSTACK - MZ_RUNSTACK_START) >= (size + SCHEME_TAIL_COPY_THRESHOLD));

}

void *scheme_enlarge_runstack(intptr_t size, void *(*k)())

/* Adds a Scheme stack segment, of at least `size' bytes */

{

Scheme_Thread *p = scheme_current_thread;

Scheme_Saved_Stack *saved;

void *v;

int cont_count;

volatile int escape;

mz_jmp_buf newbuf, * volatile savebuf;

saved = MALLOC_ONE_RT(Scheme_Saved_Stack);

#ifdef MZTAG_REQUIRED

saved->type = scheme_rt_saved_stack;

saved->prev = p->runstack_saved;

saved->runstack_start = MZ_RUNSTACK_START;

saved->runstack_offset = (MZ_RUNSTACK - MZ_RUNSTACK_START);

saved->runstack_size = p->runstack_size;

size += SCHEME_TAIL_COPY_THRESHOLD;

if (size) {

/* If we keep growing the stack, then probably it

intptr_t min_size;

min_size = 2 * (p->runstack_size);

if (min_size > 128000)

min_size = 128000;

if (size < min_size)

size = min_size;

} else {

/* This is for a prompt. Re-use the current size,

size = p->runstack_size;

if (size > 1000)

size = 1000;

}

if (p->spare_runstack && (size <= p->spare_runstack_size)) {

size = p->spare_runstack_size;

MZ_RUNSTACK_START = p->spare_runstack;

p->spare_runstack = NULL;

} else {

MZ_RUNSTACK_START = scheme_alloc_runstack(size);

}

p->runstack_size = size;

MZ_RUNSTACK = MZ_RUNSTACK_START + size;

p->runstack_saved = saved;

cont_count = scheme_cont_capture_count;

savebuf = p->error_buf;

p->error_buf = &newbuf;

if (scheme_setjmp(newbuf)) {

v = NULL;

escape = 1;

p = scheme_current_thread; /* might have changed! */

} else {

v = k();

escape = 0;

p = scheme_current_thread; /* might have changed! */

if (cont_count == scheme_cont_capture_count) {

if (!p->spare_runstack || (p->runstack_size > p->spare_runstack_size)) {

p->spare_runstack = MZ_RUNSTACK_START;

p->spare_runstack_size = p->runstack_size;

}

}

}

p->error_buf = savebuf;

saved = p->runstack_saved;

p->runstack_saved = saved->prev;

MZ_RUNSTACK_START = saved->runstack_start;

MZ_RUNSTACK = MZ_RUNSTACK_START + saved->runstack_offset;

p->runstack_size = saved->runstack_size;

if (escape) {

scheme_longjmp(*p->error_buf, 1);

}

return v;

}

static Scheme_Object *link_module_variable(Scheme_Object *modidx,

int flags, Scheme_Object *shape)

{

Scheme_Object *modname;

Scheme_Env *menv;

Scheme_Bucket *bkt;

int self = 0;

/* If it's a name id, resolve the name. */

modname = scheme_module_resolve(modidx, 1);

if (env->module && SAME_OBJ(env->module->modname, modname)

&& (env->mod_phase == mod_phase)) {

self = 1;

menv = env;

} else {

menv = scheme_module_access(modname, env, mod_phase);

if (!menv) {

scheme_wrong_syntax("link", NULL, varname,

"namespace mismatch;\n"

" reference to a module that is not available\n"

" reference phase: %d\n"

" referenced module: %D\n"

" referenced phase level: %d\n"

" reference in module: %D",

env->phase,

modname,

mod_phase,

env->module ? env->module->modsrc : scheme_false);

return NULL;

}

if (check_access && !SAME_OBJ(menv, env)) {

varname = scheme_check_accessible_in_module(menv, insp, NULL, varname, NULL, NULL,

insp, NULL, pos, 0, NULL, NULL, env, NULL,

NULL);

}

}

if (exprs) {

if (self) {

exprs[which] = varname;

} else {

if (flags & SCHEME_MODVAR_CONST) {

Scheme_Object *v;

v = scheme_make_vector((mod_phase != 0) ? 4 : 3, modname);

SCHEME_VEC_ELS(v)[1] = varname;

SCHEME_VEC_ELS(v)[2] = (shape ? shape : scheme_false);

if (mod_phase != 0)

SCHEME_VEC_ELS(v)[3] = scheme_make_integer(mod_phase);

} else {

Scheme_Object *v = modname;

if (mod_phase != 0)

v = scheme_make_pair(v, scheme_make_integer(mod_phase));

v = scheme_make_pair(varname, v);

exprs[which] = v;

}

}

}

bkt = scheme_global_bucket(varname, menv);

if (!self) {

const char *bad_reason = NULL;

if (!bkt->val) {

bad_reason = "is uninitialized";

} else if (flags) {

if (flags & SCHEME_MODVAR_CONST) {

if (!(((Scheme_Bucket_With_Flags *)bkt)->flags & GLOB_IS_CONSISTENT))

bad_reason = "is not a procedure or structure-type constant across all instantiations";

else if (shape && SCHEME_TRUEP(shape)) {

if (!scheme_get_or_check_procedure_shape(bkt->val, shape))

bad_reason = "has the wrong procedure or structure-type shape";

}

} else {

if (!(((Scheme_Bucket_With_Flags *)bkt)->flags & GLOB_IS_IMMUTATED))

bad_reason = "not constant";

}

}

if (bad_reason) {

scheme_wrong_syntax("link", NULL, varname,

"bad variable linkage;\n"

" reference to a variable that %s\n"

" reference phase level: %d\n"

" variable module: %D\n"

" variable phase: %d\n"

" reference in module: %D",

bad_reason,

env->phase,

modname,

mod_phase,

env->module ? env->module->modsrc : scheme_false);

}

if (!(((Scheme_Bucket_With_Flags *)bkt)->flags & (GLOB_IS_IMMUTATED | GLOB_IS_LINKED)))

((Scheme_Bucket_With_Flags *)bkt)->flags |= GLOB_IS_LINKED;

}

return (Scheme_Object *)bkt;

}

static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env *env,

Scheme_Object *src_modidx,

Scheme_Object *dest_modidx,

Scheme_Object *insp)

{

Scheme_Object *expr = exprs[which];

if (SCHEME_FALSEP(expr)) {

/* See scheme_make_environment_dummy */

Scheme_Bucket *b;

b = scheme_global_bucket(scheme_stack_dump_key, env);

if (!(((Scheme_Bucket_With_Flags *)b)->flags & GLOB_STRONG_HOME_LINK)) {

((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_STRONG_HOME_LINK;

((Scheme_Bucket_With_Home *)b)->home_link = (Scheme_Object *)env;

}

return (Scheme_Object *)b;

} else if (SCHEME_PAIRP(expr) || SCHEME_SYMBOLP(expr) || SCHEME_VECTORP(expr)) {

/* Simplified module reference (as installed by link_module_variable) */

Scheme_Object *modname, *varname, *shape;

int mod_phase = 0, flags = 0;

if (SCHEME_SYMBOLP(expr)) {

if (!env->module) {

/* compiled as a module variable, but instantiated in a non-module

return (Scheme_Object *)scheme_global_bucket(expr, env);

} else {

varname = expr;

modname = env->module->modname;

mod_phase = env->mod_phase;

}

shape = NULL;

} else if (SCHEME_PAIRP(expr)) {

varname = SCHEME_CAR(expr);

modname = SCHEME_CDR(expr);

if (SCHEME_PAIRP(modname)) {

mod_phase = SCHEME_INT_VAL(SCHEME_CDR(modname));

modname = SCHEME_CAR(modname);

}

shape = NULL;

} else {

modname = SCHEME_VEC_ELS(expr)[0];

varname = SCHEME_VEC_ELS(expr)[1];

flags = SCHEME_MODVAR_CONST;

shape = SCHEME_VEC_ELS(expr)[2];

if (SCHEME_VEC_SIZE(expr) > 3)

mod_phase = SCHEME_INT_VAL(SCHEME_VEC_ELS(expr)[3]);

}

return link_module_variable(modname,

varname,

0, NULL,

-1, mod_phase,

env,

NULL, 0,

flags, shape);

} else if (SAME_TYPE(SCHEME_TYPE(expr), scheme_variable_type)) {

Scheme_Bucket *b = (Scheme_Bucket *)expr;

Scheme_Env *home;

home = scheme_get_bucket_home(b);

if (!env || !home || !home->module)

return (Scheme_Object *)b;

else

return link_module_variable(home->module->modname,

(Scheme_Object *)b->key,

1, home->access_insp,

-1, home->mod_phase,

env,

exprs, which,

0, NULL);

} else {

Module_Variable *mv = (Module_Variable *)expr;

if ((!insp || SCHEME_FALSEP(insp)) && !mv->insp)

insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);

return link_module_variable(scheme_modidx_shift(mv->modidx,

src_modidx,

dest_modidx),

mv->sym, 1, (mv->insp ? mv->insp : insp),

mv->pos, mv->mod_phase,

env,

exprs, which,

SCHEME_MODVAR_FLAGS(mv) & 0x3, mv->shape);

}

}

void scheme_push_continuation_frame(Scheme_Cont_Frame_Data *d)

{

d->cont_mark_pos = MZ_CONT_MARK_POS;