#include "schpriv.h"

#include "schexpobs.h"

#include "schmach.h"

#ifdef TIME_SYNTAX

# ifdef USE_MACTIME

# include <OSUtils.h>

# include <Timer.h>

# ifndef USE_PALMTIME

# if defined(OSKIT) && !defined(OSKIT_TEST)

/* Get FreeBSD version, not oskit/time.h version */

# include <freebsd/time.h>

# include <time.h>

# ifdef USE_FTIME

# include <sys/timeb.h>

# include <sys/time.h>

# endif /* USE_FTIME */

# ifdef USE_GETRUSAGE

# include <sys/types.h>

# include <sys/time.h>

# include <sys/resource.h>

# include <errno.h>

# endif /* USE_GETRUSAGE */

# ifdef USE_SYSCALL_GETRUSAGE

# include <sys/syscall.h>

# define getrusage(a, b) syscall(SYS_GETRUSAGE, a, b)

# define USE_GETRUSAGE

# endif /* USE_SYSCALL_GETRUSAGE */

# ifdef WINDOWS_GET_PROCESS_TIMES

# include <Windows.h>

# endif /* USE_PALMTIME */

# endif /* USE_MACTIME */

#endif /* TIME_SYNTAX */

static void ASSERT_SUSPEND_BREAK_ZERO() {

#if 0

if (scheme_current_thread->suspend_break)

abort();

}

SHARED_OK int scheme_defining_primitives; /* set to 1 during start-up */

SHARED_OK int scheme_prim_opt_flags[(1 << SCHEME_PRIM_OPT_INDEX_SIZE)];

READ_ONLY Scheme_Object scheme_void[1]; /* the void constant */

READ_ONLY Scheme_Object *scheme_values_func; /* the function bound to `values' */

READ_ONLY Scheme_Object *scheme_procedure_p_proc;

READ_ONLY Scheme_Object *scheme_procedure_arity_includes_proc;

READ_ONLY Scheme_Object *scheme_void_proc;

READ_ONLY Scheme_Object *scheme_apply_proc;

READ_ONLY Scheme_Object *scheme_call_with_values_proc; /* the function bound to `call-with-values' */

READ_ONLY Scheme_Object *scheme_reduced_procedure_struct;

READ_ONLY Scheme_Object *scheme_tail_call_waiting;

READ_ONLY Scheme_Object *scheme_inferred_name_symbol;

READ_ONLY Scheme_Object *scheme_default_prompt_tag;

ROSYM static Scheme_Object *certify_mode_symbol;

ROSYM static Scheme_Object *taint_mode_symbol;

ROSYM static Scheme_Object *transparent_symbol;

ROSYM static Scheme_Object *transparent_binding_symbol;

ROSYM static Scheme_Object *opaque_symbol;

ROSYM static Scheme_Object *none_symbol;

ROSYM static Scheme_Object *is_method_symbol;

ROSYM static Scheme_Object *cont_key; /* uninterned */

ROSYM static Scheme_Object *barrier_prompt_key; /* uninterned */

ROSYM static Scheme_Object *prompt_cc_guard_key; /* uninterned */

READ_ONLY static Scheme_Prompt *original_default_prompt; /* for escapes, represents the implicit initial prompt */

READ_ONLY static Scheme_Object *call_with_prompt_proc;

READ_ONLY static Scheme_Object *abort_continuation_proc;

READ_ONLY static Scheme_Object *internal_call_cc_prim;

READ_ONLY static Scheme_Object *finish_call_cc_prim;

THREAD_LOCAL_DECL(static Scheme_Prompt *available_prompt);

THREAD_LOCAL_DECL(static Scheme_Prompt *available_cws_prompt);

THREAD_LOCAL_DECL(static Scheme_Prompt *available_regular_prompt);

THREAD_LOCAL_DECL(static Scheme_Dynamic_Wind *available_prompt_dw);

THREAD_LOCAL_DECL(static Scheme_Meta_Continuation *available_prompt_mc);

THREAD_LOCAL_DECL(static Scheme_Cont *offstack_cont);

THREAD_LOCAL_DECL(static Scheme_Overflow *offstack_overflow);

THREAD_LOCAL_DECL(int scheme_cont_capture_count);

THREAD_LOCAL_DECL(static int scheme_prompt_capture_count);

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

#ifdef TIME_SYNTAX

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Scheme_Object *scheme_values(int argc, Scheme_Object *argv[]);

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

