Back to index

plt-scheme  4.2.1
Defines | Typedefs | Functions | Variables
module.c File Reference
#include "schpriv.h"
#include "mzrt.h"
#include "schmach.h"
#include "schexpobs.h"
#include "mzstkchk.h"

Go to the source code of this file.

Defines

#define mzrt_mutex_lock(l)   /* empty */
#define mzrt_mutex_unlock(l)   /* empty */
#define cons   scheme_make_pair
#define GLOBAL_SHIFT_CACHE_SIZE   40
#define SHIFT_CACHE_NULL   NULL
#define SHIFT_CACHE_NULLP(x)   !(x)
#define SCHEME_MODNAMEP(obj)   SAME_TYPE(SCHEME_TYPE(obj), scheme_resolved_module_path_type)
#define MODCHAIN_TABLE(p)   ((Scheme_Hash_Table *)(SCHEME_VEC_ELS(p)[0]))
#define MODCHAIN_AVAIL(p, n)   (SCHEME_VEC_ELS(p)[3+n])
#define LOG_ATTACH(x)   /* nothing */
#define show_indent(d)   /* nothing */
#define show(w, m, v1, v2, bp)   /* nothing */
#define show_done(w, m, v1, v2, bp)   /* nothing */
#define LOG_RUN_DECLS   /* empty */
#define LOG_START_RUN(mod)   /* empty */
#define LOG_END_RUN(mod)   /* empty */
#define LOG_EXPAND_DECLS   /* empty */
#define LOG_START_EXPAND(mod)   /* empty */
#define LOG_END_EXPAND(mod)   /* empty */
#define return_NULL()   return NULL

Typedefs

typedef void(* Check_Func )(Scheme_Object *prnt_name, Scheme_Object *name, Scheme_Object *nominal_modname, Scheme_Object *nominal_export, Scheme_Object *modname, Scheme_Object *srcname, int exet, int isval, void *data, Scheme_Object *e, Scheme_Object *form, Scheme_Object *err_src, Scheme_Object *mark_src, Scheme_Object *to_phase, Scheme_Object *src_phase_index, Scheme_Object *nominal_export_phase, Scheme_Object *in_insp)

Functions

static Scheme_Objectcurrent_module_name_resolver (int argc, Scheme_Object *argv[])
static Scheme_Objectcurrent_module_name_prefix (int argc, Scheme_Object *argv[])
static Scheme_Objectdynamic_require_for_syntax (int argc, Scheme_Object *argv[])
static Scheme_Objectnamespace_require (int argc, Scheme_Object *argv[])
static Scheme_Objectnamespace_require_copy (int argc, Scheme_Object *argv[])
static Scheme_Objectnamespace_require_constant (int argc, Scheme_Object *argv[])
static Scheme_Objectnamespace_require_etonly (int argc, Scheme_Object *argv[])
static Scheme_Objectnamespace_attach_module (int argc, Scheme_Object *argv[])
static Scheme_Objectnamespace_unprotect_module (int argc, Scheme_Object *argv[])
static Scheme_Objectmodule_compiled_p (int argc, Scheme_Object *argv[])
static Scheme_Objectmodule_compiled_name (int argc, Scheme_Object *argv[])
static Scheme_Objectmodule_compiled_imports (int argc, Scheme_Object *argv[])
static Scheme_Objectmodule_compiled_exports (int argc, Scheme_Object *argv[])
static Scheme_Objectmodule_compiled_lang_info (int argc, Scheme_Object *argv[])
static Scheme_Objectmodule_to_namespace (int argc, Scheme_Object *argv[])
static Scheme_Objectmodule_to_lang_info (int argc, Scheme_Object *argv[])
static Scheme_Objectmodule_path_index_p (int argc, Scheme_Object *argv[])
static Scheme_Objectmodule_path_index_resolve (int argc, Scheme_Object *argv[])
static Scheme_Objectmodule_path_index_split (int argc, Scheme_Object *argv[])
static Scheme_Objectmodule_path_index_join (int argc, Scheme_Object *argv[])
static Scheme_Objectis_module_path (int argc, Scheme_Object **argv)
static Scheme_Objectresolved_module_path_p (int argc, Scheme_Object *argv[])
static Scheme_Objectmake_resolved_module_path (int argc, Scheme_Object *argv[])
static Scheme_Objectresolved_module_path_name (int argc, Scheme_Object *argv[])
static Scheme_Objectmodule_export_protected_p (int argc, Scheme_Object **argv)
static Scheme_Objectmodule_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectmodule_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectmodule_begin_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectmodule_begin_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectrequire_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectrequire_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectprovide_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec)
static Scheme_Objectprovide_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec)
static Scheme_Objectmodule_execute (Scheme_Object *data)
static Scheme_Objecttop_level_require_execute (Scheme_Object *data)
static Scheme_Objectmodule_jit (Scheme_Object *data)
static Scheme_Objecttop_level_require_jit (Scheme_Object *data)
static Scheme_Objectmodule_optimize (Scheme_Object *data, Optimize_Info *info)
static Scheme_Objectmodule_resolve (Scheme_Object *data, Resolve_Info *info)
static Scheme_Objectmodule_sfs (Scheme_Object *data, SFS_Info *info)
static Scheme_Objecttop_level_require_optimize (Scheme_Object *data, Optimize_Info *info)
static Scheme_Objecttop_level_require_resolve (Scheme_Object *data, Resolve_Info *info)
static Scheme_Objecttop_level_require_sfs (Scheme_Object *data, SFS_Info *info)
static void module_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 top_level_require_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_Objectwrite_module (Scheme_Object *obj)
static Scheme_Objectread_module (Scheme_Object *obj)
static Scheme_Modulemodule_load (Scheme_Object *modname, Scheme_Env *env, const char *who)
static void run_module (Scheme_Env *menv, int set_ns)
static void run_module_exptime (Scheme_Env *menv, int set_ns)
static void eval_exptime (Scheme_Object *names, int count, Scheme_Object *expr, Scheme_Env *genv, Scheme_Comp_Env *env, Resolve_Prefix *rp, int let_depth, int shift, Scheme_Bucket_Table *syntax, int for_stx, Scheme_Object *certs, Scheme_Object *free_id_rename_rn)
static Scheme_Module_Exportsmake_module_exports ()
static void parse_requires (Scheme_Object *form, Scheme_Object *base_modidx, Scheme_Env *env, Scheme_Module *for_m, Scheme_Object *rns, Scheme_Object *post_ex_rns, Check_Func ck, void *data, Scheme_Object *redef_modname, int unpack_kern, int copy_vars, int can_save_marshal, int eval_exp, int eval_run, int *all_simple)
static void parse_provides (Scheme_Object *form, Scheme_Object *fst, Scheme_Object *e, Scheme_Hash_Table *all_provided, Scheme_Hash_Table *all_reprovided, Scheme_Object *self_modidx, Scheme_Object **_all_defs_out, Scheme_Object **_et_all_defs_out, Scheme_Hash_Table *tables, Scheme_Object *all_defs, Scheme_Object *all_et_defs, Scheme_Comp_Env *cenv, Scheme_Compile_Info *rec, int drec, Scheme_Object **_expanded)
static int compute_reprovides (Scheme_Hash_Table *all_provided, Scheme_Hash_Table *all_reprovided, Scheme_Module *mod_for_requires, Scheme_Hash_Table *tables, Scheme_Env *genv, Scheme_Object *all_rt_defs, Scheme_Object *all_rt_defs_out, Scheme_Object *all_et_defs, Scheme_Object *all_et_defs_out, const char *matching_form, Scheme_Object *all_mods, Scheme_Object *all_phases)
static char * compute_provide_arrays (Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, Scheme_Module_Exports *me, Scheme_Env *genv, Scheme_Object *form, char **_phase1_protects)
static Scheme_Object ** compute_indirects (Scheme_Env *genv, Scheme_Module_Phase_Exports *pt, int *_count, int vars)
static void start_module (Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx, int eval_exp, int eval_run, long base_phase, Scheme_Object *cycle_list)
static void eval_module_body (Scheme_Env *menv, Scheme_Env *env)
static Scheme_Objectdo_namespace_require (Scheme_Env *env, int argc, Scheme_Object *argv[], int copy, int etonly)
static Scheme_Objectdefault_module_resolver (int argc, Scheme_Object **argv)
static void qsort_provides (Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, char *exps, char *exets, Scheme_Object **exsnoms, Scheme_Object **exinsps, int start, int count, int do_uninterned)
void scheme_init_module (Scheme_Env *env)
void scheme_init_module_resolver (void)
void scheme_finish_kernel (Scheme_Env *env)
int scheme_is_kernel_modname (Scheme_Object *modname)
Scheme_Objectscheme_sys_wraps (Scheme_Comp_Env *env)
Scheme_Objectscheme_sys_wraps_phase (Scheme_Object *phase)
void scheme_save_initial_module_set (Scheme_Env *env)
void scheme_install_initial_module_set (Scheme_Env *env)
static Scheme_Objectcheck_resolver (int argc, Scheme_Object **argv)
static Scheme_Objectprefix_p (int argc, Scheme_Object **argv)
int scheme_module_protected_wrt (Scheme_Object *home_insp, Scheme_Object *insp)
static Scheme_Object_dynamic_require (int argc, Scheme_Object *argv[], Scheme_Env *env, int get_bucket, int phase, int mod_phase, int indirect_ok, int fail_with_error, int position)
Scheme_Objectscheme_dynamic_require (int argc, Scheme_Object *argv[])
Scheme_Objectscheme_namespace_require (Scheme_Object *r)
static Scheme_Objectextend_list_depth (Scheme_Object *l, Scheme_Object *n, int with_ht)
static Scheme_Objectextract_at_depth (Scheme_Object *l, Scheme_Object *n)
static void set_at_depth (Scheme_Object *l, Scheme_Object *n, Scheme_Object *v)
static void check_phase (Scheme_Env *menv, Scheme_Env *env, int phase)
static void check_modchain_consistency (Scheme_Hash_Table *ht, int phase)
static int plain_char (int c)
static int ok_hex (int c)
static int ok_escape (int c1, int c2)
static int ok_path_string (Scheme_Object *obj, int dir_ok, int just_file_ok, int file_end_ok, int for_planet)
static int ok_planet_number (Scheme_Object *a)
static int ok_planet_string (Scheme_Object *obj)
int scheme_is_module_path (Scheme_Object *obj)
static int do_add_simple_require_renames (Scheme_Object *rn, Scheme_Hash_Table *required, Scheme_Object *orig_src, Scheme_Module *im, Scheme_Module_Phase_Exports *pt, Scheme_Object *idx, Scheme_Object *marshal_phase_index, Scheme_Object *src_phase_index, int can_override)
static Scheme_Hash_Tableget_required_from_tables (Scheme_Hash_Table *tables, Scheme_Object *phase)
static int add_simple_require_renames (Scheme_Object *orig_src, Scheme_Object *rn_set, Scheme_Hash_Table *tables, Scheme_Module *im, Scheme_Object *idx, Scheme_Object *import_shift, Scheme_Object *only_export_phase, int can_override)
void scheme_prep_namespace_rename (Scheme_Env *menv)
Scheme_Objectscheme_module_to_namespace (Scheme_Object *name, Scheme_Env *env)
static Scheme_Objectmake_provide_desc (Scheme_Module_Phase_Exports *pt, int i)
void scheme_init_module_path_table ()
Scheme_Objectscheme_intern_resolved_module_path_worker (Scheme_Object *o)
Scheme_Objectscheme_intern_resolved_module_path (Scheme_Object *o)
Scheme_Objectscheme_make_modidx (Scheme_Object *path, Scheme_Object *base_modidx, Scheme_Object *resolved)
int same_modidx (Scheme_Object *a, Scheme_Object *b)
int same_resolved_modidx (Scheme_Object *a, Scheme_Object *b)
static Scheme_Object_module_resolve_k (void)
static Scheme_Object_module_resolve (Scheme_Object *modidx, Scheme_Object *stx, Scheme_Env *env, int load_it)
Scheme_Objectscheme_module_resolve (Scheme_Object *modidx, int load_it)
Scheme_Objectmodule_resolve_in_namespace (Scheme_Object *modidx, Scheme_Env *env, int load_it)
Scheme_Objectscheme_modidx_shift (Scheme_Object *modidx, Scheme_Object *shift_from_modidx, Scheme_Object *shift_to_modidx)
void scheme_clear_modidx_cache (void)
static void setup_accessible_table (Scheme_Module *m)
Scheme_Envscheme_module_access (Scheme_Object *name, Scheme_Env *env, int rev_mod_phase)
static void check_certified (Scheme_Object *stx, Scheme_Object *certs, Scheme_Object *prot_insp, Scheme_Object *insp, Scheme_Object *rename_insp, Scheme_Object *in_modidx, Scheme_Env *env, Scheme_Object *symbol, int var, int prot, int *_would_complain)
Scheme_Objectscheme_check_accessible_in_module (Scheme_Env *env, Scheme_Object *prot_insp, Scheme_Object *in_modidx, Scheme_Object *symbol, Scheme_Object *stx, Scheme_Object *certs, Scheme_Object *unexp_insp, Scheme_Object *rename_insp, int position, int want_pos, int *_protected, int *_unexported, Scheme_Env *from_env, int *_would_complain)
int scheme_module_export_position (Scheme_Object *modname, Scheme_Env *env, Scheme_Object *varname)
Scheme_Objectscheme_module_syntax (Scheme_Object *modname, Scheme_Env *env, Scheme_Object *name)
void scheme_module_force_lazy (Scheme_Env *env, int previous)
static XFORM_NONGCING long make_key (int base_phase, int eval_exp, int eval_run)
static int did_start (Scheme_Object *v, int base_phase, int eval_exp, int eval_run)
static Scheme_Objectadd_start (Scheme_Object *v, int base_phase, int eval_exp, int eval_run)
static void compute_require_names (Scheme_Env *menv, Scheme_Object *phase, Scheme_Env *load_env, Scheme_Object *syntax_idx)
static void chain_start_module (Scheme_Env *menv, Scheme_Env *env, int eval_exp, int eval_run, long base_phase, Scheme_Object *cycle_list, Scheme_Object *syntax_idx)
static Scheme_Envinstantiate_module (Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx)
static void expstart_module (Scheme_Env *menv, Scheme_Env *env, int restart)
static void do_start_module (Scheme_Module *m, Scheme_Env *menv, Scheme_Env *env, int restart)
static void should_run_for_compile (Scheme_Env *menv)
static void do_prepare_compile_env (Scheme_Env *env, int base_phase, int pos)
void scheme_prepare_compile_env (Scheme_Env *env)
static voideval_module_body_k (void)
Scheme_Envscheme_primitive_module (Scheme_Object *name, Scheme_Env *for_env)
void scheme_finish_primitive_module (Scheme_Env *env)
void scheme_protect_primitive_provide (Scheme_Env *env, Scheme_Object *name)
Scheme_Bucketscheme_module_bucket (Scheme_Object *modname, Scheme_Object *var, int pos, Scheme_Env *env)
Scheme_Objectscheme_builtin_value (const char *name)
Scheme_Modulescheme_extract_compiled_module (Scheme_Object *o)
static voideval_exptime_k (void)
static int is_simple_expr (Scheme_Object *v)
static Scheme_Object ** declare_insps (int n, Scheme_Object **insps, Scheme_Object *insp)
static Scheme_Objectrebuild_et_vec (Scheme_Object *naya, Scheme_Object *vec, Resolve_Prefix *rp)
static Scheme_Objectjit_vector (Scheme_Object *orig_l, int in_vec, int jit)
static Scheme_Objectdo_module_clone (Scheme_Object *data, int jit)
Scheme_Objectscheme_module_eval_clone (Scheme_Object *data)
static int set_code_closure_flags (Scheme_Object *clones, int set_flags, int mask_flags, int just_tentative)
static Scheme_Objectdo_module (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec)
Scheme_Objectscheme_apply_for_syntax_in_env (Scheme_Object *proc, Scheme_Env *env)
static void check_require_name (Scheme_Object *prnt_name, Scheme_Object *name, Scheme_Object *nominal_modidx, Scheme_Object *nominal_name, Scheme_Object *modidx, Scheme_Object *exname, int exet, int isval, void *tables, Scheme_Object *e, Scheme_Object *form, Scheme_Object *err_src, Scheme_Object *mark_src, Scheme_Object *phase, Scheme_Object *src_phase_index, Scheme_Object *nominal_export_phase, Scheme_Object *in_insp)
static int check_already_required (Scheme_Hash_Table *required, Scheme_Object *name)
static Scheme_Objectstx_sym (Scheme_Object *name, Scheme_Object *_genv)
static Scheme_Objectadd_a_rename (Scheme_Object *fm, Scheme_Object *post_ex_rn)
static Scheme_Objectadd_req (Scheme_Object *imods, Scheme_Object *requires)
static Scheme_Objectadd_lifted_defn (Scheme_Object *data, Scheme_Object **_ids, Scheme_Object *expr, Scheme_Comp_Env *_env)
static Scheme_Objectmake_require_form (Scheme_Object *module_path, long phase, Scheme_Object *mark)
Scheme_Objectscheme_parse_lifted_require (Scheme_Object *module_path, long phase, Scheme_Object *mark, void *data)
static Scheme_Objectpackage_require_data (Scheme_Object *base_modidx, Scheme_Env *env, Scheme_Module *for_m, Scheme_Object *rns, Scheme_Object *post_ex_rns, void *data, Scheme_Object *redef_modname, int *all_simple)
static void flush_definitions (Scheme_Env *genv)
static Scheme_Objectdo_module_begin (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec)
static void check_already_provided (Scheme_Hash_Table *provided, Scheme_Object *outname, Scheme_Object *name, int protected, Scheme_Object *form, Scheme_Object *phase)
Scheme_Objectscheme_module_imported_list (Scheme_Env *genv, Scheme_Object *bindings, Scheme_Object *modpath, Scheme_Object *mode)
static Scheme_Objectadjust_for_rename (Scheme_Object *out_name, Scheme_Object *in_name, Scheme_Object *noms)
static Scheme_Objectextract_free_id_name (Scheme_Object *name, Scheme_Object *phase, Scheme_Env *genv, int always, int *_implicit, Scheme_Object **_implicit_src, Scheme_Object **_implicit_src_name, Scheme_Object **_implicit_mod_phase, Scheme_Object **_implicit_nominal_name, Scheme_Object **_implicit_nominal_mod, Scheme_Object **_implicit_insp)
static Scheme_Objectexpand_provide (Scheme_Object *e, Scheme_Hash_Table *tables, Scheme_Object *all_defs, Scheme_Object *all_et_defs, Scheme_Comp_Env *cenv, Scheme_Compile_Info *rec, int drec)
Scheme_Objectscheme_module_exported_list (Scheme_Object *modpath, Scheme_Env *genv)
void add_single_require (Scheme_Module_Exports *me, Scheme_Object *only_phase, Scheme_Object *src_phase_index, Scheme_Object *idx, Scheme_Env *orig_env, Scheme_Object *rn_set, Scheme_Object *post_ex_rn_set, Scheme_Object *single_rn, Scheme_Object *exns, Scheme_Hash_Table *onlys, Scheme_Object *prefix, Scheme_Object *iname, Scheme_Object *orig_ename, Scheme_Object *mark_src, int unpack_kern, int copy_vars, int for_unmarshal, int can_save_marshal, int *all_simple, Check_Func ck, void *data, Scheme_Object *form, Scheme_Object *err_src, Scheme_Object *cki)
void scheme_do_module_rename_unmarshal (Scheme_Object *rn, Scheme_Object *info, Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to, Scheme_Hash_Table *export_registry)
Scheme_Objectscheme_get_kernel_modidx (void)
static void check_dup_require (Scheme_Object *prnt_name, Scheme_Object *name, Scheme_Object *nominal_modidx, Scheme_Object *nominal_name, Scheme_Object *modidx, Scheme_Object *srcname, int exet, int isval, void *ht, Scheme_Object *e, Scheme_Object *form, Scheme_Object *err_src, Scheme_Object *mark_src, Scheme_Object *to_phase, Scheme_Object *src_phase_index, Scheme_Object *nominal_export_phase, Scheme_Object *in_insp)
static Scheme_Objectdo_require_execute (Scheme_Env *env, Scheme_Object *form)
static Scheme_Objectdo_require (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec)
Scheme_Objectscheme_toplevel_require_for_expand (Scheme_Object *module_path, long phase, Scheme_Comp_Env *cenv, Scheme_Object *mark)
static XFORM_NONGCING
Scheme_Object
wrap_mod_stx (Scheme_Object *stx)
static int check_requires_ok (Scheme_Object *l)

Variables

Scheme_Objectscheme_sys_wraps0
Scheme_Objectscheme_sys_wraps1
Scheme_Object *(* scheme_module_demand_hook )(int, Scheme_Object **)
static Scheme_Objectkernel_modname
static Scheme_Objectkernel_symbol
static Scheme_Objectkernel_modidx
static Scheme_Modulekernel
static Scheme_Objectmodule_symbol
static Scheme_Objectmodule_begin_symbol
static Scheme_Objectprefix_symbol
static Scheme_Objectonly_symbol
static Scheme_Objectrename_symbol
static Scheme_Objectall_except_symbol
static Scheme_Objectprefix_all_except_symbol
static Scheme_Objectall_from_symbol
static Scheme_Objectall_from_except_symbol
static Scheme_Objectall_defined_symbol
static Scheme_Objectall_defined_except_symbol
static Scheme_Objectprefix_all_defined_symbol
static Scheme_Objectprefix_all_defined_except_symbol
static Scheme_Objectstruct_symbol
static Scheme_Objectprotect_symbol
static Scheme_Objectexpand_symbol
static Scheme_Objectfor_syntax_symbol
static Scheme_Objectfor_template_symbol
static Scheme_Objectfor_label_symbol
static Scheme_Objectfor_meta_symbol
static Scheme_Objectjust_meta_symbol
static Scheme_Objectquote_symbol
static Scheme_Objectlib_symbol
static Scheme_Objectplanet_symbol
static Scheme_Objectfile_symbol
static Scheme_Objectmodule_name_symbol
static Scheme_Objectnominal_id_symbol
Scheme_Objectscheme_module_stx
Scheme_Objectscheme_begin_stx
Scheme_Objectscheme_define_values_stx
Scheme_Objectscheme_define_syntaxes_stx
Scheme_Objectscheme_top_stx
static Scheme_Objectmodbeg_syntax
static Scheme_Objectdefine_for_syntaxes_stx
static Scheme_Objectrequire_stx
static Scheme_Objectprovide_stx
static Scheme_Objectset_stx
static Scheme_Objectapp_stx
static Scheme_Objectlambda_stx
static Scheme_Objectcase_lambda_stx
static Scheme_Objectlet_values_stx
static Scheme_Objectletrec_values_stx
static Scheme_Objectif_stx
static Scheme_Objectbegin0_stx
static Scheme_Objectwith_continuation_mark_stx
static Scheme_Objectletrec_syntaxes_stx
static Scheme_Objectvar_ref_stx
static Scheme_Objectexpression_stx
static Scheme_Envinitial_modules_env
static int num_initial_modules
static Scheme_Object ** initial_modules
static Scheme_Objectinitial_renames
static Scheme_Bucket_Tableinitial_toplevel
static Scheme_Objectempty_self_modidx
static Scheme_Objectempty_self_modname
static THREAD_LOCAL
Scheme_Bucket_Table
starts_table
static THREAD_LOCAL Scheme_Modidxmodidx_caching_chain
static THREAD_LOCAL Scheme_Objectglobal_shift_cache
static Scheme_Bucket_Tablemodpath_table

