Back to index

plt-scheme  4.2.1
Classes | Defines | Typedefs | Functions | Variables
stxobj.c File Reference
#include "schpriv.h"
#include "schmach.h"

Go to the source code of this file.

Classes

struct  Module_Renames
struct  Module_Renames_Set
struct  Scheme_Cert
struct  Scheme_Lexical_Rib
struct  Wrap_Chunk
struct  Wrap_Pos

Defines

#define CONS   scheme_make_pair
#define ICONS   scheme_make_pair
#define HAS_SUBSTX(obj)   (SCHEME_PAIRP(obj) || SCHEME_VECTORP(obj) || SCHEME_BOXP(obj) || prefab_p(obj) || SCHEME_HASHTRP(obj))
#define STX_KEY(stx)   MZ_OPT_HASH_KEY(&(stx)->iso)
#define CERT_NO_KEY(c)   (MZ_OPT_HASH_KEY(&(c)->iso) & 0x1)
#define CERT_SET_NO_KEY(c)   (MZ_OPT_HASH_KEY(&(c)->iso) |= 0x1)
#define ACTIVE_CERTS(stx)   ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CAR((stx)->certs) : (stx)->certs) : NULL))
#define INACTIVE_CERTS(stx)   ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CDR((stx)->certs) : NULL) : NULL))
#define SCHEME_RENAME_LEN(vec)   ((SCHEME_VEC_SIZE(vec) - 2) >> 1)
#define SCHEME_RENAMESP(obj)   (SAME_TYPE(SCHEME_TYPE(obj), scheme_rename_table_type))
#define SCHEME_RENAMES_SETP(obj)   (SAME_TYPE(SCHEME_TYPE(obj), scheme_rename_table_set_type))
#define SCHEME_MODIDXP(obj)   (SAME_TYPE(SCHEME_TYPE(obj), scheme_module_index_type))
#define SCHEME_RIB_DELIMP(obj)   (SAME_TYPE(SCHEME_TYPE(obj), scheme_rib_delimiter_type))
#define SCHEME_PRUNEP(obj)   (SAME_TYPE(SCHEME_TYPE(obj), scheme_prune_context_type))
#define IS_POSMARK(x)   (SCHEME_INTP(x) ? (SCHEME_INT_VAL(x) >= 0) : SCHEME_BIGPOS(x))
#define SCHEME_MARKP(x)   (SCHEME_INTP(x) || SCHEME_BIGNUMP(x))
#define MALLOC_WRAP_CHUNK(n)   (Wrap_Chunk *)scheme_malloc_tagged(sizeof(Wrap_Chunk) + ((n - 1) * sizeof(Scheme_Object *)))
#define WRAP_POS   Wrap_Pos
#define WRAP_POS_INIT(w, wr)   w.l = wr; WRAP_POS_SET_FIRST(&w)
#define WRAP_POS_INC(w)   DO_WRAP_POS_INC(&w)
#define WRAP_POS_INIT_END(w)   (w.l = scheme_null, w.a = NULL, w.is_limb = 0, w.pos = 0)
#define WRAP_POS_END_P(w)   SCHEME_NULLP(w.l)
#define WRAP_POS_FIRST(w)   w.a
#define WRAP_POS_COPY(w, w2)   w.l = (w2).l; w.a = (w2).a; w.is_limb= (w2).is_limb; w.pos = (w2).pos
#define WRAP_POS_KEY(w)   w.l
#define WRAP_POS_REVINIT(w, k)   DO_WRAP_POS_REVINIT(&w, k)
#define WRAP_POS_REVEND_P(w)   (w.pos < 0)
#define WRAP_POS_DEC(w)   --w.pos; if (w.pos >= 0) w.a = ((Wrap_Chunk *)SCHEME_CAR(w.l))->a[w.pos]
#define WRAP_POS_PLAIN_TAIL(w)   (w.is_limb ? (w.pos ? NULL : w.l) : w.l)
#define RENAME_HT_THRESHOLD   15
#define PREEMPTIVE_CHUNK_THRESHOLD   32
#define EXPLAIN_RESOLVE   0
#define EXPLAIN(x)   /* empty */
#define FAST_STACK_SIZE   4
#define QUICK_STACK_SIZE   16
#define EXPLAIN_SIMP   0
#define EXPLAIN_S(x)   /* empty */
#define EXPLAIN_R(x)   /* empty */
#define return_NULL   return NULL
#define SCHEME_STX_IDP(o)   (SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o)))

Typedefs

typedef struct Module_Renames Module_Renames
typedef struct Module_Renames_Set Module_Renames_Set
typedef struct Scheme_Cert Scheme_Cert
typedef struct Scheme_Lexical_Rib Scheme_Lexical_Rib

Functions

static Scheme_Objectsyntax_p (int argc, Scheme_Object **argv)
static Scheme_Objectsyntax_to_datum (int argc, Scheme_Object **argv)
static Scheme_Objectdatum_to_syntax (int argc, Scheme_Object **argv)
static Scheme_Objectsyntax_line (int argc, Scheme_Object **argv)
static Scheme_Objectsyntax_col (int argc, Scheme_Object **argv)
static Scheme_Objectsyntax_pos (int argc, Scheme_Object **argv)
static Scheme_Objectsyntax_span (int argc, Scheme_Object **argv)
static Scheme_Objectsyntax_src (int argc, Scheme_Object **argv)
static Scheme_Objectsyntax_to_list (int argc, Scheme_Object **argv)
static Scheme_Objectsyntax_original_p (int argc, Scheme_Object **argv)
static Scheme_Objectsyntax_property (int argc, Scheme_Object **argv)
static Scheme_Objectsyntax_property_keys (int argc, Scheme_Object **argv)
static Scheme_Objectsyntax_track_origin (int argc, Scheme_Object **argv)
static Scheme_Objectbound_eq (int argc, Scheme_Object **argv)
static Scheme_Objectmodule_eq (int argc, Scheme_Object **argv)
static Scheme_Objectmodule_trans_eq (int argc, Scheme_Object **argv)
static Scheme_Objectmodule_templ_eq (int argc, Scheme_Object **argv)
static Scheme_Objectmodule_label_eq (int argc, Scheme_Object **argv)
static Scheme_Objectmodule_binding (int argc, Scheme_Object **argv)
static Scheme_Objectmodule_trans_binding (int argc, Scheme_Object **argv)
static Scheme_Objectmodule_templ_binding (int argc, Scheme_Object **argv)
static Scheme_Objectmodule_label_binding (int argc, Scheme_Object **argv)
static Scheme_Objectidentifier_prune (int argc, Scheme_Object **argv)
static Scheme_Objectsyntax_src_module (int argc, Scheme_Object **argv)
static Scheme_Objectsyntax_recertify (int argc, Scheme_Object **argv)
static Scheme_Objectlift_inactive_certs (Scheme_Object *o, int as_active)
static Scheme_Objectwrite_free_id_info_prefix (Scheme_Object *obj)
static Scheme_Objectread_free_id_info_prefix (Scheme_Object *obj)
static int includes_mark (Scheme_Object *wraps, Scheme_Object *mark)
static void add_all_marks (Scheme_Object *wraps, Scheme_Hash_Table *marks)
static struct Scheme_Certcons_cert (Scheme_Object *mark, Scheme_Object *modidx, Scheme_Object *insp, Scheme_Object *key, struct Scheme_Cert *next_cert)
static void phase_shift_certs (Scheme_Object *o, Scheme_Object *owner_wraps, int len)
static void preemptive_chunk (Scheme_Stx *stx)
static XFORM_NONGCING int prefab_p (Scheme_Object *o)
static Scheme_Objectstx_activate_certs (Scheme_Object *o, Scheme_Cert **cp)
static XFORM_NONGCING int is_member (Scheme_Object *a, Scheme_Object *l)
static int is_rename_inspector_info (Scheme_Object *v)
static XFORM_NONGCING int nom_mod_p (Scheme_Object *p)
static XFORM_NONGCING void WRAP_POS_SET_FIRST (Wrap_Pos *w)
static XFORM_NONGCING
MZ_INLINE void 
DO_WRAP_POS_INC (Wrap_Pos *w)
static XFORM_NONGCING void DO_WRAP_POS_REVINIT (Wrap_Pos *w, Scheme_Object *k)
void scheme_init_stx (Scheme_Env *env)
void scheme_init_stx_places ()
Scheme_Objectscheme_make_stx (Scheme_Object *val, Scheme_Stx_Srcloc *srcloc, Scheme_Object *props)
Scheme_Objectscheme_make_stx_w_offset (Scheme_Object *val, long line, long col, long pos, long span, Scheme_Object *src, Scheme_Object *props)
Scheme_Objectscheme_make_renamed_stx (Scheme_Object *sym, Scheme_Object *rn)
Scheme_Objectscheme_stx_track (Scheme_Object *naya, Scheme_Object *old, Scheme_Object *origin)
static int maybe_add_chain_cache (Scheme_Stx *stx)
static void set_wraps_to_skip (Scheme_Hash_Table *ht, WRAP_POS *wraps)
static void fill_chain_cache (Scheme_Object *wraps)
Scheme_Objectscheme_new_mark ()
static Scheme_Objectnegate_mark (Scheme_Object *n)
Scheme_Objectscheme_add_remove_mark (Scheme_Object *o, Scheme_Object *m)
Scheme_Objectscheme_make_rename (Scheme_Object *newname, int c)
static void maybe_install_rename_hash_table (Scheme_Object *v)
void scheme_set_rename (Scheme_Object *rnm, int pos, Scheme_Object *oldname)
Scheme_Objectscheme_make_rename_rib ()
void scheme_add_rib_rename (Scheme_Object *ro, Scheme_Object *rename)
void scheme_drop_first_rib_rename (Scheme_Object *ro)
void scheme_stx_seal_rib (Scheme_Object *rib)
intscheme_stx_get_rib_sealed (Scheme_Object *rib)
Scheme_Objectscheme_stx_id_remove_rib (Scheme_Object *stx, Scheme_Object *ro)
static Scheme_Objectmake_prune_context (Scheme_Object *a)
static int same_phase (Scheme_Object *a, Scheme_Object *b)
Scheme_Objectscheme_make_module_rename_set (int kind, Scheme_Object *share_marked_names)
void scheme_add_module_rename_to_set (Scheme_Object *set, Scheme_Object *rn)
Scheme_Objectscheme_get_module_rename_from_set (Scheme_Object *set, Scheme_Object *phase, int create)
Scheme_Hash_Tablescheme_get_module_rename_marked_names (Scheme_Object *set, Scheme_Object *phase, int create)
Scheme_Objectscheme_make_module_rename (Scheme_Object *phase, int kind, Scheme_Hash_Table *marked_names)
void scheme_seal_module_rename (Scheme_Object *rn, int level)
void scheme_seal_module_rename_set (Scheme_Object *_rns, int level)
static void check_not_sealed (Module_Renames *mrn)
static Scheme_Objectphase_to_index (Scheme_Object *phase)
Scheme_Objectscheme_extend_module_rename (Scheme_Object *mrn, Scheme_Object *modname, Scheme_Object *localname, Scheme_Object *exname, Scheme_Object *nominal_mod, Scheme_Object *nominal_ex, int mod_phase, Scheme_Object *src_phase_index, Scheme_Object *nom_phase, Scheme_Object *insp, int mode)
void scheme_extend_module_rename_with_shared (Scheme_Object *rn, Scheme_Object *modidx, Scheme_Module_Phase_Exports *pt, Scheme_Object *unmarshal_phase_index, Scheme_Object *src_phase_index, Scheme_Object *marks, int save_unmarshal)
void scheme_save_module_rename_unmarshal (Scheme_Object *rn, Scheme_Object *info)
static void do_append_module_rename (Scheme_Object *src, Scheme_Object *dest, Scheme_Object *old_midx, Scheme_Object *new_midx, int do_pes, int do_unm)
void scheme_append_module_rename (Scheme_Object *src, Scheme_Object *dest, int do_unm)
void scheme_append_rename_set_to_env (Scheme_Object *_mrns, Scheme_Env *env)
void scheme_remove_module_rename (Scheme_Object *mrn, Scheme_Object *localname)
void scheme_list_module_rename (Scheme_Object *set, Scheme_Hash_Table *ht)
Scheme_Objectscheme_rename_to_stx (Scheme_Object *mrn)
Scheme_Objectscheme_stx_to_rename (Scheme_Object *stx)
Scheme_Objectscheme_stx_shift_rename (Scheme_Object *mrn, Scheme_Object *old_midx, Scheme_Object *new_midx)
Scheme_Objectscheme_stx_shift_rename_set (Scheme_Object *_mrns, Scheme_Object *old_midx, Scheme_Object *new_midx)
Scheme_Hash_Tablescheme_module_rename_marked_names (Scheme_Object *rn)
static void unmarshal_rename (Module_Renames *mrn, Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to, Scheme_Hash_Table *export_registry)
Scheme_Objectscheme_add_rename (Scheme_Object *o, Scheme_Object *rename)
void scheme_load_delayed_syntax (struct Resolve_Prefix *rp, long i)
Scheme_Objectscheme_delayed_rename (Scheme_Object **o, long i)
Scheme_Objectscheme_add_rename_rib (Scheme_Object *o, Scheme_Object *rib)
Scheme_Objectscheme_add_rib_delimiter (Scheme_Object *o, Scheme_Object *ribs)
static int is_in_rib_delim (Scheme_Object *envname, Scheme_Object *rib_delim)
static Scheme_Hash_Tablemake_recur_table ()
static void release_recur_table (Scheme_Hash_Table *free_id_recur)
static Scheme_Objectextract_module_free_id_binding (Scheme_Object *mrn, Scheme_Object *id, Scheme_Object *orig_id, int *_sealed, Scheme_Hash_Table *free_id_recur)
void scheme_install_free_id_rename (Scheme_Object *id, Scheme_Object *orig_id, Scheme_Object *rename_rib, Scheme_Object *phase)
Scheme_Objectscheme_stx_phase_shift_as_rename (long shift, Scheme_Object *old_midx, Scheme_Object *new_midx, Scheme_Hash_Table *export_registry)
Scheme_Objectscheme_stx_phase_shift (Scheme_Object *stx, long shift, Scheme_Object *old_midx, Scheme_Object *new_midx, Scheme_Hash_Table *export_registry)
void scheme_clear_shift_cache (void)
static Scheme_Objectmake_chunk (int len, Scheme_Object *owner_wraps)
static Scheme_Objectpropagate_wraps (Scheme_Object *o, int len, Scheme_Object **_ml, Scheme_Object *owner_wraps)
int scheme_stx_certified (Scheme_Object *stx, Scheme_Object *extra_certs, Scheme_Object *home_modidx, Scheme_Object *home_insp)
static void make_mapped (Scheme_Cert *cert)
static int cert_in_chain (Scheme_Object *mark, Scheme_Object *key, Scheme_Cert *cert)
static Scheme_Certappend_certs (Scheme_Cert *a, Scheme_Cert *b)
static Scheme_Objectadd_certs (Scheme_Object *o, Scheme_Cert *certs, Scheme_Object *use_key, int active)
Scheme_Objectscheme_stx_add_inactive_certs (Scheme_Object *o, Scheme_Object *certs)
Scheme_Objectscheme_stx_propagate_inactive_certs (Scheme_Object *o, Scheme_Object *orig)
Scheme_Objectscheme_stx_extract_certs (Scheme_Object *o, Scheme_Object *base_certs)
Scheme_Objectscheme_stx_cert (Scheme_Object *o, Scheme_Object *mark, Scheme_Env *menv, Scheme_Object *plus_stx_or_certs, Scheme_Object *key, int active)
Scheme_Objectscheme_stx_content (Scheme_Object *o)
Scheme_Objectscheme_stx_extract_marks (Scheme_Object *stx)
Scheme_Objectscheme_stx_strip_module_context (Scheme_Object *_stx)
Scheme_Objectscheme_stx_activate_certs (Scheme_Object *o)
int scheme_stx_has_empty_wraps (Scheme_Object *o)
static Scheme_Objectcheck_floating_id (Scheme_Object *stx)
static int same_marks (WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env)
static int check_matching_marks (Scheme_Object *p, Scheme_Object *orig_id, Scheme_Object **marks_cache, int depth, int *_skipped)
static Scheme_Objectsearch_shared_pes (Scheme_Object *shared_pes, Scheme_Object *glob_id, Scheme_Object *orig_id, Scheme_Object **get_names, int get_orig_name, int depth, int *_skipped)
static Module_Renamesextract_renames (Module_Renames_Set *mrns, Scheme_Object *phase)
static int nonempty_rib (Scheme_Lexical_Rib *rib)
static int in_skip_set (Scheme_Object *timestamp, Scheme_Object *skip_ribs)
static Scheme_Objectadd_skip_set (Scheme_Object *timestamp, Scheme_Object *skip_ribs)
static XFORM_NONGCING int same_skipped_ribs (Scheme_Object *a, Scheme_Object *b)
static XFORM_NONGCING
Scheme_Object
filter_cached_env (Scheme_Object *other_env, Scheme_Object *skip_ribs)
static Scheme_Objectextend_cached_env (Scheme_Object *orig, Scheme_Object *other_env, Scheme_Object *skip_ribs, int depends_on_unsealed_rib)
static void extract_lex_range (Scheme_Object *rename, Scheme_Object *a, int *_istart, int *_iend)
static Scheme_Objectresolve_env (WRAP_POS *_wraps, Scheme_Object *a, Scheme_Object *orig_phase, int w_mod, Scheme_Object **get_names, Scheme_Object *skip_ribs, int *_binding_marks_skipped, int *_depends_on_unsealed_rib, int depth, Scheme_Hash_Table *free_id_recur)
static Scheme_Objectget_module_src_name (Scheme_Object *a, Scheme_Object *orig_phase, Scheme_Hash_Table *free_id_recur)
int scheme_stx_module_eq2 (Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym)
int scheme_stx_module_eq (Scheme_Object *a, Scheme_Object *b, long phase)
Scheme_Objectscheme_stx_get_module_eq_sym (Scheme_Object *a, Scheme_Object *phase)
Scheme_Objectscheme_stx_module_name (Scheme_Hash_Table *free_id_recur, Scheme_Object **a, Scheme_Object *phase, Scheme_Object **nominal_modidx, Scheme_Object **nominal_name, Scheme_Object **mod_phase, Scheme_Object **src_phase_index, Scheme_Object **nominal_src_phase, Scheme_Object **lex_env, int *_sealed, Scheme_Object **insp)
int scheme_stx_ribs_matter (Scheme_Object *a, Scheme_Object *skip_ribs)
Scheme_Objectscheme_stx_moduleless_env (Scheme_Object *a)
int scheme_stx_env_bound_eq (Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, Scheme_Object *phase)
int scheme_stx_bound_eq (Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase)
Scheme_Objectscheme_stx_source_module (Scheme_Object *stx, int resolve)
int scheme_stx_parallel_is_used (Scheme_Object *sym, Scheme_Object *stx)
int scheme_stx_has_more_certs (Scheme_Object *id, Scheme_Object *id_certs, Scheme_Object *than_id, Scheme_Object *than_id_certs)
Scheme_Objectscheme_stx_remove_extra_marks (Scheme_Object *a, Scheme_Object *relative_to, Scheme_Object *uid)
int scheme_stx_list_length (Scheme_Object *list)
int scheme_stx_proper_list_length (Scheme_Object *list)
Scheme_Objectscheme_flatten_syntax_list (Scheme_Object *lst, int *islist)
static Scheme_Objectextract_free_id_info (Scheme_Object *id)
static int not_in_rename (Scheme_Object *constrain_to_syms, Scheme_Object *rename)
static int not_in_rib (Scheme_Object *constrain_to_syms, Scheme_Lexical_Rib *rib)
static Scheme_Objectsimplify_lex_renames (Scheme_Object *wraps, Scheme_Hash_Table *lex_cache, Scheme_Object *stx_datum)
static Scheme_Objectwraps_to_datum (Scheme_Object *stx_datum, Scheme_Object *w_in, Scheme_Marshal_Tables *mt, Scheme_Hash_Table *rns, int just_simplify)
static Scheme_Objectextract_for_common_wrap (Scheme_Object *a, int get_mark, int pair_ok)
static void lift_common_wraps (Scheme_Object *l, Scheme_Object *common_wraps, int cnt, int tail)
static Scheme_Objectrecord_certs (Scheme_Object *cert_marks, Scheme_Marshal_Tables *mt)
static Scheme_Objectsyntax_to_datum_inner (Scheme_Object *o, int with_marks, Scheme_Marshal_Tables *mt)
Scheme_Objectscheme_syntax_to_datum (Scheme_Object *stx, int with_marks, Scheme_Marshal_Tables *mt)
static Scheme_Objectunmarshal_mark (Scheme_Object *_a, Scheme_Unmarshal_Tables *ut)
static int ok_phase (Scheme_Object *o)
static int ok_phase_index (Scheme_Object *o)
static Scheme_Objectdatum_to_module_renames (Scheme_Object *a, Scheme_Hash_Table *ht, int lex_ok)
static Scheme_Objectdatum_to_wraps (Scheme_Object *w, Scheme_Unmarshal_Tables *ut)
static Scheme_Objectdatum_to_syntax_inner (Scheme_Object *o, Scheme_Unmarshal_Tables *ut, Scheme_Stx *stx_src, Scheme_Stx *stx_wraps, Scheme_Hash_Table *ht)
static Scheme_Objectgeneral_datum_to_syntax (Scheme_Object *o, Scheme_Unmarshal_Tables *ut, Scheme_Object *stx_src, Scheme_Object *stx_wraps, int can_graph, int copy_props)
Scheme_Objectscheme_datum_to_syntax (Scheme_Object *o, Scheme_Object *stx_src, Scheme_Object *stx_wraps, int can_graph, int copy_props)
Scheme_Objectscheme_unmarshal_datum_to_syntax (Scheme_Object *o, struct Scheme_Unmarshal_Tables *ut, int can_graph)
static void simplify_syntax_inner (Scheme_Object *o, Scheme_Hash_Table *rns, Scheme_Hash_Table *marks)
Scheme_Objectscheme_new_stx_simplify_cache ()
void scheme_simplify_stx (Scheme_Object *stx, Scheme_Object *cache)
static int nonneg_exact_or_false_p (Scheme_Object *o)
static int pos_exact_or_false_p (Scheme_Object *o)
Scheme_Objectscheme_checked_syntax_e (int argc, Scheme_Object **argv)
Scheme_Objectscheme_stx_property (Scheme_Object *_stx, Scheme_Object *key, Scheme_Object *val)
static Scheme_Objectdelta_introducer (int argc, struct Scheme_Object *argv[], Scheme_Object *p)
static Scheme_Objectextract_phase (const char *who, int pos, int argc, Scheme_Object **argv, Scheme_Object *delta, int use_shift)
Scheme_Objectscheme_syntax_make_transfer_intro (int argc, Scheme_Object **argv)
static Scheme_Objectdo_module_eq (const char *who, int delta, int argc, Scheme_Object **argv)
static Scheme_Objectdo_module_binding (char *name, int argc, Scheme_Object **argv, Scheme_Object *dphase)
static Scheme_Objectexplode_cert_chain (Scheme_Cert *c, Scheme_Hash_Table *ht)
static Scheme_Objectexplode_certs (Scheme_Stx *stx, Scheme_Hash_Table *ht)
static Scheme_Objectexplode_wraps (Scheme_Object *wraps, Scheme_Hash_Table *ht)
Scheme_Objectscheme_explode_syntax (Scheme_Object *stx, Scheme_Hash_Table *ht)

