static Scheme_Object *read_quote_syntax(Scheme_Object *obj) { Scheme_Quote_Syntax *qs; Scheme_Object *a; int c, i, p; if (!SCHEME_PAIRP(obj)) return NULL; a = SCHEME_CAR(obj); c = SCHEME_INT_VAL(a); obj = SCHEME_CDR(obj); if (!SCHEME_PAIRP(obj)) return NULL; a = SCHEME_CAR(obj); i = SCHEME_INT_VAL(a); a = SCHEME_CDR(obj); p = SCHEME_INT_VAL(a); qs = MALLOC_ONE_TAGGED(Scheme_Quote_Syntax); qs->so.type = scheme_quote_syntax_type; qs->depth = c; qs->position = i; qs->midpoint = p; return (Scheme_Object *)qs; }
static Scheme_Object *read_letrec(Scheme_Object *obj) { Scheme_Letrec *lr; int i, c; Scheme_Object **sa; lr = MALLOC_ONE_TAGGED(Scheme_Letrec); lr->so.type = scheme_letrec_type; if (!SCHEME_PAIRP(obj)) return NULL; c = lr->count = SCHEME_INT_VAL(SCHEME_CAR(obj)); obj = SCHEME_CDR(obj); if (!SCHEME_PAIRP(obj)) return NULL; lr->body = SCHEME_CAR(obj); obj = SCHEME_CDR(obj); sa = MALLOC_N(Scheme_Object*, c); lr->procs = sa; for (i = 0; i < c; i++) { if (!SCHEME_PAIRP(obj)) return NULL; lr->procs[i] = SCHEME_CAR(obj); obj = SCHEME_CDR(obj); } return (Scheme_Object *)lr; }
static Scheme_Object *apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj) { Scheme_Object *a[1], *v, *oprocs; a[0] = obj; v = _scheme_apply(SCHEME_CDR(procs), 1, a); if (SCHEME_FALSEP(v)) return NULL; oprocs = scheme_struct_type_property_ref(scheme_impersonator_of_property, v); if (!oprocs || !SAME_OBJ(SCHEME_CAR(oprocs), SCHEME_CAR(procs))) scheme_contract_error((for_chaperone ? "impersonator-of?" : "equal?"), "impersonator-of property procedure returned a value with a different prop:impersonator-of source", "original value", 1, obj, "returned value", 1, v, NULL); procs = scheme_struct_type_property_ref(scheme_equal_property, obj); oprocs = scheme_struct_type_property_ref(scheme_equal_property, v); if (procs || oprocs) if (!procs || !oprocs || !SAME_OBJ(SCHEME_VEC_ELS(oprocs)[0], SCHEME_VEC_ELS(procs)[0])) scheme_contract_error((for_chaperone ? "impersonator-of?" : "equal?"), "impersonator-of property procedure returned a value with a different prop:equal+hash source", "original value", 1, obj, "returned value", 1, v, NULL); return v; }
static Scheme_Object *read_top(Scheme_Object *obj) { Scheme_Compilation_Top *top; top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top); top->so.type = scheme_compilation_top_type; if (!SCHEME_PAIRP(obj)) return NULL; top->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj)); obj = SCHEME_CDR(obj); if (!SCHEME_PAIRP(obj)) return NULL; top->prefix = (Resolve_Prefix *)SCHEME_CAR(obj); top->code = SCHEME_CDR(obj); return (Scheme_Object *)top; }
static Scheme_Object * car_prim (int argc, Scheme_Object *argv[]) { if (!SCHEME_PAIRP(argv[0])) scheme_wrong_type("car", "pair", 0, argc, argv); return (SCHEME_CAR (argv[0])); }
Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i) { if (!SCHEME_NP_CHAPERONEP(o)) { return SCHEME_VEC_ELS(o)[i]; } else { Scheme_Chaperone *px = (Scheme_Chaperone *)o; Scheme_Object *a[3], *red, *orig; #ifdef DO_STACK_CHECK { # include "mzstkchk.h" return chaperone_vector_ref_overflow(o, i); } #endif orig = scheme_chaperone_vector_ref(px->prev, i); if (SCHEME_VECTORP(px->redirects)) { /* chaperone was on property accessors */ return orig; } a[0] = px->prev; a[1] = scheme_make_integer(i); a[2] = orig; red = SCHEME_CAR(px->redirects); o = _scheme_apply(red, 3, a); if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) if (!scheme_chaperone_of(o, orig)) scheme_wrong_chaperoned("vector-ref", "result", orig, o); return o; } }
Scheme_Object * scheme_append (Scheme_Object *lst1, Scheme_Object *lst2) { Scheme_Object *first, *last, *orig1, *v; orig1 = lst1; first = last = NULL; while (SCHEME_PAIRP(lst1)) { v = scheme_make_pair(SCHEME_CAR(lst1), scheme_null); if (!first) first = v; else SCHEME_CDR(last) = v; last = v; lst1 = SCHEME_CDR(lst1); SCHEME_USE_FUEL(1); } if (!SCHEME_NULLP(lst1)) scheme_wrong_type("append", "proper list", -1, 0, &orig1); if (!last) return lst2; SCHEME_CDR(last) = lst2; return first; }
static Scheme_Object *read_let_void(Scheme_Object *obj) { Scheme_Let_Void *lv; lv = (Scheme_Let_Void *)scheme_malloc_tagged(sizeof(Scheme_Let_Void)); lv->iso.so.type = scheme_let_void_type; if (!SCHEME_PAIRP(obj)) return NULL; lv->count = SCHEME_INT_VAL(SCHEME_CAR(obj)); obj = SCHEME_CDR(obj); if (!SCHEME_PAIRP(obj)) return NULL; SCHEME_LET_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj)); lv->body = SCHEME_CDR(obj); return (Scheme_Object *)lv; }
Scheme_Object *scheme_sfs_add_clears(Scheme_Object *expr, Scheme_Object *clears, int pre) { int len, i; Scheme_Object *loc; Scheme_Sequence *s; if (SCHEME_NULLP(clears)) return expr; len = scheme_list_length(clears); s = scheme_malloc_sequence(len + 1); s->so.type = (pre ? scheme_sequence_type : scheme_begin0_sequence_type); s->count = len + 1; s->array[pre ? len : 0] = expr; for (i = 0; i < len; i++) { loc = scheme_make_local(scheme_local_type, SCHEME_INT_VAL(SCHEME_CAR(clears)), SCHEME_LOCAL_CLEAR_ON_READ); s->array[i + (pre ? 0 : 1)] = loc; clears = SCHEME_CDR(clears); } return (Scheme_Object *)s; }
inline static void mark_cust_boxes(NewGC *gc, Scheme_Custodian *cur) { Scheme_Object *pr, *prev = NULL, *next; GC_Weak_Box *wb; Mark2_Proc cust_box_mark = gc->mark_table[btc_redirect_cust_box]; /* cust boxes is a list of weak boxes to cust boxes */ pr = cur->cust_boxes; while (pr) { wb = (GC_Weak_Box *)SCHEME_CAR(pr); next = SCHEME_CDR(pr); if (wb->val) { cust_box_mark(wb->val, gc); prev = pr; } else { if (prev) SCHEME_CDR(prev) = next; else cur->cust_boxes = next; --cur->num_cust_boxes; } pr = next; } cur->checked_cust_boxes = cur->num_cust_boxes; }
static Scheme_Object *read_set_bang(Scheme_Object *obj) { Scheme_Set_Bang *sb; sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang); sb->so.type = scheme_set_bang_type; if (!SCHEME_PAIRP(obj)) return NULL; sb->set_undef = SCHEME_TRUEP(SCHEME_CAR(obj)); obj = SCHEME_CDR(obj); if (!SCHEME_PAIRP(obj)) return NULL; sb->var = SCHEME_CAR(obj); sb->val = SCHEME_CDR(obj); return (Scheme_Object *)sb; }
static Scheme_Object * set_car_prim (int argc, Scheme_Object *argv[]) { if (!SCHEME_MUTABLE_PAIRP(argv[0])) scheme_wrong_type("set-car!", "mutable-pair", 0, argc, argv); SCHEME_CAR (argv[0]) = argv[1]; return scheme_void; }
static Scheme_Object *begin_for_syntax_sfs(Scheme_Object *data, SFS_Info *info) { Scheme_Object *l, *a; if (!info->pass) { int depth; depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[2]); for (l = SCHEME_VEC_ELS(data)[0]; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { a = SCHEME_CAR(l); info = scheme_new_sfs_info(depth); a = scheme_sfs(a, info, depth); SCHEME_CAR(l) = a; } } return data; }
static Scheme_Object *do_define_syntaxes_clone(Scheme_Object *expr, int jit) { Resolve_Prefix *rp, *orig_rp; Scheme_Object *naya, *rhs; rhs = SCHEME_VEC_ELS(expr)[0]; #ifdef MZ_USE_JIT if (jit) { if (SAME_TYPE(SCHEME_TYPE(expr), scheme_define_syntaxes_type)) naya = scheme_jit_expr(rhs); else { int changed = 0; Scheme_Object *a, *l = rhs; naya = scheme_null; while (!SCHEME_NULLP(l)) { a = scheme_jit_expr(SCHEME_CAR(l)); if (!SAME_OBJ(a, SCHEME_CAR(l))) changed = 1; naya = scheme_make_pair(a, naya); l = SCHEME_CDR(l); } if (changed) naya = scheme_reverse(naya); else naya = rhs; } } else #endif naya = rhs; orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(expr)[1]; rp = scheme_prefix_eval_clone(orig_rp); if (SAME_OBJ(naya, rhs) && SAME_OBJ(orig_rp, rp)) return expr; else { expr = scheme_clone_vector(expr, 0, 1); SCHEME_VEC_ELS(expr)[0] = naya; SCHEME_VEC_ELS(expr)[1] = (Scheme_Object *)rp; return expr; } }
Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr) { Scheme_Object *cons; cons = scheme_alloc_object(); cons->type = scheme_pair_type; SCHEME_CAR(cons) = car; SCHEME_CDR(cons) = cdr; return cons; }
static Scheme_Object *read_case_lambda(Scheme_Object *obj) { Scheme_Object *s, *a; int count, i, all_closed = 1; Scheme_Case_Lambda *cl; if (!SCHEME_PAIRP(obj)) return NULL; s = SCHEME_CDR(obj); for (count = 0; SCHEME_PAIRP(s); s = SCHEME_CDR(s)) { count++; } cl = (Scheme_Case_Lambda *) scheme_malloc_tagged(sizeof(Scheme_Case_Lambda) + (count - 1) * sizeof(Scheme_Object *)); cl->so.type = scheme_case_lambda_sequence_type; cl->count = count; cl->name = SCHEME_CAR(obj); if (SCHEME_NULLP(cl->name)) cl->name = NULL; s = SCHEME_CDR(obj); for (i = 0; i < count; i++, s = SCHEME_CDR(s)) { a = SCHEME_CAR(s); cl->array[i] = a; if (!SCHEME_PROCP(a)) { if (!SAME_TYPE(SCHEME_TYPE(a), scheme_unclosed_procedure_type)) return NULL; all_closed = 0; } } if (all_closed) { /* Empty closure: produce procedure value directly. (We assume that this was generated by a direct write of a case-lambda data record in print.c, and that it's not in a CASE_LAMBDA_EXPD syntax record.) */ return scheme_case_lambda_execute((Scheme_Object *)cl); } return (Scheme_Object *)cl; }
Scheme_Object *scheme_make_immutable_pair(Scheme_Object *car, Scheme_Object *cdr) { Scheme_Object *cons; cons = scheme_alloc_object(); cons->type = scheme_pair_type; SCHEME_CAR(cons) = car; SCHEME_CDR(cons) = cdr; SCHEME_SET_PAIR_IMMUTABLE(cons); return cons; }
static Scheme_Object *scheme_sfs_next_saved(SFS_Info *info) { Scheme_Object *v; if (!info->pass) scheme_signal_error("internal error: wrong pass to get saved info"); if (!SCHEME_PAIRP(info->saved)) scheme_signal_error("internal error: no saved info"); v = SCHEME_CAR(info->saved); info->saved = SCHEME_CDR(info->saved); return v; }
Scheme_Object *read_boxenv(Scheme_Object *o) { Scheme_Object *data; if (!SCHEME_PAIRP(o)) return NULL; data = scheme_alloc_object(); data->type = scheme_boxenv_type; SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); SCHEME_PTR2_VAL(data) = SCHEME_CDR(o); return data; }
Scheme_Object *scheme_chaperone_vector_ref2(Scheme_Object *o, int i, Scheme_Object *outermost) { if (!SCHEME_NP_CHAPERONEP(o)) { return SCHEME_VEC_ELS(o)[i]; } else { Scheme_Chaperone *px = (Scheme_Chaperone *)o; Scheme_Object *a[4], *red, *orig; #ifdef DO_STACK_CHECK { # include "mzstkchk.h" return chaperone_vector_ref_overflow(o, i); } #endif if(SCHEME_FALSEP(px->redirects)) { /* unsafe chaperones */ return scheme_chaperone_vector_ref2(px->val, i, outermost); } orig = scheme_chaperone_vector_ref2(px->prev, i, outermost); if (SCHEME_REDIRECTS_PROP_ONLY_VECTORP(px->redirects)) { /* chaperone was on property accessors */ /* or vector chaperone is property only */ return orig; } red = SCHEME_CAR(px->redirects); if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_VEC_CHAPERONE_STAR) { a[0] = outermost; a[1] = px->prev; a[2] = scheme_make_integer(i); a[3] = orig; o = _scheme_apply(red, 4, a); } else { a[0] = px->prev; a[1] = scheme_make_integer(i); a[2] = orig; o = _scheme_apply(red, 3, a); } if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) if (!scheme_chaperone_of(o, orig)) scheme_wrong_chaperoned("vector-ref", "result", orig, o); return o; } }
static Scheme_Object *read_with_cont_mark(Scheme_Object *obj) { Scheme_With_Continuation_Mark *wcm; if (!SCHEME_PAIRP(obj) || !SCHEME_PAIRP(SCHEME_CDR(obj))) return NULL; /* bad .zo */ wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); wcm->so.type = scheme_with_cont_mark_type; wcm->key = SCHEME_CAR(obj); wcm->val = SCHEME_CADR(obj); wcm->body = SCHEME_CDR(SCHEME_CDR(obj)); return (Scheme_Object *)wcm; }
/* This function applies a thunk, returning the Scheme value if there's no exception, otherwise returning NULL and setting *exn to the raised value (usually an exn structure). */ Scheme_Object *_apply_thunk_catch_exceptions(Scheme_Object *f, Scheme_Object **exn) { Scheme_Object *v; init_exn_catching_apply(); v = _scheme_apply(exn_catching_apply, 1, &f); /* v is a pair: (cons #t value) or (cons #f exn) */ if (SCHEME_TRUEP(SCHEME_CAR(v))) return SCHEME_CDR(v); else { *exn = SCHEME_CDR(v); return NULL; } }
static Scheme_Object * reverse_prim (int argc, Scheme_Object *argv[]) { Scheme_Object *lst, *last; last = scheme_null; lst = argv[0]; while (!SCHEME_NULLP (lst)) { if (!SCHEME_PAIRP(lst)) scheme_wrong_type("reverse", "proper list", 0, argc, argv); last = scheme_make_pair (SCHEME_CAR (lst), last); lst = SCHEME_CDR (lst); SCHEME_USE_FUEL(1); } return (last); }
Scheme_Object * scheme_list_to_vector (Scheme_Object *list) { intptr_t len, i; Scheme_Object *vec, *orig = list; len = scheme_proper_list_length(list); if (len < 0) scheme_wrong_contract("list->vector", "list?", -1, 0, &orig); vec = scheme_make_vector(len, NULL); for (i = 0; i < len; i++) { SCHEME_VEC_ELS(vec)[i] = SCHEME_CAR(list); list = SCHEME_CDR(list); } return vec; }
Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i) { if (!SCHEME_NP_CHAPERONEP(o)) { return SCHEME_VEC_ELS(o)[i]; } else { Scheme_Chaperone *px = (Scheme_Chaperone *)o; Scheme_Object *a[3], *red, *orig; #ifdef DO_STACK_CHECK { # include "mzstkchk.h" return chaperone_vector_ref_overflow(o, i); } #endif orig = scheme_chaperone_vector_ref(px->prev, i); if (SCHEME_VECTORP(px->redirects)) { /* chaperone was on property accessors */ return orig; } a[0] = px->prev; a[1] = scheme_make_integer(i); a[2] = orig; red = SCHEME_CAR(px->redirects); o = _scheme_apply(red, 3, a); if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)) if (!scheme_chaperone_of(o, orig)) scheme_raise_exn(MZEXN_FAIL_CONTRACT, "vector-ref: chaperone produced a result: %V that is not a chaperone of the original result: %V", o, orig); return o; } }
int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) { Scheme_Type t1, t2; int cmp; top: 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; } cmp = is_eqv(obj1, obj2); if (cmp > -1) return cmp; if (eql->for_chaperone && SCHEME_CHAPERONEP(obj1) && (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_IMPERSONATOR) || (eql->for_chaperone > 1))) { obj1 = ((Scheme_Chaperone *)obj1)->prev; goto top; } 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; } if (SCHEME_CHAPERONEP(obj2)) { obj2 = ((Scheme_Chaperone *)obj2)->val; goto top; } } return 0; } else if (t1 == 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; } else if (t1 == 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; } else if ((t1 == scheme_vector_type) || (t1 == 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, obj2, eql); } else if (t1 == scheme_flvector_type) { intptr_t l1, l2, i; l1 = SCHEME_FLVEC_SIZE(obj1); l2 = SCHEME_FLVEC_SIZE(obj2); if (l1 == l2) { for (i = 0; i < l1; i++) { if (!double_eqv(SCHEME_FLVEC_ELS(obj1)[i], SCHEME_FLVEC_ELS(obj2)[i])) return 0; } return 1; } return 0; } else if ((t1 == scheme_byte_string_type) || ((t1 >= scheme_unix_path_type) && (t1 <= 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)); } else if (t1 == 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))); } else if (t1 == 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; } else if ((t1 == scheme_structure_type) || (t1 == 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 = 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 = apply_impersonator_of(eql->for_chaperone, procs2, obj2); } if (procs1 || procs2) { /* impersonator-of property trumps other forms of checking */ if (procs1) obj1 = procs1; if (procs2) obj2 = procs2; goto top; } 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] = obj1; a[1] = 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; insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR); if (scheme_inspector_sees_part(obj1, insp, -2) && scheme_inspector_sees_part(obj2, insp, -2)) { # include "mzeqchk.inc" if (union_check(obj1, obj2, eql)) return 1; return struct_equal(obj1, obj2, eql); } else return 0; } } } else if (t1 == 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; obj1 = SCHEME_BOX_VAL(obj1); obj2 = SCHEME_BOX_VAL(obj2); goto top; } else if (t1 == 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, (Scheme_Hash_Table *)obj2, eql); } else if (t1 == scheme_hash_tree_type) { # include "mzeqchk.inc" if (union_check(obj1, obj2, eql)) return 1; return scheme_hash_tree_equal_rec((Scheme_Hash_Tree *)obj1, (Scheme_Hash_Tree *)obj2, eql); } else if (t1 == 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, (Scheme_Bucket_Table *)obj2, eql); } else if (t1 == scheme_cpointer_type) { return (((char *)SCHEME_CPTR_VAL(obj1) + SCHEME_CPTR_OFFSET(obj1)) == ((char *)SCHEME_CPTR_VAL(obj2) + SCHEME_CPTR_OFFSET(obj2))); } else if (t1 == scheme_wrap_chunk_type) { return vector_equal(obj1, obj2, eql); } else if (t1 == scheme_resolved_module_path_type) { obj1 = SCHEME_PTR_VAL(obj1); obj2 = SCHEME_PTR_VAL(obj2); goto top; } else if (t1 == scheme_place_bi_channel_type) { Scheme_Place_Bi_Channel *bc1, *bc2; bc1 = (Scheme_Place_Bi_Channel *)obj1; bc2 = (Scheme_Place_Bi_Channel *)obj2; return (SAME_OBJ(bc1->recvch, bc2->recvch) && SAME_OBJ(bc1->sendch, bc2->sendch)); } else 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; } 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; } }
/** * Convert a Scheme list or vector to a GVariant that represents an array. */ static GVariant * scheme_object_to_array (Scheme_Object *lv, gchar *type) { Scheme_Object *sval; // One element of the list/array GVariant *gval; // The converted element GVariantBuilder *builder; // Special case: The empty list gives the empty array. if (SCHEME_NULLP (lv)) { // Note: For individual objects, D-Bus type signatures are acceptable // as GVariant type strings. builder = g_variant_builder_new ((GVariantType *) type); if (builder == NULL) return NULL; return g_variant_builder_end (builder); } // if it's null // A list, or so we think. if (SCHEME_PAIRP (lv)) { builder = g_variant_builder_new ((GVariantType *) type); if (builder == NULL) return NULL; // Follow the cons cells through the list while (SCHEME_PAIRP (lv)) { sval = SCHEME_CAR (lv); gval = scheme_object_to_parameter (sval, type+1); if (gval == NULL) { g_variant_builder_unref (builder); return NULL; } // if (gval == NULL) g_variant_builder_add_value (builder, gval); lv = SCHEME_CDR (lv); } // while // We've reached the end. Was it really a list? if (! SCHEME_NULLP (lv)) { g_variant_builder_unref (builder); return NULL; } // If the list does not end in null, so it's not a list. // We've hit the null at the end of the list. return g_variant_builder_end (builder); } // if it's a list // A vector else if (SCHEME_VECTORP (lv)) { int len = SCHEME_VEC_SIZE (lv); int i; LOG ("scheme_object_to_array: Handling a vector of length %d", len); builder = g_variant_builder_new (G_VARIANT_TYPE_ARRAY); if (builder == NULL) return NULL; for (i = 0; i < len; i++) { sval = SCHEME_VEC_ELS(lv)[i]; gval = scheme_object_to_parameter (sval, type + 1); if (gval == NULL) { g_variant_builder_unref (builder); return NULL; } // if we could not convert the object g_variant_builder_add_value (builder, gval); } // for each index return g_variant_builder_end (builder); } // if it's a vector // Can only convert lists and vectors. else return NULL; } // scheme_object_to_array
void TpMzScheme::evalDesign(Design::Ptr d){ DesignStore::Ptr ds = Game::getGame()->getDesignStore(); if (scheme_setjmp(scheme_error_buf)) { Logger::getLogger()->warning("MzScheme Error"); } else { Scheme_Object* temp; std::ostringstream formater; formater.str(""); formater << "(define-values (struct:designType make-designType designType? designType-ref designType-set!)(make-design-type " << ds->getMaxPropertyId() << "))"; temp = scheme_eval_string(formater.str().c_str(), env); temp = scheme_eval_string("(define property-designType-set! (lambda (design id val) (designType-set! design (- id 1) val)))", env); std::set<uint32_t> propids = ds->getPropertyIds(); for(std::set<uint32_t>::iterator propit = propids.begin(); propit != propids.end(); ++propit){ // for each property type Property::Ptr p = ds->getProperty(*propit); if(p){ formater.str(""); formater << "(define designType." << p->getName() << " (make-property-accessor designType-ref " << p->getPropertyId() << " \"" << p->getName() << "\" ))"; temp = scheme_eval_string(formater.str().c_str(), env); } } propids.clear(); IdMap complist = d->getComponents(); temp = scheme_eval_string("(define design (make-designType))", env); for(std::set<uint32_t>::iterator propit = propids.begin(); propit != propids.end(); ++propit){ formater.str(""); formater << "(property-designType-set! design " << *propit << " 0.0)"; temp = scheme_eval_string(formater.str().c_str(), env); } std::map<uint32_t, std::map<uint32_t, std::list<std::string> > > propranking; for(IdMap::iterator compit = complist.begin(); compit != complist.end(); ++compit){ Component::Ptr c = ds->getComponent(compit->first); std::map<uint32_t, std::string> pilist = c->getPropertyList(); for(std::map<uint32_t, std::string>::iterator piit = pilist.begin(); piit != pilist.end(); ++piit){ Property::Ptr p = ds->getProperty(piit->first); for(uint32_t i = 0; i < compit->second; i++){ propranking[p->getRank()][p->getPropertyId()].push_back(piit->second); } } } std::map<uint32_t, PropertyValue> propertyvalues; for(std::map<uint32_t, std::map<uint32_t, std::list<std::string> > >::iterator rpiit = propranking.begin(); rpiit != propranking.end(); ++rpiit){ std::map<uint32_t, std::list<std::string> > pilist = rpiit->second; std::set<PropertyValue> localvalues; for(std::map<uint32_t, std::list<std::string> >::iterator piit = pilist.begin(); piit != pilist.end(); ++piit){ PropertyValue propval(piit->first,0.0); std::list<double> listvals; std::list<std::string> lambdas = piit->second; for(std::list<std::string>::iterator itlamb = lambdas.begin(); itlamb != lambdas.end(); ++itlamb){ temp = scheme_eval_string((std::string("(") + (*itlamb) + " design)").c_str(), env); if(!SCHEME_NUMBERP(temp)){ Logger::getLogger()->warning("MzScheme: Return not a number"); }else{ listvals.push_back(scheme_real_to_double(temp)); } } Property::Ptr p = ds->getProperty(piit->first); formater.str(""); formater << "(" << p->getTpclDisplayFunction() << " design '("; for(std::list<double>::iterator itvals = listvals.begin(); itvals != listvals.end(); ++itvals){ formater << *itvals << " "; } formater << "))"; temp = scheme_eval_string(formater.str().c_str(), env); #ifdef HAVE_MZSCHEME20X if(!SCHEME_PAIRP(temp) || !SCHEME_NUMBERP(SCHEME_CAR(temp)) || !SCHEME_STRINGP(SCHEME_CDR(temp))){ #else if(!SCHEME_PAIRP(temp) || !SCHEME_NUMBERP(SCHEME_CAR(temp)) || !SCHEME_CHAR_STRINGP(SCHEME_CDR(temp))){ #endif Logger::getLogger()->warning("MzScheme: Return not a pair, or the wrong time in the pair"); }else{ propval.setValue(scheme_real_to_double(SCHEME_CAR(temp))); #ifdef HAVE_MZSCHEME20X propval.setDisplayString(std::string(SCHEME_STR_VAL(SCHEME_CDR(temp)))); #else propval.setDisplayString(std::string((char*)SCHEME_CHAR_STR_VAL(SCHEME_CDR(temp)))); #endif localvalues.insert(propval); } } for(std::set<PropertyValue>::iterator pvit = localvalues.begin(); pvit != localvalues.end(); ++pvit){ PropertyValue pv = *pvit; formater.str(""); formater << "(property-designType-set! design " << pv.getPropertyId() << " " << pv.getValue() << ")"; temp = scheme_eval_string(formater.str().c_str(), env); propertyvalues[pv.getPropertyId()] = pv; } } d->setPropertyValues(propertyvalues); // now check if the design is valid bool valid = true; std::string feedback = ""; Logger::getLogger()->debug("About to process requirement functions"); for(IdMap::iterator compit = complist.begin(); compit != complist.end(); ++compit){ uint32_t curval = compit->first; //for each component in the design temp = scheme_eval_string((std::string("(") + ds->getComponent(curval)->getTpclRequirementsFunction() + " design)").c_str(), env); #ifdef HAVE_MZSCHEME20X if(!SCHEME_PAIRP(temp) || !SCHEME_STRINGP(SCHEME_CDR(temp))){ #else if(!SCHEME_PAIRP(temp) || !SCHEME_CHAR_STRINGP(SCHEME_CDR(temp))){ #endif Logger::getLogger()->warning("MzScheme: (a) Return not a pair, or the wrong time in the pair"); }else{ valid &= SCHEME_TRUEP(SCHEME_CAR(temp)); #ifdef HAVE_MZSCHEME20X std::string strtemp = SCHEME_STR_VAL(SCHEME_CDR(temp)); #else std::string strtemp = (char*)SCHEME_CHAR_STR_VAL(SCHEME_CDR(temp)); #endif if(strtemp.length() > 0) feedback += strtemp + " "; } } for(std::map<uint32_t, std::map<uint32_t, std::list<std::string> > >::iterator rpiit = propranking.begin(); rpiit != propranking.end(); ++rpiit){ std::map<uint32_t, std::list<std::string> > pilist = rpiit->second; for(std::map<uint32_t, std::list<std::string> >::iterator piit = pilist.begin(); piit != pilist.end(); ++piit){ temp = scheme_eval_string((std::string("(") + ds->getProperty(piit->first)->getTpclRequirementsFunction() + " design)").c_str(), env); #ifdef HAVE_MZSCHEME20X if(!SCHEME_PAIRP(temp) || !SCHEME_STRINGP(SCHEME_CDR(temp))){ #else if(!SCHEME_PAIRP(temp) || !SCHEME_CHAR_STRINGP(SCHEME_CDR(temp))){ #endif Logger::getLogger()->warning("MzScheme: (a) Return not a pair, or the wrong time in the pair"); }else{ valid &= SCHEME_TRUEP(SCHEME_CAR(temp)); #ifdef HAVE_MZSCHEME20X std::string strtemp = SCHEME_STR_VAL(SCHEME_CDR(temp)); #else std::string strtemp = (char*)SCHEME_CHAR_STR_VAL(SCHEME_CDR(temp)); #endif if(strtemp.length() > 0) feedback += strtemp + " "; } } } propranking.clear(); d->setValid(valid, feedback); Logger::getLogger()->debug("Eval'ed design"); if(!valid){ Logger::getLogger()->debug("Design %s is not valid, reason: %s", d->getName().c_str(), feedback.c_str()); } } } TpMzScheme::TpMzScheme(){ //scheme_set_stack_base(NULL, 1); /* required for OS X, only. WILL NOT WORK HERE */ bool loaded = false; env = scheme_basic_env(); if (scheme_setjmp(scheme_error_buf)) { Logger::getLogger()->warning("MzScheme warning: could not load local file, trying installed file"); } else { scheme_eval_string("(load \"../modules/tpcl/mzscheme/designstruct.scm\")",env); loaded = true; } if(loaded == false){ if (scheme_setjmp(scheme_error_buf)) { Logger::getLogger()->warning("MzScheme warning: could not load installed file"); } else { scheme_eval_string("(load \"" DATADIR "/tpserver/tpscheme/mzscheme/designstruct.scm\")", env); loaded = true; } } if(loaded == false){ Logger::getLogger()->error("MzScheme Error: failed to load designstruct.scm file"); //throw exception? } }
void force_hash_worker(Scheme_Object *so, Scheme_Hash_Table *ht) { if (SCHEME_INTP(so)) { return; } if (ht) { Scheme_Object *r; if ((r = scheme_hash_get(ht, so))) { return; } } switch (so->type) { case scheme_true_type: case scheme_false_type: case scheme_null_type: case scheme_char_type: case scheme_rational_type: case scheme_float_type: case scheme_double_type: case scheme_complex_type: case scheme_char_string_type: case scheme_byte_string_type: case scheme_unix_path_type: case scheme_symbol_type: case scheme_place_bi_channel_type: case scheme_flvector_type: break; case scheme_pair_type: { force_hash_worker(SCHEME_CAR(so), ht); force_hash_worker(SCHEME_CDR(so), ht); } break; case scheme_vector_type: { intptr_t i; intptr_t size = SCHEME_VEC_SIZE(so); for (i = 0; i <size ; i++) { force_hash_worker(SCHEME_VEC_ELS(so)[i], ht); } } break; case scheme_structure_type: { Scheme_Structure *st = (Scheme_Structure*)so; Scheme_Struct_Type *stype = st->stype; intptr_t i; intptr_t size = stype->num_slots; if (stype->prefab_key) force_hash_worker((Scheme_Object*)stype->prefab_key, ht); for (i = 0; i <size ; i++) { force_hash_worker((Scheme_Object*) st->slots[i], ht); } } break; case scheme_resolved_module_path_type: default: scheme_log_abort("cannot force hash"); abort(); break; } if (ht) { scheme_hash_set(ht, so, NULL); } return; }
Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Table *ht) { Scheme_Object *new_so = so; if (SCHEME_INTP(so)) { return so; } if (ht) { Scheme_Object *r; if ((r = scheme_hash_get(ht, so))) { return r; } } switch (so->type) { case scheme_true_type: case scheme_false_type: case scheme_null_type: case scheme_void_type: /* place_bi_channels are allocated in the master and can be passed along as is */ case scheme_place_bi_channel_type: new_so = so; break; case scheme_place_type: new_so = ((Scheme_Place *) so)->channel; break; case scheme_char_type: new_so = scheme_make_char(SCHEME_CHAR_VAL(so)); break; case scheme_rational_type: { Scheme_Object *n; Scheme_Object *d; n = scheme_rational_numerator(so); d = scheme_rational_denominator(so); n = scheme_places_deep_copy_worker(n, ht); d = scheme_places_deep_copy_worker(d, ht); new_so = scheme_make_rational(n, d); } break; case scheme_float_type: new_so = scheme_make_float(SCHEME_FLT_VAL(so)); break; case scheme_double_type: new_so = scheme_make_double(SCHEME_DBL_VAL(so)); break; case scheme_complex_type: { Scheme_Object *r; Scheme_Object *i; r = scheme_complex_real_part(so); i = scheme_complex_imaginary_part(so); r = scheme_places_deep_copy_worker(r, ht); i = scheme_places_deep_copy_worker(i, ht); new_so = scheme_make_complex(r, i); } break; case scheme_char_string_type: new_so = scheme_make_sized_offset_char_string(SCHEME_CHAR_STR_VAL(so), 0, SCHEME_CHAR_STRLEN_VAL(so), 1); break; case scheme_byte_string_type: if (SHARED_ALLOCATEDP(so)) { new_so = so; } else { new_so = scheme_make_sized_offset_byte_string(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1); } break; case scheme_unix_path_type: new_so = scheme_make_sized_offset_path(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1); break; case scheme_symbol_type: if (SCHEME_SYM_UNINTERNEDP(so)) { scheme_log_abort("cannot copy uninterned symbol"); abort(); } else { new_so = scheme_make_sized_offset_byte_string(SCHEME_SYM_VAL(so), 0, SCHEME_SYM_LEN(so), 1); new_so->type = scheme_serialized_symbol_type; } break; case scheme_serialized_symbol_type: new_so = scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(so), SCHEME_BYTE_STRLEN_VAL(so)); break; case scheme_pair_type: { Scheme_Object *car; Scheme_Object *cdr; Scheme_Object *pair; car = scheme_places_deep_copy_worker(SCHEME_CAR(so), ht); cdr = scheme_places_deep_copy_worker(SCHEME_CDR(so), ht); pair = scheme_make_pair(car, cdr); new_so = pair; } break; case scheme_vector_type: { Scheme_Object *vec; intptr_t i; intptr_t size = SCHEME_VEC_SIZE(so); vec = scheme_make_vector(size, 0); for (i = 0; i <size ; i++) { Scheme_Object *tmp; tmp = scheme_places_deep_copy_worker(SCHEME_VEC_ELS(so)[i], ht); SCHEME_VEC_ELS(vec)[i] = tmp; } SCHEME_SET_IMMUTABLE(vec); new_so = vec; } break; case scheme_fxvector_type: if (SHARED_ALLOCATEDP(so)) { new_so = so; } else { Scheme_Vector *vec; intptr_t i; intptr_t size = SCHEME_FXVEC_SIZE(so); vec = scheme_alloc_fxvector(size); for (i = 0; i < size; i++) { SCHEME_FXVEC_ELS(vec)[i] = SCHEME_FXVEC_ELS(so)[i]; } new_so = (Scheme_Object *) vec; } break; case scheme_flvector_type: if (SHARED_ALLOCATEDP(so)) { new_so = so; } else { Scheme_Double_Vector *vec; intptr_t i; intptr_t size = SCHEME_FLVEC_SIZE(so); vec = scheme_alloc_flvector(size); for (i = 0; i < size; i++) { SCHEME_FLVEC_ELS(vec)[i] = SCHEME_FLVEC_ELS(so)[i]; } new_so = (Scheme_Object *) vec; } break; case scheme_structure_type: { Scheme_Structure *st = (Scheme_Structure*)so; Scheme_Serialized_Structure *nst; Scheme_Struct_Type *stype = st->stype; Scheme_Struct_Type *ptype = stype->parent_types[stype->name_pos - 1]; Scheme_Object *nprefab_key; intptr_t size = stype->num_slots; int local_slots = stype->num_slots - (ptype ? ptype->num_slots : 0); int i = 0; if (!stype->prefab_key) { scheme_log_abort("cannot copy non prefab structure"); abort(); } { for (i = 0; i < local_slots; i++) { if (!stype->immutables || stype->immutables[i] != 1) { scheme_log_abort("cannot copy mutable prefab structure"); abort(); } } } nprefab_key = scheme_places_deep_copy_worker(stype->prefab_key, ht); nst = (Scheme_Serialized_Structure*) scheme_make_serialized_struct_instance(nprefab_key, size); for (i = 0; i <size ; i++) { Scheme_Object *tmp; tmp = scheme_places_deep_copy_worker((Scheme_Object*) st->slots[i], ht); nst->slots[i] = tmp; } new_so = (Scheme_Object*) nst; } break; case scheme_serialized_structure_type: { Scheme_Serialized_Structure *st = (Scheme_Serialized_Structure*)so; Scheme_Struct_Type *stype; Scheme_Structure *nst; intptr_t size; int i = 0; size = st->num_slots; stype = scheme_lookup_prefab_type(SCHEME_CDR(st->prefab_key), size); nst = (Scheme_Structure*) scheme_make_blank_prefab_struct_instance(stype); for (i = 0; i <size ; i++) { Scheme_Object *tmp; tmp = scheme_places_deep_copy_worker((Scheme_Object*) st->slots[i], ht); nst->slots[i] = tmp; } new_so = (Scheme_Object*)nst; } break; case scheme_resolved_module_path_type: default: printf("places deep copy cannot copy object of type %hi at %p\n", so->type, so); scheme_log_abort("places deep copy cannot copy object"); abort(); break; } if (ht) { scheme_hash_set(ht, so, new_so); } return new_so; }