Back to index

plt-scheme  4.2.1
Classes | Defines | Typedefs | Functions | Variables
fun.c File Reference
#include "schpriv.h"
#include "schexpobs.h"
#include "schmap.inc"

Go to the source code of this file.

Classes

struct  Scheme_Dynamic_Wind_List
struct  Closure_Info
struct  Dyn_Wind

Defines

#define CONS(a, b)   scheme_make_pair(a,b)
#define DO_MAP   map
#define MAP_NAME   "map"
#define MAP_MODE
#define DO_MAP   for_each
#define MAP_NAME   "for-each"
#define FOR_EACH_MODE
#define DO_MAP   andmap
#define MAP_NAME   "andmap"
#define AND_MODE
#define DO_MAP   ormap
#define MAP_NAME   "ormap"
#define OR_MODE
#define QUICK_PROMPT_ARGS   3
#define BOOL(x)   (x ? scheme_true : scheme_false)
#define BAD_CC   "bad compiled closure"
#define X_SCHEME_ASSERT(x, y)

Typedefs

typedef void(* DW_PrePost_Proc )(void *)
typedef struct
Scheme_Dynamic_Wind_List 
Scheme_Dynamic_Wind_List
typedef Scheme_Object *(* Overflow_K_Proc )(void)

Functions

static void ASSERT_SUSPEND_BREAK_ZERO ()
static Scheme_Objectprocedure_p (int argc, Scheme_Object *argv[])
static Scheme_Objectapply (int argc, Scheme_Object *argv[])
static Scheme_Objectmap (int argc, Scheme_Object *argv[])
static Scheme_Objectfor_each (int argc, Scheme_Object *argv[])
static Scheme_Objectandmap (int argc, Scheme_Object *argv[])
static Scheme_Objectormap (int argc, Scheme_Object *argv[])
static Scheme_Objectcall_cc (int argc, Scheme_Object *argv[])
static Scheme_Objectinternal_call_cc (int argc, Scheme_Object *argv[])
static Scheme_Objectcontinuation_p (int argc, Scheme_Object *argv[])
static Scheme_Objectcall_with_continuation_barrier (int argc, Scheme_Object *argv[])
static Scheme_Objectcall_with_prompt (int argc, Scheme_Object *argv[])
static Scheme_Objectcall_with_control (int argc, Scheme_Object *argv[])
static Scheme_Objectmake_prompt_tag (int argc, Scheme_Object *argv[])
static Scheme_Objectabort_continuation (int argc, Scheme_Object *argv[])
static Scheme_Objectcontinuation_prompt_available (int argc, Scheme_Object *argv[])
static Scheme_Objectget_default_prompt_tag (int argc, Scheme_Object *argv[])
static Scheme_Objectprompt_tag_p (int argc, Scheme_Object *argv[])
static Scheme_Objectcall_with_sema (int argc, Scheme_Object *argv[])
static Scheme_Objectcall_with_sema_enable_break (int argc, Scheme_Object *argv[])
static Scheme_Objectcc_marks (int argc, Scheme_Object *argv[])
static Scheme_Objectcont_marks (int argc, Scheme_Object *argv[])
static Scheme_Objectcc_marks_p (int argc, Scheme_Object *argv[])
static Scheme_Objectextract_cc_marks (int argc, Scheme_Object *argv[])
static Scheme_Objectextract_cc_markses (int argc, Scheme_Object *argv[])
static Scheme_Objectextract_cc_proc_marks (int argc, Scheme_Object *argv[])
static Scheme_Objectextract_one_cc_mark (int argc, Scheme_Object *argv[])
static Scheme_Objectcall_with_immediate_cc_mark (int argc, Scheme_Object *argv[])
static Scheme_Objectvoid_func (int argc, Scheme_Object *argv[])
static Scheme_Objectvoid_p (int argc, Scheme_Object *argv[])
static Scheme_Objectdynamic_wind (int argc, Scheme_Object *argv[])
static Scheme_Objectobject_name (int argc, Scheme_Object *argv[])
static Scheme_Objectprocedure_arity (int argc, Scheme_Object *argv[])
static Scheme_Objectprocedure_arity_p (int argc, Scheme_Object *argv[])
static Scheme_Objectprocedure_arity_includes (int argc, Scheme_Object *argv[])
static Scheme_Objectprocedure_reduce_arity (int argc, Scheme_Object *argv[])
static Scheme_Objectprocedure_rename (int argc, Scheme_Object *argv[])
static Scheme_Objectprocedure_equal_closure_p (int argc, Scheme_Object *argv[])
static Scheme_Objectprimitive_p (int argc, Scheme_Object *argv[])
static Scheme_Objectprimitive_closure_p (int argc, Scheme_Object *argv[])
static Scheme_Objectprimitive_result_arity (int argc, Scheme_Object *argv[])
static Scheme_Objectcall_with_values (int argc, Scheme_Object *argv[])
Scheme_Objectscheme_values (int argc, Scheme_Object *argv[])
static Scheme_Objectcurrent_print (int argc, Scheme_Object **argv)
static Scheme_Objectcurrent_prompt_read (int, Scheme_Object **)
static Scheme_Objectwrite_compiled_closure (Scheme_Object *obj)
static Scheme_Objectread_compiled_closure (Scheme_Object *obj)
void scheme_init_fun (Scheme_Env *env)
Scheme_Objectscheme_make_void (void)
static Scheme_Objectmake_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_Objectscheme_make_prim_w_everything (Scheme_Prim *fun, int eternal, const char *name, mzshort mina, mzshort maxa, int flags, mzshort minr, mzshort maxr)
Scheme_Objectscheme_make_prim (Scheme_Prim *fun)
Scheme_Objectscheme_make_noneternal_prim (Scheme_Prim *fun)
Scheme_Objectscheme_make_prim_w_arity (Scheme_Prim *fun, const char *name, mzshort mina, mzshort maxa)
Scheme_Objectscheme_make_folding_prim (Scheme_Prim *fun, const char *name, mzshort mina, mzshort maxa, short folding)
Scheme_Objectscheme_make_noncm_prim (Scheme_Prim *fun, const char *name, mzshort mina, mzshort maxa)
Scheme_Objectscheme_make_immed_prim (Scheme_Prim *fun, const char *name, mzshort mina, mzshort maxa)
Scheme_Objectscheme_make_noneternal_prim_w_arity (Scheme_Prim *fun, const char *name, mzshort mina, mzshort maxa)
Scheme_Objectscheme_make_prim_closure_w_arity (Scheme_Primitive_Closure_Proc *prim, int size, Scheme_Object **vals, const char *name, mzshort mina, mzshort maxa)
Scheme_Objectscheme_make_folding_prim_closure (Scheme_Primitive_Closure_Proc *prim, int size, Scheme_Object **vals, const char *name, mzshort mina, mzshort maxa, short functional)
Scheme_Objectscheme_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_Objectscheme_make_folding_closed_prim (Scheme_Closed_Prim *fun, void *data, const char *name, mzshort mina, mzshort maxa, short folding)
Scheme_Objectscheme_make_closed_prim_w_arity (Scheme_Closed_Prim *fun, void *data, const char *name, mzshort mina, mzshort maxa)
Scheme_Objectscheme_make_closed_prim (Scheme_Closed_Prim *fun, void *data)
void scheme_prim_is_method (Scheme_Object *o)
int scheme_has_method_property (Scheme_Object *code)
Scheme_Objectscheme_make_closure (Scheme_Thread *p, Scheme_Object *code, int close)
Scheme_Closurescheme_malloc_empty_closure ()
Scheme_Objectscheme_jit_closure (Scheme_Object *code, Scheme_Object *context)
void scheme_delay_load_closure (Scheme_Closure_Data *data)
Scheme_Objectscheme_optimize_closure_compilation (Scheme_Object *_data, Optimize_Info *info)
Scheme_Objectscheme_clone_closure_compilation (int dup_ok, Scheme_Object *_data, Optimize_Info *info, int delta, int closure_depth)
Scheme_Objectscheme_shift_closure_compilation (Scheme_Object *_data, int delta, int after_depth)
Scheme_Objectscheme_sfs_closure (Scheme_Object *expr, SFS_Info *info, int self_pos)
int scheme_closure_body_size (Scheme_Closure_Data *data, int check_assign)
int scheme_closure_has_top_level (Scheme_Closure_Data *data)
int scheme_closure_argument_flags (Scheme_Closure_Data *data, int i)
static XFORM_NONGCING int boxmap_size (int n)
static mzshortallocate_boxmap (int n)
static XFORM_NONGCING void boxmap_set (mzshort *boxmap, int j)
static XFORM_NONGCING int boxmap_get (mzshort *boxmap, int j)
Scheme_Objectscheme_resolve_closure_compilation (Scheme_Object *_data, Resolve_Info *info, int can_lift, int convert, int just_compute_lift, Scheme_Object *precomputed_lift)
Scheme_Objectscheme_source_to_name (Scheme_Object *code)
Scheme_Objectcombine_name_with_srcloc (Scheme_Object *name, Scheme_Object *code, int src_based_name)
Scheme_Objectscheme_build_closure_name (Scheme_Object *code, Scheme_Compile_Info *rec, int drec)
Scheme_Objectscheme_make_closure_compilation (Scheme_Comp_Env *env, Scheme_Object *code, Scheme_Compile_Info *rec, int drec)
static void initialize_prompt (Scheme_Thread *p, Scheme_Prompt *prompt, void *stack_boundary)
 MZ_DO_NOT_INLINE (void scheme_really_create_overflow(void *stack_base))