static Scheme_Object *current_prompt_read(int, Scheme_Object **);

static Scheme_Object *current_read(int, Scheme_Object **);

static Scheme_Object *current_get_read_input_port(int, Scheme_Object **);

static Scheme_Object *chaperone_wrap_cc_guard(Scheme_Object *obj, Scheme_Object *proc);

static Scheme_Object *do_cc_guard(Scheme_Object *v, Scheme_Object *cc_guard, Scheme_Object *chaperone);

static Scheme_Object *

scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key,

Scheme_Object *prompt_tag, Scheme_Meta_Continuation **_meta,

MZ_MARK_POS_TYPE *_vpos);

static Scheme_Object *get_set_cont_mark_by_pos(Scheme_Object *key,

Scheme_Object *val);

static Scheme_Object *jump_to_alt_continuation();

static void reset_cjs(Scheme_Continuation_Jump_State *a);

typedef void (*DW_PrePost_Proc)(void *);

#define CONS(a,b) scheme_make_pair(a,b)

#ifdef MZ_PRECISE_GC

static void register_traversers(void);

typedef struct Scheme_Dynamic_Wind_List {

} Scheme_Dynamic_Wind_List;

scheme_init_fun (Scheme_Env *env)

{

Scheme_Object *o;

#ifdef MZ_PRECISE_GC

register_traversers();

#ifdef MZ_APPLY_WAITING_CONSTANT

scheme_tail_call_waiting = MZ_APPLY_WAITING_CONSTANT;

REGISTER_SO(scheme_tail_call_waiting);

scheme_tail_call_waiting = scheme_alloc_eternal_object();

scheme_tail_call_waiting->type = scheme_tail_call_waiting_type;

REGISTER_SO(scheme_procedure_p_proc);

REGISTER_SO(scheme_procedure_arity_includes_proc);

o = scheme_make_folding_prim(procedure_p, "procedure?", 1, 1, 1);

SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED

| SCHEME_PRIM_IS_OMITABLE);

scheme_add_global_constant("procedure?", o, env);

scheme_procedure_p_proc = o;

REGISTER_SO(scheme_apply_proc);

scheme_apply_proc = scheme_make_prim_w_arity2(apply,

"apply",

2, -1,

0, -1);

scheme_add_global_constant("apply", scheme_apply_proc, env);

scheme_add_global_constant("map",

scheme_make_noncm_prim(map,

"map",

2, -1),

env);

scheme_add_global_constant("for-each",

scheme_make_noncm_prim(for_each,

"for-each",

2, -1),

env);

scheme_add_global_constant("andmap",

scheme_make_prim_w_arity(andmap,

"andmap",

2, -1),

env);

scheme_add_global_constant("ormap",

scheme_make_prim_w_arity(ormap,

"ormap",

2, -1),

env);

REGISTER_SO(scheme_call_with_values_proc);

scheme_call_with_values_proc = scheme_make_prim_w_arity2(call_with_values,

"call-with-values",

2, 2,

0, -1);

scheme_add_global_constant("call-with-values",

scheme_call_with_values_proc,

env);

REGISTER_SO(scheme_values_func);

scheme_values_func = scheme_make_prim_w_arity2(scheme_values,

"values",

0, -1,

0, -1);

SCHEME_PRIM_PROC_FLAGS(scheme_values_func) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED

| SCHEME_PRIM_IS_BINARY_INLINED

| SCHEME_PRIM_IS_NARY_INLINED

| SCHEME_PRIM_IS_OMITABLE);

scheme_add_global_constant("values",

scheme_values_func,

env);

o = scheme_make_prim_w_arity2(scheme_call_ec,

"call-with-escape-continuation",

1, 1,

0, -1);

scheme_add_global_constant("call-with-escape-continuation", o, env);

scheme_add_global_constant("call/ec", o, env);

REGISTER_SO(internal_call_cc_prim);

internal_call_cc_prim = scheme_make_prim_w_arity2(internal_call_cc,

"call-with-current-continuation",

1, 3,

0, -1);

REGISTER_SO(finish_call_cc_prim);

finish_call_cc_prim = scheme_make_prim_w_arity2(finish_call_cc,

"finish-call-with-current-continuation",

2, 2,

0, -1);

o = scheme_make_prim_w_arity2(call_cc,

"call-with-current-continuation",

1, 2,

0, -1);