Variables

Scheme_Objectscheme_datum_to_syntax_proc
static Scheme_Objectsource_symbol
static Scheme_Objectshare_symbol
static Scheme_Objectorigin_symbol
static Scheme_Objectlexical_symbol
static Scheme_Objectprotected_symbol
static Scheme_Objectnominal_id_symbol
static THREAD_LOCAL Scheme_Objectnominal_ipair_cache
static THREAD_LOCAL Scheme_Objectmark_id = scheme_make_integer(0)
static THREAD_LOCAL Scheme_Objectcurrent_rib_timestamp = scheme_make_integer(0)
static Scheme_Stx_Srclocempty_srcloc
static Scheme_Objectempty_simplified
static Scheme_Hash_Tableempty_hash_table
static THREAD_LOCAL
Scheme_Hash_Table
quick_hash_table
static THREAD_LOCAL Scheme_Objectlast_phase_shift
static THREAD_LOCAL Scheme_Objectunsealed_dependencies
static THREAD_LOCAL
Scheme_Hash_Table
id_marks_ht
static THREAD_LOCAL
Scheme_Hash_Table
than_id_marks_ht
static THREAD_LOCAL
Scheme_Bucket_Table
interned_skip_ribs
static Scheme_Objectno_nested_inactive_certs
static Module_Renameskrn

Class Documentation

struct Module_Renames

Definition at line 137 of file stxobj.c.

Collaboration diagram for Module_Renames:
Class Members
Scheme_Hash_Table * free_id_renames
Scheme_Hash_Table * ht
char kind
Scheme_Hash_Table * marked_names
char needs_unmarshal
Scheme_Hash_Table * nomarshal_ht
Scheme_Object * phase
char sealed
Scheme_Object * set_identity
Scheme_Object * shared_pes
Scheme_Object so
Scheme_Object * unmarshal_info
struct Module_Renames_Set

Definition at line 168 of file stxobj.c.

Collaboration diagram for Module_Renames_Set:
Class Members
Module_Renames * et
char kind
Scheme_Hash_Table * other_phases
Module_Renames * rt
char sealed
Scheme_Object * set_identity
Scheme_Object * share_marked_names
Scheme_Object so
struct Scheme_Cert

Definition at line 177 of file stxobj.c.

Collaboration diagram for Scheme_Cert:
Class Members
int depth
Scheme_Object * insp
Scheme_Inclhash_Object iso
Scheme_Object * key
Scheme_Object * mapped
Scheme_Object * mark
Scheme_Object * modidx
struct Scheme_Cert * next
struct Scheme_Lexical_Rib

Definition at line 212 of file stxobj.c.

Collaboration diagram for Scheme_Lexical_Rib:
Class Members
struct Scheme_Lexical_Rib * next
Scheme_Object * rename
int * sealed
Scheme_Object so
Scheme_Object * timestamp
struct Wrap_Chunk

Definition at line 337 of file stxobj.c.

Collaboration diagram for Wrap_Chunk:
Class Members
Scheme_Object * a
mzshort len
Scheme_Type type
struct Wrap_Pos

Definition at line 347 of file stxobj.c.

Collaboration diagram for Wrap_Pos:
Class Members
Scheme_Object * a
int is_limb
Scheme_Object * l
int pos

Define Documentation

#define ACTIVE_CERTS (   stx)    ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CAR((stx)->certs) : (stx)->certs) : NULL))

Definition at line 206 of file stxobj.c.

#define CERT_NO_KEY (   c)    (MZ_OPT_HASH_KEY(&(c)->iso) & 0x1)

Definition at line 196 of file stxobj.c.

#define CERT_SET_NO_KEY (   c)    (MZ_OPT_HASH_KEY(&(c)->iso) |= 0x1)

Definition at line 197 of file stxobj.c.

#define CONS   scheme_make_pair

Definition at line 120 of file stxobj.c.

#define EXPLAIN (   x)    /* empty */

Definition at line 3490 of file stxobj.c.

#define EXPLAIN_R (   x)    /* empty */

Definition at line 5629 of file stxobj.c.

#define EXPLAIN_RESOLVE   0

Definition at line 3485 of file stxobj.c.

#define EXPLAIN_S (   x)    /* empty */

Definition at line 5547 of file stxobj.c.

#define EXPLAIN_SIMP   0

Definition at line 5535 of file stxobj.c.

#define FAST_STACK_SIZE   4
#define HAS_SUBSTX (   obj)    (SCHEME_PAIRP(obj) || SCHEME_VECTORP(obj) || SCHEME_BOXP(obj) || prefab_p(obj) || SCHEME_HASHTRP(obj))

Definition at line 123 of file stxobj.c.

#define ICONS   scheme_make_pair

Definition at line 121 of file stxobj.c.

#define INACTIVE_CERTS (   stx)    ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CDR((stx)->certs) : NULL) : NULL))

Definition at line 207 of file stxobj.c.

#define IS_POSMARK (   x)    (SCHEME_INTP(x) ? (SCHEME_INT_VAL(x) >= 0) : SCHEME_BIGPOS(x))

Definition at line 324 of file stxobj.c.

#define MALLOC_WRAP_CHUNK (   n)    (Wrap_Chunk *)scheme_malloc_tagged(sizeof(Wrap_Chunk) + ((n - 1) * sizeof(Scheme_Object *)))

Definition at line 343 of file stxobj.c.

#define PREEMPTIVE_CHUNK_THRESHOLD   32

Definition at line 2435 of file stxobj.c.

#define QUICK_STACK_SIZE   16

Definition at line 4062 of file stxobj.c.

#define RENAME_HT_THRESHOLD   15

Definition at line 1082 of file stxobj.c.

#define return_NULL   return NULL

Definition at line 7112 of file stxobj.c.

#define SCHEME_MARKP (   x)    (SCHEME_INTP(x) || SCHEME_BIGNUMP(x))

Definition at line 325 of file stxobj.c.

Definition at line 225 of file stxobj.c.

Definition at line 228 of file stxobj.c.

#define SCHEME_RENAME_LEN (   vec)    ((SCHEME_VEC_SIZE(vec) - 2) >> 1)

Definition at line 210 of file stxobj.c.

Definition at line 223 of file stxobj.c.

Definition at line 222 of file stxobj.c.

Definition at line 226 of file stxobj.c.

#define SCHEME_STX_IDP (   o)    (SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o)))

Definition at line 8622 of file stxobj.c.

#define STX_KEY (   stx)    MZ_OPT_HASH_KEY(&(stx)->iso)

Definition at line 135 of file stxobj.c.

#define WRAP_POS   Wrap_Pos

Definition at line 394 of file stxobj.c.

#define WRAP_POS_COPY (   w,
  w2 
)    w.l = (w2).l; w.a = (w2).a; w.is_limb= (w2).is_limb; w.pos = (w2).pos

Definition at line 402 of file stxobj.c.

#define WRAP_POS_DEC (   w)    --w.pos; if (w.pos >= 0) w.a = ((Wrap_Chunk *)SCHEME_CAR(w.l))->a[w.pos]

Definition at line 426 of file stxobj.c.

#define WRAP_POS_END_P (   w)    SCHEME_NULLP(w.l)

Definition at line 400 of file stxobj.c.

#define WRAP_POS_FIRST (   w)    w.a

Definition at line 401 of file stxobj.c.

#define WRAP_POS_INC (   w)    DO_WRAP_POS_INC(&w)

Definition at line 397 of file stxobj.c.

#define WRAP_POS_INIT (   w,
  wr 
)    w.l = wr; WRAP_POS_SET_FIRST(&w)

Definition at line 395 of file stxobj.c.

#define WRAP_POS_INIT_END (   w)    (w.l = scheme_null, w.a = NULL, w.is_limb = 0, w.pos = 0)

Definition at line 399 of file stxobj.c.

#define WRAP_POS_KEY (   w)    w.l

Definition at line 423 of file stxobj.c.

#define WRAP_POS_PLAIN_TAIL (   w)    (w.is_limb ? (w.pos ? NULL : w.l) : w.l)

Definition at line 428 of file stxobj.c.

#define WRAP_POS_REVEND_P (   w)    (w.pos < 0)

Definition at line 425 of file stxobj.c.

#define WRAP_POS_REVINIT (   w,
 
)    DO_WRAP_POS_REVINIT(&w, k)

Definition at line 424 of file stxobj.c.


Typedef Documentation


Function Documentation

static void add_all_marks ( Scheme_Object wraps,
Scheme_Hash_Table marks 
) [static]

Definition at line 3711 of file stxobj.c.

{
  WRAP_POS awl;
  Scheme_Object *acur_mark;

  WRAP_POS_INIT(awl, wraps);

  while (1) {
    /* Skip over renames and cancelled marks: */
    acur_mark = NULL;
    while (1) {
      if (WRAP_POS_END_P(awl))
       break;
      if (SCHEME_NUMBERP(WRAP_POS_FIRST(awl))) {
       if (acur_mark) {
         if (SAME_OBJ(acur_mark, WRAP_POS_FIRST(awl))) {
           acur_mark = NULL;
           WRAP_POS_INC(awl);
         } else
           break;
       } else {
         acur_mark = WRAP_POS_FIRST(awl);
         WRAP_POS_INC(awl);
       }
      } else {
       WRAP_POS_INC(awl);
      }
    }

    if (acur_mark)
      scheme_hash_set(marks, acur_mark, scheme_true);
    else
      return;
  }
}

Here is the caller graph for this function:

static Scheme_Object* add_certs ( Scheme_Object o,
Scheme_Cert certs,
Scheme_Object use_key,
int  active 
) [static]

Definition at line 2758 of file stxobj.c.

{
  Scheme_Cert *orig_certs, *cl, *now_certs, *next_certs, *check_tail;
  Scheme_Stx *stx = (Scheme_Stx *)o, *res;
  Scheme_Object *pr;
  int shortcut;

  if (!stx->certs) {
    if (!certs)
      return (Scheme_Object *)stx;

    if (use_key) {
      for (cl = certs; cl; cl = cl->next) {
       if (!SAME_OBJ(cl->key, use_key))
         break;
      }
    } else
      cl = NULL;

    if (!cl) {
      res = (Scheme_Stx *)scheme_make_stx(stx->val, 
                                     stx->srcloc,
                                     stx->props);
      res->wraps = stx->wraps;
      res->u.lazy_prefix = stx->u.lazy_prefix;
      if (active)
       res->certs = (Scheme_Object *)certs;
      else {
       pr = scheme_make_raw_pair(NULL, (Scheme_Object *)certs);
       res->certs = pr;
      }
      return (Scheme_Object *)res;
    }
  }

  if (active)
    orig_certs = ACTIVE_CERTS(stx);
  else
    orig_certs = INACTIVE_CERTS(stx);
  now_certs = orig_certs;

  shortcut = 0;
  if (now_certs && certs && !use_key && CERT_NO_KEY(certs)) {
    if (now_certs->depth < certs->depth) {
      /* We can add now_certs onto certs, instead of the other
         way around. */
      now_certs = certs;
      certs = orig_certs;
    }
  }

  check_tail = now_certs;
  if (check_tail && certs
      && (certs->depth  > (check_tail->depth >> 1))) {
    while (check_tail->depth > certs->depth) {
      check_tail = check_tail->next;
    }
  }
  
  for (; certs; certs = next_certs) {
    next_certs = certs->next;
    if (check_tail && (check_tail->depth > certs->depth))
      check_tail = check_tail->next;
    if (SAME_OBJ(certs, check_tail)) {
      /* tails match --- no need to keep checking */
      break;
    }
    if (!cert_in_chain(certs->mark, use_key, now_certs)) {
      if (!now_certs && !use_key && (shortcut || CERT_NO_KEY(certs))) {
        now_certs = certs;
        next_certs = NULL;
      } else {
        now_certs = cons_cert(certs->mark, certs->modidx, certs->insp, use_key, 
                              now_certs);
      }
    }
  }

  if (!SAME_OBJ(now_certs, orig_certs)) {
    res = (Scheme_Stx *)scheme_make_stx(stx->val, 
                                        stx->srcloc,
                                        stx->props);
    res->wraps = stx->wraps;
    res->u.lazy_prefix = stx->u.lazy_prefix;
    if (!active) {
      pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)orig_certs);
      res->certs = pr;
      if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_IMMUTABLEP(stx->certs))
        SCHEME_SET_IMMUTABLE(pr);
    } else if (stx->certs && SCHEME_RPAIRP(stx->certs)) {
      pr = scheme_make_raw_pair((Scheme_Object *)orig_certs, SCHEME_CDR(stx->certs));
      res->certs = pr;
      if (SCHEME_IMMUTABLEP(stx->certs))
        SCHEME_SET_IMMUTABLE(pr);
    } else
      res->certs = (Scheme_Object *)orig_certs;
    stx = res;

    if (!active) {
      SCHEME_CDR(stx->certs) = (Scheme_Object *)now_certs;
    } else if (stx->certs && SCHEME_RPAIRP(stx->certs))
      SCHEME_CAR(stx->certs) = (Scheme_Object *)now_certs;
    else
      stx->certs = (Scheme_Object *)now_certs;
  }

  return (Scheme_Object *)stx;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* add_skip_set ( Scheme_Object timestamp,
Scheme_Object skip_ribs 
) [static]

Definition at line 3918 of file stxobj.c.

{
  if (in_skip_set(timestamp, skip_ribs))
    return skip_ribs;
  
  if (!skip_ribs)
    skip_ribs = (Scheme_Object *)scheme_make_hash_tree(1);
  
  skip_ribs = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)skip_ribs, timestamp, scheme_true);

  {
    Scheme_Bucket *b;
    scheme_start_atomic();
    b = scheme_bucket_from_table(interned_skip_ribs, (const char *)skip_ribs);
    scheme_end_atomic_no_swap();
    if (!b->val)
      b->val = scheme_true;

    skip_ribs = (Scheme_Object *)HT_EXTRACT_WEAK(b->key);
  }

  return skip_ribs;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Cert* append_certs ( Scheme_Cert a,
Scheme_Cert b 
) [static]

Definition at line 2725 of file stxobj.c.

{
  Scheme_Cert *c;

  if (!a) return b;
  if (!b) return a;
  
  if (a->depth < b->depth) {
    c = a;
    a = b;
    b = c;
  }

  c = a;
  if (b->depth > (a->depth >> 1)) {
    /* There's a good chance that b shares a tail with a, 
       so check for that, and b is large enough relative to
       a that it's worth iterating down to b's depth in a: */
    while (c->depth > b->depth) {
      c = c->next;
    }
  }

  for (; b; b = b->next) {
    if (b == c) break;
    if (!cert_in_chain(b->mark, b->key, a))
      a = cons_cert(b->mark, b->modidx, b->insp, b->key, a);
    c = c->next;
  }

  return a;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 8763 of file stxobj.c.

{
  Scheme_Object *phase;

  if (!SCHEME_STX_IDP(argv[0]))
    scheme_wrong_type("bound-identifier=?", "identifier syntax", 0, argc, argv);
  if (!SCHEME_STX_IDP(argv[1]))
    scheme_wrong_type("bound-identifier=?", "identifier syntax", 1, argc, argv);

  phase = extract_phase("bound-identifier=?", 2, argc, argv, scheme_make_integer(0), 0);

  return (scheme_stx_bound_eq(argv[0], argv[1], phase)
         ? scheme_true
         : scheme_false);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int cert_in_chain ( Scheme_Object mark,
Scheme_Object key,
Scheme_Cert cert 
) [static]

Definition at line 2698 of file stxobj.c.

{
  Scheme_Object *hkey = key ? NULL : mark;
  Scheme_Hash_Table *ht;

  while (cert) {
    if (!(cert->depth & 0xF)) {
      make_mapped(cert);

      ht = (Scheme_Hash_Table *)SCHEME_CAR(cert->mapped);
      cert = (Scheme_Cert *)SCHEME_CDR(cert->mapped);

      if (!hkey)
       hkey = scheme_make_pair(mark, key);

      if (scheme_hash_get_atomic(ht, hkey))
       return 1;
    } else if (SAME_OBJ(cert->mark, mark)
              && SAME_OBJ(cert->key, key)) {
      return 1;
    } else
      cert = cert->next;
  }

  return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* check_floating_id ( Scheme_Object stx) [static]

Definition at line 3411 of file stxobj.c.

{
  /* If `a' has a mzMOD_RENAME_MARKED rename with no following
     mzMOD_RENAME_NORMAL using the same set tag, and if there are no
     marks after the mzMOD_RENAME_MARKED rename, then we've hit a
     corner case: an identifier that was introduced by macro expansion
     but marked so that it appears to be original. To ensure that it
     gets a generated symbol in the MOD_RENAME_MARKED table, give it a
     "floating" binding: scheme_void. This is a rare case, and it more
     likely indicates a buggy macro than anything else. */
  WRAP_POS awl;
  Scheme_Object *cur_mark = NULL, *searching_identity = NULL, *a;
  int no_mark_means_floating = 0;

  WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps);
  
  while (!WRAP_POS_END_P(awl)) {

    a = WRAP_POS_FIRST(awl);
    
    if (SCHEME_RENAMESP(a)
        || SCHEME_RENAMES_SETP(a)) {
      int kind;
      Scheme_Object *set_identity;

      if (SCHEME_RENAMESP(a)) {
        Module_Renames *mrn = (Module_Renames *)a;
        
        kind = mrn->kind;
        set_identity = mrn->set_identity;
      } else {
        Module_Renames_Set *mrns = (Module_Renames_Set *)a;

        kind = mrns->kind;
        set_identity = mrns->set_identity;
      }

      if (SAME_OBJ(set_identity, searching_identity))
        searching_identity = NULL;

      if (searching_identity)
        no_mark_means_floating = 1;

      if (kind == mzMOD_RENAME_MARKED)
        searching_identity = set_identity;
      else
        searching_identity = NULL;
        
    } else if (SCHEME_MARKP(a)) {
      if (SAME_OBJ(a, cur_mark))
        cur_mark = 0;
      else {
        if (cur_mark) {
          no_mark_means_floating = 0;
          searching_identity = NULL;
        }
        cur_mark = a;
      }
    }

    WRAP_POS_INC(awl);
  }

  if (cur_mark) {
    no_mark_means_floating = 0;
    searching_identity = NULL;
  }

  if (searching_identity || no_mark_means_floating)
    return scheme_void;

  return scheme_false;
}

Here is the caller graph for this function:

static int check_matching_marks ( Scheme_Object p,
Scheme_Object orig_id,
Scheme_Object **  marks_cache,
int  depth,
int _skipped 
) [static]

Definition at line 3749 of file stxobj.c.

{
  int l1, l2;
  Scheme_Object *m1, *m2;

  p = SCHEME_CDR(p); /* skip modidx */
  p = SCHEME_CDR(p); /* skip phase_export */
  if (SCHEME_PAIRP(p)) {
    /* has marks */
    int skip = 0;
    
    EXPLAIN(fprintf(stderr, "%d       has marks\n", depth));

    m1 = SCHEME_CAR(p);
    if (*marks_cache)
      m2 = *marks_cache;
    else {
      EXPLAIN(fprintf(stderr, "%d       extract marks\n", depth));
      m2 = scheme_stx_extract_marks(orig_id);
      *marks_cache = m2;
    }

    l1 = scheme_list_length(m1);
    l2 = scheme_list_length(m2);

    if (l2 < l1) return -1; /* no match */

    while (l2 > l1) {
      m2 = SCHEME_CDR(m2);
      l2--;
      skip++;
    }

    if (scheme_equal(m1, m2)) {
      if (_skipped ) *_skipped = skip;
      return l1; /* matches */
    } else
      return -1; /* no match */
  } else {
    if (_skipped) *_skipped = -1;
    return 0; /* match empty mark set */
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void check_not_sealed ( Module_Renames mrn) [static]

Definition at line 1415 of file stxobj.c.

{
  if (mrn->sealed >= STX_SEAL_ALL)
    scheme_signal_error("internal error: attempt to change sealed module rename");
}

Here is the caller graph for this function:

static Scheme_Cert * cons_cert ( Scheme_Object mark,
Scheme_Object modidx,
Scheme_Object insp,
Scheme_Object key,
struct Scheme_Cert next_cert 
) [static, read]

Definition at line 2603 of file stxobj.c.

{
  Scheme_Cert *cert;

  cert = MALLOC_ONE_RT(Scheme_Cert);
  cert->iso.so.type = scheme_certifications_type;
  cert->mark = mark;
  cert->modidx = modidx;
  cert->insp = insp;
  cert->key = key;
  cert->next = next_cert;
  cert->depth = (next_cert ? next_cert->depth + 1 : 1);

  if (!key && (!next_cert || CERT_NO_KEY(next_cert))) {
    CERT_SET_NO_KEY(cert);
  }

  return cert;
}

Here is the caller graph for this function:

static Scheme_Object* datum_to_module_renames ( Scheme_Object a,
Scheme_Hash_Table ht,
int  lex_ok 
) [static]

Definition at line 7122 of file stxobj.c.

{
  int count, i;
  Scheme_Object *key, *p0, *p;

  if (!SCHEME_VECTORP(a)) return_NULL;
  count = SCHEME_VEC_SIZE(a);
  if (count & 0x1) return_NULL;

  for (i = 0; i < count; i+= 2) {
    key = SCHEME_VEC_ELS(a)[i];
    p0 = SCHEME_VEC_ELS(a)[i+1];
       
    if (!SCHEME_SYMBOLP(key)) return_NULL;

    p = p0;
    if (SCHEME_PAIRP(p) && SCHEME_INTP(SCHEME_CAR(p))) {
      /* reconstruct inspector info */
      Scheme_Object *insp;
      insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
      if (!SAME_OBJ(scheme_make_integer(1), SCHEME_CAR(p))) {
        insp = CONS(scheme_make_inspector(insp), insp);
      }
      p = SCHEME_CDR(p0);
      p0 = CONS(insp, p);
    }

    if (SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)) {
      /* Ok */
    } else if (SCHEME_PAIRP(p)) {
      Scheme_Object *midx;

      midx = SCHEME_CAR(p);
      if (!SAME_TYPE(SCHEME_TYPE(midx), scheme_module_index_type))
        return_NULL;

      if (SCHEME_SYMBOLP(SCHEME_CDR(p))) {
        /* Ok */
      } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_CDR(p)), scheme_module_index_type)) {
        /* Ok */
      } else {
        Scheme_Object *ap, *bp;

        ap = SCHEME_CDR(p);
        if (!SCHEME_PAIRP(ap))
          return_NULL;

        /* mod-phase, maybe */
        if (SCHEME_INTP(SCHEME_CAR(ap))) {
          bp = SCHEME_CDR(ap);
        } else
          bp = ap;
            
        /* exportname */
        if (!SCHEME_PAIRP(bp))
          return_NULL;
        ap = SCHEME_CAR(bp);
        if (!SCHEME_SYMBOLP(ap))
          return_NULL;
            
        /* nominal_modidx_plus_phase */
        bp = SCHEME_CDR(bp);
        if (!SCHEME_PAIRP(bp))
          return_NULL;
        ap = SCHEME_CAR(bp);
        if (SAME_TYPE(SCHEME_TYPE(ap), scheme_module_index_type)) {
          /* Ok */
        } else if (SCHEME_PAIRP(ap)) {
          if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(ap)), scheme_module_index_type))
            return_NULL;
          ap = SCHEME_CDR(ap);
          /* import_phase_plus_nominal_phase */
          if (SCHEME_PAIRP(ap)) {
            if (!ok_phase_index(SCHEME_CAR(ap))) return_NULL;
            if (!ok_phase_index(SCHEME_CDR(ap))) return_NULL;
          } else if (!ok_phase_index(ap))
            return_NULL;
        } else
          return_NULL;

        /* nominal_exportname */
        ap = SCHEME_CDR(bp);
        if (!SCHEME_SYMBOLP(ap))
          return_NULL;
      }
    } else if (lex_ok) {
      Scheme_Object *ap;
      if (!SCHEME_BOXP(p))
        return_NULL;
      ap = SCHEME_BOX_VAL(p);
      if (!SCHEME_PAIRP(ap))
        return_NULL;
      if (!SCHEME_SYMBOLP(SCHEME_CAR(ap)))
        return_NULL;
      ap = SCHEME_CDR(ap);
      if (!SCHEME_SYMBOLP(ap) && !SCHEME_FALSEP(ap))
        return_NULL;
    } else
      return_NULL;
       
    scheme_hash_set(ht, key, p0);
  }

  return scheme_true;
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 8264 of file stxobj.c.