Define Documentation

#define cons   scheme_make_pair

Definition at line 127 of file module.c.

#define GLOBAL_SHIFT_CACHE_SIZE   40

Definition at line 203 of file module.c.

#define LOG_ATTACH (   x)    /* nothing */

Definition at line 1190 of file module.c.

#define LOG_END_EXPAND (   mod)    /* empty */

Definition at line 5286 of file module.c.

#define LOG_END_RUN (   mod)    /* empty */

Definition at line 4152 of file module.c.

#define LOG_EXPAND_DECLS   /* empty */

Definition at line 5284 of file module.c.

#define LOG_RUN_DECLS   /* empty */

Definition at line 4150 of file module.c.

#define LOG_START_EXPAND (   mod)    /* empty */

Definition at line 5285 of file module.c.

#define LOG_START_RUN (   mod)    /* empty */

Definition at line 4151 of file module.c.

#define MODCHAIN_AVAIL (   p,
 
)    (SCHEME_VEC_ELS(p)[3+n])

Definition at line 274 of file module.c.

#define MODCHAIN_TABLE (   p)    ((Scheme_Hash_Table *)(SCHEME_VEC_ELS(p)[0]))

Definition at line 273 of file module.c.

#define mzrt_mutex_lock (   l)    /* empty */

Definition at line 40 of file module.c.

#define mzrt_mutex_unlock (   l)    /* empty */

Definition at line 41 of file module.c.

#define return_NULL ( )    return NULL

Definition at line 9526 of file module.c.

Definition at line 213 of file module.c.

#define SHIFT_CACHE_NULL   NULL

Definition at line 208 of file module.c.

#define SHIFT_CACHE_NULLP (   x)    !(x)

Definition at line 209 of file module.c.

#define show (   w,
  m,
  v1,
  v2,
  bp 
)    /* nothing */

Definition at line 3597 of file module.c.

#define show_done (   w,
  m,
  v1,
  v2,
  bp 
)    /* nothing */

Definition at line 3598 of file module.c.

#define show_indent (   d)    /* nothing */

Definition at line 3596 of file module.c.


Typedef Documentation

typedef void(* Check_Func)(Scheme_Object *prnt_name, Scheme_Object *name, Scheme_Object *nominal_modname, Scheme_Object *nominal_export, Scheme_Object *modname, Scheme_Object *srcname, int exet, int isval, void *data, Scheme_Object *e, Scheme_Object *form, Scheme_Object *err_src, Scheme_Object *mark_src, Scheme_Object *to_phase, Scheme_Object *src_phase_index, Scheme_Object *nominal_export_phase, Scheme_Object *in_insp)

Definition at line 215 of file module.c.


Function Documentation

static Scheme_Object* _dynamic_require ( int  argc,
Scheme_Object argv[],
Scheme_Env env,
int  get_bucket,
int  phase,
int  mod_phase,
int  indirect_ok,
int  fail_with_error,
int  position 
) [static]

Definition at line 805 of file module.c.

{
  Scheme_Object *modname, *modidx;
  Scheme_Object *name, *srcname, *srcmname, *fail_thunk;
  Scheme_Module *m, *srcm;
  Scheme_Env *menv, *lookup_env = NULL;
  int i, count, protected = 0;
  const char *errname;
  long base_phase;

  modname = argv[0];
  name = argv[1];
  if (argc > 2)
    fail_thunk = argv[2];
  else
    fail_thunk = NULL;

  errname = (phase 
            ? ((phase < 0)
              ? "dynamic-require-for-template" 
              : "dynamic-require-for-syntax" )
            : "dynamic-require");

  if (SCHEME_TRUEP(name) && !SCHEME_SYMBOLP(name) && !SCHEME_VOIDP(name)) {
    scheme_wrong_type(errname, "symbol, #f, or void", 1, argc, argv);
    return NULL;
  }

  if (fail_thunk)
    scheme_check_proc_arity(errname, 0, 2, argc, argv);

  if (SAME_TYPE(SCHEME_TYPE(modname), scheme_module_index_type))
    modidx = modname;
  else
    modidx = scheme_make_modidx(modname, scheme_false, scheme_false);

  modname = scheme_module_resolve(modidx, 1);
  base_phase = env->phase;

  if (phase == 1) {
    scheme_prepare_exp_env(env);
    if (mod_phase)
      lookup_env = env->exp_env;
    else
      env = env->exp_env;
  }

  scheme_prepare_compile_env(env);

  m = module_load(modname, env, errname);
  srcm = m;

  srcmname = NULL;
  srcname = NULL;

  if (SCHEME_SYMBOLP(name)) {
    if (mod_phase) {
      srcname = name;
      srcmname = modname;
    } else {
      /* Before starting, check whether the name is provided */
      count = srcm->me->rt->num_provides;
      if (position >= 0) {
       if (position < srcm->me->rt->num_var_provides) {
         i = position;
         if ((SCHEME_SYM_LEN(name) == SCHEME_SYM_LEN(srcm->me->rt->provide_src_names[i]))
             && !memcmp(SCHEME_SYM_VAL(name), SCHEME_SYM_VAL(srcm->me->rt->provide_src_names[i]), SCHEME_SYM_LEN(name))) {
           name = srcm->me->rt->provides[i];
         } else {
           i = count; /* not found */
           indirect_ok = 0; /* don't look further */
         }
       } else {
         position -= srcm->me->rt->num_var_provides;
         i = count;
       }
      } else {
       for (i = 0; i < count; i++) {
         if (SAME_OBJ(name, srcm->me->rt->provides[i])) {
           if (i < srcm->me->rt->num_var_provides) {
             break;
           } else {
             if (fail_with_error) {
                if (!phase) {
                  /* Evaluate id in a fresh namespace */
                  Scheme_Object *a[3], *ns;
                  start_module(m, env, 0, modidx, 0, 1, base_phase, scheme_null);
                  a[0] = scheme_intern_symbol("empty");
                  ns = scheme_make_namespace(1, a);
                  a[0] = (Scheme_Object *)env;
                  a[1] = srcm->modname;
                  a[2] = ns;
                  namespace_attach_module(3, a);
                  a[0] = scheme_make_pair(scheme_intern_symbol("only"),
                                          scheme_make_pair(srcm->modname,
                                                           scheme_make_pair(name,
                                                                            scheme_null)));
                  do_namespace_require((Scheme_Env *)ns, 1, a, 0, 0);
                  return scheme_eval(name, (Scheme_Env *)ns);
                } else {
                  scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                                   "%s: name is provided as syntax: %V by module: %V",
                                   errname,
                                   name, srcm->modname);
                }
              }
             return NULL;
           }
         }
       }
      }

      if (i < count) {
       if (srcm->provide_protects)
         protected = srcm->provide_protects[i];
       srcmname = (srcm->me->rt->provide_srcs ? srcm->me->rt->provide_srcs[i] : scheme_false);
       if (SCHEME_FALSEP(srcmname))
         srcmname = srcm->modname;
       else {
         srcmname = scheme_modidx_shift(srcmname, srcm->me->src_modidx, srcm->self_modidx);
         srcmname = scheme_module_resolve(srcmname, 1);
       }
       srcname = srcm->me->rt->provide_src_names[i];
      }

      if (i == count) {
       if (indirect_ok) {
         /* Try indirect provides: */
         srcm = m;
         count = srcm->num_indirect_provides;
         if (position >= 0) {
           i = position;
           if ((i < srcm->num_indirect_provides)
              && (SCHEME_SYM_LEN(name) == SCHEME_SYM_LEN(srcm->indirect_provides[i]))
              && !memcmp(SCHEME_SYM_VAL(name), SCHEME_SYM_VAL(srcm->indirect_provides[i]), SCHEME_SYM_LEN(name))) {
             name = srcm->indirect_provides[i];
             srcname = name;
             srcmname = srcm->modname;
             if (srcm->provide_protects)
              protected = srcm->provide_protects[i];
           } else
             i = count; /* not found */
         } else {
           for (i = 0; i < count; i++) {
             if (SAME_OBJ(name, srcm->indirect_provides[i])) {
              srcname = name;
              srcmname = srcm->modname;
              if (srcm->provide_protects)
                protected = srcm->provide_protects[i];
              break;
             }
           }
         }
       }

       if (i == count) {
         if (fail_with_error) {
            if (fail_thunk)
              return scheme_tail_apply(fail_thunk, 0, NULL);
           scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                          "%s: name is not provided: %V by module: %V",
                          errname,
                          name, srcm->modname);
          }
         return NULL;
       }
      }
    }
  }

  if (SCHEME_VOIDP(name))
    start_module(m, env, 0, modidx, 1, 0, base_phase, scheme_null);
  else
    start_module(m, env, 0, modidx, 0, 1, base_phase, scheme_null);

  if (SCHEME_SYMBOLP(name)) {
    Scheme_Bucket *b;

    menv = scheme_module_access(srcmname, lookup_env ? lookup_env : env, mod_phase);

    if (protected) {
      Scheme_Object *insp;
      insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
      if (scheme_module_protected_wrt(menv->insp, insp))
       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                      "%s: name is protected: %V from module: %V",
                      errname,
                      name, srcm->modname);
    }

    if (!menv || !menv->toplevel) {
      scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                       "%s: module initialization failed: %V",
                       errname,
                       srcm->modname);
    }
    
    b = scheme_bucket_from_table(menv->toplevel, (const char *)srcname);
    if (!((Scheme_Bucket_With_Home *)b)->home)
      ((Scheme_Bucket_With_Home *)b)->home = menv;

    if (get_bucket)
      return (Scheme_Object *)b;
    else {
      if (!b->val) {
        if (!menv->ran)
          run_module(menv, 1);
      }
      if (!b->val && fail_with_error) {
        if (fail_thunk)
          return scheme_tail_apply(fail_thunk, 0, NULL);
       scheme_unbound_global(b);
      }
      return b->val;
    }
  } else
    return scheme_void;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* _module_resolve ( Scheme_Object modidx,
Scheme_Object stx,
Scheme_Env env,
int  load_it 
) [static]

Definition at line 2893 of file module.c.

{
  if (SCHEME_MODNAMEP(modidx) || SCHEME_FALSEP(modidx))
    return modidx;

  if (SAME_OBJ(modidx, empty_self_modidx))
    return empty_self_modname;

  if (SCHEME_FALSEP(((Scheme_Modidx *)modidx)->resolved)) {
    /* Need to resolve access path to a module name: */
    Scheme_Object *a[4];
    Scheme_Object *name, *base;
    
    base = ((Scheme_Modidx *)modidx)->base;
    if (!SCHEME_FALSEP(base)) {
# include "mzstkchk.h"
      {
       Scheme_Thread *p = scheme_current_thread;
       p->ku.k.p1 = (void *)base;
       p->ku.k.p2 = (void *)env;
       p->ku.k.i1 = load_it;
       base = scheme_handle_stack_overflow(_module_resolve_k);
      } else {
       base = _module_resolve(base, NULL, env, load_it);
      }
    }

    if (SCHEME_SYMBOLP(base))
      base = scheme_false;

    a[0] = ((Scheme_Modidx *)modidx)->path;
    a[1] = base;
    a[2] = (stx ? stx : scheme_false);
    a[3] = (load_it ? scheme_true : scheme_false);
    
    if (SCHEME_FALSEP(a[0])) {
      scheme_arg_mismatch("module-path-index-resolve",
                          "\"self\" index has no resolution: ",
                          modidx);
    }


    {
      Scheme_Cont_Frame_Data cframe;

      if (env) {
        Scheme_Config *config;
        
        config = scheme_extend_config(scheme_current_config(),
                                      MZCONFIG_ENV,
                                      (Scheme_Object *)env);
        scheme_push_continuation_frame(&cframe);
        scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
      }

      name = scheme_apply(scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_MODULE_RESOLVER), 4, a);

      if (env) {
        scheme_pop_continuation_frame(&cframe);
      }
    }
    
    if (!SCHEME_MODNAMEP(name)) {
      a[0] = name;
      scheme_wrong_type("module name resolver", "resolved-module-path", -1, -1, a);
    }

    ((Scheme_Modidx *)modidx)->resolved = name;
  }

  return ((Scheme_Modidx *)modidx)->resolved;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * _module_resolve_k ( void  ) [static]

Definition at line 2966 of file module.c.

