/* * 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; } } } }