{
  Scheme_Object *src = scheme_false, *properties = NULL, *certs = NULL;
  
  if (!SCHEME_FALSEP(argv[0]) && !SCHEME_STXP(argv[0]))
    scheme_wrong_type("datum->syntax", "syntax or #f", 0, argc, argv);
  if (argc > 2) {
    int ll;

    src = argv[2];

    ll = scheme_proper_list_length(src);

    if (!SCHEME_FALSEP(src) 
       && !SCHEME_STXP(src)
       && !(SCHEME_VECTORP(src)
             && (SCHEME_VEC_SIZE(src) == 5)
            && pos_exact_or_false_p(SCHEME_VEC_ELS(src)[1])
            && nonneg_exact_or_false_p(SCHEME_VEC_ELS(src)[2])
            && pos_exact_or_false_p(SCHEME_VEC_ELS(src)[3])
            && nonneg_exact_or_false_p(SCHEME_VEC_ELS(src)[4]))
       && !((ll == 5)
            && pos_exact_or_false_p(SCHEME_CADR(src))
            && nonneg_exact_or_false_p(SCHEME_CADR(SCHEME_CDR(src)))
            && pos_exact_or_false_p(SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(src))))
            && nonneg_exact_or_false_p(SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(SCHEME_CDR(src)))))))
      scheme_wrong_type("datum->syntax", "syntax, source location vector or list, or #f", 2, argc, argv);

    if (SCHEME_VECTORP(src))
      ll = 5;

    if (argc > 3) {
      if (!SCHEME_FALSEP(argv[3])) {
       if (!SCHEME_STXP(argv[3]))
         scheme_wrong_type("datum->syntax", "syntax or #f", 3, argc, argv);
       properties = ((Scheme_Stx *)argv[3])->props;
      }
      
      if (argc > 4) {
        if (!SCHEME_FALSEP(argv[4])) {
          if (!SCHEME_STXP(argv[4]))
            scheme_wrong_type("datum->syntax", "syntax or #f", 4, argc, argv);
          certs = (Scheme_Object *)INACTIVE_CERTS((Scheme_Stx *)argv[4]);
        }
      }
    }

    if (ll == 5) {
      /* line--column--pos--span format */
      Scheme_Object *line, *col, *pos, *span;
      if (SCHEME_VECTORP(src)) {
        line = SCHEME_VEC_ELS(src)[1];
        col = SCHEME_VEC_ELS(src)[2];
        pos = SCHEME_VEC_ELS(src)[3];
        span = SCHEME_VEC_ELS(src)[4];
        src = SCHEME_VEC_ELS(src)[0];
      } else {
        line = SCHEME_CADR(src);
        col = SCHEME_CADR(SCHEME_CDR(src));
        pos = SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(src)));
        span = SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(SCHEME_CDR(src))));
        src = SCHEME_CAR(src);
      }
      
      if (SCHEME_FALSEP(line) != SCHEME_FALSEP(col))
       scheme_arg_mismatch("datum->syntax", 
                         "line and column positions must both be numbers or #f in: ", 
                         argv[2]);

      /* Too-large positions go to unknown */
      if (SCHEME_BIGNUMP(line) || SCHEME_BIGNUMP(col)) {
       line = scheme_make_integer(-1);
       col = scheme_make_integer(-1);
      }
      if (SCHEME_BIGNUMP(pos))
       pos = scheme_make_integer(-1);
      if (span && SCHEME_BIGNUMP(span))
       span = scheme_make_integer(-1);

      src = scheme_make_stx_w_offset(scheme_false,
                                 SCHEME_FALSEP(line) ? -1 : SCHEME_INT_VAL(line),
                                 SCHEME_FALSEP(col) ? -1 : (SCHEME_INT_VAL(col)+1),
                                 SCHEME_FALSEP(pos) ? -1 : SCHEME_INT_VAL(pos),
                                 SCHEME_FALSEP(span) ? -1 : SCHEME_INT_VAL(span),
                                 src,
                                 NULL);
    }
  }

  if (SCHEME_STXP(argv[1]))
    return argv[1];

  src = scheme_datum_to_syntax(argv[1], src, argv[0], 1, 0);

  if (properties) {
    ((Scheme_Stx *)src)->props = properties;
  }

  if (certs)
    src = add_certs(src, (Scheme_Cert *)certs, NULL, 0);    

  return src;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* datum_to_syntax_inner ( Scheme_Object o,
Scheme_Unmarshal_Tables ut,
Scheme_Stx stx_src,
Scheme_Stx stx_wraps,
Scheme_Hash_Table ht 
) [static]

Definition at line 7712 of file stxobj.c.

{
  Scheme_Object *result, *wraps, *cert_marks = NULL, *hashed;
  int do_not_unpack_wraps = 0;

  if (SCHEME_STXP(o))
    return o;

#ifdef DO_STACK_CHECK
  {
# include "mzstkchk.h"
    {
      Scheme_Thread *p = scheme_current_thread;
      p->ku.k.p1 = (void *)o;
      p->ku.k.p2 = (void *)stx_src;
      p->ku.k.p3 = (void *)stx_wraps;
      p->ku.k.p4 = (void *)ht;
      p->ku.k.p5 = (void *)ut;
      return scheme_handle_stack_overflow(datum_to_syntax_k);
    }
  }
#endif

  SCHEME_USE_FUEL(1);

  if (ht) {
    if (HAS_SUBSTX(o)) {
      if (scheme_hash_get(ht, o)) {
        /* Graphs disallowed */
        return_NULL;
      }

      scheme_hash_set(ht, o, scheme_true);
      hashed = o;
    } else 
      hashed = NULL;
  } else
    hashed = NULL;

  if (ut && !SCHEME_BOXP(stx_wraps)) {
    if (SCHEME_VECTORP(o)) {
      /* This one has certs */
      if (SCHEME_VEC_SIZE(o) == 2) {
       cert_marks = SCHEME_VEC_ELS(o)[1];
       o = SCHEME_VEC_ELS(o)[0];
      } else
       return_NULL;
    }
    if (!SCHEME_PAIRP(o)) 
      return_NULL;
    wraps = SCHEME_CDR(o);
    o = SCHEME_CAR(o);
  } else if (SCHEME_BOXP(stx_wraps)) {
    /* Shared wraps, to be used directly everywhere: */
    wraps = SCHEME_BOX_VAL(stx_wraps);
    do_not_unpack_wraps = 1;
  } else
    wraps = NULL;

  if (SCHEME_PAIRP(o)) {
    Scheme_Object *first = NULL, *last = NULL, *p;
    
    /* Check whether it's all conses with
       syntax inside */
    p = o;
    while (SCHEME_PAIRP(p)) {
      if (!SCHEME_STXP(SCHEME_CAR(p)))
       break;
      p = SCHEME_CDR(p);
    }
    if (SCHEME_NULLP(p) || SCHEME_STXP(p)) {
      result = o;
    } else {
      int cnt = -1;
      Scheme_Stx *sub_stx_wraps = stx_wraps;

      if (wraps && !SCHEME_BOXP(stx_wraps) && SAME_OBJ(SCHEME_CAR(o), scheme_true)) {
        /* Resolve wraps now, and then share it with
           all nested objects (as indicated by a box
           for stx_wraps). */
        wraps = datum_to_wraps(wraps, ut);
        do_not_unpack_wraps = 1;
        sub_stx_wraps = (Scheme_Stx *)scheme_box(wraps);
        o = SCHEME_CDR(o);
      } else if (wraps && !SCHEME_BOXP(stx_wraps) && SCHEME_INTP(SCHEME_CAR(o))) {
       /* First element is the number of items
          before a non-null terminal: */
       cnt = SCHEME_INT_VAL(SCHEME_CAR(o));
       o = SCHEME_CDR(o);
      }

      /* Build up a new list while converting elems */
      while (SCHEME_PAIRP(o) && cnt) {
       Scheme_Object *a;
      
       if (ht && last) {
         if (scheme_hash_get(ht, o)) {
            /* cdr is shared. Stop here and let someone else complain. */
            break;
         }
       }

       a = datum_to_syntax_inner(SCHEME_CAR(o), ut, stx_src, sub_stx_wraps, ht);
       if (!a) return_NULL;
      
       p = scheme_make_pair(a, scheme_null);
      
       if (last)
         SCHEME_CDR(last) = p;
       else
         first = p;
       last = p;
       o = SCHEME_CDR(o);

       --cnt;
      }
      if (!SCHEME_NULLP(o)) {
       o = datum_to_syntax_inner(o, ut, stx_src, sub_stx_wraps, ht);
       if (!o) return_NULL;
       SCHEME_CDR(last) = o;
      }

      result = first;
    }
  } else if (SCHEME_BOXP(o)) {
    o = datum_to_syntax_inner(SCHEME_PTR_VAL(o), ut, stx_src, stx_wraps, ht);
    if (!o) return_NULL;
    result = scheme_box(o);
    SCHEME_SET_BOX_IMMUTABLE(result);
  } else if (SCHEME_VECTORP(o)) {
    int size = SCHEME_VEC_SIZE(o), i;
    Scheme_Object *a;

    result = scheme_make_vector(size, NULL);
    
    for (i = 0; i < size; i++) {
      a = datum_to_syntax_inner(SCHEME_VEC_ELS(o)[i], ut, stx_src, stx_wraps, ht);
      if (!a) return_NULL;
      SCHEME_VEC_ELS(result)[i] = a;
    }

    SCHEME_SET_VECTOR_IMMUTABLE(result);
  } else if (SCHEME_HASHTRP(o)) {
    Scheme_Hash_Tree *ht1 = (Scheme_Hash_Tree *)o, *ht2;
    Scheme_Object *key, *val;
    int i;
    
    ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht1) & 0x3);
    
    i = scheme_hash_tree_next(ht1, -1);
    while (i != -1) {
      scheme_hash_tree_index(ht1, i, &key, &val);
      val = datum_to_syntax_inner(val, ut, stx_src, stx_wraps, ht);
      if (!val) return NULL;
      ht2 = scheme_hash_tree_set(ht2, key, val);
      i = scheme_hash_tree_next(ht1, i);
    }
    
    result = (Scheme_Object *)ht2;
  } else if (prefab_p(o)) {
    Scheme_Structure *s = (Scheme_Structure *)o;
    Scheme_Object *a;
    int size = s->stype->num_slots, i;
    
    s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s);
    for (i = 0; i < size; i++) {
      a = datum_to_syntax_inner(s->slots[i], ut, stx_src, stx_wraps, ht);
      if (!a) return NULL;
      s->slots[i] = a;
    }

    result = (Scheme_Object *)s;
  } else {
    result = o;
  }

  if (SCHEME_FALSEP((Scheme_Object *)stx_src))
    result = scheme_make_stx(result, empty_srcloc, NULL);
  else
    result = scheme_make_stx(result, stx_src->srcloc, NULL);

  if (wraps) {
    if (!do_not_unpack_wraps) {
      wraps = datum_to_wraps(wraps, ut);
      if (!wraps)
        return_NULL;
    }
    ((Scheme_Stx *)result)->wraps = wraps;
  } else if (SCHEME_FALSEP((Scheme_Object *)stx_wraps)) {
    /* wraps already nulled */
  } else {
    /* Note: no propagation will be needed for SUBSTX */
    ((Scheme_Stx *)result)->wraps = stx_wraps->wraps;
  }

  if (cert_marks) {
    /* Need to convert a list of marks to certs */
    Scheme_Object *certs;
    int bad = 0;

    if (SCHEME_PAIRP(cert_marks) 
       && (SCHEME_PAIRP(SCHEME_CAR(cert_marks))
           || SCHEME_NULLP(SCHEME_CAR(cert_marks))
            || SCHEME_FALSEP(SCHEME_CAR(cert_marks)))) {
      /* Have both active and inactive certs */
      Scheme_Object *icerts;
      if (SCHEME_FALSEP(SCHEME_CAR(cert_marks)))
        cert_marks = SCHEME_CDR(cert_marks);
      certs = cert_marks_to_certs(SCHEME_CAR(cert_marks), ut, stx_wraps, &bad);
      icerts = cert_marks_to_certs(SCHEME_CDR(cert_marks), ut, stx_wraps, &bad);
      certs = scheme_make_raw_pair(certs, icerts);
    } else {
      /* Just active certs */
      certs = cert_marks_to_certs(cert_marks, ut, stx_wraps, &bad);
    }
    if (bad)
      return_NULL;
    ((Scheme_Stx *)result)->certs = certs;
  }

  if (hashed) {
    scheme_hash_set(ht, hashed, NULL);
  }
  
  return result;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* datum_to_wraps ( Scheme_Object w,
Scheme_Unmarshal_Tables ut 
) [static]

Definition at line 7228 of file stxobj.c.

