static void
dbag_port_upcall(aport_id_t bag_aport_id)
{
dbag_descr_t *dbag_descr;
amsg_ret_t ret;
amsg_count_t size;
amsg_t msg;
amsg_data_t *msg_data;
if (aport_get_option(bag_aport_id, APORT_DATA_PTR,
(aport_optval_t *) &dbag_descr) != AMSG_OK)
{
p_fprintf(current_err_, "aport_get_option() failed\n");
ec_flush(current_err_);
}
while ((ret = amsg_receive(bag_aport_id, &msg, &msg_data,
(amsg_type_t *) 0, &size, 0)) != AMSG_NOMESSAGE)
{
if (ret != AMSG_OK)
{
p_fprintf(current_err_, "amsg_receive() failed\n");
ec_flush(current_err_);
continue;
}
/*
* Handle one message: Add message buffer to the bag
*/
dbag_descr->last->msg = msg;
dbag_descr->last->msg_data_hdr = (amsg_ref_t *) msg_data;
dbag_descr->last = (amsg_ref_t *) msg_data;
dbag_descr->last->msg_data_hdr = &dbag_descr->first;
}
}
void
print_procedure(dident wdid, vmcode *code)
{
extern int als(word addr);
p_fprintf(current_output_, "\n%s/", DidName(wdid));
p_fprintf(current_output_, "%d:\n", DidArity(wdid));
(void) als((word) code);
ec_flush(current_output_);
}
static int
_compatible_def_use(pri *def, pri *use)
{
uint32 conflicts;
char *reason = NULL;
/* if not yet referenced, any change is allowed */
if (!PriReferenced(use))
return 1;
/* don't allow changing certain flags */
conflicts = (def->flags ^ use->flags) &
(use->flags & CODE_DEFINED ?
PF_DONT_CHANGE_WHEN_DEFINED :
PF_DONT_CHANGE_WHEN_REFERENCED);
if (conflicts)
{
if (conflicts & TOOL)
reason = "tool declaration";
else if (conflicts & PROC_DYNAMIC)
reason = "static/dynamic";
else if (conflicts & PROC_DEMON)
reason = "demon declaration";
else if (conflicts & PROC_PARALLEL)
reason = "parallel declaration";
else if (conflicts & (CODETYPE|ARGPASSING|UNIFTYPE))
reason = "calling convention";
else
reason = "predicate properties";
}
/* other restrictions when already referenced */
if (def->mode != use->mode)
reason = "mode declaration";
if (def->trans_function != use->trans_function)
reason = "inline declaration";
if (reason)
{
p_fprintf(warning_output_,
"Definition of %s/%d in module %s is incompatible (%s) with call in module %s\n",
DidName(def->did), DidArity(def->did), DidName(def->module_def),
reason, DidName(use->module_def));
ec_flush(warning_output_);
return 0;
}
return 1;
}
static void
_free_heap_array(t_heap_array *obj) /* obj != NULL */
{
if (--obj->ref_ctr <= 0)
{
pword *p = obj->array;
int arity = DidArity(p[0].val.did);
int i;
for (i = arity; i > 0; --i)
{
free_heapterm(&p[i]);
}
hg_free_size(obj, sizeof(t_heap_array) + arity*sizeof(pword));
#ifdef DEBUG_RECORD
p_fprintf(current_err_, "\n_free_heap_array(0x%x)", obj);
ec_flush(current_err_);
#endif
}
}
static int
cpx_prepare_solve(lp_desc* lpd, struct lp_meth *meth,
struct lp_sol *sol, double timeout)
{
#ifdef HAS_MIQP_CALLBACKBUG
/* too much trouble to support MIQP with older XPRESS with this bug;
the MIQP method is `not recommended' for use in these versions
by DASH in anycase
*/
switch (lpd->prob_type)
{
case PROBLEM_MIQP:
case PROBLEM_FIXEDQ:
case PROBLEM_RELAXEDQ:
Fprintf(Current_Error, "Eplex error: quadratic MIP not supported for this solver because it is unstable.\n");
ec_flush(Current_Error);
return -1;
}
#endif
CallN(XPRSsetintcontrol(lpd->lp, XPRS_SOLUTIONFILE, 0));
/* set up call-back to get solution state at each integer solution */
if (IsMIPProb(lpd->prob_type))
{
CallN(XPRSsetcbintsol(lpd->lp, _get_xpress_sol, (void *)sol));
}
if (timeout >= 0.0)
{
/* 0 is no timeout, negative for desired semantics */
int timeout_i;
timeout = ceil(timeout); /* avoid round to zero and overflow */
timeout_i = timeout > INT_MAX ? INT_MAX : (int)timeout;
Log1(XPRSsetintcontrol(lpd->lp, XPRS_MAXTIME, %d), -timeout_i);
XPRSsetintcontrol(lpd->lp, XPRS_MAXTIME, -timeout_i);
}
void
mark_dids_from_properties(property *prop_list)
{
for (; prop_list; prop_list = prop_list->next_prop)
{
register property *p = prop_list;
do
{
if (p->module != D_UNKNOWN)
{
switch (p->name)
{
case ARRAY_PROP:
mark_dids_from_array(&p->property_value);
break;
case GLOBVAR_PROP:
mark_dids_from_heapterm(&p->property_value);
break;
case HTABLE_PROP:
{
extern t_ext_type heap_htable_tid;
heap_htable_tid.mark_dids((t_ext_ptr)p->property_value.val.wptr);
}
break;
case SHELF_PROP:
{
extern t_ext_type heap_array_tid;
heap_array_tid.mark_dids((t_ext_ptr)p->property_value.val.wptr);
}
break;
case IDB_PROP:
{
extern t_ext_type heap_rec_header_tid;
heap_rec_header_tid.mark_dids((t_ext_ptr)p->property_value.val.wptr);
}
break;
case TRANS_PROP:
case WRITE_TRANS_PROP:
case GOAL_TRANS_PROP:
case WRITE_GOAL_TRANS_PROP:
case CLAUSE_TRANS_PROP:
case WRITE_CLAUSE_TRANS_PROP:
{
macro_desc *md = (macro_desc *) p->property_value.val.ptr;
Mark_Did(md->trans_function);
Mark_Did(md->module);
}
break;
case MODULE_PROP:
{
module_item *m = (module_item *) p->property_value.val.ptr;
register didlist *scan;
for (scan = m->imports; scan; scan = scan->next)
{
Mark_Did(scan->name);
}
}
break;
case STREAM_PROP: /* just an integer */
break;
case PREFIX_PROP: /* did */
case INFIX_PROP: /* did */
case POSTFIX_PROP: /* did */
case SYSCALL_PROP: /* did or integer */
case EVENT_PROP: /* pri */
mark_dids_from_pwords(&p->property_value, &p->property_value + 1);
break;
default:
p_fprintf(current_err_, "Unknown property type %d in mark_dids_from_properties()\n", p->name);
ec_flush(current_err_);
break;
}
}
p = p->next_mod;
} while (p != prop_list);
}
}
static void
free_prop_value(int prop_name, pword *prop_value)
{
switch(prop_name)
{
case GLOBVAR_PROP:
if (IsGlobalPrologRef(prop_value)) {
ec_ref_destroy((ec_ref) prop_value->val.wptr);
prop_value->val.wptr = NULL;
}
/* If we are erasing the last global ref, decrement the global index */
else if (IsGlobalPrologRefIndex(prop_value) &&
prop_value->val.nint == (GlobalVarIndex - 1))
{
GlobalVarIndex--;
}
else
{
free_heapterm(prop_value);
}
break;
case ARRAY_PROP:
free_array(prop_value);
break;
case IDB_PROP:
{
extern t_ext_type heap_rec_header_tid;
heap_rec_header_tid.free((t_ext_ptr)prop_value->val.wptr);
break;
}
case HTABLE_PROP:
{
extern t_ext_type heap_htable_tid;
heap_htable_tid.free((t_ext_ptr)prop_value->val.wptr);
break;
}
case SHELF_PROP:
{
extern t_ext_type heap_array_tid;
heap_array_tid.free((t_ext_ptr)prop_value->val.wptr);
break;
}
case MODULE_PROP:
case TRANS_PROP:
case WRITE_TRANS_PROP:
case GOAL_TRANS_PROP:
case WRITE_GOAL_TRANS_PROP:
case CLAUSE_TRANS_PROP:
case WRITE_CLAUSE_TRANS_PROP:
hg_free((generic_ptr)prop_value->val.ptr);
break;
case EVENT_PROP:
case STREAM_PROP:
case PREFIX_PROP:
case INFIX_PROP:
case POSTFIX_PROP:
case SYSCALL_PROP:
break;
default:
p_fprintf(current_err_, "Unknown property type %d in free_prop_value()\n", prop_name);
ec_flush(current_err_);
break;
}
}
