Back to index

plt-scheme  4.2.1
Classes | Defines | Typedefs | Enumerations | Functions | Variables
eval.c File Reference
#include "schpriv.h"
#include "schrunst.h"
#include "schexpobs.h"
#include "schmach.h"
#include "schapp.inc"

Go to the source code of this file.

Classes

struct  Validate_Clearing

Defines

#define EMBEDDED_DEFINES_START_ANYWHERE   0
#define cons(x, y)   scheme_make_pair(x,y)
#define icons   scheme_make_pair
#define DO_CHECK_FOR_BREAK(p, e)
#define LOG_INLINE(x)   /*empty*/
#define MAX_SFS_CLEARING   0
#define SFS_LOG(x)   /* nothing */
#define SFS_BRANCH_W   4
#define DEBUG_CHECK_TYPE(v)
#define PRIM_CHECK_ARITY   0
#define PRIM_CHECK_MULTI   0
#define PRIM_CHECK_ARITY   1
#define PRIM_CHECK_MULTI   0
#define PRIM_CHECK_ARITY   0
#define PRIM_CHECK_MULTI   1
#define PRIM_CHECK_ARITY   1
#define PRIM_CHECK_MULTI   1
#define LOOKUP_NO_PROMPT   "continuation application: no corresponding prompt in the current continuation"
#define USE_LOCAL_RUNSTACK   1
#define DELAY_THREAD_RUNSTACK_UPDATE   1
#define p   scheme_current_thread
#define RUNSTACK   runstack
#define UPDATE_THREAD_RSPTR()   (MZ_RUNSTACK = runstack)
#define RUNSTACK_CHANGED()
#define RESET_LOCAL_RUNSTACK()   (runstack = MZ_RUNSTACK)
#define EVAL_SFS_CLEAR(runstack, obj)
#define SFS_CLEAR_RUNSTACK_ONE(runstack, pos)   runstack[pos] = NULL
#define SFS_CLEAR_RUNSTACK(runstack, i, n)   for (i = n; i--; ) { SFS_CLEAR_RUNSTACK_ONE(runstack, i); }
#define RUNSTACK_START   MZ_RUNSTACK_START
#define UPDATE_THREAD_RSPTR_FOR_GC()   UPDATE_THREAD_RSPTR()
#define UPDATE_THREAD_RSPTR_FOR_ERROR()   UPDATE_THREAD_RSPTR()
#define UPDATE_THREAD_RSPTR_FOR_PROC_MARK()   UPDATE_THREAD_RSPTR()
#define VACATE_TAIL_BUFFER_USE_RUNSTACK()
#define global_lookup(prefix, _obj, tmp)
#define GET_FIRST_EVAL   evals[0]
#define GET_NEXT_EVAL   *(evals++)
#define GET_NEXT_ARG   *(args++)
#define lo   ((Scheme_Let_One *)obj)
#define VALID_NOT   0
#define VALID_UNINIT   1
#define VALID_VAL   2
#define VALID_BOX   3
#define VALID_TOPLEVELS   4
#define VALID_VAL_NOCLEAR   5
#define VALID_BOX_NOCLEAR   6
#define CAN_RESET_STACK_SLOT   0
#define WHEN_CAN_RESET_STACK_SLOT(x)   0
#define BOOL(x)   (x ? scheme_true : scheme_false)

Typedefs

typedef void(* DW_PrePost_Proc )(void *)
typedef struct Validate_Clearing Validate_Clearing

Enumerations

enum  {
  SCHEME_EVAL_CONSTANT = 0, SCHEME_EVAL_GLOBAL, SCHEME_EVAL_LOCAL, SCHEME_EVAL_LOCAL_UNBOX,
  SCHEME_EVAL_GENERAL
}

Functions