void scheme_really_create_overflow (void *stack_base)
void scheme_create_overflow (void)
void scheme_init_overflow (void)
void scheme_reset_overflow (void)
static Scheme_Promptallocate_prompt (Scheme_Prompt **cached_prompt)
static void save_dynamic_state (Scheme_Thread *thread, Scheme_Dynamic_State *state)
static void restore_dynamic_state (Scheme_Dynamic_State *state, Scheme_Thread *thread)
void scheme_set_dynamic_state (Scheme_Dynamic_State *state, Scheme_Comp_Env *env, Scheme_Object *mark, Scheme_Object *name, Scheme_Object *certs, Scheme_Env *menv, Scheme_Object *modidx)
voidscheme_top_level_do (void *(*k)(void), int eb)
voidscheme_top_level_do_worker (void *(*k)(void), int eb, int new_thread, Scheme_Dynamic_State *dyn_state)
void scheme_clear_prompt_cache ()
static void ensure_overflow_id (Scheme_Overflow *overflow)
void scheme_ensure_dw_id (Scheme_Dynamic_Wind *dw)
static Scheme_Objectforce_values (Scheme_Object *obj, int multi_ok)
Scheme_Objectscheme_force_value (Scheme_Object *obj)
Scheme_Objectscheme_force_one_value (Scheme_Object *obj)
Scheme_Objectscheme_force_value_same_mark (Scheme_Object *obj)
Scheme_Objectscheme_force_one_value_same_mark (Scheme_Object *obj)
static voidapply_k (void)
static Scheme_Object_apply (Scheme_Object *rator, int num_rands, Scheme_Object **rands, int multi, int eb)
Scheme_Objectscheme_apply (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
Scheme_Objectscheme_apply_multi (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
Scheme_Objectscheme_apply_thread_thunk (Scheme_Object *rator)
Scheme_Objectscheme_apply_with_dynamic_state (Scheme_Object *rator, int num_rands, Scheme_Object **rands, Scheme_Dynamic_State *dyn_state)
Scheme_Objectscheme_apply_multi_with_dynamic_state (Scheme_Object *rator, int num_rands, Scheme_Object **rands, Scheme_Dynamic_State *dyn_state)
Scheme_Objectscheme_apply_no_eb (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
Scheme_Objectscheme_apply_multi_no_eb (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
static Scheme_Objectfinish_apply_with_prompt (void *_data, int argc, Scheme_Object **argv)
static Scheme_Objectdo_apply_with_prompt (Scheme_Object *rator, int num_rands, Scheme_Object **rands, int multi, int top_level)
Scheme_Objectscheme_apply_with_prompt (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
Scheme_Objectscheme_apply_multi_with_prompt (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
Scheme_Object_scheme_apply_with_prompt (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
Scheme_Object_scheme_apply_multi_with_prompt (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
Scheme_Objectscheme_tail_apply (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
Scheme_Objectscheme_tail_apply_no_copy (Scheme_Object *rator, int num_rands, Scheme_Object **rands)
static Scheme_ObjectX_scheme_apply_to_list (Scheme_Object *rator, Scheme_Object *rands, int force, int top_level)
Scheme_Objectscheme_apply_to_list (Scheme_Object *rator, Scheme_Object *rands)
Scheme_Objectscheme_tail_apply_to_list (Scheme_Object *rator, Scheme_Object *rands)
Scheme_Object_scheme_apply_to_list (Scheme_Object *rator, Scheme_Object *rands)
Scheme_Object_scheme_tail_apply_to_list (Scheme_Object *rator, Scheme_Object *rands)
static Scheme_Objectcert_with_specials (Scheme_Object *code, Scheme_Object *mark, Scheme_Env *menv, Scheme_Object *orig_code, Scheme_Object *closest_code, Scheme_Comp_Env *cenv, int phase, int deflt, int cadr_deflt)
Scheme_Objectscheme_apply_macro (Scheme_Object *name, Scheme_Env *menv, Scheme_Object *rator, Scheme_Object *code, Scheme_Comp_Env *env, Scheme_Object *boundname, Scheme_Compile_Expand_Info *rec, int drec, int for_set)
Scheme_Objectscheme_make_arity (mzshort mina, mzshort maxa)
static Scheme_Objectclone_arity (Scheme_Object *a)
static Scheme_Objectget_or_check_arity (Scheme_Object *p, long a, Scheme_Object *bign)
Scheme_Objectscheme_get_or_check_arity (Scheme_Object *p, long a)
int scheme_check_proc_arity2 (const char *where, int a, int which, int argc, Scheme_Object **argv, int false_ok)
int scheme_check_proc_arity (const char *where, int a, int which, int argc, Scheme_Object **argv)
Scheme_Objectscheme_proc_struct_name_source (Scheme_Object *a)
const char * scheme_get_proc_name (Scheme_Object *p, int *len, int for_error)
static Scheme_Objectobject_name (int argc, Scheme_Object **argv)
Scheme_Objectscheme_arity (Scheme_Object *p)
static int is_arity (Scheme_Object *a, int at_least_ok, int list_ok)
void scheme_init_reduced_proc_struct (Scheme_Env *env)
static Scheme_Objectmake_reduced_proc (Scheme_Object *proc, Scheme_Object *aty, Scheme_Object *name)
static MZ_INLINE Scheme_Objectvalues_slow (int argc, Scheme_Object *argv[])
void scheme_detach_multple_array (Scheme_Object **values)
static void reset_cjs (Scheme_Continuation_Jump_State *a)
void scheme_clear_escape (void)
static void copy_cjs (Scheme_Continuation_Jump_State *a, Scheme_Continuation_Jump_State *b)
Scheme_Objectscheme_call_ec (int argc, Scheme_Object *argv[])
int scheme_escape_continuation_ok (Scheme_Object *ec)
static Scheme_Objectdo_call_with_sema (const char *who, int enable_break, int argc, Scheme_Object *argv[])
static Scheme_Saved_Stackcopy_out_runstack (Scheme_Thread *p, Scheme_Object **runstack, Scheme_Object **runstack_start, Scheme_Cont *share_from, Scheme_Prompt *effective_prompt)
static Scheme_Cont_Markcopy_out_mark_stack (Scheme_Thread *p, MZ_MARK_STACK_TYPE pos, Scheme_Cont *sub_cont, long *_offset, Scheme_Prompt *effective_prompt, int clear_caches)
static void copy_in_runstack (Scheme_Thread *p, Scheme_Saved_Stack *isaved, int set_runstack)
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, long copied_offset, Scheme_Object **_sub_conts, int clear_caches)
static MZ_MARK_STACK_TYPE find_shareable_marks ()
static Scheme_Overflowclone_overflows (Scheme_Overflow *overflow, void *limit, Scheme_Overflow *tail)
static Scheme_Dynamic_Windclone_dyn_wind (Scheme_Dynamic_Wind *dw, Scheme_Object *limit_prompt_tag, int limit_depth, Scheme_Dynamic_Wind *tail, int keep_tail, int composable)
static void clear_cm_copy_caches (Scheme_Cont_Mark *cp, int cnt)
static Scheme_Saved_Stackclone_runstack_saved (Scheme_Saved_Stack *saved, Scheme_Object **boundary_start, Scheme_Saved_Stack *last)
static Scheme_Saved_Stackclone_runstack_copied (Scheme_Saved_Stack *copied, Scheme_Object **copied_start, Scheme_Saved_Stack *saved, Scheme_Object **boundary_start, long boundary_offset)
static Scheme_Meta_Continuationclone_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)
static void sync_meta_cont (Scheme_Meta_Continuation *resume_mc)
void prune_cont_marks (Scheme_Meta_Continuation *resume_mc, Scheme_Cont *cont, Scheme_Object *extra_marks)
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)
static Scheme_Contgrab_continuation (Scheme_Thread *p, int for_prompt, int composable, Scheme_Object *prompt_tag, Scheme_Cont *sub_cont, Scheme_Prompt *prompt, Scheme_Meta_Continuation *prompt_cont, MZ_MARK_POS_TYPE prompt_pos, Scheme_Prompt *barrier_prompt, Scheme_Prompt *effective_barrier_prompt, Scheme_Meta_Continuation *barrier_cont, MZ_MARK_POS_TYPE barrier_pos)
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_Cont *sub_cont, 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)
void scheme_takeover_stacks (Scheme_Thread *p)
Scheme_Promptscheme_get_barrier_prompt (Scheme_Meta_Continuation **_meta_cont, MZ_MARK_POS_TYPE *_pos)
Scheme_Overflowscheme_get_thread_end_overflow (void)
void scheme_drop_prompt_meta_continuations (Scheme_Object *prompt_tag)
 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_Objectscheme_finish_apply_for_prompt (Scheme_Prompt *prompt, Scheme_Object *_prompt_tag, Scheme_Object *proc, int argc, Scheme_Object **argv)
 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_Objectscheme_apply_for_prompt (Scheme_Prompt *prompt, Scheme_Object *prompt_tag, Scheme_Object *proc, int argc, Scheme_Object **argv)
static Scheme_Objectcompose_continuation (Scheme_Cont *cont, int exec_chain, Scheme_Object *loop_prompt, int empty_to_next_mc)
static void continue_prompt_escape ()
static void restore_from_prompt (Scheme_Prompt *prompt)
static void prompt_unwind_dw (Scheme_Object *prompt_tag)
static void prompt_unwind_one_dw (Scheme_Object *prompt_tag)
static Scheme_Objectpropagate_abort (int argc, Scheme_Object **argv)
static Scheme_Objectdo_call_with_prompt (Scheme_Closed_Prim f, void *data, int multi, int top_level)
Scheme_Objectscheme_call_with_prompt (Scheme_Closed_Prim f, void *data)
Scheme_Objectscheme_call_with_prompt_multi (Scheme_Closed_Prim f, void *data)
Scheme_Object_scheme_call_with_prompt (Scheme_Closed_Prim f, void *data)
Scheme_Object_scheme_call_with_prompt_multi (Scheme_Closed_Prim f, void *data)
Scheme_Objectscheme_compose_continuation (Scheme_Cont *cont, int num_rands, Scheme_Object *value)
static Scheme_Objectcontinuation_marks (Scheme_Thread *p, Scheme_Object *_cont, Scheme_Object *econt, Scheme_Meta_Continuation *mc, Scheme_Object *prompt_tag, char *who, int just_chain)
Scheme_Objectscheme_current_continuation_marks (Scheme_Object *prompt_tag)
Scheme_Objectscheme_all_current_continuation_marks ()
Scheme_Objectscheme_get_stack_trace (Scheme_Object *mark_set)
Scheme_Objectscheme_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)
Scheme_Objectscheme_extract_one_cc_mark (Scheme_Object *mark_set, Scheme_Object *key)
Scheme_Objectscheme_extract_one_cc_mark_to_tag (Scheme_Object *mark_set, Scheme_Object *key, Scheme_Object *prompt_tag)
int scheme_is_cm_deeper (Scheme_Meta_Continuation *m1, MZ_MARK_POS_TYPE p1, Scheme_Meta_Continuation *m2, MZ_MARK_POS_TYPE p2)
static void pre_post_dyn_wind (Scheme_Object *prepost)
static Scheme_Objectdo_dyn_wind (void *d)
static void pre_dyn_wind (void *d)
static void post_dyn_wind (void *d)
Scheme_Objectscheme_dynamic_wind (void(*pre)(void *), Scheme_Object *(*volatile act)(void *), void(*volatile post)(void *), Scheme_Object *(*jmp_handler)(void *), void *volatile data)
void scheme_apply_dw_in_meta (Scheme_Dynamic_Wind *dw, int post_part, int meta_depth, Scheme_Cont *recheck)
Scheme_Objectscheme_default_print_handler (int argc, Scheme_Object *argv[])
Scheme_Objectscheme_default_prompt_read_handler (int argc, Scheme_Object *argv[])

Variables

int scheme_defining_primitives
Scheme_Object scheme_void [1]
Scheme_Objectscheme_values_func
Scheme_Objectscheme_procedure_p_proc
Scheme_Objectscheme_procedure_arity_includes_proc
Scheme_Objectscheme_void_proc
Scheme_Objectscheme_call_with_values_proc
Scheme_Objectscheme_reduced_procedure_struct
Scheme_Objectscheme_tail_call_waiting
Scheme_Objectscheme_inferred_name_symbol
Scheme_Objectscheme_default_prompt_tag
int scheme_cont_capture_count
int scheme_prompt_capture_count
static Scheme_Promptoriginal_default_prompt
static Scheme_Objectcertify_mode_symbol
static Scheme_Objecttransparent_symbol
static Scheme_Objecttransparent_binding_symbol
static Scheme_Objectopaque_symbol
static Scheme_Objectcont_key
static Scheme_Objectbarrier_prompt_key
static Scheme_Objectis_method_symbol
static Scheme_Objectcall_with_prompt_proc
static Scheme_Objectabort_continuation_proc
static Scheme_Objectinternal_call_cc_prim
static THREAD_LOCAL Scheme_Promptavailable_prompt
static THREAD_LOCAL Scheme_Promptavailable_cws_prompt
static THREAD_LOCAL Scheme_Promptavailable_regular_prompt
static THREAD_LOCAL
Scheme_Dynamic_Wind
available_prompt_dw
static THREAD_LOCAL
Scheme_Meta_Continuation
available_prompt_mc
static THREAD_LOCAL Scheme_Objectcached_beg_stx
static THREAD_LOCAL Scheme_Objectcached_dv_stx
static THREAD_LOCAL Scheme_Objectcached_ds_stx
static THREAD_LOCAL int cached_stx_phase
static Scheme_Contoffstack_cont
static Scheme_Overflowoffstack_overflow
THREAD_LOCAL Scheme_Overflow_Jmpscheme_overflow_jmp
THREAD_LOCAL voidscheme_overflow_stack_start

Class Documentation

struct Scheme_Dynamic_Wind_List

Definition at line 198 of file fun.c.

Collaboration diagram for Scheme_Dynamic_Wind_List:
Class Members
MZTAG_IF_REQUIRED
Scheme_Dynamic_Wind *
dw
int meta_depth
struct Scheme_Dynamic_Wind_List * next
struct Closure_Info

Definition at line 955 of file fun.c.

Class Members
mzshort * base_closure_map
mzshort base_closure_size
short body_size
short has_tl
MZTAG_IF_REQUIRED int * local_flags
struct Dyn_Wind

Definition at line 7514 of file fun.c.

Collaboration diagram for Dyn_Wind:
Class Members
MZTAG_IF_REQUIRED Scheme_Object * act
MZTAG_IF_REQUIRED Scheme_Object * post
MZTAG_IF_REQUIRED Scheme_Object * pre

Define Documentation

#define AND_MODE

Definition at line 3831 of file fun.c.

#define BAD_CC   "bad compiled closure"
#define BOOL (   x)    (x ? scheme_true : scheme_false)

Definition at line 8400 of file fun.c.

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

Definition at line 190 of file fun.c.

#define DO_MAP   map

Definition at line 3837 of file fun.c.

#define DO_MAP   for_each

Definition at line 3837 of file fun.c.

#define DO_MAP   andmap

Definition at line 3837 of file fun.c.

#define DO_MAP   ormap

Definition at line 3837 of file fun.c.

#define FOR_EACH_MODE

Definition at line 3823 of file fun.c.

#define MAP_MODE

Definition at line 3815 of file fun.c.

#define MAP_NAME   "map"

Definition at line 3838 of file fun.c.

#define MAP_NAME   "for-each"

Definition at line 3838 of file fun.c.

#define MAP_NAME   "andmap"

Definition at line 3838 of file fun.c.

#define MAP_NAME   "ormap"

Definition at line 3838 of file fun.c.

#define OR_MODE

Definition at line 3839 of file fun.c.

#define QUICK_PROMPT_ARGS   3
#define X_SCHEME_ASSERT (   x,
  y 
)

Typedef Documentation

typedef void(* DW_PrePost_Proc)(void *)

Definition at line 188 of file fun.c.

Definition at line 1830 of file fun.c.


Function Documentation

static Scheme_Object* _apply ( Scheme_Object rator,
int  num_rands,
Scheme_Object **  rands,
int  multi,
int  eb 
) [static]

Definition at line 2243 of file fun.c.

{
  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);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 2382 of file fun.c.

{
  return do_apply_with_prompt(rator, num_rands, rands, 1, 0);
}

Here is the call graph for this function:

Definition at line 2480 of file fun.c.

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

Here is the call graph for this function:

Here is the caller graph for this function:

Scheme_Object* _scheme_apply_with_prompt ( Scheme_Object rator,
int  num_rands,
Scheme_Object **  rands 
)

Definition at line 2377 of file fun.c.

{
  return do_apply_with_prompt(rator, num_rands, rands, 0, 0);
}

Here is the call graph for this function:

Definition at line 6433 of file fun.c.

{
  return do_call_with_prompt(f, data, 0, 0);
}

Here is the call graph for this function:

Definition at line 6438 of file fun.c.

{
  return do_call_with_prompt(f, data, 1, 0);
}

Here is the call graph for this function:

Definition at line 2486 of file fun.c.

{
  return X_scheme_apply_to_list(rator, rands, 0, 0);
}

Here is the call graph for this function:

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

Definition at line 6542 of file fun.c.

{
  Scheme_Object *prompt_tag;
  Scheme_Prompt *prompt;
  Scheme_Thread *p = scheme_current_thread;

  prompt_tag = argv[0];
  if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(prompt_tag))) {
    scheme_wrong_type("abort-current-continuation", "continuation-prompt-tag",
                      0, argc, argv);
  }

  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_arg_mismatch("abort-current-continuation", 
                        "continuation includes no prompt with the given tag: ",
                        prompt_tag);
    return NULL;
  }

  if (argc == 2) {
    p->cjs.num_vals = 1;
    p->cjs.val = argv[1];
  } else {
    Scheme_Object **vals;
    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;
    p->cjs.val = (Scheme_Object *)vals;
  }
  p->cjs.jumping_to_continuation = (Scheme_Object *)prompt;

  scheme_longjmp(*p->error_buf, 1);

  return NULL;
}