{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object *base = (Scheme_Object *)p->ku.k.p1;
  Scheme_Env *env = (Scheme_Env *)p->ku.k.p2;

  p->ku.k.p1 = NULL;

  return _module_resolve(base, NULL, env, p->ku.k.i1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* add_a_rename ( Scheme_Object fm,
Scheme_Object post_ex_rn 
) [static]

Definition at line 5733 of file module.c.

{
  return scheme_add_rename(fm, post_ex_rn);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* add_lifted_defn ( Scheme_Object data,
Scheme_Object **  _ids,
Scheme_Object expr,
Scheme_Comp_Env _env 
) [static]

Definition at line 5762 of file module.c.

{
  Scheme_Comp_Env *env;
  Scheme_Object *self_modidx, *rn, *name, *ids, *id, *new_ids = scheme_null;

  env = (Scheme_Comp_Env *)SCHEME_VEC_ELS(data)[0];
  self_modidx = SCHEME_VEC_ELS(data)[1];
  rn = SCHEME_VEC_ELS(data)[2];

  for (ids = *_ids; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) {
    id = SCHEME_CAR(ids);
  
    name = scheme_tl_id_sym(env->genv, id, scheme_false, 2, NULL, NULL);

    /* Create the bucket, indicating that the name will be defined: */
    scheme_add_global_symbol(name, scheme_undefined, env->genv);
  
    /* Add a renaming: */
    scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, NULL, 0);

    id = scheme_add_rename(id, rn);
    new_ids = cons(id, new_ids);
  }

  new_ids = scheme_reverse(new_ids);
  *_ids = new_ids;

  return scheme_make_lifted_defn(scheme_sys_wraps(env), _ids, expr, _env);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* add_req ( Scheme_Object imods,
Scheme_Object requires 
) [static]

Definition at line 5738 of file module.c.

{
  for (; !SCHEME_NULLP(imods); imods = SCHEME_CDR(imods)) {
    Scheme_Object *il, *ilast = NULL;
    Scheme_Object *idx = SCHEME_CAR(imods);
    
    for (il = requires; SCHEME_PAIRP(il); il = SCHEME_CDR(il)) {
      if (same_modidx(idx, SCHEME_CAR(il)))
       break;
      ilast = il;
    }
    
    if (SCHEME_NULLP(il)) {
      il = scheme_make_pair(idx, scheme_null);
      if (ilast)
       SCHEME_CDR(ilast) = il;
      else
       requires = il;
    }
  }

  return requires;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int add_simple_require_renames ( Scheme_Object orig_src,
Scheme_Object rn_set,
Scheme_Hash_Table tables,
Scheme_Module im,
Scheme_Object idx,
Scheme_Object import_shift,
Scheme_Object only_export_phase,
int  can_override 
) [static]

Definition at line 2265 of file module.c.

{
  int saw_mb;
  Scheme_Object *phase;

  if (im->me->rt
      && (!only_export_phase || SAME_OBJ(only_export_phase, scheme_make_integer(0))))
    saw_mb = do_add_simple_require_renames(scheme_get_module_rename_from_set(rn_set, import_shift, 1), 
                                           get_required_from_tables(tables, import_shift),
                                           orig_src, im, im->me->rt, idx,
                                           scheme_make_integer(0),
                                           import_shift,
                                           can_override);
  else
    saw_mb = 0;
  
  if (im->me->et
      && (!only_export_phase || SAME_OBJ(only_export_phase, scheme_make_integer(1)))) {
    if (SCHEME_FALSEP(import_shift))
      phase = scheme_false;
    else
      phase = scheme_bin_plus(scheme_make_integer(1), import_shift);
    do_add_simple_require_renames(scheme_get_module_rename_from_set(rn_set, phase, 1), 
                                  get_required_from_tables(tables, phase),
                                  orig_src, im, im->me->et, idx,
                                  scheme_make_integer(1),
                                  import_shift,
                                  can_override);
  }

  if (im->me->dt
      && (!only_export_phase || SAME_OBJ(only_export_phase, scheme_false))) {
    do_add_simple_require_renames(scheme_get_module_rename_from_set(rn_set, scheme_false, 1), 
                                  get_required_from_tables(tables, scheme_false),
                                  orig_src, im, im->me->dt, idx,
                                  scheme_false,
                                  import_shift,
                                  can_override);
  }

  if (im->me->other_phases) {
    Scheme_Object *val, *key;
    int i;
    for (i = 0; i < im->me->other_phases->size; i++) {
      val = im->me->other_phases->vals[i];
      if (val) {
        key = im->me->other_phases->keys[i];
        if (!only_export_phase || scheme_eqv(only_export_phase, key)) {
          if (SCHEME_FALSEP(import_shift))
            phase = scheme_false;
          else
            phase = scheme_bin_plus(key, import_shift);
          do_add_simple_require_renames(scheme_get_module_rename_from_set(rn_set, phase, 1), 
                                        get_required_from_tables(tables, phase),
                                        orig_src, im, (Scheme_Module_Phase_Exports *)val, idx,
                                        key,
                                        import_shift,
                                        can_override);
        }
      }
    }
  }

  return saw_mb;
}

Here is the call graph for this function:

Here is the caller graph for this function:

void add_single_require ( Scheme_Module_Exports me,
Scheme_Object only_phase,
Scheme_Object src_phase_index,
Scheme_Object idx,
Scheme_Env orig_env,
Scheme_Object rn_set,
Scheme_Object post_ex_rn_set,
Scheme_Object single_rn,
Scheme_Object exns,
Scheme_Hash_Table onlys,
Scheme_Object prefix,
Scheme_Object iname,
Scheme_Object orig_ename,
Scheme_Object mark_src,
int  unpack_kern,
int  copy_vars,
int  for_unmarshal,
int  can_save_marshal,
int all_simple,
Check_Func  ck,
void data,
Scheme_Object form,
Scheme_Object err_src,
Scheme_Object cki 
)

Definition at line 8332 of file module.c.

{
  int j, var_count;
  Scheme_Object *orig_idx = idx, *to_phase;
  Scheme_Object **exs, **exsns, **exss, *context_marks = scheme_null, **exinsps;
  char *exets;
  int has_context, save_marshal_info = 0;
  Scheme_Object *nominal_modidx, *one_exn, *prnt_iname, *name, *rn, *ename = orig_ename;
  Scheme_Hash_Table *orig_onlys;
  int k, skip_rename, do_copy_vars;
  
  if (mark_src) {
    /* Check whether there's context for this import (which
       leads to generated local names). */
    context_marks = scheme_stx_extract_marks(mark_src);
    has_context = !SCHEME_NULLP(context_marks);
    if (has_context) {
      if (all_simple)
       *all_simple = 0;
    }
  } else
    has_context = 0; /* computed later */

  if (iname || ename || onlys || for_unmarshal || unpack_kern)
    can_save_marshal = 0;

  if (onlys)
    orig_onlys = scheme_clone_hash_table(onlys);
  else
    orig_onlys = NULL;
    
  for (k = -3; k < (me->other_phases ? me->other_phases->size : 0); k++) {
    Scheme_Module_Phase_Exports *pt;

    switch(k) {
    case -3:
      pt = me->rt;
      break;
    case -2:
      pt = me->et;
      break;
    case -1:
      pt = me->dt;
      break;
    default:
      pt = (Scheme_Module_Phase_Exports *)me->other_phases->vals[k];
      break;
    }

    if (pt && only_phase) {
      if (!scheme_eqv(pt->phase_index, only_phase))
        pt = NULL;
    }

    if (pt) {
      if (SCHEME_FALSEP(pt->phase_index))
        to_phase = scheme_false;
      else if (SCHEME_FALSEP(src_phase_index))
        to_phase = scheme_false;
      else
        to_phase = scheme_bin_plus(pt->phase_index, src_phase_index);
    } else
      to_phase = NULL;

    if (pt) {
      one_exn = NULL;
    
      nominal_modidx = idx;

      if (single_rn)
        rn = single_rn;
      else
        rn = scheme_get_module_rename_from_set((has_context ? post_ex_rn_set : rn_set),
                                               to_phase,
                                               1);

      if (copy_vars)
        do_copy_vars = !orig_env->module && !orig_env->phase && SAME_OBJ(src_phase_index, scheme_make_integer(0)) && (k == -3);
      else
        do_copy_vars = 0;

      if (can_save_marshal
          && !exns
          && !prefix
          && !orig_ename
          && pt->num_provides
          && !do_copy_vars) {
        /* Simple "import everything" whose mappings can be shared via the exporting module: */
        if (!pt->src_modidx)
          pt->src_modidx = me->src_modidx;
        scheme_extend_module_rename_with_shared(rn, idx, pt, pt->phase_index, src_phase_index, context_marks, 1);
        skip_rename = 1;
      } else
        skip_rename = 0;

      exs = pt->provides;
      exsns = pt->provide_src_names;
      exss = pt->provide_srcs;
      exets = pt->provide_src_phases;
      exinsps = pt->provide_insps;
      var_count = pt->num_var_provides;
      
      for (j = pt->num_provides; j--; ) {
        Scheme_Object *modidx;
       
        if (orig_ename) {
          if (!SAME_OBJ(SCHEME_STX_VAL(orig_ename), exs[j]))
            continue;  /* we don't want this one. */
        } else if (onlys) {
          name = scheme_hash_get(orig_onlys, exs[j]);
          if (!name)
            continue;  /* we don't want this one. */
          mark_src = name;
          {
            Scheme_Object *l;
            l = scheme_stx_extract_marks(mark_src);
            has_context = !SCHEME_NULLP(l);
          }
          /* Remove to indicate that it's been imported: */
          scheme_hash_set(onlys, exs[j], NULL);
        } else {
          if (exns) {
            Scheme_Object *l, *a;
            for (l = exns; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
              a = SCHEME_STX_CAR(l);
              if (SCHEME_STXP(a)) 
                a = SCHEME_STX_VAL(a);
              if (SAME_OBJ(a, exs[j]))
                break;
            }
            if (!SCHEME_STX_NULLP(l))
              continue; /* we don't want this one. */
          }

          if (one_exn) {
            if (SAME_OBJ(one_exn, exs[j]))
              continue; /* we don't want this one. */
          }
        }
       
        modidx = ((exss && !SCHEME_FALSEP(exss[j])) 
                  ? scheme_modidx_shift(exss[j], me->src_modidx, idx)
                  : idx);
      
        if (SCHEME_SYM_WEIRDP(exs[j])) {
          /* This shouldn't happen. In case it does, don't import a
             gensym or parallel symbol. The former is useless. The
             latter is supposed to be module-specific, and it could
             collide with local module-specific ids. */
          iname = NULL;
          continue;
        }

        if (!iname)
          iname = exs[j];

        if (prefix)
          iname = scheme_symbol_append(prefix, iname);

        prnt_iname = iname;
        if (has_context) {
          /* The `require' expression has a set of marks in its
             context, which means that we need to generate a name. */
          iname = scheme_datum_to_syntax(iname, scheme_false, mark_src, 0, 0);
          iname = scheme_tl_id_sym(orig_env, iname, scheme_false, skip_rename ? 3 : 2, to_phase, NULL);
          if (all_simple)
            *all_simple = 0;
        }

        if (ck)
          ck(prnt_iname, iname, nominal_modidx, exs[j], modidx, exsns[j], exets ? exets[j] : 0,
             (j < var_count), 
             data, cki, form, err_src, mark_src, to_phase, src_phase_index, pt->phase_index,
             exinsps ? exinsps[j] : scheme_false);

        {
          int done;

          if (do_copy_vars && (j < var_count)) {
            Scheme_Env *menv;
            Scheme_Object *val, *modname;
            Scheme_Bucket *b;
            modname = scheme_module_resolve(modidx, 1);
            menv = scheme_module_access(modname, orig_env, 0);
            val = scheme_lookup_in_table(menv->toplevel, (char *)exsns[j]);
            b = scheme_global_bucket(iname, orig_env);
            scheme_set_global_bucket(((copy_vars == 2)
                                      ? "namespace-require/constant"
                                      : "namespace-require/copy"),
                                     b, val, 1);
            if (copy_vars == 2) {
              ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED;
              done = 0;
            } else {
              scheme_shadow(orig_env, iname, 1);
              done = 1;
            }
          } else
            done = 0;

          if (done) {
          } else if (!for_unmarshal || !has_context) {
            if (!skip_rename) {
              if (!save_marshal_info && !has_context && can_save_marshal)
                save_marshal_info = 1;

              scheme_extend_module_rename(rn, 
                                          modidx, iname, exsns[j], nominal_modidx, exs[j], 
                                          exets ? exets[j] : 0,
                                          src_phase_index,
                                          pt->phase_index,
                                          exinsps ? exinsps[j] : NULL,
                                          (for_unmarshal || (!has_context && can_save_marshal)) ? 1 : 0);
            }
          }
        }

        iname = NULL;
       
        if (ename) {
          ename = NULL;
          break;
        }
      }

      if (save_marshal_info) {
        Scheme_Object *info, *a;

        if (exns) {
          /* Convert to a list of symbols: */
          info = scheme_null;
          for (; SCHEME_STX_PAIRP(exns); exns = SCHEME_STX_CDR(exns)) {
            a = SCHEME_STX_CAR(exns);
            if (SCHEME_STXP(a))
              a = SCHEME_STX_VAL(a);
            info = cons(a, info);
          }
          exns = info;
        } else
          exns = scheme_null;

        /* The format of this data is checked in stxobj for unmarshaling
           a Module_Renames. Also the idx must be first, to support shifting. */
        info = cons(orig_idx, cons(pt->phase_index,
                                   cons(src_phase_index,
                                        cons(exns, prefix ? prefix : scheme_false))));

        scheme_save_module_rename_unmarshal(rn, info);

        save_marshal_info = 0;
      }
    }
  }

  if (ename) {
    scheme_wrong_syntax(NULL, ename, form, "no such provided variable");
    return;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* add_start ( Scheme_Object v,
int  base_phase,
int  eval_exp,
int  eval_run 
) [static]

Definition at line 3556 of file module.c.

{
  long key;
  Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v;
  Scheme_Bucket *b;

  if (!ht)
    ht = scheme_make_hash_tree(0);

  key = make_key(base_phase, eval_exp, eval_run);

  ht = scheme_hash_tree_set(ht, scheme_make_integer(key), scheme_true);
  
  b = scheme_bucket_from_table(starts_table, (const char *)ht);
  if (!b->val)
    b->val = scheme_true;
  return (Scheme_Object *)HT_EXTRACT_WEAK(b->key);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* adjust_for_rename ( Scheme_Object out_name,
Scheme_Object in_name,
Scheme_Object noms 
) [static]

Definition at line 7272 of file module.c.

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

  if (SCHEME_STXP(in_name))
    in_name = SCHEME_STX_VAL(in_name);

  if (SAME_OBJ(in_name, out_name))
    return noms;

  while (SCHEME_PAIRP(noms)) {
    a = SCHEME_CAR(noms);
    if (SCHEME_PAIRP(a)) {
      /* no change */
    } else {
      a = scheme_make_pair(a,
                           scheme_make_pair(scheme_make_integer(0),
                                            scheme_make_pair(in_name,
                                                             scheme_make_pair(scheme_make_integer(0),
                                                                              scheme_null))));
    }

    p = scheme_make_pair(a, scheme_null);
    if (last)
      SCHEME_CDR(last) = p;
    else
      first = p;
    last = p;

    noms = SCHEME_CDR(noms);
  }

  return first;
}

Here is the caller graph for this function:

static void chain_start_module ( Scheme_Env menv,
Scheme_Env env,
int  eval_exp,
int  eval_run,
long  base_phase,
Scheme_Object cycle_list,
Scheme_Object syntax_idx 
) [static]

Definition at line 3668 of file module.c.

{
  Scheme_Object *new_cycle_list, *midx, *l;
  Scheme_Module *im;

  new_cycle_list = scheme_make_pair(menv->module->modname, cycle_list);
  
  if (!SCHEME_NULLP(menv->module->dt_requires)) {
    compute_require_names(menv, scheme_false, env, syntax_idx);

    scheme_prepare_label_env(menv);

    for (l = menv->dt_require_names; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
      midx = SCHEME_CAR(l);
    
      im = module_load(scheme_module_resolve(midx, 1), env, NULL);

      start_module(im, 
                   menv->label_env, 0, 
                   midx,
                   0, 0, base_phase,
                   new_cycle_list);
    }
  }
  
  if (!SCHEME_NULLP(menv->module->tt_requires)) {

    compute_require_names(menv, scheme_make_integer(-1), env, syntax_idx);

    scheme_prepare_template_env(menv);

    for (l = menv->tt_require_names; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
      midx = SCHEME_CAR(l);
    
      im = module_load(scheme_module_resolve(midx, 1), env, NULL);

      start_module(im, 
                   menv->template_env, 0, 
                   midx,
                   eval_exp, eval_run, base_phase,
                   new_cycle_list);
    }
  }

  compute_require_names(menv, scheme_make_integer(0), env, syntax_idx);

  for (l = menv->require_names; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
    midx = SCHEME_CAR(l);

    im = module_load(scheme_module_resolve(midx, 1), env, NULL);

    start_module(im, env, 0, midx, eval_exp, eval_run, base_phase, new_cycle_list);
  }

  scheme_prepare_exp_env(menv);
  menv->exp_env->link_midx = menv->link_midx;
  
  if (!SCHEME_NULLP(menv->module->et_requires)) {
    compute_require_names(menv, scheme_make_integer(1), env, syntax_idx);
    
    for (l = menv->et_require_names; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
      midx = SCHEME_CAR(l);
      
      im = module_load(scheme_module_resolve(midx, 1), env, NULL);
      
      start_module(im, menv->exp_env, 0, midx, eval_exp, eval_run, base_phase, new_cycle_list);
    }
  }

  if (menv->module->other_requires) {
    int i;
    Scheme_Object *phase, *n;
    Scheme_Env *menv2;
    for (i = 0; i < menv->module->other_requires->size; i++) {
      if (menv->module->other_requires->vals[i]) {
        phase = menv->module->other_requires->keys[i];

        if (scheme_is_negative(phase)) {
          compute_require_names(menv, phase, env, syntax_idx);

          n = phase;
          menv2 = menv;
          while (scheme_is_negative(n)) {
            scheme_prepare_template_env(menv2);
            menv2 = menv2->template_env;
            n = scheme_bin_plus(n, scheme_make_integer(1));
          }

          l = scheme_hash_get(menv->other_require_names, phase);

          for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
            midx = SCHEME_CAR(l);

            im = module_load(scheme_module_resolve(midx, 1), env, NULL);

            start_module(im, 
                         menv2, 0, 
                         midx,
                         eval_exp, eval_run, base_phase,
                         new_cycle_list);
          }
        } else {
          compute_require_names(menv, phase, env, syntax_idx);

          n = phase;
          menv2 = menv;
          while (scheme_is_positive(n)) {
            scheme_prepare_exp_env(menv2);
            menv2->exp_env->link_midx = menv2->link_midx;
            menv2 = menv2->exp_env;
            n = scheme_bin_minus(n, scheme_make_integer(1));
          }

          l = scheme_hash_get(menv->other_require_names, phase);

          for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
            midx = SCHEME_CAR(l);
            
            im = module_load(scheme_module_resolve(midx, 1), env, NULL);
            
            start_module(im, menv2, 0, midx, eval_exp, eval_run, base_phase, new_cycle_list);
          }
        }
      }
    }
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void check_already_provided ( Scheme_Hash_Table provided,
Scheme_Object outname,
Scheme_Object name,
int  protected,
Scheme_Object form,
Scheme_Object phase 
) [static]

Definition at line 6774 of file module.c.

{
  Scheme_Object *v;

  v = scheme_hash_get(provided, outname);
  if (v) {
    if (!scheme_stx_module_eq2(SCHEME_CAR(v), name, phase, NULL))
      scheme_wrong_syntax("module", outname, form, "identifier already provided (as a different binding)");
    
    if (protected && SCHEME_FALSEP(SCHEME_CDR(v)))
      scheme_wrong_syntax("module", outname, form, "identifier already provided as unprotected");
    if (!protected && SCHEME_TRUEP(SCHEME_CDR(v)))
      scheme_wrong_syntax("module", outname, form, "identifier already provided as protected");
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int check_already_required ( Scheme_Hash_Table required,
Scheme_Object name 
) [static]

Definition at line 5712 of file module.c.

{
  Scheme_Object *vec;

  vec = scheme_hash_get(required, name);
  if (vec) {
    if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) {
      scheme_hash_set(required, name, NULL);
      return 0;
    }
    return 1;
  }

  return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void check_certified ( Scheme_Object stx,
Scheme_Object certs,
Scheme_Object prot_insp,
Scheme_Object insp,
Scheme_Object rename_insp,
Scheme_Object in_modidx,
Scheme_Env env,
Scheme_Object symbol,
int  var,
int  prot,
int _would_complain 
) [static]

Definition at line 3206 of file module.c.

{
  int need_cert = 1;
  Scheme_Object *midx;

  midx = (env->link_midx ? env->link_midx : env->module->me->src_modidx);
    
  if (stx)
    need_cert = !scheme_stx_certified(stx, certs, prot ? NULL : midx, env->insp);

  if (need_cert && insp)
    need_cert = scheme_module_protected_wrt(env->insp, insp);
  if (need_cert && rename_insp) {
    if (SCHEME_PAIRP(rename_insp)) {
      /* First inspector of pair protects second */
      if (!prot_insp
          || scheme_module_protected_wrt(SCHEME_CAR(rename_insp), prot_insp)) {
        rename_insp = NULL;
      } else
        rename_insp = SCHEME_CDR(rename_insp);
    }
    if (rename_insp)
      need_cert = scheme_module_protected_wrt(env->insp, rename_insp);
  }

  if (need_cert && in_modidx && midx) {
    /* If we're currently executing a macro expander in this module,
       then allow the access under any cirsumstances. This is mostly
       useful for syntax-local-value and local-expand. */
    in_modidx = scheme_module_resolve(in_modidx, 0);
    midx = scheme_module_resolve(midx, 0);
    if (SAME_OBJ(in_modidx, midx))
      need_cert = 0;
  }

  if (need_cert) {
    if (_would_complain) {
      *_would_complain = 1;
    } else {
      /* For error, if stx is no more specific than symbol, drop symbol. */
      if (stx && SAME_OBJ(SCHEME_STX_SYM(stx), symbol)) {
        symbol = stx;
        stx = NULL;
      }
      scheme_wrong_syntax("compile", stx, symbol, 
                          "access from an uncertified context to %s %s from module: %D",
                          prot ? "protected" : "unexported",
                          var ? "variable" : "syntax",
                          env->module->modname);
    }
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void check_dup_require ( Scheme_Object prnt_name,
Scheme_Object name,
Scheme_Object nominal_modidx,
Scheme_Object nominal_name,
Scheme_Object modidx,
Scheme_Object srcname,
int  exet,
int  isval,
void ht,
Scheme_Object e,
Scheme_Object form,
Scheme_Object err_src,
Scheme_Object mark_src,
Scheme_Object to_phase,
Scheme_Object src_phase_index,
Scheme_Object nominal_export_phase,
Scheme_Object in_insp 
) [static]

Definition at line 9099 of file module.c.

{
  Scheme_Object *i;

  if (ht) {
    Scheme_Hash_Table *pht;

    pht = (Scheme_Hash_Table *)scheme_hash_get((Scheme_Hash_Table *)ht, to_phase);
    if (!pht) {
      pht = scheme_make_hash_table(SCHEME_hash_ptr);
      scheme_hash_set((Scheme_Hash_Table *)ht, name, (Scheme_Object *)pht);
    }

    i = scheme_hash_get(pht, name);

    if (i) {
      if (same_resolved_modidx(modidx, SCHEME_CAR(i)) && SAME_OBJ(srcname, SCHEME_CDR(i)))
       return; /* same source */
      scheme_wrong_syntax(NULL, prnt_name, form, "duplicate import identifier");
    } else
      scheme_hash_set((Scheme_Hash_Table *)ht, name, scheme_make_pair(modidx, srcname));
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void check_modchain_consistency ( Scheme_Hash_Table ht,
int  phase 
) [static]

Definition at line 1184 of file module.c.

{ }

Here is the caller graph for this function:

static void check_phase ( Scheme_Env menv,
Scheme_Env env,
int  phase 
) [static]

Definition at line 1183 of file module.c.

{ }

Here is the caller graph for this function:

static void check_require_name ( Scheme_Object prnt_name,
Scheme_Object name,
Scheme_Object nominal_modidx,
Scheme_Object nominal_name,
Scheme_Object modidx,
Scheme_Object exname,
int  exet,
int  isval,
void tables,
Scheme_Object e,
Scheme_Object form,
Scheme_Object err_src,
Scheme_Object mark_src,
Scheme_Object phase,
Scheme_Object src_phase_index,
Scheme_Object nominal_export_phase,
Scheme_Object in_insp 
) [static]

Definition at line 5603 of file module.c.

{
  Scheme_Bucket_Table *toplevel, *syntax;
  Scheme_Hash_Table *required;
  Scheme_Object *vec, *nml, *tvec;

  tvec = scheme_hash_get((Scheme_Hash_Table *)tables, phase);
  if (!tvec) {
    required = get_required_from_tables(tables, phase);
    toplevel = NULL;
    syntax = NULL;
  } else {
    toplevel = (Scheme_Bucket_Table *)(SCHEME_VEC_ELS(tvec)[0]);
    required = (Scheme_Hash_Table *)(SCHEME_VEC_ELS(tvec)[1]);
    syntax = (Scheme_Bucket_Table *)(SCHEME_VEC_ELS(tvec)[2]);
  }

  /* Check that it's not yet defined: */
  if (toplevel) {
    if (scheme_lookup_in_table(toplevel, (const char *)name)) {
      scheme_wrong_syntax("module", prnt_name, form, "imported identifier already defined");
    }
  }

  if (!SAME_OBJ(src_phase_index, scheme_make_integer(0))
      || !SAME_OBJ(nominal_export_phase, scheme_make_integer(0))
      || !SAME_OBJ(nominal_name, prnt_name)) {
    nominal_modidx = scheme_make_pair(nominal_modidx,
                                      scheme_make_pair(src_phase_index,
                                                       scheme_make_pair(nominal_name,
                                                                        scheme_make_pair(nominal_export_phase,
                                                                                         scheme_null))));
  }
           
  /* Check not required, or required from same module: */
  vec = scheme_hash_get(required, name);
  if (vec) {
    Scheme_Object *srcs;
    char *fromsrc = NULL, *fromsrc_colon = "";
    long fromsrclen = 0;
    
    if (same_resolved_modidx(SCHEME_VEC_ELS(vec)[1], modidx)
       && SAME_OBJ(SCHEME_VEC_ELS(vec)[2], exname)) {
      /* already required, same source; add redundant nominal (for re-provides),
         and also add source phase for re-provides. */
      nml = scheme_make_pair(nominal_modidx, SCHEME_VEC_ELS(vec)[0]);
      SCHEME_VEC_ELS(vec)[0] = nml;
      SCHEME_VEC_ELS(vec)[7] = scheme_false;
      return; 
    }

    if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) {
      /* can override */
    } else {
      /* error: already imported */
      srcs = scheme_null;
      if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[5])) {
        srcs = scheme_make_pair(SCHEME_VEC_ELS(vec)[5], srcs);
        /* don't use error_write_to_string_w_max since this is code */
        if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC))) {
          fromsrc = scheme_write_to_string_w_max(scheme_syntax_to_datum(SCHEME_VEC_ELS(vec)[5], 0, NULL), 
                                                 &fromsrclen, 32);
          fromsrc_colon = ":";
        }
      }
      
      if (!fromsrc) {
        fromsrc = "a different source";
        fromsrclen = strlen(fromsrc);
      }

      if (err_src)
        srcs = scheme_make_pair(err_src, srcs);

      scheme_wrong_syntax_with_more_sources("module", prnt_name, err_src, srcs,
                                            "identifier already imported from%s %t",
                                            fromsrc_colon, fromsrc, fromsrclen);
    }
  }
           
  /* Check not syntax: */
  if (syntax) {
    if (scheme_lookup_in_table(syntax, (const char *)name)) {
      scheme_wrong_syntax("module", prnt_name, form, "imported identifier already defined");
    }
  }

  /* Remember require: */
  vec = scheme_make_vector(10, NULL);
  nml = scheme_make_pair(nominal_modidx, scheme_null);
  SCHEME_VEC_ELS(vec)[0] = nml;
  SCHEME_VEC_ELS(vec)[1] = modidx;
  SCHEME_VEC_ELS(vec)[2] = exname;
  SCHEME_VEC_ELS(vec)[3] = (isval ? scheme_true : scheme_false);
  SCHEME_VEC_ELS(vec)[4] = prnt_name;
  SCHEME_VEC_ELS(vec)[5] = (err_src ? err_src : scheme_false);
  SCHEME_VEC_ELS(vec)[6] = (mark_src ? mark_src : scheme_false);
  SCHEME_VEC_ELS(vec)[7] = scheme_false;
  SCHEME_VEC_ELS(vec)[8] = scheme_make_integer(exet);
  SCHEME_VEC_ELS(vec)[9] = in_insp;
  scheme_hash_set(required, name, vec);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int check_requires_ok ( Scheme_Object l) [static]

Definition at line 9511 of file module.c.

{
  Scheme_Object *x;
  while (!SCHEME_NULLP(l)) {
    x = SCHEME_CAR(l);
    if (!SCHEME_SYMBOLP(x) && !SAME_TYPE(SCHEME_TYPE(x), scheme_module_index_type))
      return 0;
    l = SCHEME_CDR(l);
  }
  return 1;
}

Here is the caller graph for this function:

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

Definition at line 752 of file module.c.

{
  if (scheme_check_proc_arity(NULL, 1, 0, argc, argv)
      && scheme_check_proc_arity(NULL, 3, 0, argc, argv)
      && scheme_check_proc_arity(NULL, 4, 0, argc, argv))
    return argv[0];

  scheme_wrong_type("current-module-name-resolver", "procedure of arity 1, 3, and 4", 0, argc, argv);

  return NULL;
}

Here is the caller graph for this function:

static Scheme_Object ** compute_indirects ( Scheme_Env genv,
Scheme_Module_Phase_Exports pt,
int _count,
int  vars 
) [static]

Definition at line 7136 of file module.c.

{
  int i, count, j, start, end;
  Scheme_Bucket **bs, *b;
  Scheme_Object **exsns = pt->provide_src_names, **exis;
  int exicount;
  Scheme_Bucket_Table *t;

  if (vars) {
    start = 0;
    end = pt->num_var_provides;
  } else {
    start = pt->num_var_provides;
    end = pt->num_provides;
  }

  if (vars)
    t = genv->toplevel;
  else
    t = genv->syntax;
    

  if (!t)
    count = 0;
  else {
    bs = t->buckets;
    for (count = 0, i = t->size; i--; ) {
      b = bs[i];
      if (b && b->val)
        count++;
    }
  }

  if (!count) {
    *_count = 0;
    return NULL;
  }
  
  exis = MALLOC_N(Scheme_Object *, count);

  for (count = 0, i = t->size; i--; ) {
    b = bs[i];
    if (b && b->val) {
      Scheme_Object *name;
      
      name = (Scheme_Object *)b->key;
      
      /* If the name is directly provided, no need for indirect... */
      for (j = start; j < end; j++) {
        if (SAME_OBJ(name, exsns[j]))
          break;
      }
       
      if (j == end)
        exis[count++] = name;
    }
  }

  if (!count) {
    *_count = 0;
    return NULL;
  }
  
  exicount = count;

  qsort_provides(exis, NULL, NULL, NULL, NULL, NULL, NULL, 0, exicount, 1);

  *_count = exicount;
  return exis;
}

Here is the call graph for this function:

Here is the caller graph for this function:

char * compute_provide_arrays ( Scheme_Hash_Table all_provided,
Scheme_Hash_Table tables,
Scheme_Module_Exports me,
Scheme_Env genv,
Scheme_Object form,
char **  _phase1_protects 
) [static]

Definition at line 7417 of file module.c.

{
  int i, count, z, implicit;
  Scheme_Object **exs, **exsns, **exss, **exsnoms, **exinsps, *phase;
  Scheme_Hash_Table *provided, *required;
  char *exps, *exets, *phase0_exps = NULL, *phase1_exps = NULL;
  int excount, exvcount;
  Scheme_Module_Phase_Exports *pt;
  Scheme_Object *implicit_src, *implicit_src_name, *implicit_mod_phase;
  Scheme_Object *implicit_nominal_name, *implicit_nominal_mod;
  Scheme_Object *implicit_insp;

  for (z = 0; z < all_provided->size; z++) {
    provided = (Scheme_Hash_Table *)all_provided->vals[z];

    if (provided) {
      phase = all_provided->keys[z];
      required = get_required_from_tables(tables, phase);
      if (!required)
        required = scheme_make_hash_table(SCHEME_hash_ptr);
      
      if (SAME_OBJ(phase, scheme_make_integer(0)))
        pt = me->rt;
      else if (SAME_OBJ(phase, scheme_make_integer(1)))
        pt = me->et;
      else if (SAME_OBJ(phase, scheme_false))
        pt = me->dt;
      else {
        pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports);
        pt->so.type = scheme_module_phase_exports_type;
        pt->phase_index = phase;
        if (!me->other_phases) {
          Scheme_Hash_Table *ht;
          ht = scheme_make_hash_table_equal();
          me->other_phases = ht;
        }
        scheme_hash_set(me->other_phases, phase, (Scheme_Object *)pt);
      }

      for (count = 0, i = provided->size; i--; ) {
        if (provided->vals[i])
          count++;
      }
    
      exs = MALLOC_N(Scheme_Object *, count);
      exsns = MALLOC_N(Scheme_Object *, count);
      exss = MALLOC_N(Scheme_Object *, count);
      exsnoms = MALLOC_N(Scheme_Object *, count);
      exinsps = MALLOC_N(Scheme_Object *, count);
      exps = MALLOC_N_ATOMIC(char, count);
      exets = MALLOC_N_ATOMIC(char, count);
      memset(exets, 0, count);

      /* Do non-syntax first. */
      for (count = 0, i = provided->size; i--; ) {
        if (provided->vals[i]) {
          Scheme_Object *name, *prnt_name, *v;
          int protected;
       
          v = provided->vals[i]; /* external name */
          name = SCHEME_CAR(v);  /* internal name (maybe already a symbol) */
          protected = SCHEME_TRUEP(SCHEME_CDR(v));
          prnt_name = name;

          name = extract_free_id_name(name, phase, genv, 1, &implicit, 
                                      NULL, NULL, NULL, 
                                      NULL, NULL, NULL);

          if (!implicit
              && genv 
              && (SAME_OBJ(phase, scheme_make_integer(0))
                  || SAME_OBJ(phase, scheme_make_integer(1)))
              && scheme_lookup_in_table(SAME_OBJ(phase, scheme_make_integer(0))
                                        ? genv->toplevel
                                        : genv->exp_env->toplevel,
                                        (const char *)name)) {
            /* Defined locally */
            exs[count] = provided->keys[i];
            exsns[count] = name;
            exss[count] = scheme_false; /* means "self" */
            exsnoms[count] = scheme_null; /* since "self" */
            exps[count] = protected;
            if (SAME_OBJ(phase, scheme_make_integer(1)))
              exets[count] = 1;
            count++;
          } else if (!implicit
                     && genv 
                     && SAME_OBJ(phase, scheme_make_integer(0))
                     && scheme_lookup_in_table(genv->syntax, (const char *)name)) {
            /* Skip syntax for now. */
          } else if (implicit) {
            /* Rename-transformer redirect; skip for now. */
          } else if ((v = scheme_hash_get(required, name))) {
            /* Required */
            if (protected) {
              name = SCHEME_CAR(provided->vals[i]);
              scheme_wrong_syntax("module", NULL, name, "cannot protect imported identifier with re-provide"); 
            }
            if (SCHEME_TRUEP(SCHEME_VEC_ELS(v)[3])) {
              Scheme_Object *noms;
              exs[count] = provided->keys[i];
              exsns[count] = SCHEME_VEC_ELS(v)[2];
              exss[count] = SCHEME_VEC_ELS(v)[1];
              noms = adjust_for_rename(exs[count], SCHEME_VEC_ELS(v)[4], SCHEME_VEC_ELS(v)[0]);
              exsnoms[count] = noms;
              exps[count] = protected;
              if (SAME_OBJ(SCHEME_VEC_ELS(v)[8], scheme_make_integer(1)))
                exets[count] = 1;              
              if (SCHEME_TRUEP(SCHEME_VEC_ELS(v)[9]))
                exinsps[count] = SCHEME_VEC_ELS(v)[9];

              count++;
            }
          } else {
            /* Not defined! */
            scheme_wrong_syntax("module", prnt_name, form, "provided identifier not defined or imported");
          }
        }
      }

      exvcount = count;

      for (i = provided->size; i--; ) {
        if (provided->vals[i]) {
          Scheme_Object *name, *v;
          int protected;
         
          v = provided->vals[i];
          name = SCHEME_CAR(v); /* internal name (maybe already a symbol) */
          protected = SCHEME_TRUEP(SCHEME_CDR(v));

          name = extract_free_id_name(name, phase, genv, 0, &implicit,
                                      &implicit_src, &implicit_src_name, 
                                      &implicit_mod_phase,
                                      &implicit_nominal_name, &implicit_nominal_mod,
                                      &implicit_insp);

          if (!implicit
              && genv 
              && SAME_OBJ(phase, scheme_make_integer(0))
              && scheme_lookup_in_table(genv->syntax, (const char *)name)) {
            /* Defined locally */
            exs[count] = provided->keys[i];
            exsns[count] = name;
            exss[count] = scheme_false; /* means "self" */
            exsnoms[count] = scheme_null; /* since "self" */
            exps[count] = protected;
            count++;
          } else if (implicit) {
            /* We record all free-id=?-based exprts as syntax, even though they may be values. */
            Scheme_Object *noms;
            exs[count] = provided->keys[i];
            exsns[count] = implicit_src_name;
            exss[count] = implicit_src;
            noms = adjust_for_rename(exs[count], implicit_nominal_name, cons(implicit_nominal_mod, scheme_null));
            exsnoms[count] = noms;
            exps[count] = protected;
            if (implicit_insp) {
              if (protected) {
                implicit_insp = cons(genv->insp, implicit_insp);
              }
              exinsps[count] = implicit_insp;
            }
            count++;
          } else if ((v = scheme_hash_get(required, name))) {
            /* Required */
            if (SCHEME_FALSEP(SCHEME_VEC_ELS(v)[3])) {
              Scheme_Object *noms;
              exs[count] = provided->keys[i];
              exsns[count] = SCHEME_VEC_ELS(v)[2];
              exss[count] = SCHEME_VEC_ELS(v)[1];
              noms = adjust_for_rename(exs[count], SCHEME_VEC_ELS(v)[4], SCHEME_VEC_ELS(v)[0]);
              exsnoms[count] = noms;
              exps[count] = protected;
              if (SCHEME_TRUEP(SCHEME_VEC_ELS(v)[9]))
                exinsps[count] = SCHEME_VEC_ELS(v)[9];
              count++;
            }
          }
        }
      }

      excount = count;

      /* Discard exsnom[n]s if there are no re-exports */
      for (i = 0; i < excount; i++) {
        if (!SCHEME_NULLP(exsnoms[i]))
          break;
      }
      if (i >= excount) {
        exsnoms = NULL;
      }

      /* Discard exinsps if there are no inspectors */
      for (i = 0; i < excount; i++) {
        if (exinsps[i])
          break;
      }
      if (i >= excount) {
        exinsps = NULL;
      }

      /* Discard exets if all 0 */
      if (exets) {
        for (i = 0; i < excount; i++) {
          if (exets[i])
            break;
        }
        if (i >= excount)
          exets = NULL;
      }

      /* Sort provide array for variables: interned followed by
         uninterned, alphabetical within each. This is important for
         having a consistent provide arrays. */
      qsort_provides(exs, exsns, exss, exps, exets, exsnoms, exinsps, 0, exvcount, 1);

      pt->num_provides = excount;
      pt->num_var_provides = exvcount;
      pt->provides = exs;
      pt->provide_src_names = exsns;
      pt->provide_srcs = exss;
      pt->provide_nominal_srcs = exsnoms;
      pt->provide_insps = exinsps;
      pt->provide_src_phases = exets;

      if (SAME_OBJ(phase, scheme_make_integer(0)))
        phase0_exps = exps;
      else if (SAME_OBJ(phase, scheme_make_integer(1)))
        phase1_exps = exps;
    }
  }

  *_phase1_protects = phase1_exps;
    
  return phase0_exps;
}

Here is the call graph for this function:

Here is the caller graph for this function:

int compute_reprovides ( Scheme_Hash_Table all_provided,
Scheme_Hash_Table all_reprovided,
Scheme_Module mod_for_requires,
Scheme_Hash_Table tables,
Scheme_Env genv,
Scheme_Object all_rt_defs,
Scheme_Object all_rt_defs_out,
Scheme_Object all_et_defs,
Scheme_Object all_et_defs_out,
const char *  matching_form,
Scheme_Object all_mods,
Scheme_Object all_phases 
) [static]

Definition at line 6791 of file module.c.

{
  Scheme_Hash_Table *provided, *required;
  Scheme_Object *reprovided, *tvec;
  int i, k, z;
  Scheme_Object *rx, *provided_list, *phase, *req_phase;
  Scheme_Object *all_defs, *all_defs_out;
  Scheme_Env *genv;

  if (all_phases) {
    /* synthesize all_reprovided for the loop below: */
    if (all_mods)
      reprovided = scheme_make_pair(scheme_false, scheme_null);
    else
      reprovided = all_phases;
    all_reprovided = scheme_make_hash_table_equal();
    if (mod_for_requires->requires
        && !SCHEME_NULLP(mod_for_requires->requires))
      scheme_hash_set(all_reprovided, scheme_make_integer(0), reprovided);
    if (mod_for_requires->et_requires
        && !SCHEME_NULLP(mod_for_requires->et_requires))
      scheme_hash_set(all_reprovided, scheme_make_integer(1), reprovided);
    if (mod_for_requires->tt_requires
        && !SCHEME_NULLP(mod_for_requires->tt_requires))
      scheme_hash_set(all_reprovided, scheme_make_integer(-1), reprovided);
    if (mod_for_requires->dt_requires
        && !SCHEME_NULLP(mod_for_requires->dt_requires))
      scheme_hash_set(all_reprovided, scheme_false, reprovided);
    if (mod_for_requires->other_requires) {
      for (z = 0; z < mod_for_requires->other_requires->size; z++) {
        if (mod_for_requires->other_requires->vals[z])
          scheme_hash_set(all_reprovided, 
                          mod_for_requires->other_requires->keys[z],
                          reprovided);
      }
    }
  } else if (all_mods) {
    reprovided = scheme_make_pair(scheme_false, scheme_null);
    all_reprovided = scheme_make_hash_table_equal();
    while (SCHEME_PAIRP(all_mods)) {
      scheme_hash_set(all_reprovided, SCHEME_CAR(all_mods), reprovided);
      all_mods = SCHEME_CDR(all_mods);
    }
  }

  /* First, check the sanity of the re-provide specifications (unless
     we synthesized them): */
  if (!all_mods) {
    for (z = 0; z < all_reprovided->size; z++) {
      if (all_reprovided->vals[z]) {
        Scheme_Object *requires;

        reprovided = all_reprovided->vals[z];
        phase = all_reprovided->keys[z];

        if (SAME_OBJ(phase, scheme_make_integer(0))) {
          requires = mod_for_requires->requires;
        } else if (SAME_OBJ(phase, scheme_make_integer(1))) {
          requires = mod_for_requires->et_requires;
        } else if (SAME_OBJ(phase, scheme_make_integer(-1))) {
          requires = mod_for_requires->tt_requires;
        } else if (SAME_OBJ(phase, scheme_false)) {
          requires = mod_for_requires->dt_requires;
        } else {
          if (mod_for_requires->other_requires)
            requires = scheme_hash_get(mod_for_requires->other_requires, phase);
          else
            requires = NULL;
        }
        if (!requires)
          requires = scheme_null;
        
        for (rx = reprovided; !SCHEME_NULLP(rx); rx = SCHEME_CDR(rx)) {
          Scheme_Object *midx = SCHEME_CAR(SCHEME_CAR(rx)), *l, *exns;
       
          for (l = requires; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
            if (same_modidx(midx, SCHEME_CAR(l)))
              break;
          }
          if (SCHEME_NULLP(l)) {
            /* Didn't require the named module */
            if (matching_form) {
              Scheme_Object *name;
              name = SCHEME_CAR(rx);
              name = SCHEME_STX_CDR(name);
              name = SCHEME_STX_CAR(name);
              scheme_wrong_syntax("module", 
                                  SCHEME_MODNAMEP(midx) ? midx : ((Scheme_Modidx *)midx)->path, 
                                  name,
                                  "cannot provide from a module without a matching `%s'",
                                  matching_form);
            } else {
              return 0;
            }
          }

          exns = SCHEME_CDR(SCHEME_CDR(SCHEME_CAR(rx)));
          for (l = exns; !SCHEME_STX_NULLP(l); l = SCHEME_STX_CDR(l)) {
            /* Make sure excluded name was required: */
            Scheme_Object *a, *vec = NULL;
            a = SCHEME_STX_VAL(SCHEME_STX_CAR(l));

            for (k = 0; k < tables->size; k++) {
              if (tables->vals[k]) {
                tvec = tables->vals[k];
                required = (Scheme_Hash_Table *)SCHEME_VEC_ELS(tvec)[1];
                
                if (required)
                  vec = scheme_hash_get(required, a);
                else
                  vec = NULL;
      
                if (vec) {
                  /* Check for nominal modidx in list */
                  Scheme_Object *nml, *nml_modidx;
                  nml = SCHEME_VEC_ELS(vec)[0];
                  for (; SCHEME_PAIRP(nml); nml = SCHEME_CDR(nml)) {
                    nml_modidx = SCHEME_CAR(nml);
                    if (SCHEME_PAIRP(nml_modidx))
                      nml_modidx = SCHEME_CAR(nml_modidx);
                    if (same_modidx(SCHEME_CAR(SCHEME_CAR(rx)), nml_modidx))
                      break;
                  }
                  if (!SCHEME_PAIRP(nml))
                    vec = NULL; /* So it was provided, but not from the indicated module */
                }

                if (vec)
                  break;
              }
            }
            if (!vec) {
              a = SCHEME_STX_CAR(l);
              scheme_wrong_syntax("module", a, SCHEME_CADR(SCHEME_CAR(rx)),
                                  "excluded name was not required from the module");
            }
          }
        }
      }
    }
  }

  /* For each reprovided, walk through requires, check for re-provided bindings: */
  for (z = 0; z < all_reprovided->size; z++) {
    reprovided = all_reprovided->vals[z];
    if (reprovided && !SCHEME_NULLP(reprovided)) {
      phase = all_reprovided->keys[z];

      for (k = 0; k < tables->size; k++) {
        tvec = tables->vals[k];
        if (tvec) {
          required = (Scheme_Hash_Table *)SCHEME_VEC_ELS(tvec)[1];
          req_phase = tables->keys[k];

          for (i = required->size; i--; ) {
            if (required->vals[i]) {
              Scheme_Object *nominal_modidx, *name, *modidx, *srcname, *outname, *nml, *orig_nml, *mark_src;
              int break_outer = 0;
       
              name = required->keys[i]; /* internal symbolic name */
              orig_nml = SCHEME_VEC_ELS(required->vals[i])[0];
              modidx = SCHEME_VEC_ELS(required->vals[i])[1];
              srcname = SCHEME_VEC_ELS(required->vals[i])[2];
              outname = SCHEME_VEC_ELS(required->vals[i])[4];
              mark_src = SCHEME_VEC_ELS(required->vals[i])[6];

              for (rx = reprovided; !SCHEME_NULLP(rx); rx = SCHEME_CDR(rx)) {
                for (nml = orig_nml; SCHEME_PAIRP(nml); nml = SCHEME_CDR(nml)) {
                  nominal_modidx = SCHEME_CAR(nml);
                  if (SCHEME_PAIRP(nominal_modidx))
                    nominal_modidx = SCHEME_CAR(nominal_modidx);
                  if (all_mods || same_modidx(SCHEME_CAR(SCHEME_CAR(rx)), nominal_modidx)) {
                    Scheme_Object *nml_pi;

                    if (SCHEME_PAIRP(SCHEME_CAR(nml)))
                      nml_pi = SCHEME_CADR(SCHEME_CAR(nml));
                    else
                      nml_pi = scheme_make_integer(0);

                    if (SAME_OBJ(phase, nml_pi)) {
                      Scheme_Object *exns, *ree;

                      if (!all_mods) {
                        break_outer = 1;
                  
                        ree = SCHEME_CDR(SCHEME_CAR(rx));

                        exns = SCHEME_CDR(ree);
                      } else {
                        ree = NULL;
                        exns = scheme_null;
                      }
           
                      for (; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) {
                        /* Was this name excluded? */
                        Scheme_Object *a;
                        a = SCHEME_STX_VAL(SCHEME_STX_CAR(exns));
                        if (SAME_OBJ(a, name))
                          break;
                      }

                      if (SCHEME_STX_NULLP(exns)) {
                        /* Not excluded, so provide it. */
                        if (matching_form) {
                          /* Assert: !all_mods */
                          provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, req_phase);
                          if (!provided) {
                            provided = scheme_make_hash_table(SCHEME_hash_ptr);
                            scheme_hash_set(all_provided, req_phase, (Scheme_Object *)provided);
                          }
                          check_already_provided(provided, outname, name, 0, SCHEME_CAR(ree), req_phase);
                          scheme_hash_set(provided, outname, scheme_make_pair(name, scheme_false));
                        } else {
                          if (SCHEME_TRUEP(mark_src)) {
                            if (SCHEME_SYM_PARALLELP(name)) {
                              /* reverse scheme_tl_id_sym */
                              char *s;
                              int len;
                              len = SCHEME_SYM_LEN(name);
                              s = scheme_malloc_atomic(len + 1);
                              memcpy(s, SCHEME_SYM_VAL(name), len+1);
                              while (len && (s[len] != '.')) {
                                --len;
                              }
                              s[len] = 0;
                              name = scheme_intern_exact_symbol(s, len);
                            }
                            name = scheme_datum_to_syntax(name, scheme_false, mark_src, 0, 0);
                          } else {
                            scheme_signal_error("found an import with no lexical context");
                          }

                          provided_list = scheme_hash_get(all_provided, req_phase);
                          if (!provided_list)
                            provided_list = scheme_null;
                          provided_list = scheme_make_pair(name, provided_list);
                          scheme_hash_set(all_provided, req_phase, provided_list);
                        }
                      }
                    }
                  }
                  if (break_outer) break;
                }
              }
            }
          }
        }
      }
    }
  }

  /* Do all-defined provides */
  for (z = 0; z < 2; z++) {
    if (!z) {
      all_defs = all_rt_defs;
      all_defs_out = all_rt_defs_out;
      provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, scheme_make_integer(0));
      phase = scheme_make_integer(0);
      genv = _genv;
    } else {
      all_defs = all_et_defs;
      all_defs_out = all_et_defs_out;
      provided = (Scheme_Hash_Table *)scheme_hash_get(all_provided, scheme_make_integer(1));
      phase = scheme_make_integer(1);
      genv = _genv->exp_env;
    }

    if (all_defs_out) {
      for (; !SCHEME_NULLP(all_defs_out); all_defs_out = SCHEME_CDR(all_defs_out)) {
        Scheme_Object *exns, *ree, *ree_kw, *exl, *name, *a, *adl, *exname, *pfx;
        int protected;
           
        ree = SCHEME_CAR(all_defs_out);
        protected = SCHEME_TRUEP(SCHEME_CDR(ree));
        ree = SCHEME_CAR(ree);
        ree_kw = SCHEME_CAR(ree);
        ree = SCHEME_CDR(ree);
        exl = SCHEME_CAR(ree);
        pfx = SCHEME_CDR(ree);

        /* Make sure each excluded name was defined: */
        for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) {
          a = SCHEME_STX_CAR(exns);
          name = scheme_tl_id_sym(genv, a, NULL, 0, NULL, NULL);
          if (!scheme_lookup_in_table(genv->toplevel, (const char *)name)
              && !scheme_lookup_in_table(genv->syntax, (const char *)name)) {
            scheme_wrong_syntax("module", a, ree_kw, "excluded identifier was not defined");
          }
        }

        for (adl = all_defs; SCHEME_PAIRP(adl); adl = SCHEME_CDR(adl)) {
          name = SCHEME_CAR(adl);
          exname = SCHEME_STX_SYM(name);
          name = scheme_tl_id_sym(genv, name, NULL, 0, NULL, NULL);
       
          /* Was this one excluded? */
          for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) {
            a = SCHEME_STX_CAR(exns);
            a = scheme_tl_id_sym(genv, a, NULL, 0, NULL, NULL);
            if (SAME_OBJ(a, name))
              break;
          }

          if (SCHEME_STX_NULLP(exns)) {
            /* not excluded */
         
            /* But don't export uninterned: */
            if (!SCHEME_SYM_UNINTERNEDP(name)) {
              /* Also, check that ree_kw and the identifier have the same
                 introduction (in case one or the other was introduced by
                 a macro). We perform this check by getting exname's tl_id
                 as if it had ree_kw's context, then comparing that result
                 to the actual tl_id. */
              a = scheme_datum_to_syntax(exname, scheme_false, ree_kw, 0, 0);
              a = scheme_tl_id_sym(genv, a, NULL, 0, NULL, NULL);
           
              if (SAME_OBJ(a, name)) {
                /* Add prefix, if any */
                if (SCHEME_TRUEP(pfx)) {
                  exname = scheme_symbol_append(pfx, exname);
                }
                check_already_provided(provided, exname, name, protected, ree_kw, phase);
             
                scheme_hash_set(provided, exname, 
                                scheme_make_pair(name, protected ? scheme_true : scheme_false));
              }
            }
          }
        }
      }
    }
  }

  return 1;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void compute_require_names ( Scheme_Env menv,
Scheme_Object phase,
Scheme_Env load_env,
Scheme_Object syntax_idx 
) [static]

Definition at line 3601 of file module.c.

{
  Scheme_Object *np, *midx, *l, *reqs, *req_names;

  if (SAME_OBJ(phase, scheme_make_integer(0))) {
    req_names = menv->require_names;
    reqs = menv->module->requires;
  } else if (SAME_OBJ(phase, scheme_make_integer(1))) {
    req_names = menv->et_require_names;
    reqs = menv->module->et_requires;
  } else if (SAME_OBJ(phase, scheme_make_integer(-1))) {
    req_names = menv->tt_require_names;
    reqs = menv->module->tt_requires;
  } else if (SAME_OBJ(phase, scheme_false)) {
    req_names = menv->dt_require_names;
    reqs = menv->module->dt_requires;
  } else {
    if (menv->module->other_requires) {
      reqs = scheme_hash_get(menv->module->other_requires, phase);
      if (!reqs)
        reqs = scheme_null;
    } else
      reqs = scheme_null;
    if (!SCHEME_NULLP(reqs) && !menv->other_require_names) {
      Scheme_Hash_Table *ht;
      ht = scheme_make_hash_table_equal();
      menv->other_require_names = ht;
    }
    if (menv->other_require_names)
      req_names = scheme_hash_get(menv->other_require_names, phase);
    else
      req_names = NULL;
  }

  if (req_names && !SCHEME_NULLP(req_names))
    return;

  np = scheme_null;

  for (l = reqs; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
    midx = scheme_modidx_shift(SCHEME_CAR(l), 
                               menv->module->me->src_modidx, 
                               (syntax_idx ? syntax_idx : menv->link_midx));

    if (load_env)
      module_load(scheme_module_resolve(midx, 1), load_env, NULL);
    
    np = cons(midx, np);
  }

  if (!SAME_OBJ(np, req_names)) {
    if (SAME_OBJ(phase, scheme_make_integer(0))) {
      menv->require_names = np;
    } else if (SAME_OBJ(phase, scheme_make_integer(1))) {
      menv->et_require_names = np;
    } else if (SAME_OBJ(phase, scheme_make_integer(-1))) {
      menv->tt_require_names = np;
    } else if (SAME_OBJ(phase, scheme_false)) {
      menv->dt_require_names = np;
    } else {
      if (menv->other_require_names)
        scheme_hash_set(menv->other_require_names, phase, np);
    }
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 784 of file module.c.

{
  return scheme_param_config("current-module-declared-name",
                          scheme_make_integer(MZCONFIG_CURRENT_MODULE_NAME),
                          argc, argv,
                          -1, prefix_p, "resolved-module-path or #f", 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 765 of file module.c.

{
  return scheme_param_config("current-module-name-resolver",
                          scheme_make_integer(MZCONFIG_CURRENT_MODULE_RESOLVER),
                          argc, argv,
                          -1, check_resolver, "procedure of arity 1, 3, and 4", 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object** declare_insps ( int  n,
Scheme_Object **  insps,
Scheme_Object insp 
) [static]

Definition at line 4646 of file module.c.

{
  int i;
  Scheme_Object **naya, *v;

  for (i = 0; i < n; i++) {
    if (insps[i] && SCHEME_PAIRP(insps[i]))
      break;
  }
  if (i >= n)
    return insps;
  
  insp = scheme_make_inspector(insp);

  naya = MALLOC_N(Scheme_Object*, n);
  for (i = 0; i < n; i++) {
    v = insps[i];
    if (v && SCHEME_PAIRP(v)) {
      v = cons(insp, SCHEME_CDR(v));
    }
    naya[i] = v;
  }

  return naya;
}

Here is the caller graph for this function:

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

Definition at line 732 of file module.c.

{
  Scheme_Object *p = argv[0];

  if (argc == 1)
    return scheme_void; /* ignore notify */

  if (SCHEME_PAIRP(p)
      && SAME_OBJ(SCHEME_CAR(p), quote_symbol)
      && SCHEME_PAIRP(SCHEME_CDR(p))
      && SCHEME_SYMBOLP(SCHEME_CAR(SCHEME_CDR(p)))
      && SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(p))))
    return scheme_intern_resolved_module_path(SCHEME_CAR(SCHEME_CDR(p)));

  scheme_arg_mismatch("default-module-name-resolver", 
                    "the kernel's resolver works only on `quote' forms; given: ", 
                    p);
  return NULL;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int did_start ( Scheme_Object v,
int  base_phase,
int  eval_exp,
int  eval_run 
) [static]

Definition at line 3541 of file module.c.

{
  long key;

  key = make_key(base_phase, eval_exp, eval_run);

  if (!v)
    return 0;

  if (scheme_hash_tree_get((Scheme_Hash_Tree *)v, scheme_make_integer(key)))
    return 1;

  return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int do_add_simple_require_renames ( Scheme_Object rn,
Scheme_Hash_Table required,
Scheme_Object orig_src,
Scheme_Module im,
Scheme_Module_Phase_Exports pt,
Scheme_Object idx,
Scheme_Object marshal_phase_index,
Scheme_Object src_phase_index,
int  can_override 
) [static]

Definition at line 2170 of file module.c.

{
  int i, saw_mb, numvals;
  Scheme_Object **exs, **exss, **exsns, *midx, *info, *vec, *nml, *mark_src, **exinsps;
  char *exets;
  int with_shared = 1;

  saw_mb = 0;

  if (!pt->num_provides)
    return 0;

  if (with_shared) {
    if (!pt->src_modidx)
      pt->src_modidx = im->me->src_modidx;
    scheme_extend_module_rename_with_shared(rn, idx, pt, 
                                            marshal_phase_index, 
                                            scheme_make_integer(0), 
                                            scheme_null,
                                            1);
  }

  mark_src = scheme_rename_to_stx(rn);

  exs = pt->provides;
  exsns = pt->provide_src_names;
  exss = pt->provide_srcs;
  exets = pt->provide_src_phases;
  exinsps = pt->provide_insps;
  numvals = pt->num_var_provides;
  for (i = pt->num_provides; i--; ) {
    if (exss && !SCHEME_FALSEP(exss[i]))
      midx = scheme_modidx_shift(exss[i], im->me->src_modidx, idx);
    else
      midx = idx;
    if (!with_shared) {
      scheme_extend_module_rename(rn, midx, exs[i], exsns[i], idx, exs[i], 
                                  exets ? exets[i] : 0, src_phase_index, pt->phase_index, 
                                  exinsps ? exinsps[i] : NULL, 1);
    }
    if (SAME_OBJ(exs[i], module_begin_symbol))
      saw_mb = 1;

    if (required) {
      vec = scheme_make_vector(10, NULL);
      nml = scheme_make_pair(idx, scheme_null);
      SCHEME_VEC_ELS(vec)[0] = nml;
      SCHEME_VEC_ELS(vec)[1] = midx;
      SCHEME_VEC_ELS(vec)[2] = exsns[i];
      SCHEME_VEC_ELS(vec)[3] = ((i < numvals) ? scheme_true : scheme_false);
      SCHEME_VEC_ELS(vec)[4] = exs[i];
      SCHEME_VEC_ELS(vec)[5] = orig_src;
      SCHEME_VEC_ELS(vec)[6] = mark_src;
      SCHEME_VEC_ELS(vec)[7] = (can_override ? scheme_true : scheme_false);
      SCHEME_VEC_ELS(vec)[8] = exets ? scheme_make_integer(exets[i]) : scheme_false;
      SCHEME_VEC_ELS(vec)[9] = exinsps ? exinsps[i] : scheme_false;
      scheme_hash_set(required, exs[i], vec);
    }
  }

  if (!with_shared) {
    info = cons(idx, cons(marshal_phase_index, 
                          cons(scheme_make_integer(0),
                               cons(scheme_null, scheme_false))));
    scheme_save_module_rename_unmarshal(rn, info);
  }

  return saw_mb;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_module ( Scheme_Object form,
Scheme_Comp_Env env,
Scheme_Compile_Expand_Info rec,
int  drec 
) [static]

Definition at line 5289 of file module.c.

{
  Scheme_Object *fm, *nm, *ii, *rn, *et_rn, *iidx, *self_modidx, *rmp, *rn_set;
  Scheme_Module *iim;
  Scheme_Env *menv, *top_env;
  Scheme_Comp_Env *benv;
  Scheme_Module *m;
  Scheme_Object *mbval, *orig_ii;
  int saw_mb, check_mb = 0;
  int restore_confusing_name = 0;
  LOG_EXPAND_DECLS;

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

  fm = SCHEME_STX_CDR(form);
  if (!SCHEME_STX_PAIRP(fm))
    scheme_wrong_syntax(NULL, NULL, form, NULL);
  nm = SCHEME_STX_CAR(fm);
  if (!SCHEME_STX_SYMBOLP(nm))
    scheme_wrong_syntax(NULL, nm, form, "module name is not an identifier");
  fm = SCHEME_STX_CDR(fm);
  if (!SCHEME_STX_PAIRP(fm))
    scheme_wrong_syntax(NULL, NULL, form, NULL);
  ii = SCHEME_STX_CAR(fm);
  fm = SCHEME_STX_CDR(fm);

  m = MALLOC_ONE_TAGGED(Scheme_Module);
  m->so.type = scheme_module_type;

  /* must set before calling new_module_env: */
  rmp = SCHEME_STX_VAL(nm);
  rmp = scheme_intern_resolved_module_path(rmp);
  m->modname = rmp;

  LOG_START_EXPAND(m);

  if (SAME_OBJ(m->modname, kernel_modname)) {
    /* Too confusing. Give it a different name while compiling. */
    Scheme_Object *k2;
    k2 = scheme_intern_resolved_module_path(scheme_make_symbol("#%kernel")); /* uninterned! */
    m->modname = k2;
    restore_confusing_name = 1;
  }

  {
    Scheme_Module_Exports *me;
    me = make_module_exports();
    m->me = me;
  }

  top_env = env->genv;
  /* Create module env from phase-0 env. This doesn't create bad
     sharing, because compile-time module instances for compiling this
     module are all fresh instances. */
  while (top_env->phase) {
    scheme_prepare_template_env(top_env);
    top_env = top_env->template_env;
  }

  menv = scheme_new_module_env(top_env, m, 1);

  menv->disallow_unbound = 1;
  
  self_modidx = scheme_make_modidx(scheme_false, scheme_false, m->modname);
  m->self_modidx = self_modidx;
  m->me->src_modidx = self_modidx;

  m->insp = env->insp;

  m->ii_src = ii;

  orig_ii = ii;
  ii = scheme_syntax_to_datum(ii, 0, NULL);

  if (!scheme_is_module_path(ii)) {
    scheme_wrong_syntax(NULL, m->ii_src, form, "initial import is not a well-formed module path");
  }

  iidx = scheme_make_modidx(ii, 
                         self_modidx,
                         scheme_false);

  SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer);

  /* load the module for the initial require */
  iim = module_load(_module_resolve(iidx, m->ii_src, NULL, 1), menv, NULL); 
  start_module(iim, menv, 0, iidx, 1, 0, menv->phase, scheme_null);

  {
    Scheme_Object *ins;
    ins = cons(iidx, scheme_null);
    m->requires = ins;
    m->et_requires = scheme_null;
    m->tt_requires = scheme_null;
    m->dt_requires = scheme_null;
  }

  scheme_prepare_env_renames(menv, mzMOD_RENAME_NORMAL);

  rn_set = menv->rename_set;
  rn = scheme_get_module_rename_from_set(rn_set, scheme_make_integer(0), 1);
  et_rn = scheme_get_module_rename_from_set(rn_set, scheme_make_integer(1), 1);

  {
    Scheme_Object *insp;
    insp = scheme_make_inspector(env->insp);
    menv->insp = insp;
  }

  scheme_prepare_exp_env(menv);
  
  /* For each provide in iim, add a module rename to fm */
  saw_mb = add_simple_require_renames(NULL, rn_set, NULL, iim, iidx, scheme_make_integer(0), NULL, 1);

  if (rec[drec].comp)
    benv = scheme_new_comp_env(menv, env->insp, SCHEME_MODULE_FRAME);
  else
    benv = scheme_new_expand_env(menv, env->insp, SCHEME_MODULE_FRAME);

  /* If fm isn't a single expression, it certainly needs a
     `#%module-begin': */
  if (SCHEME_STX_PAIRP(fm) && SCHEME_STX_NULLP(SCHEME_STX_CDR(fm))) {
    /* Perhaps expandable... */
    fm = SCHEME_STX_CAR(fm);
  } else {
    fm = scheme_make_pair(scheme_datum_to_syntax(module_begin_symbol, form, scheme_false, 0, 2), 
                       fm);
    check_mb = 1;
  }

  fm = scheme_datum_to_syntax(fm, form, form, 0, 2);

  if (check_mb) {
    SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer, fm);
  }

  fm = scheme_stx_property(fm, module_name_symbol, SCHEME_PTR_VAL(m->modname));

  if (!empty_self_modidx) {
    REGISTER_SO(empty_self_modidx);
    REGISTER_SO(empty_self_modname);
    empty_self_modidx = scheme_make_modidx(scheme_false, scheme_false, scheme_false);
    empty_self_modname = scheme_make_symbol("expanded module"); /* uninterned */
    empty_self_modname = scheme_intern_resolved_module_path(empty_self_modname);
  }
  
  /* phase shift to replace self_modidx of previous expansion (if any): */
  fm = scheme_stx_phase_shift(fm, 0, empty_self_modidx, self_modidx, NULL);

  fm = scheme_add_rename(fm, rn_set);

  SCHEME_EXPAND_OBSERVE_RENAME_ONE(rec[drec].observer, fm);

  if (!check_mb) {

    fm = scheme_check_immediate_macro(fm, benv, rec, drec, 0, &mbval, NULL, NULL);

    /* If expansion is not the primitive `#%module-begin', add local one: */
    if (!SAME_OBJ(mbval, modbeg_syntax)) {
      Scheme_Object *mb;
      mb = scheme_datum_to_syntax(module_begin_symbol, form, scheme_false, 0, 0);
      fm = scheme_make_pair(mb, scheme_make_pair(fm, scheme_null));
      fm = scheme_datum_to_syntax(fm, form, form, 0, 2);
      fm = scheme_stx_property(fm, module_name_symbol, SCHEME_PTR_VAL(m->modname));
      /* Since fm is a newly-created syntax object, we need to re-add renamings: */
      fm = scheme_add_rename(fm, rn_set);
      
      SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer, fm);

      check_mb = 1;
    }
  }

  if (check_mb && !saw_mb) {
    scheme_wrong_syntax(NULL, NULL, form, 
                     "no #%%module-begin binding in the module's language");
  }

  if (rec[drec].comp) {
    Scheme_Object *dummy, *pv;

    dummy = scheme_make_environment_dummy(env);
    m->dummy = dummy;
    
    scheme_compile_rec_done_local(rec, drec);
    fm = scheme_compile_expr(fm, benv, rec, drec);

    /* result should be a module body value: */
    if (!SAME_OBJ(fm, (Scheme_Object *)m)) {
      scheme_wrong_syntax(NULL, NULL, form, "compiled body was not built with #%%module-begin");
    }

    if (restore_confusing_name)
      m->modname = kernel_modname;

    m->ii_src = NULL;

    pv = scheme_stx_property(form, scheme_intern_symbol("module-language"), NULL);
    if (pv && SCHEME_TRUEP(pv)) {
      if (SCHEME_VECTORP(pv)
          && (3 == SCHEME_VEC_SIZE(pv))
          && scheme_is_module_path(SCHEME_VEC_ELS(pv)[0])
          && SCHEME_SYMBOLP(SCHEME_VEC_ELS(pv)[1]))
        m->lang_info = pv;
    }

    fm = scheme_make_syntax_compiled(MODULE_EXPD, (Scheme_Object *)m);
  } else {
    Scheme_Object *hints, *formname;

    fm = scheme_expand_expr(fm, benv, rec, drec);

    m->ii_src = NULL;

    hints = m->hints;
    m->hints = NULL;

    formname = SCHEME_STX_CAR(form);
    fm = cons(formname,
             cons(nm,
                 cons(orig_ii, cons(fm, scheme_null))));

    fm = scheme_datum_to_syntax(fm, form, form, 0, 2);
    
    if (hints) {
      fm = scheme_stx_property(fm, 
                            scheme_intern_symbol("module-direct-requires"),
                            m->requires);
      fm = scheme_stx_property(fm, 
                            scheme_intern_symbol("module-direct-for-syntax-requires"),
                            m->et_requires);
      fm = scheme_stx_property(fm, 
                            scheme_intern_symbol("module-direct-for-template-requires"),
                            m->tt_requires);
      
      fm = scheme_stx_property(fm, 
                            scheme_intern_symbol("module-variable-provides"),
                            SCHEME_CAR(hints));
      hints = SCHEME_CDR(hints);
      fm = scheme_stx_property(fm, 
                            scheme_intern_symbol("module-syntax-provides"),
                            SCHEME_CAR(hints));
      hints = SCHEME_CDR(hints);
      fm = scheme_stx_property(fm, 
                            scheme_intern_symbol("module-indirect-provides"),
                            SCHEME_CAR(hints));
      hints = SCHEME_CDR(hints);
      fm = scheme_stx_property(fm, 
                            scheme_intern_symbol("module-kernel-reprovide-hint"),
                            SCHEME_CAR(hints));
      fm = scheme_stx_property(fm, 
                            scheme_intern_symbol("module-self-path-index"),
                            empty_self_modidx);
    }

    /* for future expansion, shift away from self_modidx: */
    fm = scheme_stx_phase_shift(fm, 0, self_modidx, empty_self_modidx, NULL);

    /* make self_modidx like the empty modidx */
    ((Scheme_Modidx *)self_modidx)->resolved = empty_self_modname;
  }

  if (rec[drec].comp || (rec[drec].depth != -2)) {
    /* rename tables no longer needed; NULL them out */
    menv->rename_set = NULL;
    menv->post_ex_rename_set = NULL;
  }

  LOG_END_EXPAND(m);

  SCHEME_EXPAND_OBSERVE_RENAME_ONE(rec[drec].observer, fm);
  return fm;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_module_begin ( Scheme_Object form,
Scheme_Comp_Env env,
Scheme_Compile_Expand_Info rec,
int  drec 
) [static]

Definition at line 5878 of file module.c.

{
  Scheme_Object *fm, *first, *last, *p, *rn_set, *rn, *exp_body, *et_rn, *self_modidx, *prev_p;
  Scheme_Comp_Env *xenv, *cenv, *rhs_env;
  Scheme_Hash_Table *et_required; /* just to avoid duplicates */
  Scheme_Hash_Table *required;    /* name -> (vector nominal-modidx-list modidx srcname var? prntname) */
                              /*   first nominal-modidx goes with modidx, rest are for re-provides */
  Scheme_Hash_Table *provided;    /* exname -> (cons locname-stx-or-sym protected?) */
  Scheme_Hash_Table *all_reprovided; /* phase -> list of (list modidx syntax except-name ...) */
  Scheme_Object *all_defs_out;    /* list of (cons protected? (stx-list except-name ...)) */
  Scheme_Object *all_et_defs_out;
  Scheme_Hash_Table *all_provided; /* phase -> table like `provided' */
  Scheme_Object *all_defs;        /* list of stxid; this is almost redundant to the syntax and toplevel
                                 tables, but it preserves the original name for exporting */
  Scheme_Object *all_et_defs;
  Scheme_Object *post_ex_rn, *post_ex_et_rn; /* renames for ids introduced by expansion */
  Scheme_Object *post_ex_rn_set; /* phase -> post_ex_rn-like rename */
  Scheme_Hash_Table *tables; /* phase -> (vector toplevels requires syntaxes) */
  Scheme_Object *lift_data;
  Scheme_Object **exis, **et_exis, **exsis;
  Scheme_Object *lift_ctx;
  Scheme_Object *lifted_reqs = scheme_null, *req_data;
  int exicount, et_exicount, exsicount;
  char *exps, *et_exps;
  int *all_simple_renames;
  int maybe_has_lifts = 0;
  Scheme_Object *redef_modname;
  Scheme_Object *observer;

  if (!(env->flags & SCHEME_MODULE_FRAME))
    scheme_wrong_syntax(NULL, NULL, form, "illegal use (not a module body)");

  if (scheme_stx_proper_list_length(form) < 0)
    scheme_wrong_syntax(NULL, NULL, form, "bad syntax (" IMPROPER_LIST_FORM ")");

  if (!env->genv->module)
    scheme_wrong_syntax(NULL, NULL, form, "not currently transforming a module");

  /* Redefining a module? */
  redef_modname = env->genv->module->modname;
  if (!scheme_hash_get(env->genv->module_registry, redef_modname))
    redef_modname = NULL;

  /* Expand each expression in form up to `begin', `define-values', `define-syntax', 
     `require', `provide', `#%app', etc. */
  xenv = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME 
                                     | SCHEME_MODULE_BEGIN_FRAME
                                     | SCHEME_FOR_STOPS), 
                                  env, NULL);
  {
    Scheme_Object *stop;
    stop = scheme_get_stop_expander();
    scheme_add_local_syntax(20, xenv);
    scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv);
    scheme_set_local_syntax(1, scheme_define_values_stx, stop, xenv);
    scheme_set_local_syntax(2, scheme_define_syntaxes_stx, stop, xenv);
    scheme_set_local_syntax(3, define_for_syntaxes_stx, stop, xenv);
    scheme_set_local_syntax(4, require_stx, stop, xenv);
    scheme_set_local_syntax(5, provide_stx, stop, xenv);
    scheme_set_local_syntax(6, set_stx, stop, xenv);
    scheme_set_local_syntax(7, app_stx, stop, xenv);
    scheme_set_local_syntax(8, scheme_top_stx, stop, xenv);
    scheme_set_local_syntax(9, lambda_stx, stop, xenv);
    scheme_set_local_syntax(10, case_lambda_stx, stop, xenv);
    scheme_set_local_syntax(11, let_values_stx, stop, xenv);
    scheme_set_local_syntax(12, letrec_values_stx, stop, xenv);
    scheme_set_local_syntax(13, if_stx, stop, xenv);
    scheme_set_local_syntax(14, begin0_stx, stop, xenv);
    scheme_set_local_syntax(15, set_stx, stop, xenv);
    scheme_set_local_syntax(16, with_continuation_mark_stx, stop, xenv);
    scheme_set_local_syntax(17, letrec_syntaxes_stx, stop, xenv);
    scheme_set_local_syntax(18, var_ref_stx, stop, xenv);
    scheme_set_local_syntax(19, expression_stx, stop, xenv);
  }

  first = scheme_null;
  last = NULL;

  rn_set = env->genv->rename_set;
  rn = scheme_get_module_rename_from_set(rn_set, scheme_make_integer(0), 1);
  et_rn = scheme_get_module_rename_from_set(rn_set, scheme_make_integer(1), 1);

  required = scheme_make_hash_table(SCHEME_hash_ptr);
  et_required = scheme_make_hash_table(SCHEME_hash_ptr);

  tables = scheme_make_hash_table_equal();
  {
    Scheme_Object *vec;

    vec = scheme_make_vector(3, NULL);
    SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->genv->toplevel;
    SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)required;
    SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)env->genv->syntax;
    scheme_hash_set(tables, scheme_make_integer(0), vec);

    vec = scheme_make_vector(3, NULL);
    SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)env->genv->exp_env->toplevel;
    SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)et_required;
    SCHEME_VEC_ELS(vec)[2] = NULL;
    scheme_hash_set(tables, scheme_make_integer(1), vec);
  }

  /* Put initial requires into the table:
     (This is redundant for the rename set, but we need to fill
     the `all_requires' table, etc.) */
  {
    Scheme_Module *iim;
    Scheme_Object *nmidx, *orig_src;

    /* stx src of original import: */
    orig_src = env->genv->module->ii_src;
    if (!orig_src)
      orig_src = scheme_false;
    else if (!SCHEME_STXP(orig_src))
      orig_src = scheme_false;
    
    nmidx = SCHEME_CAR(env->genv->module->requires);
    iim = module_load(scheme_module_resolve(nmidx, 1), env->genv, NULL);

    add_simple_require_renames(orig_src, rn_set, tables, 
                               iim, nmidx,
                               scheme_make_integer(0),
                               NULL, 1);
  }

  {
    Scheme_Object *v;
    v = scheme_rename_to_stx(rn_set);
    env->genv->module->rn_stx = v;
  }

  provided = scheme_make_hash_table(SCHEME_hash_ptr);
  all_provided = scheme_make_hash_table_equal();
  scheme_hash_set(all_provided, scheme_make_integer(0), (Scheme_Object *)provided);

  all_reprovided = scheme_make_hash_table_equal();

  all_defs_out = scheme_null;
  all_et_defs_out = scheme_null;

  all_defs = scheme_null;
  all_et_defs = scheme_null;

  exp_body = scheme_null;

  self_modidx = env->genv->module->self_modidx;

  post_ex_rn_set = scheme_make_module_rename_set(mzMOD_RENAME_MARKED, rn_set);
  post_ex_rn = scheme_get_module_rename_from_set(post_ex_rn_set, scheme_make_integer(0), 1);
  post_ex_et_rn = scheme_get_module_rename_from_set(post_ex_rn_set, scheme_make_integer(1), 1);
  env->genv->post_ex_rename_set = post_ex_rn_set;

  /* For syntax-local-context, etc., in a d-s RHS: */
  rhs_env = scheme_new_comp_env(env->genv, env->insp, SCHEME_TOPLEVEL_FRAME);

  scheme_rec_add_certs(rec, drec, form);

  observer = rec[drec].observer;

  /* It's possible that #%module-begin expansion introduces
     marked identifiers for definitions. */
  form = scheme_add_rename(form, post_ex_rn_set);
  SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, form);

  maybe_has_lifts = 0;
  lift_ctx = scheme_generate_lifts_key();

  all_simple_renames = (int *)scheme_malloc_atomic(sizeof(int));
  *all_simple_renames = 1;

  req_data = package_require_data(self_modidx, env->genv, env->genv->module,
                                  rn_set, post_ex_rn_set,
                                  tables,
                                  redef_modname, 
                                  all_simple_renames);

  /* Pass 1 */

  /* Partially expand all expressions, and process definitions, requires,
     and provides. Also, flatten top-level `begin' expressions: */
  for (fm = SCHEME_STX_CDR(form); !SCHEME_STX_NULLP(fm); ) {
    Scheme_Object *e;
    int kind;

    while (1) {
      Scheme_Object *fst;

      SCHEME_EXPAND_OBSERVE_NEXT(observer);

      e = SCHEME_STX_CAR(fm);

      p = (maybe_has_lifts 
           ? scheme_frame_get_end_statement_lifts(xenv) 
           : scheme_null);
      prev_p = (maybe_has_lifts 
                ? scheme_frame_get_provide_lifts(xenv) 
                : scheme_null);
      scheme_frame_captures_lifts(xenv, scheme_make_lifted_defn, scheme_sys_wraps(xenv), 
                                  p, lift_ctx, req_data, prev_p);
      maybe_has_lifts = 1;

      {
       Scheme_Expand_Info erec1;
       erec1.comp = 0;
       erec1.depth = -1;
       erec1.value_name = scheme_false;
       erec1.certs = rec[drec].certs;
        erec1.observer = rec[drec].observer;
        erec1.pre_unwrapped = 0;
        erec1.no_module_cert = 0;
        erec1.env_already = 0;
        erec1.comp_flags = rec[drec].comp_flags;
       e = scheme_expand_expr(e, xenv, &erec1, 0);      
      }

      lifted_reqs = scheme_append(scheme_frame_get_require_lifts(xenv), lifted_reqs);

      fst = scheme_frame_get_lifts(xenv);
      if (!SCHEME_NULLP(fst)) {
       /* Expansion lifted expressions, so add them to
          the front and try again. */
        *all_simple_renames = 0;
       fm = SCHEME_STX_CDR(fm);
        e = scheme_add_rename(e, post_ex_rn_set);
        fm = scheme_named_map_1(NULL, add_a_rename, fm, post_ex_rn_set);
        fm = scheme_make_pair(e, fm);
        SCHEME_EXPAND_OBSERVE_RENAME_LIST(observer, fm);
       fm = scheme_append(fst, fm);
        SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, fst);
      } else {
       /* No definition lifts added... */
       if (SCHEME_STX_PAIRP(e))
         fst = SCHEME_STX_CAR(e);
       else
         fst = NULL;
       
       if (fst && SCHEME_STX_SYMBOLP(fst) && scheme_stx_module_eq(scheme_begin_stx, fst, 0)) {
         fm = SCHEME_STX_CDR(fm);
         e = scheme_add_rename(e, post_ex_rn_set);
          SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e);
         fm = scheme_flatten_begin(e, fm);
         SCHEME_EXPAND_OBSERVE_SPLICE(observer, fm);
         if (SCHEME_STX_NULLP(fm)) {
            e = scheme_frame_get_provide_lifts(xenv);
            e = scheme_reverse(e);
            fm = scheme_frame_get_end_statement_lifts(xenv);
            fm = scheme_reverse(fm);
            if (!SCHEME_NULLP(e))
              fm = scheme_append(fm, e);
            SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, fm);
            maybe_has_lifts = 0;
            if (SCHEME_NULLP(fm)) {
              e = NULL;
              break;
            }
         }
       } else
          break;
      }
    }
    if (!e) break; /* (begin) expansion at end */

    e = scheme_add_rename(e, post_ex_rn_set);

    SCHEME_EXPAND_OBSERVE_RENAME_ONE(observer, e);
    
    if (SCHEME_STX_PAIRP(e)) {
      Scheme_Object *fst;

      fst = SCHEME_STX_CAR(e);

      if (SCHEME_STX_SYMBOLP(fst)) {

       Scheme_Object *n;
       n = SCHEME_STX_CAR(e);
       if (scheme_stx_module_eq(scheme_define_values_stx, fst, 0)) {
         /************ define-values *************/
         Scheme_Object *vars, *val;

          SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
          SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(observer);

         /* Create top-level vars */
         scheme_define_parse(e, &vars, &val, 0, env, 1);

         while (SCHEME_STX_PAIRP(vars)) {
           Scheme_Object *name, *orig_name;

           name = SCHEME_STX_CAR(vars);

           orig_name = name;

           /* Remember the original: */
           all_defs = scheme_make_pair(name, all_defs);
           
           name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL, NULL);

           /* Check that it's not yet defined: */
           if (scheme_lookup_in_table(env->genv->toplevel, (const char *)name)) {
             scheme_wrong_syntax("module", orig_name, e, "duplicate definition for identifier");
             return NULL;
           }

           /* Not required: */
           if (check_already_required(required, name)) {
             scheme_wrong_syntax("module", orig_name, e, "identifier is already imported");
             return NULL;
           }

           /* Not syntax: */
           if (scheme_lookup_in_table(env->genv->syntax, (const char *)name)) {
             scheme_wrong_syntax("module", orig_name, e, "duplicate definition for identifier");
             return NULL;
           }

           /* Create the bucket, indicating that the name will be defined: */
           scheme_add_global_symbol(name, scheme_undefined, env->genv);

           /* Add a renaming: */
           if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) {
             scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, NULL, 0);
              *all_simple_renames = 0;
           } else
             scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, NULL, 0);

           vars = SCHEME_STX_CDR(vars);
         }
          
          SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
         kind = 2;
       } else if (scheme_stx_module_eq(scheme_define_syntaxes_stx, fst, 0)
                 || scheme_stx_module_eq(define_for_syntaxes_stx, fst, 0)) {
         /************ define-syntaxes & define-values-for-syntax *************/
         /* Define the macro: */
         Scheme_Compile_Info mrec;
         Scheme_Object *names, *l, *code, *m, *vec, *boundname;
         Resolve_Prefix *rp;
         Resolve_Info *ri;
         Scheme_Comp_Env *oenv, *eenv;
         Optimize_Info *oi;
         int count = 0;
         int for_stx;
          int use_post_ex = 0;

         for_stx = scheme_stx_module_eq(define_for_syntaxes_stx, fst, 0);

          SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
          SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(observer);

         scheme_define_parse(e, &names, &code, 1, env, 1);

         if (SCHEME_STX_PAIRP(names) && SCHEME_STX_NULLP(SCHEME_STX_CDR(names)))
           boundname = SCHEME_STX_CAR(names);
         else
           boundname = scheme_false;
         
         scheme_prepare_exp_env(env->genv);
         scheme_prepare_compile_env(env->genv->exp_env);
         eenv = scheme_new_comp_env(env->genv->exp_env, env->insp, 0);
          scheme_frame_captures_lifts(eenv, NULL, NULL, scheme_false, scheme_false, 
                                      req_data, scheme_false);

         oenv = (for_stx ? eenv : env);
         
         for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
           Scheme_Object *name, *orig_name;
           name = SCHEME_STX_CAR(l);

           orig_name = name;

            /* Remember the original: */
           if (!for_stx)
             all_defs = scheme_make_pair(name, all_defs);
            else
              all_et_defs = scheme_make_pair(name, all_et_defs);
           
           name = scheme_tl_id_sym(oenv->genv, name, NULL, 2, NULL, NULL);
           
           if (scheme_lookup_in_table(oenv->genv->syntax, (const char *)name)) {
             scheme_wrong_syntax("module", orig_name, e, 
                              (for_stx
                               ? "duplicate for-syntax definition for identifier"
                               : "duplicate definition for identifier"));
             return NULL;
           }
           
           /* Check that it's not yet defined: */
           if (scheme_lookup_in_table(oenv->genv->toplevel, (const char *)name)) {
             scheme_wrong_syntax("module", orig_name, e, 
                              (for_stx
                               ? "duplicate for-syntax definition for identifier"
                               : "duplicate definition for identifier"));
             return NULL;
           }

           /* Not required: */
           if (check_already_required(for_stx ? et_required : required, name)) {
             scheme_wrong_syntax("module", orig_name, e, 
                              (for_stx
                               ? "identifier is already imported for syntax"
                               : "identifier is already imported"));
             return NULL;
           }

           if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) {
             scheme_extend_module_rename(for_stx ? post_ex_et_rn : post_ex_rn, self_modidx, name, name, self_modidx, name,
                                     for_stx ? 1 : 0, NULL, NULL, NULL, 0);
              *all_simple_renames = 0;
              use_post_ex = 1;
           } else
             scheme_extend_module_rename(for_stx ? et_rn : rn, self_modidx, name, name, self_modidx, name,
                                     for_stx ? 1 : 0, NULL, NULL, NULL, 0);

           count++;
         }

         names = scheme_named_map_1(NULL, stx_sym, names, (Scheme_Object *)oenv->genv);
         
         mrec.comp = 1;
         mrec.dont_mark_local_use = 0;
         mrec.resolve_module_ids = 0;
          mrec.no_module_cert = 0;
         mrec.value_name = NULL;
         mrec.certs = rec[drec].certs;
          mrec.observer = NULL;
          mrec.pre_unwrapped = 0;
          mrec.env_already = 0;
          mrec.comp_flags = rec[drec].comp_flags;
          scheme_rec_add_certs(&mrec, 0, e);

         if (!rec[drec].comp) {
           Scheme_Expand_Info erec1;
           erec1.comp = 0;
           erec1.depth = -1;
           erec1.value_name = boundname;
           erec1.certs = mrec.certs;
            erec1.observer = rec[drec].observer;
            erec1.pre_unwrapped = 0;
            erec1.no_module_cert = 0;
            erec1.env_already = 0;
            erec1.comp_flags = rec[drec].comp_flags;
           SCHEME_EXPAND_OBSERVE_PHASE_UP(observer);
           code = scheme_expand_expr_lift_to_let(code, eenv, &erec1, 0);
         }
         m = scheme_compile_expr_lift_to_let(code, eenv, &mrec, 0);

          lifted_reqs = scheme_append(scheme_frame_get_require_lifts(eenv), lifted_reqs);

         oi = scheme_optimize_info_create();
          oi->context = (Scheme_Object *)env->genv->module;
          if (!(rec[drec].comp_flags & COMP_CAN_INLINE))
            oi->inline_fuel = -1;
         m = scheme_optimize_expr(m, oi);
         
         /* Simplify only in compile mode; it is too slow in expand mode. */
         rp = scheme_resolve_prefix(1, eenv->prefix, rec[drec].comp);
         ri = scheme_resolve_info_create(rp);
          scheme_enable_expression_resolve_lifts(ri);
         m = scheme_resolve_expr(m, ri);
          m = scheme_merge_expression_resolve_lifts(m, rp, ri);
          rp = scheme_remap_prefix(rp, ri);

         /* Add code with names and lexical depth to exp-time body: */
         vec = scheme_make_vector(5, NULL);
         SCHEME_VEC_ELS(vec)[0] = ((SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names)))
                                    ? SCHEME_CAR(names)
                                    : names);
         SCHEME_VEC_ELS(vec)[1] = m;
         SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(ri->max_let_depth);
         SCHEME_VEC_ELS(vec)[3] = (Scheme_Object *)rp;
         SCHEME_VEC_ELS(vec)[4] = (for_stx ? scheme_true : scheme_false);
         exp_body = scheme_make_pair(vec, exp_body);

          m = scheme_sfs(m, NULL, ri->max_let_depth);
         if (ri->use_jit)
           m = scheme_jit_expr(m);
          rp = scheme_prefix_eval_clone(rp);
       
         eval_exptime(names, count, m, eenv->genv, rhs_env, rp, ri->max_let_depth, 0, 
                       (for_stx ? env->genv->exp_env->toplevel : env->genv->syntax), for_stx,
                       rec[drec].certs, 
                       for_stx ? scheme_false : (use_post_ex ? post_ex_rn : rn));
          
         if (rec[drec].comp)
           e = NULL;
         else {
           m = SCHEME_STX_CDR(e);
           m = SCHEME_STX_CAR(m);
           m = scheme_make_pair(SCHEME_CAR(fst),
                             scheme_make_pair(m, scheme_make_pair(code, scheme_null)));
           e = scheme_datum_to_syntax(m, e, e, 0, 2);
         }
          
          SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
         kind = 0;
       } else if (scheme_stx_module_eq(require_stx, fst, 0)) { 
         /************ require *************/
          SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
          SCHEME_EXPAND_OBSERVE_PRIM_REQUIRE(observer);

         /* Adds requires to renamings and required modules to requires lists: */
         parse_requires(e, self_modidx, env->genv, env->genv->module,
                         rn_set, post_ex_rn_set,
                         check_require_name, tables,
                         redef_modname, 
                         0, 0, 1, 
                         1, 0,
                         all_simple_renames);

         if (rec[drec].comp)
           e = NULL;

          SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
         kind = 0;
       } else if (scheme_stx_module_eq(provide_stx, fst, 0)) {
         /************ provide *************/
          /* remember it for the second pass */
          kind = 3;
       } else {
         kind = 1;
        }
      } else
       kind = 1;
    } else
      kind = 1;

    if (e) {
      p = scheme_make_pair(scheme_make_pair(e, scheme_make_integer(kind)), scheme_null);
      if (last)
       SCHEME_CDR(last) = p;
      else
       first = p;
      last = p;
    }

    fm = SCHEME_STX_CDR(fm);

    /* If we're out of declarations, check for lifted-to-end: */
    if (SCHEME_STX_NULLP(fm) && maybe_has_lifts) {
      e = scheme_frame_get_provide_lifts(xenv);
      e = scheme_reverse(e);
      fm = scheme_frame_get_end_statement_lifts(xenv);
      fm = scheme_reverse(fm);
      if (!SCHEME_NULLP(e))
        fm = scheme_append(fm, e);
      SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, fm);
      maybe_has_lifts = 0;
    }
  }
  /* first =  a list of (cons semi-expanded-expression kind) */

  /* Bound names will not be re-bound at this point: */
  if (rec[drec].comp || (rec[drec].depth != -2)) {
    scheme_seal_module_rename_set(rn_set, STX_SEAL_BOUND);
  }
  scheme_seal_module_rename_set(post_ex_rn_set, STX_SEAL_BOUND);

  /* Pass 2 */
  SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer);
  
  if (rec[drec].comp) {
    /* Module manages its own prefix. That's how we get
       multiple instantiation of a module with "dynamic linking". */
    cenv = scheme_new_comp_env(env->genv, env->insp, SCHEME_TOPLEVEL_FRAME);
  } else
    cenv = scheme_extend_as_toplevel(env);

  lift_data = scheme_make_vector(3, NULL);
  SCHEME_VEC_ELS(lift_data)[0] = (Scheme_Object *)cenv;
  SCHEME_VEC_ELS(lift_data)[1] = self_modidx;
  SCHEME_VEC_ELS(lift_data)[2] = rn;

  maybe_has_lifts = 0;

  prev_p = NULL;
  for (p = first; !SCHEME_NULLP(p); ) {
    Scheme_Object *e, *l, *ll;
    int kind;

    e = SCHEME_CAR(p);
    kind = SCHEME_INT_VAL(SCHEME_CDR(e));
    e = SCHEME_CAR(e);
    
    SCHEME_EXPAND_OBSERVE_NEXT(observer);

    if (kind == 3) {
      Scheme_Object *fst;

      fst = SCHEME_STX_CAR(e);

      if (scheme_stx_module_eq(provide_stx, fst, 0)) {
        /************ provide *************/
        /* Add provides to table: */
        Scheme_Object *ex;

        SCHEME_EXPAND_OBSERVE_ENTER_PRIM(observer, e);
        SCHEME_EXPAND_OBSERVE_PRIM_PROVIDE(observer);
      
        ex = e;
  
        parse_provides(form, fst, e, 
                       all_provided, all_reprovided,
                       self_modidx,
                       &all_defs_out, &all_et_defs_out,
                       tables,
                       all_defs, all_et_defs, cenv, rec, drec,
                       &ex);
        
        e = ex;

        SCHEME_EXPAND_OBSERVE_EXIT_PRIM(observer, e);
      }
      if (!rec[drec].comp) {
        SCHEME_CAR(p) = e;
        prev_p = p;
        p = SCHEME_CDR(p);
      } else {
        p = SCHEME_CDR(p);
        if (!prev_p)
          first = p;
        else
          SCHEME_CDR(prev_p) = p;
      }
    } else if (kind) {
      Scheme_Comp_Env *nenv;

      l = (maybe_has_lifts 
           ? scheme_frame_get_end_statement_lifts(cenv) 
           : scheme_null);
      ll = (maybe_has_lifts 
            ? scheme_frame_get_provide_lifts(cenv) 
            : scheme_null);
      scheme_frame_captures_lifts(cenv, add_lifted_defn, lift_data, l, lift_ctx, req_data, ll);
      maybe_has_lifts = 1;

      if (kind == 2)
        nenv = cenv;
      else
        nenv = scheme_new_compilation_frame(0, 0, cenv, NULL);

      if (rec[drec].comp) {
       Scheme_Compile_Info crec1;
       scheme_init_compile_recs(rec, drec, &crec1, 1);
       crec1.resolve_module_ids = 0;
       e = scheme_compile_expr(e, nenv, &crec1, 0);
      } else {
       Scheme_Expand_Info erec1;
       scheme_init_expand_recs(rec, drec, &erec1, 1);
       erec1.value_name = scheme_false;
       e = scheme_expand_expr(e, nenv, &erec1, 0);
      }

      lifted_reqs = scheme_append(scheme_frame_get_require_lifts(cenv), lifted_reqs);
      
      l = scheme_frame_get_lifts(cenv);
      if (SCHEME_NULLP(l)) {
       /* No lifts - continue normally */
       SCHEME_CAR(p) = e;
       prev_p = p;
       p = SCHEME_CDR(p);
      } else {
       /* Lifts - insert them and try again */
        *all_simple_renames = 0;
        SCHEME_EXPAND_OBSERVE_MODULE_LIFT_LOOP(observer, scheme_copy_list(l));
       e = scheme_make_pair(e, scheme_make_integer(0)); /* don't re-compile/-expand */
       SCHEME_CAR(p) = e;
       for (ll = l; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) {
         e = scheme_make_pair(SCHEME_CAR(ll), scheme_make_integer(2));
         SCHEME_CAR(ll) = e;
       }
       p = scheme_append(l, p);
       if (prev_p) {
         SCHEME_CDR(prev_p) = p;
       } else {
         first = p;
       }
      }
    } else {
      SCHEME_CAR(p) = e;
      prev_p = p;
      p = SCHEME_CDR(p);
    }

    /* If we're out of declarations, check for lifted-to-end: */
    if (SCHEME_NULLP(p) && maybe_has_lifts) {
      int expr_cnt;
      e = scheme_frame_get_provide_lifts(cenv);
      e = scheme_reverse(e);
      p = scheme_frame_get_end_statement_lifts(cenv);
      p = scheme_reverse(p);
      expr_cnt = scheme_list_length(p);
      if (!SCHEME_NULLP(e))
        p = scheme_append(p, e);
      SCHEME_EXPAND_OBSERVE_MODULE_LIFT_END_LOOP(observer, p);
      for (ll = p; SCHEME_PAIRP(ll); ll = SCHEME_CDR(ll)) {
        e = scheme_make_pair(SCHEME_CAR(ll), (expr_cnt > 0) ? scheme_make_integer(1) : scheme_make_integer(3));
        SCHEME_CAR(ll) = e;
        expr_cnt--;
      }
      maybe_has_lifts = 0;
      if (prev_p) {
        SCHEME_CDR(prev_p) = p;
      } else {
        first = p;
      }
    }
  }
  /* first = a list of expanded/compiled expressions */

  /* If compiling, drop expressions that are constants: */
  if (rec[drec].comp) {
    Scheme_Object *prev = NULL, *next;
    for (p = first; !SCHEME_NULLP(p); p = next) {
      next = SCHEME_CDR(p);
      if (scheme_omittable_expr(SCHEME_CAR(p), -1, -1, 0, NULL)) {
       if (prev)
         SCHEME_CDR(prev) = next;
       else
         first = next;
      } else
       prev = p;
    }
  }

  if (rec[drec].comp || (rec[drec].depth != -2)) {
    scheme_seal_module_rename_set(rn_set, STX_SEAL_ALL);
  }
  scheme_seal_module_rename_set(post_ex_rn_set, STX_SEAL_ALL);

  /* Compute provides for re-provides and all-defs-out: */
  (void)compute_reprovides(all_provided,
                           all_reprovided, 
                           env->genv->module, 
                           tables,
                           env->genv, 
                           all_defs, all_defs_out, 
                           all_et_defs, all_et_defs_out, 
                           "require", NULL, NULL);

  /* Compute provide arrays */
  exps = compute_provide_arrays(all_provided, tables,
                                env->genv->module->me,
                                env->genv,
                                form, &et_exps);
  
  /* Compute indirect provides (which is everything at the top-level): */
  exis = compute_indirects(env->genv, env->genv->module->me->rt, &exicount, 1);
  exsis = compute_indirects(env->genv, env->genv->module->me->rt, &exsicount, 0);
  et_exis = compute_indirects(env->genv->exp_env, env->genv->module->me->et, &et_exicount, 1);

  if (rec[drec].comp || (rec[drec].depth != -2)) {
    scheme_clean_dead_env(env->genv);
  }

  if (!rec[drec].comp) {
    Scheme_Module_Phase_Exports *rt = env->genv->module->me->rt;
    int excount = rt->num_provides;
    int exvcount = rt->num_var_provides;
    Scheme_Object **exsns = rt->provide_src_names;
    Scheme_Object **exs = rt->provides;
    Scheme_Object **exss = rt->provide_srcs;

    /* Produce annotations (in the form of properties)
       for module information:
         'module-variable-provides = '(item ...)
         'module-syntax-provides = '(item ...)
        'module-indirect-provides = '(id ...)
         'module-kernel-reprovide-hint = 'kernel-reexport

      item = name
           | (ext-id . def-id)
           | (modidx ext-id . def-id)
     kernel-reexport = #f
                     | #t
                     | exclusion-id
    */
    int j;
    Scheme_Object *e, *a, *result;

    result = scheme_null;

    /* kernel re-export info (always #f): */
    result = scheme_make_pair(scheme_false, result);

    /* Indirect provides */ 
    a = scheme_null;
    for (j = 0; j < exicount; j++) {
      a = scheme_make_pair(exis[j], a);
    }
    result = scheme_make_pair(a, result);
    
    /* add syntax and value exports: */
    for (j = 0; j < 2; j++) {
      int top, i;

      e = scheme_null;

      if (!j) {
       i = exvcount;
       top = excount;
      } else {
       i = 0;
       top = exvcount;
      }
      
      for (; i < top; i++) {
       if (SCHEME_FALSEP(exss[i])
           && SAME_OBJ(exs[i], exsns[i]))
         a = exs[i];
       else {
         a = scheme_make_pair(exs[i], exsns[i]);
         if (!SCHEME_FALSEP(exss[i])) {
           a = scheme_make_pair(exss[i], a);
         }
       }
       e = scheme_make_pair(a, e);
      }
      result = scheme_make_pair(e, result);
    }

    env->genv->module->hints = result;
  }

  if (rec[drec].comp) {
    Scheme_Object *exp_body_r = scheme_null;
    
    /* Reverse exp_body */
    while (!SCHEME_NULLP(exp_body)) {
      exp_body_r = scheme_make_pair(SCHEME_CAR(exp_body),
                                exp_body_r);
      exp_body = SCHEME_CDR(exp_body);
    }

    first = scheme_list_to_vector(first);
    env->genv->module->body = first;
    exp_body_r = scheme_list_to_vector(exp_body_r);
    env->genv->module->et_body = exp_body_r;

    env->genv->module->provide_protects = exps;
    env->genv->module->et_provide_protects = et_exps;

    env->genv->module->indirect_provides = exis;
    env->genv->module->num_indirect_provides = exicount;

    if (*all_simple_renames) {
      env->genv->module->indirect_syntax_provides = exsis;
      env->genv->module->num_indirect_syntax_provides = exsicount;
    } else {
      env->genv->module->indirect_syntax_provides = NULL;
      env->genv->module->num_indirect_syntax_provides = 0;
    }

    env->genv->module->et_indirect_provides = et_exis;
    env->genv->module->num_indirect_et_provides = et_exicount;

    env->genv->module->comp_prefix = cenv->prefix;

    if (*all_simple_renames) {
      env->genv->module->rn_stx = scheme_true;
    }

    return (Scheme_Object *)env->genv->module;
  } else {
    if (rec[drec].depth == -2) {
      /* This was a local expand. Flush definitions, because the body expand may start over. */
      flush_definitions(env->genv);
      if (env->genv->exp_env)
        flush_definitions(env->genv->exp_env);
    }

    p = SCHEME_STX_CAR(form);

    /* Add lifted requires */
    if (!SCHEME_NULLP(lifted_reqs)) {
      lifted_reqs = scheme_reverse(lifted_reqs);
      first = scheme_append(lifted_reqs, first);
    }

    return scheme_datum_to_syntax(cons(p, first), form, form, 0, 2);
  }
}

Here is the caller graph for this function:

static Scheme_Object* do_module_clone ( Scheme_Object data,
int  jit 
) [static]

Definition at line 4851 of file module.c.

{
  Scheme_Module *m = (Scheme_Module *)data;
  Scheme_Object *l1, *l2;
  Resolve_Prefix *rp;
  
  rp = scheme_prefix_eval_clone(m->prefix);

  if (jit)
    l1 = jit_vector(m->body, 0, jit);
  else
    l1 = m->body;
  l2 = jit_vector(m->et_body, 1, jit);

  if (SAME_OBJ(l1, m->body) 
      && SAME_OBJ(l2, m->body)
      && SAME_OBJ(rp, m->prefix))
    return data;
  
  m = MALLOC_ONE_TAGGED(Scheme_Module);
  memcpy(m, data, sizeof(Scheme_Module));
  m->body = l1;
  m->et_body = l2;
  m->prefix = rp;

  return (Scheme_Object *)m;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * do_namespace_require ( Scheme_Env env,
int  argc,
Scheme_Object argv[],
int  copy,
int  etonly 
) [static]

Definition at line 1045 of file module.c.

{
  Scheme_Object *form, *rns;

  if (!env)
    env = scheme_get_env(NULL);
  scheme_prepare_exp_env(env);

  form = scheme_datum_to_syntax(scheme_make_pair(require_stx,
                                           scheme_make_pair(argv[0], scheme_null)),
                            scheme_false, scheme_false, 1, 0);

  rns = scheme_make_module_rename_set(mzMOD_RENAME_TOPLEVEL, NULL);

  parse_requires(form, scheme_false, env, NULL,
                 rns, NULL,
                 NULL /* ck */, NULL /* data */,
                 NULL, 
                 1, copy, 0, 
                 etonly ? 1 : -1, !etonly,
                 NULL);

  scheme_append_rename_set_to_env(rns, env);

  return scheme_void;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void do_prepare_compile_env ( Scheme_Env env,
int  base_phase,
int  pos 
) [static]

Definition at line 4095 of file module.c.

{
  Scheme_Object *v;
  Scheme_Env *menv;

  v = MODCHAIN_AVAIL(env->modchain, pos);
  if (!SCHEME_FALSEP(v)) {
    MODCHAIN_AVAIL(env->modchain, pos) = scheme_false;
    while (SCHEME_NAMESPACEP(v)) {
      menv = (Scheme_Env *)v;
      v = menv->available_next[pos];
      menv->available_next[pos] = NULL;
      start_module(menv->module, env, 0,
                   NULL, 1, 0, base_phase,
                   scheme_null);
    }
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_require ( Scheme_Object form,
Scheme_Comp_Env env,
Scheme_Compile_Expand_Info rec,
int  drec 
) [static]

Definition at line 9220 of file module.c.

{
  Scheme_Hash_Table *ht;
  Scheme_Object *rn_set, *dummy, *modidx;
  Scheme_Env *genv;

  if (!scheme_is_toplevel(env))
    scheme_wrong_syntax(NULL, NULL, form, "not at top-level or in module body");

  /* If we get here, it must be a top-level require. */

  /* Hash table is for checking duplicate names in require list: */
  ht = scheme_make_hash_table_equal();

  rn_set = scheme_make_module_rename_set(mzMOD_RENAME_TOPLEVEL, NULL);

  genv = env->genv;
  scheme_prepare_exp_env(genv);
  scheme_prepare_template_env(genv);

  if (genv->module)
    modidx = genv->module->self_modidx;
  else
    modidx = scheme_false;

  parse_requires(form, modidx, genv, NULL,
                 rn_set, rn_set,
                 check_dup_require, ht,
                 NULL, 
                 0, 0, 0, 
                 1, 0,
                 NULL);

  if (rec && rec[drec].comp) {
    /* Dummy lets us access a top-level environment: */
    dummy = scheme_make_environment_dummy(env);
    
    scheme_compile_rec_done_local(rec, drec);
    scheme_default_compile_rec(rec, drec);
    return scheme_make_syntax_compiled(REQUIRE_EXPD, 
                                   cons(dummy,
                                       form));
  } else
    return form;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_require_execute ( Scheme_Env env,
Scheme_Object form 
) [static]

Definition at line 9130 of file module.c.

{
  Scheme_Hash_Table *ht;
  Scheme_Object *rn_set, *modidx;
  Scheme_Object *rest;

  if (env->module)
    modidx = env->module->self_modidx;
  else
    modidx = scheme_false;

  /* Don't check for dups if we import from less that two sources: */
  rest = SCHEME_STX_CDR(form);
  if (SCHEME_STX_NULLP(rest)) {
    rest = NULL;
  } else if (SCHEME_STX_PAIRP(rest)) {
    rest = SCHEME_STX_CDR(rest);
    if (SCHEME_STX_NULLP(rest)) {
      rest = NULL;
    }
  }

  scheme_prepare_exp_env(env);
  scheme_prepare_template_env(env);

  rn_set = scheme_make_module_rename_set(mzMOD_RENAME_TOPLEVEL, NULL);

  if (rest) {
    ht = scheme_make_hash_table_equal();
  } else {
    ht = NULL;
  }

  parse_requires(form, modidx, env, NULL,
                 rn_set, rn_set,
                 check_dup_require, ht,
                 NULL,
                 !env->module, 0, 0, 
                 -1, 1,
                 NULL);

  scheme_append_rename_set_to_env(rn_set, env);

  return scheme_void;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void do_start_module ( Scheme_Module m,
Scheme_Env menv,
Scheme_Env env,
int  restart 
) [static]

Definition at line 3972 of file module.c.

{
  if (m->primitive) {
    menv->running = 1;
    menv->ran = 1;
    return;
  }

  if (menv->running > 0) {
    return;
  }
  
  menv->running = 1;

  if (menv->module->prim_body) {
    Scheme_Invoke_Proc ivk = menv->module->prim_body;
    menv->ran = 1;
    ivk(menv, menv->phase, menv->link_midx, m->body);
  } else {
    eval_module_body(menv, env);
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 1040 of file module.c.

{
  return _dynamic_require(argc, argv, scheme_get_env(NULL), 0, 1, 0, 0, 1, -1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void eval_exptime ( Scheme_Object names,
int  count,
Scheme_Object expr,
Scheme_Env genv,
Scheme_Comp_Env env,
Resolve_Prefix rp,
int  let_depth,
int  shift,
Scheme_Bucket_Table syntax,
int  for_stx,
Scheme_Object certs,
Scheme_Object free_id_rename_rn 
) [static]

Definition at line 4511 of file module.c.

{
  Scheme_Object *macro, *vals, *name, **save_runstack;
  int i, g, depth;

  depth = let_depth + scheme_prefix_depth(rp);
  if (!scheme_check_runstack(depth)) {
    Scheme_Thread *p = scheme_current_thread;
    p->ku.k.p1 = names;
    p->ku.k.p2 = expr;
    vals = scheme_make_pair((Scheme_Object *)genv, (Scheme_Object *)comp_env);
    p->ku.k.p3 = vals;
    vals = scheme_make_pair((Scheme_Object *)rp, (Scheme_Object *)syntax);
    vals = scheme_make_pair(free_id_rename_rn, vals);
    p->ku.k.p4 = vals;
    p->ku.k.i1 = count;
    p->ku.k.i2 = let_depth;
    p->ku.k.i3 = shift;
    p->ku.k.i4 = for_stx;
    p->ku.k.p5 = certs;
    (void)scheme_enlarge_runstack(depth, eval_exptime_k);
    return;
  }

  if (SCHEME_TYPE(expr) > _scheme_values_types_) {
    vals = expr;
  } else {
    save_runstack = scheme_push_prefix(genv, rp,
                                       (shift ? genv->module->me->src_modidx : NULL), 
                                       (shift ? genv->link_midx : NULL), 
                                       1, genv->phase);

    if (is_simple_expr(expr)) {
      vals = _scheme_eval_linked_expr_multi_wp(expr, scheme_current_thread);
    } else {
      Scheme_Cont_Frame_Data cframe;
      Scheme_Config *config;
      Scheme_Dynamic_State dyn_state;

      config = scheme_extend_config(scheme_current_config(),
                                    MZCONFIG_ENV,
                                    (Scheme_Object *)genv);
      scheme_push_continuation_frame(&cframe);
      scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
    
      scheme_set_dynamic_state(&dyn_state, comp_env, NULL, scheme_false, certs, 
                         genv, (genv->link_midx ? genv->link_midx : genv->module->me->src_modidx));
      vals = scheme_eval_linked_expr_multi_with_dynamic_state(expr, &dyn_state);

      scheme_pop_continuation_frame(&cframe);
    }

    scheme_pop_prefix(save_runstack);
  }
  
  if (SAME_OBJ(vals, SCHEME_MULTIPLE_VALUES)) {
    g = scheme_current_thread->ku.multiple.count;
    if (count == g) {
      Scheme_Object **values;

      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++, names = SCHEME_CDR(names)) {
       name = SCHEME_CAR(names);

       if (!for_stx) {
         macro = scheme_alloc_small_object();
         macro->type = scheme_macro_type;
         SCHEME_PTR_VAL(macro) = values[i];

          if (SCHEME_TRUEP(free_id_rename_rn)
              && scheme_is_binding_rename_transformer(values[i]))
            scheme_install_free_id_rename(name, scheme_rename_transformer_id(values[i]), free_id_rename_rn, 
                                          scheme_make_integer(0));
       } else
         macro = values[i];
       
       scheme_add_to_table(syntax, (const char *)name, macro, 0);
      }
       
      return;
    }
  } else if (SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names))) {
    name = SCHEME_CAR(names);

    if (!for_stx) {
      macro = scheme_alloc_small_object();
      macro->type = scheme_macro_type;
      SCHEME_PTR_VAL(macro) = vals;

      if (SCHEME_TRUEP(free_id_rename_rn)
          && scheme_is_binding_rename_transformer(vals))
        scheme_install_free_id_rename(name, scheme_rename_transformer_id(vals), free_id_rename_rn, 
                                      scheme_make_integer(0));
    } else
      macro = vals;

    scheme_add_to_table(syntax, (const char *)name, macro, 0);
      
    return;
  } else
    g = 1;
  
  if (count)
    name = SCHEME_CAR(names);
  else
    name = NULL;
  
  {
    const char *symname;

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

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

Here is the call graph for this function:

Here is the caller graph for this function:

static void* eval_exptime_k ( void  ) [static]

Definition at line 4462 of file module.c.

{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Object *names;
  int count, for_stx;
  Scheme_Object *expr, *certs;
  Scheme_Env *genv;
  Scheme_Comp_Env *comp_env;
  Resolve_Prefix *rp;
  int let_depth, shift;
  Scheme_Bucket_Table *syntax;
  Scheme_Object *free_id_rename_rn;

  names = (Scheme_Object *)p->ku.k.p1;
  expr = (Scheme_Object *)p->ku.k.p2;
  genv = (Scheme_Env *)SCHEME_CAR((Scheme_Object *)p->ku.k.p3);
  comp_env = (Scheme_Comp_Env *)SCHEME_CDR((Scheme_Object *)p->ku.k.p3);
  free_id_rename_rn = SCHEME_CAR((Scheme_Object *)p->ku.k.p4);
  rp = (Resolve_Prefix *)SCHEME_CAR(SCHEME_CDR((Scheme_Object *)p->ku.k.p4));
  syntax = (Scheme_Bucket_Table *)SCHEME_CDR(SCHEME_CDR((Scheme_Object *)p->ku.k.p4));
  count = p->ku.k.i1;
  let_depth = p->ku.k.i2;
  shift = p->ku.k.i3;
  for_stx = p->ku.k.i4;
  certs = (Scheme_Object *)p->ku.k.p5;

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

  eval_exptime(names, count, expr, genv, comp_env, rp, let_depth, shift, syntax, for_stx, 
               certs, free_id_rename_rn);

  return NULL;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void eval_module_body ( Scheme_Env menv,
Scheme_Env env 
) [static]

Definition at line 4155 of file module.c.

{
  Scheme_Thread *p;
  Scheme_Module *m = menv->module;
  Scheme_Object *body, **save_runstack;
  int depth;
  int i, cnt;
  Scheme_Cont_Frame_Data cframe;
  Scheme_Config *config;
  int volatile save_phase_shift;
  mz_jmp_buf newbuf, * volatile savebuf;
  LOG_RUN_DECLS;

  menv->running = 1;
  menv->ran = 1;

  depth = m->max_let_depth + scheme_prefix_depth(m->prefix);
  if (!scheme_check_runstack(depth)) {
    p = scheme_current_thread;
    p->ku.k.p1 = menv;
    p->ku.k.p2 = env;
    (void)scheme_enlarge_runstack(depth, eval_module_body_k);
    return;
  }

  LOG_START_RUN(menv->module);

  save_runstack = scheme_push_prefix(menv, m->prefix,
                                 m->me->src_modidx, menv->link_midx,
                                 0, menv->phase);

  p = scheme_current_thread;
  save_phase_shift = p->current_phase_shift;
  p->current_phase_shift = menv->phase;
  savebuf = p->error_buf;
  p->error_buf = &newbuf;

  if (scheme_setjmp(newbuf)) {
    Scheme_Thread *p2;
    p2 = scheme_current_thread;
    p2->error_buf = savebuf;
    p2->current_phase_shift = save_phase_shift;
    scheme_longjmp(*savebuf, 1);
  } else {
    if (env && menv->phase) {
      config = scheme_extend_config(scheme_current_config(),
                                    MZCONFIG_ENV,
                                    (Scheme_Object *)env);
      
      scheme_push_continuation_frame(&cframe);
      scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
    }

    cnt = SCHEME_VEC_SIZE(m->body);
    for (i = 0; i < cnt; i++) {
      body = SCHEME_VEC_ELS(m->body)[i];
      _scheme_eval_linked_expr_multi(body);
    }

    if (scheme_module_demand_hook) {
      Scheme_Object *a[1], *val, *sym;
      a[0] = menv->module->modname;
      sym = scheme_module_demand_hook(1, a);
      if (sym) {
        val = scheme_lookup_global(sym, menv);
        if (val) {
          a[0] = val;
          val = scheme_module_demand_hook(3, a);
          if (val) {
            scheme_add_global_symbol(sym, val, menv);
          }
        }
      }
    }

    if (env && menv->phase) {
      scheme_pop_continuation_frame(&cframe);
    }

    p = scheme_current_thread;
    p->error_buf = savebuf;
    p->current_phase_shift = save_phase_shift;

    scheme_pop_prefix(save_runstack);
  }

  LOG_END_RUN(menv->module);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void* eval_module_body_k ( void  ) [static]

Definition at line 4128 of file module.c.

{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Env *menv, *env;

  menv = (Scheme_Env *)p->ku.k.p1;
  env = (Scheme_Env *)p->ku.k.p2;
  p->ku.k.p1 = NULL;
  p->ku.k.p2 = NULL;

  eval_module_body(menv, env);
  
  return NULL;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* expand_provide ( Scheme_Object e,
Scheme_Hash_Table tables,
Scheme_Object all_defs,
Scheme_Object all_et_defs,
Scheme_Comp_Env cenv,
Scheme_Compile_Info rec,
int  drec 
) [static]

Definition at line 7794 of file module.c.

{
  Scheme_Expand_Info erec1;
  Scheme_Object *b, *stop;
  Scheme_Comp_Env *xenv;
  
  xenv = scheme_new_compilation_frame(0, (SCHEME_CAPTURE_WITHOUT_RENAME 
                                     | SCHEME_FOR_STOPS), 
                                  cenv, NULL);
  stop = scheme_get_stop_expander();
  scheme_add_local_syntax(1, xenv);
  scheme_set_local_syntax(0, scheme_begin_stx, stop, xenv);

  b = scheme_make_pair((Scheme_Object *)tables,
                       scheme_make_pair(all_defs, all_et_defs));
  scheme_current_thread->current_local_bindings = b;
  
  scheme_init_expand_recs(rec, drec, &erec1, 1);
  erec1.value_name = scheme_false;
  erec1.depth = -1;

  e = scheme_expand_expr(e, xenv, &erec1, 0);
  
  scheme_current_thread->current_local_bindings = NULL;

  return e;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void expstart_module ( Scheme_Env menv,
Scheme_Env env,
int  restart 
) [static]

Definition at line 3892 of file module.c.

{
  if (!restart) {
    if (menv && menv->et_running)
      return;
  }

  if (menv->module->primitive)
    return;

  menv->et_running = 1;
  if (scheme_starting_up)
    menv->attached = 1; /* protect initial modules from redefinition, etc. */

  run_module_exptime(menv, 0);

  return;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* extend_list_depth ( Scheme_Object l,
Scheme_Object n,
int  with_ht 
) [static]

Definition at line 1100 of file module.c.

{
  Scheme_Object *p, *orig;
  int k;

  if (!SCHEME_INTP(n))
    scheme_raise_out_of_memory(NULL, NULL);

  k = SCHEME_INT_VAL(n);

  if (SCHEME_NULLP(l)) {
    if (with_ht)
      p = (Scheme_Object *)scheme_make_hash_table(SCHEME_hash_ptr);
    else
      p = scheme_null;
    l = scheme_make_pair(p, scheme_null);
  }
   
  orig = l;
  
  while (k--) {
    if (SCHEME_NULLP(SCHEME_CDR(l))) {
      if (with_ht)
        p = (Scheme_Object *)scheme_make_hash_table(SCHEME_hash_ptr);
      else
        p = scheme_null;
      p = scheme_make_pair(p, scheme_null);
      SCHEME_CDR(l) = p;
    }
    l = SCHEME_CDR(l);
  }

  return orig;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* extract_at_depth ( Scheme_Object l,
Scheme_Object n 
) [static]

Definition at line 1135 of file module.c.

{
  int k = SCHEME_INT_VAL(n);

  while (k--) {
    l = SCHEME_CDR(l);
  }

  return SCHEME_CAR(l);
}

Here is the caller graph for this function:

static Scheme_Object* extract_free_id_name ( Scheme_Object name,
Scheme_Object phase,
Scheme_Env genv,
int  always,
int _implicit,
Scheme_Object **  _implicit_src,
Scheme_Object **  _implicit_src_name,
Scheme_Object **  _implicit_mod_phase,
Scheme_Object **  _implicit_nominal_name,
Scheme_Object **  _implicit_nominal_mod,
Scheme_Object **  _implicit_insp 
) [static]

Definition at line 7307 of file module.c.

{
  *_implicit = 0;

  while (1) { /* loop for free-id=? renaming */
    if (SCHEME_STXP(name)) {
      if (genv
          && (always
              || SAME_OBJ(phase, scheme_make_integer(0))
              || SAME_OBJ(phase, scheme_make_integer(1))))
        name = scheme_tl_id_sym(genv, name, NULL, -1, phase, NULL);
      else
        name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */
    }
    
    /* Check for free-id=? renaming: */
    if (SAME_OBJ(phase, scheme_make_integer(0))) {
      Scheme_Object *v2;
      v2 = scheme_lookup_in_table(genv->syntax, (const char *)name);
      if (v2 && scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(v2))) {
        Scheme_Object *name2;
        Scheme_Object *mod, *id, *rename_insp = NULL;
        Scheme_Object *mod_phase = NULL;

        name2 = scheme_rename_transformer_id(SCHEME_PTR_VAL(v2));
        id = name2;

        if (_implicit_mod_phase) mod_phase = *_implicit_mod_phase;
        mod = scheme_stx_module_name(NULL, &id, phase, 
                                     _implicit_nominal_mod, _implicit_nominal_name,
                                     &mod_phase, 
                                     NULL, NULL, NULL, NULL, &rename_insp);
        if (_implicit_mod_phase) *_implicit_mod_phase = mod_phase;
          
        if (mod && SAME_TYPE(SCHEME_TYPE(mod), scheme_module_index_type)) {
          if (SCHEME_FALSEP(((Scheme_Modidx *)mod)->path)) {
            /* keep looking locally */
            name = name2;
            SCHEME_USE_FUEL(1);
          } else {
            /* free-id=? equivalence to a name that is not necessarily imported explicitly. */
            int would_complain = 0, is_prot = 0, is_unexp = 0;

            if (!SCHEME_FALSEP(phase)) {
              /* Check whether reference is certified, and ignore it if not: */
              Scheme_Env *menv;
              Scheme_Object *modname;
              
              modname = scheme_module_resolve(mod, 1);
              menv = scheme_module_access(modname, genv, SCHEME_INT_VAL(mod_phase));
              if (!menv)
                would_complain = 1;
              else {
                scheme_check_accessible_in_module(menv, menv->module->insp, mod, 
                                                  SCHEME_STX_VAL(name2), name2, 
                                                  NULL, NULL, rename_insp,
                                                  -1, 0, 
                                                  &is_prot, &is_unexp, genv, &would_complain);
                if (would_complain && (!is_prot && !is_unexp)) {
                  /* Must be unexported syntax */
                  is_prot = is_unexp = would_complain = 0;
                  scheme_check_accessible_in_module(menv, menv->module->insp, mod, 
                                                    SCHEME_STX_VAL(name2), name2, 
                                                    NULL, NULL, rename_insp,
                                                    -2, 0, 
                                                    &is_prot, &is_unexp, genv, &would_complain);
                }
              }
            }


            if (!would_complain) {
              if (_implicit_src) {
                *_implicit_src = mod;
                *_implicit_src_name = id;
                if (is_prot || is_unexp) {
                  if (rename_insp)
                    *_implicit_insp = rename_insp;
                  else
                    *_implicit_insp = genv->module->insp;
                }
                name2 = scheme_stx_property(name2, nominal_id_symbol, NULL);
                if (SCHEME_SYMBOLP(name2))
                  *_implicit_nominal_name = name2;
              }
              *_implicit = 1;
            }
            break;
          }
        } else
          break;
      } else
        break;
    } else
      break;
  }

  return name;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void flush_definitions ( Scheme_Env genv) [static]

Definition at line 5863 of file module.c.

Here is the caller graph for this function:

static Scheme_Hash_Table* get_required_from_tables ( Scheme_Hash_Table tables,
Scheme_Object phase 
) [static]

Definition at line 2246 of file module.c.

{
  Scheme_Object *vec;

  if (!tables)
    return NULL;
  
  vec = scheme_hash_get(tables, phase);
  if (!vec) {
    Scheme_Hash_Table *res;
    vec = scheme_make_vector(3, NULL);
    res = scheme_make_hash_table(SCHEME_hash_ptr);
    SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)res;
    scheme_hash_set(tables, phase, vec);
  }

  return (Scheme_Hash_Table *)SCHEME_VEC_ELS(vec)[1];
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Env* instantiate_module ( Scheme_Module m,
Scheme_Env env,
int  restart,
Scheme_Object syntax_idx 
) [static]

Definition at line 3797 of file module.c.

{
  Scheme_Env *menv;

  if (!restart) {
    menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname);
    if (menv) {
      check_phase(menv, env, 0);
      return menv;
    }
  }

  if (m->primitive) {
    menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname);
    if (!menv) {
      menv = m->primitive;
      scheme_hash_set(MODCHAIN_TABLE(env->modchain), m->modname, (Scheme_Object *)menv);
    }
    menv->require_names = scheme_null;
    menv->et_require_names = scheme_null;
    menv->tt_require_names = scheme_null;
    menv->dt_require_names = scheme_null;
    return menv;
  }

  menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname);
  if (!menv || restart) {
    Scheme_Object *insp;

    if (!menv) {
      /* printf("new %ld %s\n", env->phase, SCHEME_SYM_VAL(m->modname)); */
      menv = scheme_new_module_env(env, m, 0);
      scheme_hash_set(MODCHAIN_TABLE(env->modchain), m->modname, (Scheme_Object *)menv);
      
      menv->phase = env->phase;
      menv->link_midx = syntax_idx;
    } else {
      Scheme_Env *env2;

      menv->module = m;
      menv->running = 0;
      menv->et_running = 0;
      menv->ran = 0;
      menv->did_starts = NULL;

      for (env2 = menv->exp_env; env2; env2 = env2->exp_env) {
        env2->module = m;
      }
      for (env2 = menv->template_env; env2; env2 = env2->template_env) {
        env2->module = m;
      }
      env2 = menv->label_env;
      if (env2)
        env2->module = m;
    }

    insp = scheme_make_inspector(m->insp);
    menv->insp = insp;

    /* These three should be set by various "finish"es, but
       we initialize them in case there's an error runing a "finish". */
    menv->require_names = scheme_null;
    menv->et_require_names = scheme_null;
    menv->tt_require_names = scheme_null;
    menv->dt_require_names = scheme_null;

    if (env->label_env != env) {
      setup_accessible_table(m);

      /* Create provided global variables: */
      {
        Scheme_Object **exss, **exsns;
        int i, count;

        exsns = m->me->rt->provide_src_names;
        exss = m->me->rt->provide_srcs;
        count = m->me->rt->num_var_provides;

        for (i = 0; i < count; i++) {
          if (SCHEME_FALSEP(exss[i]))
            scheme_add_to_table(menv->toplevel, (const char *)exsns[i], NULL, 0);
        }

        count = m->num_indirect_provides;
        exsns = m->indirect_provides;
        for (i = 0; i < count; i++) {
          scheme_add_to_table(menv->toplevel, (const char *)exsns[i], NULL, 0);
        }
      }
    }
  }

  return menv;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 2163 of file module.c.

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

Here is the caller graph for this function:

static int is_simple_expr ( Scheme_Object v) [static]

Definition at line 4500 of file module.c.

{
  Scheme_Type t;

  t = SCHEME_TYPE(v);
  if (SAME_TYPE(t, scheme_unclosed_procedure_type))
    return 1;

  return 0;
}

Here is the caller graph for this function:

static Scheme_Object* jit_vector ( Scheme_Object orig_l,
int  in_vec,
int  jit 
) [static]

Definition at line 4785 of file module.c.

{
  Scheme_Object *orig, *naya = NULL;
  Resolve_Prefix *orig_rp, *rp;
  int i, cnt;

  cnt = SCHEME_VEC_SIZE(orig_l);
  for (i = 0; i < cnt; i++) {
    orig = SCHEME_VEC_ELS(orig_l)[i];
    if (in_vec) {
      orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(orig)[3];
      rp = scheme_prefix_eval_clone(orig_rp);
      orig = SCHEME_VEC_ELS(orig)[1];
    } else {
      orig_rp = rp = NULL;
    }

    if (jit)
      naya = scheme_jit_expr(orig);
    else
      naya = orig;

    if (!SAME_OBJ(orig, naya)
        || !SAME_OBJ(orig_rp, rp))
      break;
  }

  if (i < cnt) {
    Scheme_Object *new_l;
    int j;
    new_l = scheme_make_vector(cnt, NULL);
    for (j = 0; j < i; j++) {
      SCHEME_VEC_ELS(new_l)[j] = SCHEME_VEC_ELS(orig_l)[j];
    }
    if (in_vec)
      naya = rebuild_et_vec(naya, SCHEME_VEC_ELS(orig_l)[i], rp);
    SCHEME_VEC_ELS(new_l)[i] = naya;
    for (i++; i < cnt; i++) {
      orig = SCHEME_VEC_ELS(orig_l)[i];
      if (in_vec) {
        orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(orig)[3];
        rp = scheme_prefix_eval_clone(orig_rp);
        orig = SCHEME_VEC_ELS(orig)[1];        
      } else {
        orig_rp = rp = NULL;
      }

      if (jit)
        naya = scheme_jit_expr(orig);
      else
        naya = orig;

      if (in_vec) {
       if (!SAME_OBJ(orig, naya)
            || !SAME_OBJ(rp, orig_rp))
         naya = rebuild_et_vec(naya, SCHEME_VEC_ELS(orig_l)[i], rp);
       else
         naya = SCHEME_VEC_ELS(orig_l)[i];
      }
      SCHEME_VEC_ELS(new_l)[i] = naya;
    }
    return new_l;
  } else
    return orig_l;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static XFORM_NONGCING long make_key ( int  base_phase,
int  eval_exp,
int  eval_run 
) [static]

Definition at line 3534 of file module.c.

{
  return ((base_phase << 3) 
          | (eval_exp ? ((eval_exp > 0) ? 2 : 4) : 0) 
          | (eval_run ? 1 : 0));
}

Here is the caller graph for this function:

static Scheme_Object* make_provide_desc ( Scheme_Module_Phase_Exports pt,
int  i 
) [static]

Definition at line 2585 of file module.c.

Here is the caller graph for this function:

static Scheme_Object* make_require_form ( Scheme_Object module_path,
long  phase,
Scheme_Object mark 
) [static]

Definition at line 5792 of file module.c.

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 2768 of file module.c.

{
  if (!SCHEME_SYMBOLP(argv[0])
      && (!SCHEME_PATHP(argv[0])
          || !scheme_is_complete_path(SCHEME_PATH_VAL(argv[0]),
                                      SCHEME_PATH_LEN(argv[0]),
                                      SCHEME_PLATFORM_PATH_KIND)))
    scheme_wrong_type("make-resolved-module-path", "symbol or complete path", 0, argc, argv);

  return scheme_intern_resolved_module_path(argv[0]);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 6768 of file module.c.

{
  SCHEME_EXPAND_OBSERVE_PRIM_MODULE_BEGIN(erec[drec].observer);
  return do_module_begin(form, env, erec, drec);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 6762 of file module.c.

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

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 2594 of file module.c.

{
  Scheme_Module *m;
  Scheme_Object *a[2];
  Scheme_Object *ml, *vl, *val_l, *mac_l;
  Scheme_Module_Phase_Exports *pt;
  int i, n, k;

  m = scheme_extract_compiled_module(argv[0]);

  if (m) {
    val_l = scheme_null;
    mac_l = scheme_null;

    for (k = -3; k < (m->me->other_phases ? m->me->other_phases->size : 0); k++) {
      switch(k) {
      case -3:
        pt = m->me->rt;
        break;
      case -2:
        pt = m->me->et;
        break;
      case -1:
        pt = m->me->dt;
        break;
      default:
        pt = (Scheme_Module_Phase_Exports *)m->me->other_phases->vals[k];
        break;
      }

      if (pt) {
        ml = scheme_null;
        vl = scheme_null;
        n = pt->num_var_provides;
        for (i = pt->num_provides - 1; i >= n; --i) {
          ml = scheme_make_pair(make_provide_desc(pt, i), ml);
        }
        for (; i >= 0; --i) {
          vl = scheme_make_pair(make_provide_desc(pt, i), vl);
        }

        if (!SCHEME_NULLP(vl))
          val_l = scheme_make_pair(scheme_make_pair(pt->phase_index, vl), 
                                   val_l);

        if (!SCHEME_NULLP(ml))
          mac_l = scheme_make_pair(scheme_make_pair(pt->phase_index, ml),
                                   mac_l);
      }
    }
    
    a[0] = val_l;
    a[1] = mac_l;
    return scheme_values(2, a);
  }

  scheme_wrong_type("module-compiled-exports", "compiled module declaration", 0, argc, argv);
  return NULL;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 2541 of file module.c.

{
  Scheme_Module *m;
  Scheme_Object *l;
  int i;

  m = scheme_extract_compiled_module(argv[0]);

  if (m) {
    l = scheme_null;
    if (!SCHEME_NULLP(m->requires))
      l = scheme_make_pair(scheme_make_pair(scheme_make_integer(0),
                                            m->requires),
                           l);
    if (!SCHEME_NULLP(m->et_requires))
      l = scheme_make_pair(scheme_make_pair(scheme_make_integer(1),
                                            m->et_requires),
                           l);
    if (!SCHEME_NULLP(m->tt_requires))
      l = scheme_make_pair(scheme_make_pair(scheme_make_integer(-1),
                                            m->tt_requires),
                           l);
    if (!SCHEME_NULLP(m->dt_requires))
      l = scheme_make_pair(scheme_make_pair(scheme_false,
                                            m->dt_requires),
                           l);

    if (m->other_requires) {
      for (i = 0; i < m->other_requires->size; i++) {
        if (m->other_requires->vals[i]) {
          l = scheme_make_pair(scheme_make_pair(m->other_requires->keys[i],
                                                m->other_requires->vals[i]),
                               l);
        }
      }
    }
    
    return l;
  }

  scheme_wrong_type("module-compiled-imports", "compiled module declaration", 0, argc, argv);
  return NULL;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 2654 of file module.c.

{
  Scheme_Module *m;

  m = scheme_extract_compiled_module(argv[0]);

  if (m) {
    return (m->lang_info ? m->lang_info : scheme_false);
  }

  scheme_wrong_type("module-compiled-language-info", "compiled module declaration", 0, argc, argv);
  return NULL;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 2527 of file module.c.

{
  Scheme_Module *m;

  m = scheme_extract_compiled_module(argv[0]);
      
  if (m) {
    return SCHEME_PTR_VAL(m->modname);
  }

  scheme_wrong_type("module-compiled-name", "compiled module declaration", 0, argc, argv);
  return NULL;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 2518 of file module.c.

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * module_execute ( Scheme_Object data) [static]

Definition at line 4673 of file module.c.

{
  Scheme_Module *m;
  Scheme_Env *env;
  Scheme_Env *old_menv;
  Scheme_Object *prefix, *insp, **rt_insps, **et_insps;

  m = MALLOC_ONE_TAGGED(Scheme_Module);
  memcpy(m, data, sizeof(Scheme_Module));

  prefix = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_MODULE_NAME);
  if (SCHEME_MODNAMEP(prefix)) {
    m->modname = prefix;
    
    if (m->self_modidx) {
      if (!SCHEME_SYMBOLP(m->self_modidx)) {
       Scheme_Modidx *midx = (Scheme_Modidx *)m->self_modidx;
       Scheme_Object *nmidx;

       nmidx = scheme_make_modidx(midx->path, midx->base, m->modname);
       m->self_modidx = nmidx;

       if (m->rn_stx && !SAME_OBJ(scheme_true, m->rn_stx)) {
         /* Delay the shift: */
         Scheme_Object *v;
         v = scheme_make_pair(m->rn_stx, (Scheme_Object *)midx);
         m->rn_stx = v;
       }
      }
    }
  }

  env = scheme_environment_from_dummy(m->dummy);

  if (SAME_OBJ(m->modname, kernel_modname))
    old_menv = scheme_get_kernel_env();
  else
    old_menv = (Scheme_Env *)scheme_hash_get(MODCHAIN_TABLE(env->modchain), m->modname);

  insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
  
  if (old_menv) {
    if (scheme_module_protected_wrt(old_menv->insp, insp) || old_menv->attached) {
      scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                     "module->namespace: current code inspector cannot re-declare module: %D",
                     m->modname);
      return NULL;
    }
  }

  if (m->me->rt->provide_insps)
    rt_insps = declare_insps(m->me->rt->num_provides, m->me->rt->provide_insps, insp);
  else
    rt_insps = NULL;
  if (m->me->et->provide_insps)
    et_insps = declare_insps(m->me->et->num_provides, m->me->et->provide_insps, insp);
  else
    et_insps = NULL;

  if (!SAME_OBJ(rt_insps, m->me->rt->provide_insps)
      || !SAME_OBJ(et_insps, m->me->et->provide_insps)) {
    /* have to clone m->me, etc. */
    Scheme_Module_Exports *naya_me;
    Scheme_Module_Phase_Exports *pt;

    naya_me = MALLOC_ONE_TAGGED(Scheme_Module_Exports);
    memcpy(naya_me, m->me, sizeof(Scheme_Module_Exports));
    m->me = naya_me;

    if (!SAME_OBJ(rt_insps, m->me->rt->provide_insps)) {
      pt = MALLOC_ONE_TAGGED(Scheme_Module_Phase_Exports);
      memcpy(pt, m->me->rt, sizeof(Scheme_Module_Phase_Exports));
      m->me->rt = pt;
      pt->provide_insps = rt_insps;
    }

    if (!SAME_OBJ(rt_insps, m->me->et->provide_insps)) {
      pt = MALLOC_ONE_TAGGED(Scheme_Module_Phase_Exports);
      memcpy(pt, m->me->et, sizeof(Scheme_Module_Phase_Exports));
      m->me->et = pt;
      pt->provide_insps = et_insps;
    }
  }

  m->insp = insp;
  scheme_hash_set(env->module_registry, m->modname, (Scheme_Object *)m);
  scheme_hash_set(env->export_registry, m->modname, (Scheme_Object *)m->me);

  /* Replacing an already-running or already-syntaxing module? */
  if (old_menv) {
    start_module(m, env, 1, NULL, old_menv->et_running, old_menv->running, env->phase, scheme_null);
  }

  return scheme_void;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 5572 of file module.c.

{
  SCHEME_EXPAND_OBSERVE_PRIM_MODULE(erec[drec].observer);
  if (erec[drec].depth > 0)
    erec[drec].depth++;

  return do_module(form, env, erec, drec);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 2789 of file module.c.

{
  Scheme_Env *env;
  Scheme_Object *modname, *mv, *name;
  Scheme_Module *m;
  int i, count;

  if (!SCHEME_MODNAMEP(argv[0])
      && !SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_module_index_type))
    scheme_wrong_type("module-provide-protected?", "resolved-module-path or module-path-index", 0, argc, argv);
  if (!SCHEME_SYMBOLP(argv[1]))
    scheme_wrong_type("module-provide-protected?", "symbol", 1, argc, argv);

  modname = scheme_module_resolve(argv[0], 1);
  name = argv[1];

  env = scheme_get_env(NULL);
  if (SAME_OBJ(modname, kernel_modname))
    mv = (Scheme_Object *)kernel;
  else
    mv = scheme_hash_get(env->module_registry, modname);
  if (!mv) {
    scheme_arg_mismatch("module-provide-protected?",
                     "unknown module (in the source namespace): ",
                     modname);
    return NULL;
  }

  m = (Scheme_Module *)mv;

  count = m->me->rt->num_provides;
  for (i = 0; i < count; i++) {
    if (SAME_OBJ(name, m->me->rt->provides[i])) {
      if (m->provide_protects && m->provide_protects[i])
       return scheme_true;
      else
       return scheme_false;
    }
  }

  return scheme_true;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * module_jit ( Scheme_Object data) [static]

Definition at line 4879 of file module.c.

{
  return do_module_clone(data, 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Module * module_load ( Scheme_Object modname,
Scheme_Env env,
const char *  who 
) [static]

Definition at line 3095 of file module.c.

{
  if (name == kernel_modname)
    return kernel;
  else {
    Scheme_Module *m;

    m = (Scheme_Module *)scheme_hash_get(env->module_registry, name);

    if (!m) {
      char *mred_note;

      if (!strcmp(SCHEME_SYM_VAL(SCHEME_PTR_VAL(name)), "#%mred-kernel")
         && !(scheme_strncmp(scheme_banner(), "Welcome to MzScheme", 19)))
       mred_note = "; need to run in mred instead of mzscheme";
      else
       mred_note = "";

      scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                     "%s: unknown module: %D%s",
                     who ? who : "require", 
                     name, mred_note);
      return NULL;
    }

    return m;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 4960 of file module.c.

{
  Scheme_Module *m = (Scheme_Module *)data;
  Scheme_Object *e, *vars, *old_context;
  int start_simltaneous = 0, i_m, cnt;
  Scheme_Object *cl_first = NULL, *cl_last = NULL;
  Scheme_Hash_Table *consts = NULL, *ready_table = NULL, *re_consts = NULL;
  int cont, next_pos_ready = -1;

  old_context = info->context;
  info->context = (Scheme_Object *)m;

  cnt = SCHEME_VEC_SIZE(m->