/* This file is a hodge-podge of various aspects of application and
   continuations.  It includes primitives like `call/cc' and
   `procedure-arity', which have no better home, as well as parts of
   closure compilation and wrappers for evaluation to handle stack
   overflow and continuation-jump limits. */

#include "schpriv.h"
#include "schmach.h"
#include "schrktio.h"

static void ASSERT_SUSPEND_BREAK_ZERO() {
#if 0
  if (scheme_current_thread->suspend_break)
    abort();
#endif
}

/* globals */
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_proc; /* 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_procedure_specialize_proc;
READ_ONLY Scheme_Object *scheme_void_proc;
READ_ONLY Scheme_Object *scheme_void_p_proc;
READ_ONLY Scheme_Object *scheme_check_not_undefined_proc;
READ_ONLY Scheme_Object *scheme_check_assign_not_undefined_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_call_with_immed_mark_proc;
READ_ONLY Scheme_Object *scheme_reduced_procedure_struct;
READ_ONLY Scheme_Object *scheme_tail_call_waiting;
READ_ONLY Scheme_Object *scheme_default_prompt_tag;
READ_ONLY Scheme_Object *scheme_root_prompt_tag;
READ_ONLY Scheme_Object *scheme_chaperone_undefined_property;

/* READ ONLY SHARABLE GLOBALS */

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 *subprocesses_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 */
ROSYM static Scheme_Object *mark_symbol;
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;
READ_ONLY static Scheme_Object *propagate_abort_prim;

/* Caches need to be thread-local: */
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);

#define MARK_CACHE_THRESHOLD 16

/* locals */
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 *call_in_continuation (int argc, Scheme_Object *argv[]);
static Scheme_Object *propagate_abort (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_iterator (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[]);
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_inexact_monotonic_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_arity_mask(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_reduce_arity_mask(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 *procedure_specialize(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_chaperone_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *impersonate_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_impersonate_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_procedure_star(int argc, Scheme_Object *argv[]);
static Scheme_Object *impersonate_procedure_star(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 *procedure_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 *chaperone_unsafe_undefined(int argc, Scheme_Object **argv);

static Scheme_Object *unsafe_abort_continuation_no_dws(int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_call_with_control_no_dws(int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_root_continuation_prompt_tag(int argc, Scheme_Object *argv[]);

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_Thread *p,
                                               Scheme_Meta_Continuation *mc,
                                               MZ_MARK_POS_TYPE mpos,
                                               Scheme_Object *val);
static Scheme_Cont_Mark_Chain *current_mark_chain(const char *who, Scheme_Object *prompt_tag);

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)

static Scheme_Object *mask_to_arity(Scheme_Object *mask, int mode);

#ifdef MZ_PRECISE_GC
static void register_traversers(void);
#endif

/* See call_cc: */
typedef struct Scheme_Dynamic_Wind_List {
  MZTAG_IF_REQUIRED
  Scheme_Dynamic_Wind *dw;
  int meta_depth;
  struct Scheme_Dynamic_Wind_List *next;
} Scheme_Dynamic_Wind_List;

/*========================================================================*/
/*                             initialization                             */
/*========================================================================*/

void
scheme_init_fun (Scheme_Startup_Env *env)
{
  Scheme_Object *o;

#ifdef MZ_PRECISE_GC
  register_traversers();
#endif

#ifdef MZ_APPLY_WAITING_CONSTANT
  scheme_tail_call_waiting = MZ_APPLY_WAITING_CONSTANT;
#else
  REGISTER_SO(scheme_tail_call_waiting);
  scheme_tail_call_waiting = scheme_alloc_eternal_object();
  scheme_tail_call_waiting->type = scheme_tail_call_waiting_type;
#endif

  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_PRIM_PRODUCES_BOOL);
  scheme_addto_prim_instance("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_addto_prim_instance("apply", scheme_apply_proc, env);

  o = scheme_make_noncm_prim(map, "map", 2, -1);
  SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT);
  scheme_addto_prim_instance("map", o, env);

  o = scheme_make_noncm_prim(for_each, "for-each", 2, -1);
  SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT);
  scheme_addto_prim_instance("for-each", o, env);

  o = scheme_make_prim_w_arity(andmap, "andmap", 2, -1);
  SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT);
  scheme_addto_prim_instance("andmap", o, env);

  o = scheme_make_prim_w_arity(ormap, "ormap", 2, -1);
  SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT);
  scheme_addto_prim_instance("ormap", o, 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_addto_prim_instance("call-with-values",
			     scheme_call_with_values_proc,
			     env);

  REGISTER_SO(scheme_values_proc);
  scheme_values_proc = scheme_make_prim_w_arity2(scheme_values,
						 "values",
						 0, -1,
						 0, -1);
  SCHEME_PRIM_PROC_FLAGS(scheme_values_proc) |= 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_addto_prim_instance("values",
			     scheme_values_proc,
			     env);

  o = scheme_make_prim_w_arity2(scheme_call_ec,
				"call-with-escape-continuation",
				1, 1,
				0, -1);
  scheme_addto_prim_instance("call-with-escape-continuation", 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);
  REGISTER_SO(propagate_abort_prim);
  propagate_abort_prim = scheme_make_prim_w_arity(propagate_abort, "propagate-abort", 0, -1);

# define MAX_CALL_CC_ARG_COUNT 2
  o = scheme_make_prim_w_arity2(call_cc,
				"call-with-current-continuation",
				1, MAX_CALL_CC_ARG_COUNT,
				0, -1);

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

  scheme_addto_prim_instance("call-with-composable-continuation",
			     scheme_make_prim_w_arity2(call_with_control,
                                                       "call-with-composable-continuation",
                                                       1, 2,
                                                       0, -1),
			     env);

  scheme_addto_prim_instance("continuation?",
                             scheme_make_folding_prim(continuation_p,
						      "continuation?",
						      1, 1, 1),
                             env);

  scheme_addto_prim_instance("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_addto_prim_instance("call-with-continuation-prompt",
			     call_with_prompt_proc, 
			     env);

  scheme_addto_prim_instance("call-in-continuation",
			     scheme_make_prim_w_arity2(call_in_continuation,
						       "call-in-continuation",
						       2, 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_addto_prim_instance("abort-current-continuation",
			     abort_continuation_proc, 
			     env);

  scheme_addto_prim_instance("continuation-prompt-available?",
			     scheme_make_prim_w_arity(continuation_prompt_available,
                                                      "continuation-prompt-available?",
                                                      1, 2), 
			     env);

  scheme_addto_prim_instance("make-continuation-prompt-tag",
			     scheme_make_prim_w_arity(make_prompt_tag,
                                                      "make-continuation-prompt-tag",
                                                      0, 1), 
			     env);

  scheme_addto_prim_instance("default-continuation-prompt-tag",
                             scheme_make_prim_w_arity(get_default_prompt_tag,
                                                      "default-continuation-prompt-tag",
                                                      0, 0), 
			     env);
  scheme_addto_prim_instance("continuation-prompt-tag?",
                             scheme_make_folding_prim(prompt_tag_p,
						      "continuation-prompt-tag?",
						      1, 1, 1),
                             env);
  scheme_addto_prim_instance("impersonate-prompt-tag",
                             scheme_make_prim_w_arity(impersonate_prompt_tag,
						      "impersonate-prompt-tag",
						      3, -1),
                             env);
  scheme_addto_prim_instance("chaperone-prompt-tag",
                             scheme_make_prim_w_arity(chaperone_prompt_tag,
						      "chaperone-prompt-tag",
						      3, -1),
                             env);

  scheme_addto_prim_instance("call-with-semaphore",
			     scheme_make_prim_w_arity2(call_with_sema,
						       "call-with-semaphore",
						       2, -1,
						       0, -1), 
			     env);
  scheme_addto_prim_instance("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_addto_prim_instance("make-continuation-mark-key",
			     scheme_make_prim_w_arity(make_continuation_mark_key,
						      "make-continuation-mark-key",
						      0, 1),
			     env);
  scheme_addto_prim_instance("continuation-mark-key?",
			     scheme_make_prim_w_arity(continuation_mark_key_p,
						      "continuation-mark-key?",
						      1, 1),
			     env);
  scheme_addto_prim_instance("impersonate-continuation-mark-key",
                             scheme_make_prim_w_arity(impersonate_continuation_mark_key,
						      "impersonate-continuation-mark-key",
						      3, -1),
                             env);
  scheme_addto_prim_instance("chaperone-continuation-mark-key",
                             scheme_make_prim_w_arity(chaperone_continuation_mark_key,
						      "chaperone-continuation-mark-key",
						      3, -1),
                             env);

  scheme_addto_prim_instance("current-continuation-marks",
			     scheme_make_prim_w_arity(cc_marks,
						      "current-continuation-marks",
						      0, 1),
			     env);
  scheme_addto_prim_instance("continuation-marks",
			     scheme_make_prim_w_arity(cont_marks,
						      "continuation-marks",
						      1, 2),
			     env);
  scheme_addto_prim_instance("continuation-mark-set->list",
			     scheme_make_prim_w_arity(extract_cc_marks,
						      "continuation-mark-set->list",
						      2, 3),
			     env);
  scheme_addto_prim_instance("continuation-mark-set->list*",
			     scheme_make_prim_w_arity(extract_cc_markses,
						      "continuation-mark-set->list*",
						      2, 4),
			     env);

  scheme_addto_prim_instance("continuation-mark-set->iterator",
                             scheme_make_prim_w_arity(extract_cc_iterator,
                                                      "continuation-mark-set->iterator",
                                                      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_addto_prim_instance("continuation-mark-set-first", o, env);

  REGISTER_SO(scheme_call_with_immed_mark_proc);
  scheme_call_with_immed_mark_proc = scheme_make_prim_w_arity2(call_with_immediate_cc_mark,
                                                               "call-with-immediate-continuation-mark",
                                                               2, 3,
                                                               0, -1);
  scheme_addto_prim_instance("call-with-immediate-continuation-mark",
			     scheme_call_with_immed_mark_proc,
			     env);
  scheme_addto_prim_instance("continuation-mark-set?",
			     scheme_make_prim_w_arity(cc_marks_p,
						      "continuation-mark-set?",
						      1, 1),
			     env);
  scheme_addto_prim_instance("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_addto_prim_instance("void", scheme_void_proc, env);

  
  REGISTER_SO(scheme_void_p_proc);
  scheme_void_p_proc = scheme_make_folding_prim(void_p, "void?", 1, 1, 1);
  SCHEME_PRIM_PROC_FLAGS(scheme_void_p_proc) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_UNARY_INLINED
                                                                             | SCHEME_PRIM_IS_OMITABLE
                                                                             | SCHEME_PRIM_PRODUCES_BOOL);
  scheme_addto_prim_instance("void?", scheme_void_p_proc, env);

  scheme_addto_prim_instance("time-apply",
			     scheme_make_prim_w_arity2(time_apply,
						       "time-apply",
						       2, 2,
						       4, 4),
			     env);
  scheme_addto_prim_instance("current-milliseconds",
			     scheme_make_immed_prim(current_milliseconds,
                                                    "current-milliseconds",
                                                    0, 0),
			     env);
  scheme_addto_prim_instance("current-inexact-milliseconds",
			     scheme_make_immed_prim(current_inexact_milliseconds,
                                                    "current-inexact-milliseconds",
                                                    0, 0),
			     env);
  scheme_addto_prim_instance("current-inexact-monotonic-milliseconds",
			     scheme_make_immed_prim(current_inexact_monotonic_milliseconds,
                                                    "current-inexact-monotonic-milliseconds",
                                                    0, 0),
			     env);
  scheme_addto_prim_instance("current-process-milliseconds",
			     scheme_make_immed_prim(current_process_milliseconds,
                                                    "current-process-milliseconds",
                                                    0, 1),
			     env);
  scheme_addto_prim_instance("current-gc-milliseconds",
			     scheme_make_immed_prim(current_gc_milliseconds,
                                                    "current-gc-milliseconds",
                                                    0, 0),
			     env);
  scheme_addto_prim_instance("current-seconds",
			     scheme_make_immed_prim(current_seconds,
                                                    "current-seconds",
                                                    0, 0),
			     env);
  scheme_addto_prim_instance("seconds->date",
			     scheme_make_immed_prim(seconds_to_date,
                                                    "seconds->date",
                                                    1, 2),
			     env);

  scheme_addto_prim_instance("dynamic-wind",
			     scheme_make_prim_w_arity(dynamic_wind,
						      "dynamic-wind",
						      3, 3),
			     env);

  scheme_addto_prim_instance("object-name",
			     scheme_make_folding_prim(object_name,
						      "object-name",
						      1, 1, 1),
			     env);

  scheme_addto_prim_instance("procedure-arity",
			     scheme_make_folding_prim(procedure_arity,
						      "procedure-arity",
						      1, 1, 1),
			     env);
  scheme_addto_prim_instance("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_PRIM_AD_HOC_OPT
                                                            | SCHEME_PRIM_PRODUCES_BOOL);
  scheme_procedure_arity_includes_proc = o;
  scheme_addto_prim_instance("procedure-arity-includes?", o, env);

  scheme_addto_prim_instance("procedure-arity-mask",
			     scheme_make_folding_prim(procedure_arity_mask,
						      "procedure-arity-mask",
						      1, 1, 1),
			     env);

  scheme_addto_prim_instance("procedure-reduce-arity",
			     scheme_make_prim_w_arity(procedure_reduce_arity,
						      "procedure-reduce-arity",
						      2, 3),
			     env);
  scheme_addto_prim_instance("procedure-rename",
			     scheme_make_prim_w_arity(procedure_rename,
						      "procedure-rename",
						      2, 2),
			     env);
  scheme_addto_prim_instance("procedure-reduce-arity-mask",
			     scheme_make_prim_w_arity(procedure_reduce_arity_mask,
						      "procedure-reduce-arity-mask",
						      2, 3),
			     env);
  scheme_addto_prim_instance("procedure->method",
			     scheme_make_prim_w_arity(procedure_to_method,
						      "procedure->method",
						      1, 1),
			     env);

  o = scheme_make_folding_prim(procedure_equal_closure_p,
                               "procedure-closure-contents-eq?",
                               2, 2, 1);
  SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_AD_HOC_OPT
                                                            | SCHEME_PRIM_PRODUCES_BOOL);
  scheme_addto_prim_instance("procedure-closure-contents-eq?", o, env);

  REGISTER_SO(scheme_procedure_specialize_proc);
  o = scheme_make_prim_w_arity(procedure_specialize,
                               "procedure-specialize",
                               1, 1);
  scheme_procedure_specialize_proc = o;
  scheme_addto_prim_instance("procedure-specialize", o, env);

  scheme_addto_prim_instance("chaperone-procedure",
			     scheme_make_prim_w_arity(chaperone_procedure,
						      "chaperone-procedure",
						      2, -1),
			     env);
  scheme_addto_prim_instance("impersonate-procedure",
			     scheme_make_prim_w_arity(impersonate_procedure,
						      "impersonate-procedure",
						      2, -1),
			     env);
  scheme_addto_prim_instance("chaperone-procedure*",
			     scheme_make_prim_w_arity(chaperone_procedure_star,
						      "chaperone-procedure*",
						      2, -1),
			     env);
  scheme_addto_prim_instance("impersonate-procedure*",
			     scheme_make_prim_w_arity(impersonate_procedure_star,
						      "impersonate-procedure*",
						      2, -1),
			     env);

  scheme_addto_prim_instance("primitive?",
			     scheme_make_folding_prim(primitive_p,
						      "primitive?",
						      1, 1, 1),
			     env);
  scheme_addto_prim_instance("primitive-closure?",
			     scheme_make_folding_prim(primitive_closure_p,
						      "primitive-closure?",
						      1, 1, 1),
			     env);

  scheme_addto_prim_instance("primitive-result-arity",
			     scheme_make_folding_prim(primitive_result_arity,
						      "primitive-result-arity",
						      1, 1, 1),
			     env);

  scheme_addto_prim_instance("procedure-result-arity",
                             scheme_make_folding_prim(procedure_result_arity,
                                                      "procedure-result-arity",
                                                      1, 1, 1),
                             env);

  scheme_addto_prim_instance("current-print",
			     scheme_register_parameter(current_print,
						       "current-print",
						       MZCONFIG_PRINT_HANDLER),
			     env);
  scheme_addto_prim_instance("current-prompt-read",
			     scheme_register_parameter(current_prompt_read,
						       "current-prompt-read",
						       MZCONFIG_PROMPT_READ_HANDLER),
			     env);
  scheme_addto_prim_instance("current-read-interaction",
			     scheme_register_parameter(current_read,
						       "current-read-interaction",
						       MZCONFIG_READ_HANDLER),
			     env);
  scheme_addto_prim_instance("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(subprocesses_symbol);
  subprocesses_symbol = scheme_intern_symbol("subprocesses");

  REGISTER_SO(is_method_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");
  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(mark_symbol);
  mark_symbol = scheme_intern_symbol("mark");

  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(scheme_root_prompt_tag);
  {
    Scheme_Object *a[1];
    a[0] = scheme_intern_symbol("root");
    scheme_root_prompt_tag = make_prompt_tag(1, a);
    (void)scheme_hash_key(SCHEME_PTR_VAL(scheme_root_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;
}

void
scheme_init_unsafe_fun (Scheme_Startup_Env *env)
{
  Scheme_Object *o;

  REGISTER_SO(scheme_check_not_undefined_proc);
  o = scheme_make_prim_w_arity(scheme_check_not_undefined, "check-not-unsafe-undefined", 2, 2);
  scheme_check_not_undefined_proc = o;
  SCHEME_PRIM_PROC_FLAGS(o) |= (SCHEME_PRIM_OPT_IMMEDIATE
                                | scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED));
  scheme_addto_prim_instance("check-not-unsafe-undefined", o, env);

  REGISTER_SO(scheme_check_assign_not_undefined_proc);
  o = scheme_make_prim_w_arity(scheme_check_assign_not_undefined, "check-not-unsafe-undefined/assign", 2, 2);
  scheme_check_assign_not_undefined_proc = o;
  SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED);
  scheme_addto_prim_instance("check-not-unsafe-undefined/assign", o, env);

  scheme_addto_prim_instance("unsafe-undefined", scheme_undefined, env);

  REGISTER_SO(scheme_chaperone_undefined_property);
  o = scheme_make_struct_type_property(scheme_intern_symbol("chaperone-unsafe-undefined"));
  scheme_chaperone_undefined_property = o;
  scheme_addto_prim_instance("prop:chaperone-unsafe-undefined", o, env);

  o = scheme_make_prim_w_arity(chaperone_unsafe_undefined, "chaperone-struct-unsafe-undefined", 1, 1);
  scheme_addto_prim_instance("chaperone-struct-unsafe-undefined", o, env);

  scheme_addto_prim_instance("unsafe-chaperone-procedure",
			     scheme_make_prim_w_arity(unsafe_chaperone_procedure,
						      "unsafe-chaperone-procedure",
						      2, -1),
			     env);
  scheme_addto_prim_instance("unsafe-impersonate-procedure",
			     scheme_make_prim_w_arity(unsafe_impersonate_procedure,
						      "unsafe-impersonate-procedure",
						      2, -1),
			     env);

  ADD_PRIM_W_ARITY("unsafe-abort-current-continuation/no-wind", unsafe_abort_continuation_no_dws, 2, 2, env);
  ADD_PRIM_W_ARITY("unsafe-call-with-composable-continuation/no-wind", unsafe_call_with_control_no_dws, 2, 2, env);

  ADD_PRIM_W_ARITY("unsafe-root-continuation-prompt-tag", unsafe_root_continuation_prompt_tag, 0, 0, env);
}

void
scheme_init_fun_places()
{
  REGISTER_SO(offstack_cont);
  REGISTER_SO(offstack_overflow);
}


Scheme_Object *
scheme_make_void (void)
{
  return scheme_void;
}

/*========================================================================*/
/*                          primitive procedures                          */
/*========================================================================*/

static Scheme_Object *
make_prim_closure(Scheme_Prim *fun, int eternal,
		  const char *name,
		  mzshort mina, mzshort maxa,
		  int flags,
		  mzshort minr, mzshort maxr,
		  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;
#endif
    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,
			      const char *name,
			      mzshort mina, mzshort maxa,
			      int flags,
			      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_noncm_prim(Scheme_Prim *fun, const char *name,
		       mzshort mina, mzshort maxa)
{
  /* A non-cm primitive leaves the mark stack unchanged when it returns,
     it can't return multiple values or a tail call, and it cannot
     use its third argument (i.e., the closure pointer) unless
     SCHEME_PRIM_IS_CLOSURE is also set. */
  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
     capture a continuation or extend the continuation in a way that
     interacts with space safety (which implies no interposition via
     chaperones), except maybe to raise an exception. */
  return make_prim_closure(fun, 1, name, mina, maxa,
			   SCHEME_PRIM_OPT_IMMEDIATE,
			   1, 1,
			   0, 0, NULL);
}

Scheme_Object *
scheme_make_folding_prim(Scheme_Prim *fun, const char *name,
			 mzshort mina, mzshort maxa,
			 short folding)
{
  /* A folding primitive is an immediate primitive, and for constant
     arguments the result must be the same on all runs and platforms. */
  return make_prim_closure(fun, 1, name, mina, maxa,
			   (folding 
			    ? SCHEME_PRIM_OPT_FOLDING
			    : 0),
			   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,
						int size, Scheme_Object **vals,
						const char *name,
						mzshort mina, mzshort maxa,
						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,
				     void *data,
				     const char *name,
				     mzshort mina, mzshort maxa,
				     short folding,
				     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,
				void *data,
				const char *name,
				mzshort mina, mzshort maxa,
				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)
{
  scheme_signal_error("no longer supported");
}

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_log_abort("too many flag combinations");
  abort();

  return 0;
}

/*========================================================================*/
/*                            prompt helpers                              */
/*========================================================================*/

static void initialize_prompt(Scheme_Thread *p, Scheme_Prompt *prompt, void *stack_boundary, int is_barrier)
{
  prompt->is_barrier = is_barrier;
  prompt->stack_boundary = stack_boundary;
  if (is_barrier) {
    /* Avoid leak in case barrier is retained longer than the rest of the stack */
    Scheme_Object *ref;
    ref = scheme_make_weak_box((Scheme_Object *)MZ_RUNSTACK_START);
    prompt->u.runstack_boundary_start_ref = ref;
    prompt->weak_boundary = 1;
  } else
    prompt->u.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;
}

Scheme_Object **scheme_prompt_runstack_boundary_start(Scheme_Prompt *p)
{
  if (p->weak_boundary)
    return (Scheme_Object **)(SCHEME_BOX_VAL(p->u.runstack_boundary_start_ref));
  else
    return p->u.runstack_boundary_start;
}

static void init_prompt_id(Scheme_Prompt *prompt)
{
  Scheme_Object *id;

  if (!prompt->id) {
    id = scheme_make_pair(scheme_false, scheme_false);
    prompt->id = id;
  }
}

Scheme_Prompt *make_weak_prompt(Scheme_Prompt *p)
{
  Scheme_Prompt *p2;
  Scheme_Object *ref;

  if (p->weak_boundary)
    return p;

  init_prompt_id(p);

  p2 = MALLOC_ONE_TAGGED(Scheme_Prompt);
  memcpy(p2, p, sizeof(Scheme_Prompt));

  ref = scheme_make_weak_box((Scheme_Object *)p2->u.runstack_boundary_start);
  p2->u.runstack_boundary_start_ref = ref;
  p2->weak_boundary = 1;

  return p2;
}

/*========================================================================*/
/*                         stack-overflow wrapper                         */
/*========================================================================*/

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;
#endif

  scheme_init_jmpup_buf(&jmp->cont);
  if (scheme_setjmpup(&jmp->cont, jmp, stack_base)) {
    /* A jump into here is a request to handle overflow.
       The way to continue is in p->overflow_k.
       When we get back, put the result into
       scheme_overflow_reply. The route to return is
       in the thread's `overflow' field. */
    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;
      p2 = p->ku.k.p2;
      p3 = p->ku.k.p3;
      p4 = p->ku.k.p4;
      p5 = p->ku.k.p5;
      i1 = p->ku.k.i1;
      i2 = p->ku.k.i2;
      i3 = p->ku.k.i3;
      i4 = p->ku.k.i4;

      /* stack overflow is a lot of work; force a sleep */
      scheme_thread_block(0);
      p->ran_some = 1;

      p->ku.k.p1 = p1;
      p->ku.k.p2 = p2;
      p->ku.k.p3 = p3;
      p->ku.k.p4 = p4;
      p->ku.k.p5 = p5;
      p->ku.k.i1 = i1;
      p->ku.k.i2 = i2;
      p->ku.k.i3 = i3;
      p->ku.k.i4 = i4;

      reply = f();
      scheme_overflow_reply = reply;

      /* At the time of writing, there appear to be no GCs on the 
         longjmp return from stack overflow. Just in case, though,
         it seems better to protect multiple-value and tail-call 
         results from any GC that might be introduced one day. */
      if (reply == SCHEME_MULTIPLE_VALUES) {
        p = scheme_current_thread;
        if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
          p->values_buffer = NULL;
      } else if (reply == SCHEME_TAIL_CALL_WAITING) {
        p = scheme_current_thread;
        if (p->ku.apply.tail_rands == p->tail_buffer)
          scheme_realloc_tail_buffer(p);
      }
    }

    p = scheme_current_thread;
    overflow = p->overflow;
    p->stack_start = overflow->stack_start;

    /* Reset overflow buffer and continue */
    scheme_longjmpup(&overflow->jmp->cont);
  }

  if (scheme_overflow_jmp) {
    scheme_signal_error("shouldn't get here!");
  }

  scheme_overflow_jmp = jmp;
}

void scheme_create_overflow(void)
{
  void *stack_marker;
  scheme_really_create_overflow(PROMPT_STACK(stack_marker));
  stack_marker = NULL; /* to ensure that we get __gc_var_stack__ in 3m */
}

void scheme_init_overflow(void)
{
  REGISTER_SO(scheme_overflow_jmp);
}

void scheme_reset_overflow(void)
{
  scheme_overflow_jmp = NULL;
}

/*========================================================================*/
/*                       entry continuation barrier                       */
/*========================================================================*/

static Scheme_Prompt *allocate_prompt(Scheme_Prompt **cached_prompt) {
  Scheme_Prompt *prompt;
  if (*cached_prompt) {
    prompt = *cached_prompt;
    *cached_prompt = NULL;
  } else  {
    prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
    prompt->so.type = scheme_prompt_type;
  }
  return prompt;
}

static void *apply_again_k(void)
{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object *val = p->ku.k.p1;
  int num_vals = p->ku.k.i1;

  p->ku.k.p1 = NULL;

  if (num_vals != 1) {
    scheme_wrong_return_arity("call-with-continuation-prompt", 1, num_vals, (Scheme_Object **)val,
                              "\n  in: application of default prompt handler");
    return NULL;
  } else {
    scheme_check_proc_arity("default-continuation-prompt-handler", 0, 0, 1, &val);
    return (void *)_scheme_apply(val, 0, NULL);
  }
}

void *scheme_top_level_do(void *(*k)(void), int eb) {
    return scheme_top_level_do_worker(k, eb, 0);
}

void *scheme_top_level_do_worker(void *(*k)(void), int eb, int new_thread)
{
  /* Wraps a function `k' with a handler for stack overflows and
     barriers to full-continuation jumps. No barrier if !eb. */
  void * v;
  Scheme_Prompt * volatile prompt = NULL;
  mz_jmp_buf *save;
  mz_jmp_buf newbuf;
  Scheme_Stack_State envss;
  Scheme_Thread * volatile p = scheme_current_thread;
  volatile int old_pcc = scheme_prompt_capture_count;
  Scheme_Cont_Frame_Data cframe;
  volatile int need_final_abort = 0;
#ifdef MZ_PRECISE_GC
  void *external_stack;
#endif
  int num_vals = p->ku.k.i1;
  void *val = p->ku.k.p1;

  if (scheme_active_but_sleeping)
    scheme_wake_up();
  
  if (eb) {
    prompt = allocate_prompt(&available_prompt);
    initialize_prompt(p, prompt, PROMPT_STACK(prompt), !new_thread);
  }

#ifdef MZ_PRECISE_GC
  if (scheme_get_external_stack_val)
    external_stack = scheme_get_external_stack_val();
  else
    external_stack = NULL;
#endif

  scheme_create_overflow(); /* needed even if scheme_overflow_jmp is already set */

  save = p->error_buf;
    
  while (1) {

    scheme_save_env_stack_w_thread(envss, p);
    
    if (prompt) {
      scheme_push_continuation_frame(&cframe);
      scheme_set_cont_mark(barrier_prompt_key, (Scheme_Object *)prompt);
    }
    
    p->error_buf = &newbuf;

    if (scheme_setjmp(newbuf)) {
      int again;

      p = scheme_current_thread;

      if (SAME_OBJ(p->cjs.jumping_to_continuation, (Scheme_Object *)original_default_prompt)) {
        /* an abort to the thread start; act like the default prompt handler,
           but remember to jump again */
        num_vals = p->cjs.num_vals;
        val = p->cjs.val;
        reset_cjs(&p->cjs);
        k = apply_again_k;
        need_final_abort = 1;
        again = 1;
      } else {
        num_vals = 0;
        val = NULL;
        again = 0;
      }

      if (!new_thread || again) {
        scheme_restore_env_stack_w_thread(envss, p);
#ifdef MZ_PRECISE_GC
        if (scheme_set_external_stack_val)
          scheme_set_external_stack_val(external_stack);
#endif
        if (prompt) {
          scheme_pop_continuation_frame(&cframe);
          if (!again) {
            if (old_pcc == scheme_prompt_capture_count) {
              /* It wasn't used */
              available_prompt = prompt;
            }
          }
        }
      }

      if (!again)
        scheme_longjmp(*save, 1);
    } else {
      if (new_thread) {
        /* check for initial break before we do anything */
        scheme_check_break_now();
      }

      p->ku.k.i1 = num_vals;
      p->ku.k.p1 = val;
      
      v = k();

      break;
    }
  }

  /* IMPORTANT: no GCs from here to return, since v
     may refer to multiple values, and we don't want the
     multiple-value array cleared. */

  if (!new_thread) {
    p = scheme_current_thread;

    p->error_buf = save;
  }

  if (prompt) {
    scheme_pop_continuation_frame(&cframe);
    if (old_pcc == scheme_prompt_capture_count) {
      /* It wasn't used */
      available_prompt = prompt;
    }
  }

  if (scheme_active_but_sleeping)
    scheme_wake_up();

  if (need_final_abort) {
    p = scheme_current_thread;
    scheme_longjmp(*p->error_buf, 1);
  }

  return (Scheme_Object *)v;
}


void scheme_clear_prompt_cache()
{
  available_prompt = NULL;
  available_cws_prompt = NULL;
  available_regular_prompt = NULL;
  available_prompt_dw = NULL;
  available_prompt_mc = NULL;
}

static void ensure_overflow_id(Scheme_Overflow *overflow)
{
  void *id;
  if (!overflow->id) {
    if (overflow->jmp) {
      overflow->id = overflow->jmp;
    } else {
      id = scheme_malloc_atomic(4);
      overflow->id = id;
    }
  }
}

void scheme_ensure_dw_id(Scheme_Dynamic_Wind *dw)
{
  void *id;
  if (!dw->id) {
    id = scheme_malloc_atomic(4);
    dw->id = id;
  }
}

/*========================================================================*/
/*                  procedure application evaluation                      */
/*========================================================================*/

static Scheme_Object *
force_values(Scheme_Object *obj, int multi_ok)
  /* Called where _scheme_apply() or _scheme_value() might return a
     a tail-call-waiting trampoline token.  */
{
  if (SAME_OBJ(obj, SCHEME_TAIL_CALL_WAITING)) {
    Scheme_Thread *p = scheme_current_thread;
    GC_CAN_IGNORE Scheme_Object *rator, *result;
    GC_CAN_IGNORE Scheme_Object **rands;
    int argc = p->ku.apply.tail_num_rands, popc = 0;

    rands = p->ku.apply.tail_rands;

    /* Watch out for use of tail buffer: */
    if (rands == p->tail_buffer) {
      GC_CAN_IGNORE Scheme_Object **runstack = MZ_RUNSTACK;
      if (((runstack - MZ_RUNSTACK_START) - argc) > SCHEME_TAIL_COPY_THRESHOLD) {
        /* There's room on the runstack; use that instead of allocating a new buffer */
        runstack -= argc;
        memcpy(runstack, rands, argc * sizeof(Scheme_Object *));
        rands = runstack;
        popc = argc;
        MZ_RUNSTACK = rands;
      } else {
        scheme_realloc_tail_buffer(p);
        rands = p->ku.apply.tail_rands;
      }
    }

    rator = p->ku.apply.tail_rator;
    p->ku.apply.tail_rator = NULL;
    p->ku.apply.tail_rands = NULL;
      
    if (multi_ok)
      result = _scheme_apply_multi(rator, argc, rands);
    else
      result = _scheme_apply(rator, argc, rands);

    if (popc)
      MZ_RUNSTACK += popc;

    return result;
  } else if (SAME_OBJ(obj, SCHEME_EVAL_WAITING)) {
    Scheme_Thread *p = scheme_current_thread;
    if (multi_ok)
      return _scheme_eval_linked_expr_multi(p->ku.eval.wait_expr);
    else
      return _scheme_eval_linked_expr(p->ku.eval.wait_expr);
  } else if (obj)
    return obj;
  else
    return scheme_void;
}

Scheme_Object *
scheme_force_value(Scheme_Object *obj)
{
  return force_values(obj, 1);
}

Scheme_Object *
scheme_force_one_value(Scheme_Object *obj)
{
  return force_values(obj, 0);
}

Scheme_Object *
scheme_force_value_same_mark(Scheme_Object *obj)
{
  Scheme_Object *v;

  MZ_CONT_MARK_POS -= 2;
  /* At this point, if the thread is swapped out and we attempt to get
     the continuation marks of the thread, then MZ_CONT_MARK_POS may
     be inconsistent with the first mark on the stack. We assume that
     a thread swap will not happen until scheme_do_eval(), where
     the first possibility for a swap is on stack overflow, and
     in that case MZ_CONT_MARK_POS is adjusted back before overflow
     handling (which can cause the thread to swap out). */

  v = force_values(obj, 1);

  MZ_CONT_MARK_POS += 2;

  return v;
}

Scheme_Object *
scheme_force_one_value_same_mark(Scheme_Object *obj)
{
  Scheme_Object *v;
  
  MZ_CONT_MARK_POS -= 2;
  /* See above about thread swaps */

  v = force_values(obj, 0);

  MZ_CONT_MARK_POS += 2;

  return v;
}

static void *apply_k(void)
{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object *rator;
  int num_rands;
  Scheme_Object **rands;

  rator = (Scheme_Object *)p->ku.k.p1;
  rands = (Scheme_Object **)p->ku.k.p2;
  num_rands = p->ku.k.i1;

  p->ku.k.p1 = NULL;
  p->ku.k.p2 = NULL;

  if (p->ku.k.i2)
    return (void *)_scheme_apply_multi_wp(rator, num_rands, rands, p);
  else
    return (void *)_scheme_apply_wp(rator, num_rands, rands, p);
}

static Scheme_Object *
_apply(Scheme_Object *rator, int num_rands, Scheme_Object **rands, int multi, int eb)
{
  Scheme_Thread *p = scheme_current_thread;

  p->ku.k.p1 = rator;
  p->ku.k.p2 = rands;
  p->ku.k.i1 = num_rands;
  p->ku.k.i2 = multi;

  return (Scheme_Object *)scheme_top_level_do(apply_k, eb);
}

Scheme_Object *
scheme_apply(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
{
  return _apply(rator, num_rands, rands, 0, 1);
}

Scheme_Object *
scheme_apply_multi(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
{
  return _apply(rator, num_rands, rands, 1, 1);
}

Scheme_Object *
scheme_apply_thread_thunk(Scheme_Object *rator)
{
  Scheme_Thread *p = scheme_current_thread;

  p->ku.k.p1 = rator;
  p->ku.k.p2 = NULL;
  p->ku.k.i1 = 0;
  p->ku.k.i2 = 1;

  return (Scheme_Object *)scheme_top_level_do_worker(apply_k, 1, 1);
}

Scheme_Object *
scheme_apply_no_eb(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
{
  return _apply(rator, num_rands, rands, 0, 0);
}

Scheme_Object *
scheme_apply_multi_no_eb(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
{
  return _apply(rator, num_rands, rands, 1, 0);
}

static Scheme_Object *
finish_apply_with_prompt(void *_data, int argc, Scheme_Object **argv)
{
  void **data = (void **)_data;
  Scheme_Object *rator, *is_multi;

  argv = (Scheme_Object **)_data;
  for (argc = 0; data[argc]; argc++) { }

  rator = (Scheme_Object *)data[argc+1];
  is_multi = (Scheme_Object *)data[argc+2];

  if (SCHEME_TRUEP(is_multi))
    return _scheme_apply_multi(rator, argc, argv);
  else
    return _scheme_apply(rator, argc, argv);
}

static Scheme_Object *
do_apply_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands, int multi, int top_level)
{
  void **a;
  int i;

  a = MALLOC_N(void*, 3 + num_rands);

  for (i = 0; i < num_rands; i++) {
    a[i] = rands[i];
  }
  a[num_rands] = NULL;
  a[num_rands + 1] = rator;
  a[num_rands + 2] = (multi ? scheme_true : scheme_false);

  if (top_level) {
    if (multi)
      return scheme_call_with_prompt_multi(finish_apply_with_prompt, a);
    else
      return scheme_call_with_prompt(finish_apply_with_prompt, a);
  } else {
    if (multi)
      return _scheme_call_with_prompt_multi(finish_apply_with_prompt, a);
    else
      return _scheme_call_with_prompt(finish_apply_with_prompt, a);
  }
}

Scheme_Object *
scheme_apply_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
{
  return do_apply_with_prompt(rator, num_rands, rands, 0, 1);
}

Scheme_Object *
scheme_apply_multi_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
{
  return do_apply_with_prompt(rator, num_rands, rands, 1, 1);
}

Scheme_Object *
_scheme_apply_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
{
  return do_apply_with_prompt(rator, num_rands, rands, 0, 0);
}

Scheme_Object *_scheme_apply_multi_with_prompt(Scheme_Object *rator, int num_rands, Scheme_Object **rands)
{
  return do_apply_with_prompt(rator, num_rands, rands, 1, 0);
}

#ifdef INSTRUMENT_PRIMITIVES
extern int g_print_prims;
#endif

Scheme_Object *
scheme_tail_apply (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
{
  /* NOTE: apply_values_execute (in syntax.c) and
     tail_call_with_values_from_multiple_result (in jit.c)
     assume that this function won't allocate when 
     num_rands <= p->tail_buffer_size. */
  int i;
  Scheme_Thread *p = scheme_current_thread;

  p->ku.apply.tail_rator = rator;
  p->ku.apply.tail_num_rands = num_rands;

  if (num_rands) {
    Scheme_Object **a;
    if (num_rands > p->tail_buffer_size) {
      a = MALLOC_N(Scheme_Object *, num_rands);
      p->tail_buffer = a;
      p->tail_buffer_size = num_rands;
    } else
      a = p->tail_buffer;
    p->ku.apply.tail_rands = a;
    for (i = num_rands; i--; ) {
      a[i] = rands[i];
    }
  } else
    p->ku.apply.tail_rands = NULL;

  return SCHEME_TAIL_CALL_WAITING;
}

Scheme_Object *
scheme_tail_apply_no_copy (Scheme_Object *rator, int num_rands,
			   Scheme_Object **rands)
{
  Scheme_Thread *p = scheme_current_thread;

  p->ku.apply.tail_rator = rator;
  p->ku.apply.tail_num_rands = num_rands;
  p->ku.apply.tail_rands = rands;

  return SCHEME_TAIL_CALL_WAITING;
}

static
Scheme_Object *
X_scheme_apply_to_list(Scheme_Object *rator, Scheme_Object *rands, int force,
		       int top_level)
{
  int num_rands, i;
  Scheme_Object **rands_vec;

  num_rands = scheme_list_length(rands);
  rands_vec = MALLOC_N(Scheme_Object *, num_rands);

  for (i = 0; i < num_rands ; i++) {
    if (!SCHEME_PAIRP(rands)) {
      scheme_signal_error("bad application form");
    }
    rands_vec[i] = SCHEME_CAR(rands);
    rands = SCHEME_CDR(rands);
  }

  if (top_level)  {
    if (force)
      return scheme_apply(rator, num_rands, rands_vec);
    else
      return scheme_tail_apply(rator, num_rands, rands_vec);
  } else {
    if (force)
      return _scheme_apply(rator, num_rands, rands_vec);
    else
      return _scheme_tail_apply(rator, num_rands, rands_vec);
  }
}

Scheme_Object *
scheme_apply_to_list (Scheme_Object *rator, Scheme_Object *rands)
{
  return X_scheme_apply_to_list(rator, rands, 1, 1);
}

Scheme_Object *
scheme_tail_apply_to_list (Scheme_Object *rator, Scheme_Object *rands)
{
  return X_scheme_apply_to_list(rator, rands, 0, 1);
}

Scheme_Object *
_scheme_apply_to_list (Scheme_Object *rator, Scheme_Object *rands)
{
  return X_scheme_apply_to_list(rator, rands, 1, 0);
}

Scheme_Object *
_scheme_tail_apply_to_list (Scheme_Object *rator, Scheme_Object *rands)
{
  return X_scheme_apply_to_list(rator, rands, 0, 0);
}

/*========================================================================*/
/*                                   arity                                */
/*========================================================================*/

static Scheme_Object *make_arity(intptr_t mina, intptr_t maxa, int mode)
{
  if (mina == maxa)
    return scheme_make_integer(mina);
  else if (maxa == -1) {
    if (mode == -3) {
      return scheme_make_integer(-(mina+1));
    } else {
      Scheme_Object *p[1];
      p[0] = scheme_make_integer(mina);
      return scheme_make_struct_instance(scheme_arity_at_least, 1, p);
    }
  } else {
    intptr_t i;
    Scheme_Object *l = scheme_null;

    for (i = maxa; i >= mina; --i) {
      l = scheme_make_pair(scheme_make_integer(i), l);
    }

    return l;
  }
}

Scheme_Object *scheme_make_arity(mzshort mina, mzshort maxa)
{
  return make_arity(mina, maxa, -1);
}

Scheme_Object *shift_for_drop(Scheme_Object *n, int drop)
{
  Scheme_Object *a[2];
  a[0] = n;
  a[1] = scheme_make_integer(-drop);
  return scheme_bitwise_shift(2, a);
}

static Scheme_Object *make_shifted_one(intptr_t n)
{
  Scheme_Object *a[2];
  a[0] = scheme_make_integer(1);
  a[1] = scheme_make_integer(n);
  return scheme_bitwise_shift(2, a);
}

static Scheme_Object *make_arity_mask(intptr_t mina, intptr_t maxa)
{
  /* Generate a mask */
  if (mina == maxa) {
    if (mina < SCHEME_MAX_FAST_ARITY_CHECK)
      return scheme_make_integer(1 << mina);
    else
      return make_shifted_one(mina);
  } else if (maxa == -1) {
    if (mina < SCHEME_MAX_FAST_ARITY_CHECK) {
      return scheme_make_integer(((1 << mina) - 1) ^ (intptr_t)-1);
    } else {
      return scheme_bin_bitwise_xor(scheme_bin_minus(make_shifted_one(mina), scheme_make_integer(1)),
                                    scheme_make_integer(-1));
    }
  } else {
    mzshort i;
    Scheme_Object *mask = scheme_make_integer(0);
    
    for (i = mina; i <= maxa; i++) {
      mask = scheme_bin_bitwise_or(make_shifted_one(i), mask);
    }
    
    return mask;
  }
}

Scheme_Object *scheme_make_arity_mask(intptr_t mina, intptr_t maxa)
{
  return make_arity_mask(mina, maxa);
}

int scheme_fast_check_arity(Scheme_Object *p, int a)
/* Faster version of get_or_check_arity() in check mode;
   a 0 result means "maybe" */
{
  Scheme_Type type;
  int mina, maxa;

  type = SCHEME_TYPE(p);
  if (type == scheme_prim_type) {
    mina = ((Scheme_Primitive_Proc *)p)->mina;
    maxa = ((Scheme_Primitive_Proc *)p)->mu.maxa;
    if (mina < 0)
      return 0;
    else {
      if (maxa > SCHEME_MAX_ARGS)
	maxa = -1;
    }
  } else if (type == scheme_closed_prim_type) {
    mina = ((Scheme_Closed_Primitive_Proc *)p)->mina;
    maxa = ((Scheme_Closed_Primitive_Proc *)p)->maxa;
    if (mina == -2)
      return 0;
  } else
    return 0;

  if (a >= mina && (maxa < 0 || a <= maxa))
    return 1;
  
  return 0;
}

static Scheme_Object *get_or_check_arity(Scheme_Object *p, intptr_t a, Scheme_Object *bign, int inc_ok)
/* a == -1 => get arity
   a == -2 => check for allowing bignum
   a == -3 => like -1, but alternate representation using negative numbers for arity-at-least
   a == -4 => mask  */
{
  Scheme_Type type;
  mzshort mina, maxa;
  int drop = 0, cases_count = 0;
  mzshort *cases = NULL;

 top:

  type = SCHEME_TYPE(p);
  if (type == scheme_prim_type) {
    mina = ((Scheme_Primitive_Proc *)p)->mina;
    maxa = ((Scheme_Primitive_Proc *)p)->mu.maxa;
    if (mina < 0) {
      cases = ((Scheme_Primitive_Proc *)p)->mu.cases;
      cases_count = -(mina + 1);
    } else {
      if (maxa > SCHEME_MAX_ARGS)
	maxa = -1;
    }
  } else if (type == scheme_closed_prim_type) {
    mina = ((Scheme_Closed_Primitive_Proc *)p)->mina;
    maxa = ((Scheme_Closed_Primitive_Proc *)p)->maxa;
    if (mina == -2) {
      cases_count = -maxa;
      cases = ((Scheme_Closed_Case_Primitive_Proc *)p)->cases;
    }
  } else if (type == scheme_cont_type || type == scheme_escaping_cont_type) {
    mina = 0;
    maxa = -1;
  } else if ((type == scheme_case_closure_type)
             || (type == scheme_case_lambda_sequence_type)) {
    Scheme_Case_Lambda *seq;
    Scheme_Lambda *data;
    int i;
    Scheme_Object *mask = scheme_make_integer(0), *v;

    seq = (Scheme_Case_Lambda *)p;
    for (i = 0; i < seq->count; i++) {
      v = seq->array[i];
      if ((a == -1) || (a == -3) || (a == -4)) {
        mask = scheme_bin_bitwise_or(get_or_check_arity(v, -4, NULL, inc_ok), mask);
      } else {
        if (SAME_TYPE(SCHEME_TYPE(v), scheme_lambda_type))
          data = (Scheme_Lambda *)v;
        else
          data = SCHEME_CLOSURE_CODE(v);
        mina = maxa = data->num_params;
        if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) {
          if (mina)
            --mina;
          maxa = -1;
        }

        if (a >= 0) {
          if ((a + drop) >= mina && (maxa < 0 || (a + drop) <= maxa))
            return scheme_true;
        } else if (a == -2) {
          if (maxa < 0)
            return scheme_true;
        }
      }
    }

    if ((a == -1) || (a == -3) || (a == -4)) {
      if (drop)
        mask = shift_for_drop(mask, drop);
      if (a != -4)
        return mask_to_arity(mask, a);
      else
        return mask;
    } else
      return scheme_false;
  } else if (type == scheme_proc_struct_type) {
    int is_method;
    if (!inc_ok
        && scheme_no_arity_property
        && scheme_struct_type_property_ref(scheme_no_arity_property, p)) {
      if (a == -4)
        return scheme_make_integer(0);
      else
        return scheme_false;
    }
    if (scheme_reduced_procedure_struct
        && scheme_is_struct_instance(scheme_reduced_procedure_struct, p)) {
      if (a == -4) {
        p = ((Scheme_Structure *)p)->slots[1];
        if (drop)
          return shift_for_drop(p, drop);
        else
          return p;
      }
      
      if (a >= 0) {
        bign = scheme_make_integer(a);
        if (drop)
          bign = scheme_bin_plus(bign, scheme_make_integer(drop));
      }
      if ((a == -1) || (a == -3)) {
        p = ((Scheme_Structure *)p)->slots[1];
        if (drop)
          p = shift_for_drop(p, drop);
        return mask_to_arity(p, a);
      } else {
        if (scheme_bin_bitwise_bit_set_p(((Scheme_Structure *)p)->slots[1], bign))
          return scheme_true;
        else
          return scheme_false;
      }
    } else {
      p = scheme_extract_struct_procedure(p, -1, NULL, &is_method);
      if (!SCHEME_PROCP(p)) {
        if (a == -4)
          return scheme_make_integer(0);
        else if ((a == -1) || (a == -3))
          return scheme_null;
        else
          return scheme_false;
      }
      if (is_method)
        drop++;
    }
    SCHEME_USE_FUEL(1);
    goto top;
#ifdef MZ_USE_JIT
  } else if (type == scheme_native_closure_type) {
    if (a < 0) {
      Scheme_Object *pa;

      pa = scheme_get_native_arity(p, a);
      if (a == -4) {
        if (drop)
          return shift_for_drop(pa, drop);
        else
          return pa;
      }

      if (SCHEME_BOXP(pa)) {
	/* Is a method; pa already corrects for it */
	pa = SCHEME_BOX_VAL(pa);
      }

      if (SCHEME_STRUCTP(pa)) {
	/* This happens when a non-case-lambda is not yet JITted.
	   It's an arity-at-least record. Convert it to the
	   negative-int encoding. */
	int v;
	pa = ((Scheme_Structure *)pa)->slots[0];
	v = -(SCHEME_INT_VAL(pa) + 1);
	pa = scheme_make_integer(v);
      }

      if (SCHEME_INTP(pa)) {
	mina = SCHEME_INT_VAL(pa);
	if (mina < 0) {
	  if (a == -2) {
	    /* Yes, varargs */
	    return scheme_true;
	  }
	  mina = (-mina) - 1;
	  maxa = -1;
	} else {
	  if (a == -2) {
	    /* No varargs */
	    return scheme_false;
	  }
	  maxa = mina;
	}
      } else {
	if (a == -2) {
	  /* Check for varargs */
	  Scheme_Object *a;
	  while (!SCHEME_NULLP(pa)) {
	    a = SCHEME_CAR(pa);
	    if (SCHEME_STRUCTP(a))
	      return scheme_true;
	    pa = SCHEME_CDR(pa);
	  }
	  return scheme_false;
	} else {
	  if (drop) {
	    /* Need to adjust elements (e.g., because this
	       procedure is a struct's apply handler) */
	    Scheme_Object *first = scheme_null, *last = NULL, *ae;
	    int v;
	    while (SCHEME_PAIRP(pa)) {
	      ae = SCHEME_CAR(pa);
	      if (SCHEME_INTP(ae)) {
		v = SCHEME_INT_VAL(ae);
		if (v < drop)
		  ae = NULL;
		else {
		  v -= drop;
		  ae = scheme_make_integer(v);
		}
	      } else {
		/* arity-at-least */
		ae = ((Scheme_Structure *)ae)->slots[0];
		v = SCHEME_INT_VAL(ae);
		if (v >= drop) {
		  ae = make_arity(v - drop, -1, a);
		} else {
		  ae = make_arity(0, -1, a);
		}
	      }
	      if (ae) {
		ae = scheme_make_pair(ae, scheme_null);
		if (last)
		  SCHEME_CDR(last) = ae;
		else
		  first = ae;
		last = ae;
	      }
	      pa = SCHEME_CDR(pa);
	    }
	    return first;
	  }
	  return pa;
	}
      }
    } else {
      if (scheme_native_arity_check(p, a + drop))
	return scheme_true;
      else
	return scheme_false;
    }
#endif
  } else if (type == scheme_proc_chaperone_type) {
    p = SCHEME_CHAPERONE_VAL(p);
    SCHEME_USE_FUEL(1);
    goto top;
  } else {
    Scheme_Lambda *data;

    if (type == scheme_lambda_type) 
      data = (Scheme_Lambda *)p;
    else if (type == scheme_closure_type)
      data = SCHEME_CLOSURE_CODE(p);
    else
      return scheme_false;

    mina = maxa = data->num_params;
    if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) {
      if (mina)
	--mina;
      maxa = -1;
    }
  }

  if (cases) {
    int count = cases_count, i;
    if ((a == -1) || (a == -3) || (a == -4)) {
      /* Compute mask to get arity so that the arity is normalized */
      Scheme_Object *mask = scheme_make_integer(0);
      
      for (i = 0; i < count; i++) {
        mask = scheme_bin_bitwise_or(make_arity_mask(cases[2 * i], cases[(2 * i)+1]), mask);
      }
      if (drop)
        mask = shift_for_drop(mask, drop);
      
      
      if (a == -4)
        return mask;
      else
        return mask_to_arity(mask, a);
    }

    if (a == -2) {
      for (i = 0; i < count; i++) {
	if (cases[(2 * i) + 1] < 0)
	  return scheme_true;
      }

      return scheme_false;
    }

    a += drop;

    for (i = 0; i < count; i++) {
      int na, xa;
      na = cases[2 * i];
      xa = cases[(2 * i) + 1];
      if ((a >= na) && ((xa < 0) || (a <= xa)))
	return scheme_true;
    }

    return scheme_false;
  }

  if ((a == -1) || (a == -3) || (a == -4)) {
    if (mina < drop) {
      if ((maxa >= 0) && (maxa < drop)) {
        if (a == -4)
          return scheme_make_integer(0);
        else
          return scheme_null;
      } else
        mina = 0;
    } else
      mina -= drop;
    if (maxa > 0) {
      /* assert: maxa >= drop, or else would have returned in `mina < drop` test */
      maxa -= drop;
    }

    if (a == -4)
      return make_arity_mask(mina, maxa);

    return make_arity(mina, maxa, a);
  }

  if (a == -2)
    return (maxa < 0) ? scheme_true : scheme_false;

  a += drop;

  if (a < mina || (maxa >= 0 && a > maxa))
    return scheme_false;

  return scheme_true;
}

Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, intptr_t a)
{
  return get_or_check_arity(p, a, NULL, 1);
}

Scheme_Object *scheme_get_arity_mask(Scheme_Object *p)
{
  return get_or_check_arity(p, -4, NULL, 1);
}

int scheme_check_proc_arity2(const char *where, int a,
			     int which, int argc, Scheme_Object **argv,
			     int false_ok)
{
  Scheme_Object *p;

  if (which < 0)
    p = argv[0];
  else
    p = argv[which];

  if (false_ok && SCHEME_FALSEP(p))
    return 1;

  if (!SCHEME_PROCP(p) || SCHEME_FALSEP(get_or_check_arity(p, a, NULL, 1))) {
    if (where) {
      char buffer[60];
      const char *pre, *post;

      if (false_ok) {
        pre = "(or/c ";
        post = " #f)";
      } else
        pre = post = "";

      switch (a) {
      case 0:
        sprintf(buffer, "%s(-> any)%s", pre, post);
        break;
      case 1:
        sprintf(buffer, "%s(any/c . -> . any)%s", pre, post);
        break;
      case 2:
        sprintf(buffer, "%s(any/c any/c . -> . any)%s", pre, post);
        break;
      case 3:
        sprintf(buffer, "%s(any/c any/c any/c . -> . any)%s", pre, post);
        break;
      default:
        sprintf(buffer, "%s(procedure-arity-includes/c %d)%s", 
                pre, a, post);
        break;
      }

      scheme_wrong_contract(where, buffer, which, argc, argv);
    } else
      return 0;
  }

  return 1;
}

int scheme_check_proc_arity(const char *where, int a,
			    int which, int argc, Scheme_Object **argv)
{
  return scheme_check_proc_arity2(where, a, which, argc, argv, 0);
}

int scheme_closure_preserves_marks(Scheme_Object *p)
{
  Scheme_Type type = SCHEME_TYPE(p);
  Scheme_Lambda *data;

#ifdef MZ_USE_JIT
  if (type == scheme_native_closure_type)
    return scheme_native_closure_preserves_marks(p);
#endif

  if (type == scheme_closure_type) {
    data = SCHEME_CLOSURE_CODE(p);
  } else if (type == scheme_lambda_type) {
    data = (Scheme_Lambda *)p;
  } else
    return 0;

  if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_PRESERVES_MARKS)
    return 1;

  return 0;
}

Scheme_Object *scheme_get_or_check_procedure_shape(Scheme_Object *e, Scheme_Object *expected, int imprecise)
/* result is interned --- a symbol or fixnum */
{
  Scheme_Object *p;

  if (expected 
      && SCHEME_SYMBOLP(expected)) {
    if (SCHEME_SYM_VAL(expected)[0] == 's') {
      return (scheme_get_or_check_structure_shape(e, expected)
              ? expected
              : NULL);
    } else if (SCHEME_SYM_VAL(expected)[0] == 'p') {
      return (scheme_get_or_check_structure_property_shape(e, expected)
              ? expected
              : NULL);
    }
  }

  if (SAME_TYPE(SCHEME_TYPE(e), scheme_inline_variant_type))
    e = SCHEME_VEC_ELS(e)[1];

  if (!SCHEME_PROCP(e) && (SCHEME_TYPE(e) >= _scheme_ir_values_types_))
    return NULL;

  p = scheme_get_or_check_arity(e, -3);
  if (SCHEME_FALSEP(p))
    return NULL;
  
  if (SCHEME_PAIRP(p)) {
    /* encode as a symbol */
    int sz = 32, c = 0;
    char *b, *naya;
    b = (char *)scheme_malloc_atomic(sz);

    while (SCHEME_PAIRP(p)) {
      if (sz - c < 10) {
        sz *= 2;
        naya = (char *)scheme_malloc_atomic(sz);
        memcpy(naya, b, c);
        b = naya;
      }
      if (c)
        b[c++] = ':';
      c += sprintf(b XFORM_OK_PLUS c, "%" PRIdPTR, SCHEME_INT_VAL(SCHEME_CAR(p)));
      
      p = SCHEME_CDR(p);
    }
    b[c] = c;
    p = scheme_intern_exact_symbol(b, c);
  } else {
    /* Integer encoding, but shift to use low bit to indicate whether
       it preserves marks, which is useful information for the JIT. */
    intptr_t i = SCHEME_INT_VAL(p);
    i = ((uintptr_t)i) << 1;
    if (expected && SCHEME_INTP(expected) && !(SCHEME_INT_VAL(expected) & 0x1)) {
      /* It's ok for an `e` that preserves marks to match an
         expectation of not preserving marks */
    } else {
      if (!imprecise && scheme_closure_preserves_marks(e)) {
        i |= 0x1;
      }
    }
    p = scheme_make_integer(i);
  }

  if (expected && !SAME_OBJ(expected, p))
    return NULL;

  return p;
}

/*========================================================================*/
/*                        basic function primitives                       */
/*========================================================================*/

static Scheme_Object *
void_func (int argc, Scheme_Object *argv[])
{
  return scheme_void;
}

static Scheme_Object *
void_p (int argc, Scheme_Object *argv[])
{
  return SAME_OBJ(argv[0], scheme_void) ? scheme_true : scheme_false;
}

Scheme_Object *
scheme_check_not_undefined (int argc, Scheme_Object *argv[])
{
  if (!SCHEME_SYMBOLP(argv[1]))
    scheme_wrong_contract("check-not-unsafe-undefined", "symbol?", 1, argc, argv);

  if (SAME_OBJ(argv[0], scheme_undefined)) {
    scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE,
                     argv[1],
                     "%S: undefined;\n cannot use before initialization",
                     argv[1]);
  }

  return argv[0];
}

Scheme_Object *
scheme_check_assign_not_undefined (int argc, Scheme_Object *argv[])
{
  if (!SCHEME_SYMBOLP(argv[1]))
    scheme_wrong_contract("check-not-unsafe-undefined/assign", "symbol?", 1, argc, argv);

  if (SAME_OBJ(argv[0], scheme_undefined)) {
    scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE,
                     argv[1],
                     "%S: assignment disallowed;\n cannot assign before initialization",
                     argv[1]);
  }

  return argv[0];
}

static Scheme_Object *chaperone_unsafe_undefined(int argc, Scheme_Object **argv)
{
  if (SCHEME_CHAPERONE_STRUCTP(argv[0]))
    return scheme_chaperone_not_undefined(argv[0]);
  else
    return argv[0];
}

static Scheme_Object *
procedure_p (int argc, Scheme_Object *argv[])
{
  return (SCHEME_PROCP(argv[0]) ? scheme_true : scheme_false);
}

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

  if (SCHEME_PRIMP(argv[0]))
    isprim = (((Scheme_Primitive_Proc *)argv[0])->pp.flags & SCHEME_PRIM_IS_PRIMITIVE);
  else if (SCHEME_CLSD_PRIMP(argv[0]))
    isprim = (((Scheme_Closed_Primitive_Proc *)argv[0])->pp.flags & SCHEME_PRIM_IS_PRIMITIVE);
  else
    isprim = 0;

  return isprim ? scheme_true : scheme_false;
}

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

  if (SCHEME_CLSD_PRIMP(argv[0]))
    isprim = (((Scheme_Closed_Primitive_Proc *)argv[0])->pp.flags & SCHEME_PRIM_IS_PRIMITIVE);
  else
    isprim = 0;

  return isprim ? scheme_true : scheme_false;
}

Scheme_Object *scheme_proc_struct_name_source(Scheme_Object *a)
{
  Scheme_Object *b;

  while (SCHEME_CHAPERONE_PROC_STRUCTP(a)) {
    if (SCHEME_CHAPERONEP(a))
      a = SCHEME_CHAPERONE_VAL(a);
    if (scheme_object_name_property
        && scheme_struct_type_property_ref(scheme_object_name_property, a)) {
      return a;
    } else if (scheme_reduced_procedure_struct
        && scheme_is_struct_instance(scheme_reduced_procedure_struct, a)
        && SCHEME_TRUEP(((Scheme_Structure *)a)->slots[2])) {
      return a;
    } else {
      /* Either use struct name, or extract proc, depending
         whether it's method-style */
      int is_method;
      b = scheme_extract_struct_procedure(a, -1, NULL, &is_method);
      if (!is_method && SCHEME_PROCP(b)) {
        a = b;
        SCHEME_USE_FUEL(1);
      } else
        break;
    }
  }

  return a;
}

const char *scheme_get_proc_name(Scheme_Object *p, int *len, int for_error)
     /* for_error > 0 => get name for an error message;
	for_error < 0 => symbol result ok set *len to -1 */
{
  Scheme_Type type;
  int dummy;
  char *s;

  if (!len)
    len = &dummy;

 top:

  type = SCHEME_TYPE(p);
  if (type == scheme_prim_type) {
    if (((Scheme_Primitive_Proc *)p)->name)
      *len = strlen(((Scheme_Primitive_Proc *)p)->name);
    return ((Scheme_Primitive_Proc *)p)->name;
  } else if (type == scheme_closed_prim_type) {
    if (((Scheme_Closed_Primitive_Proc *)p)->name)
      *len = strlen(((Scheme_Closed_Primitive_Proc *)p)->name);
    return ((Scheme_Closed_Primitive_Proc *)p)->name;
  } else if (type == scheme_cont_type || type == scheme_escaping_cont_type) {
    return NULL;
  } else if (type == scheme_case_closure_type) {
    Scheme_Object *n;

    n = ((Scheme_Case_Lambda *)p)->name;
    if (n) {
      if (SCHEME_BOXP(n)) {
	/* See note in schpriv.h about the IS_METHOD hack */
	n = SCHEME_BOX_VAL(n);
	if (SCHEME_FALSEP(n))
	  return NULL;
      }

      if (SCHEME_VECTORP(n))
	n = SCHEME_VEC_ELS(n)[0];

      if (for_error < 0) {
	s = (char *)n;
	*len = -1;
      } else {
	*len = SCHEME_SYM_LEN(n);
	s = scheme_symbol_val(n);
      }
    } else
      return NULL;
  } else if (type == scheme_proc_struct_type) {
    /* Assert: the request is for an error. */
    Scheme_Object *other;
    other = scheme_proc_struct_name_source(p);
    if (SAME_OBJ(other, p)) {
      if (scheme_reduced_procedure_struct
          && scheme_is_struct_instance(scheme_reduced_procedure_struct, p)) {
        /* It must have a name: */
        Scheme_Object *sym = ((Scheme_Structure *)p)->slots[2];
        if (for_error < 0) {
          s = (char *)sym;
          *len = -1;
        } else {
          *len = SCHEME_SYM_LEN(sym);
          s = scheme_symbol_val(sym);
        }
      } else {
        Scheme_Object *sym;
        intptr_t offset;
        sym = SCHEME_STRUCT_NAME_SYM(p);
        *len = SCHEME_SYM_LEN(sym);
        s = (char *)scheme_malloc_atomic((*len) + 8);
        if (0) {
          memcpy(s, "struct ", 7);
          offset = 7;
        } else
          offset = 0;
        memcpy(s + offset, scheme_symbol_val(sym), *len);
        (*len) += offset;
        s[*len] = 0;
        return s;
      }
    } else {
      p = other;
      goto top;
    }
  } else if (type == scheme_proc_chaperone_type) {
    p = SCHEME_CHAPERONE_VAL(p);
    SCHEME_USE_FUEL(1);
    goto top;
  } else {
    Scheme_Object *name;

    if ((type == scheme_ir_lambda_type)
        || (type == scheme_lambda_type)) {
      name = ((Scheme_Lambda *)p)->name;
    } else if (type == scheme_closure_type) {
      name = SCHEME_CLOSURE_CODE(p)->name;
    } else if (type == scheme_case_lambda_sequence_type) {
      Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)p;
      if (!cl->count)
        name = NULL;
      else
        name = ((Scheme_Lambda *)cl->array[0])->name;
    } else {
      /* Native closure: */
      name = ((Scheme_Native_Closure *)p)->code->u2.name;
      if (name && SAME_TYPE(SCHEME_TYPE(name), scheme_lambda_type)) {
	/* Not yet jitted. Use `name' as the other alternative of 
	   the union: */
	name = ((Scheme_Lambda *)name)->name;
      }
    }

    if (name) {
      if (SCHEME_VECTORP(name))
	name = SCHEME_VEC_ELS(name)[0];
      if (for_error < 0) {
	s = (char *)name;
	*len = -1;
      } else {
	*len = SCHEME_SYM_LEN(name);
	s = scheme_symbol_val(name);
      }
    } else
      return NULL;
  }

  if (0) {
    char *r;

    r = (char *)scheme_malloc_atomic((*len) + 11);
    memcpy(r, "procedure ", 10);
    memcpy(r + 10, s, *len + 1);
    *len += 10;

    return r;
  }

  return s;
}

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

  o = argv[0];

  if (SCHEME_PRIMP(o)
      && (((Scheme_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_IS_PRIMITIVE)) {
    if (((Scheme_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT) {
      Scheme_Prim_W_Result_Arity *p = (Scheme_Prim_W_Result_Arity *)o;
      return scheme_make_arity(p->minr, p->maxr);
    }
  } else if (SCHEME_CLSD_PRIMP(o)
	     && (((Scheme_Closed_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_IS_PRIMITIVE)) {
    if (((Scheme_Closed_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT) {
      Scheme_Closed_Prim_W_Result_Arity *p = (Scheme_Closed_Prim_W_Result_Arity *)o;
      return scheme_make_arity(p->minr, p->maxr);
    }
  } else {
    scheme_wrong_contract("primitive-result-arity", "primitive?", 0, argc, argv);
    return NULL;
  }
  return scheme_make_integer(1);
}

static Scheme_Object *procedure_result_arity(int argc, Scheme_Object *argv[])
{
  Scheme_Object *o, *orig_o;

  orig_o = argv[0];
  o = orig_o;

  if (SCHEME_CHAPERONEP(o))
    o = SCHEME_CHAPERONE_VAL(o);

  /* Struct procedures could be keyword-accepting and that
     requires additional complication; defer for now */
  if (SAME_TYPE(SCHEME_TYPE(o), scheme_proc_struct_type)
      /* Structs corresponding to reduced-arity procedures are ok, though.
         Their result arity is just that of the underlying procedure. */
      && !scheme_is_struct_instance(scheme_reduced_procedure_struct, o)) {
    return scheme_false;
  }

  if (SAME_TYPE(SCHEME_TYPE(o), scheme_closure_type)) {
    if ((SCHEME_LAMBDA_FLAGS(SCHEME_CLOSURE_CODE(o)) & LAMBDA_SINGLE_RESULT)) {
      return scheme_make_integer(1);
    }
#ifdef MZ_USE_JIT
  } else if (SAME_TYPE(SCHEME_TYPE(o), scheme_native_closure_type)) {
    if (scheme_native_closure_is_single_result(o))
      return scheme_make_integer(1);
#endif
  } else if (SAME_TYPE(SCHEME_TYPE(o), scheme_case_closure_type)) {
    Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)o;
    int i;
    
    for (i = cl->count; i--; ) {
      if (!(SCHEME_LAMBDA_FLAGS(SCHEME_CLOSURE_CODE(cl->array[i])) & LAMBDA_SINGLE_RESULT))
        break;
    }

    if (i < 0)
      return scheme_make_integer(1);
  } else if (SCHEME_PRIMP(o)) {
    if (((Scheme_Primitive_Proc *)o)->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT) {
      Scheme_Prim_W_Result_Arity *p = (Scheme_Prim_W_Result_Arity *)o;
      return scheme_make_arity(p->minr, p->maxr);
    }
    return scheme_make_integer(1);
  } else if (SCHEME_STRUCTP(o)
             && scheme_is_struct_instance(scheme_reduced_procedure_struct, o)) {
    return procedure_result_arity(1, &((Scheme_Structure *)o)->slots[0]);
  } else if (!SCHEME_PROCP(o)) {
    scheme_wrong_contract("procedure-result-arity", "procedure?", 0, argc, argv);
    return NULL;
  }
  return scheme_false;
}

Scheme_Object *scheme_object_name(Scheme_Object *a)
{
  Scheme_Object *v;

  v = scheme_struct_type_property_ref(scheme_object_name_property, a);

  if (v) {
    if (SCHEME_INTP(v))
      return scheme_struct_ref(a, SCHEME_INT_VAL(v));
    if (SCHEME_PROCP(v)) {
      if (scheme_check_proc_arity(NULL, 1, 0, 1, &v)) {
        Scheme_Object *f = v, *arg[1];
        
        arg[0] = a;
        return scheme_apply(f, 1, arg);
      }
    }
  }

  if (SCHEME_CHAPERONEP(a))
    a = SCHEME_CHAPERONE_VAL(a);

  if (SCHEME_PROC_STRUCTP(a)) {
    a = scheme_proc_struct_name_source(a);
    if (SCHEME_CHAPERONEP(a))
      a = SCHEME_CHAPERONE_VAL(a);
    
    if (SCHEME_STRUCTP(a)
        && scheme_reduced_procedure_struct
        && scheme_is_struct_instance(scheme_reduced_procedure_struct, a)) {
      /* It must have a name: */
      return ((Scheme_Structure *)a)->slots[2];
    }
  }

  if (SCHEME_STRUCTP(a)) {
    if (!(SCHEME_STRUCT_TYPE(a)->more_flags & STRUCT_TYPE_FLAG_SYSTEM_OPAQUE))
      return SCHEME_STRUCT_NAME_SYM(a);
  } else if (SCHEME_PROCP(a)) {
    const char *s;
    int len;

    s = scheme_get_proc_name(a, &len, -1);
    if (s) {
      if (len < 0)
	return (Scheme_Object *)s;
      else
	return scheme_intern_exact_symbol(s, len);
    }
  } else if (SCHEME_STRUCT_TYPEP(a)) {
    return ((Scheme_Struct_Type *)a)->name;
  } else if (SAME_TYPE(SCHEME_TYPE(a), scheme_struct_property_type)) {
    return ((Scheme_Struct_Property *)a)->name;
  } else if (SAME_TYPE(SCHEME_TYPE(a), scheme_regexp_type)) {
    Scheme_Object *s;
    s = scheme_regexp_source(a);
    if (s)
      return s;
  } else if (SCHEME_INPUT_PORTP(a)) {
    Scheme_Input_Port *ip;
    ip = scheme_input_port_record(a);
    return ip->name;
  } else if (SCHEME_OUTPUT_PORTP(a)) {
    Scheme_Output_Port *op;
    op = scheme_output_port_record(a);
    return op->name;
  } else if (SCHEME_THREADP(a)) {
    Scheme_Thread *t = (Scheme_Thread *)a;
    if (t->name) {
      return t->name;
    }
  } else if (SAME_TYPE(SCHEME_TYPE(a), scheme_logger_type)) {
    Scheme_Logger *logger = (Scheme_Logger *)a;
    if (logger->name)
      return logger->name;
  } else if (SCHEME_PROMPT_TAGP(a)) {
    /* See make_prompt_tag for the structure of continuation prompt tags. */
    if (SCHEME_CDR(a))
      return SCHEME_CDR(a);
  }

  return scheme_false;
}

static Scheme_Object *object_name(int argc, Scheme_Object **argv)
{
  return scheme_object_name(argv[0]);
}

Scheme_Object *scheme_arity(Scheme_Object *p)
{
  return get_or_check_arity(p, -1, NULL, 1);
}

static Scheme_Object *procedure_arity(int argc, Scheme_Object *argv[])
{
  if (!SCHEME_PROCP(argv[0]))
    scheme_wrong_contract("procedure-arity", "procedure?", 0, argc, argv);

  return get_or_check_arity(argv[0], -1, NULL, 1);
}

static Scheme_Object *procedure_arity_mask(int argc, Scheme_Object *argv[])
{
  if (!SCHEME_PROCP(argv[0]))
    scheme_wrong_contract("procedure-arity-mask", "procedure?", 0, argc, argv);

  return get_or_check_arity(argv[0], -4, NULL, 1);
}

static Scheme_Object *procedure_arity_p(int argc, Scheme_Object *argv[])
{
  Scheme_Object *a = argv[0], *v;

  if (SCHEME_INTP(a)) {
    return ((SCHEME_INT_VAL(a) >= 0) ? scheme_true : scheme_false);
  } else if (SCHEME_BIGNUMP(a)) {
    return (SCHEME_BIGPOS(a) ? scheme_true : scheme_false);
  } else if (SCHEME_NULLP(a)) {
    return scheme_true;
  } else if (SCHEME_PAIRP(a)) {
    while (SCHEME_PAIRP(a)) {
      v = SCHEME_CAR(a);
      if (SCHEME_INTP(v)) {
        if (SCHEME_INT_VAL(v) < 0)
          return scheme_false;
      } else if (SCHEME_BIGNUMP(v)) {
        if (!SCHEME_BIGPOS(v))
          return scheme_false;
      } else if (!SCHEME_CHAPERONE_STRUCTP(v)
                 || !scheme_is_struct_instance(scheme_arity_at_least, v)) {
        return scheme_false;
      }
      a = SCHEME_CDR(a);
    }
    return SCHEME_NULLP(a) ? scheme_true : scheme_false;
  } else if (SCHEME_CHAPERONE_STRUCTP(a)
             && scheme_is_struct_instance(scheme_arity_at_least, a)) {
    return scheme_true;
  } else
    return scheme_false;
}

Scheme_Object *scheme_procedure_arity_includes(int argc, Scheme_Object *argv[])
{
  intptr_t n;
  int inc_ok;

  if (!SCHEME_PROCP(argv[0]))
    scheme_wrong_contract("procedure-arity-includes?", "procedure?", 0, argc, argv);

  n = scheme_extract_index("procedure-arity-includes?", 1, argc, argv, -2, 0);
  /* -2 means a bignum */

  inc_ok = ((argc > 2) && SCHEME_TRUEP(argv[2]));

  return get_or_check_arity(argv[0], n, argv[1], inc_ok);
}

static int is_arity(Scheme_Object *a, int at_least_ok, int list_ok)
{
  if (SCHEME_INTP(a)) {
    return (SCHEME_INT_VAL(a) >= 0);
  } else if (SCHEME_BIGNUMP(a)) {
    return SCHEME_BIGPOS(a);
  } else if (at_least_ok
             && SCHEME_CHAPERONE_STRUCTP(a)
             && scheme_is_struct_instance(scheme_arity_at_least, a)) {
    a = scheme_struct_ref(a, 0);
    return is_arity(a, 0, 0);
  }

  if (!list_ok)
    return 0;

  while (SCHEME_PAIRP(a)) {
    if (!is_arity(SCHEME_CAR(a), 1, 0))
      return 0;
    a = SCHEME_CDR(a);
  }

  if (SCHEME_NULLP(a))
    return 1;
  return 0;
}

void scheme_init_reduced_proc_struct(Scheme_Startup_Env *env)
{
  if (!scheme_reduced_procedure_struct) {
    Scheme_Inspector *insp;

    REGISTER_SO(scheme_reduced_procedure_struct);
    insp = (Scheme_Inspector *) scheme_get_current_inspector();
    while (insp->superior->superior) {
      insp = insp->superior;
    }
    scheme_reduced_procedure_struct = scheme_make_struct_type2(scheme_intern_symbol("procedure"),
                                                               NULL,
                                                               (Scheme_Object *)insp,
                                                               4, 0,
                                                               scheme_false,
                                                               scheme_null,
                                                               scheme_make_integer(0),
                                                               NULL, NULL);
  }
}

static Scheme_Object *arity_to_mask(Scheme_Object *aty)
{
  if (SCHEME_INTP(aty)) {
    intptr_t n = SCHEME_INT_VAL(aty);
    if (n <= SCHEME_MAX_FAST_ARITY_CHECK)
      return scheme_make_integer(1 << n);
    else
      return make_shifted_one(n);
  } else if (SCHEME_BIGNUMP(aty)) {
    scheme_raise_out_of_memory(NULL, NULL);
    return NULL;
  } else if (SCHEME_STRUCTP(aty)) {
    Scheme_Object *mask;

    aty = scheme_struct_ref(aty, 0);
    if (SCHEME_INTP(aty))
      return make_arity_mask(SCHEME_INT_VAL(aty), -1);
    else {
      mask = arity_to_mask(aty);
      return scheme_bin_bitwise_xor(scheme_bin_minus(mask, scheme_make_integer(1)),
                                    scheme_make_integer(-1));
    }
  } else if (SCHEME_PAIRP(aty)) {
    Scheme_Object *mask = scheme_make_integer(0);
    while (SCHEME_PAIRP(aty)) {
      mask = scheme_bin_bitwise_or(arity_to_mask(SCHEME_CAR(aty)), mask);
      aty = SCHEME_CDR(aty);
    }
    return mask;
  } else
    return scheme_make_integer(0);
}

static Scheme_Object *mask_to_arity(Scheme_Object *mask, int mode)
{
  intptr_t n, pos = 0;
  Scheme_Object *l = scheme_null;

  while (!SCHEME_INTP(mask)) {
    Scheme_Object *a[2], *b;
    b = scheme_bin_bitwise_and(mask, scheme_make_integer(0xFFFF));
    if (SCHEME_INTP(b)) {
      b = scheme_bin_bitwise_and(mask, scheme_make_integer(1));
      if (SCHEME_INTP(b))
        l = scheme_make_pair(scheme_make_integer(pos), l);
      pos++;
      a[0] = mask;
      a[1] = scheme_make_integer(-1);
      mask = scheme_bitwise_shift(2, a);
    } else {
      pos += 16;
      a[0] = mask;
      a[1] = scheme_make_integer(-16);
      mask = scheme_bitwise_shift(2, a);
    }
  }

  n = SCHEME_INT_VAL(mask);
  if (!n) {
    if (SCHEME_PAIRP(l) && SCHEME_NULLP(SCHEME_CDR(l)))
      return SCHEME_CAR(l);
    else
      return scheme_reverse(l);
  }
  
  while (1) {
    if (n == -1) {
      if (SCHEME_NULLP(l))
        return make_arity(pos, -1, mode);
      else
        return scheme_reverse(scheme_make_pair(make_arity(pos, -1, mode), l));
    } else if (n == 1) {
      if (SCHEME_NULLP(l))
        return scheme_make_integer(pos);
      else
        return scheme_reverse(scheme_make_pair(scheme_make_integer(pos), l));
    } else if (n & 0x1) {
      l = scheme_make_pair(scheme_make_integer(pos), l);
    }
    pos++;
    n >>= 1;
  }
}

Scheme_Object *scheme_arity_mask_to_arity(Scheme_Object *mask, int mode)
{
  return mask_to_arity(mask, mode);
}

static Scheme_Object *make_reduced_proc(Scheme_Object *proc,
                                        Scheme_Object *mask,
                                        Scheme_Object *name, Scheme_Object *is_meth)
{
  Scheme_Structure *inst;
  
  if (SCHEME_STRUCTP(proc)
      && scheme_is_struct_instance(scheme_reduced_procedure_struct, proc)) {
    /* Don't need the intermediate layer */
    if (!name)
      name = ((Scheme_Structure *)proc)->slots[2];
    if (!is_meth)
      is_meth = ((Scheme_Structure *)proc)->slots[3];
    proc = ((Scheme_Structure *)proc)->slots[0];
  }

  inst = (Scheme_Structure *)scheme_malloc_tagged(sizeof(Scheme_Structure)
                                                  + ((4 - mzFLEX_DELTA) * sizeof(Scheme_Object *)));
  inst->so.type = scheme_proc_struct_type;
  inst->stype = (Scheme_Struct_Type *)scheme_reduced_procedure_struct;

  inst->slots[0] = proc;
  inst->slots[1] = mask;
  inst->slots[2] = (name ? name : scheme_false);
  inst->slots[3] = (is_meth ? is_meth : scheme_false);

  return (Scheme_Object *)inst;
}

static int is_subarity(Scheme_Object *req, Scheme_Object *orig, int req_delta)
{
  Scheme_Object *oa, *ra, *ol, *lra, *ara, *prev, *pr, *tmp, *rd;

  if (!SCHEME_PAIRP(orig) && !SCHEME_NULLP(orig))
    orig = scheme_make_pair(orig, scheme_null);
  if (!SCHEME_PAIRP(req) && !SCHEME_NULLP(req))
    req = scheme_make_pair(req, scheme_null);

  rd = scheme_make_integer(req_delta);

  while (!SCHEME_NULLP(req)) {
    ra = SCHEME_CAR(req);
    if (SCHEME_CHAPERONE_STRUCTP(ra)
        && scheme_is_struct_instance(scheme_arity_at_least, ra)) {
      /* Convert to a sequence of range pairs, where the
         last one can be (min, #f); we'll iterate through the 
         original arity to knock out ranges until (if it matches)
         we end up with an empty list of ranges. */
      ra = scheme_make_pair(scheme_make_pair(scheme_struct_ref(ra, 0),
                                             scheme_false),
                            scheme_null);
    }

    for (ol = orig; !SCHEME_NULLP(ol); ol = SCHEME_CDR(ol)) {
      oa = SCHEME_CAR(ol);
      if (SCHEME_INTP(ra) || SCHEME_BIGNUMP(ra)) {
        if (SCHEME_INTP(oa) || SCHEME_BIGNUMP(oa)) {
          if (scheme_equal(scheme_bin_plus(ra, rd), oa))
            break;
        } else {
          /* orig is arity-at-least */
          oa = ((Scheme_Structure *)oa)->slots[0];
          if (scheme_bin_lt_eq(oa, scheme_bin_plus(ra, rd)))
            break;
        }
      } else {
        /* requested is arity-at-least */
        int at_least;
        if (SCHEME_INTP(oa) || SCHEME_BIGNUMP(oa)) {
          at_least = 0;
        } else {
          /* orig is arity-at-least */
          at_least = 1;
          oa = ((Scheme_Structure *)oa)->slots[0];
        }

        lra = ra;
        prev = NULL;
        while (!SCHEME_NULLP(lra)) {
          /* check [lo, hi] vs oa: */
          ara = SCHEME_CAR(lra);
          if (SCHEME_FALSEP(SCHEME_CDR(ara))
              || scheme_bin_lt_eq(oa, scheme_bin_plus(SCHEME_CDR(ara), rd))) {
            if (scheme_bin_gt_eq(oa, scheme_bin_plus(SCHEME_CAR(ara), rd))) {
              /* oa is in the range [lo, hi]: */
              if (scheme_equal(oa, scheme_bin_plus(SCHEME_CAR(ara), rd))) {
                /* the range is [oa, hi] */
                if (at_least) {
                  /* oa is arity-at least, so drop from here */
                  if (prev)
                    SCHEME_CDR(prev) = scheme_null;
                  else
                    ra = scheme_null;
                } else {
                  if (scheme_equal(oa, scheme_bin_plus(SCHEME_CDR(ara), rd))) {
                    /* the range is [oa, oa], so drop it */
                    if (prev)
                      SCHEME_CDR(prev) = SCHEME_CDR(lra);
                    else
                      ra = SCHEME_CDR(lra);
                  } else {
                    /* change range to [ao+1, hi] */
                    tmp = scheme_bin_plus(oa, scheme_make_integer(1));
                    tmp = scheme_bin_minus(tmp, rd);
                    SCHEME_CAR(ara) = tmp;
                  }
                }
              } else if (scheme_equal(oa, scheme_bin_plus(SCHEME_CAR(ara), rd))) {
                /* the range is [lo, oa], where lo < oa */
                tmp = scheme_bin_minus(oa, scheme_make_integer(1));
                tmp = scheme_bin_minus(tmp, rd);
                SCHEME_CDR(ara) = tmp;
                if (at_least) 
                  SCHEME_CDR(lra) = scheme_null;
              } else {
                /* split the range */
                if (at_least) {
                  tmp = scheme_bin_minus(oa, scheme_make_integer(1));
                  tmp = scheme_bin_minus(tmp, rd);
                  SCHEME_CDR(ara) = tmp;
                  SCHEME_CDR(lra) = scheme_null;
                } else {
                  tmp = scheme_bin_plus(oa, scheme_make_integer(1));
                  tmp = scheme_bin_minus(tmp, rd);
                  pr = scheme_make_pair(scheme_make_pair(tmp, SCHEME_CDR(ara)),
                                        SCHEME_CDR(lra));
                  tmp = scheme_bin_minus(oa, scheme_make_integer(1));
                  tmp = scheme_bin_minus(tmp, rd);
                  SCHEME_CDR(ara) = tmp;
                  SCHEME_CDR(lra) = pr;
                }
              }
              break;
            } else if (at_least) {
              /* oa is less than lo, so truncate */
              if (prev)
                SCHEME_CDR(prev) = scheme_null;
              else
                ra = scheme_null;
              break;
            }
          }
          prev = lra;
          lra = SCHEME_CDR(lra);
        }
        if (SCHEME_NULLP(ra))
          break;
      }
    }

    if (SCHEME_NULLP(ol)) {
      return 0;
    }

    req = SCHEME_CDR(req);
  }

  return 1;
}

static int proc_is_method(Scheme_Object *proc)
{
  if (SCHEME_CHAPERONEP(proc))
    proc = SCHEME_CHAPERONE_VAL(proc);

  if (SCHEME_STRUCTP(proc)
      && scheme_is_struct_instance(scheme_reduced_procedure_struct, proc))
    return SCHEME_TRUEP(((Scheme_Structure *)proc)->slots[3]);

  if (SAME_TYPE(SCHEME_TYPE(proc), scheme_case_closure_type)) {
    Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)proc;
    if (cl->count)
      proc = cl->array[0];
    else
      return 0;
  }

  if (SAME_TYPE(SCHEME_TYPE(proc), scheme_closure_type)) {
    return ((SCHEME_LAMBDA_FLAGS(SCHEME_CLOSURE_CODE(proc)) & LAMBDA_IS_METHOD)
            ? 1
            : 0);
  }

#ifdef MZ_USE_JIT
  if (SAME_TYPE(SCHEME_TYPE(proc), scheme_native_closure_type)) {
    Scheme_Object *pa;
    pa = scheme_get_native_arity(proc, -1);
    return SCHEME_BOXP(pa);
  }
#endif

  return 0;
}

static Scheme_Object *do_procedure_reduce_arity(const char *who, int argc, Scheme_Object *argv[], int as_arity)
{
  Scheme_Object *orig, *mask, *is_meth = NULL, *name = NULL;

  if (!SCHEME_PROCP(argv[0]))
    scheme_wrong_contract("procedure-reduce-arity", "procedure?", 0, argc, argv);

  if (as_arity) {
    if (!is_arity(argv[1], 1, 1)) {
      scheme_wrong_contract(who,
                            "(or/c exact-nonnegative-integer? arity-at-least? (listof (or/c exact-nonnegative-integer? arity-at-least?)))", 
                            1, argc, argv);
    }
    mask = arity_to_mask(argv[1]);
  } else {
    mask = argv[1];
    if (!scheme_exact_p(mask)) {
      scheme_wrong_contract(who, "exact-integer?", 1, argc, argv);
      return NULL;
    }
  }
  
  if (argc > 2) {
    name = argv[2];
    if (SCHEME_FALSEP(name))
      name = NULL;
    else if (!SCHEME_SYMBOLP(name)) {
      scheme_wrong_contract(who, "(or/c symbol? #f)", 2, argc, argv);
      return NULL;
    }
  } else
    name = NULL;

  /* Check whether current arity covers the requested arity. */

  orig = get_or_check_arity(argv[0], -4, NULL, 1);

  if (!scheme_bin_eq(scheme_bin_bitwise_and(mask, orig), mask)) {
    scheme_contract_error(who,
                          (as_arity
                           ? "arity of procedure does not include requested arity"
                           : "arity mask of procedure does not include requested arity mask"),
                          "procedure", 1, argv[0],
                          (as_arity ? "requested arity" : "requested arity mask"), 1, argv[1],
                          NULL);
    return NULL;
  }

  if (proc_is_method(argv[0]))
    is_meth = scheme_true;

  /* Construct a procedure that has the given arity. */
  return make_reduced_proc(argv[0], mask, name, is_meth);
}

static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
{
  return do_procedure_reduce_arity("procedure-reduce-arity", argc, argv, 1);
}

static Scheme_Object *procedure_reduce_arity_mask(int argc, Scheme_Object *argv[])
{
  return do_procedure_reduce_arity("procedure-reduce-arity-mask", argc, argv, 0);
}

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

  if (!SCHEME_PROCP(argv[0]))
    scheme_wrong_contract("procedure-rename", "procedure?", 0, argc, argv);
  if (!SCHEME_SYMBOLP(argv[1]))
    scheme_wrong_contract("procedure-rename", "symbol?", 1, argc, argv);

  p = scheme_rename_struct_proc(argv[0], argv[1]);
  if (p) return p;

  mask = get_or_check_arity(argv[0], -4, NULL, 1);

  return make_reduced_proc(argv[0], mask, argv[1], NULL);
}

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

  if (!SCHEME_PROCP(argv[0]))
    scheme_wrong_contract("procedure->method", "procedure?", 0, argc, argv);

  mask = get_or_check_arity(argv[0], -4, NULL, 1);

  return make_reduced_proc(argv[0], mask, NULL, scheme_true);
}

static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[])
{
  Scheme_Object *v1 = argv[0], *v2 = argv[1];

  if (!SCHEME_PROCP(v1))
    scheme_wrong_contract("procedure-closure-contents-eq?", "procedure?", 0, argc, argv);
  if (!SCHEME_PROCP(v2))
    scheme_wrong_contract("procedure-closure-contents-eq?", "procedure?", 1, argc, argv);

  if (SAME_OBJ(v1, v2))
    return scheme_true;

  if (!SAME_TYPE(SCHEME_TYPE(v1), SCHEME_TYPE(v2)))
    return scheme_false;

  switch (SCHEME_TYPE(v1)) {
  case scheme_prim_type:
    {
      Scheme_Primitive_Proc *p1 = (Scheme_Primitive_Proc *)v1;
      Scheme_Primitive_Proc *p2 = (Scheme_Primitive_Proc *)v2;

      if (p1->prim_val == p2->prim_val) {
	if (p1->pp.flags & SCHEME_PRIM_IS_CLOSURE) {
	  if (!(p2->pp.flags & SCHEME_PRIM_IS_CLOSURE))
	    return scheme_false;

	  /* They both are closures, but we don't know how 
	     many fields in each, except in 3m mode. So
	     give up. */
	  return scheme_false;
	} else if (!(p2->pp.flags & SCHEME_PRIM_IS_CLOSURE))
	  return scheme_true;
      }
    }
    break;
  case scheme_closure_type:
    {
      Scheme_Closure *c1 = (Scheme_Closure *)v1;
      Scheme_Closure *c2 = (Scheme_Closure *)v2;

      if (SAME_OBJ(c1->code, c2->code)) {
	int i;
	for (i = c1->code->closure_size; i--; ) {
	  if (!SAME_OBJ(c1->vals[i], c2->vals[i]))
	    return scheme_false;
	}
	return scheme_true;
      }
    }
    break;
  case scheme_native_closure_type:
    {
      Scheme_Native_Closure *c1 = (Scheme_Native_Closure *)v1;
      Scheme_Native_Closure *c2 = (Scheme_Native_Closure *)v2;

      if (SAME_OBJ(c1->code, c2->code)
          || (c1->code->eq_key && SAME_OBJ(c1->code->eq_key, c2->code->eq_key))) {
	int i;
	i = c1->code->closure_size;
	if (i < 0) {
	  /* A case closure */
	  Scheme_Native_Closure *sc1, *sc2;
	  int j;
	  i = -(i + 1);
	  while (i--) {
	    sc1 = (Scheme_Native_Closure *)c1->vals[i];
	    sc2 = (Scheme_Native_Closure *)c2->vals[i];
	    j = sc1->code->closure_size;
	    while (j--) {
	      if (!SAME_OBJ(sc1->vals[j], sc2->vals[j]))
		return scheme_false;
	    }
	  }
	} else {
	  /* Normal closure: */
	  while (i--) {
	    if (!SAME_OBJ(c1->vals[i], c2->vals[i]))
	      return scheme_false;
	  }
	}
	return scheme_true;
      }
    }
    break;
  case scheme_case_closure_type:
    {
      Scheme_Case_Lambda *c1 = (Scheme_Case_Lambda *)v1;
      Scheme_Case_Lambda *c2 = (Scheme_Case_Lambda *)v2;
      if (c1->count == c2->count) {
	Scheme_Closure *sc1, *sc2;
	int i, j;
	for (i = c1->count; i--; ) {
	  sc1 = (Scheme_Closure *)c1->array[i];
	  sc2 = (Scheme_Closure *)c2->array[i];
	  if (!SAME_OBJ(sc1->code, sc2->code))
	    return scheme_false;
	  for (j = sc1->code->closure_size; j--; ) {
	    if (!SAME_OBJ(sc1->vals[j], sc2->vals[j]))
	      return scheme_false;
	  }
	}
	return scheme_true;
      }
    }
    break;
  }

  return scheme_false;
}

static Scheme_Object *procedure_specialize(int argc, Scheme_Object *argv[])
{
  if (!SCHEME_PROCP(argv[0]))
    scheme_wrong_contract("procedure-specialize", "procedure?", 0, argc, argv);

#ifdef MZ_USE_JIT
  if (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_native_closure_type)) {
    Scheme_Native_Closure *nc = (Scheme_Native_Closure *)argv[0];
    if ((nc->code->start_code == scheme_on_demand_jit_code)
        && !(SCHEME_NATIVE_LAMBDA_FLAGS(nc->code) & NATIVE_SPECIALIZED)) {
      Scheme_Native_Lambda *data;
      if (!nc->code->eq_key) {
        void *p;
        p = scheme_malloc_atomic(sizeof(int));
        nc->code->eq_key = p;
      }
      data = MALLOC_ONE_TAGGED(Scheme_Native_Lambda);
      memcpy(data, nc->code, sizeof(Scheme_Native_Lambda));
      SCHEME_NATIVE_LAMBDA_FLAGS(data) |= NATIVE_SPECIALIZED;
      nc->code = data;
    }
  }
#endif

  return argv[0];
}

static Scheme_Object *do_chaperone_procedure(const char *name, const char *whating,
                                             int is_impersonator, int pass_self,
                                             int argc, Scheme_Object *argv[], int is_unsafe)
{
  Scheme_Chaperone *px, *px2;
  Scheme_Object *val = argv[0], *orig, *r, *app_mark;
  Scheme_Object *props;

  if (SCHEME_CHAPERONEP(val))
    val = SCHEME_CHAPERONE_VAL(val);

  if (!SCHEME_PROCP(val))
    scheme_wrong_contract(name, "procedure?", 0, argc, argv);
  if (is_unsafe) {
    if (!SCHEME_PROCP(argv[1]))
      scheme_wrong_contract(name, "procedure?", 1, argc, argv);
  } else {
    if (!SCHEME_FALSEP(argv[1]) && !SCHEME_PROCP(argv[1]))
      scheme_wrong_contract(name, "(or/c procedure? #f)", 1, argc, argv);
  }

  orig = get_or_check_arity(val, -1, NULL, 1);
  if (!SCHEME_FALSEP(argv[1])) {
    Scheme_Object *naya;
    naya = get_or_check_arity(argv[1], -1, NULL, 1);

    if (!is_subarity(orig, naya, pass_self ? 1 : 0))
      scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                       "%s: arity of wrapper procedure does not cover arity of original procedure%s\n"
                       "  wrapper: %V\n"
                       "  original: %V",
                       name,
                       (pass_self ? " (adding an extra argument)": ""),
                       argv[1],
                       argv[0]);
  }

  props = scheme_parse_chaperone_props(name, 2, argc, argv);
  if (props) {
    app_mark = scheme_chaperone_props_get(props, scheme_app_mark_impersonator_property);
    if (app_mark) {
      /* don't need to keep the property */
      props = scheme_chaperone_props_remove(props, scheme_app_mark_impersonator_property);
    } else
      app_mark = scheme_false;
  } else
    app_mark = scheme_false;

  if (SCHEME_FALSEP(argv[1]) && SCHEME_FALSEP(app_mark) && !props)
    return argv[0];

  /* app_mark should be (cons mark val) */
  if (SCHEME_FALSEP(app_mark) && !SCHEME_PAIRP(app_mark))
    app_mark = scheme_false;
  
  px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
  px->iso.so.type = scheme_proc_chaperone_type;
  px->val = val;
  px->prev = argv[0];
  px->props = props;

  /* Put the procedure along with known-good arity (to speed checking;
     initialized to -1) in a vector. 

     Vector of odd size for redirects means a procedure chaperone,
     vector with non-zero even slots means a structure chaperone,
     vector with zero slots means a property-only vector chaperone.
     A size of 5 (instead of 3) indicates that the wrapper
     procedure accepts a "self" argument. An immutable vector
     means that it wraps a chaperone that wants the "self" 
     argument.

     If the known-good arity is #f, this means the chaperone
     wrapper defers directly to SCHEME_VEC_ELES(r)[0] and no
     arity check is needed.
  */
  r = scheme_make_vector((pass_self ? 5 : 3), scheme_make_integer(-1));

  if (SCHEME_FALSEP(argv[1]))
    SCHEME_VEC_ELS(r)[0] = argv[0];
  else
    SCHEME_VEC_ELS(r)[0] = argv[1];
  if (SCHEME_FALSEP(argv[1]))
    SCHEME_VEC_ELS(r)[1] = scheme_false;
  SCHEME_VEC_ELS(r)[2] = app_mark;

  px->redirects = r;

  if (is_impersonator)
    SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
  if (is_unsafe || SCHEME_FALSEP(argv[1]))
    SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_PROC_CHAPERONE_CALL_DIRECT;

  if (!is_unsafe) {
    /* If there's a `pass_self` chaperone in px->prev, then we'll need
       to pass the self proc along. */
    for (val = px->prev; SCHEME_P_CHAPERONEP(val); val = ((Scheme_Chaperone *)val)->prev) {
      px2 = (Scheme_Chaperone *)val;
      if (SCHEME_REDIRECTS_PROCEDUREP(px2->redirects)) {
        if ((SCHEME_VEC_SIZE(px2->redirects) > 3)
            || SCHEME_IMMUTABLEP(px2->redirects))
          SCHEME_SET_IMMUTABLE(px->redirects);
        break;
      }
    }
  }

  return (Scheme_Object *)px;
}

static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[])
{
  return do_chaperone_procedure("chaperone-procedure", "chaperoning", 0, 0, argc, argv, 0);
}

static Scheme_Object *unsafe_chaperone_procedure(int argc, Scheme_Object *argv[])
{
  return do_chaperone_procedure("unsafe-chaperone-procedure", "chaperoning", 0, 0, argc, argv, 1);
}

static Scheme_Object *impersonate_procedure(int argc, Scheme_Object *argv[])
{
  return do_chaperone_procedure("impersonate-procedure", "impersonating", 1, 0, argc, argv, 0);
}

static Scheme_Object *unsafe_impersonate_procedure(int argc, Scheme_Object *argv[])
{
  return do_chaperone_procedure("unsafe-impersonate-procedure", "impersonating", 1, 0, argc, argv, 1);
}

static Scheme_Object *chaperone_procedure_star(int argc, Scheme_Object *argv[])
{
  return do_chaperone_procedure("chaperone-procedure*", "chaperoning", 0, 1, argc, argv, 0);
}

static Scheme_Object *impersonate_procedure_star(int argc, Scheme_Object *argv[])
{
  return do_chaperone_procedure("impersonate-procedure*", "impersonating", 1, 1, argc, argv, 0);
}

static Scheme_Object *apply_chaperone_k(void)
{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
  Scheme_Object **argv = (Scheme_Object **)p->ku.k.p2;
  Scheme_Object *auto_val = (Scheme_Object *)p->ku.k.p3;

  p->ku.k.p1 = NULL;
  p->ku.k.p2 = NULL;
  p->ku.k.p3 = NULL;

  return scheme_apply_chaperone(o, p->ku.k.i1, argv, auto_val, p->ku.k.i2);
}

static Scheme_Object *do_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val, int checks)
{
#ifdef DO_STACK_CHECK
  {
# include "mzstkchk.h"
    {
      Scheme_Thread *p = scheme_current_thread;
      Scheme_Object **argv2;
      argv2 = MALLOC_N(Scheme_Object*, argc);
      memcpy(argv2, argv, sizeof(Scheme_Object *) * argc);
      p->ku.k.p1 = (void *)o;
      p->ku.k.p2 = (void *)argv2;
      p->ku.k.p3 = (void *)auto_val;
      p->ku.k.i1 = argc;
      p->ku.k.i2 = checks;
      return scheme_handle_stack_overflow(apply_chaperone_k);
    }
  }
#endif

  return scheme_apply_chaperone(o, argc, argv, auto_val, checks);
}


static Scheme_Object *_apply_native(Scheme_Object *obj, int num_rands, Scheme_Object **rands)
{
  Scheme_Native_Lambda *data;
  GC_MAYBE_IGNORE_INTERIOR MZ_MARK_STACK_TYPE old_cont_mark_stack;
  GC_MAYBE_IGNORE_INTERIOR Scheme_Object **rs;

  data = ((Scheme_Native_Closure *)obj)->code;

  if ((uintptr_t)data->max_let_depth > ((uintptr_t)scheme_current_runstack - (uintptr_t)scheme_current_runstack_start)) {
    return _scheme_apply_multi(obj, num_rands, rands);
  }

  MZ_CONT_MARK_POS += 2;
  old_cont_mark_stack = MZ_CONT_MARK_STACK;
  rs = MZ_RUNSTACK;

  obj = data->start_code(obj, num_rands, rands EXTRA_NATIVE_ARGUMENT);

  if (obj == SCHEME_TAIL_CALL_WAITING)
    obj = scheme_force_value_same_mark(obj);

  MZ_CONT_MARK_STACK = old_cont_mark_stack;
  MZ_CONT_MARK_POS -= 2;
  MZ_RUNSTACK = rs;

  return obj;
}

Scheme_Object *_scheme_apply_native(Scheme_Object *obj, int num_rands, Scheme_Object **rands)
{
  return _apply_native(obj, num_rands, rands);
}

Scheme_Object *extract_impersonator_results(int c, int argc, Scheme_Object **argv2,
                                            const char *what, Scheme_Object *o,
                                            Scheme_Chaperone *px,
                                            Scheme_Cont_Frame_Data *cframe, int *_need_pop)
{
  int extra = c - argc;
  int i, fail_reason = 0;
  Scheme_Object *post;
  char nth[32];
  Scheme_Config *config = NULL;
 
  if (!extra)
    return NULL;
  
  post = NULL;
  for (i = 0; i < extra; ) {
    if (!i && SCHEME_PROCP(argv2[0])) {
      post = argv2[i];
      i++;
    } else if (SAME_OBJ(argv2[i], mark_symbol)) {
      if (i + 3 > extra) {
        fail_reason = 2;
        break;
      }
      if (post && !*_need_pop) {
        scheme_push_continuation_frame(cframe);
        *_need_pop = 1;
      }
      scheme_set_cont_mark(argv2[i+1], argv2[i+2]);
      i += 3;
    } else {
      fail_reason = 1;
      break;
    }
  }

  if (!fail_reason) {
    if (config) {
      if (post && !*_need_pop) {
        scheme_push_continuation_frame(cframe);
        *_need_pop = 1;
      }
      scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
    }
    return post;
  }

  /* Failure at argument i */

  switch (i % 10) {
  case 1:
    sprintf(nth, "%dst", i);
    break;
  case 2:
    sprintf(nth, "%dnd", i);
    break;
  case 3:
    sprintf(nth, "%drd", i);
    break;
  default:
    sprintf(nth, "%dth", i);
  }

  if (fail_reason == 1) {
    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                     "procedure %s: wrapper's %s result is not valid;\n"
                     " %s extra result (before original argument count) should be\n"
                     " 'mark%s\n"
                     "  original: %V\n"
                     "  wrapper: %V\n"
                     "  received: %V",
                     what,
                     nth,
                     nth,
                     (i ? "" : " or a wrapper for the original procedure's result"),
                     o,
                     SCHEME_VEC_ELS(px->redirects)[0],
                     argv2[i]);
  } else if (fail_reason == 2) {
    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                     "procedure %s: wrapper's %s result needs addition extra results;\n"
                     " %s extra result (before original argument count) needs an\n"
                     " additional %s after %V\n"
                     "  original: %V\n"
                     "  wrapper: %V",
                     what,
                     nth,
                     nth,
                     ((i + 1 < extra) ? "result" : "two results"),
                     argv2[i],
                     o,
                     SCHEME_VEC_ELS(px->redirects)[0]);
  }

  return NULL;
}

/* must be at least 3: */
#define MAX_QUICK_CHAP_ARGV 5

#define CHAPERONE_KIND_STR(px) (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR) ? "chaperone" : "impersonator")

Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object **argv, Scheme_Object *auto_val, int checks)
/* auto_val => no need to actually call the function (but handle further chaperoning);
   checks & 0x2 => no tail; checks == 0x3 => no tail or multiple */
{
  Scheme_Chaperone *px;
  Scheme_Object *v, *a[1], *a2[MAX_QUICK_CHAP_ARGV], **argv2, *post, *result_v, *orig_obj, *app_mark, *self_proc, *simple_call;
  int c, i, need_restore = 0;
  int need_pop_mark;
  Scheme_Cont_Frame_Data cframe;

  if (SCHEME_RPAIRP(o)) {
    /* An applicable struct, where a layer of struct chaperones
       has been removed from the object to apply, but we will
       eventually need to extract the procedure from the original
       object. */
    orig_obj = SCHEME_CDR(o);
    o = SCHEME_CAR(o);
  } else {
    orig_obj = NULL;
  }
  px = (Scheme_Chaperone *)o;

  {
    Scheme_Thread *p = scheme_current_thread;
    self_proc = p->self_for_proc_chaperone;
    if (self_proc)
      p->self_for_proc_chaperone = NULL;
    else
      self_proc = o;
  }

  /* Ensure that the original procedure accepts `argc' arguments: */
  if (!SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[1]) /* check not needed for props-only mode */
      && (argc != SCHEME_INT_VAL(SCHEME_VEC_ELS(px->redirects)[1]))) {
    a[0] = px->prev;
    if (!scheme_check_proc_arity(NULL, argc, 0, 0, a)) {
      /* Apply the original procedure, in case the chaperone would accept
         `argc' arguments (in addition to the original procedure's arity)
         in case the methodness of the original procedure is different
         from the chaperone, or in case the procedures have different names. */
      (void)_scheme_apply_multi(px->prev, argc, argv);
      scheme_signal_error("internal error: unexpected success applying chaperoned/proxied procedure");
      return NULL;
    }
    /* record that argc is ok, on the grounds that the function is likely
       to be applied to argc arguments again */
    SCHEME_VEC_ELS(px->redirects)[1] = scheme_make_integer(argc);
  }

  if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_PROC_CHAPERONE_CALL_DIRECT) {
    if (auto_val)
      return argv[0];
    simple_call = SCHEME_VEC_ELS(px->redirects)[0];
    /* no redirection procedure */
    if (SCHEME_IMMUTABLEP(px->redirects)) {
      /* communicate `self_proc` to the next layer: */
      scheme_current_thread->self_for_proc_chaperone = self_proc;
    }
    if (checks) {
      /* cannot return a tail call */
      MZ_CONT_MARK_POS -= 2;
      if (checks & 0x1) {
        v = _scheme_apply(simple_call, argc, argv);
      } else if (SAME_TYPE(SCHEME_TYPE(simple_call), scheme_native_closure_type)) {
        v = _apply_native(simple_call, argc, argv);
      } else {
        v = _scheme_apply_multi(simple_call, argc, argv);
      }
      MZ_CONT_MARK_POS += 2;
      return v;
    } else
      return _scheme_tail_apply(simple_call, argc, argv);
  }

  if (argv == MZ_RUNSTACK) {
    /* Pushing onto the runstack ensures that `(vector-ref px->redirects 0)' won't
       modify argv. */
    if (MZ_RUNSTACK > MZ_RUNSTACK_START) {
      --MZ_RUNSTACK;
      *MZ_RUNSTACK = NULL;
      need_restore = 1;
    } else {
      /* Can't push! Just allocate a copy. */
      argv2 = MALLOC_N(Scheme_Object *, argc);
      memcpy(argv2, argv, sizeof(Scheme_Object*) * argc);
      argv = argv2;
    }
  }

  app_mark = SCHEME_VEC_ELS(px->redirects)[2];
  if (SCHEME_FALSEP(app_mark))
    app_mark = NULL;

  if (app_mark) {
    v = scheme_chaperone_get_immediate_cc_mark(SCHEME_CAR(app_mark), NULL);
    if (v) {
      scheme_push_continuation_frame(&cframe);
      scheme_set_cont_mark(SCHEME_CAR(app_mark), v);
      MZ_CONT_MARK_POS -= 2;
      need_pop_mark = 1;
    } else
      need_pop_mark = 0;
  } else
    need_pop_mark = 0;

  if (SCHEME_VEC_SIZE(px->redirects) > 3) {
    /* wrapper wants the "self" argument */
    c = argc+1;
    if (c <= MAX_QUICK_CHAP_ARGV)
      argv2 = a2;
    else
      argv2 = MALLOC_N(Scheme_Object *, MAX_QUICK_CHAP_ARGV);
    for (i = 0; i < argc; i++) {
      argv2[i+1] = argv[i];
    }
    argv2[0] = self_proc;
  } else {
    /* wrapper doesn't need the extra "self" argument */
    c = argc;
    argv2 = argv;
  }

  v = SCHEME_VEC_ELS(px->redirects)[0];
  if (SAME_TYPE(SCHEME_TYPE(v), scheme_native_closure_type))
    v = _apply_native(v, c, argv2);
  else
    v = _scheme_apply_multi(v, c, argv2);

  if (v == SCHEME_MULTIPLE_VALUES) {
    GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
    c = p->ku.multiple.count;
    argv2 = p->ku.multiple.array;
    p->ku.multiple.array = NULL;
    if (SAME_OBJ(argv2, p->values_buffer)) {
      if (c <= MAX_QUICK_CHAP_ARGV) {
        for (i = 0; i < c; i++) {
          a2[i] = argv2[i];
        }
        argv2 = a2;
      } else {
        p->values_buffer = NULL;
      }
    }
  } else {
    c = 1;
    a2[0] = v;
    argv2 = a2;
  }

  if (need_pop_mark) {
    MZ_CONT_MARK_POS += 2;
    scheme_pop_continuation_frame(&cframe);
  }

  if (c >= argc) {
    int need_pop = 0;
    post = extract_impersonator_results(c, argc, argv2,
                                        CHAPERONE_KIND_STR(px), o, px,
                                        &cframe, &need_pop);
    need_pop_mark = need_pop;
    
    if (c > argc)
      memmove(argv2, argv2 + (c - argc), sizeof(Scheme_Object*)*argc);
    if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) {
      for (i = 0; i < argc; i++) {
        if (!SAME_OBJ(argv2[i], argv[i])
            && !scheme_chaperone_of(argv2[i], argv[i])) {
          if (argc == 1)
            scheme_wrong_chaperoned("procedure chaperone", "argument", argv[i], argv2[i]);
          else {
            char nbuf[32];
            sprintf(nbuf, "%d%s argument", i, scheme_number_suffix(i));
            scheme_wrong_chaperoned("procedure chaperone", nbuf, argv[i], argv2[i]);
          }
        }
      }
    }
  } else {
    scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
                     "procedure %s: arity mismatch;\n"
                     " expected number of results not received from wrapper on the original\n"
                     " procedure's arguments\n"
                     "  original: %V\n"
                     "  wrapper: %V\n"
                     "  expected: %d or more\n"
                     "  received: %d",
                     CHAPERONE_KIND_STR(px),
                     o,
                     SCHEME_VEC_ELS(px->redirects)[0],
                     argc,
                     c);
    return NULL;
  }

  if (need_restore) {
    /* As a step toward space safety, even clear out the arguments 
       form the runstack: */
    MZ_RUNSTACK++;
    for (i = 0; i < argc; i++) {
      argv[i] = NULL;
    }
  } else
    argv = NULL;

  if (!post) {
    /* No filter for the result, so tail call: */
    if (app_mark)
      scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark));
    if (SCHEME_IMMUTABLEP(px->redirects)) {
      /* commuincate `self_proc` to the next layer: */
      scheme_current_thread->self_for_proc_chaperone = self_proc;
    }
    if (auto_val) {
      if (SCHEME_CHAPERONEP(px->prev))
        return do_apply_chaperone(px->prev, argc, argv2, auto_val, 0);
      else
        return argv2[0];
    } else {
      if (orig_obj)
        /* A raw pair tells apply to extract a procedure from orig_obj */
        orig_obj = scheme_make_raw_pair(px->prev, orig_obj);
      else
        orig_obj = px->prev;
      if (checks) {
        /* cannot return a tail call */
        MZ_CONT_MARK_POS -= 2;
        if (checks & 0x1) {
          v = _scheme_apply(orig_obj, argc, argv2);
        } else if (SAME_TYPE(SCHEME_TYPE(orig_obj), scheme_native_closure_type)) {
          v = _apply_native(orig_obj, argc, argv2);
        } else {
          v = _scheme_apply_multi(orig_obj, argc, argv2);
        }
        MZ_CONT_MARK_POS += 2;
        return v;
      } else
        return scheme_tail_apply(orig_obj, argc, argv2);
    }
  } else {
    if (app_mark) {
      if (!need_pop_mark)
        scheme_push_continuation_frame(&cframe);
      scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark));
      need_pop_mark = 1;
    }else
      need_pop_mark = 0;

    if (need_pop_mark)
      MZ_CONT_MARK_POS -= 2;

    if (SCHEME_IMMUTABLEP(px->redirects)) {
      /* commuincate `self_proc` to the next layer: */
      scheme_current_thread->self_for_proc_chaperone = self_proc;
    }

    if (auto_val) {
      if (SCHEME_CHAPERONEP(px->prev))
        result_v = do_apply_chaperone(px->prev, argc, argv2, auto_val, 0);
      else
        result_v = argv2[0];
      v = auto_val;
    } else {
      if (orig_obj)
        /* A raw pair tells apply to extract a procedure from orig_obj */
        orig_obj = scheme_make_raw_pair(px->prev, orig_obj);
      else
        orig_obj = px->prev;
      if (SAME_TYPE(SCHEME_TYPE(orig_obj), scheme_native_closure_type))
        v = _apply_native(orig_obj, argc, argv2);
      else
        v = _scheme_apply_multi(orig_obj, argc, argv2);
      result_v = NULL;
    }

    if (v == SCHEME_MULTIPLE_VALUES) {
      GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
      if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
        p->values_buffer = NULL;
      c = p->ku.multiple.count;
      argv = p->ku.multiple.array;
      p->ku.multiple.array = NULL;
    } else {
      c = 1;
      a[0] = v;
      argv = a;
    }

    if (need_pop_mark) {
      MZ_CONT_MARK_POS += 2;
      scheme_pop_continuation_frame(&cframe);
    }
    
    if (!scheme_check_proc_arity(NULL, c, 0, -1, &post))
      scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                       "procedure-result %s: arity mismatch;\n"
                       " wrapper does not accept the number of values produced by\n"
                       " the original procedure\n"
                       "  original: %V\n"
                       "  wrapper: %V\n"
                       "  number of values: %d",
                       CHAPERONE_KIND_STR(px),
                       o,
                       post,
                       c);
    
    if (SAME_TYPE(SCHEME_TYPE(post), scheme_native_closure_type))
      v = _apply_native(post, c, argv);
    else
      v = _scheme_apply_multi(post, c, argv);
    if (v == SCHEME_MULTIPLE_VALUES) {
      GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
      if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
        p->values_buffer = NULL;
      argc = p->ku.multiple.count;
      argv2 = p->ku.multiple.array;
      p->ku.multiple.array = NULL;
    } else {
      argc = 1;
      a2[0] = v;
      argv2 = a2;
    }

    if (c == argc) {
      if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) {
        for (i = 0; i < argc; i++) {
          if (!SAME_OBJ(argv2[i], argv[i])
              && !scheme_chaperone_of(argv2[i], argv[i])) {
            if (argc == 1)
              scheme_wrong_chaperoned("procedure-result chaperone", "result", argv[i], argv2[i]);
            else {
              char nbuf[32];
              sprintf(nbuf, "%d%s result", i, scheme_number_suffix(i));
              scheme_wrong_chaperoned("procedure-result chaperone", nbuf, argv[i], argv2[i]);
            }
          }
        }
      }
    } else {
      scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
                       "procedure-result %s: result arity mismatch;\n"
                       " expected number of values not received from wrapper on the original\n"
                       " procedure's result\n"
                       "  original: %V\n"
                       "  wrapper: %V\n"
                       "  expected: %d\n"
                       "  received: %d",
                       CHAPERONE_KIND_STR(px),
                       o,
                       post,
                       c, argc);
      return NULL;
    }

    if (result_v)
      return result_v;
    else if (c == 1)
      return argv2[0];
    else {
      if (checks & 0x1)
        scheme_wrong_return_arity(NULL, 1, c, argv2, NULL);
      return scheme_values(c, argv2);
    }
  }
}

static Scheme_Object *
apply(int argc, Scheme_Object *argv[])
{
  Scheme_Object *rands;
  Scheme_Object **rand_vec;
  int i, num_rands;
  Scheme_Thread *p = scheme_current_thread;

  if (!SCHEME_PROCP(argv[0])) {
    scheme_wrong_contract("apply", "procedure?", 0, argc, argv);
    return NULL;
  }

  rands = argv[argc-1];

  num_rands = scheme_proper_list_length(rands);
  if (num_rands < 0) {
    scheme_wrong_contract("apply", "list?", argc - 1, argc, argv);
    return NULL;
  }
  num_rands += (argc - 2);

  if (num_rands > p->tail_buffer_size) {
    rand_vec = MALLOC_N(Scheme_Object *, num_rands);
    /* num_rands might be very big, so don't install it as the tail buffer */
  } else
    rand_vec = p->tail_buffer;

  for (i = argc - 2; i--; ) {
    rand_vec[i] = argv[i + 1];
  }

  for (i = argc - 2; SCHEME_PAIRP(rands); i++, rands = SCHEME_CDR(rands)) {
    rand_vec[i] = SCHEME_CAR(rands);
  }

  p->ku.apply.tail_rator = argv[0];
  p->ku.apply.tail_rands = rand_vec;
  p->ku.apply.tail_num_rands = num_rands;

  return SCHEME_TAIL_CALL_WAITING;
}

#define DO_MAP map
#define MAP_NAME "map"
#define MAP_MODE
#include "schmap.inc"
#undef MAP_MODE
#undef MAP_NAME
#undef DO_MAP

#define DO_MAP for_each
#define MAP_NAME "for-each"
#define FOR_EACH_MODE
#include "schmap.inc"
#undef FOR_EACH_MODE
#undef MAP_NAME
#undef DO_MAP

#define DO_MAP andmap
#define MAP_NAME "andmap"
#define AND_MODE
#include "schmap.inc"
#undef AND_MODE
#undef MAP_NAME
#undef DO_MAP

#define DO_MAP ormap
#define MAP_NAME "ormap"
#define OR_MODE
#include "schmap.inc"
#undef OR_MODE
#undef MAP_NAME
#undef DO_MAP

static Scheme_Object *call_with_values(int argc, Scheme_Object *argv[])
{
  Scheme_Thread *p;
  Scheme_Object *v;

  scheme_check_proc_arity("call-with-values", 0, 0, argc, argv);
  if (!SCHEME_PROCP(argv[1]))
    scheme_wrong_contract("call-with-values", "procedure?", 1, argc, argv);

  v = _scheme_apply_multi(argv[0], 0, NULL);
  p = scheme_current_thread;
  if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
    int n;
    Scheme_Object **a;
    if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
      p->values_buffer = NULL;
    n = p->ku.multiple.count;
    a = p->ku.multiple.array;
    p->ku.multiple.array = NULL;
    p->ku.apply.tail_num_rands = n;
    p->ku.apply.tail_rands = a;
  } else {
    p->ku.apply.tail_num_rands = 1;
    p->ku.apply.tail_rands = p->tail_buffer;
    p->ku.apply.tail_rands[0] = v;
  }

  p->ku.apply.tail_rator = argv[1];

  return SCHEME_TAIL_CALL_WAITING;
}

static MZ_INLINE Scheme_Object *values_slow(int argc, Scheme_Object *argv[])
{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object **a;
  int i;

  a = MALLOC_N(Scheme_Object *, argc);
  p->values_buffer = a;
  p->values_buffer_size = argc;

  p->ku.multiple.array = a;

  for (i = 0; i < argc; i++) {
    a[i] = argv[i];
  }

  return SCHEME_MULTIPLE_VALUES;
}

Scheme_Object *scheme_values(int argc, Scheme_Object *argv[])
{
  Scheme_Thread *p;
  int i;
  Scheme_Object **a;

  if (argc == 1)
    return argv[0];

  p = scheme_current_thread;
  p->ku.multiple.count = argc;
  if (p->values_buffer && (p->values_buffer_size >= argc)) {
    a = p->values_buffer;
  } else {
    return values_slow(argc, argv);
  }

  p->ku.multiple.array = a;

  for (i = 0; i < argc; i++) {
    a[i] = argv[i];
  }

  return SCHEME_MULTIPLE_VALUES;
}

void scheme_detach_multple_array(Scheme_Object **values)
{
  Scheme_Thread *t = scheme_current_thread;

  if (SAME_OBJ(values, t->values_buffer))
    t->values_buffer = NULL;
}

/*========================================================================*/
/*                             continuations                              */
/*========================================================================*/

static void reset_cjs(Scheme_Continuation_Jump_State *a)
{
  a->jumping_to_continuation = NULL;
  a->alt_full_continuation = NULL;
  a->val = NULL;
  a->num_vals = 0;
  a->is_kill = 0;
  a->is_escape = 0;
  a->skip_dws = 0;
}

void scheme_clear_escape(void)
{
  Scheme_Thread *p = scheme_current_thread;

  reset_cjs(&p->cjs);
  p->suspend_break = 0;
}

static void copy_cjs(Scheme_Continuation_Jump_State *a, Scheme_Continuation_Jump_State *b)
{
  a->jumping_to_continuation = b->jumping_to_continuation;
  a->alt_full_continuation = b->alt_full_continuation;
  a->val = b->val;
  a->num_vals = b->num_vals;
  a->is_kill = b->is_kill;
  a->is_escape = b->is_escape;
  a->skip_dws = b->skip_dws;
}

Scheme_Object *
do_call_ec (int argc, Scheme_Object *argv[], Scheme_Object *_for_cc)
{
  mz_jmp_buf newbuf;
  Scheme_Escaping_Cont * volatile cont;
  Scheme_Thread *p1 = scheme_current_thread;
  Scheme_Object * volatile v;
  Scheme_Object *a[1];
  Scheme_Cont_Frame_Data cframe;
  Scheme_Prompt *barrier_prompt;
  Scheme_Object * volatile for_cc = _for_cc;

  cont = MALLOC_ONE_TAGGED(Scheme_Escaping_Cont);
  cont->so.type = scheme_escaping_cont_type;
  ASSERT_SUSPEND_BREAK_ZERO();

  cont->saveerr = p1->error_buf;
  p1->error_buf = &newbuf;
  cont->myerr = &newbuf;

  scheme_save_env_stack_w_thread(cont->envss, p1);

  barrier_prompt = scheme_get_barrier_prompt(NULL, NULL);
  cont->barrier_prompt = barrier_prompt;

  scheme_prompt_capture_count++;

  if (!for_cc)
    scheme_push_continuation_frame(&cframe);
  scheme_set_cont_mark((Scheme_Object *)cont, scheme_true);

  if (scheme_setjmp(newbuf)) {
    Scheme_Thread *p2 = scheme_current_thread;
    if (p2->cjs.jumping_to_continuation
	&& SAME_OBJ(p2->cjs.jumping_to_continuation, (Scheme_Object *)cont)) {
      Scheme_Object *alt_cont;
      int n;

      alt_cont = p2->cjs.alt_full_continuation;
      if (alt_cont && !((Scheme_Cont *)alt_cont)->orig_escape_cont) {
        /* The escape continuation does not exactly match the target
           continuation; the fll continuation was just re-using an
           existing escape continuation. Now that there's no barrier
           in the way, jump to the full continuation. */
        return jump_to_alt_continuation();
      }

      n = p2->cjs.num_vals;
      v = p2->cjs.val;
      reset_cjs(&p2->cjs);
      scheme_restore_env_stack_w_thread(cont->envss, p2);
      p2->suspend_break = 0;
      scheme_check_break_now();
      if (n != 1)
        v = scheme_values(n, (Scheme_Object **)v);
      else if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_thunk_for_continue_type))
        v = _scheme_apply_multi(SCHEME_PTR_VAL(v), 0, NULL);
    } else {
      scheme_longjmp(*cont->saveerr, 1);
    }
  } else if (for_cc) {
    ((Scheme_Cont *)for_cc)->escape_cont = (Scheme_Object *)cont;
    ((Scheme_Cont *)for_cc)->orig_escape_cont = 1;
    a[0] = (Scheme_Object *)for_cc;
    MZ_CONT_MARK_POS -= 2;
    v = _scheme_apply_multi(argv[0], 1, a);
    MZ_CONT_MARK_POS += 2;
  } else {
    a[0] = (Scheme_Object *)cont;
    v = _scheme_apply_multi(argv[0], 1, a);
  }

  p1 = scheme_current_thread;

  p1->error_buf = cont->saveerr;
  if (!for_cc)
    scheme_pop_continuation_frame(&cframe);

  return v;
}

Scheme_Object *
scheme_call_ec (int argc, Scheme_Object *argv[])
{
  scheme_check_proc_arity("call-with-escape-continuation", 1,
			  0, argc, argv);

  return do_call_ec(argc, argv, NULL);
}

int scheme_escape_continuation_ok(Scheme_Object *ec)
{
  Scheme_Escaping_Cont *cont = (Scheme_Escaping_Cont *)ec;

  if (scheme_extract_one_cc_mark(NULL, (Scheme_Object *)cont))
    return 1;
  else
    return 0;
}

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

  if (argc && !SCHEME_SYMBOLP(argv[0]))
    scheme_wrong_contract("make-continuation-mark-key", "symbol?", 0, argc, argv);

  o = scheme_alloc_small_object();
  o->type = scheme_continuation_mark_key_type;
  SCHEME_PTR_VAL(o) = (argc ? argv[0] : NULL);

  return o;
}

static Scheme_Object *continuation_mark_key_p (int argc, Scheme_Object *argv[])
{
  return (SCHEME_CHAPERONE_CONTINUATION_MARK_KEYP(argv[0])
          ? scheme_true
          : scheme_false);
}

Scheme_Object *scheme_chaperone_do_continuation_mark (const char *name, int is_get, Scheme_Object *key, Scheme_Object *val)
{
  Scheme_Chaperone *px;
  Scheme_Object *proc;
  Scheme_Object *a[1];

  while (1) {
    if (SCHEME_CONTINUATION_MARK_KEYP(key)) {
      return val;
    } else {
      px = (Scheme_Chaperone *)key;
      key = px->prev;

      if (is_get)
        proc = SCHEME_CAR(px->redirects);
      else
        proc = SCHEME_CDR(px->redirects);

      a[0] = val;
      val = _scheme_apply(proc, 1, a);

      if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) {
        if (!scheme_chaperone_of(val, a[0]))
          scheme_wrong_chaperoned(name, "value", a[0], val);
      }
    }
  }
}

Scheme_Object *do_chaperone_continuation_mark_key (const char *name, int is_impersonator, int argc, Scheme_Object **argv)
{
  Scheme_Chaperone *px;
  Scheme_Object *val = argv[0];
  Scheme_Object *redirects;
  Scheme_Object *props;

  if (SCHEME_CHAPERONEP(val))
    val = SCHEME_CHAPERONE_VAL(val);

  if (!SCHEME_CONTINUATION_MARK_KEYP(val))
    scheme_wrong_contract(name, "continuation-mark-key?", 0, argc, argv);

  scheme_check_proc_arity(name, 1, 1, argc, argv);
  scheme_check_proc_arity(name, 1, 2, argc, argv);

  redirects = scheme_make_pair(argv[1], argv[2]);

  props = scheme_parse_chaperone_props(name, 3, argc, argv);

  px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
  px->iso.so.type = scheme_chaperone_type;
  px->val = val;
  px->prev = argv[0];
  px->props = props;
  px->redirects = redirects;

  if (is_impersonator)
    SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;

  return (Scheme_Object *)px;
}

static Scheme_Object *chaperone_continuation_mark_key(int argc, Scheme_Object **argv)
{
  return do_chaperone_continuation_mark_key("chaperone-continuation-mark-key", 0, argc, argv);
}

static Scheme_Object *impersonate_continuation_mark_key(int argc, Scheme_Object **argv)
{
  return do_chaperone_continuation_mark_key("impersonate-continuation-mark-key", 1, argc, argv);
}

Scheme_Object *scheme_get_immediate_cc_mark(Scheme_Object *key, Scheme_Object *def_val)
{
  Scheme_Thread *p = scheme_current_thread;
  intptr_t findpos, bottom;

  if (p->cont_mark_stack_segments) {
    findpos = (intptr_t)MZ_CONT_MARK_STACK;
    bottom = (intptr_t)p->cont_mark_stack_bottom;
    while (findpos-- > bottom) {
      Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
      intptr_t pos = findpos & SCHEME_MARK_SEGMENT_MASK;
      Scheme_Cont_Mark *find = seg + pos;

      if ((intptr_t)find->pos < (intptr_t)MZ_CONT_MARK_POS) {
        break;
      } else {
        if (find->key == key)
          return find->val;
      }
    }
  }

  return def_val;
}

Scheme_Object *scheme_chaperone_get_immediate_cc_mark(Scheme_Object *key, Scheme_Object *def_val)
{
  Scheme_Object *val;

  if (SCHEME_NP_CHAPERONEP(key)
      && SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(key))) {
    val = scheme_get_immediate_cc_mark(SCHEME_CHAPERONE_VAL(key), NULL);
    if (val)
      return scheme_chaperone_do_continuation_mark("call-with-immediate-continuation-mark",
                                                   1, key, val);
    else
      return def_val;
  } else
    return scheme_get_immediate_cc_mark(key, def_val);
}

static Scheme_Object *call_with_immediate_cc_mark (int argc, Scheme_Object *argv[])
{
  Scheme_Object *a[1], *val;

  scheme_check_proc_arity("call-with-immediate-continuation-mark", 1, 1, argc, argv);

  val = scheme_chaperone_get_immediate_cc_mark(argv[0], ((argc > 2) ? argv[2] : scheme_false));
  a[0] = val;

  return scheme_tail_apply(argv[1], 1, a);
}

static Scheme_Object *
do_call_with_sema(const char *who, int enable_break, int argc, Scheme_Object *argv[])
{
  mz_jmp_buf newbuf, * volatile savebuf;
  Scheme_Prompt * volatile prompt;
  int i, just_try;
  int volatile extra;
  Scheme_Object * volatile sema;
  Scheme_Object *v, *quick_args[4], **extra_args;
  Scheme_Cont_Frame_Data cframe;
  int old_pcc = scheme_prompt_capture_count;

  if (!SCHEME_SEMAP(argv[0])) {
    scheme_wrong_contract(who, "semaphore?", 0, argc, argv);
    return NULL;
  }
  if (argc > 2)
    extra = argc - 3;
  else
    extra = 0;
  if (!scheme_check_proc_arity(NULL, extra, 1, argc, argv)) {
    if (!SCHEME_PROCP(argv[1]))
      scheme_wrong_contract(who, "procedure?", 1, argc, argv);
    else
      scheme_contract_error(who, "procedure arity does not match extra-argument count",
                            "procedure", 1, argv[1],
                            "extra-argument count", 1, scheme_make_integer(extra),
                            NULL);
    return NULL;
  }
  if ((argc > 2) && SCHEME_TRUEP(argv[2])) {
    if (!scheme_check_proc_arity(NULL, 0, 2, argc, argv)) {
      scheme_wrong_contract(who, "(or/c (-> any) #f)", 1, argc, argv);
      return NULL;
    }
    just_try = 1;
  } else
    just_try = 0;

  sema = argv[0];

  if (just_try && enable_break && scheme_current_thread->external_break) {
    /* Check for a break before polling the semaphore */
    Scheme_Cont_Frame_Data bcframe;
    scheme_push_break_enable(&bcframe, 1, 1);
    scheme_check_break_now();
    scheme_pop_break_enable(&bcframe, 0);
  }

  if (!scheme_wait_sema(sema, just_try ? 1 : (enable_break ? -1 : 0))) {
    return _scheme_tail_apply(argv[2], 0, NULL);
  }

  savebuf = scheme_current_thread->error_buf;
  scheme_current_thread->error_buf = &newbuf;

  if (available_cws_prompt) {
    prompt = available_cws_prompt;
    available_cws_prompt = NULL;
  } else {
    prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
    prompt->so.type = scheme_prompt_type;
  }

  scheme_push_continuation_frame(&cframe);
  scheme_set_cont_mark(barrier_prompt_key, (Scheme_Object *)prompt);

  if (scheme_setjmp(newbuf)) {
    v = NULL;
  } else {
    if (extra > 4)
      extra_args = MALLOC_N(Scheme_Object *, extra);
    else
      extra_args = quick_args;
    for (i = 3; i < argc; i++) {
      extra_args[i - 3] = argv[i];
    }

    v = _scheme_apply_multi(argv[1], extra, extra_args);
  }

  scheme_pop_continuation_frame(&cframe);

  scheme_post_sema(sema); /* FIXME: what if we reach the max count? */

  if (old_pcc != scheme_prompt_capture_count)
    available_cws_prompt = prompt;

  if (!v)
    scheme_longjmp(*savebuf, 1);

  scheme_current_thread->error_buf = savebuf;

  return v;
}

static Scheme_Object *
call_with_sema(int argc, Scheme_Object *argv[])
{
  return do_call_with_sema("call-with-semaphore", 0, argc, argv);
}

static Scheme_Object *
call_with_sema_enable_break(int argc, Scheme_Object *argv[])
{
  return do_call_with_sema("call-with-semaphore/enable-break", 1, argc, argv);
}

static Scheme_Saved_Stack *copy_out_runstack(Scheme_Thread *p,
					     Scheme_Object **runstack,
					     Scheme_Object **runstack_start,
					     Scheme_Cont *share_from,
					     Scheme_Prompt *effective_prompt)
{
  Scheme_Saved_Stack *saved, *isaved, *csaved, *share_saved, *share_csaved, *ss;
  Scheme_Object **start;
  intptr_t size;
  int done;

  /* Copy out current runstack: */
  saved = MALLOC_ONE_RT(Scheme_Saved_Stack);
#ifdef MZTAG_REQUIRED
  saved->type = scheme_rt_saved_stack;
#endif
  if (share_from && (share_from->runstack_start == runstack_start)) {
    intptr_t shared_amt;
    /* Copy just the difference between share_from's runstack and current runstack... */
    size = (share_from->ss.runstack_offset - (runstack XFORM_OK_MINUS runstack_start));
    /* But skip the first few items, which are potentially call/cc's arguments: */
    shared_amt = (p->runstack_size - share_from->ss.runstack_offset);
    if (shared_amt > MAX_CALL_CC_ARG_COUNT)
      size += MAX_CALL_CC_ARG_COUNT;
    else
      size += shared_amt;
  } else if (effective_prompt && (scheme_prompt_runstack_boundary_start(effective_prompt) == runstack_start)) {
    /* Copy only up to the prompt */
    size = effective_prompt->runstack_boundary_offset - (runstack XFORM_OK_MINUS runstack_start);
  } else {
    size = p->runstack_size - (runstack XFORM_OK_MINUS runstack_start);
  }

  MZ_ASSERT(size <= p->runstack_size);

  saved->runstack_size = size;
  start = MALLOC_N(Scheme_Object*, size);
  saved->runstack_start = start;
  memcpy(saved->runstack_start, runstack, size * sizeof(Scheme_Object *));
  saved->runstack_offset = (runstack XFORM_OK_MINUS runstack_start);

  if (!effective_prompt || (scheme_prompt_runstack_boundary_start(effective_prompt) != runstack_start)) {

    /* Copy saved runstacks: */
    if (share_from) {
      /* We can share all saved runstacks */
      share_csaved = share_from->runstack_saved;
      share_saved = share_from->runstack_copied->prev;
    } else {
      share_saved = NULL;
      share_csaved = NULL;
    }
    isaved = saved;
    for (csaved = p->runstack_saved; csaved; csaved = csaved->prev) {
      if (share_csaved && (csaved->runstack_start == share_csaved->runstack_start)) {
	/* Share */
	isaved->prev = share_saved;
	break;
      }
    
      ss = MALLOC_ONE_RT(Scheme_Saved_Stack);
#ifdef MZTAG_REQUIRED
      ss->type = scheme_rt_saved_stack;
#endif
      isaved->prev = ss;
      isaved = ss;

      if (effective_prompt && (scheme_prompt_runstack_boundary_start(effective_prompt) == csaved->runstack_start)) {
	size = effective_prompt->runstack_boundary_offset - csaved->runstack_offset;
	done = 1;
      } else {
	size = csaved->runstack_size - csaved->runstack_offset;
	done = 0;
      }

      isaved->runstack_size = size;
      
      start = MALLOC_N(Scheme_Object*, size);
      isaved->runstack_start = start;
      memcpy(isaved->runstack_start, 
	     csaved->runstack_start XFORM_OK_PLUS csaved->runstack_offset, 
	     size * sizeof(Scheme_Object *));
      isaved->runstack_offset = csaved->runstack_offset;

      if (done) break;
    }
  }

  return saved;
}

static Scheme_Cont_Mark *copy_out_mark_stack(Scheme_Thread *p, 
					     MZ_MARK_STACK_TYPE pos,
					     Scheme_Cont *sub_cont,
					     intptr_t *_offset,
					     Scheme_Prompt *effective_prompt,
                                             int clear_caches)
{
  intptr_t cmcount, offset = 0, sub_count = 0;
  Scheme_Cont_Mark *cont_mark_stack_copied;

  /* Copy cont mark stack: */
  cmcount = (intptr_t)pos;
  offset = 0;

  if (sub_cont) {
    /* Rely on copy of marks in a tail of this continuation. */
    sub_count = sub_cont->cont_mark_total - sub_cont->cont_mark_nonshare;
    if (sub_count < 0)
      sub_count = 0;
  } else if (effective_prompt) {
    /* Copy only marks since the prompt. */
    sub_count = effective_prompt->mark_boundary;
  }
  cmcount -= sub_count;
  offset += sub_count; 

  if (_offset) *_offset = offset;

  if (cmcount) {
    cont_mark_stack_copied = MALLOC_N(Scheme_Cont_Mark, cmcount);
    while (cmcount--) {
      int cms = cmcount + offset;
      Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[cms >> SCHEME_LOG_MARK_SEGMENT_SIZE];
      intptr_t pos = cms & SCHEME_MARK_SEGMENT_MASK;
      Scheme_Cont_Mark *cm = seg + pos;
      
      memcpy(cont_mark_stack_copied + cmcount, cm, sizeof(Scheme_Cont_Mark));
      if (clear_caches)
        cont_mark_stack_copied[cmcount].cache = NULL;
    }
    
    return cont_mark_stack_copied;
  } else
    return NULL;
}

static void copy_in_runstack(Scheme_Thread *p, Scheme_Saved_Stack *isaved, int set_runstack)
{
  Scheme_Saved_Stack *csaved;
  intptr_t size;

  size = isaved->runstack_size;
  if (set_runstack) {
    MZ_RUNSTACK = MZ_RUNSTACK_START + (p->runstack_size - size);
  }
  memcpy(MZ_RUNSTACK, isaved->runstack_start, size * sizeof(Scheme_Object *));
  for (csaved = p->runstack_saved; csaved; csaved = csaved->prev) {
    isaved = isaved->prev;
    if (!isaved) {
      /* The saved stack can be shorter than the current stack if
         there's a barrier prompt, or if we're in shortcut mode. */
      break;
    }
    size = isaved->runstack_size;
    csaved->runstack_offset = isaved->runstack_offset;
    memcpy(csaved->runstack_start XFORM_OK_PLUS csaved->runstack_offset, 
	   isaved->runstack_start, 
	   size * sizeof(Scheme_Object *));
  }
}

static void copy_in_mark_stack(Scheme_Thread *p, Scheme_Cont_Mark *cont_mark_stack_copied,
			       MZ_MARK_STACK_TYPE cms, MZ_MARK_STACK_TYPE base_cms,
			       intptr_t copied_offset, Scheme_Object **_sub_conts,
                               int clear_caches,
                               MZ_MARK_POS_TYPE new_mark_pos)
     /* Copies in the mark stack up to depth cms, but assumes that the
	stack up to depth base_cms is already in place (probably in
	place for a dynamic-wind context in an continuation
	restoration.) */
{
  intptr_t cmcount, base_cmcount, cmoffset;
  Scheme_Cont_Mark *cm_src;
  Scheme_Cont *sub_cont = NULL;

  cmcount = (intptr_t)cms;
  base_cmcount = (intptr_t)base_cms;

  if (cmcount) {
    /* First, make sure we have enough segments */
    intptr_t needed = ((cmcount - 1) >> SCHEME_LOG_MARK_SEGMENT_SIZE) + 1;

    if (needed > p->cont_mark_seg_count) {
      Scheme_Cont_Mark **segs, **old_segs = p->cont_mark_stack_segments;
      int newcount = needed, oldcount = p->cont_mark_seg_count, npos;

      /* Note: we perform allocations before changing p to avoid GC trouble,
	 since Racket adjusts a thread's cont_mark_stack_segments on GC. */
      segs = MALLOC_N(Scheme_Cont_Mark *, needed);

      for (npos = needed; npos--; ) {
	if (npos < oldcount)
	  segs[npos] = old_segs[npos]; /* might be NULL due to GC! */
	else
	  segs[npos] = NULL;

	if (!segs[npos]) {
	  Scheme_Cont_Mark *cm;
	  cm = scheme_malloc_allow_interior(sizeof(Scheme_Cont_Mark) * SCHEME_MARK_SEGMENT_SIZE);
	  segs[npos] = cm;
	}
      }

      p->cont_mark_seg_count = newcount;
      p->cont_mark_stack_segments = segs;
    }
  }

  /* Updated after potential GC: */
  MZ_CONT_MARK_POS = new_mark_pos;
  MZ_CONT_MARK_STACK = cms;

  if (_sub_conts) {
    if (*_sub_conts) {
      sub_cont = (Scheme_Cont *)SCHEME_CAR(*_sub_conts);
    }
  }

  while (base_cmcount < cmcount) {
    Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[base_cmcount >> SCHEME_LOG_MARK_SEGMENT_SIZE];
    intptr_t pos = base_cmcount & SCHEME_MARK_SEGMENT_MASK;
    GC_CAN_IGNORE Scheme_Cont_Mark *cm = seg + pos;
    
    cm_src = cont_mark_stack_copied;
    cmoffset = base_cmcount - copied_offset;

    if (sub_cont) {
      while (base_cmcount >= (sub_cont->cont_mark_total - sub_cont->cont_mark_nonshare)) {
	*_sub_conts = SCHEME_CDR(*_sub_conts);
	if (*_sub_conts) {
	  sub_cont = (Scheme_Cont *)SCHEME_CAR(*_sub_conts);
	} else {
	  sub_cont = NULL;
	  break;
	}
      }
      if (sub_cont) {
	cm_src = sub_cont->cont_mark_stack_copied;
	cmoffset = base_cmcount - sub_cont->cont_mark_offset;
      }
    }

    memcpy(cm, cm_src + cmoffset, sizeof(Scheme_Cont_Mark));
    if (clear_caches) {
      cm->cache = NULL;
    }

    base_cmcount++;
  }
}

static MZ_MARK_STACK_TYPE find_shareable_marks()
{
  Scheme_Thread *p = scheme_current_thread;
  intptr_t cmcount, delta = 0;

  cmcount = (intptr_t)MZ_CONT_MARK_STACK;

  while (cmcount--) {
    Scheme_Cont_Mark *seg = p->cont_mark_stack_segments[cmcount >> SCHEME_LOG_MARK_SEGMENT_SIZE];
    intptr_t pos = cmcount & SCHEME_MARK_SEGMENT_MASK;

    if (seg[pos].pos < MZ_CONT_MARK_POS)
      break;

    /* If a key is cont_key or scheme_stack_dump_key, then treat it
       as sharable, because we don't mind if a new continuation gets
       the old value. */
    if (SAME_OBJ(seg[pos].key, cont_key))
      delta++;
    else if (SAME_OBJ(seg[pos].key, scheme_stack_dump_key))
      delta++;
    else
      delta = 0;
  }

  return cmcount + 1 + delta;
}

static Scheme_Overflow *clone_overflows(Scheme_Overflow *overflow, void *limit, Scheme_Overflow *tail)
{
  Scheme_Overflow *naya, *first = NULL, *prev = NULL;
  int stop = 0;

  for (; overflow && !stop; overflow = overflow->prev) {
    naya = MALLOC_ONE_RT(Scheme_Overflow);
    memcpy(naya, overflow, sizeof(Scheme_Overflow));
    if (prev)
      prev->prev = naya;
    else
      first = naya;
    prev = naya;
    if (limit && overflow->id == limit)
      stop = 1;
  }

  if (first) {
    prev->prev = tail;
    return first;
  } else
    return tail;
}

static Scheme_Dynamic_Wind *clone_dyn_wind(Scheme_Dynamic_Wind *dw, 
                                           Scheme_Object *limit_prompt_tag, int limit_depth, int limit_count,
                                           Scheme_Dynamic_Wind *tail, 
                                           int keep_tail, int composable)
{
  Scheme_Dynamic_Wind *naya, *first = NULL, *prev = NULL;
  int cnt = 0;

  for (; dw; dw = dw->prev) {
    if (dw->depth == limit_depth)
      break;
    if (composable && limit_prompt_tag && (dw->prompt_tag == limit_prompt_tag))
      break;
    if (cnt == limit_count)
      break;
    scheme_ensure_dw_id(dw);
    naya = MALLOC_ONE_RT(Scheme_Dynamic_Wind);
    memcpy(naya, dw, sizeof(Scheme_Dynamic_Wind));
    if (prev)
      prev->prev = naya;
    else
      first = naya;
    prev = naya;
    cnt++;
    if (limit_prompt_tag && (dw->prompt_tag == limit_prompt_tag)) {
      dw = dw->prev; /* in case keep_tail is true */
      break;
    }
  }
  if (keep_tail)
    tail = dw;
  if (first) {
    prev->prev = tail;
    if (tail)
      cnt += tail->depth + 1;
    for (dw = first; dw != tail; dw = dw->prev) {
      dw->depth = --cnt;
    }
    return first;
  } else
    return tail;
}

static void clear_cm_copy_caches(Scheme_Cont_Mark *cp, int cnt)
{
  int i;
  for (i = 0; i < cnt; i++) {
    cp[i].cache = NULL;
  }
}

static Scheme_Saved_Stack *clone_runstack_saved(Scheme_Saved_Stack *saved, Scheme_Object **boundary_start,
                                                Scheme_Saved_Stack *last)
{
  Scheme_Saved_Stack *naya, *first = last, *prev = NULL;

  while (saved) {
    naya = MALLOC_ONE_RT(Scheme_Saved_Stack);
    memcpy(naya, saved, sizeof(Scheme_Saved_Stack));
    if (prev)
      prev->prev = naya;
    else
      first = naya;
    prev = naya;
    if (saved->runstack_start == boundary_start)
      break;
    saved = saved->prev;
  }
  if (prev)
    prev->prev = last;
  
  return first;
}

static Scheme_Saved_Stack *clone_runstack_copied(Scheme_Saved_Stack *copied, 
                                                 Scheme_Object **copied_start,
                                                 Scheme_Saved_Stack *saved, 
                                                 Scheme_Object **boundary_start,
                                                 intptr_t boundary_offset)
{
  Scheme_Saved_Stack *naya, *first = NULL, *prev = NULL, *s;

  if (copied_start == boundary_start) {
    naya = copied;
  } else {
    for (naya = copied->prev, s = saved; 
         s->runstack_start != boundary_start; 
         naya = naya->prev, s = s->prev) {
    }
  }
  if ((naya->runstack_offset + naya->runstack_size == boundary_offset)
      && !naya->prev) {
    /* no need to prune anything */
    return copied;
  }

  s = NULL;
  while (copied) {
    naya = MALLOC_ONE_RT(Scheme_Saved_Stack);
    memcpy(naya, copied, sizeof(Scheme_Saved_Stack));
    naya->prev = NULL;
    if (prev)
      prev->prev = naya;
    else
      first = naya;
    prev = naya;
    if ((!s && copied_start == boundary_start)
        || (s && (s->runstack_start == boundary_start))) {
      intptr_t size;
      Scheme_Object **a;
      size = boundary_offset - naya->runstack_offset;
      if (size < 0)
        scheme_signal_error("negative stack-copy size while pruning");
      if (size > naya->runstack_size)
        scheme_signal_error("bigger stack-copy size while pruning: %d vs. %d", size, naya->runstack_size);
      a = MALLOC_N(Scheme_Object *, size);
      memcpy(a, naya->runstack_start, size * sizeof(Scheme_Object *));
      naya->runstack_start = a;
      naya->runstack_size = size;
      break;
    }

    copied = copied->prev;
    if (!s)
      s = saved;
    else
      s = s->prev;
  }
  
  return first;
}

static Scheme_Meta_Continuation *clone_meta_cont(Scheme_Meta_Continuation *mc,
                                                 Scheme_Object *limit_tag, int limit_depth,
                                                 Scheme_Meta_Continuation *prompt_cont,
                                                 Scheme_Prompt *prompt,
                                                 Scheme_Meta_Continuation *tail,
                                                 int for_composable)
{
  Scheme_Meta_Continuation *naya, *first = NULL, *prev = NULL;
  int cnt = 0, depth;

  for (; mc; mc = mc->next) {
    if (!limit_depth--)
      break;
    if (!mc->pseudo && SAME_OBJ(mc->prompt_tag, limit_tag))
      break;
    if (for_composable && mc->pseudo && mc->empty_to_next && mc->next
        && SAME_OBJ(mc->next->prompt_tag, limit_tag)) {
      /* We don't need to keep the compose-introduced
         meta-continuation, because it represents an empty
         continuation relative to the prompt. */
      break;
    }
    
    naya = MALLOC_ONE_RT(Scheme_Meta_Continuation);
    cnt++;
    memcpy(naya, mc, sizeof(Scheme_Meta_Continuation));
    if (SAME_OBJ(mc, prompt_cont)) {
      /* Need only part of this meta-continuation's marks. */
      intptr_t delta;
      void *stack_boundary;

      delta = prompt->mark_boundary - naya->cont_mark_offset;
      if (delta) {
        naya->cont_mark_total -= delta;
        naya->cont_mark_offset += delta;
        if (naya->cont_mark_total) {
          Scheme_Cont_Mark *cp;
          cp = MALLOC_N(Scheme_Cont_Mark, naya->cont_mark_total);
          memcpy(cp, mc->cont_mark_stack_copied + delta, naya->cont_mark_total * sizeof(Scheme_Cont_Mark));
          if (mc->cm_caches) {
            clear_cm_copy_caches(cp, naya->cont_mark_total);
          }
          naya->cont_mark_stack_copied = cp;
          naya->cm_caches = 0;
          naya->cm_shared = 0;
        } else
          naya->cont_mark_stack_copied = NULL;
      }
      naya->cont_mark_pos_bottom = prompt->boundary_mark_pos;

      if ((prompt->boundary_overflow_id && (prompt->boundary_overflow_id == naya->overflow->id))
          || (!prompt->boundary_overflow_id && !naya->overflow->prev)) {
        stack_boundary = prompt->stack_boundary;
      } else {
        stack_boundary = naya->overflow->stack_start;
      }

      if (naya->cont) {
        Scheme_Cont *cnaya;
        Scheme_Saved_Stack *saved;

        cnaya = MALLOC_ONE_TAGGED(Scheme_Cont);
        memcpy(cnaya, naya->cont, sizeof(Scheme_Cont));

        naya->cont = cnaya;

        cnaya->cont_mark_total = naya->cont_mark_total;
        cnaya->cont_mark_offset = naya->cont_mark_offset;
        cnaya->cont_mark_pos_bottom = naya->cont_mark_pos_bottom;
        cnaya->cont_mark_stack_copied = naya->cont_mark_stack_copied;

        cnaya->prompt_stack_start = stack_boundary;

        /* Prune unneeded runstack data */
        saved = clone_runstack_copied(cnaya->runstack_copied, 
                                      cnaya->runstack_start,
                                      cnaya->runstack_saved, 
                                      scheme_prompt_runstack_boundary_start(prompt),
                                      prompt->runstack_boundary_offset);
        cnaya->runstack_copied = saved;

        /* Prune unneeded buffers */
        if (scheme_prompt_runstack_boundary_start(prompt) == cnaya->runstack_start)
          saved = NULL;
        else
          saved = clone_runstack_saved(cnaya->runstack_saved, 
                                       scheme_prompt_runstack_boundary_start(prompt),
                                       NULL);
        cnaya->runstack_saved = saved;

        cnaya->need_meta_prompt = 1;
      }
      if (naya->overflow && !naya->overflow->eot) {
        /* Prune unneeded C-stack data */
        Scheme_Overflow *onaya;
        Scheme_Overflow_Jmp *jmp;
        jmp = scheme_prune_jmpup(naya->overflow->jmp, stack_boundary);
        if (jmp) {
          onaya = MALLOC_ONE_RT(Scheme_Overflow);
          memcpy(onaya, naya->overflow, sizeof(Scheme_Overflow));
          naya->overflow = onaya;
          onaya->jmp = jmp;
          onaya->stack_start = stack_boundary;
        }
      }
    } else {
      if (!mc->cm_caches) {
        mc->cm_shared = 1;
        naya->cm_shared = 1;
      } else {
        Scheme_Cont_Mark *cp;
        cp = MALLOC_N(Scheme_Cont_Mark, naya->cont_mark_total);
        if (naya->cont_mark_total)
          memcpy(cp, mc->cont_mark_stack_copied, naya->cont_mark_total * sizeof(Scheme_Cont_Mark));
        clear_cm_copy_caches(cp, naya->cont_mark_total);
        naya->cont_mark_stack_copied = cp;
        naya->cm_caches = 0;
        naya->cm_shared = 0;
      }
    }
    if (prev)
      prev->next = naya;
    else
      first = naya;
    prev = naya;
  }

  if (first) {
    prev->next = tail;
  } else
    first = tail;

  /* Set depth for newly prefixed meta-conts: */
  if (tail)
    depth = tail->depth + 1;
  else
    depth = 0;
  for (naya = first; cnt--; naya = naya->next) {
    naya->depth = depth + cnt;
  }

  return first;
}

static void sync_meta_cont(Scheme_Meta_Continuation *resume_mc)
{
  Scheme_Cont *cnaya;

  if (!resume_mc->cont)
    return;

  cnaya = MALLOC_ONE_TAGGED(Scheme_Cont);
  memcpy(cnaya, resume_mc->cont, sizeof(Scheme_Cont));
    
  resume_mc->cont = cnaya;
    
  cnaya->ss.cont_mark_stack += (resume_mc->cont_mark_total - cnaya->cont_mark_total);

  cnaya->cont_mark_total = resume_mc->cont_mark_total;
  cnaya->cont_mark_offset = resume_mc->cont_mark_offset;
  cnaya->cont_mark_pos_bottom = resume_mc->cont_mark_pos_bottom;
  cnaya->cont_mark_stack_copied = resume_mc->cont_mark_stack_copied;
}

void prune_cont_marks(Scheme_Meta_Continuation *resume_mc, Scheme_Cont *cont, Scheme_Object *extra_marks)
{
  Scheme_Object *val;
  Scheme_Hash_Table *ht;
  intptr_t pos, num_overlap, num_coverlap, new_overlap, base, i;
  Scheme_Cont_Mark *cp;
  
  for (pos = resume_mc->cont_mark_total, num_overlap = 0;
       pos--;
       num_overlap++) {
    if (resume_mc->cont_mark_stack_copied[pos].pos != resume_mc->cont_mark_pos)
      break;
  }

  if (!num_overlap && (!extra_marks || !SCHEME_VEC_SIZE(extra_marks))) {
    /* No pruning (nothing to prune) or addition needed. */
    return;
  }

  for (pos = 0, num_coverlap = 0;
       pos < cont->cont_mark_total;
       num_coverlap++, pos++) {
    if (cont->cont_mark_stack_copied[pos].pos != (cont->cont_mark_pos_bottom + 2))
      break;
  }

  if (!num_coverlap && (!extra_marks || !SCHEME_VEC_SIZE(extra_marks))) {
    /* No pruning (nothing to compare against) or addition needed. */
    return;
  }

  /* Compute the new set to have in the meta-continuation. */
  ht = scheme_make_hash_table(SCHEME_hash_ptr);
  
  for (pos = resume_mc->cont_mark_total - 1, i = 0; i < num_overlap; i++, pos--) {
    val = resume_mc->cont_mark_stack_copied[pos].val;
    if (!val)
      val = cont_key;
    scheme_hash_set(ht, 
                    resume_mc->cont_mark_stack_copied[pos].key,
                    val);
  }
  if (extra_marks) {
    for (i = 0; i < SCHEME_VEC_SIZE(extra_marks); i += 2) {
      val = SCHEME_VEC_ELS(extra_marks)[i+1];
      if (!val)
        val = cont_key;
      scheme_hash_set(ht, SCHEME_VEC_ELS(extra_marks)[i], val);
    }
  }
  for (pos = 0, i = 0; i < num_coverlap; i++, pos++) {
    scheme_hash_set(ht, 
                    cont->cont_mark_stack_copied[pos].key,
                    NULL);
  }

  new_overlap = ht->count;

  /* Install changes: */
  base = resume_mc->cont_mark_total - num_overlap;
  cp = MALLOC_N(Scheme_Cont_Mark, base + new_overlap);
  memcpy(cp, resume_mc->cont_mark_stack_copied, base * sizeof(Scheme_Cont_Mark));
  resume_mc->cont_mark_stack_copied = cp;
  resume_mc->cont_mark_total = base + new_overlap;
  resume_mc->cm_shared = 0;
  resume_mc->cont_mark_stack += (new_overlap - num_overlap);
  for (i = 0; i < ht->size; i++) {
    if (ht->vals[i]) {
      cp[base].key = ht->keys[i];
      val = ht->vals[i];
      if (SAME_OBJ(val, cont_key))
        val = NULL;
      cp[base].val = val;
      cp[base].pos = resume_mc->cont_mark_pos;
      cp[base].cache = NULL;
      base++;
    }
  }

  sync_meta_cont(resume_mc);
}

static MZ_MARK_STACK_TYPE exec_dyn_wind_pres(Scheme_Dynamic_Wind_List *dwl,
                                             int dwl_len,
                                             Scheme_Cont *cont,
                                             MZ_MARK_STACK_TYPE copied_cms,
                                             int clear_cm_caches,
                                             Scheme_Object **_sub_conts,
                                             int skip_dws)
{
  Scheme_Thread *p = scheme_current_thread;
  int old_cac = scheme_continuation_application_count;
  int need_clone = 0;
  Scheme_Dynamic_Wind *dw;

  for (; dwl; dwl = dwl->next) {
    if (dwl->dw->pre) {
      p->next_meta = dwl->meta_depth + dwl->dw->next_meta;
      if (dwl->meta_depth > 0) {
        if (!skip_dws)
          scheme_apply_dw_in_meta(dwl->dw, 0, dwl->meta_depth, cont);
      } else {
        /* Restore the needed part of the mark stack for this
           dynamic-wind context. Clear cached info on restore
           if there's a prompt. */
        DW_PrePost_Proc pre = dwl->dw->pre;
        copy_in_mark_stack(p, cont->cont_mark_stack_copied, 
                           dwl->dw->envss.cont_mark_stack, copied_cms,
                           cont->cont_mark_offset, _sub_conts,
                           clear_cm_caches,
                           dwl->dw->envss.cont_mark_pos);
        copied_cms = MZ_CONT_MARK_STACK;

        if (!skip_dws)
          pre(dwl->dw->data);

        if (!cont->composable) {
          if (scheme_continuation_application_count != old_cac) {
            old_cac = scheme_continuation_application_count;
            scheme_recheck_prompt_and_barrier(cont);
          }
        }
      }
      p = scheme_current_thread;
    }

    if (p->dw != dwl->dw->prev) {
      /* something happened in the pre-thunk to change the
         continuation that we're building */
      need_clone = 1;
    }
    
    if (need_clone) {
      dw = clone_dyn_wind(dwl->dw, NULL, -1, 1, p->dw, 0, 0);
      dw->next_meta = p->next_meta;
    } else
      dw = dwl->dw;
    p->dw = dw;
  }
  return copied_cms;
}

static void root_prompt_tag_misuse(const char *who)
{
  scheme_signal_error("%s: misuse of root prompt tag", who);
}

static Scheme_Object *
call_cc (int argc, Scheme_Object *argv[])
{
  scheme_check_proc_arity("call-with-current-continuation", 1,
			  0, argc, argv);
  if (argc > 1) {
    if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[1]))
        && !((SCHEME_NP_CHAPERONEP(argv[1])
              && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[1])))))
      scheme_wrong_contract("call-with-current-continuation", "continuation-prompt-tag?",
                            1, argc, argv);
  }

  /* Trampoline to internal_call_cc. This trampoline ensures that
     the runstack is flushed before we try to grab the continuation. */
  return _scheme_tail_apply(internal_call_cc_prim, argc, argv);
}

static Scheme_Cont *grab_continuation(Scheme_Thread *p, int for_prompt, int composable,
                                      Scheme_Object *prompt_tag, Scheme_Object *pt,
                                      Scheme_Cont *sub_cont, Scheme_Prompt *prompt,
                                      Scheme_Meta_Continuation *prompt_cont,
                                      Scheme_Prompt *effective_barrier_prompt,
                                      int cm_only,
                                      int argc, Scheme_Object **argv)
{
  Scheme_Cont *cont;
  Scheme_Cont_Jmp *buf_ptr;
  
  cont = MALLOC_ONE_TAGGED(Scheme_Cont);
  cont->so.type = scheme_cont_type;

  if (!for_prompt && !composable && !cm_only) {
    /* Set cont_key mark before capturing marks: */
    scheme_set_cont_mark(cont_key, (Scheme_Object *)cont);
  }

  if (composable)
    cont->composable = 1;
  
  buf_ptr = MALLOC_ONE_RT(Scheme_Cont_Jmp);
  SET_REQUIRED_TAG(buf_ptr->type = scheme_rt_cont_jmp);
  cont->buf_ptr = buf_ptr;

  if (!cm_only) {
    scheme_init_jmpup_buf(&cont->buf_ptr->buf);
    cont->prompt_tag = prompt_tag;
    if (for_prompt)
      cont->dw = NULL;
    else if (prompt) {
      Scheme_Dynamic_Wind *dw;
      if (p->dw) {
        dw = clone_dyn_wind(p->dw, pt, -1, -1, NULL, 0, composable);
        cont->dw = dw;
        cont->next_meta = p->next_meta;
      } else
        cont->dw = NULL;
    } else {
      cont->dw = p->dw;
      cont->next_meta = p->next_meta;
    }
  }
  if (!for_prompt)
    ASSERT_SUSPEND_BREAK_ZERO();
  copy_cjs(&cont->cjs, &p->cjs);
  cont->save_overflow = p->overflow;
  scheme_save_env_stack_w_thread(cont->ss, p);
  cont->runstack_size = p->runstack_size;
  cont->runstack_start = MZ_RUNSTACK_START;
  cont->runstack_saved = p->runstack_saved;
  cont->meta_tail_pos = (prompt ? prompt->boundary_mark_pos + 2 : 0);
  cont->init_config = p->init_config;
  cont->init_break_cell = p->init_break_cell;
  if (for_prompt || cm_only) {
    cont->meta_continuation = NULL;
  } else if (prompt) {
    Scheme_Meta_Continuation *mc;
    mc = clone_meta_cont(p->meta_continuation, pt, -1, prompt_cont, prompt, NULL, composable);
    cont->meta_continuation = mc;
    if (!prompt_cont) {
      /* Remember the prompt id, so we can maybe take a shortcut on 
         invocation. (The shortcut only works within a meta-continuation.) */
      init_prompt_id(prompt);
      cont->prompt_id = prompt->id;
    }
    cont->has_prompt_dw = 1;
  } else
    cont->meta_continuation = p->meta_continuation;

  if (!cm_only) {
    /* A weak link is good enough for detecting continuation sharing, because
       if the meta continuation goes away, then we're certainly not capturing
       the same continuation as before. */
    Scheme_Object *meta_continuation_src;
    meta_continuation_src = scheme_make_weak_box((Scheme_Object *)p->meta_continuation);
    cont->meta_continuation_src = meta_continuation_src;
  }

  if (effective_barrier_prompt) {
    cont->barrier_prompt = effective_barrier_prompt;
    scheme_prompt_capture_count++;
  }

  if (p->meta_prompt && prompt_cont) /* prompt_cont => meta-prompt is shallower than prompt */
    prompt = p->meta_prompt;

  if (!cm_only) {
    Scheme_Overflow *overflow;
    /* Mark overflows as captured: */
    for (overflow = p->overflow; overflow; overflow = overflow->prev) {
      overflow->jmp->captured = 1;
    }
    /* If prompt, then clone overflow records up to the prompt. */
    if (prompt) {
      overflow = clone_overflows(p->overflow, prompt->boundary_overflow_id, NULL);
      cont->save_overflow = overflow;
    }
    scheme_cont_capture_count++;
  }

  if ((!effective_barrier_prompt || !effective_barrier_prompt->is_barrier) && !cm_only) {
    /* This continuation can be used by other threads,
       so we need to track ownership of the runstack */
    if (!p->runstack_owner) {
      Scheme_Thread **owner;
      owner = MALLOC_N(Scheme_Thread *, 1);
      p->runstack_owner = owner;
      *owner = p;
    }
    if (cont->ss.cont_mark_stack && !p->cont_mark_stack_owner) {
      Scheme_Thread **owner;
      owner = MALLOC_N(Scheme_Thread *, 1);
      p->cont_mark_stack_owner = owner;
      *owner = p;
    }
  }

#ifdef MZ_USE_JIT
  /* This information can be expensive to compute, no one uses it
     currently, and it's approximate anyway. So skip it. */
  if (0) {
    Scheme_Object *tr;
    tr = scheme_native_stack_trace();
    cont->native_trace = tr;
  }
#endif

  if (!cm_only) {
    Scheme_Saved_Stack *saved;
    saved = copy_out_runstack(p, MZ_RUNSTACK, MZ_RUNSTACK_START, sub_cont, 
                              (for_prompt ? p->meta_prompt : prompt));
    if (argv == MZ_RUNSTACK) {
      /* The copy of RUNSTACK that we just saved captures the arguments
         to `call/cc`, but we don't want to retain those. */
      intptr_t i;
      for (i = 0; i < argc; i++) {
        saved->runstack_start[i] = scheme_false;
      }
    }
    cont->runstack_copied = saved;
    if (!for_prompt && prompt) {
      /* Prune cont->runstack_saved to drop unneeded saves.
         (Note that this is different than runstack_copied; 
          runstack_saved keeps the shared runstack buffers, 
          not the content.) */
      if (scheme_prompt_runstack_boundary_start(prompt) == MZ_RUNSTACK_START)
        saved = NULL;
      else
        saved = clone_runstack_saved(cont->runstack_saved, 
                                     scheme_prompt_runstack_boundary_start(prompt),
                                     NULL);
      cont->runstack_saved = saved;
    }
  }

  {
    Scheme_Prompt *effective_prompt;
    Scheme_Cont_Mark *msaved;
    intptr_t offset;
    effective_prompt = (for_prompt ? p->meta_prompt : prompt);
    msaved = copy_out_mark_stack(p, cont->ss.cont_mark_stack, sub_cont, &offset, 
                                 effective_prompt,
                                 /* If there's a prompt, then clear caches in the mark stack,
                                    since any cached values are wrong for the delimited
                                    continuation. Otherwise, leave the cache in place
                                    for operations directly on the continuation; the caches
                                    will be cleared on restore if the continuation is appended
                                    to another on invocation. */
                                 !!prompt);
    cont->cont_mark_stack_copied = msaved;
    cont->cont_mark_offset = offset;
    if (effective_prompt)
      cont->cont_mark_total = cont->ss.cont_mark_stack - effective_prompt->mark_boundary;
    else
      cont->cont_mark_total = cont->ss.cont_mark_stack;
    offset = find_shareable_marks();
    cont->cont_mark_nonshare = cont->ss.cont_mark_stack - offset;
    /* Need to remember the pos key for the bottom, 
       at least for composable continuations, so 
       we can splice the captured continuation marks
       with a meta continuation's marks. */
    cont->cont_mark_pos_bottom = (effective_prompt
                                  ? effective_prompt->boundary_mark_pos
                                  : 1);
  }

  if (!cm_only) {
    cont->runstack_owner = p->runstack_owner;
    cont->cont_mark_stack_owner = p->cont_mark_stack_owner;

    cont->stack_start = p->stack_start;

    cont->savebuf = p->error_buf;

    if (prompt)
      cont->prompt_buf = prompt->prompt_buf;
  }

  return cont;
}

static void restore_continuation(Scheme_Cont *cont, Scheme_Thread *p, int for_prompt,
                                 Scheme_Object *result, 
                                 Scheme_Overflow *resume, int empty_to_next_mc,
                                 Scheme_Object *prompt_tag,
                                 Scheme_Dynamic_Wind *common_dw, int common_next_meta, 
                                 Scheme_Prompt *shortcut_prompt,
                                 int clear_cm_caches, int do_reset_cjs,
                                 Scheme_Cont *cm_cont, Scheme_Object *extra_marks)
{
  MZ_MARK_STACK_TYPE copied_cms = 0;
  Scheme_Object **mv, *sub_conts = NULL;
  Scheme_Cont *sub_cont;
  int mc;

  if (SAME_OBJ(result, SCHEME_MULTIPLE_VALUES)) {
    /* Get values out before GC */
    mv = p->ku.multiple.array;
    mc = p->ku.multiple.count;
    if (SAME_OBJ(mv, p->values_buffer))
      p->values_buffer = NULL;
    p->ku.multiple.array = NULL;
  } else {
    mv = NULL;
    mc = 0;
  }

  p->error_buf = cont->savebuf;

  p->init_config = cont->init_config;
  p->init_break_cell = cont->init_break_cell;

  if (do_reset_cjs)
    copy_cjs(&p->cjs, &cont->cjs);
  if (shortcut_prompt) {
    Scheme_Overflow *overflow;
    overflow = clone_overflows(cont->save_overflow, NULL, p->overflow);
    p->overflow = overflow;
  } else {
    p->overflow = cont->save_overflow;
  }
  if (for_prompt) {
    if (p->meta_prompt)
      cont->need_meta_prompt = 1;
  } else {
    Scheme_Meta_Continuation *mc, *resume_mc;
    if (resume) {
      resume_mc = MALLOC_ONE_RT(Scheme_Meta_Continuation);
#ifdef MZTAG_REQUIRED
      resume_mc->type = scheme_rt_meta_cont;
#endif
      resume_mc->overflow = resume;

      resume_mc->prompt_tag = prompt_tag;
      resume_mc->pseudo = cont->composable;
      resume_mc->empty_to_next = empty_to_next_mc;
      resume_mc->meta_tail_pos = cont->meta_tail_pos;

      if (!cm_cont) {
        /* resume must correspond to the implicit prompt at
           the thread's beginning. */
      } else {
        resume_mc->cont_mark_stack = cm_cont->ss.cont_mark_stack;
        resume_mc->cont_mark_pos = cm_cont->ss.cont_mark_pos;
        resume_mc->cont_mark_total = cm_cont->cont_mark_total;
        resume_mc->cont_mark_offset = cm_cont->cont_mark_offset;
        resume_mc->cont_mark_pos_bottom = cm_cont->cont_mark_pos_bottom;
        resume_mc->cont_mark_stack_copied = cm_cont->cont_mark_stack_copied;

        resume_mc->cont = cm_cont;

        resume_mc->cm_caches = 1; /* conservative assumption */

        resume_mc->next = p->meta_continuation;
        if (p->meta_continuation)
          resume_mc->depth = p->meta_continuation->depth + 1;
      }
    } else
      resume_mc = NULL;
    if (resume_mc) {
      if (cont->composable) {
        /* Prune resume_mc continuation marks that have replacements
           in the deepest frame of cont, and add extra_marks */
        prune_cont_marks(resume_mc, cont, extra_marks);
        p->cont_mark_pos_bottom = cont->cont_mark_pos_bottom;
      }
      
      mc = clone_meta_cont(cont->meta_continuation, NULL, -1, NULL, NULL, resume_mc, 0);
    } else if (shortcut_prompt) {
      mc = clone_meta_cont(cont->meta_continuation, NULL, -1, NULL, NULL, p->meta_continuation, 0);
    } else
      mc = cont->meta_continuation;
    p->meta_continuation = mc;
  }

  if (shortcut_prompt) {
    /* In shortcut mode, we need to preserve saved runstacks
       that were pruned when capturing the continuation. */
    Scheme_Saved_Stack *rs;
    if (scheme_prompt_runstack_boundary_start(shortcut_prompt) == MZ_RUNSTACK_START)
      rs = p->runstack_saved;
    else {
      rs = p->runstack_saved;
      while (rs && (rs->runstack_start != scheme_prompt_runstack_boundary_start(shortcut_prompt))) {
        rs = rs->prev;
      }
      if (rs)
        rs = rs->prev;
    }
    if (rs)
      rs = clone_runstack_saved(cont->runstack_saved, NULL, rs);
    else
      rs = cont->runstack_saved;
    p->runstack_saved = rs;
  } else
    p->runstack_saved = cont->runstack_saved;

  MZ_RUNSTACK_START = cont->runstack_start;
  p->runstack_size = cont->runstack_size;

  scheme_restore_env_stack_w_thread(cont->ss, p);

  if (p->runstack_owner
      && (*p->runstack_owner == p)) {
    *p->runstack_owner = NULL;
  }

  if (resume)
    p->meta_prompt = NULL; /* in case there's a GC before we can set it */

  p->runstack_owner = cont->runstack_owner;
  if (p->runstack_owner && (*p->runstack_owner != p)) {
    Scheme_Thread *op;
    op = *p->runstack_owner;
    if (op) {
      Scheme_Saved_Stack *saved;
      saved = copy_out_runstack(op, op->runstack, op->runstack_start, NULL, NULL);
      op->runstack_swapped = saved;
    }
    *p->runstack_owner = p;
  }

  /* Copy stack back in: p->runstack and p->runstack_saved arrays
     are already restored, so the shape is certainly the same as
     when cont->runstack_copied was made. If we have a derived
     continuation, then we're sharing its base runstack. */
  copy_in_runstack(p, cont->runstack_copied, 0);
  {
    intptr_t done = cont->runstack_copied->runstack_size, size;
    sub_cont = cont;
    while (sub_cont) {
      if (sub_cont->buf_ptr->buf.cont
          && (sub_cont->runstack_start == sub_cont->buf_ptr->buf.cont->runstack_start)) {
        intptr_t delta;
        /* Copy shared part in: */
        sub_cont = sub_cont->buf_ptr->buf.cont;
        size = sub_cont->runstack_copied->runstack_size;
        /* Skip potential call/cc argument(s), which we don't want
           from the outer continuation. */
        if (size > MAX_CALL_CC_ARG_COUNT)
          delta = MAX_CALL_CC_ARG_COUNT;
        else
          delta = size;
        if (size > delta) {
          memcpy(MZ_RUNSTACK XFORM_OK_PLUS done, 
                 sub_cont->runstack_copied->runstack_start + delta,
                 (size - delta) * sizeof(Scheme_Object *));
          done += (size - delta);
        }
      } else
        break;
    }
  }
    
  if (p->cont_mark_stack_owner
      && (*p->cont_mark_stack_owner == p))
    *p->cont_mark_stack_owner = NULL;

  p->cont_mark_stack_owner = cont->cont_mark_stack_owner;
  if (p->cont_mark_stack_owner
      && (*p->cont_mark_stack_owner != p)) {
    Scheme_Thread *op;
    op = *p->cont_mark_stack_owner;
    if (op) {
      Scheme_Cont_Mark *msaved;
      msaved = copy_out_mark_stack(op, op->cont_mark_stack, NULL, NULL, NULL, 0);
      op->cont_mark_stack_swapped = msaved;
    }
    *p->cont_mark_stack_owner = p;
    /* In case there's a GC before we copy in marks: */
    MZ_CONT_MARK_STACK = 0;
  }

  /* If there's a resume, then set up a meta prompt.
     We also need a meta-prompt if we're returning from a composed
     continuation to a continuation captured under a meta-prompt,
     or truncated somewhere along the way. */
  if (resume || (for_prompt && cont->need_meta_prompt)) {
    Scheme_Prompt *meta_prompt;

    meta_prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
    meta_prompt->so.type = scheme_prompt_type;
    meta_prompt->stack_boundary = cont->prompt_stack_start;
    meta_prompt->boundary_overflow_id = NULL;
    {
      Scheme_Cont *tc;
      for (tc = cont; tc->buf_ptr->buf.cont; tc = tc->buf_ptr->buf.cont) {
      }
      meta_prompt->mark_boundary = tc->cont_mark_offset;
    }
    meta_prompt->prompt_buf = cont->prompt_buf;
    {
      /* Reverse-engineer where the saved runstack ends: */
      Scheme_Cont *rs_cont = cont;
      Scheme_Saved_Stack *saved, *actual;
      int delta = 0;
      while (rs_cont->buf_ptr->buf.cont
             && (rs_cont->buf_ptr->buf.cont->runstack_start == cont->runstack_start)) {
        delta += rs_cont->runstack_copied->runstack_size;
        rs_cont = rs_cont->buf_ptr->buf.cont;
        if (rs_cont->runstack_copied->runstack_size > MAX_CALL_CC_ARG_COUNT) {
          delta -= MAX_CALL_CC_ARG_COUNT; /* overlap for not-saved call/cc argument */
        }
      }
      actual = NULL;
      for (saved = rs_cont->runstack_copied; saved->prev; saved = saved->prev) {
        if (!actual)
          actual = p->runstack_saved;
        else
          actual = actual->prev;
      }
      if (actual) {
        meta_prompt->u.runstack_boundary_start = actual->runstack_start;
        meta_prompt->runstack_boundary_offset = actual->runstack_offset + saved->runstack_size;
      } else {
        meta_prompt->u.runstack_boundary_start = MZ_RUNSTACK_START;
        meta_prompt->runstack_boundary_offset = (MZ_RUNSTACK - MZ_RUNSTACK_START) + saved->runstack_size + delta;
        MZ_ASSERT(meta_prompt->runstack_boundary_offset <= scheme_current_thread->runstack_size);
      }
    }

    meta_prompt->boundary_mark_pos = cont->cont_mark_pos_bottom; /* for mark splicing */

    p->meta_prompt = meta_prompt;
  }

  /* For copying cont marks back in, we need a list of sub_conts,
     deepest to shallowest: */
  copied_cms = cont->cont_mark_offset;
  for (sub_cont = cont->buf_ptr->buf.cont; sub_cont; sub_cont = sub_cont->buf_ptr->buf.cont) {
    copied_cms = sub_cont->cont_mark_offset;
    sub_conts = scheme_make_raw_pair((Scheme_Object *)sub_cont, sub_conts);
  }

  if (!shortcut_prompt) {    
    Scheme_Cont *tc;
    for (tc = cont; tc->buf_ptr->buf.cont; tc = tc->buf_ptr->buf.cont) {
    }
    p->cont_mark_stack_bottom = tc->cont_mark_offset;
    p->cont_mark_pos_bottom = tc->cont_mark_pos_bottom;
  }

  if (for_prompt) {
    /* leave p->dw alone */
  } else {
    /* For dynamic-winds after the "common" intersection
       (see eval.c), execute the pre thunks. Make a list
       of these first because they have to be done in the
       inverse order of `prev' linkage. */
    Scheme_Dynamic_Wind *dw, *all_dw;
    Scheme_Dynamic_Wind_List *dwl = NULL;
    int common_depth, dwl_len = 0;

    /* The thread's dw is set to the common dw. */

    if (resume) {
      /* Figure out which dynamic winds use meta-continuations
         after an added one. */
      if (cont->composable) {
        /* All of them! */
        p->next_meta++;
      } else {
        /* D-Ws after the tag are now one further way:
           after the newly inserted meta-continuation for this tag. */
        p->dw = common_dw;
        p->next_meta = common_next_meta;
        if (p->dw) { /* can be empty if there's only the implicit prompt */
          /* also, there may be no dw with prompt_tag if there's only the implicit prompt */
          all_dw = clone_dyn_wind(p->dw, cont->prompt_tag, -1, -1, NULL, 1, 0);
          for (dw = all_dw; dw && !SAME_OBJ(dw->prompt_tag, cont->prompt_tag); dw = dw->prev) {
            p->dw = p->dw->prev;
          }
          if (dw)
            dw->next_meta += 1;
          p->dw = all_dw;
        }
      }
    } else {
      p->dw = common_dw;
      p->next_meta = common_next_meta;
    }

    if (cont->dw) {
      int meta_depth;

      /* The allow_dw chain that we build up here is actually
         premature, in that the tail to splice onto may change
         in pre-thunks. It doesn't usually happen, and we can 
         detect that case in exec_dyn_wind_pres() in re-clone. */
      common_depth = (p->dw ? p->dw->depth : -1);
      all_dw = clone_dyn_wind(cont->dw, NULL, cont->common_dw_depth, -1, p->dw, 0, 0);

      if ((common_depth != -1) && (common_depth != all_dw->depth)) {
        /* Move p->next_meta to the last added dw's next_meta. */
        for (dw = all_dw; dw->prev->depth != common_depth; dw = dw->prev) {
        }
        dw->next_meta = p->next_meta;
      }
      
      meta_depth = cont->next_meta;
      for (dw = all_dw; dw && (dw->depth != common_depth); dw = dw->prev) {
        Scheme_Dynamic_Wind_List *cell;

        cell = MALLOC_ONE_RT(Scheme_Dynamic_Wind_List);
#ifdef MZTAG_REQUIRED
        cell->type = scheme_rt_dyn_wind_cell;
#endif
        cell->dw = dw;
        cell->meta_depth = meta_depth;
        cell->next = dwl;
        dwl = cell;
        dwl_len++;

        meta_depth += dw->next_meta;
      }
      copied_cms = exec_dyn_wind_pres(dwl, dwl_len, cont, copied_cms, clear_cm_caches, &sub_conts,
                                      cont->skip_dws);
      p = scheme_current_thread;
      p->next_meta = cont->next_meta;      
    }
  }

  if (!for_prompt)
    p->suspend_break = 0;

  /* Finish copying cont mark stack back in. */
    
  copy_in_mark_stack(p, cont->cont_mark_stack_copied, 
                     cont->ss.cont_mark_stack, copied_cms,
                     cont->cont_mark_offset, &sub_conts,
                     clear_cm_caches,
                     cont->ss.cont_mark_pos);
        
  if (SAME_OBJ(result, SCHEME_MULTIPLE_VALUES)) {
    p->ku.multiple.array = mv;
    p->ku.multiple.count = mc;
  }
}

static Scheme_Object *
internal_call_cc (int argc, Scheme_Object *argv[])
{
  Scheme_Object *ret, * volatile pt, * prompt_tag;
  Scheme_Cont * volatile cont;
  Scheme_Cont *sub_cont;
  Scheme_Meta_Continuation *prompt_cont, *barrier_cont;
  MZ_MARK_POS_TYPE prompt_pos, barrier_pos;
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Prompt *prompt, *barrier_prompt, *effective_barrier_prompt;
  Scheme_Object *ec;
  GC_CAN_IGNORE void *stack_start;
  int composable;

  if (argc > 1)
    prompt_tag = argv[1];
  else
    prompt_tag = scheme_default_prompt_tag;

  if (SCHEME_NP_CHAPERONEP(prompt_tag))
    pt = SCHEME_CHAPERONE_VAL(prompt_tag);
  else
    pt = prompt_tag;

  composable = (argc > 2);

  if (SAME_OBJ(pt, scheme_root_prompt_tag)) {
    root_prompt_tag_misuse(composable
                           ? "call-with-composable-continuation"
                           : "call-with-current-continuation");
    return NULL;
  }

  prompt = scheme_get_prompt(SCHEME_PTR_VAL(pt), &prompt_cont, &prompt_pos);
  if (!prompt && !SAME_OBJ(scheme_default_prompt_tag, pt)) {
    scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
                     "%s: continuation includes no prompt with the given tag\n"
                     "  tag: %V",
                     (composable
                      ? "call-with-composable-continuation"
                      : "call-with-current-continuation"),
                     prompt_tag);
    return NULL;
  }

  /* This prompt is likely to be on the C stack when we capture it for
     the continuation, but we only want to retain the prompt's
     runstack. Convert it to one that has the same ID but holds the
     runstack weakly. */
  if (prompt)
    prompt = make_weak_prompt(prompt);

  barrier_prompt = scheme_get_barrier_prompt(&barrier_cont, &barrier_pos);

  if (composable && SCHEME_FALSEP(argv[2])) {
    if (!prompt && !barrier_prompt->is_barrier) {
      /* Pseduo-prompt ok. */
    } else {
      if (!prompt
          || scheme_is_cm_deeper(prompt_cont, prompt_pos, barrier_cont, barrier_pos)) {
        scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
                         "call-with-composable-continuation: cannot capture past continuation barrier");
      }
    }
  }

  effective_barrier_prompt = barrier_prompt;
  if (effective_barrier_prompt && prompt) {
    if (scheme_is_cm_deeper(barrier_cont, barrier_pos,
                            prompt_cont, prompt_pos))
      effective_barrier_prompt = NULL;
  }

  if (composable)
    sub_cont = NULL;
  else
    sub_cont = (Scheme_Cont *)scheme_extract_one_cc_mark(NULL, cont_key);
  if (sub_cont 
      && (sub_cont->save_overflow == p->overflow)
      && (sub_cont->prompt_tag == prompt_tag)
      && (sub_cont->barrier_prompt == effective_barrier_prompt)
      && (((Scheme_Escaping_Cont *)sub_cont->escape_cont)->myerr == p->error_buf)) {
    /* Whether sub_cont turns out to be the same continuation, we can use
       its escape continuation, because jumping to the escape continuation
       triggers the same C-level clean-up actions, same `dynamic-wind's, and
       crosses the same continuation barriers. */
    ec = sub_cont->escape_cont; 
  } else
    ec = NULL;
  if (sub_cont && ((sub_cont->save_overflow != p->overflow)
		   || (sub_cont->prompt_tag != prompt_tag)
		   || (sub_cont->barrier_prompt != effective_barrier_prompt)
		   || ((Scheme_Meta_Continuation *)SCHEME_WEAK_BOX_VAL(sub_cont->meta_continuation_src)
                       != p->meta_continuation))) {
    sub_cont = NULL;
  }
  if (sub_cont && (sub_cont->ss.cont_mark_pos == MZ_CONT_MARK_POS)) {
    Scheme_Object *argv2[1];
#ifdef MZ_USE_JIT
    /* See note above on how the stack trace is expensive to compute
       and not all that useful. */
    if (0)
      ret = scheme_native_stack_trace();
    else
      ret = NULL;
#endif    
    /* Old cont is the same as this one, except that it may
       have different marks (not counting cont_key). */
    if (!sub_cont->cont_mark_nonshare
	&& (find_shareable_marks() == MZ_CONT_MARK_STACK)
#ifdef MZ_USE_JIT
	&& (SAME_OBJ(ret, sub_cont->native_trace)
	    /* Maybe a single-function loop, where we re-allocated the
	       last pair in the trace, but it's the same name: */
	    || (ret 
                && sub_cont->native_trace
                && SCHEME_PAIRP(ret)
		&& SCHEME_PAIRP(sub_cont->native_trace)
		&& SAME_OBJ(SCHEME_CAR(ret), SCHEME_CAR(sub_cont->native_trace))
		&& SAME_OBJ(SCHEME_CDR(ret), SCHEME_CDR(sub_cont->native_trace))))
#endif
	) {
      /* Just use this one. */
      cont = sub_cont;
    } else {
      /* Only continuation marks can be different. Mostly just re-use sub_cont.
         The mark stack won't be restored, but it may be
	 used by `continuation-marks'. */

      cont = grab_continuation(p, 0, 0, prompt_tag, pt, sub_cont,
                               prompt, prompt_cont, effective_barrier_prompt, 1,
                               argc, argv);
#ifdef MZ_USE_JIT
      cont->native_trace = ret;
#endif

      cont->buf_ptr->buf.cont = sub_cont;
      cont->escape_cont = sub_cont->escape_cont;
    }

    argv2[0] = (Scheme_Object *)cont;
    return _scheme_tail_apply(argv[0], 1, argv2);
  }

  cont = grab_continuation(p, 0, composable, prompt_tag, pt, sub_cont, 
                           prompt, prompt_cont, effective_barrier_prompt, 0,
                           argc, argv);

  scheme_zero_unneeded_rands(p);

  scheme_flatten_config(scheme_current_config());

  {
    void *overflow_id;

    overflow_id = (p->overflow
                   ? (p->overflow->id
                      ? p->overflow->id
                      : p->overflow)
                   : NULL);

    if (prompt 
        && !prompt_cont
        && (prompt->boundary_overflow_id == overflow_id)) {
      /* Must be inside barrier_prompt, or it wouldn't be allowed.
         Must be inside meta_prompt, or prompt_cont would be non-NULL.
         Must be inside overflow, or the ids wouldn't match. */
      stack_start = prompt->stack_boundary;
    } else {
      Scheme_Prompt *meta_prompt, *stack_barrier_prompt;

      stack_barrier_prompt = barrier_prompt;

      if (!stack_barrier_prompt->is_barrier)
        stack_barrier_prompt = NULL;
      else if (stack_barrier_prompt->boundary_overflow_id != overflow_id)
        stack_barrier_prompt = NULL;
      meta_prompt = p->meta_prompt;
      if (meta_prompt)
        if (meta_prompt->boundary_overflow_id != overflow_id)
          meta_prompt = NULL;

      if (stack_barrier_prompt && meta_prompt) {
        stack_barrier_prompt = NULL;
      }

      if (stack_barrier_prompt)
        stack_start = stack_barrier_prompt->stack_boundary;
      else if (meta_prompt)
        stack_start = meta_prompt->stack_boundary;
      else
        stack_start = p->stack_start;
    }
  }

  /* Use cont->stack_start when calling `cont' directly
     from the same meta-continuation. Use cont->prompt_stack_start 
     when calling `cont' composably (i.e., when supplying a resume). */
  cont->prompt_stack_start = stack_start;

  cont->escape_cont = ec;

  /* Zero out any local variable that shouldn't be saved by the
     continuation.  The meta-continuation for the prompt is an
     especially important one to zero out (otherwise we build up
     chains). */
  prompt_cont = NULL;
  barrier_cont = NULL;

  if (scheme_setjmpup_relative(&cont->buf_ptr->buf, cont->buf_ptr, stack_start, sub_cont)) {
    /* We arrive here when the continuation is applied */
    Scheme_Object *result, *extra_marks;
    Scheme_Overflow *resume;
    Scheme_Cont *use_next_cont;
    Scheme_Dynamic_Wind *common_dw;
    Scheme_Prompt *shortcut_prompt;
    int common_next_meta, empty_to_next_mc;

    p = scheme_current_thread; /* maybe different than before */

    result = cont->value;
    cont->value = NULL;
    
    resume = cont->resume_to;
    cont->resume_to = NULL;

    use_next_cont = cont->use_next_cont;
    cont->use_next_cont = NULL;
  
    extra_marks = cont->extra_marks;
    cont->extra_marks = NULL;

    common_dw = cont->common_dw;
    cont->common_dw = NULL;

    common_next_meta = cont->common_next_meta;
    cont->common_next_meta = 0;
  
    shortcut_prompt = cont->shortcut_prompt;
    cont->shortcut_prompt = NULL;

    empty_to_next_mc = cont->empty_to_next_mc;
    cont->empty_to_next_mc = 0;

    restore_continuation(cont, p, 0, result, resume, empty_to_next_mc, 
                         pt,
                         common_dw, common_next_meta, shortcut_prompt,
                         !!resume, 1, 
                         use_next_cont, extra_marks);

    /* We may have just re-activated breaking: */
    scheme_check_break_now();

    if (!scheme_get_barrier_prompt(NULL, NULL)) {
      /* The continuation was applied in a thread where the barrier prompt
         was supposed to be the pseduo-prompt for a thread, but we've lost
         that prompt. The barrier prompt from capturing the continuation
         has the right info, but we need to claim that it's not a barrier
         from the perspective of changing continuations. */
      Scheme_Prompt *acting_barrier_prompt;
      if (!barrier_prompt->is_barrier)
        acting_barrier_prompt = barrier_prompt;
      else {
        acting_barrier_prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);
        memcpy(acting_barrier_prompt, barrier_prompt, sizeof(Scheme_Prompt));
        acting_barrier_prompt->is_barrier = 0;
      }
      p->acting_barrier_prompt = acting_barrier_prompt;
    }

    {
      Scheme_Meta_Continuation *mc;
      MZ_MARK_POS_TYPE pos;
      Scheme_Object *cc_guard;

      prompt = scheme_get_prompt(SCHEME_PTR_VAL(pt), &mc, &pos);
      if (prompt && (prompt->has_chaperone || SCHEME_NP_CHAPERONEP(cont->prompt_tag))) {
        cc_guard = get_set_cont_mark_by_pos(prompt_cc_guard_key, p, mc, pos, NULL);
        
        if (SCHEME_FALSEP(cc_guard))
          cc_guard = scheme_values_proc;
        if (SCHEME_NP_CHAPERONEP(cont->prompt_tag))  
          cc_guard = chaperone_wrap_cc_guard(cont->prompt_tag, cc_guard);
        
        get_set_cont_mark_by_pos(prompt_cc_guard_key, p, mc, pos, cc_guard);
      }
    }

    if ((result != SCHEME_MULTIPLE_VALUES)
        && SAME_TYPE(SCHEME_TYPE(result), scheme_thunk_for_continue_type))
      return _scheme_tail_apply(SCHEME_PTR_VAL(result), 0, NULL);
    else
      return result;
  } else if (composable || cont->escape_cont) {
    Scheme_Object *argv2[1];

    if (SCHEME_TRUEP(argv[2]))
      cont->skip_dws = 1;

    argv2[0] = (Scheme_Object *)cont;
    ret = _scheme_tail_apply(argv[0], 1, argv2);
    return ret;
  } else {
    Scheme_Object *argv2[2];

    argv2[0] = argv[0];
    argv2[1] = (Scheme_Object *)cont;

    ret = _scheme_tail_apply(finish_call_cc_prim, 2, argv2);
    return ret;
  }
}

static Scheme_Object *
finish_call_cc (int argc, Scheme_Object *argv[])
{
  return do_call_ec(1, argv, argv[1]);
}

static Scheme_Object *call_in_continuation (int argc, Scheme_Object *argv[])
{
  Scheme_Object *k = argv[0], *p, *a[1];

  if (!SCHEME_CONTP(k) && !SCHEME_ECONTP(k))
    scheme_wrong_contract("call-in-continuation", "continuation?", 0, argc, argv);

  scheme_check_proc_arity("call-in-continuation", 0, 1, argc, argv);

  /* Instead of allocating, we chould thread a flag through to say
     that the value in `argv` should be applied instead of returned.
     But we're not likely to notice the cost of this allocation,
     anyway. */
  p = scheme_alloc_small_object();
  p->type = scheme_thunk_for_continue_type;
  SCHEME_PTR_VAL(p) = argv[1];

  a[0] = p;

  if (SCHEME_CONTP(k)) {
    /* We can use escape mode only if coontinuation marks didn't change. */
    int can_escape = 0;
    return scheme_jump_to_continuation(k, 1, a, MZ_RUNSTACK, can_escape);
  } else {
    scheme_escape_to_continuation(k, 1, a, NULL);
    return NULL;
  }
}

static Scheme_Object *continuation_p (int argc, Scheme_Object *argv[])
{
  return ((SCHEME_CONTP(argv[0]) || SCHEME_ECONTP(argv[0]))
          ? scheme_true
          : scheme_false);
}

void scheme_takeover_stacks(Scheme_Thread *p)
     /* When a continuation captured in on e thread is invoked in another,
	the two threads can start using the same runstack, and possibly
	also the same cont-mark stack. This function swaps out the
	current owner in favor of p */
	
{
  if (p->runstack_owner && ((*p->runstack_owner) != p)) {
    Scheme_Thread *op;
    Scheme_Saved_Stack *swapped;
    op = *p->runstack_owner;
    if (op) {
      swapped = copy_out_runstack(op, op->runstack, op->runstack_start, NULL, NULL);
      op->runstack_swapped = swapped;
    }
    *(p->runstack_owner) = p;
    copy_in_runstack(p, p->runstack_swapped, 1);
    p->runstack_swapped = NULL;
  }

  if (p->cont_mark_stack_owner && ((*p->cont_mark_stack_owner) != p)) {
    Scheme_Thread *op;
    Scheme_Cont_Mark *swapped;
    op = *p->cont_mark_stack_owner;
    if (op) {
      swapped = copy_out_mark_stack(op, op->cont_mark_stack, NULL, NULL, NULL, 0);
      op->cont_mark_stack_swapped = swapped;
    }
    *(p->cont_mark_stack_owner) = p;
    copy_in_mark_stack(p, p->cont_mark_stack_swapped, MZ_CONT_MARK_STACK, 0, 0, NULL, 0, MZ_CONT_MARK_POS);
    p->cont_mark_stack_swapped = NULL;
  }
}

static Scheme_Object *
call_with_continuation_barrier (int argc, Scheme_Object *argv[])
{
  scheme_check_proc_arity("call-with-continuation-barrier", 0, 0, argc, argv);

  /* scheme_apply_multi() is a top-level evaluation function and will
     thus install a continuation barrier */
  return scheme_apply_multi(argv[0], 0, NULL);
}

Scheme_Prompt *scheme_get_barrier_prompt(Scheme_Meta_Continuation **_meta_cont,
                                         MZ_MARK_POS_TYPE *_pos)
{
  Scheme_Prompt *p;
  
  p = (Scheme_Prompt *)scheme_extract_one_cc_mark_with_meta(NULL, barrier_prompt_key, NULL, _meta_cont, _pos);
  if (!p) {
    p = scheme_current_thread->acting_barrier_prompt;
    if (_meta_cont) {
      /* acting barrier prompt is deepest: */
      Scheme_Meta_Continuation *mc = scheme_current_thread->meta_continuation;
      while (mc && mc->next) {
        mc = mc->next;
      }
      *_meta_cont = mc;
      *_pos = -1;
    }
  }

  return p;
}

Scheme_Prompt *scheme_get_prompt(Scheme_Object *prompt_tag,
                                 Scheme_Meta_Continuation **_meta_cont,
                                 MZ_MARK_POS_TYPE *_pos)
{
  return (Scheme_Prompt *)scheme_extract_one_cc_mark_with_meta(NULL, prompt_tag, NULL, _meta_cont, _pos);
}

static Scheme_Meta_Continuation *scheme_get_meta_continuation(Scheme_Object *key)
{
  Scheme_Meta_Continuation *mc;
  scheme_extract_one_cc_mark_with_meta(NULL, key, NULL, &mc, NULL);
  return mc;
}


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

  if (argc && !SCHEME_SYMBOLP(argv[0]))
    scheme_wrong_contract("make-continuation-prompt-tag", "symbol?", 0, argc, argv);

  key = scheme_make_pair(scheme_false, scheme_false);

  o = scheme_alloc_object();
  o->type = scheme_prompt_tag_type;
  SCHEME_CAR(o) = key;
  SCHEME_CDR(o) = (argc ? argv[0] : NULL);

  return o;
}

static Scheme_Object *get_default_prompt_tag (int argc, Scheme_Object *argv[])
{
  return scheme_default_prompt_tag;
}

static Scheme_Object *prompt_tag_p (int argc, Scheme_Object *argv[])
{
  return (SCHEME_CHAPERONE_PROMPT_TAGP(argv[0])
          ? scheme_true
          : scheme_false);
}

Scheme_Object *do_chaperone_prompt_tag (const char *name, int is_impersonator, int argc, Scheme_Object **argv)
{
  Scheme_Chaperone *px;
  Scheme_Object *val = argv[0];
  Scheme_Object *redirects;
  Scheme_Object *props;
  int ppos;

  if (SCHEME_CHAPERONEP(val))
    val = SCHEME_CHAPERONE_VAL(val);

  if (!SCHEME_PROMPT_TAGP(val))
    scheme_wrong_contract(name, "prompt-tag?", 0, argc, argv);

  if (!SCHEME_PROCP(argv[1]))
    scheme_wrong_contract(name, "procedure?", 1, argc, argv);
  if (!SCHEME_PROCP(argv[2]))
    scheme_wrong_contract(name, "procedure?", 2, argc, argv);

  if ((argc > 3) && !SCHEME_CHAPERONEP(argv[3])) {
    if (!SCHEME_PROCP(argv[3]))
      scheme_wrong_contract(name, "(or/c procedure? impersonator-property?)", 3, argc, argv);
    redirects = argv[3];
    if ((argc > 4) && !SCHEME_CHAPERONEP(argv[4])) {
      if (!scheme_check_proc_arity(NULL, 1, 4, argc, argv))
        scheme_wrong_contract(name, "(or/c (procedure-arity-includes/c 1) impersonator-property?)", 4, argc, argv);
      redirects = scheme_make_pair(redirects, argv[4]);
      ppos = 5;
    } else
      ppos = 4;
    redirects = scheme_make_pair(argv[2], redirects);
  } else {
    ppos = 3;
    redirects = argv[2];
  }
    
  redirects = scheme_make_pair(argv[1], redirects);

  props = scheme_parse_chaperone_props(name, ppos, argc, argv);

  px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
  px->iso.so.type = scheme_chaperone_type;
  px->val = val;
  px->prev = argv[0];
  px->props = props;
  px->redirects = redirects;

  if (is_impersonator)
    SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;

  return (Scheme_Object *)px;
}

static Scheme_Object *chaperone_prompt_tag(int argc, Scheme_Object **argv)
{
  return do_chaperone_prompt_tag("chaperone-prompt-tag", 0, argc, argv);
}

static Scheme_Object *impersonate_prompt_tag(int argc, Scheme_Object **argv)
{
  return do_chaperone_prompt_tag("impersonate-prompt-tag", 1, argc, argv);
}

Scheme_Overflow *scheme_get_thread_end_overflow(void)
{
  Scheme_Overflow *overflow;
  overflow = MALLOC_ONE_RT(Scheme_Overflow);
#ifdef MZTAG_REQUIRED
  overflow->type = scheme_rt_overflow;
#endif
  overflow->eot = 1;
  return overflow;
}


void scheme_drop_prompt_meta_continuations(Scheme_Object *prompt_tag)
{
  Scheme_Meta_Continuation *mc;

  mc = scheme_current_thread->meta_continuation;
  while (!SAME_OBJ(mc->prompt_tag, prompt_tag)) {
    if (mc->overflow) {
      scheme_signal_error("meta-continuation to drop is not just a placeholder?!");
    }
    mc = mc->next;
  }

  scheme_current_thread->meta_continuation = mc;
}

MZ_DO_NOT_INLINE(Scheme_Object *scheme_finish_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *_prompt_tag, 
                                                               Scheme_Object *proc, int argc, Scheme_Object **argv));

Scheme_Object *scheme_finish_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *_prompt_tag, 
                                              Scheme_Object *proc, int argc, Scheme_Object **argv)
{
  /* Put space on the stack to record a longjmp target,
     in case a following continuation is restored for a
     different prompt.
     By putting this information on the stack, it will
     get captured if there's a further capture. */
  Scheme_Thread *p;
  Scheme_Object * volatile prompt_tag = _prompt_tag;
  mz_jmp_buf newbuf, * volatile savebuf;
  Scheme_Object *val;
  int cc_count = scheme_cont_capture_count;
  
  prompt->prompt_buf = &newbuf;
  prompt = NULL; /* to avoid prompt chains */

  p = scheme_current_thread;

  savebuf = p->error_buf;
  p->error_buf = &newbuf;

  /* Initial meta-continuation says to fall through. This
     one can get replaced when the current continuation
     is captured and then restored. */
  {
    Scheme_Meta_Continuation *resume_mc;
    if (available_prompt_mc) {
      resume_mc = available_prompt_mc;
      available_prompt_mc = NULL;
    } else
      resume_mc = MALLOC_ONE_RT(Scheme_Meta_Continuation);
#ifdef MZTAG_REQUIRED
    resume_mc->type = scheme_rt_meta_cont;
#endif
    resume_mc->prompt_tag = prompt_tag;
    if (p->meta_continuation) {
      resume_mc->next = p->meta_continuation;
      resume_mc->depth = p->meta_continuation->depth + 1;
    }
    resume_mc->meta_tail_pos = MZ_CONT_MARK_POS + 2;
    p->meta_continuation = resume_mc;
  }

  if (scheme_setjmp(newbuf)) {
    /*
      We can get here in three ways:
        1. abort-current-continuation with this prompt's tag:
           In this case, p->cjs.jumping_to_continuation is the
           prompt, p->cjs.val is a value to deliver to the
           prompt handler, and p->cjs.is_escape is unset.
           [This is a jump in the normal error/abort chain.]
        2. applying a continuation that is delimited by the prompt tag
           (in which case the jump originates from scheme_do_eval):
           In this case, p->cjs.jumping_to_continuation is the
           prompt, p->cjs.val is a continuation, and
           p->cjs.is_escape is set.
           [This is a jump in the special continuation-application
            direct mode.]
        3. other exception-level escape:
           In this case, p->cjs.jumping_to_continuation is the
           target (maybe an escape continuation), p->cjs.val is
           information to propagate to the target, and p->cjs.is_escape 
           is unset.
           [This is a jump in the normal error/abort chain.]
    */
    val = NULL;
  } else {
    val = _scheme_apply_multi(proc, argc, argv);
  }

  p = scheme_current_thread;
  p->error_buf = savebuf;

  {
    Scheme_Meta_Continuation *resume_mc;
    Scheme_Overflow *resume;
    
    resume = p->meta_continuation->overflow;
    resume_mc = p->meta_continuation;
    p->meta_continuation = p->meta_continuation->next;

    /* The following test was once useful for finding bugs. However,
       dropping meta-continuations that represent empty continuations
       (see for_composable in clone_meta_cont) interferes with the test. */
    /*
      if (!SAME_OBJ(resume_mc->prompt_tag, prompt_tag)) {
        scheme_signal_error("meta-continuation prompt tag does not match current prompt tag");
      }
    */

    if (cc_count == scheme_cont_capture_count) {
      memset(resume_mc, 0, sizeof(Scheme_Meta_Continuation));
#ifdef MZTAG_REQUIRED
      resume_mc->type = scheme_rt_meta_cont;
#endif
      available_prompt_mc = resume_mc;
    }

    if (!resume) {
      /* We return NULL if there's an escape of some sort (see above), 
         otherwise we return the result value. */
      return val;
    } else if (resume->eot) {
      /* There's nothing left in the continuation, 
         so just end the thread. We havent restored
         the thread state from the prompt, so flush
         anything that might otherwise have a clean-up action: */
      MZ_RUNSTACK = NULL;
      MZ_RUNSTACK_START = NULL;
      MZ_CONT_MARK_STACK = 0;
      p->runstack_start = NULL;
      p->runstack = NULL;
      p->runstack_size = 0;
      p->runstack_saved = NULL;
      p->cont_mark_stack_segments = NULL;
      scheme_end_current_thread();
      return NULL;
    } else {
      /* Continue by jumping to a meta-continuation. If
         val, then p->cjs.jumping_to_continuation is unset,
         so it's ok to communicate val via p->cjs.val. The
         target for this jump is in compose_continuation(). */
      if (val) {
        if (val == SCHEME_MULTIPLE_VALUES) {
          if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
            p->values_buffer = NULL;
        }
        p->cjs.val = val;
      }
      p->stack_start = resume->stack_start;
      p->decompose_mc = resume_mc;
      scheme_longjmpup(&resume->jmp->cont);
      return NULL;
    }
  }
}

MZ_DO_NOT_INLINE(Scheme_Object *scheme_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *prompt_tag, 
                                                        Scheme_Object *proc, int argc, Scheme_Object **argv));

Scheme_Object *scheme_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *prompt_tag, 
                                       Scheme_Object *proc, int argc, Scheme_Object **argv)
{
  /* Grab stack address, then continue on with final step: */
  prompt->stack_boundary = PROMPT_STACK(proc);

  proc = scheme_finish_apply_for_prompt(prompt, prompt_tag, proc, argc, argv);

  return proc;
}

static Scheme_Object *compose_continuation(Scheme_Cont *cont, int exec_chain, 
                                           Scheme_Object *loop_prompt, int empty_to_next_mc)
/* continuation arguments should be in `cont' already */
{
  /* Apply continuation as composable. There may or may not
     be a prompt immediately wrapping this application, depending on
     whether the continuation was captured as composable. */
  Scheme_Overflow *overflow;
  Scheme_Overflow_Jmp *jmp;
  Scheme_Cont *saved;
  Scheme_Prompt *saved_meta_prompt;
  Scheme_Thread *p = scheme_current_thread;

  scheme_about_to_move_C_stack();

  reset_cjs(&p->cjs);
  
  saved_meta_prompt = p->meta_prompt;

  /* Grab a continuation so that we capture the current Scheme stack,
     etc.: */
  saved = grab_continuation(p, 1, 0, NULL, NULL, NULL, NULL, NULL, NULL, 0, 0, NULL);

  if (p->meta_prompt)
    saved->prompt_stack_start = p->meta_prompt->stack_boundary;

  overflow = MALLOC_ONE_RT(Scheme_Overflow);
#ifdef MZTAG_REQUIRED
  overflow->type = scheme_rt_overflow;
#endif
  overflow->prev = p->overflow;
  overflow->stack_start = p->stack_start;

  jmp = MALLOC_ONE_RT(Scheme_Overflow_Jmp);
#ifdef MZTAG_REQUIRED
  jmp->type = scheme_rt_overflow_jmp;
#endif
  overflow->jmp = jmp;

  saved->resume_to = overflow; /* used by eval to jump to current meta-continuation */
  offstack_cont = saved;
  saved = NULL;

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

  offstack_overflow = overflow;
  overflow = NULL; /* so it's not saved in the continuation */

  if (scheme_setjmpup(&offstack_overflow->jmp->cont, 
                      offstack_overflow->jmp, 
                      p->stack_start)) {
    /* Returning. (Jumped here from finish_apply_for_prompt,
       scheme_compose_continuation, scheme_eval, or start_child.)
       
       We can return for several reasons:
        1. We got a result value.
           In that case, p->cjs.val holds the value, and
           p->cjs.jumping_to_continuation is NULL.
        2. There's an escape, and p->cjs.jumping_to_continuation
           is set. It could be a prompt, in which case we're
           escaping to the prompt, or it could be an
           error escape. In the former case, we may or may not be 
           applying a continuation at the target; see
           scheme_finish_apply_for_prompt() for those possibilities.
    */
    Scheme_Object *v;
    Scheme_Meta_Continuation *mc, *dmc;

    p = scheme_current_thread;

    dmc = p->decompose_mc;
    p->decompose_mc = NULL;
    saved = dmc->cont;
    overflow = dmc->overflow;

    if (!p->cjs.jumping_to_continuation) {
      /* Got a result: */
      v = p->cjs.val;
      p->cjs.val = NULL;
      if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
        if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
          p->values_buffer = NULL;
      }
    } else {
      /* Some sort of escape, to be handled by the caller,
         or to be handled below if it's an escape to loop_prompt.  */
      v = NULL;
    }
    mc = p->meta_continuation;
    p->meta_prompt = saved_meta_prompt; /* Set meta_prompt before restoring runstack,
                                           since GC erases meta-prompt-blocked portion
                                           on the runstack. */
    restore_continuation(saved, p, 1, v, NULL, 0,
                         NULL,
                         NULL, 0, NULL,
                         1, !p->cjs.jumping_to_continuation, 
                         NULL, NULL);

    p->meta_continuation = mc;

    /* There can be two kinds of loops:
         1. An escape to the current prompt to invoke another
            continuation.
         2. A trampoline to turn a composable-continuation
            application into a tail call; in this case,
            jumping_to_continuation = #t. */
    if (!v && ((loop_prompt
                && SAME_OBJ((Scheme_Object *)p->cjs.jumping_to_continuation,
                            loop_prompt)
                && p->cjs.is_escape)
               || (!loop_prompt
                   && p->cjs.jumping_to_continuation
                   && SCHEME_VECTORP((Scheme_Object *)p->cjs.jumping_to_continuation)))) {
      /* We'll handle this escape directly, to avoid re-computing
         saved and overflow. */
      cont = (Scheme_Cont *)p->cjs.val;
      if (SCHEME_VECTORP((Scheme_Object *)p->cjs.jumping_to_continuation)) {
        /* Instead of installing marks in `saved' now, ask `cont' to do it, 
           since `cont' may have some of its own replacements. */
        cont->extra_marks = (Scheme_Object *)p->cjs.jumping_to_continuation;
      }
      reset_cjs(&p->cjs);
      /* The current meta-continuation may have changed since capture: */
      saved->meta_continuation = p->meta_continuation;
      /* Fall though to continuation application below. */
    } else {
      return v;
    }
  } else {
    saved = offstack_cont;
    overflow = offstack_overflow;
    offstack_cont = NULL;
    offstack_overflow = NULL;
  }

  scheme_current_thread->suspend_break++;
  
  /* Here's where we jump to the target: */
  cont->use_next_cont = saved;
  cont->resume_to = overflow;
  cont->empty_to_next_mc = (char)empty_to_next_mc;
  scheme_current_thread->stack_start = cont->prompt_stack_start;
  scheme_longjmpup(&cont->buf_ptr->buf);

  ESCAPED_BEFORE_HERE;
}

static void continue_prompt_escape()
{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Prompt *targetc = (Scheme_Prompt *)p->cjs.jumping_to_continuation;

  scheme_drop_prompt_meta_continuations(targetc->tag);

  if ((!targetc->boundary_overflow_id && !p->overflow)
      || (targetc->boundary_overflow_id == p->overflow->id)) {
    /* Jump directly to the target. */
    scheme_longjmp(*targetc->prompt_buf, 1);
  } else {
    /* More hassle: need to unwind overflows to get to the prompt. */
    Scheme_Overflow *overflow = p->overflow;
    while (overflow->prev
           && (!overflow->prev->id
               || (overflow->prev->id != targetc->boundary_overflow_id))) {
      overflow = overflow->prev;
    }
    p->overflow = overflow;
    p->stack_start = overflow->stack_start;
    scheme_longjmpup(&overflow->jmp->cont);
  }
}

static void restore_from_prompt(Scheme_Prompt *prompt)
{
  Scheme_Thread *p = scheme_current_thread;

  while (MZ_RUNSTACK_START != scheme_prompt_runstack_boundary_start(prompt)) {
    MZ_RUNSTACK_START = p->runstack_saved->runstack_start;
    p->runstack_saved = p->runstack_saved->prev;
  }

  MZ_RUNSTACK = MZ_RUNSTACK_START + prompt->runstack_boundary_offset;
  MZ_CONT_MARK_STACK = prompt->mark_boundary;
  MZ_CONT_MARK_POS = prompt->boundary_mark_pos;
  
  p->runstack_size = prompt->runstack_size;

  if (prompt->boundary_overflow_id) {
    while (p->overflow->id != prompt->boundary_overflow_id) {
      p->overflow = p->overflow->prev;
    }
  } else
    p->overflow = NULL;
}

static void prompt_unwind_dw(Scheme_Object *prompt_tag)
{
  int delta = 0;
  Scheme_Thread *p = scheme_current_thread;

  while (p->dw && !SAME_OBJ(p->dw->prompt_tag, prompt_tag)) {
    delta += p->dw->next_meta;
    p->dw = p->dw->prev;
  }
  if (!p->dw) {
    scheme_signal_error("Lost prompt dynamic-wind record!\n");
  } else {
    delta += p->dw->next_meta;
    p->dw = p->dw->prev;
    p->next_meta += delta;
  }
}

static void prompt_unwind_one_dw(Scheme_Object *prompt_tag)
{
  Scheme_Thread *p = scheme_current_thread;
  if (!p->dw || !SAME_OBJ(p->dw->prompt_tag, prompt_tag)) {
    scheme_signal_error("Dynamic-wind record doesn't match prompt!\n");
  } else
    prompt_unwind_dw(prompt_tag);
}

static Scheme_Object **chaperone_do_control(const char *name, int mode, 
                                            Scheme_Object *init_guard, Scheme_Object *obj,
                                            int argc, Scheme_Object **argv)
{
  Scheme_Chaperone *px;
  Scheme_Object **vals = argv;
  Scheme_Object *v;
  Scheme_Object *proc;
  int i, num_args;

  while (1) {
    if (init_guard || !SCHEME_PROMPT_TAGP(obj)) {
      if (init_guard) {
        proc = init_guard;
        if (SAME_OBJ(NULL, scheme_values_proc))
          proc = NULL;
        px = NULL;
      } else {
        px = (Scheme_Chaperone *)obj;
        obj = px->prev;

        if (!mode)
          proc = SCHEME_CAR(px->redirects);
        else {
          proc = SCHEME_CDR(px->redirects);
          if (mode == 1) {
            if (SCHEME_PAIRP(proc))
              proc = SCHEME_CAR(proc);
          } else {
            if (SCHEME_PAIRP(proc)) {
              proc = SCHEME_CDR(proc);
              if (mode == 2) {
                if (SCHEME_PAIRP(proc))
                  proc = SCHEME_CAR(proc);
              } else {
                if (SCHEME_PAIRP(proc))
                  proc = SCHEME_CDR(proc);
                else
                  proc = NULL;
              }
            } else
              proc = NULL;
          }
        }
      }

      if (proc) {
        if (mode == 3)
          v = scheme_apply(proc, argc, argv); /* with barrier */
        else
          v = _scheme_apply_multi(proc, argc, argv);

        if (v == SCHEME_MULTIPLE_VALUES) {
          GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
          if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
            p->values_buffer = NULL;
          num_args = p->ku.multiple.count;
          vals = p->ku.multiple.array;
          p->ku.multiple.array = NULL;
        } else {
          num_args = 1;
          vals = MALLOC_N(Scheme_Object *, 1);
          vals[0] = v;
        }

        /*
         * All kinds of proxies should return the same number of results
         * as the number of aborted values
         */
        if (num_args == 1 && num_args != argc)
          scheme_wrong_return_arity(name, argc, 1, (Scheme_Object **)(vals[0]), "\n  in: use of redirecting procedure");
        else if (num_args != argc)
          scheme_wrong_return_arity(name, argc, num_args, vals, "\n   in: use of redirecting procedure");

        if (mode == 3) {
          if (!scheme_check_proc_arity(NULL, 1, 0, argc, vals)) {
            scheme_wrong_type("call/cc guard-wrapping function", "(procedure-arity-includes/c 2)", 0, -1, vals);
          }
        }

        if (!init_guard) {
          if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) {
            for (i = 0; i < argc; i++) {
              if (!scheme_chaperone_of(vals[i], argv[i]))
                scheme_wrong_chaperoned(name, "value", argv[i], vals[i]);
            }
          }
        }

        argv = vals;
      }

      init_guard = NULL;
    } else {
      return vals;
    }
  }
}

static Scheme_Object **chaperone_do_prompt_handler(Scheme_Object *obj, int argc, Scheme_Object **argv)
{
  return chaperone_do_control("call-with-continuation-prompt", 0, NULL, obj, argc, argv);
}

static Scheme_Object **chaperone_do_abort(Scheme_Object *obj, int argc, Scheme_Object **argv)
{
  return chaperone_do_control("abort-current-continuation", 1, NULL, obj, argc, argv);
}

static Scheme_Object **chaperone_do_cc_guard(Scheme_Object *cc_guard, Scheme_Object *obj, int argc, Scheme_Object **argv)
{
  return chaperone_do_control("call-with-continuation-prompt", 2, cc_guard, obj, argc, argv);
}

static Scheme_Object *chaperone_wrap_cc_guard(Scheme_Object *obj, Scheme_Object *proc)
{
  Scheme_Object *a[1], **a2;

  a[0] = proc;
  a2 = chaperone_do_control("call-with-current-continuation", 3, NULL, obj, 1, a);

  return a2[0];
}

static Scheme_Object *do_cc_guard(Scheme_Object *v, Scheme_Object *cc_guard, Scheme_Object *chaperone)
{
  int argc;
  Scheme_Object **argv, *a[1];

  if (v == SCHEME_MULTIPLE_VALUES) {
    GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
    if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
      p->values_buffer = NULL;
    argc = p->ku.multiple.count;
    argv = p->ku.multiple.array;
    p->ku.multiple.array = NULL;
  } else {
    a[0] = v;
    argv = a;
    argc = 1;
  }
  
  if (!chaperone) chaperone = scheme_default_prompt_tag;

  argv = chaperone_do_cc_guard(cc_guard, chaperone, argc, argv);

  if (argc == 1)
    return argv[0];
  else
    return scheme_values(argc, argv);
}

static Scheme_Object *call_with_prompt (int in_argc, Scheme_Object *in_argv[])
{
  Scheme_Object *v;
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object *proc = in_argv[0], *prompt_tag;
  Scheme_Prompt *prompt;
  int argc, handler_argument_error = 0;
# define QUICK_PROMPT_ARGS 3
  Scheme_Object **argv, *a[QUICK_PROMPT_ARGS], *handler;
  Scheme_Cont_Frame_Data cframe;
  Scheme_Dynamic_Wind *prompt_dw;
  int cc_count = scheme_cont_capture_count;
  Scheme_Object *chaperone = NULL, *cc_guard = scheme_false;

  argc = in_argc - 3;
  if (argc <= 0) {
    argc = 0;
    argv = NULL;
  } else {
    int i;
    if (argc <= QUICK_PROMPT_ARGS)
      argv = a;
    else
      argv = MALLOC_N(Scheme_Object *, argc);
    for (i = 0; i < argc; i++) {
      argv[i] = in_argv[i+3];
    }
  }

  scheme_check_proc_arity("call-with-continuation-prompt", argc, 0, in_argc, in_argv);
  if (in_argc > 1) {
    /* Check if the prompt tag is proxied */
    if (!SCHEME_PROMPT_TAGP(in_argv[1])) {
      if (SCHEME_NP_CHAPERONEP(in_argv[1])
          && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(in_argv[1]))) {
        chaperone = in_argv[1];
        prompt_tag = SCHEME_CHAPERONE_VAL(in_argv[1]);
      } else {
        scheme_wrong_contract("call-with-continuation-prompt", "continuation-prompt-tag?",
                              1, in_argc, in_argv);
        return NULL;
      }
    } else
      prompt_tag = in_argv[1];
    if (SAME_OBJ(prompt_tag, scheme_root_prompt_tag)) {
      root_prompt_tag_misuse("call-with-continuation-prompt");
      return NULL;
    }
  } else
    prompt_tag = scheme_default_prompt_tag;

  if (in_argc > 2) {
    if (SCHEME_TRUEP(in_argv[2]) && !SCHEME_PROCP(in_argv[2]))
      scheme_wrong_contract("call-with-continuation-prompt", "(or/c procedure? #f)", 2, in_argc, in_argv);
    handler = in_argv[2];
  } else
    handler = scheme_false;

  do {
    /* loop implements the default prompt handler */

    if (available_regular_prompt) {
      /* `call-with-continuation-prompt' is used by `with-handlers' which might
         easily occur in a loop. Try to avoid allocation, even if only for unnested
         prompts. */
      prompt = available_regular_prompt;
      available_regular_prompt = NULL;
    } else
      prompt = MALLOC_ONE_TAGGED(Scheme_Prompt);

    prompt->so.type = scheme_prompt_type;

    prompt->tag = prompt_tag;

    /* An abuse of the continuation-mark stack: to keep track of
       chaperoning guards on a continuation result, we mutate a mark
       that is keyed on prompt_cc_mark_key and that sits next to the
       prompt mark. This is an abuse, because marks are not supposed
       to be mutable, but we do that to keep the mark setting attached
       to a continuation (given that continuation marks are copied out
       and in for a saved and restored continuation). We don't run
       afoul of caching, which depends on immuatbility of marks,
       because we access the mark only by get_set_cont_mark_by_pos(). */

    scheme_push_continuation_frame(&cframe);
    scheme_set_cont_mark(prompt_cc_guard_key, cc_guard); /* see "abuse" note above */
    scheme_set_cont_mark(SCHEME_PTR_VAL(prompt_tag), (Scheme_Object *)prompt);

    /* Note: prompt save marks after the one corresponding to itself,
       so that restoring a continuation captured under the prompt
       doesn't re-install this prompt. (Instead, the prompt that applies
       is the one in the invocation context). */

    ASSERT_SUSPEND_BREAK_ZERO();

    initialize_prompt(p, prompt, NULL, 0);

    if (p->overflow) {
      ensure_overflow_id(p->overflow);
      prompt->boundary_overflow_id = p->overflow->id;
    }

    prompt->runstack_size = p->runstack_size;

    if (available_prompt_dw) {
      prompt_dw = available_prompt_dw;
      available_prompt_dw = NULL;
    } else
      prompt_dw = MALLOC_ONE_RT(Scheme_Dynamic_Wind);
#ifdef MZTAG_REQUIRED
    prompt_dw->type = scheme_rt_dyn_wind;
#endif
    prompt_dw->prompt_tag = prompt_tag;
    if (p->dw) {
      prompt_dw->next_meta = p->next_meta;
      prompt_dw->prev = p->dw;
      prompt_dw->depth = p->dw->depth + 1;
    }

    p->next_meta = 0;
    p->dw = prompt_dw;
    if (chaperone)
      prompt->has_chaperone = 1;

    v = scheme_apply_for_prompt(prompt, prompt_tag, proc, argc, argv);

    /* >> An escape can jump directly here, instead of going through the
       usual escape chain of setjmps. That means we need to reset everything,
       such as the runstack pointer. The information we need is in the
       prompt record. */

    p = scheme_current_thread;

    if (v == SCHEME_MULTIPLE_VALUES) {
      if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
        p->values_buffer = NULL;
    }

    restore_from_prompt(prompt);

    p->suspend_break = 0;

    if (!v) {
      /* There was an escape. See scheme_finish_apply_for_prompt for the possibilities. */
      if (SAME_OBJ((Scheme_Object *)p->cjs.jumping_to_continuation,
                   (Scheme_Object *)prompt)) {
        /* Jumping to this prompt, maybe to apply a different
           continuation... */
        if (p->cjs.is_escape) {
          /* Yes, a different continuation. That is, apply a non-functional continuation 
             that is based on a (potentially) different prompt. The d-w record
             is already removed as necessary at the cont call site in "eval.c". 
             Loop, in case we have a kind of tail-call to another such contionuation: */
          Scheme_Cont *target;

          target = (Scheme_Cont *)p->cjs.val;
          reset_cjs(&p->cjs);

          v = compose_continuation(target, 1, (Scheme_Object *)prompt, 0);
        
          if (v) {
            /* Got a result: */
            if (v == SCHEME_MULTIPLE_VALUES) {
              if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
                p->values_buffer = NULL;
            }
            prompt_unwind_one_dw(prompt_tag);
            handler = NULL;
          } else {
            /* Escaping, maybe to here... */
            p = scheme_current_thread;
            if (SAME_OBJ((Scheme_Object *)p->cjs.jumping_to_continuation,
                         (Scheme_Object *)prompt)) {
              /* Jump to here. If p->cjs.is_escape, then 
                 we want to apply a continuation --- again. */
              if (p->cjs.is_escape) {
                /* this should have been caught in compose_continuation */
                scheme_signal_error("escape-to-prompt escaped!");
                return NULL;
              } else {
                /* It's an abort to here, so fall though and
                   pick up the values. */
                prompt_unwind_one_dw(prompt_tag);
                v = NULL;
              }
            } else if (p->cjs.is_escape) {
              /* We're trying to get to a prompt in this meta-continuation.
                 Jump again. */
              continue_prompt_escape();
              return NULL;
            } else {
              /* Exception-level or call/ec escape. Continue jumping: */
              restore_from_prompt(prompt);
              prompt_unwind_one_dw(prompt_tag);
              scheme_longjmp(*p->error_buf, 1);
              return NULL;
            }
          }
        } else {
          /* It was an abort to here; fall through, which picks up
             p->cjs.val to deliver to the handler. First discard the
             dw record that we introduced. */
          prompt_unwind_one_dw(prompt_tag);
          v = NULL;
        }

        /* At this point, v can be non-NULL if a continuation
           delivered a value. */

        if (!v) {
          /* cancel any pending cc_guard: */
          get_set_cont_mark_by_pos(prompt_cc_guard_key, p, NULL, MZ_CONT_MARK_POS, scheme_false);

          argc = p->cjs.num_vals;

          if (argc == 1) {
            a[0] = p->cjs.val;
            argv = a;
          } else
            argv = (Scheme_Object **)p->cjs.val;

          reset_cjs(&p->cjs);

          /*
           * If the prompt tag is proxied, run the intercession function
           * and call the handler on its results
           */
          if (chaperone) {
            argv = chaperone_do_prompt_handler(chaperone, argc, argv);
          }

          if (SAME_OBJ(handler, scheme_values_proc)) {
            v = scheme_values(argc, argv);
            if (v == SCHEME_MULTIPLE_VALUES) {
              if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
                p->values_buffer = NULL;
            }
            handler = NULL;
          } else if (SCHEME_FALSEP(handler)) {
            if (argc == 1) {
              if (!scheme_check_proc_arity(NULL, 0, 0, argc, argv)) {
                /* delay error until we clean up: */
                handler_argument_error = 1;
                handler = NULL;
              } else {
                proc = a[0];
                argc = 0;
                argv = NULL;
              }
            } else {
              /* wrong number of arguments returned to default handler */
              handler_argument_error = 1;
              handler = NULL;
            }
          }
        } else {
          argc = 0;
          argv = NULL;
        }
      } else {
        /* Other error-like escape: */
        if ((p->dw != prompt_dw)
            && (!p->dw || !prompt_dw->id || (p->dw->id != prompt_dw->id))) {
          /* A full continuation jump was interrupted by an
             escape continuation jump (in a dw pre or post thunk). */
        } else
          prompt_unwind_one_dw(prompt_tag);
        scheme_longjmp(*p->error_buf, 1);
        return NULL;
      }
    } else {
      prompt_unwind_one_dw(prompt_tag);
      handler = NULL;
      argc = 0;
      argv = NULL;
    }

    cc_guard = get_set_cont_mark_by_pos(prompt_cc_guard_key, p, NULL, MZ_CONT_MARK_POS, NULL);
    if (SCHEME_FALSEP(cc_guard)) cc_guard = NULL;

    scheme_pop_continuation_frame(&cframe);

    if (cc_count == scheme_cont_capture_count) {
      if (!available_regular_prompt) {
        memset(prompt, 0, sizeof(Scheme_Prompt));
        prompt->so.type = scheme_prompt_type;
        available_regular_prompt = prompt;
      }
      if (!available_prompt_dw) {
        memset(prompt_dw, 0, sizeof(Scheme_Dynamic_Wind));
#ifdef MZTAG_REQUIRED
        prompt_dw->type = scheme_rt_dyn_wind;
#endif
        available_prompt_dw = prompt_dw;
      }
    }
  } while (handler && SCHEME_FALSEP(handler));

  if (handler_argument_error) {
    if (argc == 1) {
      scheme_check_proc_arity("default-continuation-prompt-handler", 0, 0, argc, argv);
    } else {
      scheme_wrong_return_arity("call-with-continuation-prompt", 1, argc, argv,
                                "\n  in: application of default prompt handler");
    }
  }

  if (handler) {
    return _scheme_tail_apply(handler, argc, argv);
  } else if (cc_guard) {
    if (SAME_OBJ(cc_guard, scheme_values_proc))
      cc_guard = NULL;
    if (cc_guard || chaperone)
      return do_cc_guard(v, cc_guard, chaperone);
    else
      return v;
  } else
    return v;
}

static Scheme_Object *propagate_abort(int argc, Scheme_Object **argv)
{
  Scheme_Object **argv2;

  argv2 = MALLOC_N(Scheme_Object *, argc + 1);
  memcpy(argv2 XFORM_OK_PLUS 1, argv, sizeof(Scheme_Object *) * argc);
  argv2[0] = scheme_default_prompt_tag;

  return _scheme_apply(abort_continuation_proc, argc+1, argv2);
}

static Scheme_Object *do_call_with_prompt(Scheme_Closed_Prim f, void *data, 
                                          int multi, int top_level)
{
  Scheme_Object *prim, *a[3];

  prim = scheme_make_closed_prim(f, data);
  a[0] = prim;
  a[1] = scheme_default_prompt_tag;
  a[2] = propagate_abort_prim;

  if (multi) {
    if (top_level)
      return scheme_apply_multi(call_with_prompt_proc, 3, a);
    else
      return _scheme_apply_multi(call_with_prompt_proc, 3, a);
  } else {
    if (top_level)
      return scheme_apply(call_with_prompt_proc, 3, a);
    else
      return _scheme_apply(call_with_prompt_proc, 3, a);
  }
}

Scheme_Object *scheme_call_with_prompt(Scheme_Closed_Prim f, void *data)
{
  return do_call_with_prompt(f, data, 0, 1);
}

Scheme_Object *scheme_call_with_prompt_multi(Scheme_Closed_Prim f, void *data)
{
  return do_call_with_prompt(f, data, 1, 1);
}

Scheme_Object *_scheme_call_with_prompt(Scheme_Closed_Prim f, void *data)
{
  return do_call_with_prompt(f, data, 0, 0);
}

Scheme_Object *_scheme_call_with_prompt_multi(Scheme_Closed_Prim f, void *data)
{
  return do_call_with_prompt(f, data, 1, 0);
}

Scheme_Object *scheme_compose_continuation(Scheme_Cont *cont, int num_rands, Scheme_Object *value)
{
  Scheme_Meta_Continuation *mc;
  int empty_to_next_mc;

  if (num_rands != 1) {
    value = scheme_values(num_rands, (Scheme_Object **)value);
    {
      Scheme_Thread *p = scheme_current_thread;
      if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
        p->values_buffer = NULL;
    }
  }
  cont->value = value;
  cont->common_dw_depth = -1;

  mc = scheme_current_thread->meta_continuation;
  if (mc && mc->pseudo && mc->meta_tail_pos == MZ_CONT_MARK_POS) {
    /* The existing meta-continuation is the same as the
       current continuation. Trampoline through the meta-continuation
       to implement the call as a tail call.
       We also need to propagate continuation marks here, if any,
       back to the trampoline. They get merged with the trampoline's
       meta-continuation when `cont' is applied. */
    Scheme_Thread *p = scheme_current_thread;
    Scheme_Object *cm_info;
    intptr_t findpos, bottom, pos;
    int count, mcount, i;

    p->meta_continuation = mc->next;

    bottom = (intptr_t)p->cont_mark_stack_bottom;
    count = 0;
    for (findpos = (intptr_t)MZ_CONT_MARK_STACK - 1; findpos >= bottom; findpos--) {
      GC_CAN_IGNORE Scheme_Cont_Mark *seg;

      seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
      pos = findpos & SCHEME_MARK_SEGMENT_MASK;
      if (seg[pos].pos != MZ_CONT_MARK_POS)
        break;
      count++;
    }
    mcount = 0;
    for (findpos = (intptr_t)mc->cont_mark_total; findpos--; ) {
      if (mc->cont_mark_stack_copied[findpos].pos != mc->cont_mark_pos)
        break;
      mcount++;
    }

    cm_info = scheme_make_vector((count + mcount) * 2, NULL);
    for (findpos = (intptr_t)MZ_CONT_MARK_STACK - 1, i = 0; i < count; findpos--, i++) {
      GC_CAN_IGNORE Scheme_Cont_Mark *seg;

      seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
      pos = findpos & SCHEME_MARK_SEGMENT_MASK;
      SCHEME_VEC_ELS(cm_info)[2*i] = seg[pos].key;
      SCHEME_VEC_ELS(cm_info)[(2*i)+1] = seg[pos].val;
    }
    for (findpos = (intptr_t)mc->cont_mark_total - 1, i = 0; i < mcount; findpos--, i++) {
      SCHEME_VEC_ELS(cm_info)[2*(count + i)] = mc->cont_mark_stack_copied[findpos].key;
      SCHEME_VEC_ELS(cm_info)[(2*(count + i))+1] = mc->cont_mark_stack_copied[findpos].val;
    }

    p->cjs.jumping_to_continuation = cm_info; /* vector => trampoline */
    p->cjs.alt_full_continuation = NULL;
    p->cjs.val = (Scheme_Object *)cont;
    p->cjs.num_vals = 1;
    p->cjs.is_escape = 1;
    p->cjs.skip_dws = 0;

    p->stack_start = mc->overflow->stack_start;
    p->decompose_mc = mc;

    scheme_longjmpup(&mc->overflow->jmp->cont);
    return NULL;
  } else if (mc && mc->meta_tail_pos == MZ_CONT_MARK_POS) {
    empty_to_next_mc = 1;
  } else {
    empty_to_next_mc = 0;
  }

  /* Clear to avoid retaining a chain of meta-continuationss: */
  mc = NULL;

  value = compose_continuation(cont, 0, NULL, empty_to_next_mc);
  
  scheme_current_thread->next_meta -= 1;

  if (!value) {
    /* Continue escape --- maybe a direct jump to a prompt
       in this meta-continuation. */
    Scheme_Thread *p = scheme_current_thread;
    if (p->cjs.is_escape) {
      /* We're trying to get to a prompt in this meta-continuation.
         Jump again. */
      continue_prompt_escape();
    } else {
      scheme_longjmp(*scheme_current_thread->error_buf, 1);
    }
  }

  return value;
}

static Scheme_Object *do_abort_continuation (int argc, Scheme_Object *argv[], int skip_dws)
{
  Scheme_Object *prompt_tag;
  Scheme_Prompt *prompt;
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object *a[1];
  Scheme_Object **vals;
  int is_chaperoned = 0;

  if (!SCHEME_PROMPT_TAGP(argv[0])) {
    /* Check if the prompt tag is proxied */
    if (SCHEME_NP_CHAPERONEP(argv[0])
        && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[0]))) {
      is_chaperoned = 1;
      prompt_tag = SCHEME_CHAPERONE_VAL(argv[0]);
    } else {
      scheme_wrong_contract("abort-current-continuation", "continuation-prompt-tag?",
                            0, argc, argv);
      return NULL;
    }
  } else
    prompt_tag = argv[0];

  if (SAME_OBJ(prompt_tag, scheme_root_prompt_tag)) {
    root_prompt_tag_misuse("abort-current-continuation");
    return NULL;
  }

  prompt = (Scheme_Prompt *)scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag));
  if (!prompt && SAME_OBJ(scheme_default_prompt_tag, prompt_tag))
    prompt = original_default_prompt;

  if (!prompt) {
    scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
                     "abort-current-continuation: continuation includes no prompt with the given tag\n"
                     "  tag: %V",
                     prompt_tag);
    return NULL;
  }

  if (argc == 2) {
    p->cjs.num_vals = 1;
    /*
     * If the prompt tag isn't proxied, continue with the aborted value.
     * Otherwise, run the intercession function and then continue with its
     * new results.
     */
    if (!is_chaperoned)
      p->cjs.val = argv[1];
    else {
      a[0] = argv[1];
      vals = chaperone_do_abort(argv[0], 1, a);
      p->cjs.val = (Scheme_Object *)vals[0];
    }
  } else {
    int i;
    vals = MALLOC_N(Scheme_Object *, argc - 1);
    for (i = argc; i-- > 1; ) {
      vals[i-1] = argv[i];
    }
    p->cjs.num_vals = argc - 1;
    if (!is_chaperoned)
      p->cjs.val = (Scheme_Object *)vals;
    else {
      vals = chaperone_do_abort(argv[0], argc - 1, vals);
      p->cjs.val = (Scheme_Object *)vals;
    }
  }
  p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;
  p->cjs.alt_full_continuation = NULL;
  p->cjs.skip_dws = skip_dws;

  scheme_longjmp(*p->error_buf, 1);

  return NULL;
}

static Scheme_Object *abort_continuation (int argc, Scheme_Object *argv[])
{
  return do_abort_continuation(argc, argv, 0);
}

Scheme_Object *scheme_abort_continuation_no_dws (Scheme_Object *pt, Scheme_Object *v)
{
  /* This function is useful for GRacket-like extensions of Racket that need to
     implement something like subtreads through composable continuations. */
  Scheme_Object *a[2];

  a[0] = pt;
  a[1] = v;

  return do_abort_continuation(2, a, 1);
}

static Scheme_Object *unsafe_abort_continuation_no_dws(int argc, Scheme_Object *argv[])
{
  /* See scheme_abort_continuation_no_dws() */
  return do_abort_continuation(argc, argv, 1);
}

static Scheme_Object *do_call_with_control (int argc, Scheme_Object *argv[], int no_dws)
{
  Scheme_Object *prompt_tag;
  Scheme_Object *a[3];

  scheme_check_proc_arity("call-with-composable-continuation", 1, 0, argc, argv);
  if (argc > 1) {
    prompt_tag = argv[1];
    if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(prompt_tag))) {
      if (SCHEME_NP_CHAPERONEP(prompt_tag)
          && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(prompt_tag)))
        prompt_tag = SCHEME_CHAPERONE_VAL(prompt_tag);
      else {
        scheme_wrong_contract("call-with-composable-continuation", "continuation-prompt-tag?",
                              1, argc, argv);
        return NULL;
      }
    }
    if (SAME_OBJ(prompt_tag, scheme_root_prompt_tag)) {
      root_prompt_tag_misuse("abort-current-continuation");
      return NULL;
    }
  } else
    prompt_tag = scheme_default_prompt_tag;

  a[0] = argv[0];
  a[1] = prompt_tag;
  a[2] = (no_dws ? scheme_true : scheme_false);

  /* Trampoline to internal_call_cc. This trampoline ensures that
     the runstack is flushed before we try to grab the continuation. */
  return _scheme_tail_apply(internal_call_cc_prim, 3, a);
}

static Scheme_Object *call_with_control (int argc, Scheme_Object *argv[])
{
  return do_call_with_control(argc, argv, 0);
}

Scheme_Object *scheme_call_with_composable_no_dws (Scheme_Object *proc, Scheme_Object *pt)
{
  /* Works with scheme_abort_continuation_no_dws() above. */
  Scheme_Object *a[2];

  a[0] = proc;
  a[1] = pt;

  return do_call_with_control(2, a, 1);
}

static Scheme_Object *unsafe_call_with_control_no_dws(int argc, Scheme_Object *argv[])
{
  /* See scheme_call_with_composable_no_dws() */
  return do_call_with_control(argc, argv, 1);
}

static Scheme_Object *unsafe_root_continuation_prompt_tag(int argc, Scheme_Object *argv[])
{
  return scheme_root_prompt_tag;
}

static Scheme_Cont_Mark *copy_cm_shared_on_write(Scheme_Meta_Continuation *mc)
{
  Scheme_Cont_Mark *cp;

  cp = MALLOC_N(Scheme_Cont_Mark, mc->cont_mark_total);
  memcpy(cp, mc->cont_mark_stack_copied, mc->cont_mark_total * sizeof(Scheme_Cont_Mark));
  mc->cont_mark_stack_copied = cp;
  mc->cm_shared = 0;

  return cp;
}

static Scheme_Object *continuation_marks(Scheme_Thread *p,
					 Scheme_Object *_cont,
					 Scheme_Object *econt,
                                         Scheme_Meta_Continuation *mc,
                                         Scheme_Object *prompt_tag,
                                         const char *who,
					 int just_chain,
                                         int use_boundary_prompt)
     /* cont => p is not used */
{
  Scheme_Cont *cont = (Scheme_Cont *)_cont, *top_cont;
  Scheme_Cont_Mark_Chain *first = NULL, *last = NULL;
  Scheme_Cont_Mark_Set *set;
  Scheme_Object *cache, *nt;
  intptr_t findpos, bottom;
  intptr_t cmpos, first_cmpos = 0, cdelta = 0;
  int found_tag = 0, at_mc_boundary = 0;

  if (SAME_OBJ(prompt_tag, scheme_root_prompt_tag))
    prompt_tag = NULL;

  if (cont
      && (use_boundary_prompt || !cont->composable)
      && SAME_OBJ(cont->prompt_tag, prompt_tag))
    found_tag = 1;
  if (!prompt_tag)
    found_tag = 1;

  do {
    if (econt) {
      findpos = (intptr_t)((Scheme_Escaping_Cont *)econt)->envss.cont_mark_stack;
      cmpos = (intptr_t)((Scheme_Escaping_Cont *)econt)->envss.cont_mark_pos;
      if (mc) {
        cdelta = mc->cont_mark_offset;
        bottom = 0;
      } else
        bottom = p->cont_mark_stack_bottom;
    } else if (cont) {
      findpos = (intptr_t)cont->ss.cont_mark_stack;
      cmpos = (intptr_t)cont->ss.cont_mark_pos;
      cdelta = cont->cont_mark_offset;
      bottom = 0;
    } else if (mc) {
      findpos = (intptr_t)mc->cont_mark_stack;
      cmpos = (intptr_t)mc->cont_mark_pos;
      cdelta = mc->cont_mark_offset;
      bottom = 0;
      at_mc_boundary = 1;
    } else {
      findpos = (intptr_t)MZ_CONT_MARK_STACK;
      cmpos = (intptr_t)MZ_CONT_MARK_POS;
      if (!p->cont_mark_stack_segments)
        findpos = 0;
      bottom = p->cont_mark_stack_bottom;
    }

    top_cont = cont;

    while (findpos-- > bottom) {
      Scheme_Cont_Mark *find;
      intptr_t pos;

      if (cont) {
        while (findpos < cdelta) {
          if (!cont->runstack_copied) {
            /* Current cont was just a mark-stack variation of
               next cont, so skip the next cont. */
            cont = cont->buf_ptr->buf.cont;
          }
          cont = cont->buf_ptr->buf.cont;
          if (cont)
            cdelta = cont->cont_mark_offset;
          else
            break;
        }
        if (!cont)
          break;
        find = cont->cont_mark_stack_copied;
        pos = findpos - cdelta;
      } else if (mc) {
        if (findpos < cdelta)
          break;
        find = mc->cont_mark_stack_copied;
        pos = findpos - cdelta;
      } else {
        GC_CAN_IGNORE Scheme_Cont_Mark *seg;

        seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
        pos = findpos & SCHEME_MARK_SEGMENT_MASK;
        find = seg;
      }

      /* A cache is one of:
          NULL (empty)
          #f (empty)
          hash-table: maps prompt tag to tag-cache
          chain : for default_scheme_prompt_tag
          (vector chain key val depth) : chain is for default_scheme_prompt_tag,
                                         key+val+depth is for !prompt_tag

          A tag-cache is one of:
          chain : the chain we're looking for
          (vector chain key val depth) : key = NULL implies that val is
                                         a table of mappings from keys to (cons val depth)s
      */

      if (prompt_tag && (find[pos].key == SCHEME_PTR_VAL(prompt_tag))) {
        found_tag = 1;
        /* Break out of outer loop, too: */
        mc = NULL;
        p = NULL;
        econt = NULL;
        cont = NULL;
        top_cont = NULL;
        break;
      }

      cache = find[pos].cache;
      if (cache) {
        if (SCHEME_FALSEP(cache))
          cache = NULL;
        if (cache) {
          if (SCHEME_HASHTP(cache))
            cache = scheme_eq_hash_get((Scheme_Hash_Table *)cache, prompt_tag ? prompt_tag : scheme_false);
          else if (prompt_tag != scheme_default_prompt_tag)
            cache = NULL;
        }
        if (cache && SCHEME_VECTORP(cache)) {
          cache = SCHEME_VEC_ELS(cache)[0];
        }
      }

      if (cache) {
        if (((Scheme_Cont_Mark_Chain *)cache)->key) {
          if (last) {
            last->next = (Scheme_Cont_Mark_Chain *)cache;
            if (at_mc_boundary) {
              SCHEME_MARK_CHAIN_FLAG(last) |= 0x1;
              at_mc_boundary = 0;
            }
          } else {
            first = (Scheme_Cont_Mark_Chain *)cache;
            first_cmpos = cmpos;
          }
          
          found_tag = 1; /* cached => tag is there */
        } else {
          /* bogus: tag wasn't there when we cached this chain */
        }

        /* Break out of outer loop, too: */
        mc = NULL;
        p = NULL;
        econt = NULL;
        cont = NULL;
        top_cont = NULL;

        break;
      } else {
        Scheme_Cont_Mark_Chain *pr;
        pr = MALLOC_ONE_RT(Scheme_Cont_Mark_Chain);
        pr->iso.so.type = scheme_cont_mark_chain_type;
        pr->key = find[pos].key;
        pr->val = find[pos].val;
        pr->pos = find[pos].pos;
        pr->next = NULL;
        if (mc) {
          if (mc->cm_shared)
            find = copy_cm_shared_on_write(mc);
          mc->cm_caches = 1;
        }
        cache = find[pos].cache;
        if (cache && !SCHEME_FALSEP(cache)) {
          if (SCHEME_HASHTP(cache)) {
            Scheme_Hash_Table *ht = (Scheme_Hash_Table *)cache;
            cache = scheme_eq_hash_get(ht, prompt_tag ? prompt_tag : scheme_false);
            if (!cache) {
              scheme_hash_set(ht, prompt_tag ? prompt_tag : scheme_false, (Scheme_Object *)pr);
            } else {
              /* cache must be a vector */
              SCHEME_VEC_ELS(cache)[0] = (Scheme_Object *)pr;
            }
          } else if (!SCHEME_VECTORP(cache)) {
            /* cache is a chain and the tag is not the default prompt tag */
            Scheme_Hash_Table *ht;
            ht = scheme_make_hash_table(SCHEME_hash_ptr);
            scheme_hash_set(ht, scheme_default_prompt_tag, cache);
            scheme_hash_set(ht, prompt_tag ? prompt_tag : scheme_false, (Scheme_Object *)pr);
            find[pos].cache = (Scheme_Object *)ht;
          } else {
            /* cache must be a vector */
            if (prompt_tag == scheme_default_prompt_tag)
              SCHEME_VEC_ELS(cache)[0] = (Scheme_Object *)pr;
            else {
              /* Need to split up the default and NULL tags. Don't
                 try to use cache for just the null tag, in case
                 it's use by other copies. */
              Scheme_Hash_Table *ht;
              Scheme_Object *vec;
              ht = scheme_make_hash_table(SCHEME_hash_ptr);
              vec = scheme_make_vector(4, NULL);
              SCHEME_VEC_ELS(vec)[1] = SCHEME_VEC_ELS(cache)[1];
              SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(cache)[2];
              SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(cache)[3];
              scheme_hash_set(ht, scheme_false, vec);
              if (!prompt_tag)
                SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)pr;
              else
                scheme_hash_set(ht, prompt_tag, (Scheme_Object *)pr);
              find[pos].cache = (Scheme_Object *)ht;
            }
          }
        } else if (prompt_tag == scheme_default_prompt_tag) {
          find[pos].cache = (Scheme_Object *)pr;
        } else {
          cache = (Scheme_Object *)scheme_make_hash_table(SCHEME_hash_ptr);
          scheme_hash_set((Scheme_Hash_Table *)cache, 
                          prompt_tag ? prompt_tag : scheme_false, 
                          (Scheme_Object *)pr);
          find[pos].cache = cache;
        }
        if (last) {
          last->next = pr;
          if (at_mc_boundary) {
            SCHEME_MARK_CHAIN_FLAG(last) |= 1;
            at_mc_boundary = 0;
          }
        } else {
          first = pr;
          first_cmpos = cmpos;
        }

        last = pr;
      }
    }

    if (mc) {
      mc = mc->next;
    } else if (top_cont) {
      mc = top_cont->meta_continuation;
    } else if (econt) {
      mc = p->meta_continuation;
    } else if (p) {
      mc = p->meta_continuation;
    }
    cont = NULL;
    econt = NULL;
    p = NULL;
  } while (mc);

  if (!found_tag) {
    if (!SAME_OBJ(prompt_tag, scheme_default_prompt_tag)) {
      /* The chain is cached. Destroy it, so that future cache references
         will indicate that the tag is not present (as opposed to delivering
         the bogus chain). */
      while (first) {
        first->key = NULL;
        first = first->next;
      }
      if (!who)
        return NULL;
      scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
                       "%s: no corresponding prompt in the continuation\n"
                       "  tag: %V",
                       who, prompt_tag);
    } else if (!use_boundary_prompt) {
      /* Don't treat default tag as found */
      return NULL;
    }
  }

  if (just_chain)
    return (Scheme_Object *)first;

#ifdef MZ_USE_JIT
  if (_cont)
    nt = ((Scheme_Cont *)_cont)->native_trace;
  else if (econt)
    nt = ((Scheme_Escaping_Cont *)econt)->native_trace;
  else
    nt = scheme_native_stack_trace();
#else
  nt = NULL;
#endif

  if (first && (first_cmpos < first->pos)) {
    /* Don't use scheme_signal_error(), because that will try to get
       a continuation mark... */
    scheme_log_abort("internal error: bad mark-stack position");
    abort();
  }

  set = MALLOC_ONE_TAGGED(Scheme_Cont_Mark_Set);
  set->so.type = scheme_cont_mark_set_type;
  set->chain = first;
  set->cmpos = first_cmpos;
  set->native_stack_trace = nt;

  return (Scheme_Object *)set;
}

static Scheme_Object *make_empty_marks()
{
  /* empty marks */
  Scheme_Cont_Mark_Set *set;
  
  set = MALLOC_ONE_TAGGED(Scheme_Cont_Mark_Set);
  set->so.type = scheme_cont_mark_set_type;
  set->chain = NULL;
  set->cmpos = 1;
  set->native_stack_trace = NULL;
  
  return (Scheme_Object *)set;
}

Scheme_Object *scheme_current_continuation_marks_as(const char *who, Scheme_Object *prompt_tag)
/* if who is NULL, the result can be NULL instead of a prompt-tag error */
{
  return continuation_marks(scheme_current_thread, NULL, NULL, NULL, 
                            prompt_tag ? prompt_tag : scheme_default_prompt_tag,
                            who,
                            0, 1);
}

Scheme_Object *scheme_current_continuation_marks(Scheme_Object *prompt_tag)
{
  return scheme_current_continuation_marks_as("continuation-marks", prompt_tag);
}

Scheme_Object *scheme_all_current_continuation_marks()
{
  return continuation_marks(scheme_current_thread, NULL, NULL, NULL, 
                            NULL,
                            "continuation-marks",
                            0, 1);
}

Scheme_Cont_Mark_Chain *current_mark_chain(const char *who, Scheme_Object *prompt_tag) {
  return (Scheme_Cont_Mark_Chain *)continuation_marks(scheme_current_thread, NULL, NULL, NULL, 
                                                      prompt_tag,
                                                      who,
                                                      1, 1);
}

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

  if (argc) {
    prompt_tag = argv[0];
    if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(prompt_tag))) {
      if (SCHEME_NP_CHAPERONEP(prompt_tag)
          && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(prompt_tag)))
        prompt_tag = SCHEME_CHAPERONE_VAL(prompt_tag);
      else
        scheme_wrong_contract("current-continuation-marks", "continuation-prompt-tag?",
                              0, argc, argv);
    }

    if (!SAME_OBJ(scheme_default_prompt_tag, prompt_tag)
        && !SAME_OBJ(scheme_root_prompt_tag, prompt_tag))
      if (!scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag))) {
        scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
                         "current-continuation-marks: no corresponding prompt in the continuation\n"
                         "  prompt tag: %V",
                         prompt_tag);
      }
  }

  return scheme_current_continuation_marks(argc ? prompt_tag : NULL);
}

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

  if (SCHEME_TRUEP(argv[0])
      && !SCHEME_CONTP(argv[0]) && !SCHEME_ECONTP(argv[0]) && !SCHEME_THREADP(argv[0]))
    scheme_wrong_contract("continuation-marks", "(or/c continuation? thread? #f)", 0, argc, argv);

  if (argc > 1) {
    if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[1]))) {
      if (SCHEME_NP_CHAPERONEP(argv[1])
          && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[1])))
        prompt_tag = SCHEME_CHAPERONE_VAL(argv[1]);
      else {
        scheme_wrong_contract("continuation-marks", "continuation-prompt-tag?",
                              1, argc, argv);
        return NULL;
      }
    } else
      prompt_tag = argv[1];
  } else
    prompt_tag = scheme_default_prompt_tag;

  if (SCHEME_FALSEP(argv[0])) {
    return make_empty_marks();
  } else if (SCHEME_ECONTP(argv[0])) {
    if (!scheme_escape_continuation_ok(argv[0])) {
      scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
                       "continuation-marks: escape continuation not in the current thread's continuation\n"
                       "  escape continuation: %V", argv[0]);
      return NULL;
    } else {
      Scheme_Meta_Continuation *mc;
      mc = scheme_get_meta_continuation(argv[0]);

      return continuation_marks(scheme_current_thread, NULL, argv[0], mc, prompt_tag, 
                                "continuation-marks", 0, 1);
    }
  } else if (SCHEME_THREADP(argv[0])) {
    Scheme_Thread *t = (Scheme_Thread *)argv[0];
    Scheme_Object *m;

    while (t->nestee) {
      t = t->nestee;
    }

    if (SAME_OBJ(t, scheme_current_thread))
      return scheme_current_continuation_marks(prompt_tag);

    while (t->return_marks_to) {
      scheme_thread_block(0.0);
    }

    if (!(t->running & MZTHREAD_RUNNING)) {
      return make_empty_marks();
    } else {
      scheme_start_atomic(); /* just in case */

      t->return_marks_to = scheme_current_thread;
      t->returned_marks = prompt_tag;
      scheme_swap_thread(t);
      
      m = t->returned_marks;
      t->returned_marks = NULL;
      
      scheme_end_atomic_no_swap();

      if (!m)
        scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
                         "%s: no corresponding prompt in the continuation\n"
                         "  tag: %V",
                         "continuation-marks", prompt_tag);

      return m;
    }
  } else {
    return continuation_marks(NULL, argv[0], NULL, NULL, prompt_tag, 
                              "continuation-marks", 0, 1);
  }
}

static Scheme_Object *
cc_marks_p(int argc, Scheme_Object *argv[])
{
  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type))
    return scheme_false;
  else
    return scheme_true;
}

static Scheme_Object *
extract_cc_marks(int argc, Scheme_Object *argv[])
{
  Scheme_Cont_Mark_Chain *chain;
  Scheme_Object *first = scheme_null, *last = NULL, *key, *prompt_tag;
  Scheme_Object *v;
  Scheme_Object *pr;
  int is_chaperoned = 0;

  if (SCHEME_TRUEP(argv[0])
      && !SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) {
    scheme_wrong_contract("continuation-mark-set->list", "(or/c continuation-mark-set? #f)", 0, argc, argv);
    return NULL;
  }
  if (argc > 2) {
    if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[2]))) {
      if (SCHEME_NP_CHAPERONEP(argv[2])
          && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[2])))
        prompt_tag = SCHEME_CHAPERONE_VAL(argv[2]);
      else {
        scheme_wrong_contract("continuation-mark-set->list", "continuation-prompt-tag?",
                              2, argc, argv);
        return NULL;
      }
    } else
      prompt_tag = argv[2];
  } else
    prompt_tag = scheme_default_prompt_tag;

  if (SCHEME_FALSEP(argv[0]))
    chain = current_mark_chain("continuation-mark-set->list", prompt_tag);
  else
    chain = ((Scheme_Cont_Mark_Set *)argv[0])->chain;
  key = argv[1];

  if ((key == scheme_parameterization_key)
      || (key == scheme_break_enabled_key)
      || (key == scheme_exn_handler_key)) {
    scheme_signal_error("continuation-mark-set->list: secret key leaked!");
    return NULL;
  }

  if (SCHEME_NP_CHAPERONEP(key)
      && SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(key))) {
    is_chaperoned = 1;
    key = SCHEME_CHAPERONE_VAL(key);
  }

  prompt_tag = SCHEME_PTR_VAL(prompt_tag);

  while (chain) {
    if (chain->key == key) {
      if (is_chaperoned)
        v = scheme_chaperone_do_continuation_mark("continuation-mark-set->list",
                                                  1, argv[1], chain->val);
      else
        v = chain->val;
      pr = scheme_make_pair(v, scheme_null);
      if (last)
	SCHEME_CDR(last) = pr;
      else
	first = pr;
      last = pr;
    } else if (chain->key == prompt_tag)
      break;

    chain = chain->next;
  }

  return first;
}

static Scheme_Object *
iterate_cc_markses(const char *who,
                   Scheme_Object *prompt_tag, Scheme_Object *none,
                   intptr_t len, Scheme_Object **keys,
                   Scheme_Cont_Mark_Chain **_chain)
{
  Scheme_Cont_Mark_Chain *chain = *_chain;
  intptr_t last_pos = -1, i;
  Scheme_Object *vals = NULL;
  
  prompt_tag = SCHEME_PTR_VAL(prompt_tag);

  while (chain) {
    if (vals && (last_pos != chain->pos)) {
      *_chain = chain;
      return vals;
    }
    
    for (i = 0; i < len; i++) {
      int is_chaperoned = 0;
      Scheme_Object *orig_key, *val;

      if (SCHEME_MARK_CHAIN_FLAG(chain) & 0x1)
        last_pos = -1;
      if (SCHEME_NP_CHAPERONEP(keys[i])
          && SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(keys[i]))) {
        is_chaperoned = 1;
        orig_key = keys[i];
        keys[i] = SCHEME_CHAPERONE_VAL(orig_key);
      } else
        orig_key = NULL;
      if (SAME_OBJ(chain->key, keys[i])) {
	intptr_t pos;
	pos = (intptr_t)chain->pos;
	if (!vals) {
	  vals = scheme_make_vector(len, none);
	  last_pos = pos;
        }
        if (is_chaperoned) {
          val = scheme_chaperone_do_continuation_mark(who,
                                                      1, orig_key, chain->val);
          SCHEME_VEC_ELS(vals)[i] = val;
        } else
	  SCHEME_VEC_ELS(vals)[i] = chain->val;
      }
    }

    if (SAME_OBJ(chain->key, prompt_tag))
      break;
    
    chain = chain->next;
  }

  *_chain = NULL;

  return vals;
}

static Scheme_Object *iterate_step(void *data, int argc, Scheme_Object *argv[])
{
  Scheme_Cont_Mark_Chain *chain = ((void **)data)[0];
  void **clos = ((void **)data)[1], **new_state;
  Scheme_Object *vals, *a[2];
  Scheme_Object *prompt_tag = ((Scheme_Object **)clos)[0];
  Scheme_Object **keys = ((Scheme_Object ***)clos)[1];
  intptr_t len = SCHEME_INT_VAL(((Scheme_Object **)clos)[2]);
  Scheme_Object *none = ((Scheme_Object **)clos)[3];

  if (!chain) {
    a[0] = scheme_false;
    new_state = data;
  } else {
    vals = iterate_cc_markses("mark-list*-iterator", prompt_tag, none, len, keys, &chain);
    if (!vals)
      a[0] = scheme_false;
    else
      a[0] = vals;
    new_state = MALLOC_N(void*, 2);
    new_state[0] = chain;
    new_state[1] = clos;
  }

  a[1] = scheme_make_closed_prim_w_arity(iterate_step, new_state, "mark-list*-iterator", 0, 0);
  return scheme_values(2, a);
}

static Scheme_Object *
do_extract_cc_markses(const char *who, int argc, Scheme_Object *argv[], int iterator)
{
  Scheme_Cont_Mark_Chain *chain;
  Scheme_Object *first = scheme_null, *last = NULL;
  Scheme_Object *pr, **keys, *vals, *none, *prompt_tag;
  intptr_t len, i;

  if (SCHEME_TRUEP(argv[0])
      && !SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) {
    scheme_wrong_contract(who, "(or/c continuation-mark-set? #f)", 0, argc, argv);
    return NULL;
  }
  len = scheme_proper_list_length(argv[1]);
  if (len < 0) {
    scheme_wrong_contract(who, "list?", 1, argc, argv);
    return NULL;
  }
  if (argc > 2)
    none = argv[2];
  else
    none = scheme_false;
  if (argc > 3) {
    if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[3]))) {
      if (SCHEME_NP_CHAPERONEP(argv[3])
          && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[3])))
        prompt_tag = SCHEME_CHAPERONE_VAL(argv[3]);
      else {
        scheme_wrong_contract(who, "continuation-prompt-tag?",
                              3, argc, argv);
        return NULL;
      }
    } else
      prompt_tag = argv[3];
  } else
    prompt_tag = scheme_default_prompt_tag;

  keys = MALLOC_N(Scheme_Object *, len);
  for (pr = argv[1], i = 0; SCHEME_PAIRP(pr); pr = SCHEME_CDR(pr), i++) {
    keys[i] = SCHEME_CAR(pr);
    if ((keys[i] == scheme_parameterization_key)
	|| (keys[i] == scheme_break_enabled_key)) {
      scheme_signal_error("%s: misuse of primitive key", who);
      return NULL;
    }
  }

  if (SCHEME_FALSEP(argv[0]))
    chain = current_mark_chain(who, prompt_tag);
  else
    chain = ((Scheme_Cont_Mark_Set *)argv[0])->chain;

  if (iterator) {
    void **clos, **state;
    clos = MALLOC_N(void*, 4);
    clos[0] = prompt_tag;
    clos[1] = keys;
    clos[2] = scheme_make_integer(len);
    clos[3] = none;
    state = MALLOC_N(void*, 2);
    state[0] = chain;
    state[1] = clos;
    return scheme_make_closed_prim_w_arity(iterate_step, state, "mark-list*-iterator", 0, 0);
  } else {
    while (chain) {
      vals = iterate_cc_markses(who, prompt_tag, none, len, keys, &chain);
      if (vals) {
        pr = scheme_make_pair(vals, scheme_null);
        if (last)
          SCHEME_CDR(last) = pr;
        else
          first = pr;
        last = pr;
      }
    }

    return first;
  }
}

static Scheme_Object *
extract_cc_markses(int argc, Scheme_Object *argv[])
{
  return do_extract_cc_markses("continuation-mark-set->list*", argc, argv, 0);
}

static Scheme_Object *
extract_cc_iterator(int argc, Scheme_Object *argv[])
{
  return do_extract_cc_markses("continuation-mark-set->iterator", argc, argv, 1);
}

Scheme_Object *
scheme_get_stack_trace(Scheme_Object *mark_set)
{
  Scheme_Object *l, *n, *m, *name, *loc;
  Scheme_Object *a[2];

  l = ((Scheme_Cont_Mark_Set *)mark_set)->native_stack_trace;

  if (!l) {
    a[0] = mark_set;
    a[1] = scheme_stack_dump_key;
    
    l = extract_cc_marks(2, a);
  } else {
    /* Copy l: */
    Scheme_Object *first = scheme_null, *last = NULL;
    while (SCHEME_PAIRP(l)) {
      n = scheme_make_pair(SCHEME_CAR(l), scheme_null);
      if (last)
	SCHEME_CDR(last) = n;
      else
	first = n;
      last = n;
      l = SCHEME_CDR(l);
    }
    l = first;
  }

  /* Filter out NULLs */
  while (SCHEME_PAIRP(l) && !SCHEME_CAR(l)) {
    l = SCHEME_CDR(l);
  }
  for (n = l; SCHEME_PAIRP(n); ) { 
    m = SCHEME_CDR(n);
    if (SCHEME_NULLP(m))
      break;
    if (SCHEME_CAR(m)) {
      n = m;
    } else {
      SCHEME_CDR(n) = SCHEME_CDR(m);
    }
  }

  /* Make srclocs */
  for (n = l; SCHEME_PAIRP(n); n = SCHEME_CDR(n)) { 
    name = SCHEME_CAR(n);
    if (SCHEME_VECTORP(name)) {
      loc = scheme_make_location(SCHEME_VEC_ELS(name)[1],
				 SCHEME_VEC_ELS(name)[2],
				 SCHEME_VEC_ELS(name)[3],
				 SCHEME_VEC_ELS(name)[4],
				 SCHEME_VEC_ELS(name)[5]);
      if (SCHEME_TRUEP(SCHEME_VEC_ELS(name)[6]))
	name = scheme_make_pair(scheme_false, loc);
      else
	name = scheme_make_pair(SCHEME_VEC_ELS(name)[0], loc);
    } else if (SCHEME_PAIRP(name) && SAME_OBJ(SCHEME_CDR(name), scheme_true)) {
      /* a pair with #t we're running a module body */
      const char *what;

      what = "[running body]";

      name = SCHEME_CAR(name);
      loc = scheme_make_location(name, scheme_false, scheme_false, scheme_false, scheme_false);

      name = scheme_intern_symbol(what);
      name = scheme_make_pair(name, loc);
    } else {
      name = scheme_make_pair(name, scheme_false);
    }
    SCHEME_CAR(n) = name;
  }

  return l;
}

static Scheme_Object *
extract_cc_proc_marks(int argc, Scheme_Object *argv[])
{
  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) {
    scheme_wrong_contract("continuation-mark-set->context", "continuation-mark-set?", 0, argc, argv);
    return NULL;
  }

  return scheme_get_stack_trace(argv[0]);
}

XFORM_NONGCING static Scheme_Object *default_mark_value(Scheme_Object *key)
{
  if (key == scheme_parameterization_key)
    return (Scheme_Object *)scheme_current_thread->init_config;
  else if (key == scheme_break_enabled_key)
    return scheme_current_thread->init_break_cell;
  
  return NULL;
}

static Scheme_Object *
scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key_arg, 
                                     Scheme_Object *prompt_tag, Scheme_Meta_Continuation **_meta,
                                     MZ_MARK_POS_TYPE *_vpos)
{
  Scheme_Object *key = key_arg;

  if (prompt_tag && SAME_OBJ(prompt_tag, SCHEME_PTR_VAL(scheme_root_prompt_tag)))
    prompt_tag = NULL;

  if (SCHEME_NP_CHAPERONEP(key)
      && SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(key))) {
    key = SCHEME_CHAPERONE_VAL(key);
  }

  if (mark_set) {
    Scheme_Cont_Mark_Chain *chain;
    chain = ((Scheme_Cont_Mark_Set *)mark_set)->chain;
    while (chain) {
      if (chain->key == key)
        if (key_arg != key)
          return scheme_chaperone_do_continuation_mark("continuation-mark-set-first",
                                                       1, key_arg, chain->val);
        else
	  return chain->val;
      else if (SAME_OBJ(chain->key, prompt_tag))
        break;
      else 
	chain = chain->next;
    }
  } else {
    intptr_t findpos, bottom, startpos;
    intptr_t pos;
    Scheme_Object *val = NULL;
    MZ_MARK_POS_TYPE vpos = 0;
    Scheme_Object *cache;
    Scheme_Meta_Continuation *mc = NULL;
    Scheme_Cont_Mark *seg;
    Scheme_Thread *p = scheme_current_thread;

    do {
      if (mc) {
        startpos = mc->cont_mark_total;
        bottom = 0;
      } else {
        startpos = (intptr_t)MZ_CONT_MARK_STACK;
        bottom = p->cont_mark_stack_bottom;
      }

      findpos = startpos;

      /* Search mark stack, checking caches along the way: */
      while (findpos-- > bottom) {
        if (mc) {
          seg = mc->cont_mark_stack_copied;
          pos = findpos;
        } else {
          seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
          pos = findpos & SCHEME_MARK_SEGMENT_MASK;
        }

        if (SAME_OBJ(seg[pos].key, key)) {
          val = seg[pos].val;
          vpos = seg[pos].pos;
          break;
        } else if (SAME_OBJ(seg[pos].key, prompt_tag)) {
          break;
        } else {
          cache = seg[pos].cache;
          if (cache && SCHEME_HASHTP(cache))
            cache = scheme_eq_hash_get((Scheme_Hash_Table *)cache, 
                                    prompt_tag ? prompt_tag : scheme_false);
          else if (prompt_tag)
            cache = NULL;
          if (cache && SCHEME_VECTORP(cache)) {
            /* If slot 1 has a key, this cache has just one key--value
               pair. Otherwise, slot 2 is a hash table. */
            if (SCHEME_VEC_ELS(cache)[1]) {
              if (SAME_OBJ(SCHEME_VEC_ELS(cache)[1], key)) {
                val = SCHEME_VEC_ELS(cache)[2];
                vpos = (MZ_MARK_POS_TYPE)SCHEME_VEC_ELS(cache)[3];
                break;
              }
            } else {
              Scheme_Hash_Table *ht;
              ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(cache)[2];
              val = scheme_eq_hash_get(ht, key);
              if (val) {
                vpos = (MZ_MARK_POS_TYPE)SCHEME_CDR(val);
                val = SCHEME_CAR(val);
                break;
              }
            }
          }
	}
      }

      if (key_arg != key && val != NULL)
        val = scheme_chaperone_do_continuation_mark("continuation-mark-set-first", 1, key_arg, val);

      pos = startpos - findpos;
      if (pos > MARK_CACHE_THRESHOLD) {
        pos >>= 1;
        findpos = findpos + pos;
        if (mc) {
          seg = mc->cont_mark_stack_copied;
          pos = findpos;
        } else {
          seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
          pos = findpos & SCHEME_MARK_SEGMENT_MASK;
        }

        /* See continuation_marks() for information on what
           cache can be: */
        cache = seg[pos].cache;
        {
          Scheme_Hash_Table *cht;
          if (cache && SCHEME_HASHTP(cache)) {
            cht = (Scheme_Hash_Table *)cache;
            cache = scheme_eq_hash_get(cht, prompt_tag ? prompt_tag : scheme_false);
          } else if (prompt_tag) {
            cht = scheme_make_hash_table(SCHEME_hash_ptr);
            if (cache) {
              if (SCHEME_VECTORP(cache)) {
                Scheme_Object *vec;
                if (SCHEME_VEC_ELS(cache)[0])
                  scheme_hash_set(cht, scheme_default_prompt_tag, SCHEME_VEC_ELS(cache)[0]);
                /* Don't try to re-use cache just for the null key */
                vec = scheme_make_vector(4, NULL);
                SCHEME_VEC_ELS(vec)[1] = SCHEME_VEC_ELS(cache)[1];
                SCHEME_VEC_ELS(vec)[2] = SCHEME_VEC_ELS(cache)[2];
                SCHEME_VEC_ELS(vec)[3] = SCHEME_VEC_ELS(cache)[3];
                scheme_hash_set(cht, scheme_false, vec);
              } else {
                scheme_hash_set(cht, scheme_default_prompt_tag, cache);
              }
              cache = NULL;
            }
            seg[pos].cache = (Scheme_Object *)cht;
          } else
            cht = NULL;

          if (!cache || !SCHEME_VECTORP(cache)) {
            /* No cache so far, so map one key */
            cache = scheme_make_vector(4, NULL);
            SCHEME_VEC_ELS(cache)[1] = key;
            SCHEME_VEC_ELS(cache)[2] = val;
            SCHEME_VEC_ELS(cache)[3] = (Scheme_Object *)vpos;
            if (cht) {
              scheme_hash_set(cht, prompt_tag ? prompt_tag : scheme_false, cache);
            } else {
              if (seg[pos].cache && !SCHEME_FALSEP(seg[pos].cache))
                SCHEME_VEC_ELS(cache)[0] = seg[pos].cache;
              seg[pos].cache = cache;
            }
          } else {
            if (SCHEME_VEC_ELS(cache)[1]) {
              /* More than one cached key, now; create hash table */
              Scheme_Hash_Table *ht;
              ht = scheme_make_hash_table(SCHEME_hash_ptr);
              scheme_hash_set(ht, key, scheme_make_raw_pair(val, (Scheme_Object *)vpos));
              scheme_hash_set(ht, SCHEME_VEC_ELS(cache)[1], scheme_make_raw_pair(SCHEME_VEC_ELS(cache)[2],
                                                                                 SCHEME_VEC_ELS(cache)[3]));
              SCHEME_VEC_ELS(cache)[1] = NULL;
              SCHEME_VEC_ELS(cache)[2] = (Scheme_Object *)ht;
            } else {
              /* Already have a hash table */
              Scheme_Hash_Table *ht;
              ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(cache)[2];
              scheme_hash_set(ht, key, scheme_make_raw_pair(val, (Scheme_Object *)vpos));
            }
          }
        }
      }

      if (val) {
        if (_meta)
          *_meta = mc;
        if (_vpos)
          *_vpos = vpos;
        return val;
      }
      
      if (mc) {
        mc = mc->next;
      } else {
        mc = p->meta_continuation;
      }
    } while (mc);
  }

  return default_mark_value(key);
}

XFORM_NONGCING static Scheme_Object *
extract_one_cc_mark_fast(Scheme_Object *key, int *_conclusive)
/* A non-GCing fast path for scheme_extract_one_cc_mark_with_meta()
   where there are no complications. */
{
  intptr_t findpos, bottom, startpos;
  intptr_t pos;
  Scheme_Object *val = NULL;
  Scheme_Object *cache;
  Scheme_Cont_Mark *seg;
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Meta_Continuation *mc = NULL;

  do {
    if (mc) {
      startpos = mc->cont_mark_total;
      bottom = 0;
    } else {
      startpos = (intptr_t)MZ_CONT_MARK_STACK;
      bottom = p->cont_mark_stack_bottom;
    }
  
    findpos = startpos;
  
    /* Search mark stack, checking caches along the way: */
    while (findpos-- > bottom) {
      if ((startpos - findpos) > MARK_CACHE_THRESHOLD) {
        /* Use full search to trigger caching */
        return NULL;
      }

      if (mc) {
        seg = mc->cont_mark_stack_copied;
        pos = findpos;
      } else {
        seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
        pos = findpos & SCHEME_MARK_SEGMENT_MASK;
      }

      if (SAME_OBJ(seg[pos].key, key)) {
        *_conclusive = 1;
        return seg[pos].val;
      } else {
        cache = seg[pos].cache;
        if (cache && SCHEME_HASHTP(cache))
          cache = scheme_eq_hash_get((Scheme_Hash_Table *)cache, scheme_false);
        if (cache && SCHEME_VECTORP(cache)) {
          /* If slot 1 has a key, this cache has just one key--value
             pair. Otherwise, slot 2 is a hash table. */
          if (SCHEME_VEC_ELS(cache)[1]) {
            if (SAME_OBJ(SCHEME_VEC_ELS(cache)[1], key)) {
              val = SCHEME_VEC_ELS(cache)[2];
              if (val) {
                *_conclusive = 1;
                return val;
              } else
                break; /* cached absence of a value */
            }
          } else {
            Scheme_Hash_Table *ht;
            ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(cache)[2];
            val = scheme_eq_hash_get(ht, key);
            if (val) {
              val = SCHEME_CAR(val);
              if (val) {
                *_conclusive = 1;
                return val;
              } else
                break; /* cached absence of a value */
            }
          }
        }
      }
    }

    if (mc)
      mc = mc->next;
    else
      mc = p->meta_continuation;
  } while (mc);

  /* Since we searched the metacontinuation chain, 
     the absence of a value is conclusive */
  *_conclusive = 1;
  return default_mark_value(key);
}

static Scheme_Object *get_set_cont_mark_by_pos(Scheme_Object *key,
                                               Scheme_Thread *p,
                                               Scheme_Meta_Continuation *mc,
                                               MZ_MARK_POS_TYPE mpos,
                                               Scheme_Object *val)
{
  intptr_t findpos, bottom, startpos;
  intptr_t pos;
  int down_delta = 0;
  Scheme_Cont_Mark *seg;

  if (mc) {
    startpos = mc->cont_mark_total;
    bottom = 0;
  } else {
    startpos = (intptr_t)MZ_CONT_MARK_STACK;
    bottom = p->cont_mark_stack_bottom;
  }
  
  /* binary search: */
  while (bottom < startpos) {
    findpos = ((bottom + startpos) / 2) - down_delta;

    if (mc) {
      seg = mc->cont_mark_stack_copied;
      pos = findpos;
    } else {
      seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE];
      pos = findpos & SCHEME_MARK_SEGMENT_MASK;
    }

    if (seg[pos].pos == mpos) {
      if (SAME_OBJ(seg[pos].key, key)) {
        if (!val)
          return seg[pos].val;
        
        if (mc && mc->cm_shared)
          seg = copy_cm_shared_on_write(mc);
        
        seg[pos].val = val;
        
        return scheme_void;
      } else if (findpos > bottom) {
        down_delta++;
      } else {
        bottom = (findpos + down_delta) + 1;
        down_delta = 0;
      }
    } else if (seg[pos].pos < mpos) {
      bottom = findpos + 1;
    } else {
      startpos = findpos;
    }
  }

  scheme_signal_error("get_set_cont_mark_by_pos: key not found");
  return NULL;
}

Scheme_Object *
scheme_extract_one_cc_mark(Scheme_Object *mark_set, Scheme_Object *key)
{
  Scheme_Object *v;

  if (!mark_set) {
    int conclusive = 0;
    v = extract_one_cc_mark_fast(key, &conclusive);
    if (conclusive) return v;
  }

  return scheme_extract_one_cc_mark_with_meta(mark_set, key, NULL, NULL, NULL);
}

Scheme_Object *
scheme_extract_one_cc_mark_to_tag(Scheme_Object *mark_set, Scheme_Object *key,
                                  Scheme_Object *prompt_tag)
{
  return scheme_extract_one_cc_mark_with_meta(mark_set, key, prompt_tag, NULL, NULL);
}

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

  if (SCHEME_TRUEP(argv[0])
      && !SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type))
    scheme_wrong_contract("continuation-mark-set-first", "(or/c continuation-mark-set? #f)", 0, argc, argv);

  if ((argv[1] == scheme_parameterization_key)
      || (argv[1] == scheme_break_enabled_key)) {
    /* Minor hack: these keys are used in the startup linklet to access
       parameterizations, and we want that access to go through
       prompts. If they keys somehow leaked, it's ok, because that
       doesn't expose anything that isn't already exposed by functions
       like `current-parameterization'. */
    prompt_tag = NULL; 
  } else
    prompt_tag = scheme_default_prompt_tag;

  if (argc > 3) {
    if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[3]))) {
      if (SCHEME_NP_CHAPERONEP(argv[3])
          && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(argv[3])))
        prompt_tag = SCHEME_CHAPERONE_VAL(argv[3]);
      else
        scheme_wrong_contract("continuation-mark-set-first", "continuation-prompt-tag?",
                          3, argc, argv);
    } else
      prompt_tag = argv[3];

    if (!SAME_OBJ(scheme_default_prompt_tag, prompt_tag)
        && !SAME_OBJ(scheme_root_prompt_tag, prompt_tag)) {
      if (SCHEME_FALSEP(argv[0])) {
        if (!scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag))) {
          scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
                           "continuation-mark-set-first: no corresponding prompt in the current continuation\n"
                           "  tag: %V",
                           prompt_tag);
        }
      }
    }
  } 

  r = scheme_extract_one_cc_mark_to_tag(SCHEME_TRUEP(argv[0]) ? argv[0] : NULL, argv[1], 
                                        prompt_tag ? SCHEME_PTR_VAL(prompt_tag) : NULL);
  if (!r) {
    if (argc > 2)
      r = argv[2];
    else
      r = scheme_false;
  }

  return r;
}

int scheme_is_cm_deeper(Scheme_Meta_Continuation *m1, MZ_MARK_POS_TYPE p1,
                        Scheme_Meta_Continuation *m2, MZ_MARK_POS_TYPE p2)
{
  if (m1 != m2) {
    if (!m1)
      return 0;
    if (!m2)
      return 1;
    return (m1->depth < m2->depth);
  }
  return p1 < p2;
}

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

  prompt_tag = argv[0];
  if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(prompt_tag))) {
    if (SCHEME_NP_CHAPERONEP(prompt_tag)
        && SCHEME_PROMPT_TAGP(SCHEME_CHAPERONE_VAL(prompt_tag)))
      prompt_tag = SCHEME_CHAPERONE_VAL(prompt_tag);
    else
      scheme_wrong_contract("continuation-prompt-available?", "continuation-prompt-tag?",
                        0, argc, argv);
  }

  if (argc > 1) {
    if (SCHEME_ECONTP(argv[1])) {
      if (!scheme_escape_continuation_ok(argv[1])) {
        scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
                         "continuation-prompt-available?: escape continuation not in the current thread's continuation\n"
                         "  escape continuation: %V",
                         argv[1]);
        return NULL;
      } else {
        Scheme_Meta_Continuation *mc;

        if (SAME_OBJ(scheme_default_prompt_tag, prompt_tag)
            || SAME_OBJ(scheme_root_prompt_tag, prompt_tag))
          return scheme_true;

        mc = scheme_get_meta_continuation(argv[1]);
        
        if (continuation_marks(scheme_current_thread, NULL, argv[1], mc, prompt_tag, 
                               NULL, 0, 0))
          return scheme_true;
      }
    } else if (SCHEME_CONTP(argv[1])) {
      if (continuation_marks(NULL, argv[1], NULL, NULL, prompt_tag, NULL, 0, 0))
        return scheme_true;
    } else {
      scheme_wrong_contract("continuation-prompt-available?", "continuation?",
                        1, argc, argv);
    }
  } else {
    if (SAME_OBJ(scheme_default_prompt_tag, prompt_tag)
        || SAME_OBJ(scheme_root_prompt_tag, prompt_tag))
      return scheme_true;

    if (scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag)))
      return scheme_true;
  }

  return scheme_false;
}

/*========================================================================*/
/*                        lightweight continuations                       */
/*========================================================================*/

/* A lightweight continuation is one that contains only frames from
   JIT-generated code. The code here manages capture and restore for
   the runstack and mark stack, while the rest is in the JIT. */

#ifdef MZ_USE_JIT

struct Scheme_Lightweight_Continuation {
  MZTAG_IF_REQUIRED /* scheme_rt_lightweight_cont */
  Scheme_Current_LWC *saved_lwc;
  void *stack_slice;
  Scheme_Object **runstack_slice;
  Scheme_Cont_Mark *cont_mark_stack_slice;
  void *stored1, *stored2;
};

void scheme_init_thread_lwc(void) XFORM_SKIP_PROC
{
  scheme_current_lwc = (Scheme_Current_LWC *)malloc(sizeof(Scheme_Current_LWC));
}

void scheme_fill_lwc_start(void) XFORM_SKIP_PROC
{
  scheme_current_lwc->runstack_start = MZ_RUNSTACK;
  scheme_current_lwc->cont_mark_stack_start = MZ_CONT_MARK_STACK;
  scheme_current_lwc->cont_mark_pos_start = MZ_CONT_MARK_POS;
}

void scheme_fill_lwc_end(void) XFORM_SKIP_PROC
{
  scheme_current_lwc->runstack_end = MZ_RUNSTACK;
  scheme_current_lwc->cont_mark_stack_end = MZ_CONT_MARK_STACK;
  scheme_current_lwc->cont_mark_pos_end = MZ_CONT_MARK_POS;
  scheme_fill_stack_lwc_end();
}

void scheme_clear_lwc(void) XFORM_SKIP_PROC
{
}

Scheme_Lightweight_Continuation *scheme_capture_lightweight_continuation(Scheme_Thread *p,
                                                                         Scheme_Current_LWC *p_lwc,
                                                                         void **storage)
  XFORM_SKIP_PROC
/* This function explicitly cooperates with the GC by storing the
   pointers it needs to save across a collection in `storage'. Also,
   if allocation fails, it can abort and return NULL. The combination
   allows it to work in a thread for running futures (where allocation
   and GC in general ae disallowed). */
{
  intptr_t len, i, j, pos;
  Scheme_Object **runstack_slice;
  Scheme_Cont_Mark *cont_mark_stack_slice;
  Scheme_Current_LWC *lwc;
  Scheme_Cont_Mark *seg;
  Scheme_Lightweight_Continuation *lw;
  void *stack;

  storage[1] = p;

  lw = MALLOC_ONE_RT(Scheme_Lightweight_Continuation);
  if (!lw) return NULL;
#ifdef MZTAG_REQUIRED
  lw->type = scheme_rt_lightweight_cont;
#endif

  storage[0] = lw;

  lwc = (Scheme_Current_LWC *)scheme_malloc_atomic(sizeof(Scheme_Current_LWC));
  if (!lwc) return NULL;

  memcpy(lwc, p_lwc, sizeof(Scheme_Current_LWC));

  lw = (Scheme_Lightweight_Continuation *)storage[0];
  lw->saved_lwc = lwc;

  stack = scheme_save_lightweight_continuation_stack(p_lwc);
  if (!stack) return NULL;

  lw = (Scheme_Lightweight_Continuation *)storage[0];
  lw->stack_slice = stack;
  lwc = lw->saved_lwc;

  len = lwc->runstack_start - lwc->runstack_end;
  runstack_slice = MALLOC_N(Scheme_Object*, len);
  if (!runstack_slice) return NULL;

  lw = (Scheme_Lightweight_Continuation *)storage[0];
  lwc = lw->saved_lwc;
  lw->runstack_slice = runstack_slice;
  memcpy(runstack_slice, lw->saved_lwc->runstack_end, len * sizeof(Scheme_Object *));

  /* The runstack may contain pointers to itself, but they are just 
     cleared slots where a register containing the runstack pointer
     was handy; zero out such slots to avoid retaining a runstack
     unnecessarily: */
  for (i = 0; i < len; i++) {
    if (((uintptr_t)runstack_slice[i] >= (uintptr_t)lwc->runstack_end)
        && ((uintptr_t)runstack_slice[i] <= (uintptr_t)lwc->runstack_start))
      runstack_slice[i] = NULL;
  }

  len = lwc->cont_mark_stack_end - lwc->cont_mark_stack_start;

  if (len) {
    cont_mark_stack_slice = MALLOC_N(Scheme_Cont_Mark, len);
    if (!cont_mark_stack_slice) return NULL;
    lw = (Scheme_Lightweight_Continuation *)storage[0];
  } else
    cont_mark_stack_slice = NULL;

  lw->cont_mark_stack_slice = cont_mark_stack_slice;

  lwc = lw->saved_lwc;
  p = (Scheme_Thread *)storage[1];

  for (j = 0; j < len; j++) {
    i = j + lwc->cont_mark_stack_start;

    seg = p->cont_mark_stack_segments[i >> SCHEME_LOG_MARK_SEGMENT_SIZE];
    pos = i & SCHEME_MARK_SEGMENT_MASK;
    
    memcpy(cont_mark_stack_slice + j, seg + pos, sizeof(Scheme_Cont_Mark));
  }

  return lw;
}

Scheme_Object **scheme_adjust_runstack_argument(Scheme_Lightweight_Continuation *lw,
                                                Scheme_Object **arg)
  XFORM_SKIP_PROC
{
  if (arg == lw->saved_lwc->runstack_end)
    return lw->runstack_slice;
  else
    return arg;
}

static void *apply_lwc_k()
{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Lightweight_Continuation *lw = (Scheme_Lightweight_Continuation *)p->ku.k.p1;
  Scheme_Object *result = (Scheme_Object *)p->ku.k.p2;

  p->ku.k.p1 = NULL;
  p->ku.k.p2 = NULL;

  return scheme_apply_lightweight_continuation(lw, result, p->ku.k.i1, p->ku.k.i2);
}

static Scheme_Object *can_apply_lwc_k(void);

static int can_apply_lightweight_continuation(Scheme_Lightweight_Continuation *lw, int did_overflow)
{
#ifdef DO_STACK_CHECK
  /* enough room on C stack? */
  uintptr_t size;
  size = (uintptr_t)lw->saved_lwc->stack_start - (uintptr_t)lw->saved_lwc->stack_end;
  
  {
# define SCHEME_PLUS_STACK_DELTA(x) ((x) - size)
# include "mzstkchk.h"
    {
      if (did_overflow)
        return 0;
      else {
        scheme_current_thread->ku.k.p1 = lw;
        if (SCHEME_TRUEP(scheme_handle_stack_overflow(can_apply_lwc_k)))
          return 2;
        else
          return 0;
      }
    }
  }

  return 1;
#else
  return 0;
#endif
}

int scheme_can_apply_lightweight_continuation(Scheme_Lightweight_Continuation *lw, int check_overflow)
/* result value 2 => need to handle stack overflow to have enough room */
{
  if (check_overflow)
    return can_apply_lightweight_continuation(lw, 0);
  else
    /* assume that we can apply the continuation, though 
       overflow handling may be needed (i.e., assume that the runtime
       thread's stack size is > than a future thread's stack) */
    return 1;
}

static Scheme_Object *can_apply_lwc_k(void)
{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Lightweight_Continuation *lwc = (Scheme_Lightweight_Continuation *)p->ku.k.p1;

  p->ku.k.p1 = NULL;

  if (can_apply_lightweight_continuation(lwc, 1))
    return scheme_true;
  else
    return scheme_false;
}

Scheme_Object *scheme_apply_lightweight_continuation(Scheme_Lightweight_Continuation *lw,
                                                     Scheme_Object *result,
                                                     int result_is_rs_argv,
                                                     intptr_t min_stacksize) 
  XFORM_SKIP_PROC
{
  intptr_t len, cm_delta, i, cm;
  Scheme_Object **rs;

  len = lw->saved_lwc->runstack_start - lw->saved_lwc->runstack_end;
 
  if (!scheme_check_runstack(len)
      /* besides making sure that the save slice fits, we need to
         make sure that any advance check on available from the old thread
         still applies in the new thread */
      || ((MZ_RUNSTACK - MZ_RUNSTACK_START) < min_stacksize)) {
    /* This will not happen when restoring a future-thread-captured
       continuation in a future thread. */
    scheme_current_thread->ku.k.p1 = lw;
    scheme_current_thread->ku.k.p2 = result;
    scheme_current_thread->ku.k.i1 = result_is_rs_argv;
    scheme_current_thread->ku.k.i2 = min_stacksize;
    if (len < min_stacksize)
      len = min_stacksize;
    return (Scheme_Object *)scheme_enlarge_runstack(len, apply_lwc_k);
  }

  /* application of a lightweight continuation forms a lightweight continuation: */
  scheme_current_lwc->runstack_start = MZ_RUNSTACK;
  scheme_current_lwc->cont_mark_stack_start = MZ_CONT_MARK_STACK;
  scheme_current_lwc->cont_mark_pos_start = MZ_CONT_MARK_POS + 2;

#ifdef MZ_USE_FUTURES
  jit_future_storage[3] = result;
#endif      
  lw = scheme_restore_lightweight_continuation_marks(lw); /* can trigger GC */
#ifdef MZ_USE_FUTURES
  result = (Scheme_Object *)jit_future_storage[3];
#endif      

  cm_delta = (intptr_t)MZ_CONT_MARK_STACK - (intptr_t)lw->saved_lwc->cont_mark_stack_end;

  rs = MZ_RUNSTACK - len;
  MZ_RUNSTACK = rs;

  memcpy(rs, lw->runstack_slice, len * sizeof(Scheme_Object*));
  
  /* If SCHEME_EVAL_WAITING appears in the runstack slice, it
     indicates that a cm position follows: */
  for (i = 0; i < len; i++) {
    if (rs[i] == SCHEME_EVAL_WAITING) {
      cm = SCHEME_INT_VAL(rs[i+1]);
      cm += cm_delta;
      rs[i+1] = scheme_make_integer(cm);
    }
  }

  if (result_is_rs_argv)
    result = (Scheme_Object *)(rs + 2);

  return scheme_apply_lightweight_continuation_stack(lw->saved_lwc, lw->stack_slice, result);
}

Scheme_Lightweight_Continuation *scheme_restore_lightweight_continuation_marks(Scheme_Lightweight_Continuation *lw)
  XFORM_SKIP_PROC
/* Called by any thread, but this function can trigger a GC in the runtime thread */
{
  intptr_t cm_len, i, cm_pos_delta;
  Scheme_Cont_Mark *seg;

  cm_len = lw->saved_lwc->cont_mark_stack_end - lw->saved_lwc->cont_mark_stack_start;
  cm_pos_delta = MZ_CONT_MARK_POS + 2 - lw->saved_lwc->cont_mark_pos_start;

  if (cm_len) {
    /* install captured continuation marks, adjusting the pos
       to match the new context: */
    seg = lw->cont_mark_stack_slice;
    for (i = 0; i < cm_len; i++) {
      MZ_CONT_MARK_POS = seg[i].pos + cm_pos_delta;
#ifdef MZ_USE_FUTURES
      jit_future_storage[2] = lw;
#endif      
      scheme_set_cont_mark(seg[i].key, seg[i].val); /* can trigger a GC */
#ifdef MZ_USE_FUTURES
      lw = (Scheme_Lightweight_Continuation *)jit_future_storage[2];
#endif      
    }
  }

  MZ_CONT_MARK_POS = lw->saved_lwc->cont_mark_pos_end + cm_pos_delta;

  return lw;
}

int scheme_push_marks_from_lightweight_continuation(Scheme_Lightweight_Continuation *lw, 
                                                    Scheme_Cont_Frame_Data *d)
{
  intptr_t pos, len, delta;
  Scheme_Cont_Mark *seg;

  len = (lw->saved_lwc->cont_mark_stack_end
         - lw->saved_lwc->cont_mark_stack_start);

  if (len) {
    scheme_push_continuation_frame(d);

    seg = lw->cont_mark_stack_slice;

    delta = MZ_CONT_MARK_POS + 2 - lw->saved_lwc->cont_mark_pos_start;
      
    for (pos = 0; pos < len; pos++) {
      MZ_CONT_MARK_POS = seg[pos].pos + delta;
      scheme_set_cont_mark(seg[pos].key, seg[pos].val);
    }

    MZ_CONT_MARK_POS = lw->saved_lwc->cont_mark_pos_end + delta;

    return 1;
  }

  return 0;
}

int scheme_push_marks_from_thread(Scheme_Thread *p2, Scheme_Cont_Frame_Data *d)
{
  intptr_t i, pos, delta;
  Scheme_Cont_Mark *seg;

  if (p2->cont_mark_stack) {
    scheme_push_continuation_frame(d);

    delta = MZ_CONT_MARK_POS - p2->cont_mark_pos;
    if (delta < 0) delta = 0;
      
    for (i = 0; i < p2->cont_mark_stack; i++) {
      seg = p2->cont_mark_stack_segments[i >> SCHEME_LOG_MARK_SEGMENT_SIZE];
      pos = i & SCHEME_MARK_SEGMENT_MASK;

      MZ_CONT_MARK_POS = seg[pos].pos + delta;
      scheme_set_cont_mark(seg[pos].key, seg[pos].val);
    }

    MZ_CONT_MARK_POS = p2->cont_mark_pos + delta;

    return 1;
  }

  return 0;
}

#else

void scheme_init_thread_lwc(void) XFORM_SKIP_PROC { }

#endif

/*========================================================================*/
/*                             dynamic-wind                               */
/*========================================================================*/

typedef struct {
  MZTAG_IF_REQUIRED
  Scheme_Object *pre, *act, *post;
} Dyn_Wind;

static void pre_post_dyn_wind(Scheme_Object *prepost)
{
  Scheme_Cont_Frame_Data cframe;

  /* Cancel internal suspend in eval or dyn-wind, because we convert
     it to a parameterize. */
  --scheme_current_thread->suspend_break;
  ASSERT_SUSPEND_BREAK_ZERO();

  scheme_push_break_enable(&cframe, 0, 0);

  /* Here's the main call: */
  scheme_ignore_result(_scheme_apply_multi(prepost, 0, NULL));

  scheme_pop_break_enable(&cframe, 0);

  /* Restore internal suspend: */
  scheme_current_thread->suspend_break++;
}

static Scheme_Object *do_dyn_wind(void *d)
{
  Dyn_Wind *dw;
  dw = (Dyn_Wind *)d;

  return _scheme_apply_multi(dw->act, 0, NULL);
}

static void pre_dyn_wind(void *d)
{
  pre_post_dyn_wind(((Dyn_Wind *)d)->pre);
}

static void post_dyn_wind(void *d)
{
  pre_post_dyn_wind(((Dyn_Wind *)d)->post);
}

static Scheme_Object *dynamic_wind(int c, Scheme_Object *argv[])
{
  Dyn_Wind *dw;
  Scheme_Object *v;

  scheme_check_proc_arity("dynamic-wind", 0, 0, c, argv);
  scheme_check_proc_arity("dynamic-wind", 0, 1, c, argv);
  scheme_check_proc_arity("dynamic-wind", 0, 2, c, argv);

  dw = MALLOC_ONE_RT(Dyn_Wind);
#ifdef MZTAG_REQUIRED
  dw->type = scheme_rt_dyn_wind_info;
#endif

  dw->pre = argv[0];
  dw->act = argv[1];
  dw->post = argv[2];

  v = scheme_dynamic_wind(pre_dyn_wind, do_dyn_wind, post_dyn_wind, NULL,
			  (void *)dw);

  /* We may have just re-activated breaking: */
  {
    Scheme_Thread *p = scheme_current_thread;
    if (p->external_break && scheme_can_break(p)) {
      Scheme_Object **save_values;
      int save_count;

      if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
	save_count = p->ku.multiple.count;
	save_values = p->ku.multiple.array;
	p->ku.multiple.array = NULL;
	if (SAME_OBJ(save_values, p->values_buffer))
	  p->values_buffer = NULL;
      } else {
	save_count = 0;
	save_values = NULL;
      }

      scheme_thread_block_w_thread(0.0, p);
      p->ran_some = 1;

      if (save_values) {
	p->ku.multiple.count = save_count;
	p->ku.multiple.array = save_values;
      }
    }
  }

  return v;
}

Scheme_Object *scheme_dynamic_wind(void (*pre)(void *),
				   Scheme_Object *(* volatile act)(void *),
				   void (* volatile post)(void *),
				   Scheme_Object *(*jmp_handler)(void *),
				   void * volatile data)
{
  mz_jmp_buf newbuf;
  Scheme_Object * volatile v, ** volatile save_values;
  volatile int err;
  Scheme_Dynamic_Wind * volatile dw;
  volatile int save_count, old_cac;
  Scheme_Thread *p;
  int delta;

  p = scheme_current_thread;

  if (pre) {
    ASSERT_SUSPEND_BREAK_ZERO();
    p->suspend_break++;
    pre(data);
    p = scheme_current_thread;
    --p->suspend_break;
  }

  /* set up `dw' after pre(), in case a continuation
     is captured in pre() and composed later */

  dw = MALLOC_ONE_RT(Scheme_Dynamic_Wind);
#ifdef MZTAG_REQUIRED
  dw->type = scheme_rt_dyn_wind;
#endif

  dw->data = data;
  dw->pre = pre;
  dw->post = post;
  dw->prev = p->dw;
  if (dw->prev)
    dw->depth = dw->prev->depth + 1;
  else
    dw->depth = 0;
  dw->next_meta = p->next_meta;

  p->next_meta = 0;
  p->dw = dw;
  
  dw->saveerr = scheme_current_thread->error_buf;
  scheme_current_thread->error_buf = &newbuf;

   scheme_save_env_stack_w_thread(dw->envss, p);

  if (scheme_setjmp(newbuf)) {
    p = scheme_current_thread;
    scheme_restore_env_stack_w_thread(dw->envss, p);
    if ((p->dw != dw)
        && (!p->dw || !dw->id || (p->dw->id != dw->id))) {
      /* A full continuation jump was interrupted by an
	 escape continuation jump (in a dw pre or post thunk). Either
           1. this dw's post is already done for an interupted upward
              jump; or
           2. we never actually got this far for an interrupted
	      downward jump.
	 In either case, skip up until we get to the right level. */
      scheme_longjmp(*dw->saveerr, 1);
    } else {
      if (jmp_handler)
	v = jmp_handler(data);
      else
	v = NULL;
      err = !v;
    }
  } else {
    if (pre) {
      /* Need to check for a break, in case one was queued during
	 pre: */
      scheme_check_break_now();
    }

    v = act(data);

    err = 0;
  }

  p = scheme_current_thread;
  if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
    save_count = p->ku.multiple.count;
    save_values = p->ku.multiple.array;
    p->ku.multiple.array = NULL;
    if (SAME_OBJ(save_values, p->values_buffer))
      p->values_buffer = NULL;
  } else {
    save_count = 0;
    save_values = NULL;
  }

  delta = p->dw->next_meta;
  p->dw = p->dw->prev; /* note: use p->dw, not dw, in case
                          continuation was composed */
  p->next_meta += delta;

  /* Don't run Racket-based dyn-winds when we're killing a nested thread. */
  if (err && p->cjs.is_kill && (post == post_dyn_wind))
    post = NULL;

  old_cac = scheme_continuation_application_count;

  if (post) {
    p->error_buf = &newbuf;
    if (scheme_setjmp(newbuf)) {
      p = scheme_current_thread;
      scheme_restore_env_stack_w_thread(dw->envss, p);
      err = 1;
    } else {
      Scheme_Continuation_Jump_State cjs;
      p = scheme_current_thread;
      if (!p->cjs.skip_dws) {
        ASSERT_SUSPEND_BREAK_ZERO();
        p->suspend_break++;
        copy_cjs(&cjs, &p->cjs);
        reset_cjs(&p->cjs);
        post(data);
        copy_cjs(&p->cjs, &cjs);
        p = scheme_current_thread;
        --p->suspend_break;
      }
    }
  }

  if (err) {
    /* If we're escaping to a prompt or escape continuation,
       check that it's still there. */
    if ((old_cac != scheme_continuation_application_count)
        && p->cjs.jumping_to_continuation) {
      p->error_buf = dw->saveerr;
      if (SAME_TYPE(SCHEME_TYPE(p->cjs.jumping_to_continuation), scheme_prompt_type)) {
        Scheme_Object *tag;
        Scheme_Prompt *prompt;
        tag = ((Scheme_Prompt *)p->cjs.jumping_to_continuation)->tag;
        prompt = (Scheme_Prompt *)scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(tag));
        if (!prompt && SAME_OBJ(scheme_default_prompt_tag, tag)) {
          prompt = original_default_prompt;
        }
        if (!prompt) {
          scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
                           "abort-current-continuation:"
                           " abort in progress, but current continuation includes"
                           " no prompt with the given tag"
                           " after a `dynamic-wind' post-thunk return\n"
                           "  tag: %V",
                           tag);
          return NULL;
        }
        p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;
      } else if (SCHEME_ECONTP(p->cjs.jumping_to_continuation)) {
        if (!scheme_escape_continuation_ok(p->cjs.jumping_to_continuation)) {
          if (p->cjs.alt_full_continuation) {
            /* We were trying to execute a full-continuation jump through
               an escape-continuation jump. Go back to full-jump mode. */
            return jump_to_alt_continuation();
          }
          scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
                           "continuation application: lost target;\n"
                           " jump to escape continuation in progress, and the target is not in the\n"
                           " current continuation after a `dynamic-wind' post-thunk return");
          return NULL;
        }
      }
    }

    scheme_longjmp(*dw->saveerr, 1);
  }

  p->error_buf = dw->saveerr;

  if (post) {
    /* Need to check for a break, in case one was queued during post: */
    scheme_check_break_now();
  }

  if (v == SCHEME_MULTIPLE_VALUES) {
    p->ku.multiple.count = save_count;
    p->ku.multiple.array = save_values;
  }

  return v;
}

void scheme_apply_dw_in_meta(Scheme_Dynamic_Wind *dw, int post_part, int meta_depth, Scheme_Cont *recheck)
{
  /* Run the given dw pre/post thunk, but let it see only the 
     continuation marks starting with the given meta-continuation.
     We don't want to actually prune the meta-continuation, since 
     that would be out of sync with the control state, so we instead
     replace the first meta_depth frames to prune the continuation marks.
     On return, we have to unprune those marks. (If there's an escape,
     then we don't have to unprune, because the escape jumps out of
     the pruned meta-continuations.) Unfortunately, pruning this way
     requires time proportional to the meta depth.
     
     The pre/post thunk might install it's own marks. In that case, it
     uses the current mark stack. We don't care about the current mark
     stack's state, since we're either on our way out, or we're on our
     way in and we haven't started restoring the marks. So start with
     a clean mark stack, but make sure it doesn't appear to be in tail
     position for a meta-continuation.

     The pre/post thunk might jump, or it might capture a continuation that
     is later restored. In that case, the meta-continuation can be extended
     or different by the time we get back. That's why we take a meta_depth,
     rather than a meta continuation (i.e., the loop that calls this
     function shouldn't remember meta-continuations). The meta-continuation
     can't become shorter than the current needed meta_depth. It may become
     shorter than it was originally, which is relevant to a post loop that
     calls this function; but the d-w list for posts will become shorter in 
     that case, too, so the post loop is fine as long as it consults
     scheme_current_thread->dw.
  */
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Meta_Continuation *mc, *old_mc, *rest;
  intptr_t delta;
  int i, actual_depth;
  int old_cac;

  MZ_CONT_MARK_STACK = p->cont_mark_stack_bottom;
  MZ_CONT_MARK_POS = p->meta_continuation->meta_tail_pos + 2;

  old_mc = p->meta_continuation;

  /* clone the first meta_depth meta continuations: */
  for (i = 0, actual_depth = 0, rest = old_mc; i < meta_depth; actual_depth++) {
    if (rest->overflow)
      i++;
    rest = rest->next;
  }
  mc = clone_meta_cont(p->meta_continuation, NULL, actual_depth, NULL, NULL, rest, 0);
  p->meta_continuation = mc;

  /* strip the marks of the first actual_depth-1 meta continuations */
  rest = mc;
  for (i = 0; i < actual_depth - 1; i++) {
    rest->cont_mark_total = 0;
    rest->cont_mark_offset = rest->cont_mark_stack;
    rest->cont_mark_stack_copied = NULL;
    sync_meta_cont(rest);
    rest = rest->next;
  }

  /* prune the actual_depth's meta continuation's marks. */
  delta = rest->cont_mark_stack - dw->envss.cont_mark_stack;
  if (delta) {
    rest->cont_mark_total -= delta;
    rest->cont_mark_stack -= delta;
    if (rest->cont_mark_total) {
      Scheme_Cont_Mark *cp;
      cp = MALLOC_N(Scheme_Cont_Mark, rest->cont_mark_total);
      memcpy(cp, rest->cont_mark_stack_copied, rest->cont_mark_total * sizeof(Scheme_Cont_Mark));
      rest->cont_mark_stack_copied = cp;
    } else
      rest->cont_mark_stack_copied = NULL;
    sync_meta_cont(rest);
  }

  old_cac = scheme_continuation_application_count;

  /* Run the post or pre thunk: */
  if (post_part) {
    DW_PrePost_Proc post = dw->post;
    post(dw->data);
  } else {
    DW_PrePost_Proc pre = dw->pre;
    pre(dw->data);
  }

  p = scheme_current_thread;

  if (recheck && !recheck->composable) {
    if (scheme_continuation_application_count != old_cac) {
      scheme_recheck_prompt_and_barrier(recheck);
    }
  }

  /* restore the first meta_depth meta continuations (onto
     a tail that is possibly different than when we captured
     old_mc) */
  for (i = 0, rest = p->meta_continuation; i < actual_depth; i++) {
    rest = rest->next;
  }
  old_mc = clone_meta_cont(old_mc, NULL, actual_depth, NULL, NULL, rest, 0);
  p->meta_continuation = old_mc;
}

static Scheme_Object *jump_to_alt_continuation()
{
  Scheme_Thread *p;
  Scheme_Object *a[1], **args, *fc;

  p = scheme_current_thread;

  a[0] = p->cjs.val;
  fc = p->cjs.alt_full_continuation;
  args = ((p->cjs.num_vals == 1) ? a : (Scheme_Object **)p->cjs.val);
  p->cjs.jumping_to_continuation = NULL;
  p->cjs.alt_full_continuation = NULL;
  p->cjs.val = NULL;
  p->cjs.skip_dws = 0;

  return scheme_jump_to_continuation(fc, p->cjs.num_vals, args, NULL, 0);
}

/*========================================================================*/
/*                                  time                                  */
/*========================================================================*/

uintptr_t scheme_get_milliseconds(void)
/* this function can be called from any OS thread */
{
  return rktio_get_milliseconds();
}

double scheme_get_inexact_milliseconds(void)
/* this function can be called from any OS thread */
{
  return rktio_get_inexact_milliseconds();
}

static double get_inexact_monotonic_milliseconds(void)
/* this function can be called from any OS thread */
{
  return rktio_get_inexact_monotonic_milliseconds(scheme_rktio);
}

intptr_t scheme_get_process_milliseconds(void)
{
  return rktio_get_process_milliseconds(scheme_rktio);
}

intptr_t scheme_get_process_children_milliseconds(void)
{
  return rktio_get_process_children_milliseconds(scheme_rktio);
}

intptr_t scheme_get_thread_milliseconds(Scheme_Object *thrd)
  XFORM_SKIP_PROC
{
  Scheme_Thread *t = thrd ? (Scheme_Thread *)thrd : scheme_current_thread;

  if (t == scheme_current_thread) {
    intptr_t cpm;
    cpm = scheme_get_process_milliseconds();
    return t->accum_process_msec + (cpm - t->current_start_process_msec);
  } else {
    return t->accum_process_msec;
  }
}

intptr_t scheme_get_seconds(void)
{
  return rktio_get_seconds(scheme_rktio);
}

static Scheme_Object *seconds_to_date(int argc, Scheme_Object **argv)
{
  intptr_t lnow;
  int get_gmt;
  rktio_date_t *dt;
  Scheme_Object *p[12], *secs, *nsecs, *zname;
  char *tzn;

  secs = argv[0];

  if (!SCHEME_REALP(secs)) {
    scheme_wrong_contract("seconds->date", "real?", 0, argc, argv);
    return NULL;
  }
  
  if (argc > 1)
    get_gmt = SCHEME_FALSEP(argv[1]);
  else
    get_gmt = 0;

  if (SCHEME_INTP(secs) || SCHEME_BIGNUMP(secs)) {
    nsecs = scheme_make_integer(0);
  } else {
    p[0] = secs;
    secs = scheme_inexact_to_exact(1, p);
    nsecs = secs;
    p[0] = secs;
    secs = scheme_floor(1, p);
    nsecs = scheme_bin_minus(nsecs, secs);
    nsecs = scheme_bin_mult(nsecs, scheme_make_integer(1000000000));
    p[0] = nsecs;
    nsecs = scheme_floor(1, p);
    p[0] = nsecs;
    nsecs = scheme_inexact_to_exact(1, p);
    p[0] = secs;
    secs = scheme_inexact_to_exact(1, p);
  }

  if (scheme_get_time_val(secs, &lnow)) {
    dt = rktio_seconds_to_date(scheme_rktio, lnow, SCHEME_INT_VAL(nsecs), get_gmt);
    if (dt) {
      tzn = dt->zone_name;
      if (!tzn)
        tzn = "?";
      zname = scheme_make_utf8_string(tzn);
      SCHEME_SET_IMMUTABLE(zname);

      p[0] = scheme_make_integer(dt->second);
      p[1] = scheme_make_integer(dt->minute);
      p[2] = scheme_make_integer(dt->hour);
      p[3] = scheme_make_integer(dt->day);
      p[4] = scheme_make_integer(dt->month);
      p[5] = scheme_make_integer(dt->year);
      p[6] = scheme_make_integer(dt->day_of_week);
      p[7] = scheme_make_integer(dt->day_of_year);
      p[8] = (dt->is_dst ? scheme_true : scheme_false);
      p[9] = scheme_make_integer(dt->zone_offset);
      p[10] = scheme_make_integer(dt->nanosecond);
      p[11] = zname;

      if (dt->zone_name)
        rktio_free(dt->zone_name);
      free(dt);

      return scheme_make_struct_instance(scheme_date, 12, p);
    } else if ((rktio_get_last_error(scheme_rktio) != RKTIO_ERROR_TIME_OUT_OF_RANGE)
               || (rktio_get_last_error_kind(scheme_rktio) != RKTIO_ERROR_KIND_RACKET)) {
      scheme_raise_exn(MZEXN_FAIL,
                       "seconds->date: conversion error\n"
                       "  error: %d; %s",
                       rktio_get_last_error(scheme_rktio),
                       rktio_get_last_error_string(scheme_rktio));
    }
  }

  scheme_raise_exn(MZEXN_FAIL,
		   "seconds->date: integer is out-of-range\n"
                   "  integer: %V",
                   secs);

  return NULL;
}

static Scheme_Object *time_apply(int argc, Scheme_Object *argv[])
{
  double start, end;
  uintptr_t cpustart, cpuend;
  uintptr_t gcstart, gcend;
  uintptr_t dur, cpudur, gcdur;
  int i, num_rands;
  Scheme_Object *v, *p[4], **rand_vec, *rands, *r;

  if (!SCHEME_PROCP(argv[0]))
    scheme_wrong_contract("time-apply", "procedure?", 0, argc, argv);

  rands = argv[1];

  num_rands = 0;
  r = rands;
  while (!SCHEME_NULLP(r)) {
    if (!SCHEME_PAIRP(r))
      scheme_wrong_contract("time-apply", "list?", 1, argc, argv);
    r = SCHEME_CDR(r);
    num_rands++;
  }

  if (SCHEME_FALSEP(get_or_check_arity(argv[0], num_rands, NULL, 1))) {
    scheme_contract_error("time-apply",
                          "arity mismatch between procedure and argument-list length\n",
                          "procedure", 1, argv[0],
                          "argument-list length", 1, scheme_make_integer(num_rands),
                          NULL);
    return NULL;
  }

  rand_vec = MALLOC_N(Scheme_Object *, num_rands);
  for (i = 0; SCHEME_PAIRP(rands); i++, rands = SCHEME_CDR(rands)) {
    rand_vec[i] = SCHEME_CAR(rands);
  }

  gcstart = scheme_total_gc_time;
  start = get_inexact_monotonic_milliseconds();
  cpustart = scheme_get_process_milliseconds();
  v = _scheme_apply_multi(argv[0], num_rands, rand_vec);
  cpuend = scheme_get_process_milliseconds();
  end = get_inexact_monotonic_milliseconds();
  gcend = scheme_total_gc_time;

  dur = (uintptr_t)(end - start);
  cpudur = cpuend - cpustart;
  gcdur = gcend - gcstart;

  if (v == SCHEME_MULTIPLE_VALUES) {
    Scheme_Thread *cp = scheme_current_thread;
    Scheme_Object **args;
    if (SAME_OBJ(cp->ku.multiple.array, cp->values_buffer))
      cp->values_buffer = NULL;
    args = cp->ku.multiple.array;
    cp->ku.multiple.array = NULL;
    v = scheme_build_list(cp->ku.multiple.count, args);
  } else
    v = scheme_make_pair(v, scheme_null);

  p[0] = v;
  p[1] = scheme_make_integer(cpudur);
  p[2] = scheme_make_integer(dur);
  p[3] = scheme_make_integer(gcdur);

  return scheme_values(4, p);
}

static Scheme_Object *current_milliseconds(int argc, Scheme_Object **argv)
{
  return scheme_make_integer(scheme_get_milliseconds());
}

static Scheme_Object *current_inexact_milliseconds(int argc, Scheme_Object **argv)
{
  return scheme_make_double(scheme_get_inexact_milliseconds());
}

static Scheme_Object *current_inexact_monotonic_milliseconds(int argc, Scheme_Object **argv)
{
  return scheme_make_double(get_inexact_monotonic_milliseconds());
}

static Scheme_Object *current_process_milliseconds(int argc, Scheme_Object **argv)
{
  if (!argc || SCHEME_FALSEP(argv[0]))
    return scheme_make_integer(scheme_get_process_milliseconds());
  else if (SAME_OBJ(argv[0], subprocesses_symbol))
    return scheme_make_integer(scheme_get_process_children_milliseconds());
  else {
    if (SCHEME_THREADP(argv[0]))
      return scheme_make_integer(scheme_get_thread_milliseconds(argv[0]));
    scheme_wrong_contract("current-process-milliseconds", "(or/c #f thread? 'subprocesses)", 0, argc, argv);
    return NULL;
  }
}

static Scheme_Object *current_gc_milliseconds(int argc, Scheme_Object **argv)
{
  return scheme_make_integer(scheme_total_gc_time);
}

static Scheme_Object *current_seconds(int argc, Scheme_Object **argv)
{
  intptr_t secs;
  secs = scheme_get_seconds();
  return scheme_make_integer_value_from_time(secs);
}


/*========================================================================*/
/*                             read-eval-print                            */
/*========================================================================*/

static Scheme_Object *
current_print(int argc, Scheme_Object **argv)
{
  return scheme_param_config("current-print",
			     scheme_make_integer(MZCONFIG_PRINT_HANDLER),
			     argc, argv,
			     1, NULL, NULL, 0);
}

static Scheme_Object *
current_prompt_read(int argc, Scheme_Object **argv)
{
  return scheme_param_config("current-prompt-read",
			     scheme_make_integer(MZCONFIG_PROMPT_READ_HANDLER),
			     argc, argv,
			     0, NULL, NULL, 0);
}

static Scheme_Object *
current_read(int argc, Scheme_Object **argv)
{
  return scheme_param_config("current-read-interaction",
			     scheme_make_integer(MZCONFIG_READ_HANDLER),
			     argc, argv,
			     2, NULL, NULL, 0);
}

static Scheme_Object *
current_get_read_input_port(int argc, Scheme_Object **argv)
{
  return scheme_param_config("current-get-interaction-input-port",
			     scheme_make_integer(MZCONFIG_READ_INPUT_PORT_HANDLER),
			     argc, argv,
			     0, NULL, NULL, 0);
}

Scheme_Object *
scheme_default_print_handler(int argc, Scheme_Object *argv[])
{
  Scheme_Object *obj = argv[0];

  if (!SAME_OBJ(obj, scheme_void)) {
    Scheme_Config *config;
    Scheme_Object *port;
    Scheme_Object *argv[2];

    config = scheme_current_config();
    port = scheme_get_param(config, MZCONFIG_OUTPUT_PORT);

    argv[0] = obj;
    argv[1] = port;
    _scheme_apply(scheme_print_proc, 2, argv);
    scheme_write_byte_string("\n", 1, port);
  }

  return scheme_void;
}

Scheme_Object *
scheme_default_read_input_port_handler(int argc, Scheme_Object *argv[])
{
  Scheme_Object *inport;
  
  inport = scheme_get_param(scheme_current_config(), MZCONFIG_INPUT_PORT);

  if (inport == scheme_orig_stdin_port)
    scheme_flush_orig_outputs();

  return inport;
}

Scheme_Object *
scheme_default_prompt_read_handler(int argc, Scheme_Object *argv[])
{
  Scheme_Config *config;
  Scheme_Object *port, *reader, *getter;
  Scheme_Object *inport, *name, *a[4], *v;

  config = scheme_current_config();
  port = scheme_get_param(config, MZCONFIG_OUTPUT_PORT);

  scheme_write_byte_string("> ", 2, port);
  scheme_flush_output(port);

  getter = scheme_get_param(config, MZCONFIG_READ_INPUT_PORT_HANDLER);
  inport = _scheme_apply(getter, 0, NULL);

  if (!SCHEME_INPORTP(inport))
    scheme_wrong_contract("default-prompt-read-hander", "input-port?", -1, -1, &inport);

  name = (Scheme_Object *)scheme_port_record(inport);
  name = ((Scheme_Input_Port *)name)->name;

  reader = scheme_get_param(config, MZCONFIG_READ_HANDLER);

  a[0] = name;
  a[1] = inport;
  v = _scheme_apply(reader, 2, a);

  a[0] = inport;
  if (SCHEME_TRUEP(scheme_terminal_port_p(1, a))) {
    a[0] = port;
    if (SCHEME_TRUEP(scheme_terminal_port_p(1, a))) {
      intptr_t line, col, pos;
      scheme_tell_all(port, &line, &col, &pos);
      if ((col > 0) && (line > 0)) {
        /* input and output are terminals (assume the same one), 
           and the output port counts lines: tell output port
           that it's on a new line: */
        a[0] = port;
        a[1] = scheme_make_integer(line + 1);
        a[2] = scheme_make_integer(0);
        if (pos > 0)
          a[3] = scheme_make_integer(pos + 2); /* incremet plus 0-adjust */
        else
          a[3] = scheme_false;
        scheme_set_port_location(4, a);
      }
    }
  }

  return v;
}
  
Scheme_Object *
scheme_default_read_handler(int argc, Scheme_Object *argv[])
{
  Scheme_Config *config;
  Scheme_Object *name = argv[0];
  Scheme_Object *inport = argv[1];
  Scheme_Object *stx;
  Scheme_Cont_Frame_Data cframe;

  if (!SCHEME_INPORTP(inport))
    scheme_wrong_contract("default-read-interaction-handler",
                          "input-port?",
                          1,
                          argc,
                          argv);

  config = scheme_current_config();
  // FIXME
  // config = scheme_extend_config(config, MZCONFIG_CAN_READ_READER, scheme_true);
  // config = scheme_extend_config(config, MZCONFIG_CAN_READ_LANG, scheme_false);

  scheme_push_continuation_frame(&cframe);
  scheme_install_config(config);

  stx = scheme_read_syntax(inport, name);

  scheme_pop_continuation_frame(&cframe);

  return stx;
}

/*========================================================================*/
/*                                precise GC                              */
/*========================================================================*/

#ifdef MZ_PRECISE_GC

START_XFORM_SKIP;

#include "mzmark_fun.inc"

static void register_traversers(void)
{
  GC_REG_TRAV(scheme_rt_dyn_wind_cell, mark_dyn_wind_cell);
  GC_REG_TRAV(scheme_rt_dyn_wind_info, mark_dyn_wind_info);
  GC_REG_TRAV(scheme_cont_mark_chain_type, mark_cont_mark_chain);
#ifdef MZ_USE_JIT
  GC_REG_TRAV(scheme_rt_lightweight_cont, mark_lightweight_cont);
#endif
}

END_XFORM_SKIP;

#endif
