Scheme_Object *extract_exn_message(Scheme_Object *v) { init_exn_catching_apply(); if (SCHEME_TRUEP(_scheme_apply(exn_p, 1, &v))) return _scheme_apply(exn_message, 1, &v); else return NULL; /* Not an exn structure */ }
Scheme_Object *scheme_rational_round(const Scheme_Object *o) { Scheme_Rational *r = (Scheme_Rational *)o; Scheme_Object *q, *qd, *delta, *half; int more = 0, can_eq_half, negative; negative = !scheme_is_rational_positive(o); q = scheme_bin_quotient(r->num, r->denom); /* Get remainder absolute value: */ qd = scheme_bin_mult(q, r->denom); if (negative) delta = scheme_bin_minus(qd, r->num); else delta = scheme_bin_minus(r->num, qd); half = scheme_bin_quotient(r->denom, scheme_make_integer(2)); can_eq_half = SCHEME_FALSEP(scheme_odd_p(1, &r->denom)); if (SCHEME_INTP(half) && SCHEME_INTP(delta)) { if (can_eq_half && (SCHEME_INT_VAL(delta) == SCHEME_INT_VAL(half))) more = SCHEME_TRUEP(scheme_odd_p(1, &q)); else more = (SCHEME_INT_VAL(delta) > SCHEME_INT_VAL(half)); } else if (SCHEME_BIGNUMP(delta) && SCHEME_BIGNUMP(half)) { if (can_eq_half && (scheme_bignum_eq(delta, half))) more = SCHEME_TRUEP(scheme_odd_p(1, &q)); else more = !scheme_bignum_lt(delta, half); } else more = SCHEME_BIGNUMP(delta); if (more) { if (negative) q = scheme_sub1(1, &q); else q = scheme_add1(1, &q); } return q; }
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; }
/* 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 void sfs_restore_one_branch(SFS_Info *info, int ip, Scheme_Object *vec, int delta) { int t_min_t, t_cnt, i; Scheme_Object *t_vec; t_vec = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 1]; if (SCHEME_FALSEP(t_vec)) return; t_min_t = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[delta * SFS_BRANCH_W]); t_cnt = SCHEME_VEC_SIZE(t_vec); for (i = 0; i < t_cnt; i++) { if (SCHEME_TRUEP(SCHEME_VEC_ELS(t_vec)[i])) info->max_used[i + t_min_t] = ip; } }
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 int is_equal_overflow(Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) { Scheme_Thread *p = scheme_current_thread; Equal_Info *eql2; Scheme_Object *v; eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info)); memcpy(eql2, eql, sizeof(Equal_Info)); p->ku.k.p1 = (void *)obj1; p->ku.k.p2 = (void *)obj2; p->ku.k.p3 = (void *)eql2; v = scheme_handle_stack_overflow(equal_k); memcpy(eql, eql2, sizeof(Equal_Info)); return SCHEME_TRUEP(v); }
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; } }
/** * Import all of the methods from a LouDBusProxy. */ Scheme_Object * loudbus_import (int argc, Scheme_Object **argv) { Scheme_Env *env = NULL; // The environment GDBusMethodInfo *method; // Information on one method LouDBusProxy *proxy; // The proxy int m; // Counter variable for methods int n; // The total number of methods int arity; // The arity of a method gchar *prefix = NULL; // The prefix we use gchar *external_name; // The name we use in Scheme int dashes; // Convert underscores to dashes? // Annotations and other stuff for garbage collection. MZ_GC_DECL_REG (3); MZ_GC_VAR_IN_REG (0, argv); MZ_GC_VAR_IN_REG (1, env); MZ_GC_VAR_IN_REG (2, prefix); MZ_GC_REG (); // Get the proxy proxy = scheme_object_to_proxy (argv[0]); if (proxy == NULL) { MZ_GC_UNREG (); scheme_wrong_type ("loudbus-import", "LouDBusProxy *", 0, argc, argv); } // if (proxy == NULL) // Get the prefix prefix = scheme_object_to_string (argv[1]); if (prefix == NULL) { MZ_GC_UNREG (); scheme_wrong_type ("loudbus-import", "string", 1, argc, argv); } // if (prefix == NULL) // Get the flag if (! SCHEME_BOOLP (argv[2])) { MZ_GC_UNREG (); scheme_wrong_type ("loudbus-import", "Boolean", 2, argc, argv); } // if (!SCHEME_BOOLB (argv[2]) dashes = SCHEME_TRUEP (argv[2]); // Get the current environment, since we're mutating it. env = scheme_get_env (scheme_current_config ()); // Process the methods n = g_dbus_interface_info_num_methods (proxy->iinfo); for (m = 0; m < n; m++) { method = proxy->iinfo->methods[m]; arity = g_dbus_method_info_num_formals (method); external_name = g_strdup_printf ("%s%s", prefix, method->name); if (external_name != NULL) { if (dashes) { dash_it_all (external_name); } // if (dashes) // And add the procedure LOG ("loudbus-import: adding %s as %s", method->name, external_name); loudbus_add_dbus_proc (env, argv[0], method->name, external_name, arity); // Clean up g_free (external_name); } // if (external_name != NULL) } // for each method // And we're done. MZ_GC_UNREG (); return scheme_void; } // loudbus_import
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? } }
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; } } } }