{
  Scheme_Object *a, *wraps_key, *local_key;
  int stack_size, decoded;
  Wrap_Chunk *wc;

  /* ut->rns maps numbers (table indices) to renaming tables, and negative
     numbers (negated fixnum marks) and symbols (interned marks) to marks.*/

  /* This function has to be defensive, since `w' can originate in
     untrusted .zo bytecodes. Return NULL for bad wraps. */

  if (SCHEME_INTP(w)) {
    wraps_key = w;
    w = scheme_unmarshal_wrap_get(ut, wraps_key, &decoded);
    if (decoded && (!w || !SCHEME_LISTP(w))) /* list => a wrap, as opposed to a mark, etc. */
      return_NULL;
    if (decoded)
      return w;
  } else {
    /* not shared */
    wraps_key = NULL;
  }

  stack_size = scheme_proper_list_length(w);
  if (stack_size < 1) {
    scheme_unmarshal_wrap_set(ut, wraps_key, scheme_null);
    return scheme_null;
  } else if (stack_size < 2) {
    wc = NULL;
  } else {
    wc = MALLOC_WRAP_CHUNK(stack_size);
    wc->type = scheme_wrap_chunk_type;
    wc->len = stack_size;
  }

  a = NULL;

  while (!SCHEME_NULLP(w)) {
    a = SCHEME_CAR(w);
    if (SCHEME_NUMBERP(a)) {
      /* Re-use rename table or env rename */
      local_key = a;
      a = scheme_unmarshal_wrap_get(ut, local_key, &decoded);
      if (decoded && (!a || SCHEME_LISTP(a))) /* list => a whole wrap, no good as an element */
       return_NULL;
    } else  {
      /* Not shared */
      local_key = NULL;
      decoded = 0;
    }

    if (decoded) {
      /* done */
    } else if (SCHEME_PAIRP(a) 
              && SCHEME_NULLP(SCHEME_CDR(a))
              && SCHEME_NUMBERP(SCHEME_CAR(a))) {
      /* Mark */
      a = unmarshal_mark(SCHEME_CAR(a), ut);
      if (!a) return_NULL;
    } else if (SCHEME_VECTORP(a)) {
      /* A (simplified) rename table. */
      int sz = SCHEME_VEC_SIZE(a), cnt, i, any_free_id_renames = 0;
      Scheme_Object *v;

      /* Make sure that it's a well-formed rename table. */
      if (sz < 2)
       return_NULL;
      cnt = (sz - 2) >> 1;
      for (i = 0; i < cnt; i++) {
       if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(a)[i + 2]))
         return_NULL;
        v = SCHEME_VEC_ELS(a)[i + cnt + 2];
        if (SCHEME_SYMBOLP(v)) {
          /* simple target-environment symbol */
        } else if (SCHEME_PAIRP(v)) {
          /* target-environment symbol paired with free-id=? rename info */
          any_free_id_renames = 1;
          if (!SCHEME_SYMBOLP(SCHEME_CAR(v)))
            return_NULL;
          v = SCHEME_CDR(v);
          if (SCHEME_PAIRP(v)) {
            if (!SCHEME_SYMBOLP(SCHEME_CAR(v)))
              return_NULL;
            v = SCHEME_CDR(v);
            if (!SCHEME_SYMBOLP(v) && !SCHEME_FALSEP(v))
              return_NULL;
          } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_free_id_info_type)) {
            if (!SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[0])
                || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[1])
                || !SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[2])
                || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[3])
                || !ok_phase(SCHEME_VEC_ELS(v)[4])
                || !ok_phase(SCHEME_VEC_ELS(v)[5])
                || !ok_phase(SCHEME_VEC_ELS(v)[6]))
              return_NULL;
          } else
            return_NULL;
        } else
          return_NULL;
      }

      SCHEME_VEC_ELS(a)[0] = (any_free_id_renames ? scheme_true : scheme_false);
      
      if (!SCHEME_FALSEP(SCHEME_VEC_ELS(a)[1])) {
        SCHEME_VEC_ELS(a)[1] = scheme_false;
        maybe_install_rename_hash_table(a);
      }

      /* It's ok: */
      scheme_unmarshal_wrap_set(ut, local_key, a);
    } else if (SCHEME_PAIRP(a)) {
      /* A rename table:
           - ([#t] <phase-num> <kind-num> <set-identity> [unmarshal] #(<table-elem> ...)
              . ((<sym> (<marked-list-or-mark> . <target-gensym>) ...) ...)) ; <- marked_names
       where a <table-elem> is actually two values, one of:
           - <exname> <modname>
           - <exname> (<modname> . <defname>)
      */
      Scheme_Object *mns;
      Module_Renames *mrn;
      Scheme_Object *p, *key;
      int kind;
      Scheme_Object *phase, *set_identity;
      
      if (!SCHEME_PAIRP(a)) return_NULL;
      
      /* Convert list to rename table: */
      
      if (SAME_OBJ(SCHEME_CAR(a), scheme_true)) {
        scheme_signal_error("leftover plus-kernel");
      }

      if (!SCHEME_PAIRP(a)) return_NULL;
      phase = SCHEME_CAR(a);
      if (!ok_phase(phase)) return_NULL;
      a = SCHEME_CDR(a);

      if (!SCHEME_PAIRP(a)) return_NULL;
      if (SCHEME_TRUEP(SCHEME_CAR(a)))
       kind = mzMOD_RENAME_MARKED;
      else
       kind = mzMOD_RENAME_NORMAL;
      a = SCHEME_CDR(a);

      if (!SCHEME_PAIRP(a)) return_NULL;
      set_identity = unmarshal_mark(SCHEME_CAR(a), ut); 
      if (!set_identity) return_NULL;
      a = SCHEME_CDR(a);

      mrn = (Module_Renames *)scheme_make_module_rename(phase, kind, NULL);
      mrn->set_identity = set_identity;

      if (!SCHEME_PAIRP(a)) return_NULL;
      mns = SCHEME_CDR(a);
      a = SCHEME_CAR(a);

      if (!SCHEME_VECTORP(a)) {
       /* Unmarshall info: */
       Scheme_Object *ml = a, *mli, *first = scheme_null, *last = NULL, *ai;
       while (SCHEME_PAIRP(ml)) {
          ai = SCHEME_CAR(ml);
         mli = ai;
         if (!SCHEME_PAIRP(mli)) return_NULL;

         /* A module path index: */
         p = SCHEME_CAR(mli);
         if (!(SCHEME_SYMBOLP(p)
              || SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)))
           return_NULL;
         mli = SCHEME_CDR(mli);

          if (!SCHEME_PAIRP(mli)) return_NULL;

          /* A phase/dimension index k */
          p = SCHEME_CAR(mli);
          if (!ok_phase_index(p))
            return_NULL;
          
          p = SCHEME_CDR(mli);
          if (SCHEME_PAIRP(p) && SCHEME_PAIRP(SCHEME_CAR(p))) {
            /* list of marks: */
            Scheme_Object *m_first = scheme_null, *m_last = NULL, *mp, *after_marks;

            after_marks = SCHEME_CDR(p);
            mli = SCHEME_CAR(p);

            while (SCHEME_PAIRP(mli)) {
              p = SCHEME_CAR(mli);
              p = unmarshal_mark(p, ut); 
              if (!p) return_NULL;

              mp = scheme_make_pair(p, scheme_null);
              if (m_last)
                SCHEME_CDR(m_last) = mp;
              else
                m_first = mp;
              m_last = mp;

              mli = SCHEME_CDR(mli);
            }

            /* Rebuild for unmarshaled marks: */
            ai = scheme_make_pair(SCHEME_CAR(ai),
                                  scheme_make_pair(SCHEME_CADR(ai),
                                                   scheme_make_pair(m_first, after_marks)));

            if (!SCHEME_NULLP(mli)) return_NULL;
            p = after_marks;
          }

          if (ok_phase_index(p)) {
            /* For a shared table: src-phase-index */
          } else {
            /* For a non-shared table: (list* src-phase-index exceptions prefix), after k */
            mli = p;
            if (!SCHEME_PAIRP(mli)) return_NULL;

            p = SCHEME_CAR(mli);
            if (!ok_phase_index(p))
              return_NULL;
            mli = SCHEME_CDR(mli);

            if (!SCHEME_PAIRP(mli)) return_NULL;

            /* A list of symbols: */
            p = SCHEME_CAR(mli);
            while (SCHEME_PAIRP(p)) {
              if (!SCHEME_SYMBOLP(SCHEME_CAR(p))) return_NULL;
              p = SCHEME_CDR(p);
            }
            if (!SCHEME_NULLP(p)) return_NULL;

            /* #f or a symbol: */
            p = SCHEME_CDR(mli);
            if (!SCHEME_SYMBOLP(p) && !SCHEME_FALSEP(p)) return_NULL;
          }

         ml = SCHEME_CDR(ml);

          /* rebuild, in case we converted marks */
          p = scheme_make_pair(ai, scheme_null);
          if (last)
            SCHEME_CDR(last) = p;
          else
            first = p;
          last = p;
       }
       if (!SCHEME_NULLP(ml)) return_NULL;

       mrn->unmarshal_info = first;
       if (SCHEME_PAIRP(first))
         mrn->needs_unmarshal = 1;

       if (!SCHEME_PAIRP(mns)) return_NULL;
       a = SCHEME_CAR(mns);
       mns = SCHEME_CDR(mns);
      }

      if (!datum_to_module_renames(a, mrn->ht, 0))
        return_NULL;

      /* Extract free-id=? renames, if any */
      if (SCHEME_PAIRP(mns) && SCHEME_VECTORP(SCHEME_CAR(mns))) {
        Scheme_Hash_Table *ht;
        ht = scheme_make_hash_table(SCHEME_hash_ptr);
        mrn->free_id_renames = ht;
        if (!datum_to_module_renames(SCHEME_CAR(mns), mrn->free_id_renames, 1))
          return_NULL;
        mns = SCHEME_CDR(mns);
      }

      /* Extract the mark-rename table, if any: */
      if (SCHEME_PAIRP(mns)) {
       Scheme_Hash_Table *ht;
       Scheme_Object *ll, *kkey, *kfirst, *klast, *kp;

       ht = scheme_make_hash_table(SCHEME_hash_ptr);
       for (; SCHEME_PAIRP(mns); mns = SCHEME_CDR(mns)) {
         p = SCHEME_CAR(mns);
         if (!SCHEME_PAIRP(p)) return_NULL;
         key = SCHEME_CAR(p);
         p = SCHEME_CDR(p);
         if (!SCHEME_SYMBOLP(key)) return_NULL;
         
         ll = scheme_null;

         /* Convert marks */
         for (; SCHEME_PAIRP(p); p = SCHEME_CDR(p)) {
           a = SCHEME_CAR(p);
           if (!SCHEME_PAIRP(a))  return_NULL;
           kkey = SCHEME_CDR(a);
           if (!SCHEME_SYMBOLP(kkey)) return_NULL;

           kfirst = scheme_null;
           klast = NULL;
           a = SCHEME_CAR(a);
           if (SCHEME_MARKP(a)) {
             kfirst = unmarshal_mark(a, ut);
           } else {
              Scheme_Object *bdg = NULL;

              if (SCHEME_VECTORP(a)) {
                if (SCHEME_VEC_SIZE(a) != 2) return_NULL;
                bdg = SCHEME_VEC_ELS(a)[1];
                if (!SCHEME_SYMBOLP(bdg)) return_NULL;
                a = SCHEME_VEC_ELS(a)[0];
              }

             for (; SCHEME_PAIRP(a); a = SCHEME_CDR(a)) {
              kp = CONS(unmarshal_mark(SCHEME_CAR(a), ut), scheme_null);
              if (!klast)
                kfirst = kp;
              else
                SCHEME_CDR(klast) = kp;
              klast = kp;
             }
             if (!SCHEME_NULLP(a)) {
                if (bdg && SCHEME_MARKP(a) && SCHEME_NULLP(kfirst))
                  kfirst = unmarshal_mark(a, ut);
                else
                  return_NULL;
              }

              if (bdg) {
                a = scheme_make_vector(2, NULL);
                SCHEME_VEC_ELS(a)[0] = kfirst;
                SCHEME_VEC_ELS(a)[1] = bdg;
                kfirst = a;
              }
           }

           ll = CONS(CONS(kfirst, kkey), ll);
         }
         
         scheme_hash_set(ht, key, ll);

         if (!SCHEME_NULLP(p)) return_NULL;
       }
       if (!SCHEME_NULLP(mns)) return_NULL;

       mrn->marked_names = ht;
      }

      scheme_unmarshal_wrap_set(ut, local_key, (Scheme_Object *)mrn);

      scheme_seal_module_rename((Scheme_Object *)mrn, STX_SEAL_ALL);

      a = (Scheme_Object *)mrn;
    } else if (SAME_OBJ(a, scheme_true)
               || SCHEME_FALSEP(a)) {
      /* current env rename */
      Scheme_Env *env;

      env = scheme_get_env(NULL);
      scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL);
      a = scheme_get_module_rename_from_set(env->rename_set, 
                                            (SCHEME_FALSEP(a) 
                                             ? scheme_make_integer(1) 
                                             : scheme_make_integer(0)), 
                                            1);
    } else if (SCHEME_SYMBOLP(a)) {
      /* mark barrier */
    } else if (SCHEME_BOXP(a)) {
      if (SCHEME_PAIRP(SCHEME_BOX_VAL(a))) {
        /* prune context */
        a = make_prune_context(SCHEME_BOX_VAL(a));
      } else {
        /* must be a phase shift */
        Scheme_Object *vec;
        vec = SCHEME_BOX_VAL(a);
        if (!SCHEME_VECTORP(vec)) return_NULL;
        if (SCHEME_VEC_SIZE(vec) != 4) return_NULL;
      }
    } else {
      return_NULL;
    }

    if (wc)
      wc->a[--stack_size] = a;

    w = SCHEME_CDR(w);
  }

  if (wc)
    a = (Scheme_Object *)wc;
  a = CONS(a, scheme_null);

  scheme_unmarshal_wrap_set(ut, wraps_key, a);

  return a;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* delta_introducer ( int  argc,
struct Scheme_Object argv[],
Scheme_Object p 
) [static]

Definition at line 8636 of file stxobj.c.