scheme_add_global_constant("call-with-current-continuation", o, env);

scheme_add_global_constant("call/cc", o, env);

scheme_add_global_constant("continuation?",

scheme_make_folding_prim(continuation_p,

"continuation?",

1, 1, 1),

env);

scheme_add_global_constant("call-with-continuation-barrier",

scheme_make_prim_w_arity2(call_with_continuation_barrier,

"call-with-continuation-barrier",

1, 1,

0, -1),

env);

REGISTER_SO(call_with_prompt_proc);

call_with_prompt_proc = scheme_make_prim_w_arity2(call_with_prompt,

"call-with-continuation-prompt",

1, -1,

0, -1);

scheme_add_global_constant("call-with-continuation-prompt",

call_with_prompt_proc,

env);

scheme_add_global_constant("call-with-composable-continuation",

scheme_make_prim_w_arity2(call_with_control,

"call-with-composable-continuation",

1, 2,

0, -1),

env);

REGISTER_SO(abort_continuation_proc);

abort_continuation_proc = scheme_make_prim_w_arity(abort_continuation,

"abort-current-continuation",

1, -1);

scheme_add_global_constant("abort-current-continuation",

abort_continuation_proc,

env);

scheme_add_global_constant("continuation-prompt-available?",

scheme_make_prim_w_arity(continuation_prompt_available,

"continuation-prompt-available?",

1, 2),

env);

scheme_add_global_constant("make-continuation-prompt-tag",

scheme_make_prim_w_arity(make_prompt_tag,

"make-continuation-prompt-tag",

0, 1),

env);

scheme_add_global_constant("default-continuation-prompt-tag",

scheme_make_prim_w_arity(get_default_prompt_tag,

"default-continuation-prompt-tag",

0, 0),

env);

scheme_add_global_constant("continuation-prompt-tag?",

scheme_make_folding_prim(prompt_tag_p,

"continuation-prompt-tag?",

1, 1, 1),

env);

scheme_add_global_constant("impersonate-prompt-tag",

scheme_make_prim_w_arity(impersonate_prompt_tag,

"impersonate-prompt-tag",

3, -1),

env);

scheme_add_global_constant("chaperone-prompt-tag",

scheme_make_prim_w_arity(chaperone_prompt_tag,

"chaperone-prompt-tag",

3, -1),

env);

scheme_add_global_constant("call-with-semaphore",

scheme_make_prim_w_arity2(call_with_sema,

"call-with-semaphore",

2, -1,

0, -1),

env);

scheme_add_global_constant("call-with-semaphore/enable-break",

scheme_make_prim_w_arity2(call_with_sema_enable_break,

"call-with-semaphore/enable-break",

2, -1,

0, -1),

env);

scheme_add_global_constant("make-continuation-mark-key",

scheme_make_prim_w_arity(make_continuation_mark_key,

"make-continuation-mark-key",

0, 1),

env);

scheme_add_global_constant("continuation-mark-key?",

scheme_make_prim_w_arity(continuation_mark_key_p,

"continuation-mark-key?",

1, 1),

env);

scheme_add_global_constant("impersonate-continuation-mark-key",

scheme_make_prim_w_arity(impersonate_continuation_mark_key,

"impersonate-continuation-mark-key",

3, -1),

env);

scheme_add_global_constant("chaperone-continuation-mark-key",

scheme_make_prim_w_arity(chaperone_continuation_mark_key,

"chaperone-continuation-mark-key",

3, -1),

env);

scheme_add_global_constant("current-continuation-marks",

scheme_make_prim_w_arity(cc_marks,

"current-continuation-marks",

0, 1),

env);

scheme_add_global_constant("continuation-marks",

scheme_make_prim_w_arity(cont_marks,

"continuation-marks",

1, 2),

env);

scheme_add_global_constant("continuation-mark-set->list",

scheme_make_prim_w_arity(extract_cc_marks,

"continuation-mark-set->list",

2, 3),

env);

scheme_add_global_constant("continuation-mark-set->list*",

scheme_make_prim_w_arity(extract_cc_markses,

"continuation-mark-set->list*",

2, 4),

env);

o = scheme_make_prim_w_arity(extract_one_cc_mark,

"continuation-mark-set-first",

2, 4);

SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED);

scheme_add_global_constant("continuation-mark-set-first", o, env);