Here is the caller graph for this function:

static mzshort* allocate_boxmap ( int  n) [static]

Definition at line 1211 of file fun.c.

{
  mzshort *boxmap;
  int size;

  size = boxmap_size(n);
  boxmap = MALLOC_N_ATOMIC(mzshort, size);
  memset(boxmap, 0, size * sizeof(mzshort));

  return boxmap;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Prompt* allocate_prompt ( Scheme_Prompt **  cached_prompt) [static]

Definition at line 1941 of file fun.c.

                                                                     {
  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;
}

Here is the caller graph for this function:

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

Here is the caller graph for this function:

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

Definition at line 3771 of file fun.c.

{
  Scheme_Object *rands;
  Scheme_Object **rand_vec;
  int i, num_rands;
  Scheme_Thread *p = scheme_current_thread;

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

  rands = argv[argc-1];

  num_rands = scheme_proper_list_length(rands);
  if (num_rands < 0) {
    scheme_wrong_type("apply", "proper 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;
}

Here is the caller graph for this function:

static void* apply_k ( void  ) [static]

Definition at line 2222 of file fun.c.

{
  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);
}

Here is the caller graph for this function:

static void ASSERT_SUSPEND_BREAK_ZERO ( ) [static]

Definition at line 71 of file fun.c.

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

Here is the caller graph for this function:

static XFORM_NONGCING int boxmap_get ( mzshort boxmap,
int  j 
) [static]

Definition at line 1228 of file fun.c.

{
  if (boxmap[j / BITS_PER_MZSHORT] & ((mzshort)1 << (j & (BITS_PER_MZSHORT - 1))))
    return 1;
  else
    return 0;
}

Here is the caller graph for this function:

static XFORM_NONGCING void boxmap_set ( mzshort boxmap,
int  j 
) [static]

Definition at line 1223 of file fun.c.

{
  boxmap[j / BITS_PER_MZSHORT] |= ((mzshort)1 << (j & (BITS_PER_MZSHORT - 1)));
}

Here is the caller graph for this function:

static XFORM_NONGCING int boxmap_size ( int  n) [static]

Definition at line 1206 of file fun.c.

{
  return (n + (BITS_PER_MZSHORT - 1)) / BITS_PER_MZSHORT;
}

Here is the caller graph for this function:

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

Definition at line 4870 of file fun.c.

{
  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_wrong_type("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);
}

Here is the caller graph for this function:

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

Definition at line 5677 of file fun.c.

{
  scheme_check_proc_arity("call-with-continuation-barrier", 0, 0, argc, argv);

  return scheme_apply_multi(argv[0], 0, NULL);
}

Here is the caller graph for this function:

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

Definition at line 6585 of file fun.c.

{
  Scheme_Object *prompt_tag;
  Scheme_Object *a[3];

  scheme_check_proc_arity("call-with-composable-continuation", 1, 0, argc, argv);
  if (argc > 1) {
    if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[1]))) {
      scheme_wrong_type("call-with-composable-continuation", "continuation-prompt-tag",
                        1, argc, argv);
    }
    prompt_tag = argv[1];
  } else
    prompt_tag = scheme_default_prompt_tag;

  a[0] = argv[0];
  a[1] = prompt_tag;
  a[2] = scheme_true;

  /* 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);
}

Here is the caller graph for this function:

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

Definition at line 4028 of file fun.c.

{
  Scheme_Thread *p = scheme_current_thread;
  long findpos, bottom;
  Scheme_Object *a[1], *key;

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

  key = argv[0];
  if (argc > 2)
    a[0] = argv[2];
  else
    a[0] = scheme_false;

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

      if ((long)find->pos < (long)MZ_CONT_MARK_POS) {
        break;
      } else {
        if (find->key == key) {
          a[0] = find->val;
          break;
        }
      }
    }
  }

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

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 6129 of file fun.c.

{
  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;

  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) {
    if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(in_argv[1]))) {
      scheme_wrong_type("call-with-continuation-prompt", "continuation-prompt-tag",
                        1, in_argc, in_argv);
    }
    prompt_tag = in_argv[1];
  } else
    prompt_tag = scheme_default_prompt_tag;

  if (in_argc > 2) {
    if (SCHEME_TRUEP(in_argv[2]) && !SCHEME_PROCP(in_argv[2]))
      scheme_wrong_type("call-with-continuation-prompt", "procedure or #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;

    scheme_push_continuation_frame(&cframe);
    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);

    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;

    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;

    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: */
            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) {
          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 (SAME_OBJ(handler, scheme_values_func)) {
            v = scheme_values(argc, argv);
            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;
    }

    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,
                                "application of default prompt handler");
    }
  }

  if (handler) {
    return _scheme_tail_apply(handler, argc, argv);
  } else
    return v;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 4155 of file fun.c.

{
  return do_call_with_sema("call-with-semaphore", 0, argc, argv);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 4161 of file fun.c.

{
  return do_call_with_sema("call-with-semaphore/enable-break", 1, argc, argv);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 3845 of file fun.c.

{
  Scheme_Thread *p;
  Scheme_Object *v;

  scheme_check_proc_arity("call-with-values", 0, 0, argc, argv);
  if (!SCHEME_PROCP(argv[1]))
    scheme_wrong_type("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;
    /* Beware: the fields overlap! */
    n = p->ku.multiple.count;
    a = p->ku.multiple.array;
    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;
}

Here is the caller graph for this function:

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

Definition at line 6901 of file fun.c.

{
  if (argc) {
    if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[0]))) {
      scheme_wrong_type("current-continuation-marks", "continuation-prompt-tag",
                        0, argc, argv);
    }

    if (!SAME_OBJ(scheme_default_prompt_tag, argv[0]))
      if (!scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(argv[0])))
        scheme_arg_mismatch("current-continuation-marks",
                            "no corresponding prompt in the continuation: ",
                            argv[0]);
  }

  return scheme_current_continuation_marks(argc ? argv[0] : NULL);
}

Here is the caller graph for this function:

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

Definition at line 6996 of file fun.c.

{
  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type))
    return scheme_false;
  else
    return scheme_true;
}