{
  Scheme_Object *r, *delta;

  r = argv[0];

  if (!SCHEME_STXP(r))
    scheme_wrong_type("delta-introducer", "syntax", 0, argc, argv);

  delta = SCHEME_PRIM_CLOSURE_ELS(p)[0];

  for(; !SCHEME_NULLP(delta); delta = SCHEME_CDR(delta)) {
    r = scheme_add_remove_mark(r, SCHEME_CAR(delta));
  }

  return r;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void do_append_module_rename ( Scheme_Object src,
Scheme_Object dest,
Scheme_Object old_midx,
Scheme_Object new_midx,
int  do_pes,
int  do_unm 
) [static]

Definition at line 1551 of file stxobj.c.

{
  Scheme_Hash_Table *ht, *hts, *drop_ht;
  Scheme_Object *v;
  int i, t;

  check_not_sealed((Module_Renames *)dest);

  if (do_pes) {
    if (!SCHEME_NULLP(((Module_Renames *)src)->shared_pes)) {
      Scheme_Object *first = NULL, *last = NULL, *pr, *l;
      for (l = ((Module_Renames *)src)->shared_pes; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
        pr = scheme_make_pair(SCHEME_CAR(l), scheme_null);
        if (last)
          SCHEME_CDR(last) = pr;
        else
          first = pr;
        last = pr;
      }
      SCHEME_CDR(last) = ((Module_Renames *)dest)->shared_pes;
      ((Module_Renames *)dest)->shared_pes = first;
    }
  }

  if (do_unm) {
    if (!SCHEME_NULLP(((Module_Renames *)src)->unmarshal_info)) {
      Scheme_Object *first = NULL, *last = NULL, *pr, *l;
      for (l = ((Module_Renames *)src)->unmarshal_info; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
        pr = scheme_make_pair(SCHEME_CAR(l), scheme_null);
        if (last)
          SCHEME_CDR(last) = pr;
        else
          first = pr;
        last = pr;
      }
      SCHEME_CDR(last) = ((Module_Renames *)dest)->unmarshal_info;
      ((Module_Renames *)dest)->unmarshal_info = first;

      ((Module_Renames *)dest)->needs_unmarshal = 1;
    }
  }

  for (t = 0; t < 2; t++) {
    if (!t) {
      ht = ((Module_Renames *)dest)->ht;
      hts = ((Module_Renames *)src)->ht;
      drop_ht = ((Module_Renames *)dest)->nomarshal_ht;
    } else {
      hts = ((Module_Renames *)src)->nomarshal_ht;
      if (!hts)
       break;
      ht = ((Module_Renames *)dest)->nomarshal_ht;
      if (!ht) {
       ht = scheme_make_hash_table(SCHEME_hash_ptr);
       ((Module_Renames *)dest)->nomarshal_ht = ht;
      }
      drop_ht = ((Module_Renames *)dest)->ht;
    }
  
    /* Mappings in src overwrite mappings in dest: */

    for (i = hts->size; i--; ) {
      if (hts->vals[i]) {
       v = hts->vals[i];
       if (old_midx) {
          Scheme_Object *insp = NULL;

          if (SCHEME_PAIRP(v) && is_rename_inspector_info(SCHEME_CAR(v))) {
            insp = SCHEME_CAR(v);
            v = SCHEME_CDR(v);
          } else
            insp = NULL;

         /* Shift the modidx part */
         if (SCHEME_PAIRP(v)) {
           if (SCHEME_PAIRP(SCHEME_CDR(v))) {
             /* (list* modidx [mod-phase] exportname nominal_modidx+index nominal_exportname) */
             Scheme_Object *midx1, *midx2;
             int mod_phase;
             midx1 = SCHEME_CAR(v);
             v = SCHEME_CDR(v);
             if (SCHEME_INTP(SCHEME_CAR(v))) {
              mod_phase = SCHEME_INT_VAL(SCHEME_CAR(v));
              v = SCHEME_CDR(v);
             } else
              mod_phase = 0;
             midx2 = SCHEME_CAR(SCHEME_CDR(v));
             midx1 = scheme_modidx_shift(midx1, old_midx, new_midx);
              if (SCHEME_PAIRP(midx2)) {
                midx2 = scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(midx2), old_midx, new_midx),
                                         SCHEME_CDR(midx2));
              } else {
                midx2 = scheme_modidx_shift(midx2, old_midx, new_midx);
              }
             v = CONS(SCHEME_CAR(v), CONS(midx2, SCHEME_CDR(SCHEME_CDR(v))));
             if (mod_phase)
              v = CONS(scheme_make_integer(mod_phase), v);
             v = CONS(midx1, v);
           } else if (nom_mod_p(v)) {
             /* (cons modidx nominal_modidx) */
             v = ICONS(scheme_modidx_shift(SCHEME_CAR(v), old_midx, new_midx),
                     scheme_modidx_shift(SCHEME_CDR(v), old_midx, new_midx));
           } else {
             /* (cons modidx exportname) */
             v = CONS(scheme_modidx_shift(SCHEME_CAR(v), old_midx, new_midx),
                     SCHEME_CDR(v));
           }
         } else {
           /* modidx */
           v = scheme_modidx_shift(v, old_midx, new_midx);
         }

          if (insp)
            v = CONS(insp, v);
       }
       scheme_hash_set(ht, hts->keys[i], v);
       if (drop_ht)
         scheme_hash_set(drop_ht, hts->keys[i], NULL);
      }
    }
  }

  /* Need to share marked names: */

  if (((Module_Renames *)src)->marked_names) {
    ((Module_Renames *)dest)->marked_names = ((Module_Renames *)src)->marked_names;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_module_binding ( char *  name,
int  argc,
Scheme_Object **  argv,
Scheme_Object dphase 
) [static]

Definition at line 8819 of file stxobj.c.

{
  Scheme_Object *a, *m, *nom_mod, *nom_a, *phase;
  Scheme_Object *src_phase_index, *mod_phase, *nominal_src_phase;

  a = argv[0];

  if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a))
    scheme_wrong_type(name, "identifier syntax", 0, argc, argv);

  phase = extract_phase(name, 1, argc, argv, dphase, 1);

  if (argc > 1) {
    phase = argv[1];
    if (!SCHEME_FALSEP(phase)
        && !SCHEME_INTP(phase)
        && !SCHEME_BIGNUMP(phase))
      scheme_wrong_type(name, "exact integer or #f", 1, argc, argv);
  } else {
    Scheme_Thread *p = scheme_current_thread;
    phase = scheme_make_integer(p->current_local_env
                                ? p->current_local_env->genv->phase
                                : p->current_phase_shift);
    if (SCHEME_FALSEP(dphase) || SCHEME_FALSEP(phase))
      phase = scheme_false;
    else
      phase = scheme_bin_plus(dphase, phase);
  }

  m = scheme_stx_module_name(scheme_make_hash_table(SCHEME_hash_ptr),
                             &a, 
                             phase,
                          &nom_mod, &nom_a,
                          &mod_phase,
                             &src_phase_index,
                             &nominal_src_phase,
                             NULL,
                             NULL,
                             NULL);

  if (!m)
    return scheme_false;
  else if (SAME_OBJ(m, scheme_undefined)) {
    return lexical_symbol;
  } else
    return CONS(m, CONS(a, CONS(nom_mod, 
                                CONS(nom_a, 
                                     CONS(mod_phase,
                                          CONS(src_phase_index, 
                                               CONS(nominal_src_phase,
                                                    scheme_null)))))));
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* do_module_eq ( const char *  who,
int  delta,
int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 8779 of file stxobj.c.

{
  Scheme_Object *phase;

  if (!SCHEME_STX_IDP(argv[0]))
    scheme_wrong_type(who, "identifier syntax", 0, argc, argv);
  if (!SCHEME_STX_IDP(argv[1]))
    scheme_wrong_type(who, "identifier syntax", 1, argc, argv);

  phase = extract_phase(who, 2, argc, argv, 
                        ((delta == MZ_LABEL_PHASE) 
                         ? scheme_false 
                         : scheme_make_integer(delta)),
                        0);

  return (scheme_stx_module_eq2(argv[0], argv[1], phase, NULL)
         ? scheme_true
         : scheme_false);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 370 of file stxobj.c.

{
  Scheme_Object *a;
  if (w->is_limb && (w->pos + 1 < ((Wrap_Chunk *)SCHEME_CAR(w->l))->len)) {
    a = SCHEME_CAR(w->l);
    w->pos++;
    w->a = ((Wrap_Chunk *)a)->a[w->pos];
  } else {
    w->l = SCHEME_CDR(w->l);
    if (!SCHEME_NULLP(w->l)) {
      a = SCHEME_CAR(w->l);
      if (SCHEME_TYPE(a) == scheme_wrap_chunk_type) {
       w->is_limb = 1;
       w->pos = 0;
       w->a = ((Wrap_Chunk *)a)->a[0];
      } else {
       w->is_limb = 0;
       w->a = a;
      }
    } else
      w->is_limb = 0;
  }
}
static XFORM_NONGCING void DO_WRAP_POS_REVINIT ( Wrap_Pos w,
Scheme_Object k 
) [static]

Definition at line 406 of file stxobj.c.

{
  Scheme_Object *a;
  a = SCHEME_CAR(k);
  if (SCHEME_TYPE(a) == scheme_wrap_chunk_type) {
    w->is_limb = 1;
    w->l = k;
    w->pos = ((Wrap_Chunk *)a)->len - 1;
    w->a = ((Wrap_Chunk *)a)->a[w->pos];
  } else {
    w->l = k;
    w->a = a;
    w->is_limb = 0;
    w->pos = 0;
  }
}
static Scheme_Object* explode_cert_chain ( Scheme_Cert c,
Scheme_Hash_Table ht 
) [static]

Definition at line 9011 of file stxobj.c.

{
  Scheme_Object *first = scheme_null, *last = NULL, *pr, *vec;
  Scheme_Cert *next;
  int depth = c ? c->depth : 0;

  while (c) {
    next = c->next;
    pr = scheme_hash_get(ht, (Scheme_Object *)c);
    if (!pr) {
      vec = scheme_make_vector(3, NULL);
      SCHEME_VEC_ELS(vec)[0] = c->mark;
      SCHEME_VEC_ELS(vec)[1] = (c->modidx ? c->modidx : scheme_false);
      SCHEME_VEC_ELS(vec)[2] = (c->key ? c->key : scheme_false);
      pr = scheme_make_pair(vec, scheme_null);
      scheme_hash_set(ht, (Scheme_Object *)c, pr);
    } else
      next = NULL;
    if (last)
      SCHEME_CDR(last) = pr;
    else
      first = pr;
    last = pr;
    c = next;
  }

  if (!SCHEME_NULLP(first)) {
    first = scheme_make_pair(scheme_make_integer(depth), first);
  }

  return first;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* explode_certs ( Scheme_Stx stx,
Scheme_Hash_Table ht 
) [static]

Definition at line 9044 of file stxobj.c.

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* explode_wraps ( Scheme_Object wraps,
Scheme_Hash_Table ht 
) [static]

Definition at line 9055 of file stxobj.c.

{
  Scheme_Object *key, *prev_key = NULL, *pr, *first = scheme_null, *last = NULL, *v;
  WRAP_POS awl;

  WRAP_POS_INIT(awl, wraps);

  while (!WRAP_POS_END_P(awl)) {
    key = WRAP_POS_KEY(awl);
    if (key != prev_key) {
      pr = scheme_hash_get(ht, key);
      if (pr) {
        if (last)
          SCHEME_CDR(last) = pr;
        else
          first = pr;
        break;
      } else {
        pr = scheme_make_pair(scheme_void, scheme_null);
        if (last)
          SCHEME_CDR(last) = pr;
        else
          first = pr;
        last = pr;
        pr = scheme_make_pair(scheme_false, scheme_null);
        scheme_hash_set(ht, key, pr);
      }
      prev_key = key;
    } else {
      pr = scheme_make_pair(scheme_false, scheme_null);
    }
    if (last)
      SCHEME_CDR(last) = pr;
    else
      first = pr;
    last = pr;

    v = WRAP_POS_FIRST(awl);

    if (SCHEME_RENAMESP(v)) {
      Module_Renames *mrn = (Module_Renames *)v;
      Scheme_Object *o;

      v = scheme_hash_get(ht, (Scheme_Object *)mrn);
      if (!v) {
        v = scheme_make_vector(7, NULL);
        o = scheme_intern_symbol("rename:");
        SCHEME_VEC_ELS(v)[0] = o;
        SCHEME_VEC_ELS(v)[1] = mrn->phase;
        SCHEME_VEC_ELS(v)[2] = (Scheme_Object *)mrn->ht;
        SCHEME_VEC_ELS(v)[3] = (mrn->nomarshal_ht ? (Scheme_Object *)mrn->nomarshal_ht : scheme_false);
        SCHEME_VEC_ELS(v)[4] = scheme_true; /* mrn->shared_pes; */
        SCHEME_VEC_ELS(v)[5] = (mrn->marked_names ? (Scheme_Object *)mrn->marked_names : scheme_false);
        SCHEME_VEC_ELS(v)[6] = (Scheme_Object *)mrn->unmarshal_info;
        scheme_hash_set(ht, (Scheme_Object *)mrn, v);
      }
    }

    SCHEME_CAR(pr) = v;
    
    WRAP_POS_INC(awl);
  }

  return first;
}

Here is the caller graph for this function:

static Scheme_Object* extend_cached_env ( Scheme_Object orig,
Scheme_Object other_env,
Scheme_Object skip_ribs,
int  depends_on_unsealed_rib 
) [static]

Definition at line 3977 of file stxobj.c.

{
  Scheme_Object *in_mpair = NULL;
  Scheme_Object *free_id_rename = NULL;

  if (SCHEME_PAIRP(orig)) {
    free_id_rename = SCHEME_CDR(orig);
    orig = SCHEME_CAR(orig);
  }

  if (SCHEME_MPAIRP(orig)) {
    in_mpair = orig;
    orig = SCHEME_CAR(orig);
    if (!depends_on_unsealed_rib && !orig) {
      /* no longer depends on unsealed rib: */
      in_mpair = NULL;
      orig = scheme_void;
    } else {
      /* (some) still depends on unsealed rib: */
      if (!orig) {
        /* re-register in list of dependencies */
        SCHEME_CDR(in_mpair) = unsealed_dependencies;
        unsealed_dependencies = in_mpair;
        orig = scheme_void;
      }
    }
  } else if (depends_on_unsealed_rib) {
    /* register dependency: */
    in_mpair = scheme_make_mutable_pair(NULL, unsealed_dependencies);
    unsealed_dependencies = in_mpair;
  }

  if (SCHEME_VOIDP(orig) && !skip_ribs) {
    orig = other_env;
  } else {
    if (!SCHEME_RPAIRP(orig))
      orig = scheme_make_raw_pair(scheme_make_raw_pair(NULL, orig), NULL);

    orig = scheme_make_raw_pair(scheme_make_raw_pair(skip_ribs, other_env), orig);
  }

  if (in_mpair) {
    SCHEME_CAR(in_mpair) = orig;
    orig = in_mpair;
  }

  if (free_id_rename) {
    orig = CONS(orig, free_id_rename);
  }

  return orig;
}

Here is the caller graph for this function:

static Scheme_Object* extract_for_common_wrap ( Scheme_Object a,
int  get_mark,
int  pair_ok 
) [static]

Definition at line 6760 of file stxobj.c.

{
  /* We only share wraps for things constucted with pairs and
     atomic (w.r.t. syntax) values, where there are no certificates
     on any of the sub-parts. */
  Scheme_Object *v;

  if (SCHEME_PAIRP(a)) {
    v = SCHEME_CAR(a);

    if (SCHEME_PAIRP(v)) {
      if (pair_ok && SAME_OBJ(SCHEME_CAR(v), scheme_true)) {
        /* A pair with shared wraps for its elements */
        if (get_mark)
          return SCHEME_CDR(a);
        else
          return SCHEME_CDR(v);
      }
    } else if (!SCHEME_BOXP(v) && !SCHEME_VECTORP(v)) {
      /* It's atomic. */
      if (get_mark)
        return SCHEME_CDR(a);
      else
        return v;
    }
  }

  return NULL;
}

Here is the caller graph for this function:

static Scheme_Object* extract_free_id_info ( Scheme_Object id) [static]

Definition at line 5550 of file stxobj.c.

{
  Scheme_Object *bind;
  Scheme_Object *nominal_modidx;
  Scheme_Object *nominal_name, *nom2;
  Scheme_Object *mod_phase;
  Scheme_Object *src_phase_index;
  Scheme_Object *nominal_src_phase;
  Scheme_Object *lex_env = NULL;
  Scheme_Object *vec, *phase, *insp;
  Scheme_Hash_Table *free_id_recur;

  phase = SCHEME_CDR(id);
  id = SCHEME_CAR(id);

  nom2 = scheme_stx_property(id, nominal_id_symbol, NULL);

  free_id_recur = make_recur_table();
  bind = scheme_stx_module_name(free_id_recur, 
                                &id, phase, &nominal_modidx, &nominal_name,
                                &mod_phase, &src_phase_index, &nominal_src_phase,
                                &lex_env, NULL, &insp);
  release_recur_table(free_id_recur);

  if (SCHEME_SYMBOLP(nom2))
    nominal_name = nom2;
  if (!nominal_name)
    nominal_name = SCHEME_STX_VAL(id);

  if (!bind)
    return CONS(nominal_name, scheme_false);
  else if (SAME_OBJ(bind, scheme_undefined))
    return CONS(nominal_name, lex_env);
  else {
    vec = scheme_make_vector(8, NULL);
    vec->type = scheme_free_id_info_type;
    SCHEME_VEC_ELS(vec)[0] = bind;
    SCHEME_VEC_ELS(vec)[1] = id;
    SCHEME_VEC_ELS(vec)[2] = nominal_modidx;
    SCHEME_VEC_ELS(vec)[3] = nominal_name;
    SCHEME_VEC_ELS(vec)[4] = mod_phase;
    SCHEME_VEC_ELS(vec)[5] = src_phase_index;
    SCHEME_VEC_ELS(vec)[6] = nominal_src_phase;
    SCHEME_VEC_ELS(vec)[7] = (insp ? insp : scheme_false);
    return vec;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void extract_lex_range ( Scheme_Object rename,
Scheme_Object a,
int _istart,
int _iend 
) [static]

Definition at line 4031 of file stxobj.c.

{
  int istart, iend, c;

  c = SCHEME_RENAME_LEN(rename);

  if (!SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1])) {
    void *pos;
    pos = scheme_hash_get((Scheme_Hash_Table *)(SCHEME_VEC_ELS(rename)[1]), a);
    if (pos) {
      istart = SCHEME_INT_VAL(pos);
      if (istart < 0) {
        /* -1 indicates multiple slots matching this name. */
        istart = 0;
        iend = c;
      } else
        iend = istart + 1;
    } else {
      istart = 0;
      iend = 0;
    }
  } else {
    istart = 0;
    iend = c;
  }

  *_istart = istart;
  *_iend = iend;
}

Here is the caller graph for this function:

static Scheme_Object* extract_module_free_id_binding ( Scheme_Object mrn,
Scheme_Object id,
Scheme_Object orig_id,
int _sealed,
Scheme_Hash_Table free_id_recur 
) [static]

Definition at line 2041 of file stxobj.c.

{
  Scheme_Object *result;
  Scheme_Object *modname;
  Scheme_Object *nominal_modidx;
  Scheme_Object *nominal_name, *nom2;
  Scheme_Object *mod_phase;
  Scheme_Object *src_phase_index;
  Scheme_Object *nominal_src_phase;
  Scheme_Object *lex_env;
  Scheme_Object *rename_insp;

  if (scheme_hash_get(free_id_recur, id)) {
    return id;
  }
  scheme_hash_set(free_id_recur, id, id);
  
  nom2 = scheme_stx_property(orig_id, nominal_id_symbol, NULL);

  modname = scheme_stx_module_name(free_id_recur,
                                   &orig_id, ((Module_Renames *)mrn)->phase, &nominal_modidx,
                                   &nominal_name,
                                   &mod_phase, 
                                   &src_phase_index,
                                   &nominal_src_phase,
                                   &lex_env,
                                   _sealed,
                                   &rename_insp);
 
  if (SCHEME_SYMBOLP(nom2))
    nominal_name = nom2;
  
  if (!modname)
    result = scheme_box(CONS(SCHEME_STX_VAL(orig_id), scheme_false));
  else if (SAME_OBJ(modname, scheme_undefined))
    result = scheme_box(CONS(SCHEME_STX_VAL(orig_id), lex_env));
  else
    result = scheme_extend_module_rename(mrn,
                                         modname,
                                         id,                 /* name in local context */
                                         orig_id,            /* name in definition context  */
                                         nominal_modidx,     /* nominal source module */
                                         nominal_name,       /* nominal import before local renaming */
                                         SCHEME_INT_VAL(mod_phase), /* phase of source defn */
                                         src_phase_index,    /* nominal import phase */
                                         nominal_src_phase,  /* nominal export phase */
                                         rename_insp,
                                         3);

  if (*_sealed) {
    /* cache the result */
    scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, id, result);
  }

  return result;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* extract_phase ( const char *  who,
int  pos,
int  argc,
Scheme_Object **  argv,
Scheme_Object delta,
int  use_shift 
) [static]

Definition at line 8654 of file stxobj.c.

{
  Scheme_Object *phase;

  if (argc > pos) {
    phase = argv[pos];
    if (!SCHEME_FALSEP(phase)
        && !SCHEME_INTP(phase)
        && !SCHEME_BIGNUMP(phase))
      scheme_wrong_type(who, "exact integer or #f", pos, argc, argv);
  } else {
    Scheme_Thread *p = scheme_current_thread;
    long ph;
    ph = (p->current_local_env
          ? p->current_local_env->genv->phase
          : (use_shift
             ? p->current_phase_shift
             : 0));
    phase = scheme_make_integer(ph);
    
    if (SCHEME_FALSEP(delta) || SCHEME_FALSEP(phase))
      phase = scheme_false;
    else
      phase = scheme_bin_plus(delta, phase);
  }

  return phase;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Module_Renames* extract_renames ( Module_Renames_Set mrns,
Scheme_Object phase 
) [static]

Definition at line 3882 of file stxobj.c.

{
  if (SAME_OBJ(phase, scheme_make_integer(0)))
    return mrns->rt;
  else if (SAME_OBJ(phase, scheme_make_integer(1)))
    return mrns->et;
  else if (mrns->other_phases)
    return (Module_Renames *)scheme_hash_get(mrns->other_phases, phase);
  else
    return NULL;
}

Here is the caller graph for this function:

static void fill_chain_cache ( Scheme_Object wraps) [static]

Definition at line 945 of file stxobj.c.

{
  int pos, max_depth, limit;
  Scheme_Hash_Table *ht;
  Scheme_Object *p, *id;
  WRAP_POS awl;

  ht = (Scheme_Hash_Table *)SCHEME_CAR(wraps);

  p = scheme_hash_get(ht, scheme_make_integer(5));
  if (p) {
    limit = SCHEME_INT_VAL(p);

    /* Extend the chain cache to deeper: */
    set_wraps_to_skip(ht, &awl);

    p = scheme_hash_get(ht, scheme_make_integer(2));
    pos = SCHEME_INT_VAL(p);

    scheme_hash_set(ht, scheme_make_integer(5), NULL);
  } else {
    pos = ht->size;
    ht->size = 0;

    wraps = SCHEME_CDR(wraps);

    WRAP_POS_INIT(awl, wraps);

    limit = 4;
  }

  /* Limit how much of the cache we build, in case we never
     reuse this cache: */
  max_depth = limit;

  while (!WRAP_POS_END_P(awl)) {
    if (!(max_depth--)) {
      limit *= 2;
      scheme_hash_set(ht, scheme_make_integer(5), scheme_make_integer(limit));
      break;
    }

    p = WRAP_POS_FIRST(awl);
    if (SCHEME_VECTORP(p)) {
      int i, len;
      len = SCHEME_RENAME_LEN(p);
      for (i = 0; i < len; i++) {
       id = SCHEME_VEC_ELS(p)[i+2];
       if (SCHEME_STXP(id))
         id = SCHEME_STX_VAL(id);
       scheme_hash_set(ht, id, scheme_true);
      }
    } else if (SCHEME_NUMBERP(p) || SCHEME_SYMBOLP(p)) {
      /* ok to skip */
    } else if (SCHEME_HASHTP(p)) {
      /* Hack: we store the depth of the table in the chain
        in the `size' fields, at least until the table is initialized: */
      Scheme_Hash_Table *ht2 = (Scheme_Hash_Table *)p;
      int pos2;
      if (!ht2->count)
       pos2 = ht2->size;
      else {
       p = scheme_hash_get(ht2, scheme_make_integer(2));
       pos2 = SCHEME_INT_VAL(p);
      }
      /* The theory here is the same as the `mapped' table:
        every power of two covers the whole range, etc. */
      if ((pos & pos2) == pos2)
       break;
    } else
      break;
    WRAP_POS_INC(awl);
  }

  /* Record skip destination: */
  scheme_hash_set(ht, scheme_make_integer(0), awl.l);
  if (!awl.is_limb) {
    scheme_hash_set(ht, scheme_make_integer(1), scheme_false);
  } else {
    scheme_hash_set(ht, scheme_make_integer(1), scheme_make_integer(awl.pos));
  }
  scheme_hash_set(ht, scheme_make_integer(2), scheme_make_integer(pos));
}

Here is the call graph for this function:

Here is the caller graph for this function:

static XFORM_NONGCING Scheme_Object* filter_cached_env ( Scheme_Object other_env,
Scheme_Object skip_ribs 
) [static]

Definition at line 3947 of file stxobj.c.

{
  Scheme_Object *p;

  if (SCHEME_PAIRP(other_env)) {
    /* paired with free-id=? rename */
    other_env = SCHEME_CAR(other_env);
  }

  if (SCHEME_MPAIRP(other_env)) {
    other_env = SCHEME_CAR(other_env);
    if (!other_env) 
      return scheme_void;
  }

  if (SCHEME_RPAIRP(other_env)) {
    while (other_env) {
      p = SCHEME_CAR(other_env);
      if (same_skipped_ribs(SCHEME_CAR(p), skip_ribs)) {
        return SCHEME_CDR(p);
      }
      other_env = SCHEME_CDR(other_env);
    }
    return scheme_void;
  } else if (!skip_ribs)
    return other_env;
  else
    return scheme_void;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* general_datum_to_syntax ( Scheme_Object o,
Scheme_Unmarshal_Tables ut,
Scheme_Object stx_src,
Scheme_Object stx_wraps,
int  can_graph,
int  copy_props 
) [static]

Definition at line 7943 of file stxobj.c.

{
  Scheme_Hash_Table *ht;
  Scheme_Object *v, *code = NULL;

  if (!SCHEME_FALSEP(stx_src) && !SCHEME_STXP(stx_src))
    return o;

  if (SCHEME_STXP(o))
    return o;

  if (can_graph && HAS_SUBSTX(o))
    ht = scheme_make_hash_table(SCHEME_hash_ptr);
  else
    ht = NULL;

  if (ut) {
    /* If o is just a number, look it up in the table. */
    if (SCHEME_INTP(o)) {
      int decoded;
      v = scheme_unmarshal_wrap_get(ut, o, &decoded);
      if (!decoded) {
        code = o;
        o = v;
      } else
        return v;
    }
  }

  v = datum_to_syntax_inner(o, 
                            ut,
                         (Scheme_Stx *)stx_src,
                         (Scheme_Stx *)stx_wraps,
                         ht);

  if (!v) {
    if (ut)
      return_NULL; /* happens with bad wraps from a bad .zo */
    /* otherwise, only happens with cycles: */
    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                     "datum->syntax: cannot create syntax from cyclic datum: %V",
                     o);
    return NULL;
  }

  if (code) {
    scheme_unmarshal_wrap_set(ut, code, v);
  }

  if (copy_props > 0)
    ((Scheme_Stx *)v)->props = ((Scheme_Stx *)stx_src)->props;

  if (copy_props && (copy_props != 1)) {
    if (ACTIVE_CERTS(((Scheme_Stx *)stx_src)))
      v = add_certs(v, ACTIVE_CERTS((Scheme_Stx *)stx_src), NULL, 1);
    if (INACTIVE_CERTS((Scheme_Stx *)stx_src)) {
      v = lift_inactive_certs(v, 0);
      v = add_certs(v, INACTIVE_CERTS((Scheme_Stx *)stx_src), NULL, 0);
    }
  }

  return v;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* get_module_src_name ( Scheme_Object a,
Scheme_Object orig_phase,
Scheme_Hash_Table free_id_recur 
) [static]

Definition at line 4692 of file stxobj.c.

{
  WRAP_POS wraps;
  Scheme_Object *result, *result_from;
  int is_in_module = 0, skip_other_mods = 0, sealed = STX_SEAL_ALL, floating_checked = 0;
  int no_lexical = !free_id_recur;
  Scheme_Object *phase = orig_phase;
  Scheme_Object *bdg = NULL, *floating = NULL;

  if (!free_id_recur
      && SAME_OBJ(phase, scheme_make_integer(0))
      && ((Scheme_Stx *)a)->u.modinfo_cache)
    return ((Scheme_Stx *)a)->u.modinfo_cache;

  WRAP_POS_INIT(wraps, ((Scheme_Stx *)a)->wraps);

  result = NULL;

  while (1) {
    if (WRAP_POS_END_P(wraps)) {
      int can_cache = (sealed >= STX_SEAL_ALL);

      if (result)
        can_cache = (sealed >= STX_SEAL_BOUND); /* If it becomes bound, it can't become unbound. */

      if (!result)
       result = SCHEME_STX_VAL(a);
      
      if (can_cache && SAME_OBJ(orig_phase, scheme_make_integer(0)) && !free_id_recur)
        ((Scheme_Stx *)a)->u.modinfo_cache = result;
 
      return result;
    } else if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps))
               || SCHEME_RENAMES_SETP(WRAP_POS_FIRST(wraps))) {
      Module_Renames *mrn;

      if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps))) {
        mrn = (Module_Renames *)WRAP_POS_FIRST(wraps);
      } else {
        /* Extract the relevant phase, if available */
        Module_Renames_Set *mrns = (Module_Renames_Set *)WRAP_POS_FIRST(wraps);

        if (mrns->kind != mzMOD_RENAME_TOPLEVEL)
         is_in_module = 1;
        
        if ((!is_in_module || (mrns->kind != mzMOD_RENAME_TOPLEVEL))
            && !skip_other_mods) {
          if (mrns->sealed < sealed)
            sealed = mrns->sealed;
        }

        mrn = extract_renames(mrns, phase);
      }

      if (mrn && (!is_in_module || (mrn->kind != mzMOD_RENAME_TOPLEVEL)) 
          && !skip_other_mods) {
       if (mrn->kind != mzMOD_RENAME_TOPLEVEL)
         is_in_module = 1;

       if (same_phase(phase, mrn->phase)) {
         /* Module rename: */
         Scheme_Object *rename, *glob_id;

          if (mrn->sealed < sealed)
            sealed = mrn->sealed;
          
         if (mrn->needs_unmarshal) {
           /* Use resolve_env to trigger unmarshal, so that we
              don't have to implement top/from shifts here: */
           resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL, NULL, 0, NULL);
         }

         if (mrn->marked_names) {
           /* Resolve based on rest of wraps: */
           if (!bdg)
             bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL, NULL, 0, NULL);
            if (SCHEME_FALSEP(bdg))  {
              if (!floating_checked) {
                floating = check_floating_id(a);
                floating_checked = 1;
              }
              bdg = floating;
            }
           /* Remap id based on marks and rest-of-wraps resolution: */
           glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL, NULL);

            if (SCHEME_TRUEP(bdg)
              && !SAME_OBJ(glob_id, SCHEME_STX_VAL(a))) {
             /* See "Even if this module doesn't match, the lex-renamed id" in resolve_env() */
             no_lexical = 1;
           }
         } else
           glob_id = SCHEME_STX_VAL(a);

          if (free_id_recur && mrn->free_id_renames) {
            rename = scheme_hash_get(mrn->free_id_renames, glob_id);
            if (rename && SCHEME_STXP(rename)) {
              int sealed;
              rename = extract_module_free_id_binding((Scheme_Object *)mrn,
                                                      glob_id, 
                                                      rename,
                                                      &sealed,
                                                      free_id_recur);
              if (!sealed)
                sealed = 0;
            }
          } else
            rename = NULL;
          if (!rename)
            rename = scheme_hash_get(mrn->ht, glob_id);
         if (!rename && mrn->nomarshal_ht)
           rename = scheme_hash_get(mrn->nomarshal_ht, glob_id);

          if (!rename)
            result = search_shared_pes(mrn->shared_pes, glob_id, a, NULL, 1, 0, NULL);
         else {
           /* match; set result: */
           if (mrn->kind == mzMOD_RENAME_MARKED)
             skip_other_mods = 1;
            if (SCHEME_BOXP(rename)) {
              /* only happens with free_id_renames */
              rename = SCHEME_BOX_VAL(rename);
              result = SCHEME_CAR(rename);
            } else if (SCHEME_PAIRP(rename)) {
             if (nom_mod_p(rename)) {
              result = glob_id;
             } else {
              result = SCHEME_CDR(rename);
              if (SCHEME_PAIRP(result))
                result = SCHEME_CAR(result);
             }
           } else
             result = glob_id;
         }

          result_from = WRAP_POS_FIRST(wraps);
       }
      }
    } else if (SCHEME_BOXP(WRAP_POS_FIRST(wraps))) {
      /* Phase shift */
      Scheme_Object *n, *vec;
      vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(wraps));
      n = SCHEME_VEC_ELS(vec)[0];
      if (SCHEME_TRUEP(phase))
        phase = scheme_bin_minus(phase, n);
    } else if (!no_lexical
               && (SCHEME_VECTORP(WRAP_POS_FIRST(wraps))
                   || SCHEME_RIBP(WRAP_POS_FIRST(wraps)))) {
      /* Lexical rename */
      Scheme_Object *rename, *renamed, *renames;
      Scheme_Lexical_Rib *rib;
      int ri, istart, iend;

      rename = WRAP_POS_FIRST(wraps);
      if (SCHEME_RIBP(rename)) {
        rib = ((Scheme_Lexical_Rib *)rename)->next;
        rename = NULL;
      } else {
        rib = NULL;
        if (SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[0])) {
          /* No free-id=? renames here. */
          rename = NULL;
        }
      }

      do {
        if (rib) {
          if (!*rib->sealed) sealed = 0;
          rename = rib->rename;
          rib = rib->next;
        }

        if (rename) {
          int c = SCHEME_RENAME_LEN(rename);

          /* Get index from hash table, if there is one: */
          if (!SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1])) {
            void *pos;
            pos = scheme_hash_get((Scheme_Hash_Table *)(SCHEME_VEC_ELS(rename)[1]), SCHEME_STX_VAL(a));
            if (pos) {
              istart = SCHEME_INT_VAL(pos);
              if (istart < 0) {
                /* -1 indicates multiple slots matching this name. */
                istart = 0;
                iend = c;
              } else
                iend = istart + 1;
            } else {
              istart = 0;
              iend = 0;
            }
          } else {
            istart = 0;
            iend = c;
          }

          for (ri = istart; ri < iend; ri++) {
            renamed = SCHEME_VEC_ELS(rename)[2+ri];
            if (SAME_OBJ(SCHEME_STX_VAL(a), SCHEME_STX_SYM(renamed))) {
              /* Check for free-id mapping: */
              renames = SCHEME_VEC_ELS(rename)[2 + ri + c];
              if (SCHEME_PAIRP(renames)) {
                /* Has a relevant-looking free-id mapping. 
                   Give up on the "fast" traversal. */
                Scheme_Object *modname, *names[7];
                int rib_dep;

                names[0] = NULL;
                names[1] = NULL;
                names[3] = scheme_make_integer(0);
                names[4] = NULL;
                names[5] = NULL;
                names[6] = NULL;

                modname = resolve_env(NULL, a, orig_phase, 1, names, NULL, NULL, &rib_dep, 0, free_id_recur);
                if (rib_dep)
                  sealed = 0;

                if (!SCHEME_FALSEP(modname)
                    && !SAME_OBJ(names[0], scheme_undefined)) {
                  result = names[0];
                } else {
                  result = names[1]; /* can be NULL or alternate name */
                }
                
                WRAP_POS_INIT_END(wraps);
                rib = NULL;
                break;
              }
            }
          }
        }
      } while (rib);
    } else if (SCHEME_PRUNEP(WRAP_POS_FIRST(wraps))) {
      if (!is_member(SCHEME_STX_VAL(a), SCHEME_BOX_VAL(WRAP_POS_FIRST(wraps)))) {
        /* Doesn't match pruned-to sym, so no binding */
        return SCHEME_STX_VAL(a);
      }
    }
    
    /* Keep looking: */
    if (!WRAP_POS_END_P(wraps))
      WRAP_POS_INC(wraps);
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 8892 of file stxobj.c.