void scheme_set_startup_use_jit (int v)
int get_overflow_count ()
static Scheme_Objecteval (int argc, Scheme_Object *argv[])
static Scheme_Objectcompile (int argc, Scheme_Object *argv[])
static Scheme_Objectcompiled_p (int argc, Scheme_Object *argv[])
static Scheme_Objectexpand (int argc, Scheme_Object **argv)
static Scheme_Objectlocal_expand (int argc, Scheme_Object **argv)
static Scheme_Objectlocal_expand_expr (int argc, Scheme_Object **argv)
static Scheme_Objectlocal_expand_catch_lifts (int argc, Scheme_Object **argv)
static Scheme_Objectlocal_transformer_expand (int argc, Scheme_Object **argv)
static Scheme_Objectlocal_transformer_expand_catch_lifts (int argc, Scheme_Object **argv)
static Scheme_Objectlocal_eval (int argc, Scheme_Object **argv)
static Scheme_Objectexpand_once (int argc, Scheme_Object **argv)
static Scheme_Objectexpand_to_top_form (int argc, Scheme_Object **argv)
static Scheme_Objectenable_break (int, Scheme_Object *[])
static Scheme_Objectcurrent_eval (int argc, Scheme_Object *[])
static Scheme_Objectcurrent_compile (int argc, Scheme_Object *[])
static Scheme_Objecteval_stx (int argc, Scheme_Object *argv[])
static Scheme_Objectcompile_stx (int argc, Scheme_Object *argv[])
static Scheme_Objectexpand_stx (int argc, Scheme_Object **argv)
static Scheme_Objectexpand_stx_once (int argc, Scheme_Object **argv)
static Scheme_Objectexpand_stx_to_top_form (int argc, Scheme_Object **argv)
static Scheme_Objecttop_introduce_stx (int argc, Scheme_Object **argv)
static Scheme_Objectallow_set_undefined (int argc, Scheme_Object **argv)
static Scheme_Objectcompile_module_constants (int argc, Scheme_Object **argv)
static Scheme_Objectuse_jit (int argc, Scheme_Object **argv)
static Scheme_Objectdisallow_inline (int argc, Scheme_Object **argv)
static Scheme_Objectapp_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectapp_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectdatum_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectdatum_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objecttop_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objecttop_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectwrite_application (Scheme_Object *obj)
static Scheme_Objectread_application (Scheme_Object *obj)
static Scheme_Objectwrite_sequence (Scheme_Object *obj)
static Scheme_Objectread_sequence (Scheme_Object *obj)
static Scheme_Objectread_sequence_save_first (Scheme_Object *obj)
static Scheme_Objectwrite_branch (Scheme_Object *obj)
static Scheme_Objectread_branch (Scheme_Object *obj)
static Scheme_Objectwrite_with_cont_mark (Scheme_Object *obj)
static Scheme_Objectread_with_cont_mark (Scheme_Object *obj)
static Scheme_Objectwrite_syntax (Scheme_Object *obj)
static Scheme_Objectread_syntax (Scheme_Object *obj)
static Scheme_Objectwrite_quote_syntax (Scheme_Object *obj)
static Scheme_Objectread_quote_syntax (Scheme_Object *obj)
static Scheme_Objectscheme_compile_expand_expr (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec, int app_position)
static Scheme_Object_eval_compiled_multi_with_prompt (Scheme_Object *obj, Scheme_Env *env)
void scheme_init_eval (Scheme_Env *env)
void scheme_init_eval_places ()
Scheme_Objectscheme_handle_stack_overflow (Scheme_Object *(*k)(void))
void scheme_init_stack_check ()
int scheme_check_runstack (long size)
voidscheme_enlarge_runstack (long size, void *(*k)())
static int is_current_inspector_call (Scheme_Object *a)
static int is_proc_spec_proc (Scheme_Object *p)
static void note_match (int actual, int expected, Optimize_Info *warn_info)
int scheme_omittable_expr (Scheme_Object *o, int vals, int fuel, int resolved, Optimize_Info *warn_info)
int scheme_is_compiled_procedure (Scheme_Object *o, int can_be_closed, int can_be_liftable)
int scheme_get_eval_type (Scheme_Object *obj)
static Scheme_Objecttry_apply (Scheme_Object *f, Scheme_Object *args, Scheme_Object *context)
static int foldable_body (Scheme_Object *f)
static Scheme_Objectmake_application (Scheme_Object *v)
Scheme_App_Recscheme_malloc_application (int n)
void scheme_finish_application (Scheme_App_Rec *app)
static Scheme_Objectcheck_converted_rator (Scheme_Object *rator, Resolve_Info *info, Scheme_Object **new_rator, int orig_arg_cnt, int *_rdelta)
static Scheme_Objectresolve_application (Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count)
static Scheme_Objectresolve_application3 (Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count)
static void set_app2_eval_type (Scheme_App2_Rec *app)
void scheme_reset_app2_eval_type (Scheme_App2_Rec *app)
static Scheme_Objectresolve_application2 (Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count)
static int eq_testable_constant (Scheme_Object *v)
static void set_app3_eval_type (Scheme_App3_Rec *app)
Scheme_Objectscheme_make_branch (Scheme_Object *test, Scheme_Object *thenp, Scheme_Object *elsep)
static Scheme_Objectresolve_branch (Scheme_Object *o, Resolve_Info *info)
static Scheme_Objectresolve_wcm (Scheme_Object *o, Resolve_Info *info)
static Scheme_Sequencemalloc_sequence (int count)
Scheme_Objectscheme_make_sequence_compilation (Scheme_Object *seq, int opt)
static Scheme_Objectlook_for_letv_change (Scheme_Sequence *s)
static Scheme_Objectresolve_sequence (Scheme_Object *o, Resolve_Info *info)
Scheme_Objectscheme_make_syntax_resolved (int idx, Scheme_Object *data)
Scheme_Objectscheme_make_syntax_compiled (int idx, Scheme_Object *data)
static Scheme_Objectlink_module_variable (Scheme_Object *modidx, Scheme_Object *varname, int check_access, Scheme_Object *insp, int pos, int mod_phase, Scheme_Env *env, Scheme_Object **exprs, int which)
static Scheme_Objectlink_toplevel (Scheme_Object **exprs, int which, Scheme_Env *env, Scheme_Object *src_modidx, Scheme_Object *dest_modidx)
static Scheme_Objectresolve_k (void)
Scheme_Objectscheme_resolve_expr (Scheme_Object *expr, Resolve_Info *info)
Scheme_Objectscheme_resolve_list (Scheme_Object *expr, Resolve_Info *info)
static Scheme_Objecttry_optimize_fold (Scheme_Object *f, Scheme_Object *o, Optimize_Info *info)
static Scheme_Objectapply_inlined (Scheme_Object *p, Scheme_Closure_Data *data, Optimize_Info *info, int argc, Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3)
Scheme_Objectoptimize_for_inline (Optimize_Info *info, Scheme_Object *le, int argc, Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3, int *_flags)
char * scheme_optimize_context_to_string (Scheme_Object *context)
static void reset_rator (Scheme_Object *app, Scheme_Object *a)
static Scheme_Objectcheck_app_let_rator (Scheme_Object *app, Scheme_Object *rator, Optimize_Info *info, int argc)
static Scheme_Objectoptimize_application (Scheme_Object *o, Optimize_Info *info)
static Scheme_Objectlookup_constant_proc (Optimize_Info *info, Scheme_Object *rand)
static Scheme_Objectoptimize_application2 (Scheme_Object *o, Optimize_Info *info)
static Scheme_Objectoptimize_application3 (Scheme_Object *o, Optimize_Info *info)
Scheme_Objectscheme_optimize_apply_values (Scheme_Object *f, Scheme_Object *e, Optimize_Info *info, int e_single_result)
static Scheme_Objectoptimize_sequence (Scheme_Object *o, Optimize_Info *info)
int scheme_compiled_duplicate_ok (Scheme_Object *fb)
static Scheme_Objectoptimize_branch (Scheme_Object *o, Optimize_Info *info)
static Scheme_Objectoptimize_wcm (Scheme_Object *o, Optimize_Info *info)
static Scheme_Objectoptimize_k (void)
Scheme_Objectscheme_optimize_expr (Scheme_Object *expr, Optimize_Info *info)
Scheme_Objectscheme_optimize_clone (int dup_ok, Scheme_Object *expr, Optimize_Info *info, int delta, int closure_depth)
Scheme_Objectscheme_optimize_shift (Scheme_Object *expr, int delta, int after_depth)
Scheme_Objectscheme_sfs (Scheme_Object *o, SFS_Info *info, int max_let_depth)
SFS_Infoscheme_new_sfs_info (int depth)
static void scheme_sfs_save (SFS_Info *info, Scheme_Object *v)
static Scheme_Objectscheme_sfs_next_saved (SFS_Info *info)
void scheme_sfs_start_sequence (SFS_Info *info, int cnt, int last_is_tail)
void scheme_sfs_push (SFS_Info *info, int cnt, int track)
void scheme_sfs_used (SFS_Info *info, int pos)
Scheme_Objectscheme_sfs_add_clears (Scheme_Object *expr, Scheme_Object *clears, int pre)
static void sfs_note_app (SFS_Info *info, Scheme_Object *rator)
static Scheme_Objectsfs_application (Scheme_Object *o, SFS_Info *info)
static Scheme_Objectsfs_application2 (Scheme_Object *o, SFS_Info *info)
static Scheme_Objectsfs_application3 (Scheme_Object *o, SFS_Info *info)
static Scheme_Objectsfs_sequence (Scheme_Object *o, SFS_Info *info)
static Scheme_Objectsfs_one_branch (SFS_Info *info, int ip, Scheme_Object *vec, int delta, Scheme_Object *tbranch)
static Scheme_Objectsfs_branch (Scheme_Object *o, SFS_Info *info)
static Scheme_Objectsfs_let_value (Scheme_Object *o, SFS_Info *info)
static Scheme_Objectsfs_let_one (Scheme_Object *o, SFS_Info *info)
static Scheme_Objectsfs_let_void (Scheme_Object *o, SFS_Info *info)
static Scheme_Objectsfs_letrec (Scheme_Object *o, SFS_Info *info)
static Scheme_Objectsfs_wcm (Scheme_Object *o, SFS_Info *info)
Scheme_Objectscheme_sfs_expr (Scheme_Object *expr, SFS_Info *info, int closure_self_pos)
Scheme_Objectscheme_jit_expr (Scheme_Object *expr)
void scheme_default_compile_rec (Scheme_Compile_Info *rec, int drec)
void scheme_init_compile_recs (Scheme_Compile_Info *src, int drec, Scheme_Compile_Info *dest, int n)
void scheme_init_expand_recs (Scheme_Expand_Info *src, int drec, Scheme_Expand_Info *dest, int n)
void scheme_merge_compile_recs (Scheme_Compile_Info *src, int drec, Scheme_Compile_Info *dest, int n)
void scheme_init_lambda_rec (Scheme_Compile_Info *src, int drec, Scheme_Compile_Info *lam, int dlrec)
void scheme_merge_lambda_rec (Scheme_Compile_Info *src, int drec, Scheme_Compile_Info *lam, int dlrec)
void scheme_compile_rec_done_local (Scheme_Compile_Info *rec, int drec)
void scheme_rec_add_certs (Scheme_Compile_Expand_Info *src, int drec, Scheme_Object *stx)
static Scheme_Objectscheme_inner_compile_list (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, int start_app_position)
static Scheme_Objectcompile_application (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
Scheme_Objectscheme_compile_list (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectcall_compile_handler (Scheme_Object *form, int immediate_eval)
static Scheme_Objectadd_renames_unless_module (Scheme_Object *form, Scheme_Env *genv)
static int get_comp_flags (Scheme_Config *config)
void scheme_enable_expression_resolve_lifts (Resolve_Info *ri)
Scheme_Objectscheme_merge_expression_resolve_lifts (Scheme_Object *expr, Resolve_Prefix *rp, Resolve_Info *ri)
static voidcompile_k (void)
static Scheme_Object_compile (Scheme_Object *form, Scheme_Env *env, int writeable, int for_eval, int eb, int rename)
Scheme_Objectscheme_compile (Scheme_Object *form, Scheme_Env *env, int writeable)
Scheme_Objectscheme_compile_for_eval (Scheme_Object *form, Scheme_Env *env)
Scheme_Objectscheme_check_immediate_macro (Scheme_Object *first, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec, int internel_def_pos, Scheme_Object **current_val, Scheme_Comp_Env **_xenv, Scheme_Object *ctx)
static Scheme_Objectcompile_expand_macro_app (Scheme_Object *name, Scheme_Env *menv, Scheme_Object *macro, Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec)
static int same_effective_env (Scheme_Comp_Env *orig, Scheme_Comp_Env *e)
static Scheme_Objectcompile_expand_expr_k (void)
static int arg_count (Scheme_Object *lam, Scheme_Comp_Env *env)
static Scheme_Objectcert_ids (Scheme_Object *orig_ids, Scheme_Object *orig)
static Scheme_Objectcompile_expand_app (Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec)
static Scheme_Objectcheck_top (const char *when, Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
Scheme_Objectscheme_compile_expr (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
Scheme_Objectscheme_expand_expr (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectpair_lifted (Scheme_Object *_ip, Scheme_Object **_ids, Scheme_Object *expr, Scheme_Comp_Env *env)
static Scheme_Objectadd_lifts_as_let (Scheme_Object *obj, Scheme_Object *l, Scheme_Comp_Env *env, Scheme_Object *orig_form, int comp_rev)
static Scheme_Objectcompile_expand_expr_lift_to_let_k (void)
static Scheme_Objectcompile_expand_expr_lift_to_let (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *rec, int drec)
Scheme_Objectscheme_compile_expr_lift_to_let (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
Scheme_Objectscheme_expand_expr_lift_to_let (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectscheme_compile_expand_block (Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec)
Scheme_Objectscheme_compile_block (Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
Scheme_Objectscheme_expand_block (Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
Scheme_Objectscheme_expand_list (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
Scheme_Objectscheme_flatten_begin (Scheme_Object *expr, Scheme_Object *append_onto)
void scheme_push_continuation_frame (Scheme_Cont_Frame_Data *d)
void scheme_pop_continuation_frame (Scheme_Cont_Frame_Data *d)
static MZ_MARK_STACK_TYPE clone_meta_cont_set_mark (Scheme_Meta_Continuation *mc, Scheme_Object *val, long findpos)
static MZ_MARK_STACK_TYPE new_segment_set_mark (long segpos, long pos, Scheme_Object *key, Scheme_Object *val)
MZ_MARK_STACK_TYPE scheme_set_cont_mark (Scheme_Object *key, Scheme_Object *val)
void scheme_temp_dec_mark_depth ()
void scheme_temp_inc_mark_depth ()
static Scheme_Objectdo_apply_known_k (void)
Scheme_Object_scheme_apply_known_prim_closure_multi (Scheme_Object *rator, int argc, Scheme_Object **argv)
Scheme_Object_scheme_apply_prim_closure_multi (Scheme_Object *rator, int argc, Scheme_Object **argv)
Scheme_Object_scheme_apply_known_prim_closure (Scheme_Object *rator, int argc, Scheme_Object **argv)
Scheme_Object_scheme_apply_prim_closure (Scheme_Object *rator, int argc, Scheme_Object **argv)
Scheme_Objectscheme_check_one_value (Scheme_Object *v)
static Scheme_Objectdo_eval_k (void)
static void unbound_global (Scheme_Object *obj)
static void make_tail_buffer_safe ()
static Scheme_Object ** evacuate_runstack (int num_rands, Scheme_Object **rands, Scheme_Object **runstack)
static Scheme_Dynamic_Windintersect_dw (Scheme_Dynamic_Wind *a, Scheme_Dynamic_Wind *b, Scheme_Object *prompt_tag, int b_has_tag, int *_common_depth)
static Scheme_Promptlookup_cont_prompt (Scheme_Cont *c, Scheme_Meta_Continuation **_prompt_mc, MZ_MARK_POS_TYPE *_prompt_pos, const char *msg)
static Scheme_Promptcheck_barrier (Scheme_Prompt *prompt, Scheme_Meta_Continuation *prompt_cont, MZ_MARK_POS_TYPE prompt_pos, Scheme_Cont *c)
void scheme_recheck_prompt_and_barrier (Scheme_Cont *c)
static int exec_dyn_wind_posts (Scheme_Dynamic_Wind *common, Scheme_Cont *c, int common_depth, Scheme_Dynamic_Wind **_common)
Scheme_Objectscheme_jump_to_continuation (Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object **old_runstack)
void scheme_escape_to_continuation (Scheme_Object *obj, int num_rands, Scheme_Object **rands)
Scheme_Objectscheme_do_eval (Scheme_Object *obj, int num_rands, Scheme_Object **rands, int get_value)
Scheme_Objectscheme_eval (Scheme_Object *obj, Scheme_Env *env)
Scheme_Objectscheme_eval_multi (Scheme_Object *obj, Scheme_Env *env)
static Scheme_Objectfinish_eval_with_prompt (void *_data, int argc, Scheme_Object **argv)
Scheme_Objectscheme_eval_with_prompt (Scheme_Object *obj, Scheme_Env *env)
static Scheme_Objectfinish_eval_multi_with_prompt (void *_data, int argc, Scheme_Object **argv)
Scheme_Objectscheme_eval_multi_with_prompt (Scheme_Object *obj, Scheme_Env *env)
static voideval_k (void)
static Scheme_Object_eval (Scheme_Object *obj, Scheme_Env *env, int isexpr, int multi, int top, int as_tail)
Scheme_Objectscheme_eval_compiled (Scheme_Object *obj, Scheme_Env *env)
Scheme_Objectscheme_eval_compiled_multi (Scheme_Object *obj, Scheme_Env *env)
Scheme_Object_scheme_eval_compiled (Scheme_Object *obj, Scheme_Env *env)
Scheme_Object_scheme_eval_compiled_multi (Scheme_Object *obj, Scheme_Env *env)
static Scheme_Objectfinish_compiled_multi_with_prompt (void *_data, int argc, Scheme_Object **argv)
Scheme_Objectscheme_eval_linked_expr (Scheme_Object *obj)
Scheme_Objectscheme_eval_linked_expr_multi (Scheme_Object *obj)
Scheme_Objectscheme_eval_linked_expr_multi_with_dynamic_state (Scheme_Object *obj, Scheme_Dynamic_State *dyn_state)
Scheme_Objectscheme_load_compiled_stx_string (const char *str, long len)
Scheme_Objectscheme_compiled_stx_symbol (Scheme_Object *stx)
Scheme_Objectscheme_eval_compiled_stx_string (Scheme_Object *expr, Scheme_Env *env, long shift, Scheme_Object *modidx)
static Scheme_Objectadd_lifts_as_begin (Scheme_Object *obj, Scheme_Object *l, Scheme_Comp_Env *env)
static voidexpand_k (void)
static Scheme_Object_expand (Scheme_Object *obj, Scheme_Comp_Env *env, int depth, int rename, int just_to_top, Scheme_Object *catch_lifts_key, int eb, Scheme_Object *certs, int as_local)
Scheme_Objectscheme_expand (Scheme_Object *obj, Scheme_Env *env)
Scheme_Objectscheme_tail_eval_expr (Scheme_Object *obj)
static Scheme_Objectsch_eval (const char *who, int argc, Scheme_Object *argv[])
Scheme_Objectscheme_default_eval_handler (int argc, Scheme_Object **argv)
Scheme_Objectscheme_default_compile_handler (int argc, Scheme_Object **argv)
static Scheme_Objectcurrent_eval (int argc, Scheme_Object **argv)
static Scheme_Objectcurrent_compile (int argc, Scheme_Object **argv)
Scheme_Objectscheme_datum_to_kernel_stx (Scheme_Object *e)
static Scheme_Objectstop_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectstop_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
Scheme_Objectscheme_get_stop_expander (void)
Scheme_Objectscheme_generate_lifts_key (void)
Scheme_Objectscheme_make_lifted_defn (Scheme_Object *sys_wraps, Scheme_Object **_ids, Scheme_Object *expr, Scheme_Comp_Env *env)
static Scheme_Objectadd_intdef_renamings (Scheme_Object *l, Scheme_Object *renaming)
static void update_intdef_chain (Scheme_Object *intdef)
static Scheme_Objectdo_local_expand (const char *name, int for_stx, int catch_lifts, int for_expr, int argc, Scheme_Object **argv)
static Scheme_Objectdo_eval_string_all (const char *str, Scheme_Env *env, int cont, int w_prompt)
Scheme_Objectscheme_eval_string_all (const char *str, Scheme_Env *env, int cont)
Scheme_Objectscheme_eval_string (const char *str, Scheme_Env *env)
Scheme_Objectscheme_eval_module_string (const char *str, Scheme_Env *env)
Scheme_Objectscheme_eval_string_multi (const char *str, Scheme_Env *env)
Scheme_Objectscheme_eval_string_all_with_prompt (const char *str, Scheme_Env *env, int cont)
Scheme_Objectscheme_eval_string_with_prompt (const char *str, Scheme_Env *env)
Scheme_Objectscheme_eval_string_multi_with_prompt (const char *str, Scheme_Env *env)
void scheme_init_collection_paths_post (Scheme_Env *global_env, Scheme_Object *extra_dirs, Scheme_Object *post_dirs)
void scheme_init_collection_paths (Scheme_Env *global_env, Scheme_Object *extra_dirs)
Scheme_Objectscheme_eval_clone (Scheme_Object *expr)
Resolve_Prefixscheme_prefix_eval_clone (Resolve_Prefix *rp)
int scheme_prefix_depth (Resolve_Prefix *rp)
Scheme_Object ** scheme_push_prefix (Scheme_Env *genv, Resolve_Prefix *rp, Scheme_Object *src_modidx, Scheme_Object *now_modidx, int src_phase, int now_phase)
void scheme_pop_prefix (Scheme_Object **rs)
static struct Validate_Clearingmake_clearing_stack ()
static void reset_clearing (struct Validate_Clearing *vc)
static void clearing_stack_push (struct Validate_Clearing *vc, int pos, int val)
static void noclear_stack_push (struct Validate_Clearing *vc, int pos)
void scheme_validate_code (Mz_CPort *port, Scheme_Object *code, int depth, int num_toplevels, int num_stxes, int num_lifts, int code_vec)
static Scheme_Objectvalidate_k (void)
int scheme_validate_rator_wants_box (Scheme_Object *app_rator, int pos, int hope, Validate_TLS tls, int num_toplevels, int num_stxes, int num_lifts)
static int argument_to_arity_error (Scheme_Object *app_rator, int proc_with_refs_ok)
void scheme_validate_closure (Mz_CPort *port, Scheme_Object *expr, char *closure_stack, Validate_TLS tls, int num_toplevels, int num_stxes, int num_lifts, int self_pos_in_closure)
static void validate_unclosed_procedure (Mz_CPort *port, Scheme_Object *expr, char *stack, Validate_TLS tls, int depth, int delta, int num_toplevels, int num_stxes, int num_lifts, Scheme_Object *app_rator, int proc_with_refs_ok, int self_pos)
static void check_self_call_valid (Scheme_Object *rator, Mz_CPort *port, struct Validate_Clearing *vc, int delta, char *stack)
void scheme_validate_expr (Mz_CPort *port, Scheme_Object *expr, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, int num_toplevels, int num_stxes, int num_lifts, Scheme_Object *app_rator, int proc_with_refs_ok, int result_ignored, struct Validate_Clearing *vc, int tailpos)
void scheme_validate_toplevel (Scheme_Object *expr, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int delta, int num_toplevels, int num_stxes, int num_lifts, int skip_refs_check)
void scheme_validate_boxenv (int p, Mz_CPort *port, char *stack, int depth, int delta)

Variables

volatile int scheme_fuel_counter
int scheme_startup_use_jit = 1
static THREAD_LOCAL Scheme_Objectquick_stx
int scheme_overflow_count
int scheme_continuation_application_count
Scheme_Objectscheme_eval_waiting
Scheme_Objectscheme_multiple_values
static Scheme_Objectapp_expander
static Scheme_Objectdatum_expander
static Scheme_Objecttop_expander
static Scheme_Objectstop_expander
static Scheme_Objectapp_symbol
static Scheme_Objectdatum_symbol
static Scheme_Objecttop_symbol
static Scheme_Objecttop_level_symbol
static Scheme_Objectdefine_values_symbol
static Scheme_Objectletrec_values_symbol
static Scheme_Objectlambda_symbol
static Scheme_Objectunknown_symbol
static Scheme_Objectvoid_link_symbol
static Scheme_Objectquote_symbol
static Scheme_Objectletrec_syntaxes_symbol
static Scheme_Objectbegin_symbol
static Scheme_Objectlet_values_symbol
static Scheme_Objectinternal_define_symbol
static Scheme_Objectmodule_symbol
static Scheme_Objectmodule_begin_symbol
static Scheme_Objectexpression_symbol
static Scheme_Objectprotected_symbol
Scheme_Objectscheme_stack_dump_key
static Scheme_Objectzero_rands_ptr

Class Documentation

struct Validate_Clearing

Definition at line 10292 of file eval.c.

Class Members
int * ncstack
int ncstackpos
int ncstacksize
int self_count
int self_pos
int self_start
int * stack
MZTAG_IF_REQUIRED int stackpos
MZTAG_IF_REQUIRED int stacksize

Define Documentation

#define BOOL (   x)    (x ? scheme_true : scheme_false)

Definition at line 11185 of file eval.c.

#define CAN_RESET_STACK_SLOT   0

Definition at line 10660 of file eval.c.

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

Definition at line 253 of file eval.c.

#define DEBUG_CHECK_TYPE (   v)

Definition at line 7118 of file eval.c.

Definition at line 7679 of file eval.c.

#define DO_CHECK_FOR_BREAK (   p,
 
)
Value:
if (DECREMENT_FUEL(scheme_fuel_counter, 1) <= 0) { \
         e scheme_thread_block(0); \
          (p)->ran_some = 1; \
       }

Definition at line 413 of file eval.c.

Definition at line 147 of file eval.c.

#define EVAL_SFS_CLEAR (   runstack,
  obj 
)
Value:
#define GET_FIRST_EVAL   evals[0]
#define GET_NEXT_ARG   *(args++)
#define GET_NEXT_EVAL   *(evals++)
#define global_lookup (   prefix,
  _obj,
  tmp 
)
Value:
tmp = RUNSTACK[SCHEME_TOPLEVEL_DEPTH(_obj)];                  \
          tmp = ((Scheme_Object **)tmp)[SCHEME_TOPLEVEL_POS(_obj)];     \
         tmp = (Scheme_Object *)(SCHEME_VAR_BUCKET(tmp))->val;         \
         if (!tmp) {                                                   \
            UPDATE_THREAD_RSPTR_FOR_ERROR();                            \
            unbound_global(_obj);                                       \
            return NULL;                                                \
         }                                                             \
         prefix tmp
#define icons   scheme_make_pair

Definition at line 271 of file eval.c.

#define lo   ((Scheme_Let_One *)obj)
#define LOG_INLINE (   x)    /*empty*/

Definition at line 2280 of file eval.c.

#define LOOKUP_NO_PROMPT   "continuation application: no corresponding prompt in the current continuation"

Definition at line 7308 of file eval.c.

#define MAX_SFS_CLEARING   0

Definition at line 3567 of file eval.c.

#define p   scheme_current_thread
#define PRIM_CHECK_ARITY   0
#define PRIM_CHECK_ARITY   1
#define PRIM_CHECK_ARITY   0
#define PRIM_CHECK_ARITY   1
#define PRIM_CHECK_MULTI   0
#define PRIM_CHECK_MULTI   0
#define PRIM_CHECK_MULTI   1
#define PRIM_CHECK_MULTI   1
#define RESET_LOCAL_RUNSTACK ( )    (runstack = MZ_RUNSTACK)
#define RUNSTACK   runstack
#define RUNSTACK_CHANGED ( )
#define SFS_BRANCH_W   4

Definition at line 3861 of file eval.c.

#define SFS_CLEAR_RUNSTACK (   runstack,
  i,
 
)    for (i = n; i--; ) { SFS_CLEAR_RUNSTACK_ONE(runstack, i); }
#define SFS_CLEAR_RUNSTACK_ONE (   runstack,
  pos 
)    runstack[pos] = NULL
#define SFS_LOG (   x)    /* nothing */

Definition at line 3569 of file eval.c.

#define UPDATE_THREAD_RSPTR ( )    (MZ_RUNSTACK = runstack)
#define USE_LOCAL_RUNSTACK   1

Definition at line 7678 of file eval.c.

Value:
if (rands == p->tail_buffer) {                                \
       if (num_rands < SCHEME_TAIL_COPY_THRESHOLD) {               \
         int i;                                                    \
         GC_CAN_IGNORE Scheme_Object **quick_rands;                \
                                                                    \
         quick_rands = PUSH_RUNSTACK(p, RUNSTACK, num_rands);      \
         RUNSTACK_CHANGED();                                       \
                                                                    \
         for (i = num_rands; i--; ) {                              \
           quick_rands[i] = rands[i];                              \
         }                                                         \
         rands = quick_rands;                                      \
       } else {                                                    \
         UPDATE_THREAD_RSPTR_FOR_GC();                             \
         make_tail_buffer_safe();                                  \
       }                                                           \
      }
#define VALID_BOX   3

Definition at line 10287 of file eval.c.

#define VALID_BOX_NOCLEAR   6

Definition at line 10290 of file eval.c.

#define VALID_NOT   0

Definition at line 10284 of file eval.c.

#define VALID_TOPLEVELS   4

Definition at line 10288 of file eval.c.

#define VALID_UNINIT   1

Definition at line 10285 of file eval.c.

#define VALID_VAL   2

Definition at line 10286 of file eval.c.

#define VALID_VAL_NOCLEAR   5

Definition at line 10289 of file eval.c.

#define WHEN_CAN_RESET_STACK_SLOT (   x)    0

Definition at line 10662 of file eval.c.


Typedef Documentation

typedef void(* DW_PrePost_Proc)(void *)

Definition at line 255 of file eval.c.


Enumeration Type Documentation

anonymous enum
Enumerator:
SCHEME_EVAL_CONSTANT 
SCHEME_EVAL_GLOBAL 
SCHEME_EVAL_LOCAL 
SCHEME_EVAL_LOCAL_UNBOX 
SCHEME_EVAL_GENERAL 

Definition at line 263 of file eval.c.


Function Documentation

static Scheme_Object* _compile ( Scheme_Object form,
Scheme_Env env,
int  writeable,
int  for_eval,
int  eb,
int  rename 
) [static]

Definition at line 5212 of file eval.c.

{
  Scheme_Thread *p = scheme_current_thread;

  if (SAME_TYPE(SCHEME_TYPE(form), scheme_compilation_top_type))
    return form;

  if (SCHEME_STXP(form)) {
    if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_compilation_top_type))
      return SCHEME_STX_VAL(form);
  }

  p->ku.k.p1 = form;
  p->ku.k.p2 = env;
  p->ku.k.i1 = writeable;
  p->ku.k.i2 = for_eval;
  p->ku.k.i3 = rename;

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

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* _eval ( Scheme_Object obj,
Scheme_Env env,
int  isexpr,
int  multi,
int  top,
int  as_tail 
) [static]

Definition at line 8961 of file eval.c.

{
  Scheme_Thread *p = scheme_current_thread;
  
  p->ku.k.p1 = obj;
  p->ku.k.p2 = env;
  p->ku.k.i1 = multi;
  p->ku.k.i2 = isexpr;
  p->ku.k.i3 = as_tail;

  if (top)
    return (Scheme_Object *)scheme_top_level_do(eval_k, 1);
  else
    return (Scheme_Object *)eval_k();
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 9004 of file eval.c.

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* _expand ( Scheme_Object obj,
Scheme_Comp_Env env,
int  depth,
int  rename,
int  just_to_top,
Scheme_Object catch_lifts_key,
int  eb,
Scheme_Object certs,
int  as_local 
) [static]

Definition at line 9192 of file eval.c.

{
  Scheme_Thread *p = scheme_current_thread;

  p->ku.k.p1 = obj;
  p->ku.k.p2 = env;
  p->ku.k.i1 = depth;
  p->ku.k.i2 = rename;
  p->ku.k.i3 = just_to_top;
  p->ku.k.p4 = catch_lifts_key;
  p->ku.k.p3 = certs;
  p->ku.k.i4 = as_local;

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

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 7139 of file eval.c.

{
#define PRIM_CHECK_ARITY 0
#define PRIM_CHECK_MULTI 1
#include "schapp.inc"
}

Definition at line 7121 of file eval.c.

{
#define PRIM_CHECK_ARITY 0
#define PRIM_CHECK_MULTI 0
#include "schapp.inc"
}

Definition at line 7148 of file eval.c.

{
#define PRIM_CHECK_ARITY 1
#define PRIM_CHECK_MULTI 1
#include "schapp.inc"
}

Definition at line 7130 of file eval.c.

{
#define PRIM_CHECK_ARITY 1
#define PRIM_CHECK_MULTI 0
#include "schapp.inc"
}

Definition at line 8988 of file eval.c.

{
  return _eval(obj, env, 0, 0, 0, 0);
}

Here is the call graph for this function:

Definition at line 8993 of file eval.c.

{
  return _eval(obj, env, 0, 1, 0, 0);
}

Here is the call graph for this function:

static Scheme_Object* add_intdef_renamings ( Scheme_Object l,
Scheme_Object renaming 
) [static]

Definition at line 9456 of file eval.c.

{
  Scheme_Object *rl = renaming;

  if (SCHEME_PAIRP(renaming)) {
    int need_delim;
    need_delim = !SCHEME_NULLP(SCHEME_CDR(rl));
    if (need_delim)
      l = scheme_add_rib_delimiter(l, scheme_null);
    while (!SCHEME_NULLP(rl)) {
      l = scheme_add_rename(l, SCHEME_CAR(rl));
      rl = SCHEME_CDR(rl);
    }
    if (need_delim)
      l = scheme_add_rib_delimiter(l, renaming);
  } else {
    l = scheme_add_rename(l, renaming);
  }

  return l;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* add_lifts_as_begin ( Scheme_Object obj,
Scheme_Object l,
Scheme_Comp_Env env 
) [static]

Definition at line 9078 of file eval.c.

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* add_lifts_as_let ( Scheme_Object obj,
Scheme_Object l,
Scheme_Comp_Env env,
Scheme_Object orig_form,
int  comp_rev 
) [static]

Definition at line 6282 of file eval.c.

{
  Scheme_Object *revl, *a;

  if (SCHEME_NULLP(l)) return obj;

  revl = scheme_reverse(l);

  if (comp_rev) {
    /* We've already compiled the body of this let
       with the bindings in reverse order. So insert a series of `lets'
       to match that order: */
    if (!SCHEME_NULLP(SCHEME_CDR(l))) {
      for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
        a = scheme_reverse(SCHEME_CAR(SCHEME_CAR(l)));
        for (; !SCHEME_NULLP(a); a = SCHEME_CDR(a)) {
          obj = icons(scheme_datum_to_syntax(let_values_symbol, scheme_false, scheme_sys_wraps(env), 0, 0),
                      icons(icons(icons(icons(SCHEME_CAR(a), scheme_null), icons(SCHEME_CAR(a), scheme_null)),
                                  scheme_null),
                            icons(obj, scheme_null)));
        }
      }
    }
  }

  for (; SCHEME_PAIRP(revl); revl = SCHEME_CDR(revl)) {
    a = SCHEME_CAR(revl);
    obj = icons(scheme_datum_to_syntax(let_values_symbol, scheme_false, scheme_sys_wraps(env), 0, 0),
                icons(icons(a, scheme_null),
                      icons(obj, scheme_null)));
  }

  obj = scheme_datum_to_syntax(obj, orig_form, scheme_false, 0, 0);
  
  return obj;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* add_renames_unless_module ( Scheme_Object form,
Scheme_Env genv 
) [static]

Definition at line 4932 of file eval.c.

{
  if (genv->rename_set) {
    if (SCHEME_STX_PAIRP(form)) {
      Scheme_Object *a, *d, *module_stx;
      
      a = SCHEME_STX_CAR(form);
      if (SCHEME_STX_SYMBOLP(a)) {
       a = scheme_add_rename(a, genv->rename_set);
        module_stx = scheme_datum_to_syntax(scheme_intern_symbol("module"),
                                            scheme_false, 
                                            scheme_sys_wraps_phase(scheme_make_integer(genv->phase)), 
                                            0, 0);
       if (scheme_stx_module_eq(a, module_stx, genv->phase)) {
         /* Don't add renames to the whole module; let the 
            module's language take over. */
         d = SCHEME_STX_CDR(form);
         a = scheme_make_pair(a, d);
         form = scheme_datum_to_syntax(a, form, form, 0, 1);
         return form;
       }
      }
    }
  }

  if (genv->rename_set) {
    form = scheme_add_rename(form, genv->rename_set);
    /* this "phase shift" just attaches the namespace's module registry: */
    form = scheme_stx_phase_shift(form, 0, NULL, NULL, genv->export_registry);
  }

  return form;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 9984 of file eval.c.

{
  return scheme_param_config("compile-allow-set!-undefined", 
                          scheme_make_integer(MZCONFIG_ALLOW_SET_UNDEFINED),
                          argc, argv,
                          -1, NULL, NULL, 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * app_expand ( Scheme_Object form,
Scheme_Comp_Env env,
Scheme_Expand_Info erec,
int  drec 
) [static]

Definition at line 6111 of file eval.c.

{
  SCHEME_EXPAND_OBSERVE_PRIM_APP(erec[drec].observer);
  return compile_expand_app(form, env, erec, drec);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * app_syntax ( Scheme_Object form,
Scheme_Comp_Env env,
Scheme_Compile_Info rec,
int  drec 
) [static]

Definition at line 6105 of file eval.c.

{
  return compile_expand_app(form, env, rec, drec);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* apply_inlined ( Scheme_Object p,
Scheme_Closure_Data data,
Optimize_Info info,
int  argc,
Scheme_App_Rec app,
Scheme_App2_Rec app2,
Scheme_App3_Rec app3 
) [static]

Definition at line 2221 of file eval.c.

{
  Scheme_Let_Header *lh;
  Scheme_Compiled_Let_Value *lv, *prev = NULL;
  int i;
  int *flags, flag;

  if (!argc) {
    info = scheme_optimize_info_add_frame(info, 0, 0, 0);
    info->inline_fuel >>= 1;
    p = scheme_optimize_expr(p, info);
    info->next->single_result = info->single_result;
    info->next->preserves_marks = info->preserves_marks;
    scheme_optimize_info_done(info);
    return p;
  }

  lh = MALLOC_ONE_TAGGED(Scheme_Let_Header);
  lh->iso.so.type = scheme_compiled_let_void_type;
  lh->count = argc;
  lh->num_clauses = argc;

  for (i = 0; i < argc; i++) {
    lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value);
    lv->so.type = scheme_compiled_let_value_type;
    lv->count = 1;
    lv->position = i;

    if (app)
      lv->value = app->args[i + 1];
    else if (app3)
      lv->value = (i ? app3->rand2 : app3->rand1);
    else if (app2)
      lv->value = app2->rand;

    flag = scheme_closure_argument_flags(data, i);
    flags = (int *)scheme_malloc_atomic(sizeof(int));
    flags[0] = flag;
    lv->flags = flags;

    if (prev)
      prev->body = (Scheme_Object *)lv;
    else
      lh->body = (Scheme_Object *)lv;
    prev = lv;
  }

  if (prev)
    prev->body = p;
  else
    lh->body = p;

  return scheme_optimize_lets((Scheme_Object *)lh, info, 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int arg_count ( Scheme_Object lam,
Scheme_Comp_Env env 
) [static]

Definition at line 5832 of file eval.c.

{
  Scheme_Object *l, *id, *form = lam;
  int cnt = 0;
  DupCheckRecord r;
  
  lam = SCHEME_STX_CDR(lam);
  if (!SCHEME_STX_PAIRP(lam)) return -1;

  l = SCHEME_STX_CAR(lam);

  lam = SCHEME_STX_CDR(lam);
  if (!SCHEME_STX_PAIRP(lam)) return -1;

  while (SCHEME_STX_PAIRP(lam)) { lam = SCHEME_STX_CDR(lam); }
  if (!SCHEME_STX_NULLP(lam)) return -1;
  

  scheme_begin_dup_symbol_check(&r, env);

  while (SCHEME_STX_PAIRP(l)) {
    id = SCHEME_STX_CAR(l);
    scheme_check_identifier("lambda", id, NULL, env, form);
    scheme_dup_symbol_check(&r, NULL, id, "argument", form);
    l = SCHEME_STX_CDR(l);
    cnt++;
  }
  if (!SCHEME_STX_NULLP(l)) return -1;

  return cnt;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int argument_to_arity_error ( Scheme_Object app_rator,
int  proc_with_refs_ok 
) [static]

Definition at line 10506 of file eval.c.

{
  /* Since `raise-arity-error' doesn't actually apply its argument,
     it's ok to pass any procedure. In particular, the compiler generates
     calls to converted procedures. */
  return ((proc_with_refs_ok == 2)
          && SAME_OBJ(app_rator, scheme_raise_arity_error_proc));
}

Here is the caller graph for this function:

static Scheme_Object* call_compile_handler ( Scheme_Object form,
int  immediate_eval 
) [static]

Definition at line 4914 of file eval.c.

{
  Scheme_Object *argv[2], *o;

  argv[0] = form;
  argv[1] = (immediate_eval ? scheme_true : scheme_false);
  o = scheme_get_param(scheme_current_config(), MZCONFIG_COMPILE_HANDLER);
  o = scheme_apply(o, 2, argv);
  
  if (!SAME_TYPE(SCHEME_TYPE(o), scheme_compilation_top_type)) {
    argv[0] = o;
    scheme_wrong_type("compile-handler", "compiled code", 0, -1, argv);
    return NULL;
  }

  return o;
}

Here is the caller graph for this function:

static Scheme_Object* cert_ids ( Scheme_Object orig_ids,
Scheme_Object orig 
) [static]

Definition at line 5864 of file eval.c.

{
  Scheme_Object *id, *ids = orig_ids, *pr, *first = scheme_null, *last = NULL;

  while (!SCHEME_STX_NULLP(ids)) {

    id = SCHEME_STX_CAR(ids);
    id = scheme_stx_cert(id, NULL, NULL, orig, NULL, 1);

    pr = scheme_make_pair(id, scheme_null);
    
    if (last)
      SCHEME_CDR(last) = pr;
    else
      first = pr;
    last = pr;

    ids = SCHEME_STX_CDR(ids);
  }

  return scheme_datum_to_syntax(first, orig_ids, orig_ids, 0, 2);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* check_app_let_rator ( Scheme_Object app,
Scheme_Object rator,
Optimize_Info info,
int  argc 
) [static]

Definition at line 2480 of file eval.c.

{
  if (SAME_TYPE(SCHEME_TYPE(rator), scheme_compiled_let_void_type)) {
    Scheme_Let_Header *head = (Scheme_Let_Header *)rator;

    if ((head->count == 1) && (head->num_clauses == 1)) {
      Scheme_Object *body;
      Scheme_Compiled_Let_Value *clv;

      clv = (Scheme_Compiled_Let_Value *)head->body;
      body = clv->body;
      if (SAME_TYPE(SCHEME_TYPE(body), scheme_local_type)
          && (SCHEME_LOCAL_POS(body) == 0)
          && scheme_is_compiled_procedure(clv->value, 1, 1)) {
        
        reset_rator(app, scheme_false);
        app = scheme_optimize_shift(app, 1, 0);
        reset_rator(app, scheme_make_local(scheme_local_type, 0, 0));

        clv->body = app;
        
        if (clv->flags[0] & SCHEME_WAS_APPLIED_EXCEPT_ONCE) {
          clv->flags[0] -= SCHEME_WAS_APPLIED_EXCEPT_ONCE;
          clv->flags[0] |= SCHEME_WAS_ONLY_APPLIED;
        }
        
        return scheme_optimize_expr(rator, info);
      }
    }
  }

  return NULL;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Prompt* check_barrier ( Scheme_Prompt prompt,
Scheme_Meta_Continuation prompt_cont,
MZ_MARK_POS_TYPE  prompt_pos,
Scheme_Cont c 
) [static]

Definition at line 7310 of file eval.c.

{
  Scheme_Prompt *barrier_prompt, *b1, *b2;
  Scheme_Meta_Continuation *barrier_cont;
  MZ_MARK_POS_TYPE barrier_pos;

  barrier_prompt = scheme_get_barrier_prompt(&barrier_cont, &barrier_pos);
  b1 = barrier_prompt;
  if (b1) {
    if (!b1->is_barrier)
      b1 = NULL;
    else if (prompt
             && scheme_is_cm_deeper(barrier_cont, barrier_pos,
                                    prompt_cont, prompt_pos))
      b1 = NULL;
  }
  b2 = c->barrier_prompt;
  if (b2) {
    if (!b2->is_barrier)
      b2 = NULL;
  }
  
  if (b1 != b2) {
    scheme_raise_exn(MZEXN_FAIL_CONTRACT_CONTINUATION,
                     "continuation application: attempt to cross a continuation barrier");
  }

  return barrier_prompt;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* check_converted_rator ( Scheme_Object rator,
Resolve_Info info,
Scheme_Object **  new_rator,
int  orig_arg_cnt,
int _rdelta 
) [static]

Definition at line 1162 of file eval.c.

{
  Scheme_Object *lifted;
  int flags;

  if (!SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type))
    return NULL;

  (void)scheme_resolve_info_lookup(info, SCHEME_LOCAL_POS(rator), &flags, &lifted, orig_arg_cnt + 1);

  if (lifted && SCHEME_RPAIRP(lifted)) {
    Scheme_Object *vec, *arity;

    *new_rator = SCHEME_CAR(lifted);
    vec = SCHEME_CDR(lifted);
    *_rdelta = 0;

    if (SCHEME_VEC_SIZE(vec) > 1) {
      /* Check that actual argument count matches expected. If
         it doesn't, we need to generate explicit code to report
         the error, so that the conversion's arity change isn't
         visible. */
      arity = SCHEME_VEC_ELS(vec)[0];
      if (SCHEME_INTP(arity)) {
        if (orig_arg_cnt == SCHEME_INT_VAL(arity))
          arity = NULL;
      } else {
        arity = SCHEME_BOX_VAL(arity);
        if (orig_arg_cnt >= SCHEME_INT_VAL(arity))
          arity = NULL;
        else {
          Scheme_App2_Rec *app;
          app = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
          app->iso.so.type = scheme_application2_type;
          app->rator = scheme_make_arity_at_least;
          app->rand = arity;
          arity = (Scheme_Object *)app;
          *_rdelta = 1; /* so app gets resolved */
        }
      }
      /* If arity is non-NULL, there's a mismatch. */
      if (arity) {
        /* Generate a call to `raise-arity-error' instead of
           the current *new_rator: */
        Scheme_Object *old_rator = *new_rator;
        if (SAME_TYPE(SCHEME_TYPE(old_rator), scheme_toplevel_type)) {
          /* More coordinate trouble. old_rator was computed for an
             application with a potentially different number of arguments. */
          int delta;
          delta = 3 - SCHEME_VEC_SIZE(vec);
          if (delta)
            old_rator = scheme_shift_toplevel(old_rator, delta);
        }
        vec = scheme_make_vector(3, NULL);
        SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(0);
        SCHEME_VEC_ELS(vec)[1] = old_rator;
        SCHEME_VEC_ELS(vec)[2] = arity;
        *new_rator = scheme_raise_arity_error_proc;
      }
    }

    return vec;
  } else
    return NULL;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void check_self_call_valid ( Scheme_Object rator,
Mz_CPort *  port,
struct Validate_Clearing vc,
int  delta,
char *  stack 
) [static]

Definition at line 10643 of file eval.c.

{
  if ((vc->self_pos >= 0)
      && SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type)
      && !(SCHEME_LOCAL_FLAGS(rator) & SCHEME_LOCAL_CLEARING_MASK)
      && ((SCHEME_LOCAL_POS(rator) + delta) == vc->self_pos)) {
    /* For a self call, the JIT needs the closure data to be intact. */
    int i, pos;
    for (i = vc->self_count; i--; ) {
      pos = i + vc->self_start;
      if (stack[pos] <= VALID_UNINIT)
        scheme_ill_formed_code(port);
    }
  }
}

Here is the caller graph for this function:

static Scheme_Object* check_top ( const char *  when,
Scheme_Object form,
Scheme_Comp_Env env,
Scheme_Compile_Info rec,
int  drec 
) [static]

Definition at line 6162 of file eval.c.

{
  Scheme_Object *c;

  if (rec[drec].pre_unwrapped) {
    c = form;
    rec[drec].pre_unwrapped = 0;
  } else
    c = SCHEME_STX_CDR(form);

  if (!SCHEME_STX_SYMBOLP(c))
    scheme_wrong_syntax(NULL, NULL, form, NULL);

  if (env->genv->module) {
    Scheme_Object *modidx, *symbol = c, *tl_id;
    int bad;

    tl_id = scheme_tl_id_sym(env->genv, symbol, NULL, 0, NULL, NULL);
    if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) {
      /* Since the module has a rename for this id, it's certainly defined. */
    } else {
      modidx = scheme_stx_module_name(NULL, &symbol, scheme_make_integer(env->genv->phase), NULL, NULL, NULL, 
                                      NULL, NULL, NULL, NULL, NULL);
      if (modidx) {
       /* If it's an access path, resolve it: */
       if (env->genv->module
           && SAME_OBJ(scheme_module_resolve(modidx, 1), env->genv->module->modname))
         bad = 0;
       else
         bad = 1;
      } else
       bad = 1;

      if (env->genv->disallow_unbound) {
       if (bad || !scheme_lookup_in_table(env->genv->toplevel, (const char *)SCHEME_STX_SYM(c))) {
          GC_CAN_IGNORE const char *reason;
          if (env->genv->phase == 1) {
            reason = "unbound identifier in module (transformer environment)";
            /* Check in the run-time environment */
            if (scheme_lookup_in_table(env->genv->template_env->toplevel, (const char *)SCHEME_STX_SYM(c))) {
              reason = ("unbound identifier in module (in the transformer environment, which does"
                        " not include the run-time definition)");
            } else if (env->genv->template_env->syntax
                       && scheme_lookup_in_table(env->genv->template_env->syntax, (const char *)SCHEME_STX_SYM(c))) {
              reason = ("unbound identifier in module (in the transformer environment, which does"
                        " not include the macro definition that is visible to run-time expressions)");
            }
          } else
            reason = "unbound identifier in module";
         scheme_wrong_syntax(when, NULL, c, reason);
       }
      }
    }
  }

  return c;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void clearing_stack_push ( struct Validate_Clearing vc,
int  pos,
int  val 
) [static]

Definition at line 10316 of file eval.c.

{
  if (vc->stackpos + 2 > vc->stacksize) {
    int *a, sz;
    sz = (vc->stacksize ? 2 * vc->stacksize : 32);
    a = (int *)scheme_malloc_atomic(sizeof(int) * sz);
    memcpy(a, vc->stack, vc->stacksize * sizeof(int));
    vc->stacksize = sz;
    vc->stack = a;
  }
  vc->stack[vc->stackpos] = pos;
  vc->stack[vc->stackpos + 1] = val;
  vc->stackpos += 2;
}

Here is the caller graph for this function:

static MZ_MARK_STACK_TYPE clone_meta_cont_set_mark ( Scheme_Meta_Continuation mc,
Scheme_Object val,
long  findpos 
) [static]

Definition at line 6943 of file eval.c.

{
  /* Clone the meta-continuation, in case it was captured by
     a continuation in its current state. */
  Scheme_Meta_Continuation *naya;
  Scheme_Cont_Mark *cp;

  naya = MALLOC_ONE_RT(Scheme_Meta_Continuation);
  memcpy(naya, mc, sizeof(Scheme_Meta_Continuation));
  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));
  naya->cont_mark_stack_copied = cp;
  naya->copy_after_captured = scheme_cont_capture_count;
  mc = naya;
  scheme_current_thread->meta_continuation = mc;

  mc->cont_mark_stack_copied[findpos].val = val;
  mc->cont_mark_stack_copied[findpos].cache = NULL;

  return 0;
}

Here is the caller graph for this function:

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

Definition at line 9351 of file eval.c.

{
  Scheme_Object *form = argv[0];
  Scheme_Env *genv;

  if (!SCHEME_STXP(form))
    form = scheme_datum_to_syntax(form, scheme_false, scheme_false, 1, 0);

  genv = scheme_get_env(NULL);
  form = add_renames_unless_module(form, genv);

  return call_compile_handler(form, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* compile_application ( Scheme_Object form,
Scheme_Comp_Env env,
Scheme_Compile_Info rec,
int  drec 
) [static]

Definition at line 4887 of file eval.c.

{
  Scheme_Object *result;
  int len;

  len = scheme_stx_proper_list_length(form);

  if (len < 0)
    scheme_wrong_syntax(scheme_application_stx_string, NULL, form, NULL);
  
  scheme_compile_rec_done_local(rec, drec);
  scheme_rec_add_certs(rec, drec, form);
  form = scheme_inner_compile_list(form, scheme_no_defines(env), rec, drec, 1);

  result = make_application(form);
  
  return result;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* compile_expand_app ( Scheme_Object forms,
Scheme_Comp_Env env,
Scheme_Compile_Expand_Info rec,
int  drec 
) [static]

Definition at line 5888 of file eval.c.

{
  Scheme_Object *form, *naya;
  int tsc;

  tsc = rec[drec].pre_unwrapped;
  rec[drec].pre_unwrapped = 0;

  scheme_rec_add_certs(rec, drec, forms);
  if (tsc) {
    form = forms;
  } else {
    form = SCHEME_STX_CDR(forms);
    form = scheme_datum_to_syntax(form, forms, forms, 0, 0);
  }
  
  if (SCHEME_STX_NULLP(form)) {
    /* Compile/expand empty application to null list: */
    if (rec[drec].comp)
      return scheme_null;
    else
      return scheme_datum_to_syntax(icons(quote_symbol,
                                          icons(form, scheme_null)),
                                form,
                                scheme_sys_wraps(env), 
                                0, 2);
  } else if (!SCHEME_STX_PAIRP(form)) {
     /* will end in error */
    if (rec[drec].comp)
      return compile_application(form, env, rec, drec);
    else {
      rec[drec].value_name = scheme_false;
      naya = scheme_expand_list(form, scheme_no_defines(env), rec, drec);
      /* naya will be prefixed and returned... */
    }
  } else if (rec[drec].comp) {
    Scheme_Object *name, *origname, *gval, *orig_rest_form, *rest_form;
    name = SCHEME_STX_CAR(form);
    origname = name;
    
    name = scheme_check_immediate_macro(name, env, rec, drec, 0, &gval, NULL, NULL);

    /* look for ((lambda (x) ...) ...); */
    if (SAME_OBJ(gval, scheme_lambda_syntax)) {
      Scheme_Object *argsnbody;
       
      argsnbody = SCHEME_STX_CDR(name);
      if (SCHEME_STX_PAIRP(argsnbody)) {
        Scheme_Object *args, *body;

        args = SCHEME_STX_CAR(argsnbody);
        body = SCHEME_STX_CDR(argsnbody);
         
        if (SCHEME_STX_PAIRP(body)) {
          int pl;
          pl = scheme_stx_proper_list_length(args);
          if (pl >= 0) {
            Scheme_Object *bindings = scheme_null, *last = NULL;
            Scheme_Object *rest;
            int al;
             
            rest = SCHEME_STX_CDR(form);
            al = scheme_stx_proper_list_length(rest);

            if (al == pl) {       
              DupCheckRecord r;

              scheme_begin_dup_symbol_check(&r, env);
             
              while (!SCHEME_STX_NULLP(args)) {
                Scheme_Object *v, *n;
                
                n = SCHEME_STX_CAR(args);
                scheme_check_identifier("lambda", n, NULL, env, name);

                /* If we don't check here, the error is in terms of `let': */
                scheme_dup_symbol_check(&r, NULL, n, "argument", name);
  
                /* Propagate certifications to bound id: */
                n = scheme_stx_cert(n, NULL, NULL, name, NULL, 1);

                v = SCHEME_STX_CAR(rest);
                v = cons(cons(cons(n, scheme_null), cons(v, scheme_null)), scheme_null);
                if (last)
                  SCHEME_CDR(last) = v;
                else
                  bindings = v;
                
                last = v;
                args = SCHEME_STX_CDR(args);
                rest = SCHEME_STX_CDR(rest);
              }

              body = scheme_datum_to_syntax(icons(begin_symbol, body), form, 
                                            scheme_sys_wraps(env), 
                                            0, 2);
              /* Copy certifications from lambda to `body'. */
              body = scheme_stx_cert(body, NULL, NULL, name, NULL, 1);
              
              body = scheme_datum_to_syntax(cons(let_values_symbol,
                                                 cons(bindings,
                                                      cons(body, scheme_null))),
                                            form, 
                                            scheme_sys_wraps(env), 
                                            0, 2);

              return scheme_compile_expand_expr(body, env, rec, drec, 0);
            } else {
#if 0
              scheme_wrong_syntax(scheme_application_stx_string, NULL, form, 
                                  "procedure application: bad ((lambda (...) ...) ...) syntax");
              return NULL;
#endif
            }
          }
        }
      }
    }

    orig_rest_form = SCHEME_STX_CDR(form);

    /* Look for (call-with-values (lambda () M) (lambda (id ...) N)) */ 
    if (SCHEME_STX_SYMBOLP(name)) {
      Scheme_Object *at_first, *at_second, *the_end, *cwv_stx;
      at_first = SCHEME_STX_CDR(form);
      if (SCHEME_STX_PAIRP(at_first)) {
        at_second = SCHEME_STX_CDR(at_first);
        if (SCHEME_STX_PAIRP(at_second)) {
          the_end = SCHEME_STX_CDR(at_second);
          if (SCHEME_STX_NULLP(the_end)) {
            Scheme_Object *orig_at_second = at_second;

            cwv_stx = scheme_datum_to_syntax(scheme_intern_symbol("call-with-values"), 
                                             scheme_false, scheme_sys_wraps(env), 0, 0);
            if (scheme_stx_module_eq(name, cwv_stx, 0)) {
              Scheme_Object *first, *orig_first;
              orig_first = SCHEME_STX_CAR(at_first);
              first = scheme_check_immediate_macro(orig_first, env, rec, drec, 0, &gval, NULL, NULL);
              if (SAME_OBJ(gval, scheme_lambda_syntax) 
                  && SCHEME_STX_PAIRP(first)
                  && (arg_count(first, env) == 0)) {
                Scheme_Object *second, *orig_second;
                orig_second = SCHEME_STX_CAR(at_second);
                second = scheme_check_immediate_macro(orig_second, env, rec, drec, 0, &gval, NULL, NULL);
                if (SAME_OBJ(gval, scheme_lambda_syntax) 
                    && SCHEME_STX_PAIRP(second)
                    && (arg_count(second, env) >= 0)) {
                  Scheme_Object *lhs, *orig_post_first, *orig_post_second;
                  orig_post_first = first;
                  orig_post_second = second;
                  second = SCHEME_STX_CDR(second);
                  lhs = SCHEME_STX_CAR(second);
                  second = SCHEME_STX_CDR(second);
                  first = SCHEME_STX_CDR(first);
                  first = SCHEME_STX_CDR(first);
                  first = icons(begin_symbol, first);
                  first = scheme_datum_to_syntax(first, orig_post_first, scheme_sys_wraps(env), 0, 1);
                  second = icons(begin_symbol, second);
                  second = scheme_datum_to_syntax(second, orig_post_second, scheme_sys_wraps(env), 0, 1);
                  /* Copy certifications from lambda to body: */
                  lhs = cert_ids(lhs, orig_post_second);
                  first = scheme_stx_cert(first, NULL, NULL, orig_post_first, NULL, 1);
                  second = scheme_stx_cert(second, NULL, NULL, orig_post_second, NULL, 1);
                  /* Convert to let-values: */
                  name = icons(let_values_symbol,
                               icons(icons(icons(lhs, icons(first, scheme_null)), 
                                           scheme_null),
                                     icons(second, scheme_null)));
                  form = scheme_datum_to_syntax(name, forms, scheme_sys_wraps(env), 0, 2);
                  return scheme_compile_expand_expr(form, env, rec, drec, 0);
                }
                if (!SAME_OBJ(second, orig_second)) {
                  at_second = scheme_datum_to_syntax(icons(second, the_end), at_second, at_second, 0, 2);
                } 
              }
              if (!SAME_OBJ(first, orig_first)
                  || !SAME_OBJ(at_second, orig_at_second)) {
                at_first = scheme_datum_to_syntax(icons(first, at_second), at_first, at_first, 0, 2);
              }
            }
          }
        }
      }
      rest_form = at_first;
    } else {
      rest_form = orig_rest_form;
    }

    if (NOT_SAME_OBJ(name, origname)
        || NOT_SAME_OBJ(rest_form, orig_rest_form)) {
      form = scheme_datum_to_syntax(scheme_make_pair(name, rest_form), forms, forms, 0, 2);
    }
    
    return compile_application(form, env, rec, drec);
  } else {
    scheme_rec_add_certs(rec, drec, form);
    rec[drec].value_name = scheme_false;
    naya = scheme_expand_list(form, scheme_no_defines(env), rec, drec);
    /* naya will be prefixed returned... */
  }

  if (SAME_OBJ(form, naya))
    return forms;

  /* Add #%app prefix back: */
  {
    Scheme_Object *first;

    first = SCHEME_STX_CAR(forms);
    return scheme_datum_to_syntax(scheme_make_pair(first, naya),
                              forms,
                              forms, 0, 2);
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* compile_expand_expr_k ( void  ) [static]

Definition at line 5379 of file eval.c.

{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object *form = (Scheme_Object *)p->ku.k.p1;
  Scheme_Comp_Env *env = (Scheme_Comp_Env *)p->ku.k.p2;
  Scheme_Compile_Info *rec = (Scheme_Compile_Info *)p->ku.k.p3;

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

  return scheme_compile_expand_expr(form, 
                                env,
                                rec,
                                p->ku.k.i3,
                                p->ku.k.i2);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* compile_expand_expr_lift_to_let ( Scheme_Object form,
Scheme_Comp_Env env,
Scheme_Expand_Info rec,
int  drec 
) [static]

Definition at line 6323 of file eval.c.

{
  Scheme_Expand_Info recs[2];
  Scheme_Object *l, *orig_form = form, *context_key;
  Scheme_Comp_Env *inserted, **ip;

  /* This function only works when `env' has no lexical bindings,
     because we might insert new ones at the beginning.  In
     particular, we might insert frames between `inserted' and
     `env'.

     This function also relies on the way that compilation of `let'
     works. A let-bound variable is compiled to a count of the frames
     to skip and the index within the frame, so we can insert new
     frames without affecting lookups computed so far. Inserting each
     new frame before any previous one turns out to be consistent with
     the nested `let's that we generate at the end. 

     Some optimizations can happen later, for example constant
     propagate.  But these optimizations take place on the result of
     this function, so we don't have to worry about them.  

     Don't generate a `let*' expression instead of nested `let's,
     because the compiler actually takes shortcuts (that are
     inconsistent with our frame nesting) instead of expanding `let*'
     to `let'. */

#ifdef DO_STACK_CHECK
  {
# include "mzstkchk.h"
    {
      Scheme_Thread *p = scheme_current_thread;
      Scheme_Compile_Expand_Info *recx;

      recx = MALLOC_ONE_RT(Scheme_Compile_Expand_Info);
      memcpy(recx, rec + drec, sizeof(Scheme_Compile_Expand_Info));
#ifdef MZTAG_REQUIRED
      recx->type = scheme_rt_compile_info;
#endif

      p->ku.k.p1 = (void *)form;
      p->ku.k.p2 = (void *)env;
      p->ku.k.p3 = (void *)recx;

      form = scheme_handle_stack_overflow(compile_expand_expr_lift_to_let_k);

      memcpy(rec + drec, recx, sizeof(Scheme_Compile_Expand_Info));
      return form;
    }
  }
#endif

  inserted = scheme_new_compilation_frame(0, 0, env, NULL);

  ip = MALLOC_N(Scheme_Comp_Env *, 1);
  *ip = inserted;

  context_key = scheme_generate_lifts_key();
  
  scheme_frame_captures_lifts(inserted, pair_lifted, (Scheme_Object *)ip, scheme_false, 
                              context_key, NULL, scheme_false);

  if (rec[drec].comp) {
    scheme_init_compile_recs(rec, drec, recs, 2);
    form = scheme_compile_expr(form, inserted, recs, 0);
  } else {
    scheme_init_expand_recs(rec, drec, recs, 2);
    form = scheme_expand_expr(form, inserted, recs, 0);
  }

  l = scheme_frame_get_lifts(inserted);
  if (SCHEME_NULLP(l)) {
    /* No lifts */
    if (rec[drec].comp)
      scheme_merge_compile_recs(rec, drec, recs, 1);
    return form;
  } else {
    /* We have lifts, so add let* wrapper and go again */
    Scheme_Object *o;
    if (rec[drec].comp) {
      /* Wrap compiled part so the compiler recognizes it later: */
      o = scheme_alloc_object();
      o->type = scheme_already_comp_type;
      SCHEME_IPTR_VAL(o) = form;
    } else
      o = form;
    form = add_lifts_as_let(o, l, env, orig_form, rec[drec].comp);
    SCHEME_EXPAND_OBSERVE_LETLIFT_LOOP(rec[drec].observer, form);
    form = compile_expand_expr_lift_to_let(form, env, recs, 1);
    if (rec[drec].comp)
      scheme_merge_compile_recs(rec, drec, recs, 2);
    return form;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 6419 of file eval.c.

{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object *form = (Scheme_Object *)p->ku.k.p1;
  Scheme_Comp_Env *env = (Scheme_Comp_Env *)p->ku.k.p2;
  Scheme_Compile_Info *rec = (Scheme_Compile_Info *)p->ku.k.p3;

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

  return compile_expand_expr_lift_to_let(form, env, rec, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* compile_expand_macro_app ( Scheme_Object name,
Scheme_Env menv,
Scheme_Object macro,
Scheme_Object form,
Scheme_Comp_Env env,
Scheme_Compile_Expand_Info rec,
int  drec 
) [static]

Definition at line 5341 of file eval.c.

{
  Scheme_Object *xformer, *boundname;

  xformer = (Scheme_Object *)SCHEME_PTR_VAL(macro);

  if (scheme_is_set_transformer(xformer)) {
    /* scheme_apply_macro unwraps it */
  } else {
    if (!scheme_check_proc_arity(NULL, 1, 0, -1, &xformer)) {
      scheme_wrong_syntax(NULL, NULL, form, "illegal use of syntax");
      return NULL;
    }
  }

  boundname = rec[drec].value_name;
  if (!boundname)
    boundname = scheme_false;

  return scheme_apply_macro(name, menv, xformer, form, env, boundname, rec, drec, 0);

  /* caller expects rec[drec] to be used to compile the result... */
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void* compile_k ( void  ) [static]

Definition at line 5018 of file eval.c.

{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object *form;
  int writeable, for_eval, rename, enforce_consts, comp_flags;
  Scheme_Env *genv;
  Scheme_Compile_Info rec, rec2;
  Scheme_Object *o, *rl, *tl_queue;
  Scheme_Compilation_Top *top;
  Resolve_Prefix *rp;
  Resolve_Info *ri;
  Optimize_Info *oi;
  Scheme_Object *gval, *insp;
  Scheme_Comp_Env *cenv;

  form = (Scheme_Object *)p->ku.k.p1;
  genv = (Scheme_Env *)p->ku.k.p2;
  writeable = p->ku.k.i1;
  for_eval = p->ku.k.i2;
  rename = p->ku.k.i3;

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

  if (!SCHEME_STXP(form)) {
    form = scheme_datum_to_syntax(form, scheme_false, scheme_false, 1, 0);
    rename = 1;
  }

  /* Renamings for requires: */
  if (rename) {
    form = add_renames_unless_module(form, genv);
    if (genv->module) {
      form = scheme_stx_phase_shift(form, 0, 
                                genv->module->me->src_modidx, 
                                genv->module->self_modidx,
                                genv->export_registry);
    }
  }

  tl_queue = scheme_null;

  {
    Scheme_Config *config;
    config = scheme_current_config();
    insp = scheme_get_param(config, MZCONFIG_CODE_INSPECTOR);
    enforce_consts = SCHEME_TRUEP(scheme_get_param(config, MZCONFIG_COMPILE_MODULE_CONSTS));
    comp_flags = get_comp_flags(config);
  }

  while (1) {
    scheme_prepare_compile_env(genv);

    rec.comp = 1;
    rec.dont_mark_local_use = 0;
    rec.resolve_module_ids = !writeable && !genv->module;
    rec.no_module_cert = 0;
    rec.value_name = scheme_false;
    rec.certs = NULL;
    rec.observer = NULL;
    rec.pre_unwrapped = 0;
    rec.env_already = 0;
    rec.comp_flags = comp_flags;

    cenv = scheme_new_comp_env(genv, insp, SCHEME_TOPLEVEL_FRAME);

    if (for_eval) {
      /* Need to look for top-level `begin', and if we
        find one, break it up to eval first expression
        before the rest. */
      while (1) {
       scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), 
                                    scheme_false, scheme_false, scheme_null, scheme_false);
       form = scheme_check_immediate_macro(form, 
                                       cenv, &rec, 0,
                                       0, &gval, NULL, NULL);
       if (SAME_OBJ(gval, scheme_begin_syntax)) {
         if (scheme_stx_proper_list_length(form) > 1){
           form = SCHEME_STX_CDR(form);
           tl_queue = scheme_append(scheme_flatten_syntax_list(form, NULL),
                                 tl_queue);
           tl_queue = scheme_append(scheme_frame_get_lifts(cenv),
                                 tl_queue);
           form = SCHEME_CAR(tl_queue);
           tl_queue = SCHEME_CDR(tl_queue);
         } else
           break;
       } else {
         rl = scheme_frame_get_require_lifts(cenv);
         o = scheme_frame_get_lifts(cenv);
         if (!SCHEME_NULLP(o)
              || !SCHEME_NULLP(rl)) {
           tl_queue = scheme_make_pair(form, tl_queue);
           tl_queue = scheme_append(o, tl_queue);
           tl_queue = scheme_append(rl, tl_queue);
           form = SCHEME_CAR(tl_queue);
           tl_queue = SCHEME_CDR(tl_queue);
         }
         break;
       }
      }
    }

    if (for_eval) {
      o = call_compile_handler(form, 1);
      top = (Scheme_Compilation_Top *)o;
    } else {
      /* We want to simply compile `form', but we have to loop in case
        an expression is lifted in the process of compiling: */
      Scheme_Object *l, *prev_o = NULL;

      while (1) {
       scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), 
                                    scheme_false, scheme_false, scheme_null, scheme_false);

       scheme_init_compile_recs(&rec, 0, &rec2, 1);

       o = scheme_compile_expr(form, cenv, &rec2, 0);

       /* If we had compiled an expression in a previous iteration,
          combine it in a sequence: */
       if (prev_o) {
         Scheme_Sequence *seq;
         seq = malloc_sequence(2);
         seq->so.type = scheme_sequence_type;
         seq->count = 2;
         seq->array[0] = o;
         seq->array[1] = prev_o;
         o = (Scheme_Object *)seq;
       }

       /* If any definitions were lifted in the process of compiling o,
          we need to fold them in. */
       l = scheme_frame_get_lifts(cenv);
       rl = scheme_frame_get_require_lifts(cenv);
       if (!SCHEME_NULLP(l)
            || !SCHEME_NULLP(rl)) {
          rl = scheme_append(rl, l);
          rl = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(cenv), 0, 0),
                     rl);
          form = scheme_datum_to_syntax(rl, scheme_false, scheme_false, 0, 0);
         prev_o = o;
       } else 
         break;
      }

      oi = scheme_optimize_info_create();
      oi->enforce_const = enforce_consts;
      if (!(comp_flags & COMP_CAN_INLINE))
        oi->inline_fuel = -1;
      o = scheme_optimize_expr(o, oi);

      rp = scheme_resolve_prefix(0, cenv->prefix, 1);
      ri = scheme_resolve_info_create(rp);
      ri->enforce_const = enforce_consts;
      scheme_enable_expression_resolve_lifts(ri);

      o = scheme_resolve_expr(o, ri);
      o = scheme_sfs(o, NULL, ri->max_let_depth);

      o = scheme_merge_expression_resolve_lifts(o, rp, ri);

      rp = scheme_remap_prefix(rp, ri);

      top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top);
      top->so.type = scheme_compilation_top_type;
      top->max_let_depth = ri->max_let_depth;
      top->code = o;
      top->prefix = rp;

      if (0) { /* <- change to 1 to check compilation result */
        scheme_validate_code(NULL, top->code,
                             top->max_let_depth,
                             top->prefix->num_toplevels,
                             top->prefix->num_stxes,
                             top->prefix->num_lifts,
                             0);
      }
    }

    if (SCHEME_PAIRP(tl_queue)) {
      /* This compile is interleaved with evaluation,
        and we need to eval now before compiling more. */
      _eval_compiled_multi_with_prompt((Scheme_Object *)top, genv);

      form = SCHEME_CAR(tl_queue);
      tl_queue = SCHEME_CDR(tl_queue);
    } else
      break;
  }

  return (void *)top;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 9992 of file eval.c.

{
  return scheme_param_config("compile-enforce-module-constants", 
                          scheme_make_integer(MZCONFIG_COMPILE_MODULE_CONSTS),
                          argc, argv,
                          -1, NULL, NULL, 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 9366 of file eval.c.

{
  if (!SCHEME_STXP(argv[0]))
    scheme_wrong_type("compile-syntax", "syntax", 0, argc, argv);

  return call_compile_handler(argv[0], 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 9375 of file eval.c.

Here is the caller graph for this function:

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

Here is the caller graph for this function:

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

Definition at line 9316 of file eval.c.

{
  return scheme_param_config("current-compile", 
                          scheme_make_integer(MZCONFIG_COMPILE_HANDLER),
                          argc, argv,
                          2, NULL, NULL, 0);
}

Here is the call graph for this function:

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

Here is the caller graph for this function:

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

Definition at line 9307 of file eval.c.

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

Here is the call graph for this function:

static Scheme_Object * datum_expand ( Scheme_Object form,
Scheme_Comp_Env env,
Scheme_Expand_Info erec,
int  drec 
) [static]

Definition at line 6141 of file eval.c.

{
  Scheme_Object *rest, *v;

  SCHEME_EXPAND_OBSERVE_PRIM_DATUM(erec[drec].observer);

  rest = SCHEME_STX_CDR(form);

  v = SCHEME_STX_VAL(rest);
  if (SCHEME_KEYWORDP(v)) {
    scheme_wrong_syntax("#%datum", NULL, rest, "keyword used as an expression");
    return NULL;
  }

  return scheme_datum_to_syntax(icons(quote_symbol,
                                      icons(rest, scheme_null)),
                                form,
                                scheme_sys_wraps(env), 
                                0, 2);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * datum_syntax ( Scheme_Object form,
Scheme_Comp_Env env,
Scheme_Compile_Info rec,
int  drec 
) [static]

Definition at line 6118 of file eval.c.

{
  Scheme_Object *c, *v;

  if (rec[drec].pre_unwrapped) {
    c = form;
    rec[drec].pre_unwrapped = 0;
  } else {
    c = SCHEME_STX_CDR(form);
    /* Need datum->syntax, in case c is a list: */
    c = scheme_datum_to_syntax(c, form, form, 0, 2);
  }

  v = SCHEME_STX_VAL(c);
  if (SCHEME_KEYWORDP(v)) {
    scheme_wrong_syntax("#%datum", NULL, c, "keyword used as an expression");
    return NULL;
  }

  return scheme_syntax_to_datum(c, 0, NULL);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 10008 of file eval.c.

{
  return scheme_param_config("compile-context-preservation-enabled", 
                          scheme_make_integer(MZCONFIG_DISALLOW_INLINE),
                          argc, argv,
                          -1, NULL, NULL, 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_apply_known_k ( void  ) [static]

Definition at line 7096 of file eval.c.

{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object **argv = (Scheme_Object **)p->ku.k.p2;

  p->ku.k.p2 = NULL;

  return _scheme_apply_known_prim_closure_multi((Scheme_Object *)p->ku.k.p1, 
                                          p->ku.k.i1, 
                                          argv);
}
static Scheme_Object* do_eval_k ( void  ) [static]

Definition at line 7189 of file eval.c.

{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object *obj = (Scheme_Object *)p->ku.k.p1;
  Scheme_Object **argv = (Scheme_Object **)p->ku.k.p2;

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

  return scheme_do_eval(obj, 
                     p->ku.k.i1, 
                     argv,
                     p->ku.k.i2);
}

Here is the caller graph for this function:

static Scheme_Object* do_eval_string_all ( const char *  str,
Scheme_Env env,
int  cont,
int  w_prompt 
) [static]

Definition at line 9853 of file eval.c.

{
  Scheme_Object *port, *expr, *result = scheme_void;

  port = scheme_make_byte_string_input_port(str);
  do {
    expr = scheme_read_syntax(port, scheme_false);

    if (cont == -2) {
      if (SCHEME_STXP(expr)) {
        Scheme_Object *m;
        m = SCHEME_STX_VAL(expr);
        if (SCHEME_PAIRP(m)) {
          m = scheme_make_pair(scheme_datum_to_syntax(module_symbol, 
                                                      SCHEME_CAR(m), 
                                                      scheme_sys_wraps(NULL), 
                                                      0, 0),
                               SCHEME_CDR(m));
          expr = scheme_datum_to_syntax(m, expr, expr, 0, 1);
        }
      }
    }

    if (SAME_OBJ(expr, scheme_eof))
      cont = 0;
    else if (cont < 0) {
      if (w_prompt)
        result = scheme_eval_with_prompt(expr, env);
      else
        result = scheme_eval(expr, env);
    } else {
      if (w_prompt)
        result = scheme_eval_multi_with_prompt(expr, env);
      else
        result = scheme_eval_multi(expr, env);

      if (cont == 2) {
        Scheme_Object **a, *_a[1], *arg[1], *printer;
        int cnt, i;

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

        for (i = 0; i < cnt; i++) {
          printer = scheme_get_param(scheme_current_config(), MZCONFIG_PRINT_HANDLER);
          arg[0] = a[i];
          scheme_apply(printer, 1, arg);
        }
      }
    }
  } while (cont > 0);

  return result;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_local_expand ( const char *  name,
int  for_stx,
int  catch_lifts,
int  for_expr,
int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 9504 of file eval.c.

{
  Scheme_Comp_Env *env, *orig_env, **ip;
  Scheme_Object *l, *local_mark, *renaming = NULL, *orig_l, *exp_expr = NULL;
  int cnt, pos, kind;
  int bad_sub_env = 0, bad_intdef = 0;
  Scheme_Object *observer, *catch_lifts_key = NULL;

  env = scheme_current_thread->current_local_env;
  orig_env = env;

  if (!env)
    scheme_raise_exn(MZEXN_FAIL_CONTRACT, "%s: not currently transforming", name);

  if (for_stx) {
    scheme_prepare_exp_env(env->genv);
    env = scheme_new_comp_env(env->genv->exp_env, env->insp, 0);
    scheme_propagate_require_lift_capture(orig_env, env);
  }
  scheme_prepare_compile_env(env->genv);

  if (for_expr)
    kind = 0; /* expression */
  else if (SAME_OBJ(argv[1], module_symbol))
    kind = SCHEME_MODULE_BEGIN_FRAME; /* name is backwards compared to symbol! */
  else if (SAME_OBJ(argv[1], module_begin_symbol))
    kind = SCHEME_MODULE_FRAME; /* name is backwards compared to symbol! */
  else if (SAME_OBJ(argv[1], top_level_symbol))
    kind = SCHEME_TOPLEVEL_FRAME;
  else if (SAME_OBJ(argv[1], expression_symbol))
    kind = 0;
  else if (scheme_proper_list_length(argv[1]) > 0)
    kind = SCHEME_INTDEF_FRAME;
  else  {
    scheme_wrong_type(name,
                    "'expression, 'module, 'module-begin, 'top-level, or non-empty list",
                    1, argc, argv);
    return NULL;
  }

  if (argc > 3) {
    if (SCHEME_TRUEP(argv[3])) {
      if (SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[3]))) {
       Scheme_Comp_Env *stx_env;
        update_intdef_chain(argv[3]);
       stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[3]))[0];
       renaming = SCHEME_PTR2_VAL(argv[3]);
       if (!scheme_is_sub_env(stx_env, env))
         bad_sub_env = 1;
       env = stx_env;
      } else if (SCHEME_PAIRP(argv[3])) {
        Scheme_Object *rl = argv[3];
        while (SCHEME_PAIRP(rl)) {
          if (SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(SCHEME_CAR(rl)))) {
            Scheme_Comp_Env *stx_env;
            stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(SCHEME_CAR(rl)))[0];
            if (!scheme_is_sub_env(stx_env, env))
              bad_sub_env = 1;
          } else
            break;
          rl = SCHEME_CDR(rl);
        }
        if (!SCHEME_NULLP(rl))
          bad_intdef = 1;
        else {
          rl = argv[3];
          update_intdef_chain(SCHEME_CAR(rl));
          env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(SCHEME_CAR(rl)))[0];
          if (SCHEME_NULLP(SCHEME_CDR(rl)))
            renaming = SCHEME_PTR2_VAL(SCHEME_CAR(rl));
          else {
            /* reverse and extract: */
            renaming = scheme_null;
            while (!SCHEME_NULLP(rl)) {
              renaming = cons(SCHEME_PTR2_VAL(SCHEME_CAR(rl)), renaming);
              rl = SCHEME_CDR(rl);
            }
          }
        }
      } else
        bad_intdef = 1;
    }

    if (argc > 4) {
      /* catch_lifts */
      catch_lifts_key = argv[4];
    }
  }

  if (catch_lifts && !catch_lifts_key)
    catch_lifts_key = scheme_generate_lifts_key();

  /* For each given stop-point identifier, shadow any potential syntax
     in the environment with an identity-expanding syntax expander. */

  (void)scheme_get_stop_expander();

  env = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME 
                                    | SCHEME_FOR_STOPS
                                    | kind), 
                                 env, NULL);
  if (catch_lifts < 0) {
    /* Note: extra frames can get inserted after env by pair_lifted */
    ip = MALLOC_N(Scheme_Comp_Env *, 1);
    *ip = env;
  } else
    ip = NULL;

  if (kind == SCHEME_INTDEF_FRAME)
    env->intdef_name = argv[1];
  env->in_modidx = scheme_current_thread->current_local_modidx;

  local_mark = scheme_current_thread->current_local_mark;
  
  if (for_expr) {
  } else if (SCHEME_TRUEP(argv[2])) {
    cnt = scheme_stx_proper_list_length(argv[2]);
    if (cnt > 0)
      scheme_add_local_syntax(cnt, env);
    pos = 0;

    for (l = argv[2]; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
      Scheme_Object *i;
    
      i = SCHEME_CAR(l);
      if (!SCHEME_STXP(i) || !SCHEME_STX_SYMBOLP(i)) {
        scheme_wrong_type(name, "#f or list of identifier syntax", 2, argc, argv);
        return NULL;
      }
    
      if (cnt > 0)
        scheme_set_local_syntax(pos++, i, stop_expander, env);
    }
    if (!SCHEME_NULLP(l)) {
      scheme_wrong_type(name, "#f or list of identifier syntax", 2, argc, argv);
      return NULL;
    }
  }

  /* Report errors related to 3rd argument, finally */
  if (argc > 3) {
    if (bad_intdef) {
      scheme_wrong_type(name, "internal-definition context, non-empty list of internal-definition contexts, or #f", 3, argc, argv);
      return NULL;
    } else if (bad_sub_env) {
      scheme_raise_exn(MZEXN_FAIL_CONTRACT, "%s: transforming context does not match internal-definition context",
                       name);
      return NULL;
    }
  }

  l = argv[0];

  if (!SCHEME_STXP(l))
    l = scheme_datum_to_syntax(l, scheme_false, scheme_false, 1, 0);

  orig_l = l;

  observer = scheme_get_expand_observe();
  if (observer) {
    SCHEME_EXPAND_OBSERVE_ENTER_LOCAL(observer, l);
    if (for_stx) {
      SCHEME_EXPAND_OBSERVE_PHASE_UP(observer);
    }
  }

  if (local_mark) {
    /* Since we have an expression from local context,
       we need to remove the temporary mark... */
    l = scheme_add_remove_mark(l, local_mark);
  }

  l = scheme_stx_activate_certs(l);

  if (renaming)
    l = add_intdef_renamings(l, renaming);

  SCHEME_EXPAND_OBSERVE_LOCAL_PRE(observer, l);

  if (SCHEME_FALSEP(argv[2])) {
    Scheme_Object *xl, *gval;
    Scheme_Compile_Expand_Info drec[1];

    if (catch_lifts_key) {
      Scheme_Object *data;
      data = (catch_lifts < 0) ? (Scheme_Object *)ip : scheme_sys_wraps(env);
      scheme_frame_captures_lifts(env, 
                                  (catch_lifts < 0) ? pair_lifted : scheme_make_lifted_defn, data,
                                  scheme_false, 
                                  catch_lifts_key, NULL,
                                  scheme_false);
    }

    memset(drec, 0, sizeof(drec));
    drec[0].value_name = scheme_false; /* or scheme_current_thread->current_local_name ? */
    drec[0].certs = scheme_current_thread->current_local_certs;
    drec[0].depth = -2;
    drec[0].observer = observer;
    {
      int comp_flags;
      comp_flags = get_comp_flags(NULL);
      drec[0].comp_flags = comp_flags;
    }

    xl = scheme_check_immediate_macro(l, env, drec, 0, 0, &gval, NULL, NULL);

    if (SAME_OBJ(xl, l)) {
      SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, xl);
      SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, orig_l);
      return orig_l;
    }

    if (catch_lifts_key) {
      if (catch_lifts < 0)
        xl = add_lifts_as_let(xl, scheme_frame_get_lifts(env), env, orig_l, 0);
      else
        xl = add_lifts_as_begin(xl, scheme_frame_get_lifts(env), env);
      SCHEME_EXPAND_OBSERVE_LIFT_LOOP(observer,xl);
    }

    l = xl;
  } else {
    /* Expand the expression. depth = -2 means expand all the way, but
       preserve letrec-syntax. */
    l = _expand(l, env, -2, 0, 0, catch_lifts_key, 0, scheme_current_thread->current_local_certs, 
                catch_lifts ? catch_lifts : 1);
  }

  SCHEME_EXPAND_OBSERVE_LOCAL_POST(observer, l);

  if (renaming)
    l = add_intdef_renamings(l, renaming);

  if (for_expr) {
    /* Package up expanded expr with the environment. */
    while (1) {
      if (orig_env->flags & SCHEME_FOR_STOPS)
        orig_env = orig_env->next;
      else if ((orig_env->flags & SCHEME_INTDEF_FRAME)
               && !orig_env->num_bindings)
        orig_env = orig_env->next;
      else
        break;
    }
    exp_expr = scheme_alloc_object();
    exp_expr->type = scheme_expanded_syntax_type;
    SCHEME_PTR1_VAL(exp_expr) = l;
    SCHEME_PTR2_VAL(exp_expr) = orig_env;
    exp_expr = scheme_datum_to_syntax(exp_expr, l, scheme_false, 0, 0);
    exp_expr = scheme_add_remove_mark(exp_expr, local_mark);
  }

  if (local_mark) {
    /* Put the temporary mark back: */
    l = scheme_add_remove_mark(l, local_mark);
  }

  if (for_expr) {
    Scheme_Object *a[2];
    SCHEME_EXPAND_OBSERVE_OPAQUE_EXPR(observer, exp_expr);
    SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, l);
    a[0] = l;
    a[1] = exp_expr;
    return scheme_values(2, a);
  } else
    SCHEME_EXPAND_OBSERVE_EXIT_LOCAL(observer, l);
    return l;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 10017 of file eval.c.

{
  if (argc == 1) {
    scheme_set_can_break(SCHEME_TRUEP(argv[0]));
    if (SCHEME_TRUEP(argv[0])) {
      if (scheme_current_thread->external_break && scheme_can_break(scheme_current_thread)) {
       scheme_thread_block(0.0);
       scheme_current_thread->ran_some = 1;
      }
    }
    return scheme_void;
  } else {
    return scheme_can_break(scheme_current_thread) ? scheme_true : scheme_false;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int eq_testable_constant ( Scheme_Object v) [static]

Definition at line 1385 of file eval.c.

{
  if (SCHEME_SYMBOLP(v)
      || SCHEME_FALSEP(v)
      || SAME_OBJ(v, scheme_true)
      || SCHEME_VOIDP(v))
    return 1;

  if (SCHEME_CHARP(v) && (SCHEME_CHAR_VAL(v) < 256))
    return 1;

  if (SCHEME_INTP(v) 
      && (SCHEME_INT_VAL(v) < (1 << 29))
      && (SCHEME_INT_VAL(v) > -(1 << 29)))
    return 1;

  return 0;
}

Here is the caller graph for this function:

static Scheme_Object** evacuate_runstack ( int  num_rands,
Scheme_Object **  rands,
Scheme_Object **  runstack 
) [static]

Definition at line 7224 of file eval.c.

{
  if (rands == runstack) {
    /* See [TC-SFS] in "schnapp.inc" */
    Scheme_Thread *p = scheme_current_thread;
    (void)scheme_tail_apply(scheme_void, num_rands, rands);
    rands = p->ku.apply.tail_rands;
    p->ku.apply.tail_rands = NULL;
    return rands;
  } else
    return rands;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 8875 of file eval.c.

{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object *v, **save_runstack;
  Scheme_Env *env;
  int isexpr, multi, use_jit, as_tail;

  v = (Scheme_Object *)p->ku.k.p1;
  env = (Scheme_Env *)p->ku.k.p2;
  p->ku.k.p1 = NULL;
  p->ku.k.p2 = NULL;
  multi = p->ku.k.i1;
  isexpr = p->ku.k.i2;
  as_tail = p->ku.k.i3;

  {
    Scheme_Object *b;
    b = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT);
    use_jit = SCHEME_TRUEP(b);
  }

  if (isexpr) {
    if (multi)
      v = _scheme_eval_linked_expr_multi_wp(v, p);
    else
      v = _scheme_eval_linked_expr_wp(v, p);
  } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_compilation_top_type)) {
    Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)v;
    Resolve_Prefix *rp;
    int depth;

    depth = top->max_let_depth + scheme_prefix_depth(top->prefix);
    if (!scheme_check_runstack(depth)) {
      p->ku.k.p1 = top;
      p->ku.k.p2 = env;
      p->ku.k.i1 = multi;
      p->ku.k.i2 = 0;
      return (Scheme_Object *)scheme_enlarge_runstack(depth, eval_k);
    }

    v = top->code;

    if (use_jit)
      v = scheme_jit_expr(v);
    else
      v = scheme_eval_clone(v);
    rp = scheme_prefix_eval_clone(top->prefix);

    save_runstack = scheme_push_prefix(env, top->prefix, NULL, NULL, 0, env->phase);

    if (as_tail) {
      /* Cons up a closure to capture the prefix */
      Scheme_Closure_Data *data;
      mzshort *map;
      int i, sz;

      sz = (save_runstack XFORM_OK_MINUS MZ_RUNSTACK);
      map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * sz);
      for (i = 0; i < sz; i++) {
        map[i] = i;
      }

      data = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
      data->iso.so.type = scheme_compiled_unclosed_procedure_type;
      data->num_params = 0;
      data->max_let_depth = top->max_let_depth + sz;
      data->closure_size = sz;
      data->closure_map = map;
      data->code = v;

      v = scheme_make_closure(p, (Scheme_Object *)data, 1);

      v = _scheme_tail_apply(v, 0, NULL);
    } else if (multi)
      v = _scheme_eval_linked_expr_multi_wp(v, p);
    else
      v = _scheme_eval_linked_expr_wp(v, p);

    scheme_pop_prefix(save_runstack);
  } else {
    v = scheme_void;
  }

  return (void *)v;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 9272 of file eval.c.

{
  if (!SCHEME_STXP(argv[0])) {
    scheme_wrong_type("eval-syntax", "syntax", 0, argc, argv);
    return NULL;
  }
  
  return sch_eval("eval-syntax", argc, argv);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int exec_dyn_wind_posts ( Scheme_Dynamic_Wind common,
Scheme_Cont c,
int  common_depth,
Scheme_Dynamic_Wind **  _common 
) [static]

Definition at line 7359 of file eval.c.

{
  int meta_depth;
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Dynamic_Wind *dw;
  int old_cac = scheme_continuation_application_count;

  *_common = common;

  for (dw = p->dw; 
       (common ? dw->depth != common->depth : dw != common);  /* not id, which may be duplicated */
       ) {
    meta_depth = p->next_meta;
    p->next_meta += dw->next_meta;
    p->dw = dw->prev;
    if (dw->post) {
      if (meta_depth > 0) {
        scheme_apply_dw_in_meta(dw, 1, meta_depth, c);
      } else {
        DW_PrePost_Proc post = dw->post;
        
        MZ_CONT_MARK_POS = dw->envss.cont_mark_pos;
        MZ_CONT_MARK_STACK = dw->envss.cont_mark_stack;
        post(dw->data);

        if (scheme_continuation_application_count != old_cac) {
          scheme_recheck_prompt_and_barrier(c);
        }
      }
      p = scheme_current_thread;
      /* p->dw might not match dw if the post thunk captures a
         continuation that is later restored in a different 
         meta continuation: */
      dw = p->dw;

      /* If any continuations were applied, then the set of dynamic
         winds may be different now than before. Re-compute the
         intersection. */
      if (scheme_continuation_application_count != old_cac) {
        old_cac = scheme_continuation_application_count;
        
        common = intersect_dw(p->dw, c->dw, c->prompt_tag, c->has_prompt_dw, &common_depth);
        *_common = common;
      }
    } else
      dw = dw->prev;
  }
  return common_depth;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 9382 of file eval.c.

{
  Scheme_Env *env;

  env = scheme_get_env(NULL);

  return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
                 -1, 1, 0, scheme_false, 0, NULL, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void* expand_k ( void  ) [static]

Definition at line 9087 of file eval.c.

{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object *obj, *certs, *observer, *catch_lifts_key;
  Scheme_Comp_Env *env, **ip;
  Scheme_Expand_Info erec1;
  int depth, rename, just_to_top, as_local, comp_flags;

  obj = (Scheme_Object *)p->ku.k.p1;
  env = (Scheme_Comp_Env *)p->ku.k.p2;
  depth = p->ku.k.i1;
  rename = p->ku.k.i2;
  just_to_top = p->ku.k.i3;
  catch_lifts_key = p->ku.k.p4;
  certs = (Scheme_Object *)p->ku.k.p3;
  as_local = p->ku.k.i4; /* < 0 => catch lifts to let */

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

  if (!SCHEME_STXP(obj))
    obj = scheme_datum_to_syntax(obj, scheme_false, scheme_false, 1, 0);

  if (rename > 0) {
    /* Renamings for requires: */
    obj = add_renames_unless_module(obj, env->genv);
  }

  observer = scheme_get_expand_observe();
  SCHEME_EXPAND_OBSERVE_START_EXPAND(observer);

  comp_flags = get_comp_flags(NULL);

  if (as_local < 0) {
    /* Insert a dummy frame so that `pair_lifted' can add more. */
    env = scheme_new_compilation_frame(0, 0, env, NULL);
    ip = MALLOC_N(Scheme_Comp_Env *, 1);
    *ip = env;
  }  else
    ip = NULL;

  scheme_prepare_compile_env(env->genv);

  /* Loop for lifted expressions: */
  while (1) {
    erec1.comp = 0;
    erec1.depth = depth;
    erec1.value_name = scheme_false;
    erec1.certs = certs;
    erec1.observer = observer;
    erec1.pre_unwrapped = 0;
    erec1.no_module_cert = 0;
    erec1.env_already = 0;
    erec1.comp_flags = comp_flags;

    if (catch_lifts_key) {
      Scheme_Object *data;
      data = (as_local < 0) ? (Scheme_Object *)ip : scheme_sys_wraps(env);
      scheme_frame_captures_lifts(env, 
                                  (as_local < 0) ? pair_lifted : scheme_make_lifted_defn, data, 
                                  scheme_false, catch_lifts_key, 
                                  (!as_local && catch_lifts_key) ? scheme_null : NULL,
                                  scheme_false);
    }

    if (just_to_top) {
      Scheme_Object *gval;
      obj = scheme_check_immediate_macro(obj, env, &erec1, 0, 0, &gval, NULL, NULL);
    } else
      obj = scheme_expand_expr(obj, env, &erec1, 0);

    if (catch_lifts_key) {
      Scheme_Object *l, *rl;
      l = scheme_frame_get_lifts(env);
      rl = scheme_frame_get_require_lifts(env);
      if (SCHEME_PAIRP(l)
          || SCHEME_PAIRP(rl)) {
        l = scheme_append(rl, l);
        if (as_local < 0)
          obj = add_lifts_as_let(obj, l, env, scheme_false, 0);
        else
          obj = add_lifts_as_begin(obj, l, env);
        SCHEME_EXPAND_OBSERVE_LIFT_LOOP(erec1.observer,obj);
       if ((depth >= 0) || as_local)
         break;
      } else {
        if (as_local > 0) {
          obj = add_lifts_as_begin(obj, scheme_null, env);
          SCHEME_EXPAND_OBSERVE_LIFT_LOOP(erec1.observer,obj);
        }
       break;
      }
    } else
      break;
  }

  if (rename && !just_to_top) {
    /* scheme_simplify_stx(obj, scheme_new_stx_simplify_cache()); */ /* too expensive */
  }

  return obj;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 9804 of file eval.c.

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 9392 of file eval.c.

{
  Scheme_Env *env;

  if (!SCHEME_STXP(argv[0]))
    scheme_wrong_type("expand-syntax", "syntax", 0, argc, argv);

  env = scheme_get_env(NULL);
  
  return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
                 -1, -1, 0, scheme_false, 0, NULL, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 9815 of file eval.c.

{
  Scheme_Env *env;

  if (!SCHEME_STXP(argv[0]))
    scheme_wrong_type("expand-syntax-once", "syntax", 0, argc, argv);
  
  env = scheme_get_env(NULL);

  return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
                 1, -1, 0, scheme_false, 0, NULL, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 9840 of file eval.c.

{
  Scheme_Env *env;

  if (!SCHEME_STXP(argv[0]))
    scheme_wrong_type("expand-syntax-to-top", "syntax", 0, argc, argv);
  
  env = scheme_get_env(NULL);

  return _expand(argv[0], scheme_new_expand_env(env, NULL, SCHEME_TOPLEVEL_FRAME), 
                 1, -1, 1, scheme_false, 0, NULL, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 9829 of file eval.c.

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 8998 of file eval.c.

{
  Scheme_Object *data = (Scheme_Object *)_data;
  return _eval(SCHEME_CAR(data), (Scheme_Env *)SCHEME_CDR(data), 0, 1, 0, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 8861 of file eval.c.

Here is the caller graph for this function:

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

Definition at line 8847 of file eval.c.

Here is the caller graph for this function:

static int foldable_body ( Scheme_Object f) [static]

Definition at line 1043 of file eval.c.

Here is the call graph for this function:

Here is the caller graph for this function:

static int get_comp_flags ( Scheme_Config config) [static]

Definition at line 4966 of file eval.c.

Here is the caller graph for this function:

Definition at line 165 of file eval.c.

static Scheme_Dynamic_Wind* intersect_dw ( Scheme_Dynamic_Wind a,
Scheme_Dynamic_Wind b,
Scheme_Object prompt_tag,
int  b_has_tag,
int _common_depth 
) [static]

Definition at line 7237 of file eval.c.

{
  int alen = 0, blen = 0;
  int a_has_tag = 0, a_prompt_delta = 0, b_prompt_delta = 0;
  Scheme_Dynamic_Wind *dw;

  for (dw = a; dw && (dw->prompt_tag != prompt_tag); dw = dw->prev) {
  }
  if (dw) {
    /* Cut off `a' below the prompt dw. */
    a_prompt_delta = dw->depth;
    a_has_tag = 1;
  }

  if (a_has_tag)
    a_prompt_delta += 1;
  if (b_has_tag)
    b_prompt_delta += 1;

  alen = (a ? a->depth + 1 : 0) - a_prompt_delta;
  blen = (b ? b->depth + 1 : 0) - b_prompt_delta;

  while (alen > blen) {
    --alen;
    a = a->prev;
  }
  if (!alen) {
    *_common_depth = b_prompt_delta - 1;
    return a;
  }
  while (blen > alen) {
    --blen;
    b = b->prev;
  }

  /* At this point, we have chains that are the same length. */
  while (blen) {
    if (SAME_OBJ(a->id ? a->id : (Scheme_Object *)a, 
                 b->id ? b->id : (Scheme_Object *)b))
      break;
    a = a->prev;
    b = b->prev;
    blen--;
  }

  *_common_depth = (b ? b->depth : -1);

  return a;
}

Here is the caller graph for this function:

static int is_current_inspector_call ( Scheme_Object a) [static]

Definition at line 686 of file eval.c.

{
  if (SAME_TYPE(SCHEME_TYPE(a), scheme_application_type)) {
    Scheme_App_Rec *app = (Scheme_App_Rec *)a;
    if (!app->num_args
        && SAME_OBJ(app->args[0], scheme_current_inspector_proc))
      return 1;
  }
  return 0;
}

Here is the caller graph for this function:

static int is_proc_spec_proc ( Scheme_Object p) [static]

Definition at line 697 of file eval.c.

{
  Scheme_Type vtype;
  
  if (SCHEME_PROCP(p)) {
    p = scheme_get_or_check_arity(p, -1);
    if (SCHEME_INTP(p)) {
      return (SCHEME_INT_VAL(p) >= 1);
    } else if (SCHEME_STRUCTP(p)
               && scheme_is_struct_instance(scheme_arity_at_least, p)) {
      p = ((Scheme_Structure *)p)->slots[0];
      if (SCHEME_INTP(p))
        return (SCHEME_INT_VAL(p) >= 1);
    }
    return 0;
  }

  vtype = SCHEME_TYPE(p);

  if (vtype == scheme_unclosed_procedure_type) {
    if (((Scheme_Closure_Data *)p)->num_params >= 1)
      return 1;
  }

  return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* link_module_variable ( Scheme_Object modidx,
Scheme_Object varname,
int  check_access,
Scheme_Object insp,
int  pos,
int  mod_phase,
Scheme_Env env,
Scheme_Object **  exprs,
int  which 
) [static]

Definition at line 1753 of file eval.c.

{
  Scheme_Object *modname;
  Scheme_Env *menv;
  int self = 0;

  /* If it's a name id, resolve the name. */
  modname = scheme_module_resolve(modidx, 1);

  if (env->module && SAME_OBJ(env->module->modname, modname)
      && (env->mod_phase == mod_phase)) {
    self = 1;
    menv = env;
  } else {
    menv = scheme_module_access(modname, env, mod_phase);
    
    if (!menv && env->phase) {
      /* The failure might be due a laziness in required-syntax
        execution. Force all laziness at the prior level 
        and try again. */
      scheme_module_force_lazy(env, 1);
      menv = scheme_module_access(modname, env, mod_phase);
    }
    
    if (!menv) {
      scheme_wrong_syntax("link", NULL, varname,
                       "namespace mismatch; reference (phase %d) to a module"
                          " %D that is not available (phase level %d); reference"
                       " appears in module: %D", 
                       env->phase,
                          modname,
                          mod_phase,
                          env->module ? env->module->modname : scheme_false);
      return NULL;
    }

    if (check_access && !SAME_OBJ(menv, env)) {
      varname = scheme_check_accessible_in_module(menv, insp, NULL, varname, NULL, NULL, 
                                                  insp, NULL, pos, 0, NULL, NULL, env, NULL);
    }
  }

  if (exprs) {
    if (self) {
      exprs[which] = varname;
    } else {
      if (mod_phase != 0)
        modname = scheme_make_pair(modname, scheme_make_integer(mod_phase));
      modname = scheme_make_pair(varname, modname);
      exprs[which] = modname;
    }
  }

  return (Scheme_Object *)scheme_global_bucket(varname, menv);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* link_toplevel ( Scheme_Object **  exprs,
int  which,
Scheme_Env env,
Scheme_Object src_modidx,
Scheme_Object dest_modidx 
) [static]

Definition at line 1814 of file eval.c.

{
  Scheme_Object *expr = exprs[which];

  if (SCHEME_FALSEP(expr)) {
    /* See scheme_make_environment_dummy */
    return (Scheme_Object *)scheme_global_bucket(begin_symbol, env);
  } else if (SCHEME_PAIRP(expr) || SCHEME_SYMBOLP(expr)) {
    /* Simplified module reference */
    Scheme_Object *modname, *varname;
    int mod_phase = 0;
    if (SCHEME_SYMBOLP(expr)) {
      varname = expr;
      modname = env->module->modname;
      mod_phase = env->mod_phase;
    } else {
      varname = SCHEME_CAR(expr);
      modname = SCHEME_CDR(expr);
      if (SCHEME_PAIRP(modname)) {
        mod_phase = SCHEME_INT_VAL(SCHEME_CDR(modname));
        modname = SCHEME_CAR(modname);
      }
    }
    return link_module_variable(modname,
                                varname,
                                0, NULL,
                                -1, mod_phase,
                                env, 
                                NULL, 0);
  } else if (SAME_TYPE(SCHEME_TYPE(expr), scheme_variable_type)) {
    Scheme_Bucket_With_Home *b = (Scheme_Bucket_With_Home *)expr;
    
    if (!env || !b->home->module)
      return (Scheme_Object *)b;
    else
      return link_module_variable(b->home->module->modname,
                              (Scheme_Object *)b->bucket.bucket.key,
                              1, b->home->module->insp,
                              -1, b->home->mod_phase,
                              env, 
                                  exprs, which);
  } else {
    Module_Variable *mv = (Module_Variable *)expr;
    
    return link_module_variable(scheme_modidx_shift(mv->modidx,
                                                    src_modidx,
                                                    dest_modidx),
                            mv->sym, 1, mv->insp,
                            mv->pos, mv->mod_phase,
                            env,
                                exprs, which);
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 10034 of file eval.c.

{
  Scheme_Comp_Env *env, *stx_env, *old_stx_env;
  Scheme_Object *l, *a, *rib, *expr, *certs, *names, *observer;
  int cnt = 0, pos;

  observer = scheme_get_expand_observe();
  SCHEME_EXPAND_OBSERVE_LOCAL_BIND(observer, argv[0]);

  names = argv[0];
  for (l = names; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
    a = SCHEME_CAR(l);
    if (!SCHEME_STX_SYMBOLP(a))
      break;
    cnt++;
  }
  if (!SCHEME_NULLP(l))
    scheme_wrong_type("syntax-local-bind-syntaxes", "list of syntax identifiers", 0, argc, argv);

  expr = argv[1];
  if (!SCHEME_FALSEP(expr) && !SCHEME_STXP(expr))
    scheme_wrong_type("syntax-local-bind-syntaxes", "syntax or #f", 1, argc, argv);
  if (!SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[2])))
    scheme_wrong_type("syntax-local-bind-syntaxes", "internal-definition context", 2, argc, argv);

  env = scheme_current_thread->current_local_env;
  if (!env)
    scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-bind-syntaxes: not currently transforming");

  update_intdef_chain(argv[2]);
  stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[2]))[0];
  rib = SCHEME_PTR2_VAL(argv[2]);

  if (*scheme_stx_get_rib_sealed(rib)) {
    scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-bind-syntaxes: given "
                   "internal-definition context has been sealed");
  }
  
  if (!scheme_is_sub_env(stx_env, env)) {
    scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-bind-syntaxes: transforming context does "
                   "not match given internal-definition context");
  }

  certs = scheme_current_thread->current_local_certs;
  old_stx_env = stx_env;
  stx_env = scheme_new_compilation_frame(0, SCHEME_FOR_INTDEF, stx_env, certs);
  scheme_add_local_syntax(cnt, stx_env);

  /* Mark names */
  names = scheme_named_map_1(NULL, scheme_add_remove_mark, names,
                          scheme_current_thread->current_local_mark);

  SCHEME_EXPAND_OBSERVE_RENAME_LIST(observer,names);

  /* Initialize environment slots to #f, which means "not syntax". */
  cnt = 0;
  for (l = names; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
    scheme_set_local_syntax(cnt++, SCHEME_CAR(l), scheme_false, stx_env);
  }
         
  stx_env->in_modidx = scheme_current_thread->current_local_modidx;
  if (!SCHEME_FALSEP(expr)) {
    Scheme_Compile_Expand_Info rec;
    rec.comp = 0;
    rec.depth = -1;
    rec.value_name = scheme_false;
    rec.certs = certs;
    rec.observer = observer;
    rec.pre_unwrapped = 0;
    rec.no_module_cert = 0;
    rec.env_already = 0;
    rec.comp_flags = get_comp_flags(NULL);
    
    /* Evaluate and bind syntaxes */
    expr = scheme_add_remove_mark(expr, scheme_current_thread->current_local_mark);

    scheme_prepare_exp_env(stx_env->genv);
    scheme_prepare_compile_env(stx_env->genv->exp_env);
    pos = 0;
    expr = scheme_add_rename_rib(expr, rib);
    scheme_bind_syntaxes("local syntax definition", names, expr,
                      stx_env->genv->exp_env, stx_env->insp, &rec, 0,
                      stx_env, stx_env,
                      &pos, rib);
  }

  /* Extend shared rib with renamings */
  scheme_add_env_renames(rib, stx_env, old_stx_env);

  /* Remember extended environment */
  ((void **)SCHEME_PTR1_VAL(argv[2]))[0] = stx_env;
  if (!((void **)SCHEME_PTR1_VAL(argv[2]))[2])
    ((void **)SCHEME_PTR1_VAL(argv[2]))[2] = stx_env;

  return scheme_void;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 9774 of file eval.c.

{
  return do_local_expand("local-expand", 0, 0, 0, argc, argv);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 9792 of file eval.c.

{
  return do_local_expand("local-expand/capture-lifts", 0, 1, 0, argc, argv);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 9780 of file eval.c.

{
  return do_local_expand("syntax-local-expand-expression", 0, 0, 1, argc, argv);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 9786 of file eval.c.

{
  return do_local_expand("local-transformer-expand", 1, -1, 0, argc, argv);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 9798 of file eval.c.

{
  return do_local_expand("local-transformer-expand/capture-lifts", 1, 1, 0, argc, argv);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 1659 of file eval.c.

{
  int i;

  /* Change (begin e1 ... (set!-for-let [x 10] (void)) e2 ...)
     to (begin e1 ... (set!-for-let [x 10] e2 ...)), which 
     avoids an unneeded recursive call in the evaluator */

  for (i = 0; i < s->count - 1; i++) {
    Scheme_Object *v;
    v = s->array[i];
    if (SAME_TYPE(SCHEME_TYPE(v), scheme_let_value_type)) {
      Scheme_Let_Value *lv = (Scheme_Let_Value *)v;
      if (scheme_omittable_expr(lv->body, 1, -1, 0, NULL)) {
       int esize = s->count - (i + 1);
       int nsize = i + 1;
       Scheme_Object *nv, *ev;

       if (nsize > 1) {
         Scheme_Sequence *naya;

         naya = malloc_sequence(nsize);
         naya->so.type = scheme_sequence_type;
         naya->count = nsize;
         nv = (Scheme_Object *)naya;

         for (i = 0; i < nsize; i++) {
           naya->array[i] = s->array[i];
         }
       } else
         nv = (Scheme_Object *)lv;

       if (esize > 1) {
         Scheme_Sequence *e;
         e = malloc_sequence(esize);
         e->so.type = scheme_sequence_type;
         e->count = esize;

         for (i = 0; i < esize; i++) {
           e->array[i] = s->array[i + nsize];
         }

         ev = (Scheme_Object *)look_for_letv_change(e);
       } else
         ev = s->array[nsize]; 

       lv->body = ev;

       return nv;
      }
    }
  }

  return (Scheme_Object *)s;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* lookup_constant_proc ( Optimize_Info info,
Scheme_Object rand 
) [static]

Definition at line 2572 of file eval.c.

{
  Scheme_Object *c = NULL;

  if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(rand)))
    c = rand;
  if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)) {
    int offset;
    Scheme_Object *expr;
    expr = scheme_optimize_reverse(info, SCHEME_LOCAL_POS(rand), 0);
    c = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(expr), &offset, NULL);
  }
  if (SAME_TYPE(SCHEME_TYPE(rand), scheme_compiled_toplevel_type)) {
    if (info->top_level_consts) {
      int pos;
      
      while (1) {
        pos = SCHEME_TOPLEVEL_POS(rand);
        c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos));
        if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_compiled_toplevel_type))
          rand = c;
        else
          break;
      }
    }
  }    

  if (c && SAME_TYPE(scheme_noninline_proc_type, SCHEME_TYPE(c))) {
    c = SCHEME_BOX_VAL(c);
  
    while (SAME_TYPE(SCHEME_TYPE(c), scheme_compiled_let_void_type)) {
      /* This must be (let ([x <proc>]) <proc>); see scheme_is_statically_proc() */
      Scheme_Let_Header *lh = (Scheme_Let_Header *)c;
      Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body;
      c = lv->body;
    }
  }

  if (c 
      && (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(c))
          || (SAME_TYPE(scheme_compiled_syntax_type, SCHEME_TYPE(c))
              && (SCHEME_PINT_VAL(c) == CASE_LAMBDA_EXPD))))
    return c;

  return NULL;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Prompt* lookup_cont_prompt ( Scheme_Cont c,
Scheme_Meta_Continuation **  _prompt_mc,
MZ_MARK_POS_TYPE _prompt_pos,
const char *  msg 
) [static]

Definition at line 7288 of file eval.c.

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* make_application ( Scheme_Object v) [static]

Definition at line 1054 of file eval.c.

{
  Scheme_Object *o;
  int i, nv;
  volatile int n;

  o = v;
  n = 0;
  nv = 0;
  while (!SCHEME_NULLP(o)) {
    Scheme_Type type;
    
    n++;
    type = SCHEME_TYPE(SCHEME_CAR(o));
    if (type < _scheme_compiled_values_types_)
      nv = 1;
    o = SCHEME_CDR(o);
  }

  if (!nv) {
    /* They're all values. Applying folding prim or closure? */
    Scheme_Object *f;

    f = SCHEME_CAR(v);

    if ((SCHEME_PRIMP(f) && ((((Scheme_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK)
                             == SCHEME_PRIM_OPT_FOLDING))
       || (SCHEME_CLSD_PRIMP(f) 
           && ((((Scheme_Closed_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK)
                == SCHEME_PRIM_OPT_FOLDING))
       || (SAME_TYPE(SCHEME_TYPE(f), scheme_closure_type)
           && (foldable_body(f)))) {
      f = try_apply(f, SCHEME_CDR(v), scheme_false);
      
      if (f)
       return f;
    }
  }

  if (n == 2) {
    Scheme_App2_Rec *app;

    app = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
    app->iso.so.type = scheme_application2_type;

    app->rator = SCHEME_CAR(v);
    v = SCHEME_CDR(v);
    app->rand = SCHEME_CAR(v);
    
    return (Scheme_Object *)app;
  } else if (n == 3) {
    Scheme_App3_Rec *app;

    app = MALLOC_ONE_TAGGED(Scheme_App3_Rec);
    app->iso.so.type = scheme_application3_type;

    app->rator = SCHEME_CAR(v);
    v = SCHEME_CDR(v);
    app->rand1 = SCHEME_CAR(v);
    v = SCHEME_CDR(v);
    app->rand2 = SCHEME_CAR(v);

    return (Scheme_Object *)app;
  } else {
    Scheme_App_Rec *app;

    app = scheme_malloc_application(n);
    
    for (i = 0; i < n; i++, v = SCHEME_CDR(v)) {
      app->args[i] = SCHEME_CAR(v);
    }

    return (Scheme_Object *)app;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static struct Validate_Clearing* make_clearing_stack ( ) [static, read]

Definition at line 10301 of file eval.c.

{
  Validate_Clearing *vc;
  vc = MALLOC_ONE_RT(Validate_Clearing);
  SET_REQUIRED_TAG(vc->type = scheme_rt_validate_clearing);
  vc->self_pos = -1;
  return vc;
}

Here is the caller graph for this function:

static void make_tail_buffer_safe ( ) [static]

Definition at line 7214 of file eval.c.

Here is the caller graph for this function:

static Scheme_Sequence* malloc_sequence ( int  count) [static]

Definition at line 1552 of file eval.c.

{
  return (Scheme_Sequence *)scheme_malloc_tagged(sizeof(Scheme_Sequence)
                                           + (count - 1) 
                                           * sizeof(Scheme_Object *));
}

Here is the caller graph for this function:

static MZ_MARK_STACK_TYPE new_segment_set_mark ( long  segpos,
long  pos,
Scheme_Object key,
Scheme_Object val 
) [static]

Definition at line 6965 of file eval.c.

{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Cont_Mark *cm = NULL;
  int c = p->cont_mark_seg_count;
  Scheme_Cont_Mark **segs, *seg;
  long findpos;
  
  /* 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 *, c + 1);
  seg = scheme_malloc_allow_interior(sizeof(Scheme_Cont_Mark) * SCHEME_MARK_SEGMENT_SIZE);
  segs[c] = seg;
  
  memcpy(segs, p->cont_mark_stack_segments, c * sizeof(Scheme_Cont_Mark *));
  
  p->cont_mark_seg_count++;
  p->cont_mark_stack_segments = segs;

  seg = p->cont_mark_stack_segments[segpos];
  cm = seg + pos;
  findpos = MZ_CONT_MARK_STACK;
  MZ_CONT_MARK_STACK++;

  cm->key = key;
  cm->val = val;
  cm->pos = MZ_CONT_MARK_POS; /* always odd */
  cm->cache = NULL;

  return findpos;
}

Here is the caller graph for this function:

static void noclear_stack_push ( struct Validate_Clearing vc,
int  pos 
) [static]

Definition at line 10331 of file eval.c.

{
  if (vc->ncstackpos + 1 > vc->ncstacksize) {
    int *a, sz;
    sz = (vc->ncstacksize ? 2 * vc->ncstacksize : 32);
    a = (int *)scheme_malloc_atomic(sizeof(int) * sz);
    memcpy(a, vc->ncstack, vc->ncstacksize * sizeof(int));
    vc->ncstacksize = sz;
    vc->ncstack = a;
  }
  vc->ncstack[vc->ncstackpos] = pos;
  vc->ncstackpos += 1;
}

Here is the caller graph for this function:

static void note_match ( int  actual,
int  expected,
Optimize_Info warn_info 
) [static]

Definition at line 724 of file eval.c.

{
  if (!warn_info || (expected == -1))
    return;

  if (actual != expected) {
    scheme_log(NULL,
               SCHEME_LOG_WARNING,
               0,
               "warning%s: optimizer detects %d values produced when %d expected",
               scheme_optimize_context_to_string(warn_info->context),
               actual, expected);
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* optimize_application ( Scheme_Object o,
Optimize_Info info 
) [static]

Definition at line 2514 of file eval.c.

{
  Scheme_Object *le;
  Scheme_App_Rec *app;
  int i, n, all_vals = 1, rator_flags = 0;

  app = (Scheme_App_Rec *)o;

  le = check_app_let_rator(o, app->args[0], info, app->num_args);
  if (le) return le;

  n = app->num_args + 1;

  for (i = 0; i < n; i++) {
    if (!i) {
      le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags);
      if (le)
       return le;
    }
     
    le = scheme_optimize_expr(app->args[i], info);
    app->args[i] = le;

    if (!i) {
      if (SAME_TYPE(SCHEME_TYPE(app->args[0]),scheme_compiled_unclosed_procedure_type)) {
        /* Found "((lambda" after optimizing; try again */
        le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags);
        if (le)
          return le;
      }
    }


    if (i && (SCHEME_TYPE(le) < _scheme_compiled_values_types_))
      all_vals = 0;
  }

  if (all_vals) {
    le = try_optimize_fold(app->args[0], (Scheme_Object *)app, info);
    if (le)
      return le;
  }

  info->size += 1;

  info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
  info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT);
  if (rator_flags & CLOS_RESULT_TENTATIVE) {
    info->preserves_marks = -info->preserves_marks;
    info->single_result = -info->single_result;
  }

  if (!app->num_args && SAME_OBJ(app->args[0], scheme_list_proc))
    return scheme_null;

  return (Scheme_Object *)app;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* optimize_application2 ( Scheme_Object o,
Optimize_Info info 
) [static]

Definition at line 2619 of file eval.c.

{
  Scheme_App2_Rec *app;
  Scheme_Object *le;
  int rator_flags = 0;

  app = (Scheme_App2_Rec *)o;

  le = check_app_let_rator(o, app->rator, info, 1);
  if (le) return le;

  le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags);
  if (le)
    return le;

  le = scheme_optimize_expr(app->rator, info);
  app->rator = le;

  if (SAME_TYPE(SCHEME_TYPE(app->rator),scheme_compiled_unclosed_procedure_type)) {
    /* Found "((lambda" after optimizing; try again */
    le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags);
    if (le)
      return le;
  }

  le = scheme_optimize_expr(app->rand, info);
  app->rand = le;
  if (SCHEME_TYPE(le) > _scheme_compiled_values_types_) {
    le = try_optimize_fold(app->rator, (Scheme_Object *)app, info);
    if (le)
      return le;
  }

  if (SAME_OBJ(scheme_procedure_p_proc, app->rator)) {
    if (lookup_constant_proc(info, app->rand)) {
      info->preserves_marks = 1;
      info->single_result = 1;
      return scheme_true;
    }
  }

  if ((SAME_OBJ(scheme_values_func, app->rator)
       || SAME_OBJ(scheme_list_star_proc, app->rator))
      && scheme_omittable_expr(app->rand, 1, -1, 0, info)) {
    info->preserves_marks = 1;
    info->single_result = 1;
    return app->rand;
  }

  info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
  info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT);
  if (rator_flags & CLOS_RESULT_TENTATIVE) {
    info->preserves_marks = -info->preserves_marks;
    info->single_result = -info->single_result;
  }

  return (Scheme_Object *)app;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* optimize_application3 ( Scheme_Object o,
Optimize_Info info 
) [static]

Definition at line 2678 of file eval.c.

{
  Scheme_App3_Rec *app;
  Scheme_Object *le;
  int all_vals = 1;
  int rator_flags = 0;

  app = (Scheme_App3_Rec *)o;

  le = check_app_let_rator(o, app->rator, info, 2);
  if (le) return le;

  le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags);
  if (le)
    return le;

  le = scheme_optimize_expr(app->rator, info);
  app->rator = le;

  if (SAME_TYPE(SCHEME_TYPE(app->rator),scheme_compiled_unclosed_procedure_type)) {
    /* Found "((lambda" after optimizing; try again */
    le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags);
    if (le)
      return le;
  }

  /* 1st arg */

  le = scheme_optimize_expr(app->rand1, info);
  app->rand1 = le;

  if (SCHEME_TYPE(le) < _scheme_compiled_values_types_)
    all_vals = 0;

  /* 2nd arg */

  le = scheme_optimize_expr(app->rand2, info);
  app->rand2 = le;

  if (SCHEME_TYPE(le) < _scheme_compiled_values_types_)
    all_vals = 0;

  /* Fold or continue */

  if (all_vals) {
    le = try_optimize_fold(app->rator, (Scheme_Object *)app, info);
    if (le)
      return le;
  }

  info->size += 1;

  /* Check for (call-with-values (lambda () M) N): */
  if (SAME_OBJ(app->rator, scheme_call_with_values_proc)) {
    if (SAME_TYPE(SCHEME_TYPE(app->rand1), scheme_compiled_unclosed_procedure_type)) {
      Scheme_Closure_Data *data = (Scheme_Closure_Data *)app->rand1;

      if (!data->num_params) {
        /* Convert to apply-values form: */ 
        return scheme_optimize_apply_values(app->rand2, data->code, info,
                                            ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SINGLE_RESULT)
                                             ? ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)
                                                ? -1
                                                : 1)
                                             : 0));
      }
    }
  }

  if (SAME_OBJ(scheme_procedure_arity_includes_proc, app->rator)) {
    if (SCHEME_INTP(app->rand2)) {
      Scheme_Object *proc;
      Scheme_Case_Lambda *cl;
      int i, cnt;

      proc = lookup_constant_proc(info, app->rand1);      
      if (proc) {
        if (SAME_TYPE(SCHEME_TYPE(proc), scheme_compiled_unclosed_procedure_type)) {
          cnt = 1;
          cl = NULL;
        } else {
          cl = (Scheme_Case_Lambda *)SCHEME_IPTR_VAL(proc);
          cnt = cl->count;
        }

        for (i = 0; i < cnt; i++) {
          if (cl) proc = cl->array[i];
          
          if (SAME_TYPE(SCHEME_TYPE(proc), scheme_compiled_unclosed_procedure_type)) {
            Scheme_Closure_Data *data = (Scheme_Closure_Data *)proc;
            int n = SCHEME_INT_VAL(app->rand2), ok;
            if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) {
              ok = ((data->num_params - 1) <= n);
            } else {
              ok = (data->num_params == n);
            }
            if (ok) {
              info->preserves_marks = 1;
              info->single_result = 1;
              return scheme_true;
            }
          } else {
            break;
          }
        }

        if (i == cnt) {
          info->preserves_marks = 1;
          info->single_result = 1;
          return scheme_false;
        }
      }
    }
  }


  info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
  info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT);
  if (rator_flags & CLOS_RESULT_TENTATIVE) {
    info->preserves_marks = -info->preserves_marks;
    info->single_result = -info->single_result;
  }

  return (Scheme_Object *)app;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* optimize_branch ( Scheme_Object o,
Optimize_Info info 
) [static]

Definition at line 2959 of file eval.c.

{
  Scheme_Branch_Rec *b;
  Scheme_Object *t, *tb, *fb;
  int preserves_marks = 1, single_result = 1;

  b = (Scheme_Branch_Rec *)o;

  t = b->test;
  tb = b->tbranch;
  fb = b->fbranch;
  
  /* Try optimize: (if (not x) y z) => (if x z y) */
  while (1) {
    if (SAME_TYPE(SCHEME_TYPE(t), scheme_application2_type)) {
      Scheme_App2_Rec *app;
      
      app = (Scheme_App2_Rec *)t;
      if (SAME_PTR(scheme_not_prim, app->rator)) {
       t = tb;
       tb = fb;
       fb = t;
       t = app->rand;
      } else
       break;
    } else
      break;
  }

  if (SAME_TYPE(SCHEME_TYPE(t), scheme_compiled_let_void_type)) {
    /* Maybe convert: (let ([x M]) (if x x N)) => (if M #t N) */
    t = scheme_optimize_lets_for_test(t, info);
  } else
    t = scheme_optimize_expr(t, info);

  /* For test position, convert (if <expr> #t #f) to <expr> */
  if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type)
      && SAME_OBJ(((Scheme_Branch_Rec *)t)->tbranch, scheme_true)
      && SAME_OBJ(((Scheme_Branch_Rec *)t)->fbranch, scheme_false))
    t = ((Scheme_Branch_Rec *)t)->test;

  if (SCHEME_TYPE(t) > _scheme_compiled_values_types_) {
    if (SCHEME_FALSEP(t))
      return scheme_optimize_expr(fb, info);
    else
      return scheme_optimize_expr(tb, info);
  } else if (SAME_TYPE(SCHEME_TYPE(t), scheme_compiled_quote_syntax_type)
             || SAME_TYPE(SCHEME_TYPE(t), scheme_compiled_unclosed_procedure_type))
    return scheme_optimize_expr(tb, info);

  tb = scheme_optimize_expr(tb, info);

  if (!info->preserves_marks) 
    preserves_marks = 0;
  else if (info->preserves_marks < 0)
    preserves_marks = -1;
  if (!info->single_result) 
    single_result = 0;
  else if (info->single_result < 0)
    single_result = -1;

  fb = scheme_optimize_expr(fb, info);

  if (!info->preserves_marks) 
    preserves_marks = 0;
  else if (preserves_marks && (info->preserves_marks < 0))
    preserves_marks = -1;
  if (!info->single_result) 
    single_result = 0;
  else if (single_result && (info->single_result < 0))
    single_result = -1;

  info->preserves_marks = preserves_marks;
  info->single_result = single_result;

  /* Try optimize: (if x x #f) => x */
  if (SAME_TYPE(SCHEME_TYPE(t), scheme_local_type)
      && SAME_TYPE(SCHEME_TYPE(tb),