Here is the caller graph for this function:

static Scheme_Object* cert_with_specials ( Scheme_Object code,
Scheme_Object mark,
Scheme_Env menv,
Scheme_Object orig_code,
Scheme_Object closest_code,
Scheme_Comp_Env cenv,
int  phase,
int  deflt,
int  cadr_deflt 
) [static]

Definition at line 2492 of file fun.c.

{
  Scheme_Object *prop;
  int next_cadr_deflt = 0;

  if (!certify_mode_symbol) {
    REGISTER_SO(certify_mode_symbol);
    REGISTER_SO(transparent_symbol);
    REGISTER_SO(transparent_binding_symbol);
    REGISTER_SO(opaque_symbol);
    certify_mode_symbol = scheme_intern_symbol("certify-mode");
    transparent_symbol = scheme_intern_symbol("transparent");
    transparent_binding_symbol = scheme_intern_symbol("transparent-binding");
    opaque_symbol = scheme_intern_symbol("opaque");
  }

  if (SCHEME_STXP(code)) {
    prop = scheme_stx_property(code, certify_mode_symbol, NULL);
    if (SAME_OBJ(prop, opaque_symbol)) {
      return scheme_stx_cert(code, mark, menv, orig_code, NULL, 1);
    } else if (SAME_OBJ(prop, transparent_symbol)) {
      cadr_deflt = 0;
      /* fall through */
    } else if (SAME_OBJ(prop, transparent_binding_symbol)) {
      cadr_deflt = 0;
      next_cadr_deflt = 1;
      /* fall through */
    } else {
      /* Default transparency depends on module-identifier=? comparison
        to `begin', `define-values', and `define-syntaxes'. */
      int trans = deflt;
      if (SCHEME_TRUEP(prop))
        scheme_log(NULL,
                   SCHEME_LOG_WARNING,
                   0,
                   "warning: unrecognized 'certify-mode property value: %V",
                   prop);
      if (SCHEME_STX_PAIRP(code)) {
       Scheme_Object *name;
       name = SCHEME_STX_CAR(code);
       if (SCHEME_STX_SYMBOLP(name)) {
         Scheme_Object *beg_stx, *dv_stx, *ds_stx;

         if (!phase) {
           beg_stx = scheme_begin_stx;
           dv_stx = scheme_define_values_stx;
           ds_stx = scheme_define_syntaxes_stx;
         } else if (phase == cached_stx_phase) {
           beg_stx = cached_beg_stx;
           dv_stx = cached_dv_stx;
           ds_stx = cached_ds_stx;
         } else {
           beg_stx = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_begin_stx), scheme_false, 
                                        scheme_sys_wraps(cenv), 0, 0);
           dv_stx = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_define_values_stx), scheme_false, 
                                       scheme_sys_wraps(cenv), 0, 0);
           ds_stx = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_define_syntaxes_stx), scheme_false, 
                                       scheme_sys_wraps(cenv), 0, 0);
           cached_beg_stx = beg_stx;
           cached_dv_stx = dv_stx;
           cached_ds_stx = ds_stx;
           cached_stx_phase = phase;
         }

         if (scheme_stx_module_eq(beg_stx, name, phase)) {
           trans = 1;
           next_cadr_deflt = 0;
         } else if (scheme_stx_module_eq(dv_stx, name, phase)
                   || scheme_stx_module_eq(ds_stx, name, phase)) {
           trans = 1;
           next_cadr_deflt = 1;
         }
       }
      }
      
      if (!trans)
       return scheme_stx_cert(code, mark, menv, orig_code, NULL, 1);
    }
  }

  if (SCHEME_STX_PAIRP(code)) {
    Scheme_Object *a, *d, *v;
    
    if (SCHEME_STXP(code))
      closest_code = code;

    a = SCHEME_STX_CAR(code);
    a = scheme_stx_propagate_inactive_certs(a, closest_code);
    a = cert_with_specials(a, mark, menv, orig_code, closest_code, cenv, phase, cadr_deflt, 0);
    d = SCHEME_STX_CDR(code);
    if (SCHEME_STXP(d))
      d = scheme_stx_propagate_inactive_certs(d, closest_code);
    d = cert_with_specials(d, mark, menv, orig_code, closest_code, cenv, phase, 1, next_cadr_deflt);

    v = scheme_make_pair(a, d);

    if (SCHEME_PAIRP(code))
      return v;

    return scheme_datum_to_syntax(v, code, code, 0, 2);
  } else if (SCHEME_STX_NULLP(code))
    return code;

  return scheme_stx_cert(code, mark, menv, orig_code, NULL, 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void clear_cm_copy_caches ( Scheme_Cont_Mark cp,
int  cnt 
) [static]

Definition at line 4493 of file fun.c.

{
  int i;
  for (i = 0; i < cnt; i++) {
    cp[i].cache = NULL;
  }
}

Here is the caller graph for this function:

static Scheme_Object* clone_arity ( Scheme_Object a) [static]

Definition at line 2720 of file fun.c.

{
  if (SCHEME_PAIRP(a)) {
    Scheme_Object *m, *l;
    m = scheme_copy_list(a);
    for (l = m; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
      a = clone_arity(SCHEME_CAR(l));
      SCHEME_CAR(l) = a;
    }
    return m;
  } else if (SCHEME_STRUCTP(a)) {
    Scheme_Object *p[1];
    p[0] = ((Scheme_Structure *)a)->slots[0];
    return scheme_make_struct_instance(scheme_arity_at_least, 1, p);
  } else
    return a;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Dynamic_Wind* clone_dyn_wind ( Scheme_Dynamic_Wind dw,
Scheme_Object limit_prompt_tag,
int  limit_depth,
Scheme_Dynamic_Wind tail,
int  keep_tail,
int  composable 
) [static]

Definition at line 4452 of file fun.c.

{
  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;
    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;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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 
) [static]

Definition at line 4582 of file fun.c.

{
  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. */
      long 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, 
                                      prompt->runstack_boundary_start,
                                      prompt->runstack_boundary_offset);
        cnaya->runstack_copied = saved;

        /* Prune unneeded buffers */
        if (prompt->runstack_boundary_start == cnaya->runstack_start)
          saved = NULL;
        else
          saved = clone_runstack_saved(cnaya->runstack_saved, 
                                       prompt->runstack_boundary_start,
                                       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);
        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;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Overflow* clone_overflows ( Scheme_Overflow overflow,
void limit,
Scheme_Overflow tail 
) [static]

Definition at line 4431 of file fun.c.

{
  Scheme_Overflow *naya, *first = NULL, *prev = NULL;

  for (; overflow && (!limit || (overflow->id != limit)); 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 (first) {
    prev->prev = tail;
    return first;
  } else
    return tail;
}

Here is the caller graph for this function:

static Scheme_Saved_Stack* clone_runstack_copied ( Scheme_Saved_Stack copied,
Scheme_Object **  copied_start,
Scheme_Saved_Stack saved,
Scheme_Object **  boundary_start,
long  boundary_offset 
) [static]

Definition at line 4524 of file fun.c.

{
  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))) {
      long 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;
}

Here is the caller graph for this function:

static Scheme_Saved_Stack* clone_runstack_saved ( Scheme_Saved_Stack saved,
Scheme_Object **  boundary_start,
Scheme_Saved_Stack last 
) [static]

Definition at line 4501 of file fun.c.

{
  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;
}

Here is the caller graph for this function:

Scheme_Object* combine_name_with_srcloc ( Scheme_Object name,
Scheme_Object code,
int  src_based_name 
)

Definition at line 1672 of file fun.c.

{
  Scheme_Stx *cstx = (Scheme_Stx *)code;

  if (((cstx->srcloc->col >= 0) || (cstx->srcloc->pos >= 0))
      && cstx->srcloc->src) {
    Scheme_Object *vec;
    vec = scheme_make_vector(7, NULL);
    SCHEME_VEC_ELS(vec)[0] = name;
    SCHEME_VEC_ELS(vec)[1] = cstx->srcloc->src;
    if (cstx->srcloc->line >= 0) {
      SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(cstx->srcloc->line);
      SCHEME_VEC_ELS(vec)[3] = scheme_make_integer(cstx->srcloc->col-1);
    } else {
      SCHEME_VEC_ELS(vec)[2] = scheme_false;
      SCHEME_VEC_ELS(vec)[3] = scheme_false;
    }
    if (cstx->srcloc->pos >= 0)
      SCHEME_VEC_ELS(vec)[4] = scheme_make_integer(cstx->srcloc->pos);
    else
      SCHEME_VEC_ELS(vec)[4] = scheme_false;
    if (cstx->srcloc->span >= 0)
      SCHEME_VEC_ELS(vec)[5] = scheme_make_integer(cstx->srcloc->span);
    else
      SCHEME_VEC_ELS(vec)[5] = scheme_false;
    SCHEME_VEC_ELS(vec)[6] = (src_based_name ? scheme_true : scheme_false);
    
    return vec;
  }

  return name;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* compose_continuation ( Scheme_Cont cont,
int  exec_chain,
Scheme_Object loop_prompt,
int  empty_to_next_mc 
) [static]

Definition at line 5907 of file fun.c.

{
  /* 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, 0, NULL, NULL, NULL, 0);

  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,
                         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);

  ESCAPED_BEFORE_HERE;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 6920 of file fun.c.

{
  Scheme_Object *prompt_tag;

  if (!SCHEME_CONTP(argv[0]) && !SCHEME_ECONTP(argv[0]) && !SCHEME_THREADP(argv[0]))
    scheme_wrong_type("continuation-marks", "continuation or thread", 0, argc, argv);

  if (argc > 1) {
    if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[1]))) {
      scheme_wrong_type("continuation-marks", "continuation-prompt-tag",
                        1, argc, argv);
    }
    prompt_tag = argv[1];
  } else
    prompt_tag = scheme_default_prompt_tag;

  if (SCHEME_ECONTP(argv[0])) {
    if (!scheme_escape_continuation_ok(argv[0])) {
      scheme_arg_mismatch("continuation-marks",
                       "escape continuation not in the current thread's continuation: ",
                       argv[0]);
      return NULL;
    } else {
      Scheme_Meta_Continuation *mc;
      scheme_extract_one_cc_mark_with_meta(NULL, argv[0], NULL, &mc, NULL);

      return continuation_marks(scheme_current_thread, NULL, argv[0], mc, prompt_tag, 
                                "continuation-marks", 0);
    }
  } 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)) {
      /* 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;
    } 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();

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

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* continuation_marks ( Scheme_Thread p,
Scheme_Object _cont,
Scheme_Object econt,
Scheme_Meta_Continuation mc,
Scheme_Object prompt_tag,
char *  who,
int  just_chain 
) [static]

Definition at line 6609 of file fun.c.

{
  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;
  long findpos, bottom;
  long cmpos, cdelta = 0;
  int found_tag = 0;

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

  do {
    if (econt) {
      findpos = (long)((Scheme_Escaping_Cont *)econt)->envss.cont_mark_stack;
      cmpos = (long)((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 = (long)cont->ss.cont_mark_stack;
      cmpos = (long)cont->ss.cont_mark_pos;
      cdelta = cont->cont_mark_offset;
      bottom = 0;
    } else if (mc) {
      findpos = (long)mc->cont_mark_stack;
      cmpos = (long)mc->cont_mark_pos;
      cdelta = mc->cont_mark_offset;
      bottom = 0;
    } else {
      findpos = (long)MZ_CONT_MARK_STACK;
      cmpos = (long)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;
      long 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.cont;
          }
          cont = cont->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;
        break;
      }

      cache = find[pos].cache;
      if (cache) {
        if (SCHEME_FALSEP(cache))
          cache = NULL;
        if (cache) {
          if (SCHEME_HASHTP(cache))
            cache = scheme_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;
          else
            first = (Scheme_Cont_Mark_Chain *)cache;
          
          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;

        break;
      } else {
        Scheme_Cont_Mark_Chain *pr;
        pr = MALLOC_ONE_RT(Scheme_Cont_Mark_Chain);
        pr->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) {
            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;
            find = cp;
            mc->cm_shared = 0;
          }
          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_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;
        else
          first = pr;

        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_arg_mismatch(who,
                          "no corresponding prompt in the continuation: ",
                          prompt_tag);
    }
  }

  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

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

  return (Scheme_Object *)set;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 5635 of file fun.c.

{
  return ((SCHEME_CONTP(argv[0]) || SCHEME_ECONTP(argv[0]))
          ? scheme_true
          : scheme_false);
}

Here is the caller graph for this function:

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

Definition at line 7463 of file fun.c.

{
  Scheme_Object *prompt_tag;

  prompt_tag = argv[0];
  if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(prompt_tag))) {
    scheme_wrong_type("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_arg_mismatch("continuation-prompt-available?",
                            "escape continuation not in the current thread's continuation: ",
                            argv[1]);
        return NULL;
      } else {
        Scheme_Meta_Continuation *mc;

        if (SAME_OBJ(scheme_default_prompt_tag, prompt_tag))
          return scheme_true;

        scheme_extract_one_cc_mark_with_meta(NULL, argv[1], NULL, &mc, NULL);
        
        if (continuation_marks(scheme_current_thread, NULL, argv[1], mc, prompt_tag, 
                               NULL, 0))
          return scheme_true;
      }
    } else if (SCHEME_CONTP(argv[1])) {
      if (continuation_marks(NULL, argv[1], NULL, NULL, prompt_tag, NULL, 0))
        return scheme_true;
    } else {
      scheme_wrong_type("continuation-prompt-available?", "continuation",
                        1, argc, argv);
    }
  } else {
    if (SAME_OBJ(scheme_default_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;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void continue_prompt_escape ( ) [static]

Definition at line 6054 of file fun.c.

{
  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);
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 3951 of file fun.c.

Here is the caller graph for this function:

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,
long  copied_offset,
Scheme_Object **  _sub_conts,
int  clear_caches 
) [static]

Definition at line 4324 of file fun.c.

{
  long cmcount, base_cmcount, cmoffset;
  Scheme_Cont_Mark *cm_src;
  Scheme_Cont *sub_cont = NULL;

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

  if (cmcount) {
    /* First, make sure we have enough segments */
    long 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 MzScheme 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;
    }
  }

  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];
    long 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++;
  }
}