{
  Scheme_Object *a = argv[0], *p, *l;

  if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a))
    scheme_wrong_type("identifier-prune-lexical-context", "identifier syntax", 0, argc, argv);

  if (argc > 1) {
    l = argv[1];
    while (SCHEME_PAIRP(l)) {
      if (!SCHEME_SYMBOLP(SCHEME_CAR(l)))
        break;
      l = SCHEME_CDR(l);
    }
    if (!SCHEME_NULLP(l))
      scheme_wrong_type("identifier-prune-lexical-context", "list of symbols", 1, argc, argv);
    l = argv[1];
  } else {
    l = scheme_make_pair(SCHEME_STX_VAL(a), scheme_null);
  }

  p = make_prune_context(l);

  return scheme_add_rename(a, p);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int in_skip_set ( Scheme_Object timestamp,
Scheme_Object skip_ribs 
) [static]

Definition at line 3907 of file stxobj.c.

{
  if (!skip_ribs)
    return 0;
  
  if (scheme_hash_tree_get((Scheme_Hash_Tree *)skip_ribs, timestamp))
    return 1;
  
  return 0;
}

Here is the caller graph for this function:

static int includes_mark ( Scheme_Object wraps,
Scheme_Object mark 
) [static]

Definition at line 3670 of file stxobj.c.

{
  WRAP_POS awl;
  Scheme_Object *acur_mark;

  WRAP_POS_INIT(awl, wraps);

  while (1) {
    /* Skip over renames and cancelled marks: */
    acur_mark = NULL;
    while (1) {
      if (WRAP_POS_END_P(awl))
       break;
      if (SCHEME_NUMBERP(WRAP_POS_FIRST(awl))) {
       if (acur_mark) {
         if (SAME_OBJ(acur_mark, WRAP_POS_FIRST(awl))) {
           acur_mark = NULL;
           WRAP_POS_INC(awl);
         } else
           break;
       } else {
         acur_mark = WRAP_POS_FIRST(awl);
         WRAP_POS_INC(awl);
       }
      } else {
       WRAP_POS_INC(awl);
      }
    }

    /* Same mark? */
    if (SAME_OBJ(acur_mark, mark))
      return 1;

    if (WRAP_POS_END_P(awl))
      return 0;
  }
}

Here is the caller graph for this function:

static int is_in_rib_delim ( Scheme_Object envname,
Scheme_Object rib_delim 
) [static]

Definition at line 2006 of file stxobj.c.

{
  Scheme_Object *l = SCHEME_BOX_VAL(rib_delim);
  Scheme_Lexical_Rib *rib;

  while (!SCHEME_NULLP(l)) {
    rib = (Scheme_Lexical_Rib *)SCHEME_CAR(l);
    while (rib) {
      if (rib->rename && SAME_OBJ(envname, SCHEME_VEC_ELS(rib->rename)[0]))
        return 1;
      rib = rib->next;
    }
    l = SCHEME_CDR(l);
  }
  return 0;
}

Here is the caller graph for this function:

static XFORM_NONGCING int is_member ( Scheme_Object a,
Scheme_Object l 
) [static]

Definition at line 230 of file stxobj.c.

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

Here is the caller graph for this function:

static int is_rename_inspector_info ( Scheme_Object v) [static]

Definition at line 240 of file stxobj.c.

Here is the caller graph for this function:

static void lift_common_wraps ( Scheme_Object l,
Scheme_Object common_wraps,
int  cnt,
int  tail 
) [static]

Definition at line 6790 of file stxobj.c.

