Back to index

plt-scheme  4.2.1
Defines | Functions | Variables
syntax.c File Reference
#include "schpriv.h"
#include "schmach.h"
#include "schexpobs.h"

Go to the source code of this file.

Defines

#define cons(a, b)   scheme_make_pair(a,b)
#define max(a, b)   (((a) > (b)) ? (a) : (b))
#define MAX_PROC_INLINE_SIZE   256

Functions

static Scheme_Objectlambda_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectlambda_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectdefine_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectdefine_values_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectref_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectref_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectquote_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectquote_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectif_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectif_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectset_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectset_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectcase_lambda_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectcase_lambda_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectlet_values_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectlet_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectlet_star_values_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectlet_star_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectletrec_values_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectletrec_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectbegin_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectbegin_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectbegin0_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectbegin0_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectexpression_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectexpression_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectunquote_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectunquote_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectwith_cont_mark_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectwith_cont_mark_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectquote_syntax_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectquote_syntax_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectdefine_syntaxes_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectdefine_syntaxes_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectdefine_for_syntaxes_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectdefine_for_syntaxes_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectletrec_syntaxes_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectletrec_syntaxes_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectdefine_values_execute (Scheme_Object *data)
static Scheme_Objectref_execute (Scheme_Object *data)
static Scheme_Objectset_execute (Scheme_Object *data)
static Scheme_Objectdefine_syntaxes_execute (Scheme_Object *expr)
static Scheme_Objectdefine_for_syntaxes_execute (Scheme_Object *expr)
static Scheme_Objectcase_lambda_execute (Scheme_Object *expr)
static Scheme_Objectbegin0_execute (Scheme_Object *data)
static Scheme_Objectapply_values_execute (Scheme_Object *data)
static Scheme_Objectsplice_execute (Scheme_Object *data)
static Scheme_Objectbangboxenv_execute (Scheme_Object *data)
static Scheme_Objectdefine_values_optimize (Scheme_Object *data, Optimize_Info *info)
static Scheme_Objectref_optimize (Scheme_Object *data, Optimize_Info *info)
static Scheme_Objectset_optimize (Scheme_Object *data, Optimize_Info *info)
static Scheme_Objectdefine_syntaxes_optimize (Scheme_Object *expr, Optimize_Info *info)
static Scheme_Objectdefine_for_syntaxes_optimize (Scheme_Object *expr, Optimize_Info *info)
static Scheme_Objectcase_lambda_optimize (Scheme_Object *expr, Optimize_Info *info)
static Scheme_Objectbegin0_optimize (Scheme_Object *data, Optimize_Info *info)
static Scheme_Objectapply_values_optimize (Scheme_Object *data, Optimize_Info *info)
static Scheme_Objectsplice_optimize (Scheme_Object *data, Optimize_Info *info)
static Scheme_Objectbegin0_clone (int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth)
static Scheme_Objectset_clone (int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth)
static Scheme_Objectapply_values_clone (int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth)
static Scheme_Objectsplice_clone (int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth)
static Scheme_Objectbegin0_shift (Scheme_Object *data, int delta, int after_depth)
static Scheme_Objectset_shift (Scheme_Object *data, int delta, int after_depth)
static Scheme_Objectref_shift (Scheme_Object *data, int delta, int after_depth)
static Scheme_Objectcase_lambda_shift (Scheme_Object *data, int delta, int after_depth)
static Scheme_Objectapply_values_shift (Scheme_Object *data, int delta, int after_depth)
static Scheme_Objectsplice_shift (Scheme_Object *data, int delta, int after_depth)
static Scheme_Objectdefine_values_resolve (Scheme_Object *data, Resolve_Info *info)
static Scheme_Objectref_resolve (Scheme_Object *data, Resolve_Info *info)
static Scheme_Objectset_resolve (Scheme_Object *data, Resolve_Info *info)
static Scheme_Objectdefine_syntaxes_resolve (Scheme_Object *expr, Resolve_Info *info)
static Scheme_Objectdefine_for_syntaxes_resolve (Scheme_Object *expr, Resolve_Info *info)
static Scheme_Objectcase_lambda_resolve (Scheme_Object *expr, Resolve_Info *info)
static Scheme_Objectbegin0_resolve (Scheme_Object *data, Resolve_Info *info)
static Scheme_Objectapply_values_resolve (Scheme_Object *data, Resolve_Info *info)
static Scheme_Objectsplice_resolve (Scheme_Object *data, Resolve_Info *info)
static Scheme_Objectdefine_values_sfs (Scheme_Object *data, SFS_Info *info)
static Scheme_Objectref_sfs (Scheme_Object *data, SFS_Info *info)
static Scheme_Objectset_sfs (Scheme_Object *data, SFS_Info *info)
static Scheme_Objectdefine_syntaxes_sfs (Scheme_Object *expr, SFS_Info *info)
static Scheme_Objectdefine_for_syntaxes_sfs (Scheme_Object *expr, SFS_Info *info)
static Scheme_Objectcase_lambda_sfs (Scheme_Object *expr, SFS_Info *info)
static Scheme_Objectbegin0_sfs (Scheme_Object *data, SFS_Info *info)
static Scheme_Objectapply_values_sfs (Scheme_Object *data, SFS_Info *info)
static Scheme_Objectsplice_sfs (Scheme_Object *data, SFS_Info *info)
static Scheme_Objectbangboxenv_sfs (Scheme_Object *data, SFS_Info *info)
static void define_values_validate (Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, int num_toplevels, int num_stxes, int num_lifts, struct Validate_Clearing *vc, int tailpos)
static void ref_validate (Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, int num_toplevels, int num_stxes, int num_lifts, struct Validate_Clearing *vc, int tailpos)
static void set_validate (Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, int num_toplevels, int num_stxes, int num_lifts, struct Validate_Clearing *vc, int tailpos)
static void define_syntaxes_validate (Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, int num_toplevels, int num_stxes, int num_lifts, struct Validate_Clearing *vc, int tailpos)
static void define_for_syntaxes_validate (Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, int num_toplevels, int num_stxes, int num_lifts, struct Validate_Clearing *vc, int tailpos)
static void case_lambda_validate (Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, int num_toplevels, int num_stxes, int num_lifts, struct Validate_Clearing *vc, int tailpos)
static void begin0_validate (Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, int num_toplevels, int num_stxes, int num_lifts, struct Validate_Clearing *vc, int tailpos)
static void apply_values_validate (Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, int num_toplevels, int num_stxes, int num_lifts, struct Validate_Clearing *vc, int tailpos)
static void splice_validate (Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, int num_toplevels, int num_stxes, int num_lifts, struct Validate_Clearing *vc, int tailpos)
static void bangboxenv_validate (Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, int num_toplevels, int num_stxes, int num_lifts, struct Validate_Clearing *vc, int tailpos)
static Scheme_Objectdefine_values_jit (Scheme_Object *data)
static Scheme_Objectref_jit (Scheme_Object *data)
static Scheme_Objectset_jit (Scheme_Object *data)
static Scheme_Objectdefine_syntaxes_jit (Scheme_Object *expr)
static Scheme_Objectdefine_for_syntaxes_jit (Scheme_Object *expr)
static Scheme_Objectcase_lambda_jit (Scheme_Object *expr)
static Scheme_Objectbegin0_jit (Scheme_Object *data)
static Scheme_Objectapply_values_jit (Scheme_Object *data)
static Scheme_Objectsplice_jit (Scheme_Object *data)
static Scheme_Objectbangboxenv_jit (Scheme_Object *data)
static Scheme_Objectexpand_lam (int argc, Scheme_Object **argv)
static Scheme_Objectwrite_let_value (Scheme_Object *obj)
static Scheme_Objectread_let_value (Scheme_Object *obj)
static Scheme_Objectwrite_let_void (Scheme_Object *obj)
static Scheme_Objectread_let_void (Scheme_Object *obj)
static Scheme_Objectwrite_letrec (Scheme_Object *obj)
static Scheme_Objectread_letrec (Scheme_Object *obj)
static Scheme_Objectwrite_let_one (Scheme_Object *obj)
static Scheme_Objectread_let_one (Scheme_Object *obj)
static Scheme_Objectwrite_top (Scheme_Object *obj)
static Scheme_Objectread_top (Scheme_Object *obj)
static Scheme_Objectwrite_case_lambda (Scheme_Object *obj)
static Scheme_Objectread_case_lambda (Scheme_Object *obj)
void scheme_init_syntax (Scheme_Env *env)
Scheme_Objectscheme_make_compiled_syntax (Scheme_Syntax *proc, Scheme_Syntax_Expander *eproc)
static int check_form (Scheme_Object *form, Scheme_Object *base_form)
static void bad_form (Scheme_Object *form, int l)
Scheme_Objectscheme_check_name_property (Scheme_Object *code, Scheme_Object *current_val)
static void lambda_check (Scheme_Object *form)
static void lambda_check_args (Scheme_Object *args, Scheme_Object *form, Scheme_Comp_Env *env)
void scheme_set_global_bucket (char *who, Scheme_Bucket *b, Scheme_Object *val, int set_undef)
void scheme_install_macro (Scheme_Bucket *b, Scheme_Object *v)
static Scheme_Objectdefine_execute_with_dynamic_state (Scheme_Object *vec, int delta, int defmacro, Resolve_Prefix *rp, Scheme_Env *dm_env, Scheme_Dynamic_State *dyn_state)
static Scheme_Objectclone_vector (Scheme_Object *data, int skip)
void scheme_resolve_lift_definition (Resolve_Info *info, Scheme_Object *var, Scheme_Object *rhs)
void scheme_define_parse (Scheme_Object *form, Scheme_Object **var, Scheme_Object **_stk_val, int defmacro, Scheme_Comp_Env *env, int no_toplevel_check)
static Scheme_Objectdefn_targets_syntax (Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static void check_if_len (Scheme_Object *form, int len)
Scheme_Objectscheme_unclose_case_lambda (Scheme_Object *expr, int mode)
static void case_lambda_check_line (Scheme_Object *line, Scheme_Object *form, Scheme_Comp_Env *env)
static int is_liftable_prim (Scheme_Object *v)
static int is_liftable (Scheme_Object *o, int bind_count, int fuel, int as_rator)
int scheme_compiled_propagate_ok (Scheme_Object *value, Optimize_Info *info)
int scheme_is_statically_proc (Scheme_Object *value, Optimize_Info *info)
Scheme_Objectscheme_make_noninline_proc (Scheme_Object *e)
static int is_values_apply (Scheme_Object *e)
static void unpack_values_application (Scheme_Object *e, Scheme_Compiled_Let_Value *naya)
static Scheme_Objectmake_clones (Scheme_Compiled_Let_Value *retry_start, Scheme_Compiled_Let_Value *pre_body, Optimize_Info *body_info)
static int set_code_flags (Scheme_Compiled_Let_Value *retry_start, Scheme_Compiled_Let_Value *pre_body, Scheme_Object *clones, int set_flags, int mask_flags, int just_tentative)
static int expr_size (Scheme_Object *o)
static int might_invoke_call_cc (Scheme_Object *value)
static int worth_lifting (Scheme_Object *v)
Scheme_Objectscheme_optimize_lets (Scheme_Object *form, Optimize_Info *info, int for_inline)
Scheme_Objectscheme_optimize_lets_for_test (Scheme_Object *form, Optimize_Info *info)
static int is_lifted_reference (Scheme_Object *v)
static int is_closed_reference (Scheme_Object *v)
static Scheme_Objectscheme_resolve_generate_stub_closure ()
static void shift_lift (Scheme_Object *lifted, int frame_size, int lifted_frame_size)
static int get_convert_arg_count (Scheme_Object *lift)
Scheme_Objectscheme_resolve_lets (Scheme_Object *form, Resolve_Info *info)
static Scheme_Objectgen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, int star, int recursive, int multi, Scheme_Compile_Info *rec, int drec, Scheme_Comp_Env *frame_already)
static Scheme_Objectdo_let_expand (Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info *erec, int drec, const char *formname, int letrec, int multi, int letstar, Scheme_Comp_Env *env_already)
Scheme_Objectscheme_compile_sequence (Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
Scheme_Objectscheme_compiled_void ()
static Scheme_Objectdo_begin_syntax (char *name, Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, int zero)
static Scheme_Objectdo_begin_expand (char *name, Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec, int zero)
static Scheme_Objectsplice_one_expr (void *expr, int argc, Scheme_Object **argv)
static Scheme_Objectcheck_single (Scheme_Object *form, Scheme_Comp_Env *top_only)
static Scheme_Objectsingle_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, int top_only)
static Scheme_Objectsingle_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec, int top_only, int simplify)
static Scheme_Objectdo_define_syntaxes_execute (Scheme_Object *expr, Scheme_Env *dm_env, int for_stx)
static voiddefine_syntaxes_execute_k (void)
static Scheme_Objectdo_define_syntaxes_jit (Scheme_Object *expr, int jit)
Scheme_Objectscheme_syntaxes_eval_clone (Scheme_Object *expr)
static void do_define_syntaxes_validate (Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, int depth, int letlimit, int delta, int num_toplevels, int num_stxes, int num_lifts, int for_stx)
static Scheme_Objectdo_define_syntaxes_optimize (Scheme_Object *data, Optimize_Info *info, int for_stx)
static Scheme_Objectdo_define_syntaxes_resolve (Scheme_Object *data, Resolve_Info *info, int for_stx)
static Scheme_Objectdo_define_syntaxes_sfs (Scheme_Object *data, SFS_Info *info)
static Scheme_Objectstx_val (Scheme_Object *name, Scheme_Object *_env)
static Scheme_Objectdo_define_syntaxes_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, int for_stx)
Scheme_Objectscheme_make_environment_dummy (Scheme_Comp_Env *env)
Scheme_Envscheme_environment_from_dummy (Scheme_Object *dummy)
static voideval_letmacro_rhs_k (void)
static Scheme_Objecteval_letmacro_rhs (Scheme_Object *a, Scheme_Comp_Env *rhs_env, int max_let_depth, Resolve_Prefix *rp, int phase, Scheme_Object *certs)
void scheme_bind_syntaxes (const char *where, Scheme_Object *names, Scheme_Object *a, Scheme_Env *exp_env, Scheme_Object *insp, Scheme_Compile_Expand_Info *rec, int drec, Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env, int *_pos, Scheme_Object *rename_rib)
static Scheme_Objectdo_letrec_syntaxes (const char *where, Scheme_Object *forms, Scheme_Comp_Env *origenv, Scheme_Compile_Info *rec, int drec)
void scheme_call_expand_observe (Scheme_Object *obs, int tag, Scheme_Object *obj)
static Scheme_Objectcurrent_expand_observe (int argc, Scheme_Object **argv)
Scheme_Objectscheme_get_expand_observe ()
void scheme_init_expand_observe (Scheme_Env *env)

Variables

Scheme_Objectscheme_define_values_syntax
Scheme_Objectscheme_define_syntaxes_syntax
Scheme_Objectscheme_ref_syntax
Scheme_Objectscheme_begin_syntax
Scheme_Objectscheme_lambda_syntax
Scheme_Objectscheme_compiled_void_code
Scheme_Object scheme_undefined [1]
Scheme_Syntax_Optimizer scheme_syntax_optimizers [_COUNT_EXPD_]
Scheme_Syntax_Resolver scheme_syntax_resolvers [_COUNT_EXPD_]
Scheme_Syntax_SFSer scheme_syntax_sfsers [_COUNT_EXPD_]
Scheme_Syntax_Validater scheme_syntax_validaters [_COUNT_EXPD_]
Scheme_Syntax_Executer scheme_syntax_executers [_COUNT_EXPD_]
Scheme_Syntax_Jitter scheme_syntax_jitters [_COUNT_EXPD_]
Scheme_Syntax_Cloner scheme_syntax_cloners [_COUNT_EXPD_]
Scheme_Syntax_Shifter scheme_syntax_shifters [_COUNT_EXPD_]
int scheme_syntax_protect_afters [_COUNT_EXPD_]
static Scheme_Objectlambda_symbol
static Scheme_Objectletrec_values_symbol
static Scheme_Objectlet_star_values_symbol
static Scheme_Objectlet_values_symbol
static Scheme_Objectbegin_symbol
static Scheme_Objectdisappeared_binding_symbol

Define Documentation

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

Definition at line 241 of file syntax.c.

#define max (   a,
  b 
)    (((a) > (b)) ? (a) : (b))

Definition at line 243 of file syntax.c.

#define MAX_PROC_INLINE_SIZE   256

Definition at line 245 of file syntax.c.


Function Documentation

static Scheme_Object * apply_values_clone ( int  dup_ok,
Scheme_Object data,
Optimize_Info info,
int  delta,
int  closure_depth 
) [static]

Definition at line 2140 of file syntax.c.

{
  Scheme_Object *f, *e;

  f = SCHEME_CAR(data);
  e = SCHEME_CDR(data);
  
  f = scheme_optimize_clone(dup_ok, f, info, delta, closure_depth);
  if (!f) return NULL;
  e = scheme_optimize_clone(dup_ok, e, info, delta, closure_depth);
  if (!e) return NULL;  
  
  return scheme_make_syntax_compiled(APPVALS_EXPD, cons(f, e));
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * apply_values_execute ( Scheme_Object data) [static]

Definition at line 2032 of file syntax.c.

{
  Scheme_Object *f, *v;
  
  f = SCHEME_CAR(data);

  f = _scheme_eval_linked_expr(f);
  if (!SCHEME_PROCP(f)) {
    Scheme_Object *a[1];
    a[0] = f;
    scheme_wrong_type("call-with-values", "procedure", -1, 1, a);    
    return NULL;
  }

  v = _scheme_eval_linked_expr_multi(SCHEME_CDR(data));
  if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
    Scheme_Thread *p = scheme_current_thread;
    int num_rands = p->ku.multiple.count;

    if (num_rands > p->tail_buffer_size) {
      /* scheme_tail_apply will allocate */
      if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
        p->values_buffer = NULL;
    }
    return scheme_tail_apply(f, num_rands, p->ku.multiple.array);
  } else {
    Scheme_Object *a[1];
    a[0] = v;
    return scheme_tail_apply(f, 1, a);
  }
}

Here is the caller graph for this function:

static Scheme_Object * apply_values_jit ( Scheme_Object data) [static]

Definition at line 2064 of file syntax.c.