scheme_add_global_constant("call-with-immediate-continuation-mark",

scheme_make_prim_w_arity2(call_with_immediate_cc_mark,

"call-with-immediate-continuation-mark",

2, 3,

0, -1),

env);

scheme_add_global_constant("continuation-mark-set?",

scheme_make_prim_w_arity(cc_marks_p,

"continuation-mark-set?",

1, 1),

env);

scheme_add_global_constant("continuation-mark-set->context",

scheme_make_prim_w_arity(extract_cc_proc_marks,

"continuation-mark-set->context",

1, 1),

env);

REGISTER_SO(scheme_void_proc);

scheme_void_proc = scheme_make_folding_prim(void_func,

"void",

0, -1, 1);

SCHEME_PRIM_PROC_FLAGS(scheme_void_proc) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_OMITABLE);

scheme_add_global_constant("void", scheme_void_proc, env);

o = scheme_make_folding_prim(void_p, "void?", 1, 1, 1);

SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED

| SCHEME_PRIM_IS_OMITABLE);

scheme_add_global_constant("void?", o, env);

#ifdef TIME_SYNTAX

scheme_add_global_constant("time-apply",

scheme_make_prim_w_arity2(time_apply,

"time-apply",

2, 2,

4, 4),

env);

scheme_add_global_constant("current-milliseconds",

scheme_make_immed_prim(current_milliseconds,

"current-milliseconds",

0, 0),

env);

scheme_add_global_constant("current-inexact-milliseconds",

scheme_make_immed_prim(current_inexact_milliseconds,

"current-inexact-milliseconds",

0, 0),

env);

scheme_add_global_constant("current-process-milliseconds",

scheme_make_immed_prim(current_process_milliseconds,

"current-process-milliseconds",

0, 1),

env);

scheme_add_global_constant("current-gc-milliseconds",

scheme_make_immed_prim(current_gc_milliseconds,

"current-gc-milliseconds",

0, 0),

env);

scheme_add_global_constant("current-seconds",

scheme_make_immed_prim(current_seconds,

"current-seconds",

0, 0),

env);

scheme_add_global_constant("seconds->date",

scheme_make_immed_prim(seconds_to_date,

"seconds->date",

1, 2),

env);

scheme_add_global_constant("dynamic-wind",

scheme_make_prim_w_arity(dynamic_wind,

"dynamic-wind",

3, 3),

env);

scheme_add_global_constant("object-name",

scheme_make_folding_prim(object_name,

"object-name",

1, 1, 1),

env);

scheme_add_global_constant("procedure-arity",

scheme_make_folding_prim(procedure_arity,

"procedure-arity",

1, 1, 1),

env);

scheme_add_global_constant("procedure-arity?",

scheme_make_folding_prim(procedure_arity_p,

"procedure-arity?",

1, 1, 1),

env);

o = scheme_make_folding_prim(scheme_procedure_arity_includes,

"procedure-arity-includes?",

2, 3, 1);

SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED);

scheme_procedure_arity_includes_proc = o;

scheme_add_global_constant("procedure-arity-includes?", o, env);

scheme_add_global_constant("procedure-reduce-arity",

scheme_make_prim_w_arity(procedure_reduce_arity,

"procedure-reduce-arity",

2, 2),

env);

scheme_add_global_constant("procedure-rename",

scheme_make_prim_w_arity(procedure_rename,

"procedure-rename",

2, 2),

env);

scheme_add_global_constant("procedure->method",

scheme_make_prim_w_arity(procedure_to_method,

"procedure->method",

1, 1),

env);

scheme_add_global_constant("procedure-closure-contents-eq?",

scheme_make_folding_prim(procedure_equal_closure_p,

"procedure-closure-contents-eq?",

2, 2, 1),

env);

scheme_add_global_constant("chaperone-procedure",

scheme_make_prim_w_arity(chaperone_procedure,

"chaperone-procedure",

2, -1),

env);

scheme_add_global_constant("impersonate-procedure",

scheme_make_prim_w_arity(impersonate_procedure,

"impersonate-procedure",

2, -1),

env);

scheme_add_global_constant("primitive?",

scheme_make_folding_prim(primitive_p,

"primitive?",

1, 1, 1),

env);

scheme_add_global_constant("primitive-closure?",

scheme_make_folding_prim(primitive_closure_p,

"primitive-closure?",

1, 1, 1),

env);