{
  Scheme_Object *a;

  while (cnt--) {
    a = SCHEME_CAR(l);
    a = extract_for_common_wrap(a, 0, 1);
    SCHEME_CAR(l) = a;
    if (cnt)
      l = SCHEME_CDR(l);
  }
  if (tail) {
    a = SCHEME_CDR(l);
    a = extract_for_common_wrap(a, 0, 0);
    SCHEME_CDR(l) = a;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * lift_inactive_certs ( Scheme_Object o,
int  as_active 
) [static]

Definition at line 3365 of file stxobj.c.

{
  Scheme_Cert *certs = NULL;

  o = stx_activate_certs(o, &certs);
  /* the inactive certs collected into `certs'
     have been stripped from `o' at this point */

  if (certs)
    o = add_certs(o, certs, NULL, as_active);

  return o;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* make_chunk ( int  len,
Scheme_Object owner_wraps 
) [static]

Definition at line 2333 of file stxobj.c.

{
  Wrap_Chunk *wc;
  Scheme_Object *l, *a, *max_chunk_start_list = NULL, *ml;
  int i, count = 0, j, max_chunk_size = 0, max_chunk_start_pos = 0;

  if (len > 1) {
    for (i = 0, l = owner_wraps; i < len; i++, l = SCHEME_CDR(l)) {
      a = SCHEME_CAR(l);
      if (SAME_TYPE(SCHEME_TYPE(a), scheme_wrap_chunk_type)) {
       j = ((Wrap_Chunk *)a)->len;
       if (j > max_chunk_size) {
         max_chunk_start_list = l;
         max_chunk_start_pos = i;
         max_chunk_size = j;
       }
       count += j;
      } else if (SCHEME_NUMBERP(a)) {
       if ((i >= len-1) || !SAME_OBJ(a, SCHEME_CADR(l)))
         count++;
       else {
         /* Skip canceling marks */
         i++;
         l = SCHEME_CDR(l);
       }
      } else if (SCHEME_HASHTP(a)) {
       /* Don't propagate chain-specific table */
      } else
       count++;
    }

    if ((max_chunk_size > 8) && ((max_chunk_size * 2) > count)) {
      /* It's not worth copying a big existing chunk into
        a new chunk. First copy over the part before new chunk,
        then the new chunk, and finally the rest. */
      Scheme_Object *ml2;
      if (max_chunk_start_pos) {
       ml = make_chunk(max_chunk_start_pos, owner_wraps);
       if (!SCHEME_PAIRP(ml) && !SCHEME_NULLP(ml))
         ml = scheme_make_pair(ml, scheme_null);
      } else
       ml = scheme_null;
      ml = scheme_make_pair(SCHEME_CAR(max_chunk_start_list), ml);
      if (max_chunk_start_pos + 1 < len) {
       ml2 = make_chunk(len - 1 - max_chunk_start_pos, 
                      SCHEME_CDR(max_chunk_start_list));
       if (!SCHEME_NULLP(ml2)) {
         if (SCHEME_PAIRP(ml2))
           ml = scheme_append(ml2, ml);
         else
           ml = scheme_make_pair(ml2, ml);
       }
      }
    } else {
      if (!count) {
       ml = scheme_null; /* everything disappeared! */
      } else {
       wc = MALLOC_WRAP_CHUNK(count);
       wc->type = scheme_wrap_chunk_type;
       wc->len = count;
       
       ml = NULL; /* to make compiler happy */

       j = 0;
       for (i = 0, l = owner_wraps; i < len; i++, l = SCHEME_CDR(l)) {
         a = SCHEME_CAR(l);
         if (SAME_TYPE(SCHEME_TYPE(a), scheme_wrap_chunk_type)) {
           int k, cl = ((Wrap_Chunk *)a)->len;
           for (k = 0; k < cl; k++) {
             wc->a[j++] = ((Wrap_Chunk *)a)->a[k];
           }
         }  else if (SCHEME_NUMBERP(a)) {
           if ((i >= len-1) || !SAME_OBJ(a, SCHEME_CADR(l)))
             wc->a[j++] = a;
           else {
             /* Skip canceling marks */
             i++;
             l= SCHEME_CDR(l);
           }
         } else if (SCHEME_HASHTP(a)) {
           /* Skip chain-specific table */
         } else
           wc->a[j++] = a;
       }

       if (count == 1) /* in case mark removal left only one */
         ml = wc->a[0];
       else
         ml = (Scheme_Object *)wc;
      }
    }
  } else {
    ml = SCHEME_CAR(owner_wraps);
    if (SCHEME_HASHTP(ml))
      return scheme_null;
  }

  return ml;
}

Here is the caller graph for this function:

static void make_mapped ( Scheme_Cert cert) [static]

Definition at line 2640 of file stxobj.c.

{
  Scheme_Cert *stop, *c2;
  Scheme_Object *pr;
  Scheme_Hash_Table *ht;

  if (cert->mapped)
    return;

#ifdef DO_STACK_CHECK
  {
# include "mzstkchk.h"
    {
      Scheme_Thread *p = scheme_current_thread;
      p->ku.k.p1 = (void *)cert;
      scheme_handle_stack_overflow(make_mapped_k);
      return;
    }
  }
#endif
  SCHEME_USE_FUEL(1);

  if (cert->depth == 16) {
    stop = NULL;
  } else {
    for (stop = cert->next; 
        stop && ((stop->depth & cert->depth) != stop->depth); 
        stop = stop->next) {
    }
    if (stop)
      make_mapped(stop);
  }

  /* Check whether an `eq?' table will work: */
  for (c2 = cert; c2 != stop; c2 = c2->next) {
    if (c2->key)
      break;
    if (!SCHEME_INTP(c2->mark))
      break;
  }

  if (c2 == stop)
    ht = scheme_make_hash_table(SCHEME_hash_ptr);
  else
    ht = scheme_make_hash_table_equal();

  pr = scheme_make_raw_pair((Scheme_Object *)ht, (Scheme_Object *)stop);
  cert->mapped = pr;

  for (; cert != stop; cert = cert->next) {
    if (cert->key)
      pr = scheme_make_pair(cert->mark, cert->key);
    else
      pr = cert->mark;
    scheme_hash_set_atomic(ht, pr, scheme_true);
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* make_prune_context ( Scheme_Object a) [static]

Definition at line 1246 of file stxobj.c.

Here is the caller graph for this function:

static Scheme_Hash_Table* make_recur_table ( ) [static]

Definition at line 2023 of file stxobj.c.

Here is the caller graph for this function:

static int maybe_add_chain_cache ( Scheme_Stx stx) [static]

Definition at line 874 of file stxobj.c.

{
  WRAP_POS awl;
  Scheme_Object *p;
  int skipable = 0, pos = 1;

  WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps);

  while (!WRAP_POS_END_P(awl)) {
    /* Skip over renames, cancelled marks, and negative marks: */
    p = WRAP_POS_FIRST(awl);
    if (SCHEME_VECTORP(p)) {
      skipable++;
    } else if (SCHEME_NUMBERP(p) || SCHEME_SYMBOLP(p)) {
      /* ok to skip, but don<'t count toward needing a cache */
    } else if (SCHEME_HASHTP(p)) {
      /* Hack: we store the depth of the table in the chain
        in the `size' fields, at least until the table is initialized: */
      Scheme_Hash_Table *ht2 = (Scheme_Hash_Table *)p;
      if (!ht2->count)
       pos = ht2->size;
      else {
       p = scheme_hash_get(ht2, scheme_make_integer(2));
       pos = SCHEME_INT_VAL(p);
      }
      pos++;
      break;
    } else
      break;
    WRAP_POS_INC(awl);
  }

  if (skipable >= 32) {
    /* Insert a cache placeholder. We'll fill it if
       it's ever used in resolve_env(). */
    Scheme_Hash_Table *ht;

    ht = scheme_make_hash_table(SCHEME_hash_ptr);

    ht->size = pos;

    p = scheme_make_pair((Scheme_Object *)ht, stx->wraps);
    stx->wraps = p;
    
    if (STX_KEY(stx) & STX_SUBSTX_FLAG)
      stx->u.lazy_prefix++;

    return 1;
  }

  return 0;
}

Here is the caller graph for this function:

Definition at line 1105 of file stxobj.c.

{
  if (SCHEME_VEC_SIZE(v) > ((2 * RENAME_HT_THRESHOLD) + 2)) {
    Scheme_Hash_Table *ht;
    int i;

    ht = scheme_make_hash_table(SCHEME_hash_ptr);
    MZ_OPT_HASH_KEY(&(ht->iso)) |= 0x1;
    for (i = (SCHEME_VEC_SIZE(v) - 2) >> 1; i--; ) {
      scheme_hash_set(ht, SCHEME_VEC_ELS(v)[i + 2], scheme_make_integer(i));
    }
    SCHEME_VEC_ELS(v)[1] = (Scheme_Object *)ht;
  }
}

Here is the caller graph for this function:

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

Definition at line 8872 of file stxobj.c.

{
  return do_module_binding("identifier-binding", argc, argv, scheme_make_integer(0));
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 8799 of file stxobj.c.

{
  return do_module_eq("free-identifier=?", 0, argc, argv);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 8887 of file stxobj.c.

{
  return do_module_binding("identifier-label-binding", argc, argv, scheme_false);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 8814 of file stxobj.c.

{
  return do_module_eq("free-label-identifier=?", MZ_LABEL_PHASE, argc, argv);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 8882 of file stxobj.c.

{
  return do_module_binding("identifier-template-binding", argc, argv, scheme_make_integer(-1));
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 8809 of file stxobj.c.

{
  return do_module_eq("free-template-identifier=?", -1, argc, argv);
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 8877 of file stxobj.c.

{
  return do_module_binding("identifier-transformer-binding", argc, argv, scheme_make_integer(1));
}

Here is the call graph for this function:

Here is the caller graph for this function:

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

Definition at line 8804 of file stxobj.c.

{
  return do_module_eq("free-transformer-identifier=?", 1, argc, argv);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* negate_mark ( Scheme_Object n) [static]

Definition at line 1037 of file stxobj.c.

Here is the call graph for this function:

Here is the caller graph for this function:

static XFORM_NONGCING int nom_mod_p ( Scheme_Object p) [static]

Definition at line 327 of file stxobj.c.

{
  p = SCHEME_CDR(p);
  return !SCHEME_PAIRP(p) && !SCHEME_SYMBOLP(p);
}

Here is the caller graph for this function:

static int nonempty_rib ( Scheme_Lexical_Rib rib) [static]

Definition at line 3894 of file stxobj.c.

{
  rib = rib->next;

  while (rib) {
    if (SCHEME_RENAME_LEN(rib->rename))
      return 1;
    rib = rib->next;
  }

  return 0;
}

Here is the caller graph for this function:

static int nonneg_exact_or_false_p ( Scheme_Object o) [static]

Definition at line 8252 of file stxobj.c.

{
  return SCHEME_FALSEP(o) || scheme_nonneg_exact_p(o);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int not_in_rename ( Scheme_Object constrain_to_syms,
Scheme_Object rename 
) [static]

Definition at line 5598 of file stxobj.c.

{
  int istart, iend, ri;
  Scheme_Object *renamed, *s;

  while (SCHEME_PAIRP(constrain_to_syms)) {
  
    s = SCHEME_CAR(constrain_to_syms);
    extract_lex_range(rename, s, &istart, &iend);
    
    for (ri = istart; ri < iend; ri++) {
      renamed = SCHEME_VEC_ELS(rename)[2+ri];
      if (SAME_OBJ(renamed, s))
        return 0;
    }

    constrain_to_syms = SCHEME_CDR(constrain_to_syms);
  }
  
  return 1;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int not_in_rib ( Scheme_Object constrain_to_syms,
Scheme_Lexical_Rib rib 
) [static]

Definition at line 5620 of file stxobj.c.

{
  for (rib = rib->next; rib; rib = rib->next) {
    if (!not_in_rename(constrain_to_syms, rib->rename))
      return 0;
  }
  return 1;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int ok_phase ( Scheme_Object o) [static]

Definition at line 7115 of file stxobj.c.

                                      {
  return (SCHEME_INTP(o) || SCHEME_BIGNUMP(o) || SCHEME_FALSEP(o));
}

Here is the caller graph for this function:

static int ok_phase_index ( Scheme_Object o) [static]

Definition at line 7118 of file stxobj.c.

                                            {
  return ok_phase(o);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void phase_shift_certs ( Scheme_Object o,
Scheme_Object owner_wraps,
int  len 
) [static]

Definition at line 2244 of file stxobj.c.

{
  Scheme_Object *l, *a, *modidx_shift_to = NULL, *modidx_shift_from = NULL, *vec, *src, *dest;
  int i, j, cnt;

  for (i = 0, l = owner_wraps; i < len; i++, l = SCHEME_CDR(l)) {
    a = SCHEME_CAR(l);
    if (SAME_TYPE(SCHEME_TYPE(a), scheme_wrap_chunk_type)) {
      cnt = ((Wrap_Chunk *)a)->len;
      for (j = 0; j < cnt; j++) {
       if (SCHEME_BOXP(((Wrap_Chunk *)a)->a[j])) {
         vec = SCHEME_BOX_VAL(((Wrap_Chunk *)a)->a[j]);
         src = SCHEME_VEC_ELS(vec)[1];
         dest = SCHEME_VEC_ELS(vec)[2];
         if (!modidx_shift_to) {
           modidx_shift_to = dest;
         } else if (!SAME_OBJ(modidx_shift_from, dest)) {
           modidx_shift_to = scheme_modidx_shift(dest,
                                            modidx_shift_from,
                                            modidx_shift_to);
         }
         modidx_shift_from = src;
       }
      }
    } else if (SCHEME_BOXP(a)) {
      vec = SCHEME_BOX_VAL(a);
      src = SCHEME_VEC_ELS(vec)[1];
      dest = SCHEME_VEC_ELS(vec)[2];
      if (!modidx_shift_to) {
       modidx_shift_to = dest;
      } else if (!SAME_OBJ(modidx_shift_from, dest)) {
       modidx_shift_to = scheme_modidx_shift(dest,
                                         modidx_shift_from,
                                         modidx_shift_to);
      }
      modidx_shift_from = src;
    }
  }

  if (modidx_shift_from) {
    Scheme_Cert *certs, *acerts, *icerts, *first = NULL, *last = NULL, *c;
    Scheme_Object *nc;
    int i;

    acerts = ACTIVE_CERTS(((Scheme_Stx *)o));
    icerts = INACTIVE_CERTS(((Scheme_Stx *)o));
    
    /* Clone certs list, phase-shifting each cert */
    for (i = 0; i < 2; i++) {
      certs = (i ? acerts : icerts);
      first = last = NULL;
      while (certs) {
       a = scheme_modidx_shift(certs->modidx, modidx_shift_from, modidx_shift_to);
       c = cons_cert(certs->mark, a, certs->insp, certs->key, NULL);
       c->mapped = certs->mapped;
       c->depth = certs->depth;
       if (first)
         last->next = c;
       else
         first = c;
       last = c;
       certs = certs->next;
      }
      if (i)
       acerts = first;
      else
       icerts = first;
    }

    /* Even if icerts is NULL, may preserve the pair in ->certs, 
       to indicate no nested inactive certs: */
    {
      int no_sub = (SCHEME_RPAIRP(((Scheme_Stx *)o)->certs)
                    && SCHEME_IMMUTABLEP(((Scheme_Stx *)o)->certs));
      if (icerts || no_sub) {
        nc = scheme_make_raw_pair((Scheme_Object *)acerts, (Scheme_Object *)icerts);
        if (no_sub)
          SCHEME_SET_IMMUTABLE(nc);
      } else
        nc = (Scheme_Object *)acerts;
      
      ((Scheme_Stx *)o)->certs = nc;
    }
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* phase_to_index ( Scheme_Object phase) [static]

Definition at line 1421 of file stxobj.c.

{
  return phase;
}

Here is the caller graph for this function:

static int pos_exact_or_false_p ( Scheme_Object o) [static]

Definition at line 8257 of file stxobj.c.

{
  return (SCHEME_FALSEP(o)
         || (SCHEME_INTP(o) && (SCHEME_INT_VAL(o) > 0))
         || (SCHEME_BIGNUMP(o) && SCHEME_BIGPOS(o)));
}

Here is the caller graph for this function:

static void preemptive_chunk ( Scheme_Stx stx) [static]

Definition at line 2437 of file stxobj.c.

{
  int wl_count;
  int new_count;
  Scheme_Object *here_wraps, *ml;

  /* If the lazy prefix is long, transform it into a chunk. Probably,
     some syntax object derived from this one will be unpacked, and
     then the lazy prefix will need to be pushed down.

     This chunking fights somewhat with the chain-cache heuristic,
     since a chain cache can't be included in a chunk. Still, the
     combination seems to work better than either alone for deeply
     nested scopes.

     It might also interact badly with simplication or marshaling,
     since it decreases chain sharing. This is seems unlikely to
     matter, since deeply nested syntax information will be expensive
     in any case, and nodes in the wraps are still shared. */

  wl_count = stx->u.lazy_prefix;

  if (wl_count > PREEMPTIVE_CHUNK_THRESHOLD) {
    /* Chunk it */
    here_wraps = stx->wraps;

    ml = make_chunk(wl_count, here_wraps);
    
    if (SCHEME_PAIRP(ml) || SCHEME_NULLP(ml)) {
      new_count = scheme_list_length(ml);
      if (new_count == 1)
       ml = SCHEME_CAR(ml);
    } else {
      new_count = 1;
    }

    while (wl_count--) {
      here_wraps = SCHEME_CDR(here_wraps);
    }
    wl_count = new_count;

    if (new_count == 1)
      here_wraps = scheme_make_pair(ml, here_wraps);
    else {
      while (new_count--) {
       here_wraps = scheme_make_pair(SCHEME_CAR(ml), here_wraps);
       ml = SCHEME_CDR(ml);
      }
    }

    stx->wraps = here_wraps;
    stx->u.lazy_prefix = wl_count;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static XFORM_NONGCING int prefab_p ( Scheme_Object o) [static]

Definition at line 125 of file stxobj.c.

{
  if (SCHEME_STRUCTP(o)) {
    if (((Scheme_Structure *)o)->stype->prefab_key)
      if (MZ_OPT_HASH_KEY(&((Scheme_Structure *)o)->stype->iso) & STRUCT_TYPE_ALL_IMMUTABLE)
        return 1;
  }
  return 0;
}

Here is the caller graph for this function:

static Scheme_Object* propagate_wraps ( Scheme_Object o,
int  len,
Scheme_Object **  _ml,
Scheme_Object owner_wraps 
) [static]

Definition at line 2492 of file stxobj.c.

{
  int i;
  Scheme_Object *ml, *a;

  /* Would adding the wraps generate a list equivalent to owner_wraps?
     If so, use owner_wraps directly. But if len is too big, then it
     takes too long to check, and so it's better to start chunking. */
  if (len < 128) {
    Scheme_Stx *stx = (Scheme_Stx *)o;
    Scheme_Object *p1 = owner_wraps;
    Scheme_Object *certs;

    /* Find list after |wl| items in owner_wraps: */
    for (i = 0; i < len; i++) {
      p1 = SCHEME_CDR(p1);
    }
    /* p1 is the list after wl... */
    
    if (SAME_OBJ(stx->wraps, p1)) {
      /* So, we can use owner_wraps directly instead of building
        new wraps. */
      long lp;

      if (STX_KEY(stx) & STX_SUBSTX_FLAG)
       lp = stx->u.lazy_prefix + len;
      else
       lp = 0;

      certs = stx->certs;
      stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props);
      stx->wraps = owner_wraps;
      stx->u.lazy_prefix = lp; /* same as zeroing cache if no SUBSTX */
      stx->certs = certs;

      if (stx->certs)
       phase_shift_certs((Scheme_Object *)stx, owner_wraps, len);

      return (Scheme_Object *)stx;
    }
  }

  ml = *_ml;
  if (!ml) {
    ml = make_chunk(len, owner_wraps);
    *_ml = ml;
  }

  if (SCHEME_PAIRP(ml)) {
    while (SCHEME_PAIRP(ml)) {
      a = SCHEME_CAR(ml);
      if (SCHEME_NUMBERP(a)) {
       o = scheme_add_remove_mark(o, a);
      } else {
       o = scheme_add_rename(o, a);
      }
      ml = SCHEME_CDR(ml);
    }
  } else if (SCHEME_NUMBERP(ml))
    o = scheme_add_remove_mark(o, ml);
  else if (SCHEME_NULLP(ml)) {
    /* nothing to add */
  } else
    o = scheme_add_rename(o, ml);

  if (((Scheme_Stx *)o)->certs)
    phase_shift_certs(o, owner_wraps, len);

  return o;
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 9171 of file stxobj.c.

{
  Scheme_Object *vec, *insp;
  int i;

  if (!SCHEME_VECTORP(obj)
      || (SCHEME_VEC_SIZE(obj) != 8))
    return NULL;

  vec = scheme_make_vector(8, NULL);
  for (i = 0; i < 8; i++) {
    SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(obj)[i];
  }

  if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) {
    insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
    SCHEME_VEC_ELS(vec)[7] = insp;
  }

  vec->type = scheme_free_id_info_type;
    
  return vec;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* record_certs ( Scheme_Object cert_marks,
Scheme_Marshal_Tables mt 
) [static]

Definition at line 6808 of file stxobj.c.

{
  Scheme_Object *v, *local_key;

  if (SCHEME_PAIRP(cert_marks)) {
    v = scheme_hash_get(mt->cert_lists, cert_marks);
    if (!v) {
      scheme_hash_set(mt->cert_lists, cert_marks, cert_marks);
      v = cert_marks;
    }

    local_key = scheme_marshal_lookup(mt, v);
    if (local_key) {
      scheme_marshal_using_key(mt, v);
      return local_key;
    } else {
      return scheme_marshal_wrap_set(mt, v, v);
    }
  } else
    return scheme_null;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void release_recur_table ( Scheme_Hash_Table free_id_recur) [static]

Definition at line 2034 of file stxobj.c.

{
  if (!free_id_recur->size && !quick_hash_table) {
    quick_hash_table = free_id_recur;
  }
}

Here is the caller graph for this function:

static Scheme_Object* resolve_env ( WRAP_POS _wraps,
Scheme_Object a,
Scheme_Object orig_phase,
int  w_mod,
Scheme_Object **  get_names,
Scheme_Object skip_ribs,
int _binding_marks_skipped,
int _depends_on_unsealed_rib,
int  depth,
Scheme_Hash_Table free_id_recur 
) [static]

Definition at line 4068 of file stxobj.c.

{
  WRAP_POS wraps;
  Scheme_Object *o_rename_stack = scheme_null, *recur_skip_ribs = skip_ribs;
  Scheme_Object *mresult = scheme_false, *mresult_insp;
  Scheme_Object *modidx_shift_to = NULL, *modidx_shift_from = NULL;
  Scheme_Object *rename_stack[QUICK_STACK_SIZE], *rib_delim = scheme_false;
  int stack_pos = 0, no_lexical = 0;
  int is_in_module = 0, skip_other_mods = 0, floating_checked = 0;
  Scheme_Lexical_Rib *rib = NULL, *did_rib = NULL;
  Scheme_Object *phase = orig_phase;
  Scheme_Object *bdg = NULL, *floating = NULL;
  Scheme_Hash_Table *export_registry = NULL;
  int mresult_skipped = -1;
  int depends_on_unsealed_rib = 0, mresult_depends_unsealed = 0;

  EXPLAIN(fprintf(stderr, "%d Resolving %s [skips: %s]:\n", depth, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)),
                  scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL)));

  if (_wraps) {
    WRAP_POS_COPY(wraps, *_wraps);
    WRAP_POS_INC(wraps);
  } else
    WRAP_POS_INIT(wraps, ((Scheme_Stx *)a)->wraps);
  
  while (1) {
    if (WRAP_POS_END_P(wraps)) {
      /* See rename case for info on rename_stack: */
      Scheme_Object *result, *result_free_rename, *key, *rd;
      int did_lexical = 0;

      EXPLAIN(fprintf(stderr, "%d Rename...\n", depth));

      result = scheme_false;
      result_free_rename = scheme_false;
      rib_delim = scheme_null;
      while (!SCHEME_NULLP(o_rename_stack)) {
       key = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[0];
       if (SAME_OBJ(key, result)) {
          EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0)));
         did_lexical = 1;
          rd = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[3];
          if (SCHEME_TRUEP(rd) && !SAME_OBJ(rd, rib_delim) && is_in_rib_delim(result, rd)) {
            /* not a match, due to rib delimiter */
          } else {
            result = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[1];
            result_free_rename = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[2];
            rib_delim = rd;
          }
       } else {
          EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0)));
          if (SAME_OBJ(key, scheme_true)) {
            /* marks a module-level renaming that overrides lexical renaming */
            did_lexical = 0;
          }
        }
       o_rename_stack = SCHEME_CDR(o_rename_stack);
      }
      while (stack_pos) {
       key = rename_stack[stack_pos - 1];
       if (SAME_OBJ(key, result)) {
          EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0)));
          rd = rename_stack[stack_pos - 4];
          if (SCHEME_TRUEP(rd) && !SAME_OBJ(rd, rib_delim) && is_in_rib_delim(result, rd)) {
            /* not a match, due to rib delimiter */
          } else {
            result = rename_stack[stack_pos - 2];
            result_free_rename = rename_stack[stack_pos - 3];
            rib_delim = rd;
            did_lexical = 1;
          }
       } else {
          EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0)));
          if (SAME_OBJ(key, scheme_true)) {
            /* marks a module-level renaming that overrides lexical renaming */
            did_lexical = 0;
          }
        }
       stack_pos -= 4;
      }
      if (!did_lexical) {
       result = mresult;
        if (_binding_marks_skipped)
          *_binding_marks_skipped = mresult_skipped;
        if (mresult_depends_unsealed)
          depends_on_unsealed_rib = 1;
      } else {
        if (free_id_recur && !SCHEME_VOIDP(result_free_rename)) {
          Scheme_Object *orig;
          int rib_dep = 0;
          orig = result_free_rename;
          result_free_rename = SCHEME_VEC_ELS(orig)[0];
          if (SCHEME_PAIRP(result_free_rename) && SCHEME_STXP(SCHEME_CAR(result_free_rename))) {
            phase = SCHEME_CDR(result_free_rename);
            if (!SCHEME_FALSEP(SCHEME_VEC_ELS(orig)[1]))
              phase = scheme_bin_plus(phase, SCHEME_VEC_ELS(orig)[1]);
            if (get_names)
              get_names[1] = NULL;
            result = SCHEME_CAR(result_free_rename);
            if (!scheme_hash_get(free_id_recur, result)) {
              scheme_hash_set(free_id_recur, result, scheme_true);
              result = resolve_env(NULL, result, phase,
                                   w_mod, get_names,
                                   NULL, _binding_marks_skipped,
                                   &rib_dep, depth + 1, free_id_recur);
            }
            if (get_names && !get_names[1])
              if (SCHEME_FALSEP(result) || SAME_OBJ(scheme_undefined, get_names[0]))
                get_names[1] = SCHEME_STX_VAL(SCHEME_CAR(result_free_rename));
          } else if (SCHEME_PAIRP(result_free_rename) && SCHEME_SYMBOLP(SCHEME_CDR(result_free_rename))) {
            if (get_names)
              get_names[1] = SCHEME_CAR(result_free_rename);
            result = SCHEME_CDR(result_free_rename);
            if (get_names)
              get_names[0] = scheme_undefined;
          } else if (SAME_OBJ(SCHEME_TYPE(result_free_rename), scheme_free_id_info_type)) {
            result = SCHEME_VEC_ELS(result_free_rename)[0];
            if (get_names) {
              get_names[0] = SCHEME_VEC_ELS(result_free_rename)[1];
              get_names[1] = SCHEME_VEC_ELS(result_free_rename)[2];
              get_names[2] = SCHEME_VEC_ELS(result_free_rename)[3];
              get_names[3] = SCHEME_VEC_ELS(result_free_rename)[4];
              get_names[4] = SCHEME_VEC_ELS(result_free_rename)[5];
              get_names[5] = SCHEME_VEC_ELS(result_free_rename)[6];
              get_names[6] = SCHEME_VEC_ELS(result_free_rename)[7];
            }
          } else {
            if (get_names)
              get_names[1] = SCHEME_CAR(result_free_rename);
            result = scheme_false;
          }
          if (rib_dep)
            depends_on_unsealed_rib = 1;
          if (SAME_TYPE(SCHEME_TYPE(result), scheme_module_index_type))
            result = scheme_modidx_shift(result, SCHEME_VEC_ELS(orig)[2], SCHEME_VEC_ELS(orig)[3]);
        } else {
          if (get_names) {
            get_names[0] = scheme_undefined;
            get_names[1] = NULL;
          }
        }
      }

      if (_depends_on_unsealed_rib)
        *_depends_on_unsealed_rib = depends_on_unsealed_rib;

      EXPLAIN(fprintf(stderr, "%d Result: %s\n", depth, scheme_write_to_string(result, 0)));

      return result;
    } else if ((SCHEME_RENAMESP(WRAP_POS_FIRST(wraps)) 
                || SCHEME_RENAMES_SETP(WRAP_POS_FIRST(wraps)))
               && w_mod) {
      /* Module rename: */
      Module_Renames *mrn;
      int skipped;

      EXPLAIN(fprintf(stderr, "%d Rename/set\n", depth));
       
      if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps))) {
        mrn = (Module_Renames *)WRAP_POS_FIRST(wraps);
      } else {
        /* Extract the relevant phase, if available */
        Module_Renames_Set *mrns = (Module_Renames_Set *)WRAP_POS_FIRST(wraps);

        if (mrns->kind != mzMOD_RENAME_TOPLEVEL)
         is_in_module = 1;

        mrn = extract_renames(mrns, phase);
      }

      if (mrn && (!is_in_module || (mrn->kind != mzMOD_RENAME_TOPLEVEL)) 
          && !skip_other_mods) {
       if (mrn->kind != mzMOD_RENAME_TOPLEVEL)
         is_in_module = 1;

        if (same_phase(phase, mrn->phase)) {
         Scheme_Object *rename, *nominal = NULL, *glob_id;
          int get_names_done;

          EXPLAIN(fprintf(stderr, "%d  use rename %p %d\n", depth, mrn->phase, mrn->kind));

         if (mrn->needs_unmarshal) {
            EXPLAIN(fprintf(stderr, "%d  {unmarshal}\n", depth));
           unmarshal_rename(mrn, modidx_shift_from, modidx_shift_to, export_registry);
          }

          if (mrn->marked_names) {
           /* Resolve based on rest of wraps: */
            EXPLAIN(fprintf(stderr, "%d  tl_id_sym\n", depth));
           if (!bdg) {
              EXPLAIN(fprintf(stderr, "%d   get bdg\n", depth));
             bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1, NULL);
              if (SCHEME_FALSEP(bdg)) {
                if (!floating_checked) {
                  floating = check_floating_id(a);
                  floating_checked = 1;
                }
                bdg = floating;
              }
            }
           /* Remap id based on marks and rest-of-wraps resolution: */
           glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL, &skipped);
         
           if (SCHEME_TRUEP(bdg)
              && !SAME_OBJ(glob_id, SCHEME_STX_VAL(a))) {
             /* Even if this module doesn't match, the lex-renamed id
               has been top-level bound in its scope, so ignore all
               lexical renamings.  (If the id was further renamed, then
               the further renaming would show up in bdg, and bdg wouldn't
               have matched in marked_names.) */
             no_lexical = 1;
             stack_pos = 0;
             o_rename_stack = scheme_null;
           }
         } else {
            skipped = -1;
           glob_id = SCHEME_STX_VAL(a);
          }

          EXPLAIN(fprintf(stderr, "%d  search %s\n", depth, scheme_write_to_string(glob_id, 0)));

          if (free_id_recur && mrn->free_id_renames) {
            rename = scheme_hash_get(mrn->free_id_renames, glob_id);
            if (rename && SCHEME_STXP(rename)) {
              int sealed;
              rename = extract_module_free_id_binding((Scheme_Object *)mrn,
                                                      glob_id, 
                                                      rename,
                                                      &sealed,
                                                      free_id_recur);
              if (!sealed)
                mresult_depends_unsealed = 1;
            }
          } else
            rename = NULL;
          if (!rename)
            rename = scheme_hash_get(mrn->ht, glob_id);
         if (!rename && mrn->nomarshal_ht)
           rename = scheme_hash_get(mrn->nomarshal_ht, glob_id);
          get_names_done = 0;
          if (!rename) {
            EXPLAIN(fprintf(stderr, "%d    in pes\n", depth));
            rename = search_shared_pes(mrn->shared_pes, glob_id, a, get_names, 0, depth, &skipped);
            if (rename)
              get_names_done = 1;
          }

          EXPLAIN(fprintf(stderr, "%d  search result: %p\n", depth, rename));
                
         if (rename) {
            if (mrn->sealed < STX_SEAL_BOUND)
              mresult_depends_unsealed = 1;

           if (mrn->kind == mzMOD_RENAME_MARKED) {
              /* One job of a mzMOD_RENAME_MARKED renamer is to replace any
                 binding that might have come from the identifier in its source
                 module, instead of the module where it was eventually bound
                 (after being introduced by a macro in the source module). */
             skip_other_mods = 1;
            }

           /* match; set mresult, which is used in the case of no lexical capture: */
            mresult_skipped = skipped;

            mresult_insp = NULL;
            
            if (SCHEME_BOXP(rename)) {
              /* This should only happen for mappings from free_id_renames */
              mresult = SCHEME_BOX_VAL(rename);
              if (get_names) {
                if (SCHEME_FALSEP(SCHEME_CDR(mresult)))
                  get_names[0] = NULL;
                else
                  get_names[0] = scheme_undefined;
                get_names[1] = SCHEME_CAR(mresult);
              }
              mresult = SCHEME_CDR(mresult);
            } else {
              if (SCHEME_PAIRP(rename)) {
                mresult = SCHEME_CAR(rename);
                if (is_rename_inspector_info(mresult)) {
                  mresult_insp = mresult;
                  rename = SCHEME_CDR(rename);
                  mresult = SCHEME_CAR(rename);
                }
              } else
                mresult = rename;
           
              if (modidx_shift_from)
                mresult = scheme_modidx_shift(mresult,
                                              modidx_shift_from,
                                              modidx_shift_to);

              if (get_names) {
                int no_shift = 0;

                if (!get_names_done) {
                  if (SCHEME_PAIRP(rename)) {
                    if (nom_mod_p(rename)) {
                      /* (cons modidx nominal_modidx) case */
                      get_names[0] = glob_id;
                      get_names[1] = SCHEME_CDR(rename);
                      get_names[2] = get_names[0];
                    } else {
                      rename = SCHEME_CDR(rename);
                      if (SCHEME_PAIRP(rename)) {
                        /* (list* modidx [mod-phase] exportname nominal_modidx nominal_exportname) case */
                        if (SCHEME_INTP(SCHEME_CAR(rename))
                            || SCHEME_FALSEP(SCHEME_CAR(rename))) {
                          get_names[3] = SCHEME_CAR(rename);
                          rename = SCHEME_CDR(rename);
                        }
                        get_names[0] = SCHEME_CAR(rename);
                        get_names[1] = SCHEME_CADR(rename);
                        if (SCHEME_PAIRP(get_names[1])) {
                          get_names[4] = SCHEME_CDR(get_names[1]);
                          get_names[1] = SCHEME_CAR(get_names[1]);
                          if (SCHEME_PAIRP(get_names[4])) {
                            get_names[5] = SCHEME_CDR(get_names[4]);
                            get_names[4] = SCHEME_CAR(get_names[4]);
                          } else {
                            get_names[5] = get_names[3];
                          }
                        }
                        get_names[2] = SCHEME_CDDR(rename);
                      } else {
                        /* (cons modidx exportname) case */
                        get_names[0] = rename;
                        get_names[2] = NULL; /* finish below */
                      }
                    }
                  } else {
                    get_names[0] = glob_id;
                    get_names[2] = NULL; /* finish below */
                  }

                  if (!get_names[2]) {
                    get_names[2] = get_names[0];
                    if (nominal)
                      get_names[1] = nominal;
                    else {
                      no_shift = 1;
                      get_names[1] = mresult;
                    }
                  }
                  if (!get_names[4]) {
                    GC_CAN_IGNORE Scheme_Object *pi;
                    pi = phase_to_index(mrn->phase);
                    get_names[4] = pi;
                  }
                  if (!get_names[5]) {
                    get_names[5] = get_names[3];
                  }
                  get_names[6] = mresult_insp;
                }

                if (modidx_shift_from && !no_shift) {
                  Scheme_Object *nom;
                  nom = get_names[1];
                  nom = scheme_modidx_shift(nom,
                                            modidx_shift_from,
                                            modidx_shift_to);
                  get_names[1] = nom;
                }
              }
            }
          } else {
            if (mrn->sealed < STX_SEAL_ALL)
              mresult_depends_unsealed = 1;
           mresult = scheme_false;
            mresult_skipped = -1;
           if (get_names)
             get_names[0] = NULL;
         }
       }
      }
    } else if (SCHEME_BOXP(WRAP_POS_FIRST(wraps)) && w_mod) {
      /* Phase shift */
      Scheme_Object *vec, *n, *dest, *src;
      
      EXPLAIN(fprintf(stderr, "%d phase shift\n", depth));

      vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(wraps));
      n = SCHEME_VEC_ELS(vec)[0];
      if (SCHEME_TRUEP(phase))
        phase = scheme_bin_minus(phase, n);
     
      src = SCHEME_VEC_ELS(vec)[1];
      dest = SCHEME_VEC_ELS(vec)[2];

      /* If src is #f, shift is just for phase; no redirection */

      if (!SCHEME_FALSEP(src)) {
       if (!modidx_shift_to) {
         modidx_shift_to = dest;
       } else if (!SAME_OBJ(modidx_shift_from, dest)) {
         modidx_shift_to = scheme_modidx_shift(dest,
                                          modidx_shift_from,
                                          modidx_shift_to);
       }
       
       modidx_shift_from = src;
      }

      {
       Scheme_Object *er;
       er = SCHEME_VEC_ELS(vec)[3];
       if (SCHEME_TRUEP(er))
         export_registry = (Scheme_Hash_Table *)er;
      }
    } else if (rib || (SCHEME_VECTORP(WRAP_POS_FIRST(wraps))
                     && !no_lexical)) {
      /* Lexical rename: */
      Scheme_Object *rename, *renamed;
      int ri, c, istart, iend;
      Scheme_Lexical_Rib *is_rib;

      if (rib) {
       rename = rib->rename;
       is_rib = rib;
       rib = rib->next;
      } else {
       rename = WRAP_POS_FIRST(wraps);
       is_rib = NULL;
        did_rib = NULL;
      }

      EXPLAIN(fprintf(stderr, "%d lexical rename (%d) %d %s%s\n", depth, is_rib ? 1 : 0,
                      SCHEME_VEC_SIZE(rename), 
                      SCHEME_SYMBOLP(SCHEME_VEC_ELS(rename)[0]) ? SCHEME_SYM_VAL(SCHEME_VEC_ELS(rename)[0]) : "<simp>",
                      SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1]) ? "" : " hash"));

      c = SCHEME_RENAME_LEN(rename);

      /* Get index from hash table, if there is one: */
      extract_lex_range(rename, SCHEME_STX_VAL(a), &istart, &iend);

      for (ri = istart; ri < iend; ri++) {
       renamed = SCHEME_VEC_ELS(rename)[2+ri];
       if (SAME_OBJ(SCHEME_STX_VAL(a), SCHEME_STX_SYM(renamed))) {
         int same;

         {
           Scheme_Object *other_env, *envname, *free_id_rename;

           if (SCHEME_SYMBOLP(renamed)) {
             /* Simplified table */
             other_env = scheme_false;
             envname = SCHEME_VEC_ELS(rename)[2+c+ri];
              if (SCHEME_PAIRP(envname)) {
                free_id_rename = SCHEME_CDR(envname);
                envname = SCHEME_CAR(envname);
              } else
                free_id_rename = scheme_void;
             same = 1;
              no_lexical = 1; /* simplified table always has final result */
              EXPLAIN(fprintf(stderr, "%d Targes %s <- %s %p\n", depth,
                              scheme_write_to_string(envname, 0),
                              scheme_write_to_string(other_env, 0),
                              free_id_rename));
           } else {
             envname = SCHEME_VEC_ELS(rename)[0];
             other_env = SCHEME_VEC_ELS(rename)[2+c+ri];
              if (SCHEME_PAIRP(other_env))
                free_id_rename = SCHEME_CDR(other_env);
              else
                free_id_rename = scheme_void;
              other_env = filter_cached_env(other_env, recur_skip_ribs);
              
             if (SCHEME_VOIDP(other_env)) {
                int rib_dep = 0;
              SCHEME_USE_FUEL(1);
              other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1, NULL);
              {
                  Scheme_Object *e;
                  e = extend_cached_env(SCHEME_VEC_ELS(rename)[2+c+ri], other_env, recur_skip_ribs,
                                        (is_rib && !(*is_rib->sealed)) || rib_dep);
                  SCHEME_VEC_ELS(rename)[2+c+ri] = e;
                }
                if (rib_dep)
                  depends_on_unsealed_rib = 1;
              SCHEME_USE_FUEL(1);
             }

              EXPLAIN(fprintf(stderr, "%d Target %s <- %s (%d)\n", depth,
                              scheme_write_to_string(envname, 0),
                              scheme_write_to_string(other_env, 0),
                              nom_mod_p(rename)));

             {
              WRAP_POS w2;
              WRAP_POS_INIT(w2, ((Scheme_Stx *)renamed)->wraps);
              same = same_marks(&w2, &wraps, other_env);
                if (!same)
                  EXPLAIN(fprintf(stderr, "%d Different marks\n", depth));
             }
           }
           
           if (same) {
             /* If it turns out that we're going to return
               other_env, then return envname instead. 
               It's tempting to try to compare envname to the
               top element of the stack and combine the two
               mappings, but the intermediate name may be needed
               (for other_env values that don't come from this stack). */
              if (free_id_recur && !SCHEME_VOIDP(free_id_rename)) {
                /* Need to remember phase ad shifts for free-id=? rename: */
                Scheme_Object *vec;
                vec = scheme_make_vector(4, NULL);
                SCHEME_VEC_ELS(vec)[0] = free_id_rename;
                SCHEME_VEC_ELS(vec)[1] = phase; 
                SCHEME_VEC_ELS(vec)[2] = modidx_shift_from;
                SCHEME_VEC_ELS(vec)[3] = modidx_shift_to;
                free_id_rename = vec;
              }
             if (stack_pos < QUICK_STACK_SIZE) {
              rename_stack[stack_pos++] = rib_delim;
              rename_stack[stack_pos++] = free_id_rename;
              rename_stack[stack_pos++] = envname;
              rename_stack[stack_pos++] = other_env;
             } else {
                Scheme_Object *vec;
                vec = scheme_make_vector(4, NULL);
                SCHEME_VEC_ELS(vec)[0] = other_env;
                SCHEME_VEC_ELS(vec)[1] = envname;
                SCHEME_VEC_ELS(vec)[2] = free_id_rename;
                SCHEME_VEC_ELS(vec)[3] = rib_delim;
              o_rename_stack = CONS(vec, o_rename_stack);
             }
              if (is_rib) {
                /* skip future instances of the same rib;
                   used to skip the rest of the current rib, too, but 
                   that's wrong in the case that the same symbolic 
                   name with multiple binding contexts is re-bound 
                   in a rib */
                skip_ribs = add_skip_set(is_rib->timestamp, skip_ribs);
              }
           }

           break;
         }
       }
      }
    } else if (SCHEME_RIBP(WRAP_POS_FIRST(wraps)) && !no_lexical) {
      /* Lexical-rename rib. Splice in the names. */
      rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(wraps);
      EXPLAIN(fprintf(stderr, "%d Rib: %p...\n", depth, rib));
      if (skip_ribs) {
       if (in_skip_set(rib->timestamp, skip_ribs)) {
          EXPLAIN(fprintf(stderr, "%d Skip rib\n", depth));
         rib = NULL;
        }
      }
      if (rib) {
        if (!*rib->sealed)
          depends_on_unsealed_rib = 1;
        if (nonempty_rib(rib)) {
          if (SAME_OBJ(did_rib, rib)) {
            EXPLAIN(fprintf(stderr, "%d Did rib\n", depth));
            rib = NULL;
          } else {
            recur_skip_ribs = add_skip_set(rib->timestamp, recur_skip_ribs);
            did_rib = rib;
            rib = rib->next; /* First rib record has no rename */
          }
        } else
          rib = NULL;
      }
    } else if (SCHEME_RIB_DELIMP(WRAP_POS_FIRST(wraps))) {
      rib_delim = WRAP_POS_FIRST(wraps);
      if (SCHEME_NULLP(SCHEME_BOX_VAL(rib_delim)))
        rib_delim = scheme_false;
      did_rib = NULL;
    } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))) {
      EXPLAIN(fprintf(stderr, "%d mark %p\n", depth, WRAP_POS_FIRST(wraps)));
      did_rib = NULL;
    } else if (SCHEME_HASHTP(WRAP_POS_FIRST(wraps))) {
      Scheme_Hash_Table *ht = (Scheme_Hash_Table *)WRAP_POS_FIRST(wraps);

      EXPLAIN(fprintf(stderr, "%d forwarding table...\n", depth));

      did_rib = NULL;

      if (!ht->count 
         /* Table isn't finished if 5 is mapped to a limit: */
         || scheme_hash_get(ht, scheme_make_integer(5))) {
       fill_chain_cache(wraps.l);
      }

      if (!scheme_hash_get(ht, SCHEME_STX_VAL(a))) {
        EXPLAIN(fprintf(stderr, "%d   forwarded\n", depth));
       set_wraps_to_skip(ht, &wraps);

       continue; /* <<<<< ------ */
      }
    } else if (SCHEME_PRUNEP(WRAP_POS_FIRST(wraps))) {
      if (!is_member(SCHEME_STX_VAL(a), SCHEME_BOX_VAL(WRAP_POS_FIRST(wraps)))) {
        /* Doesn't match pruned-to sym; already produce #f */
        return scheme_false;
      }
    }

    if (!rib)
      WRAP_POS_INC(wraps);
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int same_marks ( WRAP_POS _awl,
WRAP_POS _bwl,
Scheme_Object barrier_env 
) [static]