Here is the caller graph for this function:

static void copy_in_runstack ( Scheme_Thread p,
Scheme_Saved_Stack isaved,
int  set_runstack 
) [static]

Definition at line 4299 of file fun.c.

{
  Scheme_Saved_Stack *csaved;
  long 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 *));
  }
}

Here is the caller graph for this function:

static Scheme_Cont_Mark* copy_out_mark_stack ( Scheme_Thread p,
MZ_MARK_STACK_TYPE  pos,
Scheme_Cont sub_cont,
long *  _offset,
Scheme_Prompt effective_prompt,
int  clear_caches 
) [static]

Definition at line 4253 of file fun.c.

{
  long cmcount, offset = 0, sub_count = 0;
  Scheme_Cont_Mark *cont_mark_stack_copied;

  /* Copy cont mark stack: */
  cmcount = (long)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];
      long 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;
}

Here is the caller graph for this function:

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 
) [static]

Definition at line 4166 of file fun.c.

{
  Scheme_Saved_Stack *saved, *isaved, *csaved, *share_saved, *share_csaved, *ss;
  Scheme_Object **start;
  long 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)) {
    /* 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 add one, because call/cc takes one argument. If there's not one
       move value on the stack, then call/cc must have received its argument
       from elsewhere. */
    if (share_from->ss.runstack_offset < p->runstack_size)
      size++;
  } else if (effective_prompt && (effective_prompt->runstack_boundary_start == 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);
  }

  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 || (effective_prompt->runstack_boundary_start != 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 && (effective_prompt->runstack_boundary_start == 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;
}

Here is the caller graph for this function:

static Scheme_Object * current_print ( int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 8323 of file fun.c.

{
  return scheme_param_config("current-print",
                          scheme_make_integer(MZCONFIG_PRINT_HANDLER),
                          argc, argv,
                          1, NULL, NULL, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * current_prompt_read ( int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 8332 of file fun.c.

{
  return scheme_param_config("current-prompt-read",
                          scheme_make_integer(MZCONFIG_PROMPT_READ_HANDLER),
                          argc, argv,
                          0, NULL, NULL, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_apply_with_prompt ( Scheme_Object rator,
int  num_rands,
Scheme_Object **  rands,
int  multi,
int  top_level 
) [static]

Definition at line 2337 of file fun.c.

{
  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);
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_call_with_prompt ( Scheme_Closed_Prim  f,
void data,
int  multi,
int  top_level 
) [static]

Definition at line 6400 of file fun.c.

{
  Scheme_Object *prim, *a[3];

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

  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);
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_call_with_sema ( const char *  who,
int  enable_break,
int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 4065 of file fun.c.

{
  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_type(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)) {
    scheme_wrong_type(who, "procedure (arity matching extra args)", 1, argc, argv);
    return NULL;
  }
  if ((argc > 2) && SCHEME_TRUEP(argv[2])) {
    if (!scheme_check_proc_arity(NULL, 0, 2, argc, argv)) {
      scheme_wrong_type(who, "procedure (arity 0) or #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;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_dyn_wind ( void d) [static]

Definition at line 7539 of file fun.c.

{
  Dyn_Wind *dw;
  dw = (Dyn_Wind *)d;

  return _scheme_apply_multi(dw->act, 0, NULL);
}

Here is the caller graph for this function:

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

Definition at line 7557 of file fun.c.

{
  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;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void ensure_overflow_id ( Scheme_Overflow overflow) [static]

Definition at line 2116 of file fun.c.

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

Here is the caller graph for this function:

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 
) [static]

Definition at line 4827 of file fun.c.

{
  Scheme_Thread *p = scheme_current_thread;
  int old_cac = scheme_continuation_application_count;

  for (; dwl; dwl = dwl->next) {
    if (dwl->dw->pre) {
      p->dw = dwl->dw->prev;
      p->next_meta = dwl->meta_depth + dwl->dw->next_meta;
      if (dwl->meta_depth > 0) {
        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;
        MZ_CONT_MARK_POS = dwl->dw->envss.cont_mark_pos;
        MZ_CONT_MARK_STACK = dwl->dw->envss.cont_mark_stack;
        copy_in_mark_stack(p, cont->cont_mark_stack_copied, 
                           MZ_CONT_MARK_STACK, copied_cms,
                           cont->cont_mark_offset, _sub_conts,
                           clear_cm_caches);
        copied_cms = MZ_CONT_MARK_STACK;

        pre(dwl->dw->data);

        if (scheme_continuation_application_count != old_cac) {
          old_cac = scheme_continuation_application_count;
          scheme_recheck_prompt_and_barrier(cont);
        }
      }
      p = scheme_current_thread;
    }
  }
  return copied_cms;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 7005 of file fun.c.

{
  Scheme_Cont_Mark_Chain *chain;
  Scheme_Object *first = scheme_null, *last = NULL, *key, *prompt_tag;
  Scheme_Object *pr;

  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) {
    scheme_wrong_type("continuation-mark-set->list", "continuation-mark-set", 0, argc, argv);
    return NULL;
  }
  if (argc > 2) {
    if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[2]))) {
      scheme_wrong_type("continuation-mark-set->list", "continuation-prompt-tag",
                        2, argc, argv);
    }
    prompt_tag = argv[2];
  } else
    prompt_tag = scheme_default_prompt_tag;

  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;
  }

  prompt_tag = SCHEME_PTR_VAL(prompt_tag);

  while (chain) {
    if (chain->key == key) {
      pr = scheme_make_pair(chain->val, 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;
}

Here is the caller graph for this function:

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

Definition at line 7054 of file fun.c.

{
  Scheme_Cont_Mark_Chain *chain;
  Scheme_Object *first = scheme_null, *last = NULL;
  Scheme_Object *pr, **keys, *vals, *none, *prompt_tag;
  int len, i;
  long last_pos;

  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) {
    scheme_wrong_type("continuation-mark-set->list*", "continuation-mark-set", 0, argc, argv);
    return NULL;
  }
  len = scheme_proper_list_length(argv[1]);
  if (len < 0) {
    scheme_wrong_type("continuation-mark-set->list*", "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]))) {
      scheme_wrong_type("continuation-mark-set->list*", "continuation-prompt-tag",
                        3, argc, argv);
    }
    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)
       || (keys[i] == scheme_exn_handler_key)) {
      scheme_signal_error("continuation-mark-set->list: secret key leaked!");
      return NULL;
    }
  }

  prompt_tag = SCHEME_PTR_VAL(prompt_tag);

  chain = ((Scheme_Cont_Mark_Set *)argv[0])->chain;
  last_pos = ((Scheme_Cont_Mark_Set *)argv[0])->cmpos + 2;

  while (chain) {
    for (i = 0; i < len; i++) {
      if (SAME_OBJ(chain->key, keys[i])) {
       long pos;
       pos = (long)chain->pos;
       if (pos != last_pos) {
         vals = scheme_make_vector(len, none);
         last_pos = pos;
         pr = scheme_make_pair(vals, scheme_null);
         if (last)
           SCHEME_CDR(last) = pr;
         else
           first = pr;
         last = pr;
       } else
         vals = SCHEME_CAR(last);
       SCHEME_VEC_ELS(vals)[i] = chain->val;
      }
    }

    if (SAME_OBJ(chain->key, prompt_tag))
      break;
    
    chain = chain->next;
  }

  return first;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 7195 of file fun.c.

{
  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_cont_mark_set_type)) {
    scheme_wrong_type("continuation-mark-set->context", "continuation-mark-set", 0, argc, argv);
    return NULL;
  }

  return scheme_get_stack_trace(argv[0]);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 7401 of file fun.c.

{
  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_type("continuation-mark-set-first", "continuation-mark-set or #f", 0, argc, argv);
  
  if ((argv[1] == scheme_parameterization_key)
      || (argv[1] == scheme_break_enabled_key)) {
    /* Minor hack: these keys are used in "startup.ss" 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]))) {
      scheme_wrong_type("continuation-mark-set-first", "continuation-prompt-tag",
                        3, argc, argv);
    }
    prompt_tag = argv[3];

    if (!SAME_OBJ(scheme_default_prompt_tag, prompt_tag)) {
      if (SCHEME_FALSEP(argv[0])) {
        if (!scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(prompt_tag)))
          scheme_arg_mismatch("continuation-mark-set-first",
                              "no corresponding prompt in the current continuation: ",
                              prompt_tag);
      }
    }
  } 

  r = scheme_extract_one_cc_mark_with_meta(SCHEME_TRUEP(argv[0]) ? argv[0] : NULL, argv[1], 
                                           prompt_tag, NULL, NULL);
  if (!r) {
    if (argc > 2)
      r = argv[2];
    else
      r = scheme_false;
  }

  return r;
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 4409 of file fun.c.

{
  Scheme_Thread *p = scheme_current_thread;
  long cmcount, delta = 0;

  cmcount = (long)MZ_CONT_MARK_STACK;

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

    if (seg[pos].pos < MZ_CONT_MARK_POS)
      break;
    if (SAME_OBJ(seg[pos].key, cont_key))
      delta = 1;
    else
      delta = 0;
  }

  return cmcount + 1 + delta;
}

Here is the caller graph for this function:

static Scheme_Object* finish_apply_with_prompt ( void _data,
int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 2319 of file fun.c.

{
  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);
}

Here is the caller graph for this function:

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

Here is the caller graph for this function:

static Scheme_Object* force_values ( Scheme_Object obj,
int  multi_ok 
) [static]

Definition at line 2143 of file fun.c.

{
  if (SAME_OBJ(obj, SCHEME_TAIL_CALL_WAITING)) {
    Scheme_Thread *p = scheme_current_thread;
    GC_CAN_IGNORE Scheme_Object *rator;
    GC_CAN_IGNORE Scheme_Object **rands;
      
    /* Watch out for use of tail buffer: */
    if (p->ku.apply.tail_rands == p->tail_buffer) {
      GC_CAN_IGNORE Scheme_Object **tb;
      p->tail_buffer = NULL; /* so args aren't zeroed */
      tb = MALLOC_N(Scheme_Object *, p->tail_buffer_size);
      p->tail_buffer = tb;
    }

    rator = p->ku.apply.tail_rator;
    rands = p->ku.apply.tail_rands;
    p->ku.apply.tail_rator = NULL;
    p->ku.apply.tail_rands = NULL;
      
    if (multi_ok) {
      return _scheme_apply_multi(rator,
                             p->ku.apply.tail_num_rands,
                             rands);
    } else {
      return _scheme_apply(rator,
                        p->ku.apply.tail_num_rands,
                        rands);
    }
  } 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;
}

Here is the caller graph for this function:

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

Definition at line 5712 of file fun.c.

Here is the caller graph for this function:

static Scheme_Object* get_or_check_arity ( Scheme_Object p,
long  a,
Scheme_Object bign 
) [static]

Definition at line 2738 of file fun.c.

{
  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) {
    Scheme_Case_Lambda *seq;
    Scheme_Closure_Data *data;
    int i;
    Scheme_Object *first, *last = NULL, *v;

    if (a == -1)
      first = scheme_null;
    else
      first = scheme_false;

    seq = (Scheme_Case_Lambda *)p;
    for (i = 0; i < seq->count; i++) {
      data = SCHEME_COMPILED_CLOS_CODE(seq->array[i]);
      mina = maxa = data->num_params;
      if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_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;
      } else {
       if (mina >= drop) {
         mina -= drop;
         if (maxa > 0)
           maxa -= drop;

         v = scheme_make_pair(scheme_make_arity(mina, maxa), scheme_null);
         if (!last)
           first = v;
         else
           SCHEME_CDR(last) = v;
         last = v;
       }
      }
    }

    return first;
  } else if (type == scheme_proc_struct_type) {
    int is_method;
    if (scheme_reduced_procedure_struct
        && scheme_is_struct_instance(scheme_reduced_procedure_struct, p)) {
      if (a >= 0)
        bign = scheme_make_integer(a);
      if (a == -1)
        return clone_arity(((Scheme_Structure *)p)->slots[1]);
      else {
        /* Check arity (or for varargs) */
        Scheme_Object *v;
        v = ((Scheme_Structure *)p)->slots[1];
        if (SCHEME_STRUCTP(v)) {
          v = ((Scheme_Structure *)v)->slots[0];
          return (scheme_bin_lt_eq(v, bign)
                  ? scheme_true
                  : scheme_false);
        } else if (SCHEME_PAIRP(v)) {
          Scheme_Object *x;
          while (!SCHEME_NULLP(v)) {
            x = SCHEME_CAR(v);
            if (SCHEME_STRUCTP(x)) {
              x = ((Scheme_Structure *)x)->slots[0];  
              if (scheme_bin_lt_eq(x, bign))
                return scheme_true;
            } else {
              if (scheme_bin_eq(x, bign))
                return scheme_true;
            }
            v = SCHEME_CDR(v);
          }
          return scheme_false;
        } else if (SCHEME_NULLP(v)) {
          return scheme_false;
        } else {
          return (scheme_bin_eq(v, bign)
                  ? scheme_true
                  : scheme_false);
        }
      }
    } else {
      p = scheme_extract_struct_procedure(p, -1, NULL, &is_method);
      if (!SCHEME_PROCP(p)) {
        if (a == -1)
          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);

      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, *a;
           int v;
           while (SCHEME_PAIRP(pa)) {
             a = SCHEME_CAR(pa);
             if (SCHEME_INTP(a)) {
              v = SCHEME_INT_VAL(a);
              if (v < drop)
                a = NULL;
              else {
                v -= drop;
                a = scheme_make_integer(v);
              }
             } else {
              /* arity-at-least */
              a = ((Scheme_Structure *)a)->slots[0];
              v = SCHEME_INT_VAL(a);
              if (v >= drop) {
                a = scheme_make_arity(v - drop, -1);
              } else {
                a = scheme_make_arity(0, -1);
              }
             }
             if (a) {
              a = scheme_make_pair(a, scheme_null);
              if (last)
                SCHEME_CDR(last) = a;
              else
                first = a;
              last = a;
             }
             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 {
    Scheme_Closure_Data *data;

    data = SCHEME_COMPILED_CLOS_CODE(p);
    mina = maxa = data->num_params;
    if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) {
      if (mina)
       --mina;
      maxa = -1;
    }
  }

  if (cases) {
    int count = cases_count, i;

    if (a == -1) {
      Scheme_Object *arity, *a, *last = NULL;

      arity = scheme_alloc_list(count);

      for (i = 0, a = arity; i < count; i++) {
       Scheme_Object *av;
       int mn, mx;
       mn = cases[2 * i];
       mx = cases[(2 * i) + 1];

       if (mn >= drop) {
         mn -= drop;
         if (mx > 0)
           mx -= drop;

         av = scheme_make_arity(mn, mx);

         SCHEME_CAR(a) = av;
         last = a;
         a = SCHEME_CDR(a);
       }
      }

      /* If drop > 0, might have found no matches */
      if (!SCHEME_NULLP(a)) {
       if (last)
         SCHEME_CDR(last) = scheme_null;
       else
         arity = scheme_null;
      }

      return arity;
    }

    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) {
    if (mina < drop)
      return scheme_null;
    else
      mina -= drop;
    if (maxa > 0)
      maxa -= drop;

    return scheme_make_arity(mina, maxa);
  }

  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;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Cont* grab_continuation ( Scheme_Thread p,
int  for_prompt,
int  composable,
Scheme_Object prompt_tag,
Scheme_Cont sub_cont,
Scheme_Prompt prompt,
Scheme_Meta_Continuation prompt_cont,
MZ_MARK_POS_TYPE  prompt_pos,
Scheme_Prompt barrier_prompt,
Scheme_Prompt effective_barrier_prompt,
Scheme_Meta_Continuation barrier_cont,
MZ_MARK_POS_TYPE  barrier_pos 
) [static]

Definition at line 4886 of file fun.c.

{
  Scheme_Cont *cont;
  
  cont = MALLOC_ONE_TAGGED(Scheme_Cont);
  cont->so.type = scheme_cont_type;

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

  if (composable)
    cont->composable = 1;

  scheme_init_jmpup_buf(&cont->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, prompt_tag, -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) {
    cont->meta_continuation = NULL;
  } else if (prompt) {
    Scheme_Meta_Continuation *mc;
    Scheme_Object *id;
    mc = clone_meta_cont(p->meta_continuation, prompt_tag, -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.) */
      if (!prompt->id) {
        id = scheme_make_pair(scheme_false, scheme_false);
        prompt->id = id;
      }
      cont->prompt_id = prompt->id;
    }
    cont->has_prompt_dw = 1;
  } else
    cont->meta_continuation = p->meta_continuation;

  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;

  {
    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) {
    /* 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 (p->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
  {
    Scheme_Object *tr;
    tr = scheme_native_stack_trace();
    cont->native_trace = tr;
  }
#endif

  {
    Scheme_Saved_Stack *saved;
    saved = copy_out_runstack(p, MZ_RUNSTACK, MZ_RUNSTACK_START, sub_cont, 
                              (for_prompt ? p->meta_prompt : prompt));
    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 (SAME_OBJ(prompt->runstack_boundary_start, MZ_RUNSTACK_START))
        saved = NULL;
      else
        saved = clone_runstack_saved(cont->runstack_saved, 
                                     prompt->runstack_boundary_start,
                                     NULL);
      cont->runstack_saved = saved;
    }
  }

  {
    Scheme_Prompt *effective_prompt;
    Scheme_Cont_Mark *msaved;
    long 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);
  }

  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;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void initialize_prompt ( Scheme_Thread p,
Scheme_Prompt prompt,
void stack_boundary 
) [static]

Definition at line 1816 of file fun.c.

Here is the caller graph for this function:

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

Definition at line 5408 of file fun.c.

{
  Scheme_Object *ret, * volatile 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;
  GC_CAN_IGNORE void *stack_start;
  int composable;

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

  composable = (argc > 2);

  prompt = (Scheme_Prompt *)scheme_extract_one_cc_mark_with_meta(NULL, SCHEME_PTR_VAL(prompt_tag), 
                                                                 NULL, &prompt_cont, &prompt_pos);
  if (!prompt && !SAME_OBJ(scheme_default_prompt_tag, prompt_tag)) {
    scheme_arg_mismatch((composable
                         ? "call-with-composable-continuation"
                         : "call-with-current-continuation"), 
                        "continuation includes no prompt with the given tag: ",
                        prompt_tag);
    return NULL;
  }

  barrier_prompt = scheme_get_barrier_prompt(&barrier_cont, &barrier_pos);

  if (composable) {
    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)
                 || (sub_cont->meta_continuation != 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
    ret = scheme_native_stack_trace();
#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. */
      long offset;
      Scheme_Cont_Mark *msaved;

      cont = MALLOC_ONE_TAGGED(Scheme_Cont);
      cont->so.type = scheme_cont_type;
      cont->buf.cont = sub_cont;
      sub_cont = sub_cont->buf.cont;

      /* This mark stack won't be restored, but it may be
        used by `continuation-marks'. */
      cont->ss.cont_mark_stack = MZ_CONT_MARK_STACK;
      msaved = copy_out_mark_stack(p, cont->ss.cont_mark_stack, sub_cont, &offset, NULL, 0);
      cont->cont_mark_stack_copied = msaved;
      cont->cont_mark_offset = offset;
      cont->cont_mark_total = cont->ss.cont_mark_stack;
      offset = find_shareable_marks();
      cont->cont_mark_nonshare = cont->ss.cont_mark_stack - offset;
#ifdef MZ_USE_JIT
      cont->native_trace = ret;
#endif
    }

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

  cont = grab_continuation(p, 0, composable, prompt_tag, sub_cont, 
                           prompt, prompt_cont, prompt_pos,
                           barrier_prompt, effective_barrier_prompt, barrier_cont, barrier_pos);

  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;

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

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

      if (barrier_prompt)
        stack_start = 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;

  /* 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, cont, 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, 
                         prompt_tag, sub_cont, 
                         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();
    
    return result;
  } else {
    Scheme_Object *argv2[1];

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

Here is the call graph for this function:

Here is the caller graph for this function:

static int is_arity ( Scheme_Object a,
int  at_least_ok,
int  list_ok 
) [static]

Definition at line 3436 of file fun.c.

{
  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_STRUCTP(a)
             && scheme_is_struct_instance(scheme_arity_at_least, a)) {
    a = ((Scheme_Structure *)a)->slots[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;
}

Here is the caller graph for this function:

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 
) [static]

Definition at line 581 of file fun.c.

{
  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 - 1) * 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;
}

Here is the caller graph for this function:

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

Definition at line 5695 of file fun.c.

{
  Scheme_Object *o, *key;

  if (argc && !SCHEME_SYMBOLP(argv[0]))
    scheme_wrong_type("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;
}

Here is the caller graph for this function:

static Scheme_Object* make_reduced_proc ( Scheme_Object proc,
Scheme_Object aty,
Scheme_Object name 
) [static]

Definition at line 3483 of file fun.c.

{
  Scheme_Object *a[3];
  
  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];
    proc = ((Scheme_Structure *)proc)->slots[0];
  }

  a[0] = proc;
  a[1] = aty;
  a[2] = (name ? name : scheme_false);

  return scheme_make_struct_instance(scheme_reduced_procedure_struct, 3, a);
}

Here is the caller graph for this function:

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

Here is the caller graph for this function:

MZ_DO_NOT_INLINE ( void   scheme_really_create_overflowvoid *stack_base)
MZ_DO_NOT_INLINE ( Scheme_Object scheme_finish_apply_for_promptScheme_Prompt *prompt, Scheme_Object *_prompt_tag, Scheme_Object *proc, int argc, Scheme_Object **argv)
MZ_DO_NOT_INLINE ( Scheme_Object scheme_apply_for_promptScheme_Prompt *prompt, Scheme_Object *prompt_tag, Scheme_Object *proc, int argc, Scheme_Object **argv)
static Scheme_Object* object_name ( int  argc,
Scheme_Object argv[] 
) [static]

Here is the caller graph for this function:

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

Definition at line 3322 of file fun.c.

{
  Scheme_Object *a = argv[0];

  if (SCHEME_PROC_STRUCTP(a)) {
    a = scheme_proc_struct_name_source(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)) {
    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;
    }
  }

  return scheme_false;
}

Here is the call graph for this function:

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

Here is the caller graph for this function:

static void post_dyn_wind ( void d) [static]

Definition at line 7552 of file fun.c.

{
  pre_post_dyn_wind(((Dyn_Wind *)d)->post);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void pre_dyn_wind ( void d) [static]

Definition at line 7547 of file fun.c.

{
  pre_post_dyn_wind(((Dyn_Wind *)d)->pre);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void pre_post_dyn_wind ( Scheme_Object prepost) [static]

Definition at line 7519 of file fun.c.

{
  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: */
  (void)_scheme_apply_multi(prepost, 0, NULL);

  scheme_pop_break_enable(&cframe, 0);

  /* Restore internal suspend: */
  scheme_current_thread->suspend_break++;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 3135 of file fun.c.

{
  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;
}

Here is the caller graph for this function:

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

Definition at line 3121 of file fun.c.

{
  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;
}

Here is the caller graph for this function:

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

Definition at line 3296 of file fun.c.

{
  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_type("primitive-result_arity", "primitive", 0, argc, argv);
    return NULL;
  }

  return scheme_make_integer(1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 3382 of file fun.c.

{
  if (!SCHEME_PROCP(argv[0]))
    scheme_wrong_type("procedure-arity", "procedure", 0, argc, argv);

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

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * procedure_arity_includes ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 3423 of file fun.c.

{
  long n;

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

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

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

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 3390 of file fun.c.

{
  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_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_STRUCTP(a)
             && scheme_is_struct_instance(scheme_arity_at_least, a)) {
    return scheme_true;
  } else
    return scheme_false;
}

Here is the caller graph for this function:

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

Definition at line 3661 of file fun.c.

{
  Scheme_Object *v1 = argv[0], *v2 = argv[1];

  if (!SCHEME_PROCP(v1))
    scheme_wrong_type("procedure-closure-contents-eq?", "procedure", 0, argc, argv);
  if (!SCHEME_PROCP(v2))
    scheme_wrong_type("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)) {
       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;
}

Here is the caller graph for this function:

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

Definition at line 3116 of file fun.c.

{
  return (SCHEME_PROCP(argv[0]) ? scheme_true : scheme_false);
}

Here is the caller graph for this function:

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

Definition at line 3502 of file fun.c.

{
  Scheme_Object *orig, *req, *aty, *oa, *ra, *ol, *lra, *ara, *prev, *pr, *tmp;

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

  if (!is_arity(argv[1], 1, 1)) {
    scheme_wrong_type("procedure-reduce-arity", "arity", 1, argc, argv);
  }

  /* Check whether current arity covers the requested arity.  This is
     a bit complicated, because both the source and target can be
     lists that include arity-at-least records. */

  orig = get_or_check_arity(argv[0], -1, NULL);
  aty = clone_arity(argv[1]);
  req = aty;

  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);

  while (!SCHEME_NULLP(req)) {
    ra = SCHEME_CAR(req);
    if (SCHEME_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_Structure *)ra)->slots[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(ra, oa))
            break;
        } else {
          /* orig is arity-at-least */
          oa = ((Scheme_Structure *)oa)->slots[0];
          if (scheme_bin_lt_eq(oa, ra))
            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_CDR(ara))) {
            if (scheme_bin_gt_eq(oa, SCHEME_CAR(ara))) {
              /* oa is in the range [lo, hi]: */
              if (scheme_equal(oa, SCHEME_CAR(ara))) {
                /* 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_CDR(ara))) {
                    /* 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));
                    SCHEME_CAR(ara) = tmp;
                  }
                }
              } else if (scheme_equal(oa, SCHEME_CAR(ara))) {
                /* the range is [lo, oa], where lo < oa */
                tmp = scheme_bin_minus(oa, scheme_make_integer(1));
                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));
                  SCHEME_CDR(ara) = tmp;
                  SCHEME_CDR(lra) = scheme_null;
                } else {
                  pr = scheme_make_pair(scheme_make_pair(scheme_bin_plus(oa, scheme_make_integer(1)),
                                                         SCHEME_CDR(ara)),
                                        SCHEME_CDR(lra));
                  tmp = scheme_bin_minus(oa, scheme_make_integer(1));
                  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)) {
      scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
                       "procedure-reduce-arity: arity of procedure: %V"
                       " does not include requested arity: %V",
                       argv[0],
                       argv[1]);
      return NULL;
    }

    req = SCHEME_CDR(req);
  }

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

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 3647 of file fun.c.

{
  Scheme_Object *aty;

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

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

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

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 5717 of file fun.c.

Here is the caller graph for this function:

static void prompt_unwind_dw ( Scheme_Object prompt_tag) [static]

Definition at line 6102 of file fun.c.

{
  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;
  }
}

Here is the caller graph for this function:

static void prompt_unwind_one_dw ( Scheme_Object prompt_tag) [static]

Definition at line 6120 of file fun.c.

{
  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);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* propagate_abort ( int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 6389 of file fun.c.

{
  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);
}

Here is the caller graph for this function:

void prune_cont_marks ( Scheme_Meta_Continuation resume_mc,
Scheme_Cont cont,
Scheme_Object extra_marks 
)

Definition at line 4745 of file fun.c.

{
  Scheme_Object *val;
  Scheme_Hash_Table *ht;
  long 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 = cont->cont_mark_total, num_coverlap = 0;
       pos--;
       num_coverlap++) {
    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 = cont->cont_mark_total - 1, 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);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * read_compiled_closure ( Scheme_Object obj) [static]

Definition at line 8532 of file fun.c.

{
  Scheme_Closure_Data *data;
  Scheme_Object *v;

#define BAD_CC "bad compiled closure"
#define X_SCHEME_ASSERT(x, y)

  data  = (Scheme_Closure_Data *)scheme_malloc_tagged(sizeof(Scheme_Closure_Data));

  data->iso.so.type = scheme_unclosed_procedure_type;

  if (!SCHEME_PAIRP(obj)) return NULL;
  v = SCHEME_CAR(obj);
  obj = SCHEME_CDR(obj);
  SCHEME_CLOSURE_DATA_FLAGS(data) = (short)(SCHEME_INT_VAL(v));

  if (!SCHEME_PAIRP(obj)) return NULL;
  v = SCHEME_CAR(obj);
  obj = SCHEME_CDR(obj);
  data->num_params = SCHEME_INT_VAL(v);
  if (data->num_params < 0) return NULL;

  if (!SCHEME_PAIRP(obj)) return NULL;
  data->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj));
  if (data->max_let_depth < 0) return NULL;
  obj = SCHEME_CDR(obj);

  if (!SCHEME_PAIRP(obj)) return NULL;
  data->name = SCHEME_CAR(obj);
  obj = SCHEME_CDR(obj);
  if (SCHEME_NULLP(data->name))
    data->name = NULL;

  if (!SCHEME_PAIRP(obj)) return NULL;
  v = SCHEME_CAR(obj);
  obj = SCHEME_CDR(obj);

  /* v is an svector or an integer... */
  if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REF_ARGS) {
    if (!SCHEME_INTP(v)) return NULL;
    data->closure_size = SCHEME_INT_VAL(v);
    
    if (!SCHEME_PAIRP(obj)) return NULL;
    v = SCHEME_CAR(obj);
    obj = SCHEME_CDR(obj);
  }

  data->code = obj;

  if (!SAME_TYPE(scheme_svector_type, SCHEME_TYPE(v))) return NULL;

  if (!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REF_ARGS))
    data->closure_size = SCHEME_SVEC_LEN(v);
  data->closure_map = SCHEME_SVEC_VEC(v);

  /* If the closure is empty, create the closure now */
  if (!data->closure_size)
    return scheme_make_closure(NULL, (Scheme_Object *)data, 0);
  else
    return (Scheme_Object *)data;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void reset_cjs ( Scheme_Continuation_Jump_State a) [static]

Definition at line 3934 of file fun.c.

{
  a->jumping_to_continuation = NULL;
  a->val = NULL;
  a->num_vals = 0;
  a->is_kill = 0;
  a->is_escape = 0;
}

Here is the caller graph for this function:

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_Cont sub_cont,
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 
) [static]

Definition at line 5064 of file fun.c.

{
  MZ_MARK_STACK_TYPE copied_cms = 0;
  Scheme_Object **mv, *sub_conts = NULL;
  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;
  } 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);
      }
      
      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 (shortcut_prompt->runstack_boundary_start == MZ_RUNSTACK_START)
      rs = p->runstack_saved;
    else {
      rs = p->runstack_saved;
      while (rs && (rs->runstack_start != shortcut_prompt->runstack_boundary_start)) {
        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 it's base runstack. */
  copy_in_runstack(p, cont->runstack_copied, 0);
  {
    long done = cont->runstack_copied->runstack_size, size;
    sub_cont = cont;
    while (sub_cont) {
      if (sub_cont->buf.cont
          && (sub_cont->runstack_start == sub_cont->buf.cont->runstack_start)) {
        /* Copy shared part in: */
        sub_cont = sub_cont->buf.cont;
        size = sub_cont->runstack_copied->runstack_size;
        if (size) {
          /* Skip the first item, since that's the call/cc argument,
             which we don't want from the outer continuation. */
          memcpy(MZ_RUNSTACK XFORM_OK_PLUS done, 
                 sub_cont->runstack_copied->runstack_start + 1, 
                 (size - 1) * sizeof(Scheme_Object *));
          done += (size - 1);
        }
      } 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.cont; tc = tc->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.cont) {
        delta += rs_cont->runstack_copied->runstack_size;
        rs_cont = rs_cont->buf.cont;
        if (rs_cont->runstack_copied->runstack_size) {
          delta -= 1; /* 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->runstack_boundary_start = actual->runstack_start;
        meta_prompt->runstack_boundary_offset = actual->runstack_offset + saved->runstack_size;
      } else {
        meta_prompt->runstack_boundary_start = MZ_RUNSTACK_START;
        meta_prompt->runstack_boundary_offset = (MZ_RUNSTACK - MZ_RUNSTACK_START) + saved->runstack_size + delta;
      }
    }

    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.cont; sub_cont; sub_cont = sub_cont->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.cont; tc = tc->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, 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;

      common_depth = (p->dw ? p->dw->depth : -1);
      all_dw = clone_dyn_wind(cont->dw, NULL, cont->common_dw_depth, 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);
      p = scheme_current_thread;
      p->dw = all_dw;
      p->next_meta = cont->next_meta;      
    }
  }

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

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

Here is the call graph for this function:

Here is the caller graph for this function:

static void restore_dynamic_state ( Scheme_Dynamic_State state,
Scheme_Thread thread 
) [static]

Definition at line 1962 of file fun.c.

                                                                                      {
    thread->current_local_env     = state->current_local_env;
    thread->current_local_mark    = state->mark;
    thread->current_local_name    = state->name;
    thread->current_local_certs   = state->certs;
    thread->current_local_modidx  = state->modidx;
    thread->current_local_menv    = state->menv;
}

Here is the caller graph for this function:

static void restore_from_prompt ( Scheme_Prompt prompt) [static]

Definition at line 6079 of file fun.c.

Here is the caller graph for this function:

static void save_dynamic_state ( Scheme_Thread thread,
Scheme_Dynamic_State state 
) [static]

Definition at line 1953 of file fun.c.

                                                                                   {
    state->current_local_env = thread->current_local_env;
    state->mark              = thread->current_local_mark;
    state->name              = thread->current_local_name;
    state->certs             = thread->current_local_certs;
    state->modidx            = thread->current_local_modidx;
    state->menv              = thread->current_local_menv;
}

Here is the caller graph for this function:

Definition at line 6892 of file fun.c.

{
  return continuation_marks(scheme_current_thread, NULL, NULL, NULL, 
                            NULL,
                            "continuation-marks",
                            0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Scheme_Object* scheme_apply ( Scheme_Object rator,
int  num_rands,
Scheme_Object **  rands 
)

Definition at line 2256 of file fun.c.

{
  return _apply(rator, num_rands, rands, 0, 1);
}

Here is the call graph for this function:

void scheme_apply_dw_in_meta ( Scheme_Dynamic_Wind dw,
int  post_part,
int  meta_depth,
Scheme_Cont recheck 
)

Definition at line 7783 of file fun.c.

{
  /* 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;
  long 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 = 0;
    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) {
    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;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 5896 of file fun.c.

{
  /* 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;
}

Here is the call graph for this function:

Here is the caller graph for this function:

Scheme_Object* scheme_apply_macro ( Scheme_Object name,
Scheme_Env menv,
Scheme_Object rator,
Scheme_Object code,
Scheme_Comp_Env env,
Scheme_Object boundname,
Scheme_Compile_Expand_Info rec,
int  drec,
int  for_set 
)

Definition at line 2602 of file fun.c.

{
  Scheme_Object *orig_code = code;
  Scheme_Object *certs;
  certs = rec[drec].certs;

  if (scheme_is_rename_transformer(rator)) {
    Scheme_Object *mark;
   
    rator = scheme_rename_transformer_id(rator);
    /* rator is now an identifier */

    /* and it's introduced by this expression: */
    mark = scheme_new_mark();
    rator = scheme_add_remove_mark(rator, mark);

    if (for_set) {
      Scheme_Object *tail, *setkw;

      tail = SCHEME_STX_CDR(code);
      setkw = SCHEME_STX_CAR(code);
      tail = SCHEME_STX_CDR(tail);
      code = scheme_make_pair(setkw, scheme_make_pair(rator, tail));
      code = scheme_datum_to_syntax(code, orig_code, orig_code, 0, 0);
    } else if (SCHEME_SYMBOLP(SCHEME_STX_VAL(code)))
      code = rator;
    else {
      code = SCHEME_STX_CDR(code);
      code = scheme_make_pair(rator, code);
      code = scheme_datum_to_syntax(code, orig_code, scheme_sys_wraps(env), 0, 0);
    }

    code = cert_with_specials(code, mark, menv, orig_code, orig_code, env, env->genv->phase, 0, 0);

    code = scheme_stx_track(code, orig_code, name);

    return code;
  } else {
    Scheme_Object *mark, *rands_vec[1];

    certs = scheme_stx_extract_certs(code, certs);
 
    if (scheme_is_set_transformer(rator))
      rator = scheme_set_transformer_proc(rator);

    mark = scheme_new_mark();
    code = scheme_add_remove_mark(code, mark);

    SCHEME_EXPAND_OBSERVE_MACRO_PRE_X(rec[drec].observer, code);

    {
      Scheme_Dynamic_State dyn_state;
      Scheme_Cont_Frame_Data cframe;
      Scheme_Config *config;

      scheme_prepare_exp_env(env->genv);
      config = scheme_extend_config(scheme_current_config(),
                                    MZCONFIG_ENV,
                                    (Scheme_Object *)env->genv->exp_env);
      scheme_push_continuation_frame(&cframe);
      scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);

      scheme_set_dynamic_state(&dyn_state, env, mark, boundname, certs, 
          menv, menv ? menv->link_midx : env->genv->link_midx);

      rands_vec[0] = code;
      code = scheme_apply_with_dynamic_state(rator, 1, rands_vec, &dyn_state);

      scheme_pop_continuation_frame(&cframe);
    }

    SCHEME_EXPAND_OBSERVE_MACRO_POST_X(rec[drec].observer, code);

    if (!SCHEME_STXP(code)) {
      scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                       "%S: return value from syntax expander was not syntax: %V",
                       SCHEME_STX_SYM(name),
                       code);
    }

    code = scheme_add_remove_mark(code, mark);

    code = cert_with_specials(code, mark, menv, orig_code, orig_code, env, env->genv->phase, 0, 0);

    code = scheme_stx_track(code, orig_code, name);

    return code;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

Scheme_Object* scheme_apply_multi ( Scheme_Object rator,
int  num_rands,
Scheme_Object **  rands 
)

Definition at line 2262 of file fun.c.

{
  return _apply(rator, num_rands, rands, 1, 1);
}

Here is the call graph for this function:

Scheme_Object* scheme_apply_multi_no_eb ( Scheme_Object rator,
int  num_rands,
Scheme_Object **  rands 
)

Definition at line 2313 of file fun.c.

{
  return _apply(rator, num_rands, rands, 1, 0);
}

Here is the call graph for this function:

Definition at line 2294 of file fun.c.

{
  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 = 1;

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

Here is the call graph for this function:

Here is the caller graph for this function:

Scheme_Object* scheme_apply_multi_with_prompt ( Scheme_Object rator,
int  num_rands,
Scheme_Object **  rands 
)

Definition at line 2371 of file fun.c.

{
  return do_apply_with_prompt(rator, num_rands, rands, 1, 1);
}

Here is the call graph for this function:

Scheme_Object* scheme_apply_no_eb ( Scheme_Object rator,
int  num_rands,
Scheme_Object **  rands 
)

Definition at line 2307 of file fun.c.

{
  return _apply(rator, num_rands, rands, 0, 0);
}

Here is the call graph for this function:

Definition at line 2268 of file fun.c.

{
  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, NULL);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 2468 of file fun.c.

{
  return X_scheme_apply_to_list(rator, rands, 1, 1);
}

Here is the call graph for this function:

Scheme_Object* scheme_apply_with_dynamic_state ( Scheme_Object rator,
int  num_rands,
Scheme_Object **  rands,
Scheme_Dynamic_State dyn_state 
)

Definition at line 2281 of file fun.c.

{
  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 = 0;

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

Here is the call graph for this function:

Here is the caller graph for this function:

Scheme_Object* scheme_apply_with_prompt ( Scheme_Object rator,
int  num_rands,
Scheme_Object **  rands 
)

Definition at line 2365 of file fun.c.

{
  return do_apply_with_prompt(rator, num_rands, rands, 0, 1);
}

Here is the call graph for this function:

Definition at line 3377 of file fun.c.

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

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 1705 of file fun.c.

{
  Scheme_Object *name;

  name = scheme_stx_property(code, scheme_inferred_name_symbol, NULL);
  if (name && SCHEME_SYMBOLP(name)) {
    name = combine_name_with_srcloc(name, code, 0);
  } else {
    name = rec[drec].value_name;
    if (!name || SCHEME_FALSEP(name)) {
      name = scheme_source_to_name(code);
      if (name)
       name = combine_name_with_srcloc(name, code, 1);
    } else {
      name = combine_name_with_srcloc(name, code, 0);
    }
  }
  return name;
}

Here is the call graph for this function:

Here is the caller graph for this function:

Scheme_Object* scheme_call_ec ( int  argc,
Scheme_Object argv[] 
)

Definition at line 3961 of file fun.c.

{
  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_check_proc_arity("call-with-escape-continuation", 1,
                       0, argc, argv);

  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;

  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++;

  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)) {
      int 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;
      if (n != 1)
        v = scheme_values(n, (Scheme_Object **)v);
    } else {
      scheme_longjmp(*cont->saveerr, 1);
    }
  } else {
    a[0] = (Scheme_Object *)cont;
    v = _scheme_apply_multi(argv[0], 1, a);
  }

  p1 = scheme_current_thread;

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

  return v;
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 6423 of file fun.c.

{
  return do_call_with_prompt(f, data, 0, 1);
}

Here is the call graph for this function:

Definition at line 6428 of file fun.c.

{
  return do_call_with_prompt(f, data, 1, 1);
}

Here is the call graph for this function:

int scheme_check_proc_arity ( const char *  where,
int  a,
int  which,
int  argc,
Scheme_Object **  argv 
)

Definition at