scheme_add_global_constant("primitive-result-arity",

scheme_make_folding_prim(primitive_result_arity,

"primitive-result-arity",

1, 1, 1),

env);

scheme_add_global_constant("current-print",

scheme_register_parameter(current_print,

"current-print",

MZCONFIG_PRINT_HANDLER),

env);

scheme_add_global_constant("current-prompt-read",

scheme_register_parameter(current_prompt_read,

"current-prompt-read",

MZCONFIG_PROMPT_READ_HANDLER),

env);

scheme_add_global_constant("current-read-interaction",

scheme_register_parameter(current_read,

"current-read-interaction",

MZCONFIG_READ_HANDLER),

env);

scheme_add_global_constant("current-get-interaction-input-port",

scheme_register_parameter(current_get_read_input_port,

"current-get-interaction-input-port",

MZCONFIG_READ_INPUT_PORT_HANDLER),

env);

REGISTER_SO(certify_mode_symbol);

REGISTER_SO(taint_mode_symbol);

REGISTER_SO(transparent_symbol);

REGISTER_SO(transparent_binding_symbol);

REGISTER_SO(opaque_symbol);

REGISTER_SO(none_symbol);

certify_mode_symbol = scheme_intern_symbol("certify-mode");

taint_mode_symbol = scheme_intern_symbol("taint-mode");

transparent_symbol = scheme_intern_symbol("transparent");

transparent_binding_symbol = scheme_intern_symbol("transparent-binding");

opaque_symbol = scheme_intern_symbol("opaque");

none_symbol = scheme_intern_symbol("none");

REGISTER_SO(is_method_symbol);

REGISTER_SO(scheme_inferred_name_symbol);

REGISTER_SO(cont_key);

REGISTER_SO(barrier_prompt_key);

REGISTER_SO(prompt_cc_guard_key);

is_method_symbol = scheme_intern_symbol("method-arity-error");

scheme_inferred_name_symbol = scheme_intern_symbol("inferred-name");

cont_key = scheme_make_symbol("k"); /* uninterned */

barrier_prompt_key = scheme_make_symbol("bar"); /* uninterned */

prompt_cc_guard_key = scheme_make_symbol("cc"); /* uninterned */

REGISTER_SO(scheme_default_prompt_tag);

{

Scheme_Object *a[1];

a[0] = scheme_intern_symbol("default");

scheme_default_prompt_tag = make_prompt_tag(1, a);

(void)scheme_hash_key(SCHEME_PTR_VAL(scheme_default_prompt_tag));

}

REGISTER_SO(original_default_prompt);

original_default_prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);

original_default_prompt->so.type = scheme_prompt_type;

original_default_prompt->tag = scheme_default_prompt_tag;

}

scheme_init_fun_places()

{

REGISTER_SO(offstack_cont);

REGISTER_SO(offstack_overflow);

}

Scheme_Object *

scheme_make_void (void)

{

return scheme_void;

}

static Scheme_Object *

make_prim_closure(Scheme_Prim *fun, int eternal,

int closed, int count, Scheme_Object **vals)

{

Scheme_Primitive_Proc *prim;

int hasr, size;

hasr = ((minr != 1) || (maxr != 1));

size = (hasr

? sizeof(Scheme_Prim_W_Result_Arity)

: (closed

? (sizeof(Scheme_Primitive_Closure)

+ ((count - mzFLEX_DELTA) * sizeof(Scheme_Object *)))

: sizeof(Scheme_Primitive_Proc)));

if (eternal && scheme_starting_up && !closed)

prim = (Scheme_Primitive_Proc *)scheme_malloc_eternal_tagged(size);

else

prim = (Scheme_Primitive_Proc *)scheme_malloc_tagged(size);

prim->pp.so.type = scheme_prim_type;

prim->prim_val = (Scheme_Primitive_Closure_Proc *)fun;

prim->name = name;

prim->mina = mina;

if (maxa < 0)

maxa = SCHEME_MAX_ARGS + 1;

prim->mu.maxa = maxa;

prim->pp.flags = (flags

| (scheme_defining_primitives ? SCHEME_PRIM_IS_PRIMITIVE : 0)

| (hasr ? SCHEME_PRIM_IS_MULTI_RESULT : 0)

| (closed ? SCHEME_PRIM_IS_CLOSURE : 0));

if (hasr) {

((Scheme_Prim_W_Result_Arity *)prim)->minr = minr;

((Scheme_Prim_W_Result_Arity *)prim)->maxr = maxr;

}

if (closed) {

#ifdef MZ_PRECISE_GC

((Scheme_Primitive_Closure *)prim)->count = count;

memcpy(((Scheme_Primitive_Closure *)prim)->val,

vals,

count * sizeof(Scheme_Object *));

}

return (Scheme_Object *)prim;

}