Definition at line 3493 of file stxobj.c.

{
  WRAP_POS awl;
  WRAP_POS bwl;
  Scheme_Object *acur_mark, *bcur_mark;
# define FAST_STACK_SIZE 4
  Scheme_Object *a_mark_stack_fast[FAST_STACK_SIZE], *b_mark_stack_fast[FAST_STACK_SIZE];
  Scheme_Object **a_mark_stack = a_mark_stack_fast, **b_mark_stack = b_mark_stack_fast, **naya;
  int a_mark_cnt = 0, a_mark_size = FAST_STACK_SIZE, b_mark_cnt = 0, b_mark_size = FAST_STACK_SIZE;
  int used_barrier = 0;

  WRAP_POS_COPY(awl, *_awl);
  WRAP_POS_COPY(bwl, *_bwl);

  /* A simple way to compare marks would be to make two lists of
     marks.  The loop below attempts to speed up that process by
     discovering common and canceled marks early, so they can be
     omitted from the lists. The "stack" arrays accumulate the parts
     of the list that can't be skipped that way. */

  while (1) {
    /* Skip over renames and canceled marks: */
    acur_mark = NULL;
    while (1) { /* loop for canceling stack */
      /* this loop handles immediately canceled marks */
      while (1) {
        if (WRAP_POS_END_P(awl))
          break;
        if (SCHEME_NUMBERP(WRAP_POS_FIRST(awl)) && IS_POSMARK(WRAP_POS_FIRST(awl))) {
          if (acur_mark) {
            if (SAME_OBJ(acur_mark, WRAP_POS_FIRST(awl))) {
              acur_mark = NULL;
              WRAP_POS_INC(awl);
            } else
              break;
          } else {
            acur_mark = WRAP_POS_FIRST(awl);
            WRAP_POS_INC(awl);
          }
        } else if (SCHEME_RIBP(WRAP_POS_FIRST(awl))) {
          if (SCHEME_FALSEP(barrier_env)) {
            WRAP_POS_INC(awl);
          } else {
            /* See if the barrier environment is in this rib. */
            Scheme_Lexical_Rib *rib;
            rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(awl);
            for (rib = rib->next; rib; rib = rib->next) {
              if (SAME_OBJ(SCHEME_VEC_ELS(rib->rename)[0], barrier_env))
                break;
            }
            if (!rib) {
              WRAP_POS_INC(awl);
            } else {
              WRAP_POS_INIT_END(awl);
              used_barrier = 1;
            }
          }
        } else {
          WRAP_POS_INC(awl);
        }
      }
      /* Maybe cancel a mark on the stack */
      if (acur_mark && a_mark_cnt) {
        if (SAME_OBJ(acur_mark, a_mark_stack[a_mark_cnt - 1])) {
          --a_mark_cnt;
          if (a_mark_cnt) {
            acur_mark = a_mark_stack[a_mark_cnt - 1];
            --a_mark_cnt;
            break;
          } else
            acur_mark = NULL;
        } else
          break;
      } else
        break;
    }

    bcur_mark = NULL;
    while (1) { /* loop for canceling stack */
      while (1) {
        if (WRAP_POS_END_P(bwl))
          break;
        if (SCHEME_NUMBERP(WRAP_POS_FIRST(bwl)) && IS_POSMARK(WRAP_POS_FIRST(bwl))) {
          if (bcur_mark) {
            if (SAME_OBJ(bcur_mark, WRAP_POS_FIRST(bwl))) {
              bcur_mark = NULL;
              WRAP_POS_INC(bwl);
            } else
              break;
          } else {
            bcur_mark = WRAP_POS_FIRST(bwl);
            WRAP_POS_INC(bwl);
          }
        } else if (SCHEME_RIBP(WRAP_POS_FIRST(bwl))) {
          if (SCHEME_FALSEP(barrier_env)) {
            WRAP_POS_INC(bwl);
          } else {
            /* See if the barrier environment is in this rib. */
            Scheme_Lexical_Rib *rib;
            rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(bwl);
            for (rib = rib->next; rib; rib = rib->next) {
              if (SAME_OBJ(SCHEME_VEC_ELS(rib->rename)[0], barrier_env))
                break;
            }
            if (!rib) {
              WRAP_POS_INC(bwl);
            } else {
              WRAP_POS_INIT_END(bwl);
              used_barrier = 1;
            }
          }
        } else {
          WRAP_POS_INC(bwl);
        }
      }
      /* Maybe cancel a mark on the stack */
      if (bcur_mark && b_mark_cnt) {
        if (SAME_OBJ(bcur_mark, b_mark_stack[b_mark_cnt - 1])) {
          --b_mark_cnt;
          if (b_mark_cnt) {
            bcur_mark = b_mark_stack[b_mark_cnt - 1];
            --b_mark_cnt;
            break;
          } else
            bcur_mark = NULL;
        } else
          break;
      } else
        break;
    }

    /* Same mark? */
    if (a_mark_cnt || b_mark_cnt || !SAME_OBJ(acur_mark, bcur_mark)) {
      /* Not the same, so far; push onto stacks in case they're
         cancelled later */
      if (acur_mark) {
        if (a_mark_cnt >= a_mark_size) {
          a_mark_size *= 2;
          naya = MALLOC_N(Scheme_Object*, a_mark_size);
          memcpy(naya, a_mark_stack, sizeof(Scheme_Object *)*a_mark_cnt);
          a_mark_stack = naya;
        }
        a_mark_stack[a_mark_cnt++] = acur_mark;
      }
      if (bcur_mark) {
        if (b_mark_cnt >= b_mark_size) {
          b_mark_size *= 2;
          naya = MALLOC_N(Scheme_Object*, b_mark_size);
          memcpy(naya, b_mark_stack, sizeof(Scheme_Object *)*b_mark_cnt);
          b_mark_stack = naya;
        }
        b_mark_stack[b_mark_cnt++] = bcur_mark;
      }
    }

    /* Done if both reached the end: */
    if (WRAP_POS_END_P(awl) && WRAP_POS_END_P(bwl)) {
      EXPLAIN(fprintf(stderr, "    %d vs. %d marks\n", a_mark_cnt, b_mark_cnt));
      if (a_mark_cnt == b_mark_cnt) {
        while (a_mark_cnt--) {
          if (!SAME_OBJ(a_mark_stack[a_mark_cnt], b_mark_stack[a_mark_cnt]))
            return 0;
        }
        return used_barrier + 1;
      } else
        return 0;
    }
  }
}

Here is the caller graph for this function:

static int same_phase ( Scheme_Object a,
Scheme_Object b 
) [static]

Definition at line 1259 of file stxobj.c.

{
  if (SAME_OBJ(a, b))
    return 1;
  else if (SCHEME_INTP(a) || SCHEME_INTP(b)
           || SCHEME_FALSEP(a) || SCHEME_FALSEP(b))
    return 0;
  else
    return scheme_eqv(a, b);
}

Here is the caller graph for this function:

static XFORM_NONGCING int same_skipped_ribs ( Scheme_Object a,
Scheme_Object b 
) [static]

Definition at line 3942 of file stxobj.c.

{
  return SAME_OBJ(a, b);
}

Here is the caller graph for this function:

Definition at line 1289 of file stxobj.c.

{
  Module_Renames_Set *mrns = (Module_Renames_Set *)set;
  Module_Renames *mrn = (Module_Renames *)rn;

  mrn->set_identity = mrns->set_identity;

  if (same_phase(mrn->phase, scheme_make_integer(0)))
    mrns->rt = mrn;
  else if (same_phase(mrn->phase, scheme_make_integer(1)))
    mrns->et = mrn;
  else {
    Scheme_Hash_Table *ht;
    ht = mrns->other_phases;
    if (!ht) {
      ht = scheme_make_hash_table_equal();
      mrns->other_phases = ht;
    }
    scheme_hash_set(ht, mrn->phase, (Scheme_Object *)mrn);
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 1042 of file stxobj.c.

{
  Scheme_Stx *stx = (Scheme_Stx *)o;
  Scheme_Object *wraps;
  Scheme_Object *certs;
  long lp;

  if (STX_KEY(stx) & STX_SUBSTX_FLAG)
    lp = stx->u.lazy_prefix;
  else
    lp = 1;

  wraps = stx->wraps;
  if (SCHEME_PAIRP(wraps)
      && SAME_OBJ(m, SCHEME_CAR(wraps))
      && lp) {
    --lp;
    wraps = SCHEME_CDR(wraps);
  } else {
    if (maybe_add_chain_cache(stx))
      lp++;
    wraps = stx->wraps;
    lp++;
    wraps = CONS(m, wraps);
  }

  certs = stx->certs;
  stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props);
  stx->wraps = wraps;
  stx->certs = certs;

  if (STX_KEY(stx) & STX_SUBSTX_FLAG)
    stx->u.lazy_prefix = lp;
  /* else cache should stay zeroed */

  return (Scheme_Object *)stx;
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 1910 of file stxobj.c.

{
  Scheme_Stx *stx = (Scheme_Stx *)o;
  Scheme_Object *wraps;
  Scheme_Object *certs;
  long lp;

  if (STX_KEY(stx) & STX_SUBSTX_FLAG)
    preemptive_chunk(stx);

  /* relative order matters: chunk first, so that chunking
     doesn't immediately throw away a chain cache */

  maybe_add_chain_cache(stx);

  wraps = CONS(rename, stx->wraps);
  if (STX_KEY(stx) & STX_SUBSTX_FLAG)
    lp = stx->u.lazy_prefix + 1;
  else
    lp = 0;

  certs = stx->certs;
  stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props);
  stx->wraps = wraps;
  stx->certs = certs;

  stx->u.lazy_prefix = lp; /* same as zeroing cache if no SUBSTX */

  if (stx->certs)
    phase_shift_certs((Scheme_Object *)stx, stx->wraps, 1);
  
  return (Scheme_Object *)stx;
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 1978 of file stxobj.c.

{
#if 0
  WRAP_POS wl;

  /* Shortcut: there's a good chance that o already has the renaming rib */
  WRAP_POS_INIT(wl, ((Scheme_Stx *)o)->wraps);
  if (!WRAP_POS_END_P(wl)) {
    if (SAME_OBJ(rib, WRAP_POS_FIRST(wl))) {
      return o;
    }
  }
#endif

  return scheme_add_rename(o, rib);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 1995 of file stxobj.c.

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 1154 of file stxobj.c.

Here is the call graph for this function:

Here is the caller graph for this function:

void scheme_append_module_rename ( Scheme_Object src,
Scheme_Object dest,
int  do_unm 
)

Definition at line 1682 of file stxobj.c.

{
  do_append_module_rename(src, dest, NULL, NULL, 1, do_unm);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 1687 of file stxobj.c.

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 8369 of file stxobj.c.

{
  if (!SCHEME_STXP(argv[0]))
    scheme_wrong_type("syntax-e", "syntax", 0, argc, argv);
    
  return scheme_stx_content(argv[0]);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 2239 of file stxobj.c.

Here is the caller graph for this function:

Scheme_Object* scheme_datum_to_syntax ( Scheme_Object o,
Scheme_Object stx_src,
Scheme_Object stx_wraps,
int  can_graph,
int  copy_props 
)

Definition at line 8014 of file stxobj.c.

{
  return general_datum_to_syntax(o, NULL, stx_src, stx_wraps, can_graph, copy_props);
}

Here is the call graph for this function:

Definition at line 1961 of file stxobj.c.

{
  Scheme_Object *rename;
  Resolve_Prefix *rp;

  rename = o[0];

  if (!rename) return scheme_false; /* happens only with corrupted .zo! */

  rp = (Resolve_Prefix *)o[1];

  if (SCHEME_INTP(rp->stxes[i]))
    scheme_load_delayed_syntax(rp, i);

  return scheme_add_rename(rp->stxes[i], rename);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 1178 of file stxobj.c.

{
  Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)ro;
  rib->next = rib->next->next;
}

Here is the caller graph for this function:

Definition at line 9121 of file stxobj.c.

{
  Scheme_Object *vec, *v;

  if (SCHEME_PAIRP(stx)) {
    return scheme_make_pair(scheme_explode_syntax(SCHEME_CAR(stx), ht),
                            scheme_explode_syntax(SCHEME_CDR(stx), ht));
  }
  if (SCHEME_NULLP(stx))
    return scheme_null;

  vec = scheme_hash_get(ht, stx);
  if (vec)
    return vec;

  vec = scheme_make_vector(3, NULL);
  scheme_hash_set(ht, stx, vec);

  v = ((Scheme_Stx *)stx)->val;
  if (SCHEME_PAIRP(v)) {
    v = scheme_make_pair(scheme_explode_syntax(SCHEME_CAR(v), ht),
                         scheme_explode_syntax(SCHEME_CDR(v), ht));
  }
  SCHEME_VEC_ELS(vec)[0] = v;

  v = explode_certs((Scheme_Stx *)stx, ht);
  SCHEME_VEC_ELS(vec)[1] = v;
  v = explode_wraps(((Scheme_Stx *)stx)->wraps, ht);
  SCHEME_VEC_ELS(vec)[2] = v;

  return vec;
}

Here is the call graph for this function:

Here is the caller graph for this function: