/*
* Get the init filename for the system
* * First look to see if <addon-dir>/interactive.rkt exists
* * Otherwise check config file for location
*/
static Scheme_Object *get_init_filename(Scheme_Env *env,
char *init_filename_sym,
char *default_init_module,
char *user_init_module)
{
Scheme_Object *f, *a[2], *build_path;
Scheme_Thread * volatile p;
mz_jmp_buf * volatile save, newbuf;
p = scheme_get_current_thread();
save = p->error_buf;
p->error_buf = &newbuf;
if(!scheme_setjmp(newbuf)) {
build_path = scheme_builtin_value("build-path");
/* First test to see if user init file exists */
f = scheme_builtin_value("find-system-path");
a[0] = scheme_intern_symbol("addon-dir");
a[0] = _scheme_apply(f, 1, a);
a[1] = scheme_make_path(user_init_module);
f = _scheme_apply(build_path, 2, a);
if (SCHEME_PATHP(f)) {
char *filename;
filename = scheme_expand_filename(SCHEME_PATH_VAL(f), -1, "startup", NULL, SCHEME_GUARD_FILE_EXISTS);
if(scheme_file_exists(filename)) {
p->error_buf = save;
return scheme_make_path(filename);
}
}
/* Failed, next check config.rkt fo system init file */
f = scheme_builtin_value("find-main-config");
a[0] = _scheme_apply(f, 0, NULL);
a[1] = scheme_make_path("config.rktd");
f = _scheme_apply(build_path, 2, a);
if (SCHEME_PATHP(f)) {
char *filename;
filename = scheme_expand_filename(SCHEME_PATH_VAL(f), -1, "startup", NULL,
SCHEME_GUARD_FILE_EXISTS | SCHEME_GUARD_FILE_READ);
if(scheme_file_exists(filename)) {
Scheme_Object * port;
port = scheme_open_input_file(SCHEME_PATH_VAL(f), "get-init-filename");
f = scheme_read(port);
scheme_close_input_port(port);
if(SCHEME_HASHTRP(f)) {
f = scheme_hash_tree_get((Scheme_Hash_Tree *)f, scheme_intern_symbol(init_filename_sym));
if(f) {
p->error_buf = save;
return f;
}
}
}
}
/* Failed to load custom init file, load racket/interactive */
f = scheme_intern_symbol(default_init_module);
p->error_buf = save;
return f;
}
p->error_buf = save;
return NULL;
}
int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
{
Scheme_Type t1, t2;
int cmp;
Scheme_Object *orig_obj1, *orig_obj2;
top:
orig_obj1 = obj1;
orig_obj2 = obj2;
if (eql->next_next) {
if (eql->next) {
Scheme_Object *a[2];
a[0] = obj1;
a[1] = obj2;
obj1 = _scheme_apply(eql->next, 2, a);
return SCHEME_TRUEP(obj1);
}
eql->next = eql->next_next;
}
top_after_next:
cmp = is_fast_equal(obj1, obj2, eql->for_chaperone == 1);
if (cmp > -1)
return cmp;
if (eql->for_chaperone
&& SCHEME_CHAPERONEP(obj2)
&& scheme_is_noninterposing_chaperone(obj2)) {
obj2 = ((Scheme_Chaperone *)obj2)->prev;
goto top_after_next;
}
if (eql->for_chaperone
&& SCHEME_CHAPERONEP(obj1)
&& (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
|| (eql->for_chaperone > 1))) {
/* `obj1` and `obj2` are not eq, otherwise is_fast_equal()
would have returned true */
if (SCHEME_CHAPERONEP(obj2)) {
/* for immutable hashes, it's ok for the two objects to not be eq,
as long as the interpositions are the same and the underlying
values are `{impersonator,chaperone}-of?`: */
if (SCHEME_HASHTRP(((Scheme_Chaperone *)obj1)->val)
&& SCHEME_HASHTRP(((Scheme_Chaperone *)obj2)->val)
/* eq redirects means redirects were propagated: */
&& SAME_OBJ(((Scheme_Chaperone *)obj1)->redirects,
((Scheme_Chaperone *)obj2)->redirects))
obj2 = ((Scheme_Chaperone *)obj2)->prev;
}
obj1 = ((Scheme_Chaperone *)obj1)->prev;
goto top_after_next;
}
t1 = SCHEME_TYPE(obj1);
t2 = SCHEME_TYPE(obj2);
if (NOT_SAME_TYPE(t1, t2)) {
if (!eql->for_chaperone) {
if (SCHEME_CHAPERONEP(obj1)) {
obj1 = ((Scheme_Chaperone *)obj1)->val;
goto top_after_next;
} else if (t1 == scheme_hash_tree_indirection_type) {
obj1 = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)obj1);
goto top_after_next;
}
if (SCHEME_CHAPERONEP(obj2)) {
obj2 = ((Scheme_Chaperone *)obj2)->val;
goto top_after_next;
} else if (t2 == scheme_hash_tree_indirection_type) {
obj2 = (Scheme_Object *)scheme_hash_tree_resolve_placeholder((Scheme_Hash_Tree *)obj2);
goto top_after_next;
}
}
return 0;
} else {
switch (t1) {
case scheme_pair_type:
{
# include "mzeqchk.inc"
if ((eql->car_depth > 2) || !scheme_is_list(obj1)) {
if (union_check(obj1, obj2, eql))
return 1;
}
eql->car_depth += 2;
if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
eql->car_depth -= 2;
obj1 = SCHEME_CDR(obj1);
obj2 = SCHEME_CDR(obj2);
goto top;
} else
return 0;
}
case scheme_mutable_pair_type:
{
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) {
obj1 = SCHEME_CDR(obj1);
obj2 = SCHEME_CDR(obj2);
goto top;
} else
return 0;
}
case scheme_vector_type:
case scheme_fxvector_type:
{
# include "mzeqchk.inc"
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return vector_equal(obj1, orig_obj1, obj2, orig_obj2, eql);
}
case scheme_byte_string_type:
case scheme_unix_path_type:
case scheme_windows_path_type:
{
intptr_t l1, l2;
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
l1 = SCHEME_BYTE_STRTAG_VAL(obj1);
l2 = SCHEME_BYTE_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !memcmp(SCHEME_BYTE_STR_VAL(obj1), SCHEME_BYTE_STR_VAL(obj2), l1));
}
case scheme_char_string_type:
{
intptr_t l1, l2;
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
l1 = SCHEME_CHAR_STRTAG_VAL(obj1);
l2 = SCHEME_CHAR_STRTAG_VAL(obj2);
return ((l1 == l2)
&& !memcmp(SCHEME_CHAR_STR_VAL(obj1), SCHEME_CHAR_STR_VAL(obj2), l1 * sizeof(mzchar)));
}
case scheme_regexp_type:
{
if (scheme_regexp_is_byte(obj1) != scheme_regexp_is_byte(obj2))
return 0;
if (scheme_regexp_is_pregexp(obj1) != scheme_regexp_is_pregexp(obj2))
return 0;
obj1 = scheme_regexp_source(obj1);
obj2 = scheme_regexp_source(obj2);
goto top;
}
case scheme_structure_type:
case scheme_proc_struct_type:
{
Scheme_Struct_Type *st1, *st2;
Scheme_Object *procs1, *procs2;
st1 = SCHEME_STRUCT_TYPE(obj1);
st2 = SCHEME_STRUCT_TYPE(obj2);
if (eql->for_chaperone == 1)
procs1 = NULL;
else
procs1 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st1);
if (procs1)
procs1 = scheme_apply_impersonator_of(eql->for_chaperone, procs1, obj1);
if (eql->for_chaperone)
procs2 = NULL;
else {
procs2 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st2);
if (procs2)
procs2 = scheme_apply_impersonator_of(eql->for_chaperone, procs2, obj2);
}
if (procs1 || procs2) {
/* impersonator-of property trumps other forms of checking */
if (procs1) { obj1 = procs1; orig_obj1 = obj1; }
if (procs2) { obj2 = procs2; orig_obj2 = obj2; }
goto top_after_next;
} else {
procs1 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st1);
if (procs1 && (st1 != st2)) {
procs2 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st2);
if (!procs2
|| !SAME_OBJ(SCHEME_VEC_ELS(procs1)[0], SCHEME_VEC_ELS(procs2)[0]))
procs1 = NULL;
}
if (procs1) {
/* Has an equality property: */
Scheme_Object *a[3], *recur;
Equal_Info *eql2;
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
/* Create/cache closure to use for recursive equality checks: */
if (eql->recur) {
recur = eql->recur;
eql2 = (Equal_Info *)SCHEME_PRIM_CLOSURE_ELS(recur)[0];
} else {
eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info));
a[0] = (Scheme_Object *)eql2;
recur = scheme_make_prim_closure_w_arity(equal_recur,
1, a,
"equal?/recur",
2, 2);
eql->recur = recur;
}
memcpy(eql2, eql, sizeof(Equal_Info));
a[0] = orig_obj1;
a[1] = orig_obj2;
a[2] = recur;
procs1 = SCHEME_VEC_ELS(procs1)[1];
recur = _scheme_apply(procs1, 3, a);
memcpy(eql, eql2, sizeof(Equal_Info));
return SCHEME_TRUEP(recur);
} else if (st1 != st2) {
return 0;
} else if ((eql->for_chaperone == 1)
&& !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) {
return 0;
} else {
/* Same types, but doesn't have an equality property
(or checking for chaperone), so check transparency: */
Scheme_Object *insp;
if (scheme_struct_is_transparent(obj1))
insp = NULL;
else {
insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
}
if (!insp || scheme_inspector_sees_part(obj1, insp, -2)) {
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
return struct_equal(obj1, orig_obj1, obj2, orig_obj2, eql);
} else
return 0;
}
}
}
case scheme_box_type:
{
SCHEME_USE_FUEL(1);
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))
return 0;
if (union_check(obj1, obj2, eql))
return 1;
if (SAME_OBJ(obj1, orig_obj1))
obj1 = SCHEME_BOX_VAL(obj1);
else
obj1 = scheme_unbox(orig_obj1);
if (SAME_OBJ(obj2, orig_obj2))
obj2 = SCHEME_BOX_VAL(obj2);
else
obj2 = scheme_unbox(orig_obj2);
goto top;
}
case scheme_hash_table_type:
{
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return scheme_hash_table_equal_rec((Scheme_Hash_Table *)obj1, orig_obj1,
(Scheme_Hash_Table *)obj2, orig_obj2,
eql);
}
case scheme_hash_tree_type:
case scheme_eq_hash_tree_type:
case scheme_eqv_hash_tree_type:
case scheme_hash_tree_indirection_type:
{
# include "mzeqchk.inc"
if (union_check(obj1, obj2, eql))
return 1;
return scheme_hash_tree_equal_rec((Scheme_Hash_Tree *)obj1, orig_obj1,
(Scheme_Hash_Tree *)obj2, orig_obj2,
eql);
}
case scheme_bucket_table_type:
{
# include "mzeqchk.inc"
if (eql->for_chaperone == 1)
return 0;
if (union_check(obj1, obj2, eql))
return 1;
return scheme_bucket_table_equal_rec((Scheme_Bucket_Table *)obj1, orig_obj1,
(Scheme_Bucket_Table *)obj2, orig_obj2,
eql);
}
case scheme_wrap_chunk_type: {
return vector_equal(obj1, obj1, obj2, obj2, eql);
}
case scheme_resolved_module_path_type:
{
obj1 = SCHEME_PTR_VAL(obj1);
obj2 = SCHEME_PTR_VAL(obj2);
goto top;
}
case scheme_module_index_type:
{
Scheme_Modidx *midx1, *midx2;
# include "mzeqchk.inc"
midx1 = (Scheme_Modidx *)obj1;
midx2 = (Scheme_Modidx *)obj2;
if (eql->eq_for_modidx
&& (SCHEME_FALSEP(midx1->path)
|| SCHEME_FALSEP(midx2->path)))
return 0;
else if (is_equal(midx1->path, midx2->path, eql)) {
obj1 = midx1->base;
obj2 = midx2->base;
goto top;
}
}
case scheme_scope_table_type:
{
Scheme_Scope_Table *mt1 = (Scheme_Scope_Table *)obj1;
Scheme_Scope_Table *mt2 = (Scheme_Scope_Table *)obj2;
if (!is_equal((Scheme_Object *)mt1->simple_scopes, (Scheme_Object *)mt2->simple_scopes, eql))
return 0;
obj1 = mt1->multi_scopes;
obj2 = mt2->multi_scopes;
goto top;
}
default:
if (!eql->for_chaperone && ((t1 == scheme_chaperone_type)
|| (t1 == scheme_proc_chaperone_type))) {
/* both chaperones */
obj1 = ((Scheme_Chaperone *)obj1)->val;
obj2 = ((Scheme_Chaperone *)obj2)->val;
goto top_after_next;
} else {
Scheme_Equal_Proc eqlp = scheme_type_equals[t1];
if (eqlp) {
if (union_check(obj1, obj2, eql))
return 1;
return eqlp(obj1, obj2, eql);
} else
return 0;
}
}
}
}