Scheme_Object *

scheme_make_prim_w_everything(Scheme_Prim *fun, int eternal,

mzshort minr, mzshort maxr)

{

return make_prim_closure(fun, eternal,

name,

mina, maxa,

flags,

minr, maxr,

0, 0, NULL);

}

Scheme_Object *scheme_make_prim(Scheme_Prim *fun)

{

return make_prim_closure(fun, 1, NULL, 0, -1, 0, 1, 1,

0, 0, NULL);

}

Scheme_Object *

scheme_make_noneternal_prim (Scheme_Prim *fun)

{

return make_prim_closure(fun, 0, NULL, 0, -1, 0, 1, 1,

0, 0, NULL);

}

Scheme_Object *

scheme_make_prim_w_arity(Scheme_Prim *fun, const char *name,

mzshort mina, mzshort maxa)

{

return make_prim_closure(fun, 1, name, mina, maxa, 0, 1, 1,

0, 0, NULL);

}

Scheme_Object *

scheme_make_folding_prim(Scheme_Prim *fun, const char *name,

mzshort mina, mzshort maxa,

short folding)

{

return make_prim_closure(fun, 1, name, mina, maxa,

(folding

? SCHEME_PRIM_OPT_FOLDING

: 0),

1, 1,

0, 0, NULL);

}

Scheme_Object *

scheme_make_noncm_prim(Scheme_Prim *fun, const char *name,

mzshort mina, mzshort maxa)

{

/* A non-cm primitive leaves the mark stack unchanged when it returns,

return make_prim_closure(fun, 1, name, mina, maxa,

SCHEME_PRIM_OPT_NONCM,

1, 1,

0, 0, NULL);

}

Scheme_Object *

scheme_make_immed_prim(Scheme_Prim *fun, const char *name,

mzshort mina, mzshort maxa)

{

/* An immediate primitive is a non-cm primitive, and it doesn't

return make_prim_closure(fun, 1, name, mina, maxa,

SCHEME_PRIM_OPT_IMMEDIATE,

1, 1,

0, 0, NULL);

}

Scheme_Object *

scheme_make_noneternal_prim_w_arity(Scheme_Prim *fun, const char *name,

mzshort mina, mzshort maxa)

{

return make_prim_closure(fun, 0, name, mina, maxa, 0, 1, 1,

0, 0, NULL);

}

Scheme_Object *scheme_make_prim_closure_w_arity(Scheme_Primitive_Closure_Proc *prim,

int size, Scheme_Object **vals,

const char *name,

mzshort mina, mzshort maxa)

{

return make_prim_closure((Scheme_Prim *)prim, 1, name, mina, maxa, 0, 1, 1,

1, size, vals);

}

Scheme_Object *scheme_make_folding_prim_closure(Scheme_Primitive_Closure_Proc *prim,

short functional)

{

return make_prim_closure((Scheme_Prim *)prim, 1, name, mina, maxa,

(functional

? SCHEME_PRIM_OPT_FOLDING

: 0),

1, 1,

1, size, vals);

}

Scheme_Object *

scheme_make_closed_prim_w_everything(Scheme_Closed_Prim *fun,

mzshort minr, mzshort maxr)

{

Scheme_Closed_Primitive_Proc *prim;

int hasr, size;

hasr = ((minr != 1) || (maxr != 1));

size = hasr ? sizeof(Scheme_Closed_Prim_W_Result_Arity) : sizeof(Scheme_Closed_Primitive_Proc);

prim = (Scheme_Closed_Primitive_Proc *)scheme_malloc_tagged(size);

prim->pp.so.type = scheme_closed_prim_type;

SCHEME_CLSD_PRIM(prim) = fun;

SCHEME_CLSD_PRIM_DATA(prim) = data;

prim->name = name;

prim->mina = mina;

prim->maxa = maxa;

prim->pp.flags = ((folding ? SCHEME_PRIM_OPT_FOLDING : 0)

| (scheme_defining_primitives ? SCHEME_PRIM_IS_PRIMITIVE : 0)

| (hasr ? SCHEME_PRIM_IS_MULTI_RESULT : 0));

if (hasr) {

((Scheme_Closed_Prim_W_Result_Arity *)prim)->minr = minr;

((Scheme_Closed_Prim_W_Result_Arity *)prim)->maxr = maxr;

}

return (Scheme_Object *)prim;

}

Scheme_Object *

scheme_make_folding_closed_prim(Scheme_Closed_Prim *fun,

short folding)

{

return scheme_make_closed_prim_w_everything(fun, data, name, mina, maxa, folding, 1, 1);

}

Scheme_Object *

scheme_make_closed_prim_w_arity(Scheme_Closed_Prim *fun, void *data,

const char *name, mzshort mina, mzshort maxa)

{

return scheme_make_closed_prim_w_everything(fun, data, name, mina, maxa, 0, 1, 1);

}

Scheme_Object *

scheme_make_closed_prim(Scheme_Closed_Prim *fun, void *data)

{

return scheme_make_closed_prim_w_everything(fun, data, NULL, 0, -1, 0, 1, 1);

}

void scheme_prim_is_method(Scheme_Object *o)

{

if (SCHEME_CLSD_PRIMP(o))

((Scheme_Closed_Primitive_Proc *)o)->pp.flags |= SCHEME_PRIM_IS_METHOD;

else

((Scheme_Primitive_Proc *)o)->pp.flags |= SCHEME_PRIM_IS_METHOD;

}

int scheme_has_method_property(Scheme_Object *code)

{

return SCHEME_TRUEP(scheme_stx_property(code, is_method_symbol, NULL));

}

int scheme_intern_prim_opt_flags(int flags)

{

int i;

if (!flags) return 0;

for (i = 1; i < (1 << SCHEME_PRIM_OPT_INDEX_SIZE); i++) {

if (scheme_prim_opt_flags[i] == flags)

return (i << SCHEME_PRIM_OPT_INDEX_SHIFT);

else if (!scheme_prim_opt_flags[i]) {

scheme_prim_opt_flags[i] = flags;

return (i << SCHEME_PRIM_OPT_INDEX_SHIFT);

}

}

scheme_signal_error("too many flag combinations");

return 0;

}

static void initialize_prompt(Scheme_Thread *p, Scheme_Prompt *prompt, void *stack_boundary)

{

prompt->is_barrier = 0;

prompt->stack_boundary = stack_boundary;

prompt->runstack_boundary_start = MZ_RUNSTACK_START;

prompt->runstack_boundary_offset = (MZ_RUNSTACK - MZ_RUNSTACK_START);

prompt->mark_boundary = MZ_CONT_MARK_STACK;

prompt->boundary_mark_pos = MZ_CONT_MARK_POS;

}

typedef Scheme_Object *(*Overflow_K_Proc)(void);

THREAD_LOCAL_DECL(Scheme_Overflow_Jmp *scheme_overflow_jmp);

THREAD_LOCAL_DECL(void *scheme_overflow_stack_start);

MZ_DO_NOT_INLINE(void scheme_really_create_overflow(void *stack_base));

void scheme_really_create_overflow(void *stack_base)

{

Scheme_Overflow_Jmp *jmp;

if (scheme_overflow_jmp)

return;

scheme_overflow_stack_start = stack_base;

jmp = MALLOC_ONE_RT(Scheme_Overflow_Jmp);

#ifdef MZTAG_REQUIRED

jmp->type = scheme_rt_overflow_jmp;

scheme_init_jmpup_buf(&jmp->cont);

if (scheme_setjmpup(&jmp->cont, jmp, stack_base)) {

/* A jump into here is a request to handle overflow.

Scheme_Thread * volatile p;

Scheme_Overflow * volatile overflow;

mz_jmp_buf nestedbuf;

p = scheme_current_thread;

overflow = p->overflow;

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

p->error_buf = &nestedbuf;

if (scheme_setjmp(nestedbuf)) {

/* there was an escape from the overflow */

p = scheme_current_thread;

p->overflow_reply = NULL; /* means "continue the error" */

} else {

void *p1, *p2, *p3, *p4, *p5;

intptr_t i1, i2, i3, i4;

Overflow_K_Proc f = p->overflow_k;

Scheme_Object *reply;

p1 = p->ku.k.p1;