static int
_heap_arr_set(t_ext_ptr h,
int i,
pword pw) /* expected to be dereferenced */
{
pword copy_pw;
pword *pheap;
int err, arity;
pheap = ((t_heap_array*)h)->array;
arity = DidArity(pheap[0].val.did);
if (i >= 1 && i <= arity)
{
if ((err = create_heapterm(©_pw, pw.val, pw.tag)) != PSUCCEED)
{ Bip_Error(err); }
a_mutex_lock(&SharedDataLock);
free_heapterm(&pheap[i]);
move_heapterm(©_pw, &pheap[i]);
a_mutex_unlock(&SharedDataLock);
}
else if (i == 0)
{
if (IsStructure(pw.tag) && pw.val.ptr->val.did == pheap[0].val.did)
{
pword *aux = TG;
Push_Struct_Frame(pheap[0].val.did);
for (i=1; i<=arity; ++i)
{
pword *parg = &pw.val.ptr[i];
Dereference_(parg);
if ((err = create_heapterm(aux+i, parg->val, parg->tag)) != PSUCCEED)
{
TG = aux;
Bip_Error(err);
}
}
a_mutex_lock(&SharedDataLock);
for (i=1; i<=arity; ++i)
{
free_heapterm(&pheap[i]);
move_heapterm(aux+i, &pheap[i]);
}
a_mutex_unlock(&SharedDataLock);
TG = aux;
}
else { Bip_Error(RANGE_ERROR); }
}
else
{ Bip_Error(RANGE_ERROR); }
Succeed_;
}
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 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;
}
}