{
  Scheme_Object *f, *e;

  f = scheme_jit_expr(SCHEME_CAR(data));
  e = scheme_jit_expr(SCHEME_CDR(data));
  
  if (SAME_OBJ(f, SCHEME_CAR(data))
      && SAME_OBJ(e, SCHEME_CAR(data)))
    return data;
  else
    return scheme_make_pair(f, e);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * apply_values_optimize ( Scheme_Object data,
Optimize_Info info 
) [static]

Definition at line 2079 of file syntax.c.

{
  Scheme_Object *f, *e;

  f = SCHEME_CAR(data);
  e = SCHEME_CDR(data);
  
  f = scheme_optimize_expr(f, info);
  e = scheme_optimize_expr(e, info);

  return scheme_optimize_apply_values(f, e, info, info->single_result);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * apply_values_resolve ( Scheme_Object data,
Resolve_Info info 
) [static]

Definition at line 2093 of file syntax.c.

{
  Scheme_Object *f, *e;

  f = SCHEME_CAR(data);
  e = SCHEME_CDR(data);

  f = scheme_resolve_expr(f, rslv);
  e = scheme_resolve_expr(e, rslv);
  
  return scheme_make_syntax_resolved(APPVALS_EXPD, cons(f, e));
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * apply_values_sfs ( Scheme_Object data,
SFS_Info info 
) [static]

Definition at line 2107 of file syntax.c.

{
  Scheme_Object *f, *e;

  f = SCHEME_CAR(data);
  e = SCHEME_CDR(data);

  scheme_sfs_start_sequence(info, 2, 0);

  f = scheme_sfs_expr(f, info, -1);
  e = scheme_sfs_expr(e, info, -1);

  SCHEME_CAR(data) = f;
  SCHEME_CDR(data) = e;

  return data;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * apply_values_shift ( Scheme_Object data,
int  delta,
int  after_depth 
) [static]

Definition at line 2126 of file syntax.c.

{
  Scheme_Object *e;

  e = scheme_optimize_shift(SCHEME_CAR(data), delta, after_depth);
  SCHEME_CAR(data) = e;

  e = scheme_optimize_shift(SCHEME_CDR(data), delta, after_depth);
  SCHEME_CAR(data) = e;

  return scheme_make_syntax_compiled(APPVALS_EXPD, data);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void apply_values_validate ( Scheme_Object data,
Mz_CPort *  port,
char *  stack,
Validate_TLS  tls,
int  depth,
int  letlimit,
int  delta,
int  num_toplevels,
int  num_stxes,
int  num_lifts,
struct Validate_Clearing vc,
int  tailpos 
) [static]

Definition at line 2155 of file syntax.c.

{
  Scheme_Object *f, *e;

  f = SCHEME_CAR(data);
  e = SCHEME_CDR(data);

  scheme_validate_expr(port, f, stack, tls,
                       depth, letlimit, delta, 
                       num_toplevels, num_stxes, num_lifts,
                       NULL, 0, 0, vc, 0);
  scheme_validate_expr(port, e, stack, tls,
                       depth, letlimit, delta, 
                       num_toplevels, num_stxes, num_lifts,
                       NULL, 0, 0, vc, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void bad_form ( Scheme_Object form,
int  l 
) [static]

Definition at line 485 of file syntax.c.

{ 
  scheme_wrong_syntax(NULL, NULL, form, 
                    "bad syntax (has %d part%s after keyword)", 
                    l - 1, (l != 2) ? "s" : "");
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 2684 of file syntax.c.

{
  int pos = SCHEME_INT_VAL(SCHEME_CAR(data));
  Scheme_Object *bb;

  data = SCHEME_CDR(data);
  
  bb = scheme_make_envunbox(MZ_RUNSTACK[pos]);
  MZ_RUNSTACK[pos] = bb;

  return _scheme_tail_eval(data);
}

Here is the caller graph for this function:

static Scheme_Object * bangboxenv_jit ( Scheme_Object data) [static]

Definition at line 2705 of file syntax.c.

{
  Scheme_Object *orig, *naya;

  orig = SCHEME_CDR(data);
  naya = scheme_jit_expr(orig);
  if (SAME_OBJ(naya, orig))
    return data;
  else
    return cons(SCHEME_CAR(data), naya);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * bangboxenv_sfs ( Scheme_Object data,
SFS_Info info 
) [static]

Definition at line 2697 of file syntax.c.

{
  Scheme_Object *e;
  e = scheme_sfs_expr(SCHEME_CDR(data), info, -1);
  SCHEME_CDR(data) = e;
  return data;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void bangboxenv_validate ( Scheme_Object data,
Mz_CPort *  port,
char *  stack,
Validate_TLS  tls,
int  depth,
int  letlimit,
int  delta,
int  num_toplevels,
int  num_stxes,
int  num_lifts,
struct Validate_Clearing vc,
int  tailpos 
) [static]

Definition at line 2717 of file syntax.c.

{
  if (!SCHEME_PAIRP(data))
    scheme_ill_formed_code(port);
    
  scheme_validate_boxenv(SCHEME_INT_VAL(SCHEME_CAR(data)), port, stack, depth, delta);

  scheme_validate_expr(port, SCHEME_CDR(data), stack, tls, depth, letlimit, delta, 
                       num_toplevels, num_stxes, num_lifts,
                       NULL, 0, 0, vc, tailpos);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * begin0_clone ( int  dup_ok,
Scheme_Object data,
Optimize_Info info,
int  delta,
int  closure_depth 
) [static]

Definition at line 4834 of file syntax.c.

{
  obj = scheme_optimize_clone(dup_ok, obj, info, delta, closure_depth);
  if (!obj) return NULL;
  return scheme_make_syntax_compiled(BEGIN0_EXPD, obj);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * begin0_execute ( Scheme_Object data) [static]

Definition at line 4724 of file syntax.c.

{
  Scheme_Object *v, **mv;
  int i, mc, apos;
  
  i = ((Scheme_Sequence *)obj)->count;

  v = _scheme_eval_linked_expr_multi(((Scheme_Sequence *)obj)->array[0]);
  i--;
  if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) {
    Scheme_Thread *p = scheme_current_thread;
    mv = p->ku.multiple.array;
    mc = p->ku.multiple.count;
    if (SAME_OBJ(mv, p->values_buffer))
      p->values_buffer = NULL;
  } else {
    mv = NULL;
    mc = 0; /* makes compilers happy */
  }

  apos = 1;
  while (i--) {
    (void)_scheme_eval_linked_expr_multi(((Scheme_Sequence *)obj)->array[apos++]);
  }

  if (mv) {
    Scheme_Thread *p = scheme_current_thread;
    p->ku.multiple.array = mv;
    p->ku.multiple.count = mc;
  }

  return v;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 5063 of file syntax.c.

{
  SCHEME_EXPAND_OBSERVE_PRIM_BEGIN0(erec[drec].observer);
  return do_begin_expand("begin0", form, env, erec, drec, 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * begin0_jit ( Scheme_Object data) [static]

Definition at line 4758 of file syntax.c.

{
  Scheme_Sequence *seq = (Scheme_Sequence *)data, *seq2;
  Scheme_Object *old, *naya = NULL;
  int i, j, count;

  count = seq->count;
  for (i = 0; i < count; i++) {
    old = seq->array[i];
    naya = scheme_jit_expr(old);
    if (!SAME_OBJ(old, naya))
      break;
  }

  if (i >= count)
    return data;

  seq2 = (Scheme_Sequence *)scheme_malloc_tagged(sizeof(Scheme_Sequence)
                                           + (count - 1) 
                                           * sizeof(Scheme_Object *));
  seq2->so.type = scheme_begin0_sequence_type;
  seq2->count = count;
  for (j = 0; j < i; j++) {
    seq2->array[j] = seq->array[j];
  }
  seq2->array[i] = naya;
  for (i++; i < count; i++) {
    old = seq->array[i];
    naya = scheme_jit_expr(old);
    seq2->array[i] = naya;
  }
  
  return (Scheme_Object *)seq2;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * begin0_optimize ( Scheme_Object data,
Optimize_Info info 
) [static]

Definition at line 4815 of file syntax.c.

{
  int i;
  
  i = ((Scheme_Sequence *)obj)->count;

  while (i--) {
    Scheme_Object *le;
    le = scheme_optimize_expr(((Scheme_Sequence *)obj)->array[i], info);
    ((Scheme_Sequence *)obj)->array[i] = le;
  }

  /* Optimization of expression 0 has already set single_result */
  info->preserves_marks = 1;

  return scheme_make_syntax_compiled(BEGIN0_EXPD, obj);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * begin0_resolve ( Scheme_Object data,
Resolve_Info info 
) [static]

Definition at line 4857 of file syntax.c.

{
  int i;
  
  i = ((Scheme_Sequence *)obj)->count;

  while (i--) {
    Scheme_Object *le;
    le = scheme_resolve_expr(((Scheme_Sequence *)obj)->array[i], info);
    ((Scheme_Sequence *)obj)->array[i] = le;
  }

  return scheme_make_syntax_resolved(BEGIN0_EXPD, obj);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * begin0_sfs ( Scheme_Object data,
SFS_Info info 
) [static]

Definition at line 4873 of file syntax.c.

{
  int i, cnt;
  
  cnt = ((Scheme_Sequence *)obj)->count;

  scheme_sfs_start_sequence(info, cnt, 0);

  for (i = 0; i < cnt; i++) {
    Scheme_Object *le;
    le = scheme_sfs_expr(((Scheme_Sequence *)obj)->array[i], info, -1);
    ((Scheme_Sequence *)obj)->array[i] = le;
  }

  return obj;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * begin0_shift ( Scheme_Object data,
int  delta,
int  after_depth 
) [static]

Definition at line 4841 of file syntax.c.

{
  int i;
  
  i = ((Scheme_Sequence *)obj)->count;

  while (i--) {
    Scheme_Object *le;
    le = scheme_optimize_shift(((Scheme_Sequence *)obj)->array[i], delta, after_depth);
    ((Scheme_Sequence *)obj)->array[i] = le;
  }

  return scheme_make_syntax_compiled(BEGIN0_EXPD, obj);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 4977 of file syntax.c.

{
  return do_begin_syntax("begin0", form, env, rec, drec, 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void begin0_validate ( Scheme_Object data,
Mz_CPort *  port,
char *  stack,
Validate_TLS  tls,
int  depth,
int  letlimit,
int  delta,
int  num_toplevels,
int  num_stxes,
int  num_lifts,
struct Validate_Clearing vc,
int  tailpos 
) [static]

Definition at line 4793 of file syntax.c.

{
  Scheme_Sequence *seq = (Scheme_Sequence *)data;
  int i;

  if (!SAME_TYPE(SCHEME_TYPE(seq), scheme_begin0_sequence_type)
      && !SAME_TYPE(SCHEME_TYPE(seq), scheme_sequence_type))
    scheme_ill_formed_code(port);

  for (i = 0; i < seq->count; i++) { 
    scheme_validate_expr(port, seq->array[i], stack, tls,
                         depth, letlimit, delta, 
                         num_toplevels, num_stxes, num_lifts,
                         NULL, 0, i > 0, vc, 0);
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 5056 of file syntax.c.

{
  SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(erec[drec].observer);
  return do_begin_expand("begin", form, env, erec, drec, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 4971 of file syntax.c.

{
  return do_begin_syntax("begin", form, env, rec, drec, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void case_lambda_check_line ( Scheme_Object line,
Scheme_Object form,
Scheme_Comp_Env env 
) [static]

Definition at line 2485 of file syntax.c.

{
  Scheme_Object *body, *args;

  if (!SCHEME_STX_PAIRP(line))
    scheme_wrong_syntax(NULL, line, form, NULL);
  
  body = SCHEME_STX_CDR(line);
  args = SCHEME_STX_CAR(line);
  
  lambda_check_args(args, form, env);
  
  if (!SCHEME_STX_PAIRP(body))
    scheme_wrong_syntax(NULL, line, form, "bad syntax (%s)",
                     SCHEME_STX_NULLP(body) ? "empty body" : IMPROPER_LIST_FORM);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * case_lambda_execute ( Scheme_Object expr) [static]

Definition at line 2181 of file syntax.c.

{
  Scheme_Case_Lambda *seqin, *seqout;
  int i, cnt;
  Scheme_Thread *p = scheme_current_thread;

  seqin = (Scheme_Case_Lambda *)expr;

#ifdef MZ_USE_JIT
  if (seqin->native_code) {
    Scheme_Native_Closure_Data *ndata;
    Scheme_Native_Closure *nc, *na;
    Scheme_Closure_Data *data;
    Scheme_Object *val;
    GC_CAN_IGNORE Scheme_Object **runstack;
    GC_CAN_IGNORE mzshort *map;
    int j, jcnt;

    ndata = seqin->native_code;
    nc = (Scheme_Native_Closure *)scheme_make_native_case_closure(ndata);

    cnt = seqin->count;
    for (i = 0; i < cnt; i++) {
      val = seqin->array[i];
      if (!SCHEME_PROCP(val)) {
       data = (Scheme_Closure_Data *)val;
       na = (Scheme_Native_Closure *)scheme_make_native_closure(data->u.native_code);
       runstack = MZ_RUNSTACK;
       jcnt = data->closure_size;
       map = data->closure_map;
       for (j = 0; j < jcnt; j++) {
         na->vals[j] = runstack[map[j]];
       }
       val = (Scheme_Object *)na;
      }
      nc->vals[i] = val;
    }

    return (Scheme_Object *)nc;
  }
#endif

  seqout = (Scheme_Case_Lambda *)
    scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
                      + (seqin->count - 1) * sizeof(Scheme_Object *));
  seqout->so.type = scheme_case_closure_type;
  seqout->count = seqin->count;
  seqout->name = seqin->name;

  cnt = seqin->count;
  for (i = 0; i < cnt; i++) {
    if (SAME_TYPE(SCHEME_TYPE(seqin->array[i]), scheme_closure_type)) {
      /* An empty closure, created at compile time */
      seqout->array[i] = seqin->array[i];
    } else {
      Scheme_Object *lc;
      lc = scheme_make_closure(p, seqin->array[i], 1);
      seqout->array[i] = lc;
    }
  }

  return (Scheme_Object *)seqout;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 2621 of file syntax.c.

{
  Scheme_Object *first, *last, *args, *body, *c, *new_line, *orig_form = form;

  SCHEME_EXPAND_OBSERVE_PRIM_CASE_LAMBDA(erec[drec].observer);

  first = SCHEME_STX_CAR(form);
  first = cons(first, scheme_null);
  last = first;
  form = SCHEME_STX_CDR(form);

  scheme_rec_add_certs(erec, drec, orig_form);

  while (SCHEME_STX_PAIRP(form)) {
    Scheme_Object *line_form;
    Scheme_Comp_Env *newenv;
    
    SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);

    line_form = SCHEME_STX_CAR(form);

    case_lambda_check_line(line_form, orig_form, env);
    
    body = SCHEME_STX_CDR(line_form);
    args = SCHEME_STX_CAR(line_form);

    body = scheme_datum_to_syntax(body, line_form, line_form, 0, 0);
    
    newenv = scheme_add_compilation_frame(args, env, 0, erec[drec].certs);
    
    body = scheme_add_env_renames(body, newenv, env);
    args = scheme_add_env_renames(args, newenv, env);
    SCHEME_EXPAND_OBSERVE_CASE_LAMBDA_RENAMES(erec[drec].observer, args, body);

    {
      Scheme_Expand_Info erec1;
      scheme_init_expand_recs(erec, drec, &erec1, 1);
      erec1.value_name = scheme_false;
      new_line = cons(args, scheme_expand_block(body, newenv, &erec1, 0));
    }
    new_line = scheme_datum_to_syntax(new_line, line_form, line_form, 0, 1);

    c = cons(new_line, scheme_null);

    SCHEME_CDR(last) = c;
    last = c;

    form = SCHEME_STX_CDR(form);
  }

  if (!SCHEME_STX_NULLP(form))
    scheme_wrong_syntax(NULL, form, orig_form, NULL);
  
  return scheme_datum_to_syntax(first, orig_form, orig_form, 0, 2);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * case_lambda_jit ( Scheme_Object expr) [static]

Definition at line 2245 of file syntax.c.

{
#ifdef MZ_USE_JIT
  Scheme_Case_Lambda *seqin = (Scheme_Case_Lambda *)expr;

  if (!seqin->native_code) {
    Scheme_Case_Lambda *seqout;
    Scheme_Native_Closure_Data *ndata;
    Scheme_Object *val, *name;
    int i, cnt, size, all_closed = 1;

    cnt = seqin->count;
    
    size = sizeof(Scheme_Case_Lambda) + ((cnt - 1) * sizeof(Scheme_Object *));

    seqout = (Scheme_Case_Lambda *)scheme_malloc_tagged(size);
    memcpy(seqout, seqin, size);

    name = seqin->name;
    if (name && SCHEME_BOXP(name))
      name = SCHEME_BOX_VAL(name);

    for (i = 0; i < cnt; i++) {
      val = seqout->array[i];
      if (SCHEME_PROCP(val)) {
       /* Undo creation of empty closure */
       val = (Scheme_Object *)((Scheme_Closure *)val)->code;
       seqout->array[i] = val;
      }
      ((Scheme_Closure_Data *)val)->name = name;
      if (((Scheme_Closure_Data *)val)->closure_size)
       all_closed = 0;
    }

    /* Generating the code may cause empty closures to be formed: */
    ndata = scheme_generate_case_lambda(seqout);
    seqout->native_code = ndata;

    if (all_closed) {
      /* Native closures do not refer back to the original bytecode,
        so no need to worry about clearing the reference. */
      Scheme_Native_Closure *nc;
      nc = (Scheme_Native_Closure *)scheme_make_native_case_closure(ndata);
      for (i = 0; i < cnt; i++) {
       val = seqout->array[i];
       if (!SCHEME_PROCP(val)) {
         val = scheme_make_native_closure(((Scheme_Closure_Data *)val)->u.native_code);
       }
       nc->vals[i] = val;
      }
      return (Scheme_Object *)nc;
    } else {
      /* The case-lambda data must point to the original closure-data
        record, because that's where the closure maps are kept. But
        we don't need the bytecode, anymore. So clone the
        closure-data record and drop the bytecode in thte clone. */
      for (i = 0; i < cnt; i++) {
       val = seqout->array[i];
       if (!SCHEME_PROCP(val)) {
         Scheme_Closure_Data *data;
         data = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
         memcpy(data, val, sizeof(Scheme_Closure_Data));
         data->code = NULL;
         seqout->array[i] = (Scheme_Object *)data;
       }
      }
    }

    return (Scheme_Object *)seqout;
  }
#endif
 
  return expr;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * case_lambda_optimize ( Scheme_Object expr,
Optimize_Info info 
) [static]

Definition at line 2409 of file syntax.c.

{
  Scheme_Object *le;
  int i;
  Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr;

  for (i = 0; i < seq->count; i++) {
    le = seq->array[i];
    le = scheme_optimize_expr(le, info);
    seq->array[i] = le;
  }

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

  return scheme_make_syntax_compiled(CASE_LAMBDA_EXPD, expr);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * case_lambda_resolve ( Scheme_Object expr,
Resolve_Info info 
) [static]

Definition at line 2344 of file syntax.c.

{
  int i, all_closed = 1;
  Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr;

  for (i = 0; i < seq->count; i++) {
    Scheme_Object *le;
    le = seq->array[i];
    le = scheme_resolve_closure_compilation(le, rslv, 0, 0, 0, NULL);
    seq->array[i] = le;
    if (!SCHEME_PROCP(le))
      all_closed = 0;
  }

  if (all_closed) {
    /* Produce closure directly */
    return case_lambda_execute(expr);
  }

  return scheme_make_syntax_resolved(CASE_LAMBDA_EXPD, expr);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * case_lambda_sfs ( Scheme_Object expr,
SFS_Info info 
) [static]

Definition at line 2367 of file syntax.c.

{
  Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr;
  Scheme_Object *le, *clears = scheme_null;
  int i;

  scheme_sfs_start_sequence(info, seq->count, 0);

  for (i = 0; i < seq->count; i++) {
    le = seq->array[i];
    le = scheme_sfs_expr(le, info, -1);
    if (SAME_TYPE(SCHEME_TYPE(le), scheme_syntax_type)
        && (SCHEME_PINT_VAL(le) == BEGIN0_EXPD)) {
      /* Some clearing actions were added to the closure.
         Lift them out. */
      int j;
      Scheme_Sequence *cseq = (Scheme_Sequence *)SCHEME_IPTR_VAL(le);
      if (!cseq->count)
        scheme_signal_error("internal error: empty sequence");
      for (j = 1; j < cseq->count; j++) {
        int pos;
        pos = SCHEME_LOCAL_POS(cseq->array[j]);
        clears = scheme_make_pair(scheme_make_integer(pos), clears);
      }
      le = cseq->array[0];
    }
    if (!SAME_TYPE(SCHEME_TYPE(le), scheme_unclosed_procedure_type)
        && !SAME_TYPE(SCHEME_TYPE(le), scheme_closure_type)) {
      scheme_signal_error("internal error: not a lambda for case-lambda: %d",
                          SCHEME_TYPE(le));
    }
    seq->array[i] = le;
  }

  if (!SCHEME_NULLP(clears)) {
    expr = scheme_make_syntax_resolved(CASE_LAMBDA_EXPD, expr);
    return scheme_sfs_add_clears(expr, clears, 0);
  } else
    return expr;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * case_lambda_shift ( Scheme_Object data,
int  delta,
int  after_depth 
) [static]

Definition at line 2428 of file syntax.c.

{
  Scheme_Object *le;
  int i;
  Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)data;

  for (i = 0; i < seq->count; i++) {
    le = seq->array[i];
    le = scheme_optimize_shift(le, delta, after_depth);
    seq->array[i] = le;
  }
  
  return data;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 2503 of file syntax.c.

{
  Scheme_Object *list, *last, *c, *orig_form = form, *name;
  Scheme_Case_Lambda *cl;
  int i, count = 0;
  Scheme_Compile_Info *recs;
  
  form = SCHEME_STX_CDR(form);

  name = scheme_build_closure_name(orig_form, rec, drec);
  
  if (SCHEME_STX_NULLP(form)) {
    /* Case where there are no cases... */
    form = (Scheme_Object *)scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
                                           - sizeof(Scheme_Object*));

    form->type = scheme_case_lambda_sequence_type;
    ((Scheme_Case_Lambda *)form)->count = 0;
    ((Scheme_Case_Lambda *)form)->name = name;

    scheme_compile_rec_done_local(rec, drec);
    scheme_default_compile_rec(rec, drec);

    if (scheme_has_method_property(orig_form)) {
      /* See note in schpriv.h about the IS_METHOD hack */
      if (!name)
       name = scheme_false;
      name = scheme_box(name);
      ((Scheme_Case_Lambda *)form)->name = name;
    }

    return scheme_make_syntax_compiled(CASE_LAMBDA_EXPD, form);
  }

  if (!SCHEME_STX_PAIRP(form))
    scheme_wrong_syntax(NULL, form, orig_form, NULL);
  if (SCHEME_STX_NULLP(SCHEME_STX_CDR(form))) {
    c = SCHEME_STX_CAR(form);

    case_lambda_check_line(c, orig_form, env);

    c = cons(scheme_datum_to_syntax(lambda_symbol, scheme_false, scheme_sys_wraps(env), 0, 0),
             c);
    c = scheme_datum_to_syntax(c, orig_form, orig_form, 0, 2);
    
    return lambda_syntax(c, env, rec, drec);
  }

  scheme_compile_rec_done_local(rec, drec);

  scheme_rec_add_certs(rec, drec, orig_form);

  list = last = NULL;
  while (SCHEME_STX_PAIRP(form)) {
    Scheme_Object *clause;
    clause = SCHEME_STX_CAR(form);
    case_lambda_check_line(clause, orig_form, env);

    c = cons(lambda_symbol, clause);

    c = scheme_datum_to_syntax(c, clause, scheme_sys_wraps(env), 0, 0);

    c = cons(c, scheme_null);

    if (list)
      SCHEME_CDR(last) = c;
    else
      list = c;

    last = c;
    form = SCHEME_STX_CDR(form);

    count++;
  }

  if (!SCHEME_STX_NULLP(form))
    scheme_wrong_syntax(NULL, form, orig_form, NULL);

  cl = (Scheme_Case_Lambda *)
    scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
                      + (count - 1) * sizeof(Scheme_Object *));
  cl->so.type = scheme_case_lambda_sequence_type;
  cl->count = count;
  cl->name = SCHEME_TRUEP(name) ? name : NULL;

  scheme_compile_rec_done_local(rec, drec);
  recs = MALLOC_N_RT(Scheme_Compile_Info, count);
  scheme_init_compile_recs(rec, drec, recs, count);

  for (i = 0; i < count; i++) {
    Scheme_Object *ce;
    ce = SCHEME_CAR(list);
    ce = scheme_compile_expr(ce, env, recs, i);
    cl->array[i] = ce;
    list = SCHEME_CDR(list);
  }

  scheme_merge_compile_recs(rec, drec, recs, count);

  if (scheme_has_method_property(orig_form)) {
    Scheme_Closure_Data *data;
    /* Make sure no branch has 0 arguments: */
    for (i = 0; i < count; i++) {
      data = (Scheme_Closure_Data *)cl->array[i];
      if (!data->num_params)
       break;
    }
    if (i >= count) {
      data = (Scheme_Closure_Data *)cl->array[0];
      SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_IS_METHOD;
    }
  }

  return scheme_make_syntax_compiled(CASE_LAMBDA_EXPD, (Scheme_Object *)cl);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void case_lambda_validate ( Scheme_Object data,
Mz_CPort *  port,
char *  stack,
Validate_TLS  tls,
int  depth,
int  letlimit,
int  delta,
int  num_toplevels,
int  num_stxes,
int  num_lifts,
struct Validate_Clearing vc,
int  tailpos 
) [static]

Definition at line 2320 of file syntax.c.

{
  Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)data;
  Scheme_Object *e;
  int i;

  if (!SAME_TYPE(SCHEME_TYPE(data), scheme_case_lambda_sequence_type))
    scheme_ill_formed_code(port);

  for (i = 0; i < seq->count; i++) { 
    e = seq->array[i];
    if (!SAME_TYPE(SCHEME_TYPE(e), scheme_unclosed_procedure_type)
        && !SAME_TYPE(SCHEME_TYPE(e), scheme_closure_type))
      scheme_ill_formed_code(port);
    scheme_validate_expr(port, e, stack, tls, depth, letlimit, delta, 
                         num_toplevels, num_stxes, num_lifts,
                         NULL, 0, 0, vc, 0);
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int check_form ( Scheme_Object form,
Scheme_Object base_form 
) [static]

Definition at line 470 of file syntax.c.

{
  int i;

  for (i = 0; SCHEME_STX_PAIRP(form); i++) {
    form = SCHEME_STX_CDR(form);
  }

  if (!SCHEME_STX_NULLP(form)) {
    scheme_wrong_syntax(NULL, form, base_form, "bad syntax (" IMPROPER_LIST_FORM ")");
  }

  return i;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void check_if_len ( Scheme_Object form,
int  len 
) [static]

Definition at line 1235 of file syntax.c.

{
  if (len != 4) {
    if (len == 3) {
      scheme_wrong_syntax(NULL, NULL, form, 
                          "bad syntax (must have an \"else\" expression)");
    } else {
      bad_form(form, len);
    }
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* check_single ( Scheme_Object form,
Scheme_Comp_Env top_only 
) [static]

Definition at line 5160 of file syntax.c.

{
  Scheme_Object *rest;

  check_form(form, form);

  rest = SCHEME_STX_CDR(form);
  if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest))))
    scheme_wrong_syntax(NULL, NULL, form, "bad syntax (wrong number of parts)");

  if (top_only && !scheme_is_toplevel(top_only))
    scheme_wrong_syntax(NULL, NULL, form, "illegal use (not at top-level)");

  return SCHEME_STX_CAR(rest);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* clone_vector ( Scheme_Object data,
int  skip 
) [static]

Definition at line 839 of file syntax.c.

{
  Scheme_Object *naya;
  int i, size;

  size = SCHEME_VEC_SIZE(data);
  naya = scheme_make_vector(size - skip, NULL);
  for (i = skip; i < size; i++) {
    SCHEME_VEC_ELS(naya)[i - skip] = SCHEME_VEC_ELS(data)[i];
  }

  return naya;
}

Here is the caller graph for this function:

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

Definition at line 6461 of file syntax.c.

{
  return scheme_param_config("current-expand-observe",
                          scheme_make_integer(MZCONFIG_EXPAND_OBSERVE),
                          argc, argv,
                          2, NULL, NULL, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* define_execute_with_dynamic_state ( Scheme_Object vec,
int  delta,
int  defmacro,
Resolve_Prefix rp,
Scheme_Env dm_env,
Scheme_Dynamic_State dyn_state 
) [static]

Definition at line 683 of file syntax.c.

{
  Scheme_Object *name, *macro, *vals_expr, *vals, *var;
  int i, g, show_any;
  Scheme_Bucket *b;
  Scheme_Object **save_runstack = NULL;

  vals_expr = SCHEME_VEC_ELS(vec)[0];

  if (dm_env) {
    scheme_prepare_exp_env(dm_env);

    save_runstack = scheme_push_prefix(dm_env->exp_env, rp, NULL, NULL, 1, 1);
    vals = scheme_eval_linked_expr_multi_with_dynamic_state(vals_expr, dyn_state);
    if (defmacro == 2)
      dm_env = NULL;
    else
      scheme_pop_prefix(save_runstack);
  } else {
    vals = _scheme_eval_linked_expr_multi(vals_expr);
    dm_env = NULL;
  }

  if (SAME_OBJ(vals, SCHEME_MULTIPLE_VALUES)) {
    Scheme_Object **values;

    i = SCHEME_VEC_SIZE(vec) - delta;
    
    g = scheme_current_thread->ku.multiple.count;
    if (i == g) {
      values = scheme_current_thread->ku.multiple.array;
      scheme_current_thread->ku.multiple.array = NULL;
      if (SAME_OBJ(values, scheme_current_thread->values_buffer))
       scheme_current_thread->values_buffer = NULL;
      for (i = 0; i < g; i++) {
        var = SCHEME_VEC_ELS(vec)[i+delta];
       if (dm_env) {
         b = scheme_global_keyword_bucket(var, dm_env);

         macro = scheme_alloc_small_object();
         macro->type = scheme_macro_type;
         SCHEME_PTR_VAL(macro) = values[i];

         scheme_set_global_bucket("define-syntaxes", b, macro, 1);
         scheme_shadow(dm_env, (Scheme_Object *)b->key, 0);
       } else {
         Scheme_Object **toplevels;
         toplevels = (Scheme_Object **)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)];
         b = (Scheme_Bucket *)toplevels[SCHEME_TOPLEVEL_POS(var)];
       
         scheme_set_global_bucket("define-values", b, values[i], 1);
         scheme_shadow(((Scheme_Bucket_With_Home *)b)->home, (Scheme_Object *)b->key, 1);

         if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_CONST) {
            ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED;
         }
       }
      }
      if (defmacro)
       scheme_pop_prefix(save_runstack);
       
      return scheme_void;
    }

    if (SAME_OBJ(scheme_current_thread->ku.multiple.array, scheme_current_thread->values_buffer))
      scheme_current_thread->values_buffer = NULL;
  } else if (SCHEME_VEC_SIZE(vec) == delta + 1) { /* => single var */
    var = SCHEME_VEC_ELS(vec)[delta];
    if (dm_env) {
      b = scheme_global_keyword_bucket(var, dm_env);

      macro = scheme_alloc_small_object();
      macro->type = scheme_macro_type;
      SCHEME_PTR_VAL(macro) = vals;
      
      scheme_set_global_bucket("define-syntaxes", b, macro, 1);
      scheme_shadow(dm_env, (Scheme_Object *)b->key, 0);
    } else {
      Scheme_Object **toplevels;
      toplevels = (Scheme_Object **)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)];
      b = (Scheme_Bucket *)toplevels[SCHEME_TOPLEVEL_POS(var)];

      scheme_set_global_bucket("define-values", b, vals, 1);
      scheme_shadow(((Scheme_Bucket_With_Home *)b)->home, (Scheme_Object *)b->key, 1);
      
      if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_CONST) {
        int flags = GLOB_IS_IMMUTATED;
        if (SCHEME_PROCP(vals_expr) 
            || SAME_TYPE(SCHEME_TYPE(vals_expr), scheme_unclosed_procedure_type))
          flags |= GLOB_IS_CONSISTENT;
        ((Scheme_Bucket_With_Flags *)b)->flags |= flags;
      }
      
      if (defmacro)
       scheme_pop_prefix(save_runstack);
    }

    return scheme_void;
  } else
    g = 1;

  /* Special handling of 0 values for define-syntaxes:
     do nothing. This makes (define-values (a b c) (values))
     a kind of declaration form, which is useful is
     a, b, or c is introduced by a macro. */
  if (dm_env && !g)
    return scheme_void;
  
  i = SCHEME_VEC_SIZE(vec) - delta;

  show_any = i;

  if (show_any) {
    var = SCHEME_VEC_ELS(vec)[delta];
    if (dm_env) {
      b = scheme_global_keyword_bucket(var, dm_env);
      name = (Scheme_Object *)b->key;
    } else {
      Scheme_Object **toplevels;
      toplevels = (Scheme_Object **)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)];
      b = (Scheme_Bucket *)toplevels[SCHEME_TOPLEVEL_POS(var)];
      name = (Scheme_Object *)b->key;
    }
  } else
    name = NULL;
  
  if (defmacro > 1)
    scheme_pop_prefix(save_runstack);

  {
    const char *symname;

    symname = (show_any ? scheme_symbol_name(name) : "");

    scheme_wrong_return_arity((defmacro 
                            ? (dm_env ? "define-syntaxes" : "define-values-for-syntax")
                            : "define-values"),
                           i, g,
                           (g == 1) ? (Scheme_Object **)vals : scheme_current_thread->ku.multiple.array,
                           "%s%s%s",
                           show_any ? "defining \"" : "0 names",
                           symname,
                           show_any ? ((i == 1) ? "\"" : "\", ...") : "");
  }

  return NULL;
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 5377 of file syntax.c.

{
  return do_define_syntaxes_execute(form, NULL, 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 5709 of file syntax.c.

{
  return define_syntaxes_expand(form, env, erec, drec);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * define_for_syntaxes_jit ( Scheme_Object expr) [static]

Definition at line 5412 of file syntax.c.

{
  return do_define_syntaxes_jit(expr, 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * define_for_syntaxes_optimize ( Scheme_Object expr,
Optimize_Info info 
) [static]

Definition at line 5522 of file syntax.c.

{
  return do_define_syntaxes_optimize(data, info, 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * define_for_syntaxes_resolve ( Scheme_Object expr,
Resolve_Info info 
) [static]

Definition at line 5580 of file syntax.c.

{
  return do_define_syntaxes_resolve(data, info, 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * define_for_syntaxes_sfs ( Scheme_Object expr,
SFS_Info info 
) [static]

Definition at line 5605 of file syntax.c.

{
  return do_define_syntaxes_sfs(data, info);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 5675 of file syntax.c.

{
  return do_define_syntaxes_syntax(form, env, rec, drec, 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void define_for_syntaxes_validate ( Scheme_Object data,
Mz_CPort *  port,
char *  stack,
Validate_TLS  tls,
int  depth,
int  letlimit,
int  delta,
int  num_toplevels,
int  num_stxes,
int  num_lifts,
struct Validate_Clearing vc,
int  tailpos 
) [static]

Definition at line 5482 of file syntax.c.

{
  do_define_syntaxes_validate(data, port, stack, tls, depth, letlimit, delta, 
                              num_toplevels, num_stxes, num_lifts, 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * define_syntaxes_execute ( Scheme_Object expr) [static]

Definition at line 5371 of file syntax.c.

{
  return do_define_syntaxes_execute(form, NULL, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void* define_syntaxes_execute_k ( void  ) [static]

Definition at line 5303 of file syntax.c.

{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object *form = p->ku.k.p1;
  Scheme_Env *dm_env = (Scheme_Env *)p->ku.k.p2;
  p->ku.k.p1 = NULL;
  p->ku.k.p2 = NULL;
  return do_define_syntaxes_execute(form, dm_env, p->ku.k.i1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 5682 of file syntax.c.

{
  Scheme_Object *names, *code, *fpart, *fn;

  SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(erec[drec].observer);

  scheme_prepare_exp_env(env->genv);
  scheme_prepare_compile_env(env->genv->exp_env);

  scheme_define_parse(form, &names, &code, 1, env, 0);
  
  env = scheme_new_expand_env(env->genv->exp_env, env->insp, 0);

  scheme_rec_add_certs(erec, drec, form);
  erec[drec].value_name = names;
  fpart = scheme_expand_expr_lift_to_let(code, env, erec, drec);
  
  code = cons(fpart, scheme_null);
  code = cons(names, code);

  fn = SCHEME_STX_CAR(form);
  return scheme_datum_to_syntax(cons(fn, code), 
                            form, form, 
                            0, 2);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * define_syntaxes_jit ( Scheme_Object expr) [static]

Definition at line 5407 of file syntax.c.

{
  return do_define_syntaxes_jit(expr, 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * define_syntaxes_optimize ( Scheme_Object expr,
Optimize_Info info 
) [static]

Definition at line 5517 of file syntax.c.

{
  return do_define_syntaxes_optimize(data, info, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * define_syntaxes_resolve ( Scheme_Object expr,
Resolve_Info info 
) [static]

Definition at line 5575 of file syntax.c.

{
  return do_define_syntaxes_resolve(data, info, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * define_syntaxes_sfs ( Scheme_Object expr,
SFS_Info info 
) [static]

Definition at line 5600 of file syntax.c.

{
  return do_define_syntaxes_sfs(data, info);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 5668 of file syntax.c.

{
  return do_define_syntaxes_syntax(form, env, rec, drec, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void define_syntaxes_validate ( Scheme_Object data,
Mz_CPort *  port,
char *  stack,
Validate_TLS  tls,
int  depth,
int  letlimit,
int  delta,
int  num_toplevels,
int  num_stxes,
int  num_lifts,
struct Validate_Clearing vc,
int  tailpos 
) [static]

Definition at line 5472 of file syntax.c.

{
  do_define_syntaxes_validate(data, port, stack, tls, depth, letlimit, delta, 
                              num_toplevels, num_stxes, num_lifts, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * define_values_execute ( Scheme_Object data) [static]

Definition at line 834 of file syntax.c.

{
  return define_execute_with_dynamic_state(data, 1, 0, NULL, NULL, NULL);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 1164 of file syntax.c.

{
  Scheme_Object *var, *val, *fn, *boundname;

  SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(erec[drec].observer);

  scheme_define_parse(form, &var, &val, 0, env, 0);

  env = scheme_no_defines(env);

  if (SCHEME_STX_PAIRP(var) && SCHEME_STX_NULLP(SCHEME_STX_CDR(var)))
    boundname = SCHEME_STX_CAR(var);
  else
    boundname = scheme_false;
  erec[drec].value_name = boundname;

  scheme_rec_add_certs(erec, drec, form);

  fn = SCHEME_STX_CAR(form);
  return scheme_datum_to_syntax(cons(fn,
                                  cons(var,
                                       cons(scheme_expand_expr(val, env, erec, drec), 
                                            scheme_null))),
                            form,
                            form,
                            0, 2);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * define_values_jit ( Scheme_Object data) [static]

Definition at line 853 of file syntax.c.

{
  Scheme_Object *orig = SCHEME_VEC_ELS(data)[0], *naya;

  if (SAME_TYPE(SCHEME_TYPE(orig), scheme_unclosed_procedure_type)
      && (SCHEME_VEC_SIZE(data) == 2))
    naya = scheme_jit_closure(orig, SCHEME_VEC_ELS(data)[1]);
  else
    naya = scheme_jit_expr(orig);

  if (SAME_OBJ(naya, orig))
    return data;
  else {
    orig = naya;
    naya = clone_vector(data, 0);
    SCHEME_VEC_ELS(naya)[0] = orig;
    return naya;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * define_values_optimize ( Scheme_Object data,
Optimize_Info info 
) [static]

Definition at line 989 of file syntax.c.

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * define_values_resolve ( Scheme_Object data,
Resolve_Info info 
) [static]

Definition at line 1001 of file syntax.c.

{
  long cnt = 0;
  Scheme_Object *vars = SCHEME_CAR(data), *l, *a;
  Scheme_Object *val = SCHEME_CDR(data), *vec;

  /* If this is a module-level definition: for each variable, if the
     defined variable doesn't have SCHEME_TOPLEVEL_MUTATED, then
     resolve to a top-level reference with SCHEME_TOPLEVEL_CONST, so
     that we know to set GLOS_IS_IMMUTATED at run time. */
  for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
    a = SCHEME_CAR(l);
    if (rslv->in_module
       && rslv->enforce_const
       && (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED))) {
      a = scheme_toplevel_to_flagged_toplevel(a, SCHEME_TOPLEVEL_CONST);
    }
    a = scheme_resolve_toplevel(rslv, a, 0);
    SCHEME_CAR(l) = a;
    cnt++;
  }

  vec = scheme_make_vector(cnt + 1, NULL);
  cnt = 1;
  for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
    SCHEME_VEC_ELS(vec)[cnt++] = SCHEME_CAR(l);
  }

  val = scheme_resolve_expr(val, rslv);
  SCHEME_VEC_ELS(vec)[0] = val;

  return scheme_make_syntax_resolved(DEFINE_VALUES_EXPD, vec);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * define_values_sfs ( Scheme_Object data,
SFS_Info info 
) [static]

Definition at line 1036 of file syntax.c.

{
  Scheme_Object *e;
  scheme_sfs_start_sequence(info, 1, 0);
  e = scheme_sfs_expr(SCHEME_VEC_ELS(data)[0], info, -1);
  SCHEME_VEC_ELS(data)[0] = e;
  return data;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 1137 of file syntax.c.

{
  Scheme_Object *var, *val, *targets, *variables;
  
  scheme_define_parse(form, &var, &val, 0, env, 0);
  variables = var;
  
  targets = defn_targets_syntax(var, env, rec, drec);

  scheme_compile_rec_done_local(rec, drec);
  if (SCHEME_STX_PAIRP(targets) && SCHEME_STX_NULLP(SCHEME_STX_CDR(targets))) {
    var = SCHEME_STX_CAR(variables);
    rec[drec].value_name = SCHEME_STX_SYM(var);
  }

  env = scheme_no_defines(env);

  scheme_rec_add_certs(rec, drec, form);

  val = scheme_compile_expr(val, env, rec, drec);

  /* Note: module_optimize depends on the representation of
     DEFINE_VALUES_EXPD's value. */
  return scheme_make_syntax_compiled(DEFINE_VALUES_EXPD, cons(targets, val));
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void define_values_validate ( Scheme_Object data,
Mz_CPort *  port,
char *  stack,
Validate_TLS  tls,
int  depth,
int  letlimit,
int  delta,
int  num_toplevels,
int  num_stxes,
int  num_lifts,
struct Validate_Clearing vc,
int  tailpos 
) [static]

Definition at line 873 of file syntax.c.

{
  int i, size;
  Scheme_Object *val, *only_var;

  if (!SCHEME_VECTORP(data))
    scheme_ill_formed_code(port);

  val = SCHEME_VEC_ELS(data)[0];
  size = SCHEME_VEC_SIZE(data);

  if (size == 2)
    only_var = SCHEME_VEC_ELS(data)[1];
  else
    only_var = NULL;
    
  for (i = 1; i < size; i++) {
    scheme_validate_toplevel(SCHEME_VEC_ELS(data)[i], port, stack, tls, depth, delta, 
                             num_toplevels, num_stxes, num_lifts,
                             1);
  }

  if (only_var) {
    int pos;
    pos = SCHEME_TOPLEVEL_POS(only_var);
    if (pos >= (num_toplevels + num_stxes + (num_stxes ? 1 : 0))) {
      /* It's a lift. Check whether it needs to take reference arguments
         and/or install reference info. */
      Scheme_Object *app_rator;
      Scheme_Closure_Data *data = NULL;
      int tp = pos - (num_toplevels + num_stxes + (num_stxes ? 1 : 0));
      mzshort *a, *new_a = NULL;

      /* Make sure that no one has tried to register information. */
      a = tls[tp];
      if (a && (a != (mzshort *)0x1) && (a[0] < 1))
        scheme_ill_formed_code(port);

      /* Convert rator to ref-arg info: */
      app_rator = val;
      while (1) {
        if (SAME_TYPE(SCHEME_TYPE(app_rator), scheme_closure_type)) {
          data = SCHEME_COMPILED_CLOS_CODE(app_rator);
          break;
        } else if (SAME_TYPE(SCHEME_TYPE(app_rator), scheme_unclosed_procedure_type)) {
          data = (Scheme_Closure_Data *)app_rator;
          break;
        } else if (SAME_TYPE(SCHEME_TYPE(app_rator), scheme_toplevel_type)) {
          /* Record an indirection */
          data = NULL;
          new_a = MALLOC_N_ATOMIC(mzshort, 2);
          new_a[0] = 0;
          new_a[1] = SCHEME_TOPLEVEL_POS(app_rator);
          break;
        } else {
          /* Not a procedure */
          data = NULL;
          new_a = (mzshort *)0x1;
          break;
        }
      }
      if (data) {
        if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REF_ARGS) {
          int sz;
          sz = data->num_params;
          a = MALLOC_N_ATOMIC(mzshort, (sz + 1));
          a[0] = -sz;
          for (i = 0; i < sz; i++) {
            int bit = ((mzshort)1 << (i & (BITS_PER_MZSHORT - 1)));
            if (data->closure_map[data->closure_size + (i / BITS_PER_MZSHORT)] & bit)
              a[i + 1] = 1;
            else
              a[i + 1] = 0;
          }
        } else {
          new_a = (mzshort *)0x1;
        }
      }

      /* Install info: */
      tls[tp] = new_a;

      /* Check old hopes against actual */
      if (a == (mzshort *)0x1) {
        if (new_a != (mzshort *)0x1)
          scheme_ill_formed_code(port);
      } else if (a) {
        int cnt = a[0], i;

        for (i = 0; i < cnt; i++) {
          if (a[i + 1]) {
            int is;
            is = scheme_validate_rator_wants_box(val, i, 
                                                 a[i + 1] == 2,
                                                 tls, num_toplevels, num_stxes, num_lifts);
            if ((is && (a[i + 1] == 1))
                || (!is && (a[i + 1] == 2)))
              scheme_ill_formed_code(port);
          }
        }
      }
    } else
      only_var = NULL;
  }

  scheme_validate_expr(port, val, stack, tls, 
                       depth, letlimit, delta, 
                       num_toplevels, num_stxes, num_lifts,
                       NULL, !!only_var, 0, vc, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* defn_targets_syntax ( Scheme_Object var,
Scheme_Comp_Env env,
Scheme_Compile_Info rec,
int  drec 
) [static]

Definition at line 1102 of file syntax.c.

{
  Scheme_Object *first = scheme_null, *last = NULL;

  while (SCHEME_STX_PAIRP(var)) {
    Scheme_Object *name, *pr, *bucket;

    name = SCHEME_STX_CAR(var);
    name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL, NULL);

    if (rec[drec].resolve_module_ids || !env->genv->module) {
      bucket = (Scheme_Object *)scheme_global_bucket(name, env->genv);
    } else {
      /* Create a module variable reference, so that idx is preserved: */
      bucket = scheme_hash_module_variable(env->genv, env->genv->module->self_modidx, 
                                      name, env->genv->module->insp, 
                                      -1, env->genv->mod_phase);
    }
    /* Get indirection through the prefix: */
    bucket = scheme_register_toplevel_in_prefix(bucket, env, rec, drec);

    pr = cons(bucket, scheme_null);
    if (last)
      SCHEME_CDR(last) = pr;
    else
      first = pr;
    last = pr;

    var = SCHEME_STX_CDR(var);
  }

  return first;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_begin_expand ( char *  name,
Scheme_Object form,
Scheme_Comp_Env env,
Scheme_Expand_Info erec,
int  drec,
int  zero 
) [static]

Definition at line 4983 of file syntax.c.

{
  Scheme_Object *form_name;
  Scheme_Object *rest;
  Scheme_Object *orig_form = form;

  check_form(form, form);

  form_name = SCHEME_STX_CAR(form);

  rest = SCHEME_STX_CDR(form);

  if (SCHEME_STX_NULLP(rest)) {
    if (!zero && scheme_is_toplevel(env)) {
      SCHEME_EXPAND_OBSERVE_ENTER_LIST(erec[drec].observer, form);
      SCHEME_EXPAND_OBSERVE_EXIT_LIST(erec[drec].observer, form);
      return form;
    }
    scheme_wrong_syntax(NULL, NULL, form, "bad syntax (empty form)");
    return NULL;
  }

  if (zero)
    env = scheme_no_defines(env);

  if (!scheme_is_toplevel(env)) {
    /* Not at top-level: */
    if (zero) {
      Scheme_Object *fst, *boundname;
      Scheme_Expand_Info erec1;
      scheme_rec_add_certs(erec, drec, form);
      scheme_init_expand_recs(erec, drec, &erec1, 1);
      boundname = scheme_check_name_property(form, erec[drec].value_name);
      erec1.value_name = boundname;
      erec[drec].value_name = scheme_false;
      fst = SCHEME_STX_CAR(rest);
      rest = SCHEME_STX_CDR(rest);

      SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
      fst = scheme_expand_expr(fst, env, &erec1, 0);
      rest = scheme_datum_to_syntax(rest, form, form, 0, 0);
      SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
      rest = scheme_expand_list(rest, env, erec, drec);

      form = cons(fst, rest);
    } else {
      Scheme_Object *boundname;
      boundname = scheme_check_name_property(form, erec[drec].value_name);
      erec[drec].value_name = boundname;
      scheme_rec_add_certs(erec, drec, form);
      
      form = scheme_expand_list(scheme_datum_to_syntax(rest, form, form, 0, 0),
                            env, erec, drec);
#if 0
      if (SCHEME_STX_NULLP(SCHEME_STX_CDR(form)))
       return SCHEME_STX_CAR(form);
#endif
    }
  } else {
    /* Top level */
    scheme_rec_add_certs(erec, drec, form);
    form =  scheme_expand_list(scheme_datum_to_syntax(rest, form, form, 0, 0),
                            env, erec, drec);
  }

  return scheme_datum_to_syntax(cons(form_name, form), 
                            orig_form, orig_form, 
                            0, 2);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_begin_syntax ( char *  name,
Scheme_Object form,
Scheme_Comp_Env env,
Scheme_Compile_Info rec,
int  drec,
int  zero 
) [static]

Definition at line 4891 of file syntax.c.

{
  Scheme_Object *forms, *body;

  forms = SCHEME_STX_CDR(form);
  
  if (SCHEME_STX_NULLP(forms)) {
    if (!zero && scheme_is_toplevel(env))
      return scheme_compiled_void();
    scheme_wrong_syntax(NULL, NULL, form, "bad syntax (empty form)");
    return NULL;
  }

  check_form(form, form);

  if (zero)
    env = scheme_no_defines(env);

  if (SCHEME_STX_NULLP(SCHEME_STX_CDR(forms))) {
    scheme_rec_add_certs(rec, drec, form);
    forms = SCHEME_STX_CAR(forms);
    return scheme_compile_expr(forms, env, rec, drec);
  }

  if (!scheme_is_toplevel(env)) {
    /* Not at top-level */
    if (zero) {
      /* First expression is not part of the block: */
      Scheme_Compile_Info recs[2];
      Scheme_Object *first, *rest, *vname;

      vname = rec[drec].value_name;
      scheme_compile_rec_done_local(rec, drec);

      vname = scheme_check_name_property(form, vname);

      scheme_rec_add_certs(rec, drec, form);

      scheme_init_compile_recs(rec, drec, recs, 2);
      recs[0].value_name = vname;

      first = SCHEME_STX_CAR(forms);
      first = scheme_compile_expr(first, env, recs, 0);
      rest = SCHEME_STX_CDR(forms);
      rest = scheme_compile_list(rest, env, recs, 1);
      
      scheme_merge_compile_recs(rec, drec, recs, 2);

      body = cons(first, rest);
    } else {
      Scheme_Object *v;
      v = scheme_check_name_property(form, rec[drec].value_name);
      rec[drec].value_name = v;
      scheme_rec_add_certs(rec, drec, form);

      body = scheme_compile_list(forms, env, rec, drec);
    }
  } else {
    /* Top level */
    scheme_rec_add_certs(rec, drec, form);
    body = scheme_compile_list(forms, env, rec, drec);
  }

  forms = scheme_make_sequence_compilation(body, zero ? -1 : 1);

  if (!zero
      && SAME_TYPE(SCHEME_TYPE(forms), scheme_sequence_type)
      && scheme_is_toplevel(env)) {
    return scheme_make_syntax_compiled(SPLICE_EXPD, forms);
  }

  if (!zero || (NOT_SAME_TYPE(SCHEME_TYPE(forms), scheme_begin0_sequence_type)))
    return forms;

  return scheme_make_syntax_compiled(BEGIN0_EXPD, forms);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * do_define_syntaxes_execute ( Scheme_Object expr,
Scheme_Env dm_env,
int  for_stx 
) [static]

Definition at line 5314 of file syntax.c.

{
  Scheme_Thread *p = scheme_current_thread;
  Resolve_Prefix *rp;
  Scheme_Object *base_stack_depth, *dummy;
  int depth;
  Scheme_Comp_Env *rhs_env;

  rp = (Resolve_Prefix *)SCHEME_VEC_ELS(form)[1];
  base_stack_depth = SCHEME_VEC_ELS(form)[2];

  depth = SCHEME_INT_VAL(base_stack_depth) + rp->num_stxes + 1;
  if (!scheme_check_runstack(depth)) {
    p->ku.k.p1 = form;

    if (!dm_env) {
      /* Need to get env before we enlarge the runstack: */
      dummy = SCHEME_VEC_ELS(form)[3];
      dm_env = scheme_environment_from_dummy(dummy);
    }
    p->ku.k.p2 = (Scheme_Object *)dm_env;
    p->ku.k.i1 = for_stx;

    return (Scheme_Object *)scheme_enlarge_runstack(depth, define_syntaxes_execute_k);
  }

  dummy = SCHEME_VEC_ELS(form)[3];

  rhs_env = scheme_new_comp_env(scheme_get_env(NULL), NULL, SCHEME_TOPLEVEL_FRAME);

  if (!dm_env)
    dm_env = scheme_environment_from_dummy(dummy);

  {
    Scheme_Dynamic_State dyn_state;
    Scheme_Cont_Frame_Data cframe;
    Scheme_Config *config;
    Scheme_Object *result;

    scheme_prepare_exp_env(dm_env);

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

    scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, scheme_false, NULL, dm_env, dm_env->link_midx);
    result = define_execute_with_dynamic_state(form, 4, for_stx ? 2 : 1, rp, dm_env, &dyn_state);

    scheme_pop_continuation_frame(&cframe);

    return result;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_define_syntaxes_jit ( Scheme_Object expr,
int  jit 
) [static]

Definition at line 5382 of file syntax.c.

{
  Resolve_Prefix *rp, *orig_rp;
  Scheme_Object *naya, *rhs;
  
  rhs = SCHEME_VEC_ELS(expr)[0];
  if (jit)
    naya = scheme_jit_expr(rhs);
  else
    naya = rhs;

  orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(expr)[1];
  rp = scheme_prefix_eval_clone(orig_rp);
  
  if (SAME_OBJ(naya, rhs)
      && SAME_OBJ(orig_rp, rp))
    return expr;
  else {
    expr = clone_vector(expr, 0);
    SCHEME_VEC_ELS(expr)[0] = naya;
    SCHEME_VEC_ELS(expr)[1] = (Scheme_Object *)rp;
    return expr;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_define_syntaxes_optimize ( Scheme_Object data,
Optimize_Info info,
int  for_stx 
) [static]

Definition at line 5492 of file syntax.c.

{
  Scheme_Object *cp, *names, *val, *dummy;
  Optimize_Info *einfo;

  cp = SCHEME_CAR(data);
  data = SCHEME_CDDR(data);
  dummy = SCHEME_CAR(data);
  data = SCHEME_CDR(data);

  names = SCHEME_CAR(data);
  val = SCHEME_CDR(data);

  einfo = scheme_optimize_info_create();
  if (info->inline_fuel < 0)
    einfo->inline_fuel = -1;

  val = scheme_optimize_expr(val, einfo);

  return scheme_make_syntax_compiled((for_stx ? DEFINE_FOR_SYNTAX_EXPD : DEFINE_SYNTAX_EXPD), 
                                 cons(cp,
                                          cons(dummy,
                                               cons(names, val))));
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_define_syntaxes_resolve ( Scheme_Object data,
Resolve_Info info,
int  for_stx 
) [static]

Definition at line 5527 of file syntax.c.

{
  Comp_Prefix *cp;
  Resolve_Prefix *rp;
  Scheme_Object *names, *val, *base_stack_depth, *dummy, *vec;
  Resolve_Info *einfo;
  int len;

  cp = (Comp_Prefix *)SCHEME_CAR(data);
  data = SCHEME_CDR(data);
  dummy = SCHEME_CAR(data);
  data = SCHEME_CDR(data);

  names = SCHEME_CAR(data);
  val = SCHEME_CDR(data);

  rp = scheme_resolve_prefix(1, cp, 1);

  dummy = scheme_resolve_expr(dummy, info);

  einfo = scheme_resolve_info_create(rp);

  if (for_stx)
    names = scheme_resolve_list(names, einfo);
  val = scheme_resolve_expr(val, einfo);

  rp = scheme_remap_prefix(rp, einfo);

  base_stack_depth = scheme_make_integer(einfo->max_let_depth);

  len = scheme_list_length(names);
  
  vec = scheme_make_vector(len + 4, NULL);
  SCHEME_VEC_ELS(vec)[0] = val;
  SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)rp;
  SCHEME_VEC_ELS(vec)[2] = base_stack_depth;
  SCHEME_VEC_ELS(vec)[3] = dummy;

  len = 4;
  while (SCHEME_PAIRP(names)) {
    SCHEME_VEC_ELS(vec)[len++] = SCHEME_CAR(names);
    names = SCHEME_CDR(names);
  }

  return scheme_make_syntax_resolved((for_stx ? DEFINE_FOR_SYNTAX_EXPD : DEFINE_SYNTAX_EXPD), 
                                 vec);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_define_syntaxes_sfs ( Scheme_Object data,
SFS_Info info 
) [static]

Definition at line 5585 of file syntax.c.

{
  Scheme_Object *e;

  if (!info->pass) {
    int depth;
    depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[2]);
    info = scheme_new_sfs_info(depth);
    e = scheme_sfs(SCHEME_VEC_ELS(data)[0], info, depth);
    SCHEME_VEC_ELS(data)[0] = e;
  }

  return data;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 5618 of file syntax.c.

{
  Scheme_Object *names, *code, *dummy;
  Scheme_Object *val;
  Scheme_Comp_Env *exp_env;
  Scheme_Compile_Info rec1;

  scheme_compile_rec_done_local(rec, drec);
  scheme_default_compile_rec(rec, drec);
  scheme_rec_add_certs(rec, drec, form);
      
  scheme_define_parse(form, &names, &code, 1, env, 0);

  scheme_prepare_exp_env(env->genv);
  scheme_prepare_compile_env(env->genv->exp_env);

  if (!for_stx)
    names = scheme_named_map_1(NULL, stx_val, names, (Scheme_Object *)env->genv);

  exp_env = scheme_new_comp_env(env->genv->exp_env, env->insp, 0);

  dummy = scheme_make_environment_dummy(env);
  
  rec1.comp = 1;
  rec1.dont_mark_local_use = 0;
  rec1.resolve_module_ids = 0;
  rec1.no_module_cert = 0;
  rec1.value_name = NULL;
  rec1.certs = rec[drec].certs;
  rec1.observer = NULL;
  rec1.pre_unwrapped = 0;
  rec1.env_already = 0;
  rec1.comp_flags = rec[drec].comp_flags;

  if (for_stx) {
    names = defn_targets_syntax(names, exp_env, &rec1, 0);
    scheme_compile_rec_done_local(&rec1, 0);
  }

  val = scheme_compile_expr_lift_to_let(code, exp_env, &rec1, 0);

  return scheme_make_syntax_compiled((for_stx ? DEFINE_FOR_SYNTAX_EXPD : DEFINE_SYNTAX_EXPD), 
                                 cons((Scheme_Object *)exp_env->prefix, 
                                     cons(scheme_make_integer(0),
                                          cons(dummy,
                                              cons(names, val)))));
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void do_define_syntaxes_validate ( Scheme_Object data,
Mz_CPort *  port,
char *  stack,
Validate_TLS  tls,
int  depth,
int  letlimit,
int  delta,
int  num_toplevels,
int  num_stxes,
int  num_lifts,
int  for_stx 
) [static]

Definition at line 5422 of file syntax.c.

{
  Resolve_Prefix *rp;
  Scheme_Object *name, *val, *base_stack_depth, *dummy;
  int sdepth;

  if (!SCHEME_VECTORP(data)
      || (SCHEME_VEC_SIZE(data) < 4))
    scheme_ill_formed_code(port);

  rp = (Resolve_Prefix *)SCHEME_VEC_ELS(data)[1];
  base_stack_depth = SCHEME_VEC_ELS(data)[2];
  sdepth = SCHEME_INT_VAL(base_stack_depth);

  if (!SAME_TYPE(rp->so.type, scheme_resolve_prefix_type)
      || (sdepth < 0))
    scheme_ill_formed_code(port);

  dummy = SCHEME_VEC_ELS(data)[3];

  if (!for_stx) {
    int i, size;
    size = SCHEME_VEC_SIZE(data);
    for (i = 4; i < size; i++) {
      name = SCHEME_VEC_ELS(data)[i];
      if (!SCHEME_SYMBOLP(name)) {
       scheme_ill_formed_code(port);
      }
    }
  }

  scheme_validate_toplevel(dummy, port, stack, tls, depth, delta, 
                           num_toplevels, num_stxes, num_lifts,
                           0);
  
  if (!for_stx) {
    scheme_validate_code(port, SCHEME_VEC_ELS(data)[0], sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts, 0);
  } else {
    /* Make a fake `define-values' to check with respect to the exp-time stack */
    val = clone_vector(data, 3);
    SCHEME_VEC_ELS(val)[0] = SCHEME_VEC_ELS(data)[0];
    val = scheme_make_syntax_resolved(DEFINE_VALUES_EXPD, val);
    scheme_validate_code(port, val, sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts, 0);
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_let_expand ( Scheme_Object form,
Scheme_Comp_Env origenv,
Scheme_Expand_Info erec,
int  drec,
const char *  formname,
int  letrec,
int  multi,
int  letstar,
Scheme_Comp_Env env_already 
) [static]

Definition at line 4400 of file syntax.c.

{
  Scheme_Object *vars, *body, *first, *last, *name, *v, *vs, *vlist, *boundname;
  Scheme_Comp_Env *use_env, *env;
  Scheme_Expand_Info erec1;
  DupCheckRecord r;
  int rec_env_already = erec[drec].env_already;

  vars = SCHEME_STX_CDR(form);

  if (!SCHEME_STX_PAIRP(vars))
    scheme_wrong_syntax(NULL, NULL, form, NULL);

  body = SCHEME_STX_CDR(vars);
  vars = SCHEME_STX_CAR(vars);

  if (!SCHEME_STX_PAIRP(body))
    scheme_wrong_syntax(NULL, NULL, form, (SCHEME_STX_NULLP(body) 
                                      ? "bad syntax (empty body)" 
                                      : NULL));

  boundname = scheme_check_name_property(form, erec[drec].value_name);
  erec[drec].value_name = boundname;

  scheme_rec_add_certs(erec, drec, form);
  
  if (letstar) {
    if (!SCHEME_STX_NULLP(vars)) {
      Scheme_Object *a, *vr;

      if (!SCHEME_STX_PAIRP(vars))
       scheme_wrong_syntax(NULL, vars, form, NULL);

      a = SCHEME_STX_CAR(vars);
      vr = SCHEME_STX_CDR(vars);
      
      first = let_values_symbol;
      first = scheme_datum_to_syntax(first, form, scheme_sys_wraps(origenv), 0, 0);
      
      if (SCHEME_STX_NULLP(vr)) {
       /* Don't create redundant empty let form */
      } else {
       last = let_star_values_symbol;
       last = scheme_datum_to_syntax(last, form, scheme_sys_wraps(origenv), 0, 0);
       body = cons(cons(last, cons(vr, body)),
                   scheme_null);
      }
      
      body = cons(first,
                 cons(cons(a, scheme_null),
                      body));
    } else {
      first = scheme_datum_to_syntax(let_values_symbol, form, scheme_sys_wraps(origenv), 0, 0);
      body = cons(first, cons(scheme_null, body));
    }
    
    body = scheme_datum_to_syntax(body, form, form, 0, -1);

    first = SCHEME_STX_CAR(form);
    body = scheme_stx_track(body, form, first);
    
    if (erec[drec].depth > 0)
      --erec[drec].depth;
    
    if (!erec[drec].depth)
      return body;
    else {
      env = scheme_no_defines(origenv);
      return scheme_expand_expr(body, env, erec, drec);
    }
  }
  
  /* Note: no more letstar handling needed after this point */
  if (!env_already && !rec_env_already)
    scheme_begin_dup_symbol_check(&r, origenv);

  vlist = scheme_null;
  vs = vars;
  while (SCHEME_STX_PAIRP(vs)) {
    Scheme_Object *v2;
    v = SCHEME_STX_CAR(vs);
    if (SCHEME_STX_PAIRP(v))
      v2 = SCHEME_STX_CDR(v);
    else
      v2 = scheme_false;
    if (!SCHEME_STX_PAIRP(v2) || !SCHEME_STX_NULLP(SCHEME_STX_CDR(v2)))
      scheme_wrong_syntax(NULL, v, form, NULL);

    name = SCHEME_STX_CAR(v);
  
    {
      DupCheckRecord r2;
      Scheme_Object *names = name;
      if (!env_already && !rec_env_already)
        scheme_begin_dup_symbol_check(&r2, origenv);
      while (SCHEME_STX_PAIRP(names)) {
       name = SCHEME_STX_CAR(names);

       scheme_check_identifier(NULL, name, NULL, origenv, form);
       vlist = cons(name, vlist);

        if (!env_already && !rec_env_already) {
          scheme_dup_symbol_check(&r2, NULL, name, "clause binding", form);
          scheme_dup_symbol_check(&r, NULL, name, "binding", form);
        }
       
       names = SCHEME_STX_CDR(names);
      }
      if (!SCHEME_STX_NULLP(names))
       scheme_wrong_syntax(NULL, names, form, NULL);
    }

    vs = SCHEME_STX_CDR(vs);
  }

  if (!SCHEME_STX_NULLP(vs))
    scheme_wrong_syntax(NULL, vs, form, NULL);

  if (env_already)
    env = env_already;
  else
    env = scheme_add_compilation_frame(vlist, 
                                       origenv, 
                                       (rec_env_already ? SCHEME_INTDEF_SHADOW : 0),
                                       erec[drec].certs);

  if (letrec)
    use_env = env;
  else
    use_env = scheme_no_defines(origenv);

  /* Pass 1: Rename */

  first = last = NULL;
  vs = vars;
  while (SCHEME_STX_PAIRP(vars)) {
    Scheme_Object *rhs;

    v = SCHEME_STX_CAR(vars);

    /* Make sure names gets their own renames: */
    name = SCHEME_STX_CAR(v);
    name = scheme_add_env_renames(name, env, origenv);

    rhs = SCHEME_STX_CDR(v);
    rhs = SCHEME_STX_CAR(rhs);
    rhs = scheme_add_env_renames(rhs, use_env, origenv);
    
    v = scheme_datum_to_syntax(cons(name, cons(rhs, scheme_null)), v, v, 0, 1);
    v = cons(v, scheme_null);

    if (!first)
      first = v;
    else
      SCHEME_CDR(last) = v;

    last = v;
    vars = SCHEME_STX_CDR(vars);
  }
  if (!first) {
    first = scheme_null;
  }
  vars = first;

  body = scheme_datum_to_syntax(body, form, form, 0, 0);
  body = scheme_add_env_renames(body, env, origenv);
  SCHEME_EXPAND_OBSERVE_LET_RENAMES(erec[drec].observer, vars, body);

  /* Pass 2: Expand */

  first = last = NULL;
  while (SCHEME_STX_PAIRP(vars)) {
    Scheme_Object *rhs, *rhs_name;

    SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);

    v = SCHEME_STX_CAR(vars);

    name = SCHEME_STX_CAR(v);
    rhs = SCHEME_STX_CDR(v);
    rhs = SCHEME_STX_CAR(rhs);
    
    if (SCHEME_STX_PAIRP(name) && SCHEME_STX_NULLP(SCHEME_STX_CDR(name))) {
      rhs_name = SCHEME_STX_CAR(name);
    } else {
      rhs_name = scheme_false;
    }

    scheme_init_expand_recs(erec, drec, &erec1, 1);
    erec1.value_name = rhs_name;
    rhs = scheme_expand_expr(rhs, use_env, &erec1, 0);

    v = scheme_datum_to_syntax(cons(name, cons(rhs, scheme_null)), v, v, 0, 1);
    v = cons(v, scheme_null);

    if (!first)
      first = v;
    else
      SCHEME_CDR(last) = v;

    last = v;

    vars = SCHEME_STX_CDR(vars);
  }

  /* End Pass 2 */

  if (!SCHEME_STX_NULLP(vars))
    scheme_wrong_syntax(NULL, vars, form, NULL);
  
  if (!first)
    first = scheme_null;

  first = scheme_datum_to_syntax(first, vs, vs, 0, 1);
  
  SCHEME_EXPAND_OBSERVE_NEXT_GROUP(erec[drec].observer);
  scheme_init_expand_recs(erec, drec, &erec1, 1);
  erec1.value_name = erec[drec].value_name;
  body = scheme_expand_block(body, env, &erec1, 0);
  
  v = SCHEME_STX_CAR(form);
  v = cons(v, cons(first, body));
  v = scheme_datum_to_syntax(v, form, form, 0, 2);

  return v;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_letrec_syntaxes ( const char *  where,
Scheme_Object forms,
Scheme_Comp_Env origenv,
Scheme_Compile_Info rec,
int  drec 
) [static]

Definition at line 5936 of file syntax.c.

{
  Scheme_Object *form, *bindings, *var_bindings, *body, *v;
  Scheme_Object *names_to_disappear;
  Scheme_Comp_Env *stx_env, *var_env, *rhs_env;
  int cnt, stx_cnt, var_cnt, i, j, depth, saw_var, env_already;
  DupCheckRecord r;

  env_already = rec[drec].env_already;

  form = SCHEME_STX_CDR(forms);
  if (!SCHEME_STX_PAIRP(form))
    scheme_wrong_syntax(NULL, NULL, forms, NULL);
  bindings = SCHEME_STX_CAR(form);
  form = SCHEME_STX_CDR(form);
  if (!SCHEME_STX_PAIRP(form))
    scheme_wrong_syntax(NULL, NULL, forms, NULL);
  var_bindings = SCHEME_STX_CAR(form);
  form = SCHEME_STX_CDR(form);
  if (!SCHEME_STX_PAIRP(form))
    scheme_wrong_syntax(NULL, NULL, forms, NULL);
  body = scheme_datum_to_syntax(form, forms, forms, 0, 0);

  scheme_rec_add_certs(rec, drec, forms);

  if (env_already)
    stx_env = origenv;
  else
    stx_env = scheme_new_compilation_frame(0, 0, origenv, rec[drec].certs);

  rhs_env = stx_env;

  if (!SCHEME_STX_NULLP(bindings) && !SCHEME_STX_PAIRP(bindings)) {
    scheme_wrong_syntax(NULL, bindings, forms, "bad syntax (not a binding sequence)");
  } else
    check_form(bindings, forms);
  if (!SCHEME_STX_NULLP(var_bindings) && !SCHEME_STX_PAIRP(var_bindings)) {
    scheme_wrong_syntax(NULL, var_bindings, forms, "bad syntax (not a binding sequence)");
  } else
    check_form(var_bindings, forms);

  cnt = stx_cnt = var_cnt = 0;
  saw_var = 0;

  depth = rec[drec].depth;

  if (!rec[drec].comp && (depth <= 0) && (depth > -2))
    names_to_disappear = scheme_null;
  else
    names_to_disappear = NULL;

  if (!env_already)
    scheme_begin_dup_symbol_check(&r, stx_env);

  /* Pass 1: Check and Rename */

  for (i = 0; i < 2 ; i++) {
    for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
      Scheme_Object *a, *l;

      a = SCHEME_STX_CAR(v);
      if (!SCHEME_STX_PAIRP(a)
         || !SCHEME_STX_PAIRP(SCHEME_STX_CDR(a)))
       v = NULL;
      else {
       for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
         if (!SCHEME_STX_SYMBOLP(SCHEME_STX_CAR(l)))
           break;
       }
       if (!SCHEME_STX_NULLP(l))
         v = NULL;
      }

      if (v) {
       Scheme_Object *rest;
       rest = SCHEME_STX_CDR(a);
       if (!SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))
         v = NULL;
      }

      if (!v)
       scheme_wrong_syntax(NULL, a, forms, 
                         "bad syntax (binding clause not an identifier sequence and expression)");

      for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
       a = SCHEME_STX_CAR(l);
        if (!env_already) {
          scheme_check_identifier(where, a, NULL, stx_env, forms);
          scheme_dup_symbol_check(&r, where, a, "binding", forms);
        }
       cnt++;
      }
      if (i)
       saw_var = 1;
    }

    if (!i)
      stx_cnt = cnt;
    else
      var_cnt = cnt - stx_cnt;
  }

  if (!env_already)
    scheme_add_local_syntax(stx_cnt, stx_env);
  
  if (saw_var) {
    var_env = scheme_new_compilation_frame(var_cnt, 
                                           (env_already ? SCHEME_INTDEF_SHADOW : 0), 
                                           stx_env, 
                                           rec[drec].certs);
  } else
    var_env = NULL;

  for (i = (env_already ? 1 : 0); i < (var_env ? 2 : 1) ; i++) {
    cnt = (i ? var_cnt : stx_cnt);
    if (cnt > 0) {
      /* Add new syntax/variable names to the environment: */
      j = 0;
      for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
        Scheme_Object *a, *l;
       
        a = SCHEME_STX_CAR(v);
        for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
          a = SCHEME_STX_CAR(l);
          if (i) {
            /* In compile mode, this will get re-written by the letrec compiler.
               But that's ok. We need it now for env_renames. */
            scheme_add_compilation_binding(j++, a, var_env);
          } else
            scheme_set_local_syntax(j++, a, NULL, stx_env);
        }
      }
    }
  }

  if (names_to_disappear) {
    for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
      Scheme_Object *a, *names;

      a = SCHEME_STX_CAR(v);
      names = SCHEME_STX_CAR(a);
      while (!SCHEME_STX_NULLP(names)) {
        a = SCHEME_STX_CAR(names);
        if (names_to_disappear)
          names_to_disappear = cons(a, names_to_disappear);
        names = SCHEME_STX_CDR(names);
      }
    }
  }
  
  bindings = scheme_add_env_renames(bindings, stx_env, origenv);
  if (var_env)
    bindings = scheme_add_env_renames(bindings, var_env, origenv);
  if (var_env)
    var_bindings = scheme_add_env_renames(var_bindings, stx_env, origenv);

  body = scheme_add_env_renames(body, stx_env, origenv);
  SCHEME_EXPAND_OBSERVE_LETREC_SYNTAXES_RENAMES(rec[drec].observer, bindings, var_bindings, body);
  
  scheme_prepare_exp_env(stx_env->genv);
  scheme_prepare_compile_env(stx_env->genv->exp_env);

  if (!env_already) {
    i = 0;

    for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
      Scheme_Object *a, *names;

      SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);

      a = SCHEME_STX_CAR(v);
      names = SCHEME_STX_CAR(a);
      a = SCHEME_STX_CDR(a);
      a = SCHEME_STX_CAR(a);

      scheme_bind_syntaxes(where, names, a,
                           stx_env->genv->exp_env,
                           stx_env->insp,
                           rec, drec,
                           stx_env, rhs_env, 
                           &i, NULL);
    }
  }

  SCHEME_EXPAND_OBSERVE_NEXT_GROUP(rec[drec].observer);

  if (!env_already && names_to_disappear) {
    /* Need to add renaming for disappeared bindings. If they
       originated for internal definitions, then we need both
       pre-renamed and renamed, since some might have been
       expanded to determine definitions. */
    Scheme_Object *l, *a, *pf = NULL, *pl = NULL;

    if (origenv->flags & SCHEME_FOR_INTDEF) {
      for (l = names_to_disappear; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
        a = SCHEME_CAR(l);
        a = cons(a, scheme_null);
        if (pl)
          SCHEME_CDR(pl) = a;
        else
          pf = a;
        pl = a;
      }
    }

    for (l = names_to_disappear; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
      a = SCHEME_CAR(l);
      a = scheme_add_env_renames(a, stx_env, origenv);
      SCHEME_CAR(l) = a;
    }

    if (pf) {
      SCHEME_CDR(pl) = names_to_disappear;
      names_to_disappear = pf;
    }
  }

  if (!var_env) {
    var_env = scheme_require_renames(stx_env);
    if (rec[drec].comp) {
      v = scheme_check_name_property(forms, rec[drec].value_name);
      rec[drec].value_name = v;
      v = scheme_compile_block(body, var_env, rec, drec);
      v = scheme_make_sequence_compilation(v, 1);
    } else {
      v = scheme_expand_block(body, var_env, rec, drec);
      if ((depth >= 0) || (depth == -2)) {
       Scheme_Object *formname;
       formname = SCHEME_STX_CAR(forms);
       v = cons(formname, cons(bindings, cons(var_bindings, v)));
      } else {
       v = cons(let_values_symbol, cons(scheme_null, v));
      }

      if (SCHEME_PAIRP(v))
       v = scheme_datum_to_syntax(v, forms, scheme_sys_wraps(origenv), 
                               0, 2);

      if (!((depth >= 0) || (depth == -2))) {
        SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer,v);
      }
    }
  } else {
    /* Construct letrec-values expression: */
    v = cons(letrec_values_symbol, cons(var_bindings, body));
    v = scheme_datum_to_syntax(v, forms, scheme_sys_wraps(origenv), 0, 2);
    
    if (rec[drec].comp) {
      v = gen_let_syntax(v, stx_env, "letrec-values", 0, 1, 1, rec, drec, var_env);
    } else {
      SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(rec[drec].observer);
      v = do_let_expand(v, stx_env, rec, drec, "letrec-values", 1, 1, 0, var_env);
      
      if ((depth >= 0) || (depth == -2)) {
       /* Pull back out the pieces we want: */
       Scheme_Object *formname;
       formname = SCHEME_STX_CAR(forms);
       v = SCHEME_STX_CDR(v);
       v = cons(formname, cons(bindings, v));
       v = scheme_datum_to_syntax(v, forms, scheme_sys_wraps(origenv), 0, 2);
      } else {
        SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer,v);
      }
    }
  }

  /* Add the 'disappeared-binding property */
  if (names_to_disappear)
    v = scheme_stx_property(v, disappeared_binding_symbol, names_to_disappear);

  return v;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* eval_letmacro_rhs ( Scheme_Object a,
Scheme_Comp_Env rhs_env,
int  max_let_depth,
Resolve_Prefix rp,
int  phase,
Scheme_Object certs 
) [static]

Definition at line 5738 of file syntax.c.

{
  Scheme_Object **save_runstack;
  int depth;

  depth = max_let_depth + scheme_prefix_depth(rp);
  if (!scheme_check_runstack(depth)) {
    Scheme_Thread *p = scheme_current_thread;
    p->ku.k.p1 = a;
    p->ku.k.p2 = rhs_env;
    p->ku.k.p3 = rp;
    p->ku.k.p4 = certs;
    p->ku.k.i1 = max_let_depth;
    p->ku.k.i2 = phase;
    return (Scheme_Object *)scheme_enlarge_runstack(depth, eval_letmacro_rhs_k);
  }

  save_runstack = scheme_push_prefix(NULL, rp, NULL, NULL, phase, phase);

  if (scheme_omittable_expr(a, 1, -1, 0, NULL)) {
    /* short cut */
    a = _scheme_eval_linked_expr_multi(a);
  } else {
    Scheme_Cont_Frame_Data cframe;
    Scheme_Config *config;
    Scheme_Dynamic_State dyn_state;

    scheme_prepare_exp_env(rhs_env->genv);
    scheme_prepare_compile_env(rhs_env->genv->exp_env);

    config = scheme_extend_config(scheme_current_config(),
                                  MZCONFIG_ENV,
                                  (Scheme_Object *)rhs_env->genv->exp_env);
    scheme_push_continuation_frame(&cframe);
    scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
  
    scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, scheme_false, certs, rhs_env->genv, rhs_env->genv->link_midx);
    a = scheme_eval_linked_expr_multi_with_dynamic_state(a, &dyn_state);
    
    scheme_pop_continuation_frame(&cframe);
  }

  scheme_pop_prefix(save_runstack);

  return a;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void * eval_letmacro_rhs_k ( void  ) [static]

Definition at line 5787 of file syntax.c.

{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object *a, *certs; 
  Scheme_Comp_Env *rhs_env;
  int max_let_depth, phase;
  Resolve_Prefix *rp;

  a = (Scheme_Object *)p->ku.k.p1;
  rhs_env = (Scheme_Comp_Env *)p->ku.k.p2;
  rp = (Resolve_Prefix *)p->ku.k.p3;
  certs = (Scheme_Object *)p->ku.k.p4;
  max_let_depth = p->ku.k.i1;
  phase = p->ku.k.i2;

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

  return (void *)eval_letmacro_rhs(a, rhs_env, max_let_depth, rp, phase, certs);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 607 of file syntax.c.

{
  Scheme_Object *form = argv[0], *args, *fn;
  Scheme_Comp_Env *env;

  env = scheme_current_thread->current_local_env;

  lambda_check(form);
  
  args = SCHEME_STX_CDR(form);
  args = SCHEME_STX_CAR(args);

  lambda_check_args(args, form, env);

  fn = SCHEME_STX_CAR(form);
  fn = scheme_datum_to_syntax(lambda_symbol, fn, scheme_sys_wraps(env), 0, 0);
  
  args = SCHEME_STX_CDR(form);
  return scheme_datum_to_syntax(cons(fn, args), form, fn, 0, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int expr_size ( Scheme_Object o) [static]

Definition at line 2990 of file syntax.c.

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 5214 of file syntax.c.

{
  SCHEME_EXPAND_OBSERVE_PRIM_EXPRESSION(erec[drec].observer);
  return single_expand(form, scheme_no_defines(env), erec, drec, 0,
                       !(env->flags & SCHEME_TOPLEVEL_FRAME));
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 5209 of file syntax.c.

{
  return single_syntax(form, scheme_no_defines(env), rec, drec, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* gen_let_syntax ( Scheme_Object form,
Scheme_Comp_Env origenv,
char *  formname,
int  star,
int  recursive,
int  multi,
Scheme_Compile_Info rec,
int  drec,
Scheme_Comp_Env frame_already 
) [static]

Definition at line 4163 of file syntax.c.

{
  Scheme_Object *bindings, *l, *binding, *name, **names, *forms, *defname;
  int num_clauses, num_bindings, i, j, k, m, pre_k;
  Scheme_Comp_Env *frame, *env;
  Scheme_Compile_Info *recs;
  Scheme_Object *first = NULL;
  Scheme_Compiled_Let_Value *last = NULL, *lv;
  DupCheckRecord r;
  int rec_env_already = rec[drec].env_already;

  i = scheme_stx_proper_list_length(form);
  if (i < 3)
    scheme_wrong_syntax(NULL, NULL, form, (!i ? "bad syntax (empty body)" : NULL));

  bindings = SCHEME_STX_CDR(form);
  bindings = SCHEME_STX_CAR(bindings);
  num_clauses = scheme_stx_proper_list_length(bindings);

  if (num_clauses < 0)
    scheme_wrong_syntax(NULL, bindings, form, NULL);

  scheme_rec_add_certs(rec, drec, form);

  forms = SCHEME_STX_CDR(form);
  forms = SCHEME_STX_CDR(forms);
  forms = scheme_datum_to_syntax(forms, form, form, 0, 0);

  if (!num_clauses) {
    env = scheme_no_defines(origenv);

    name = scheme_check_name_property(form, rec[drec].value_name);
    rec[drec].value_name = name;

    return scheme_compile_sequence(forms, env, rec, drec);
  }
  
  if (multi) {
    num_bindings = 0;
    l = bindings;
    while (!SCHEME_STX_NULLP(l)) {
      Scheme_Object *clause, *names, *rest;
      int num_names;

      clause = SCHEME_STX_CAR(l);
      
      if (!SCHEME_STX_PAIRP(clause))
       rest = NULL;
      else {
       rest = SCHEME_STX_CDR(clause);
       if (!SCHEME_STX_PAIRP(rest))
         rest = NULL;
       else {
         rest = SCHEME_STX_CDR(rest);
         if (!SCHEME_STX_NULLP(rest))
           rest = NULL;
       }
      }
      if (!rest)
       scheme_wrong_syntax(NULL, clause, form, NULL);
      
      names = SCHEME_STX_CAR(clause);
      
      num_names = scheme_stx_proper_list_length(names);
      if (num_names < 0)
       scheme_wrong_syntax(NULL, names, form, NULL);
     
      num_bindings += num_names;
 
      l = SCHEME_STX_CDR(l);
    }
  } else
    num_bindings = num_clauses;


  names = MALLOC_N(Scheme_Object *, num_bindings);
  if (frame_already)
    frame = frame_already;
  else {
    frame = scheme_new_compilation_frame(num_bindings, 
                                         (rec_env_already ? SCHEME_INTDEF_SHADOW : 0),
                                         origenv, 
                                         rec[drec].certs);
    if (rec_env_already)
      frame_already = frame;
  }
  env = frame;

  recs = MALLOC_N_RT(Scheme_Compile_Info, (num_clauses + 1));

  defname = rec[drec].value_name;
  scheme_compile_rec_done_local(rec, drec);
  scheme_init_compile_recs(rec, drec, recs, num_clauses + 1);

  defname = scheme_check_name_property(form, defname);
  
  if (!star && !frame_already) {
    scheme_begin_dup_symbol_check(&r, env);
  }

  for (i = 0, k = 0; i < num_clauses; i++) {
    if (!SCHEME_STX_PAIRP(bindings))
      scheme_wrong_syntax(NULL, bindings, form, NULL);
    binding = SCHEME_STX_CAR(bindings);
    if (!SCHEME_STX_PAIRP(binding) || !SCHEME_STX_PAIRP(SCHEME_STX_CDR(binding)))
      scheme_wrong_syntax(NULL, binding, form, NULL);

    {
      Scheme_Object *rest;
      rest = SCHEME_STX_CDR(binding);
      if (!SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))
       scheme_wrong_syntax(NULL, binding, form, NULL);
    }
    
    pre_k = k;

    name = SCHEME_STX_CAR(binding);
    if (multi) {
      while (!SCHEME_STX_NULLP(name)) {
       Scheme_Object *n;
       n = SCHEME_STX_CAR(name);
       names[k] = n;
       scheme_check_identifier(NULL, names[k], NULL, env, form);
       k++;
       name = SCHEME_STX_CDR(name);
      }

      for (j = pre_k; j < k; j++) {
       for (m = j + 1; m < k; m++) {
         if (scheme_stx_bound_eq(names[m], names[j], scheme_make_integer(env->genv->phase)))
           scheme_wrong_syntax(NULL, NULL, form,
                            "multiple bindings of `%S' in the same clause", 
                            SCHEME_STX_SYM(names[m]));
       }
      }
    } else {
      scheme_check_identifier(NULL, name, NULL, env, form);
      names[k++] = name;
    }
    
    if (!star && !frame_already) {
      for (m = pre_k; m < k; m++) {
       scheme_dup_symbol_check(&r, NULL, names[m], "binding", form);
      }
    }

    lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value);
    lv->so.type = scheme_compiled_let_value_type;
    if (!last)
      first = (Scheme_Object *)lv;
    else
      last->body = (Scheme_Object *)lv;
    last = lv;
    lv->count = (k - pre_k);
    lv->position = pre_k;

    if (lv->count == 1)
      recs[i].value_name = SCHEME_STX_SYM(names[pre_k]);

    if (!recursive) {
      Scheme_Object *ce, *rhs;
      rhs = SCHEME_STX_CDR(binding);
      rhs = SCHEME_STX_CAR(rhs);
      rhs = scheme_add_env_renames(rhs, env, origenv);
      ce = scheme_compile_expr(rhs, env, recs, i);
      lv->value = ce;
    } else {
      Scheme_Object *rhs;
      rhs = SCHEME_STX_CDR(binding);
      rhs = SCHEME_STX_CAR(rhs);
      lv->value = rhs;
    }
    
    if (star || recursive) {
      for (m = pre_k; m < k; m++) {
       scheme_add_compilation_binding(m, names[m], frame);
      }
    }
    
    bindings = SCHEME_STX_CDR(bindings);
  }
  
  if (!star && !recursive) {
    for (i = 0; i < num_bindings; i++) {
      scheme_add_compilation_binding(i, names[i], frame);
    }
  }

  if (recursive) {
    lv = (Scheme_Compiled_Let_Value *)first;
    for (i = 0; i < num_clauses; i++, lv = (Scheme_Compiled_Let_Value *)lv->body) {
      Scheme_Object *ce, *rhs;
      rhs = lv->value;
      rhs = scheme_add_env_renames(rhs, env, origenv);
      ce = scheme_compile_expr(rhs, env, recs, i);
      lv->value = ce;
    }
  }

  recs[num_clauses].value_name = defname ? SCHEME_STX_SYM(defname) : NULL;
  {
    Scheme_Object *cs;
    forms = scheme_add_env_renames(forms, env, origenv);
    cs = scheme_compile_sequence(forms, env, recs, num_clauses);
    last->body = cs;
  }

  /* Save flags: */
  lv = (Scheme_Compiled_Let_Value *)first;
  for (i = 0; i < num_clauses; i++, lv = (Scheme_Compiled_Let_Value *)lv->body) {
    int *flags;
    flags = scheme_env_get_flags(env, lv->position, lv->count);
    lv->flags = flags;
  }

  {
    Scheme_Let_Header *head;
    
    head = MALLOC_ONE_TAGGED(Scheme_Let_Header);
    head->iso.so.type = scheme_compiled_let_void_type;
    head->body = first;
    head->count = num_bindings;
    head->num_clauses = num_clauses;
    SCHEME_LET_FLAGS(head) = ((recursive ? SCHEME_LET_RECURSIVE : 0)
                              | (star ? SCHEME_LET_STAR : 0));

    first = (Scheme_Object *)head;
  }
  
  scheme_merge_compile_recs(rec, drec, recs, num_clauses + 1);

  return first;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int get_convert_arg_count ( Scheme_Object lift) [static]

Definition at line 3564 of file syntax.c.

{
  if (!lift)
    return 0;
  else if (SCHEME_RPAIRP(lift)) {
    Scheme_Object **ca;
    ca = (Scheme_Object **)SCHEME_CDR(lift);
    return SCHEME_INT_VAL(ca[0]);
  } else
    return 0;
}

Here is the caller graph for this function:

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

Definition at line 1319 of file syntax.c.

{
  Scheme_Object *test, *rest, *thenp, *elsep, *fn, *boundname;
  int len;
  Scheme_Expand_Info recs[3];

  SCHEME_EXPAND_OBSERVE_PRIM_IF(erec[drec].observer);

  len = check_form(form, form);

  check_if_len(form, len);

  if (len == 3) {
    SCHEME_EXPAND_OBSERVE_NEXT_GROUP(erec[drec].observer);
  }

  env = scheme_no_defines(env);

  boundname = scheme_check_name_property(form, erec[drec].value_name);

  scheme_rec_add_certs(erec, drec, form);  

  scheme_init_expand_recs(erec, drec, recs, 3);
  recs[0].value_name = scheme_false;
  recs[1].value_name = boundname;
  recs[2].value_name = boundname;

  rest = SCHEME_STX_CDR(form);
  test = SCHEME_STX_CAR(rest);
  test = scheme_expand_expr(test, env, recs, 0);

  SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
  rest = SCHEME_STX_CDR(rest);
  thenp = SCHEME_STX_CAR(rest);
  thenp = scheme_expand_expr(thenp, env, recs, 1);

  rest = SCHEME_STX_CDR(rest);
  if (!SCHEME_STX_NULLP(rest)) {
    SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer);
    elsep = SCHEME_STX_CAR(rest);
    elsep = scheme_expand_expr(elsep, env, recs, 2);
    rest = cons(elsep, scheme_null);
  } else {
    rest = scheme_null;
  }

  rest = cons(thenp, rest);

  fn = SCHEME_STX_CAR(form);
  return scheme_datum_to_syntax(cons(fn, cons(test, rest)),
                            form, form, 
                            0, 2);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 1248 of file syntax.c.

{
  int len, opt;
  Scheme_Object *test, *thenp, *elsep, *name, *rest;
  Scheme_Compile_Info recs[3];

  len = check_form(form, form);
  check_if_len(form, len);

  name = rec[drec].value_name;
  scheme_compile_rec_done_local(rec, drec);

  name = scheme_check_name_property(form, name);

  rest = SCHEME_STX_CDR(form);
  test = SCHEME_STX_CAR(rest);
  rest = SCHEME_STX_CDR(rest);
  thenp = SCHEME_STX_CAR(rest);
  if (len == 4) {
    rest = SCHEME_STX_CDR(rest);
    elsep = SCHEME_STX_CAR(rest);
  } else
    elsep = scheme_compiled_void();

  scheme_rec_add_certs(rec, drec, form);

  scheme_init_compile_recs(rec, drec, recs, 3);
  recs[1].value_name = name;
  recs[2].value_name = name;

  env = scheme_no_defines(env);

  test = scheme_compile_expr(test, env, recs, 0);

  if (SCHEME_TYPE(test) > _scheme_compiled_values_types_) {
    opt = 1;
    
    if (SCHEME_FALSEP(test)) {
      /* compile other branch only to get syntax checking: */
      recs[2].dont_mark_local_use = 1;
      scheme_compile_expr(thenp, env, recs, 2);

      if (len == 4)
       test = scheme_compile_expr(elsep, env, recs, 1);
      else
       test = elsep;
    } else {
      if (len == 4) {
       /* compile other branch only to get syntax checking: */
       recs[2].dont_mark_local_use = 1;
       scheme_compile_expr(elsep, env, recs, 2);
      }
      
      test = scheme_compile_expr(thenp, env, recs, 1);
    }
  } else {
    opt = 0;
    thenp = scheme_compile_expr(thenp, env, recs, 1);
    if (len == 4)
      elsep = scheme_compile_expr(elsep, env, recs, 2);
  }

  scheme_merge_compile_recs(rec, drec, recs, (opt || (len == 3)) ? 2 : 3);
  
  if (opt)
    return test;
  else
    return scheme_make_branch(test, thenp, elsep);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int is_closed_reference ( Scheme_Object v) [static]

Definition at line 3517 of file syntax.c.

{
  /* Look for a converted function (possibly with no new arguments)
     that is accessed directly as a closure, instead of through a
     top-level reference. */
  if (SCHEME_RPAIRP(v)) {
    v = SCHEME_CAR(v);
    return SCHEME_PROCP(v);
  }

  return 0;
}

Here is the caller graph for this function:

static int is_liftable ( Scheme_Object o,
int  bind_count,
int  fuel,
int  as_rator 
) [static]

Definition at line 2748 of file syntax.c.

{
  Scheme_Type t = SCHEME_TYPE(o);

  switch (t) {
  case scheme_compiled_unclosed_procedure_type:
    return !as_rator;
  case scheme_compiled_toplevel_type:
    return 1;
  case scheme_local_type:
    if (SCHEME_LOCAL_POS(o) > bind_count)
      return 1;
    break;
  case scheme_branch_type:
    if (fuel) {
      Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)o;
      if (is_liftable(b->test, bind_count, fuel - 1, 0)
         && is_liftable(b->tbranch, bind_count, fuel - 1, as_rator)
         && is_liftable(b->fbranch, bind_count, fuel - 1, as_rator))
       return 1;
    }
    break;
  case scheme_application_type:
    {
      Scheme_App_Rec *app = (Scheme_App_Rec *)o;
      int i;
      if (!is_liftable_prim(app->args[0]))
        return 0;
      if (bind_count >= 0)
        bind_count += app->num_args;
      for (i = app->num_args + 1; i--; ) {
       if (!is_liftable(app->args[i], bind_count, fuel - 1, 1))
         return 0;
      }
      return 1;
    }
  case scheme_application2_type:
    {
      Scheme_App2_Rec *app = (Scheme_App2_Rec *)o;
      if (!is_liftable_prim(app->rator))
        return 0;
      if (bind_count >= 0)
        bind_count += 1;
      if (is_liftable(app->rator, bind_count, fuel - 1, 1)
         && is_liftable(app->rand, bind_count, fuel - 1, 1))
       return 1;
    }
  case scheme_application3_type:
    {
      Scheme_App3_Rec *app = (Scheme_App3_Rec *)o;
      if (!is_liftable_prim(app->rator))
        return 0;
      if (bind_count >= 0)
        bind_count += 2;
      if (is_liftable(app->rator, bind_count, fuel - 1, 1)
         && is_liftable(app->rand1, bind_count, fuel - 1, 1)
         && is_liftable(app->rand2, bind_count, fuel - 1, 1))
       return 1;
    }
  default:
    if (t > _scheme_compiled_values_types_)
      return 1;
  }

  return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int is_liftable_prim ( Scheme_Object v) [static]

Definition at line 2737 of file syntax.c.

{
  if (SCHEME_PRIMP(v)) {
    if ((((Scheme_Primitive_Proc *)v)->pp.flags & SCHEME_PRIM_OPT_MASK)
        >= SCHEME_PRIM_OPT_IMMEDIATE)
      return 1;
  }

  return 0;
}

Here is the caller graph for this function:

static int is_lifted_reference ( Scheme_Object v) [static]

Definition at line 3508 of file syntax.c.

Here is the caller graph for this function:

static int is_values_apply ( Scheme_Object e) [static]

Definition at line 2880 of file syntax.c.

Here is the caller graph for this function:

static void lambda_check ( Scheme_Object form) [static]

Definition at line 507 of file syntax.c.

{
  if (SCHEME_STX_PAIRP(form)
      && SCHEME_STX_PAIRP(SCHEME_STX_CDR(form))) {
    Scheme_Object *rest;
    rest = SCHEME_STX_CDR(form);
    if (SCHEME_STX_PAIRP(SCHEME_STX_CDR(rest)))
      return;
  }

  scheme_wrong_syntax(NULL, NULL, form, NULL);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void lambda_check_args ( Scheme_Object args,
Scheme_Object form,
Scheme_Comp_Env env 
) [static]

Definition at line 520 of file syntax.c.

{
  Scheme_Object *v, *a;
  DupCheckRecord r;

  if (!SCHEME_STX_SYMBOLP(args)) {
    for (v = args; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
      a = SCHEME_STX_CAR(v);
      scheme_check_identifier(NULL, a, NULL, env, form);
    }

    if (!SCHEME_STX_NULLP(v)) {
      if (!SCHEME_STX_SYMBOLP(v)) {
       scheme_check_identifier(NULL, v, NULL, env, form);
      }
    }

    /* Check for duplicate names: */
    scheme_begin_dup_symbol_check(&r, env);
    for (v = args; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
      Scheme_Object *name;

      name = SCHEME_STX_CAR(v);
      scheme_dup_symbol_check(&r, NULL, name, "argument", form);
    }
    if (!SCHEME_STX_NULLP(v)) {
      scheme_dup_symbol_check(&r, NULL, v, "argument", form);
    }
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 568 of file syntax.c.

{
  Scheme_Object *args, *body, *fn;
  Scheme_Comp_Env *newenv;

  SCHEME_EXPAND_OBSERVE_PRIM_LAMBDA(erec[drec].observer);

  lambda_check(form);
  
  args = SCHEME_STX_CDR(form);
  args = SCHEME_STX_CAR(args);

  lambda_check_args(args, form, env);

  scheme_rec_add_certs(erec, drec, form);

  newenv = scheme_add_compilation_frame(args, env, 0, erec[drec].certs);

  body = SCHEME_STX_CDR(form);
  body = SCHEME_STX_CDR(body);
  body = scheme_datum_to_syntax(body, form, form, 0, 0);

  body = scheme_add_env_renames(body, newenv, env);

  args = scheme_add_env_renames(args, newenv, env); /* for re-expansion */
  SCHEME_EXPAND_OBSERVE_LAMBDA_RENAMES(erec[drec].observer, args, body);

  fn = SCHEME_STX_CAR(form);

  return scheme_datum_to_syntax(cons(fn,
                                  cons(args,
                                       scheme_expand_block(body,
                                                        newenv,
                                                        erec, 
                                                        drec))),
                            form, form, 
                            0, 2);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 552 of file syntax.c.

{
  Scheme_Object *args;

  lambda_check(form);

  args = SCHEME_STX_CDR(form);
  args = SCHEME_STX_CAR(args);
  lambda_check_args(args, form, env);

  scheme_rec_add_certs(rec, drec, form);

  return scheme_make_closure_compilation(env, form, rec, drec);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 4637 of file syntax.c.

{
  SCHEME_EXPAND_OBSERVE_PRIM_LETSTAR_VALUES(erec[drec].observer);
  return do_let_expand(form, env, erec, drec, "let*-values", 0, 1, 1, NULL);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 4659 of file syntax.c.

{
  return gen_let_syntax(form, env, "let*-values", 1, 0, 1, rec, drec, NULL);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 4630 of file syntax.c.

{
  SCHEME_EXPAND_OBSERVE_PRIM_LET_VALUES(erec[drec].observer);
  return do_let_expand(form, env, erec, drec, "let-values", 0, 1, 0, NULL);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 4652 of file syntax.c.

{
  return gen_let_syntax(form, env, "let-values", 0, 0, 1, rec, drec, NULL);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 6219 of file syntax.c.

{
  SCHEME_EXPAND_OBSERVE_PRIM_LETREC_SYNTAXES_VALUES(erec[drec].observer);

  return do_letrec_syntaxes("letrec-syntaxes+values", form, env, erec, drec);
}

Here is the call graph for this function: