static int
p_erase_module(value module, type module_tag, value from_mod, type tfrom_mod)
{
module_item *pm, *import_pm;
int i;
didlist *lib_scan;
pword *prop;
Check_Module(tfrom_mod, from_mod);
Check_Atom_Or_Nil(module, module_tag);
if (!IsModule(module.did))
{
Succeed_;
} else if (IsLocked(module.did)
&& (from_mod.did != d_.kernel_sepia
|| !IsModuleTag(from_mod.did, tfrom_mod)))
{
Bip_Error(LOCKED);
}
/*
* This is a big mess with respect to locking. The erased module's
* descriptor is unprotected. It should be first removed as property
* and then cleaned up.
*/
pm = ModuleItem(module.did);
/* first, clean the procedures, we can reclaim the space */
erase_module_procs(pm->procedures);
hg_free_size((generic_ptr) pm->syntax, sizeof(syntax_desc));
/* reclaim the properties */
erase_module_props(pm->properties);
/* reclaim module descriptor */
(void) erase_property(module.did, MODULE_PROP);
DidPtr(module.did)->module = 0;
Succeed_;
}
void
delete_duet_from_chain(dident the_name, didlist **chain)
{
didlist *current_duet;
current_duet = *chain;
while(current_duet)
{
if (current_duet->name == the_name)
{
*chain = current_duet->next;
hg_free_size((generic_ptr) current_duet, sizeof(didlist));
break;
}
chain = &(current_duet->next);
current_duet = current_duet->next;
}
}
void
delete_proc_from_chain(pri *p, proc_duet **chain)
/* Locks: requires ProcChainLock. aquires nothing. */
{
proc_duet *current_gd;
current_gd = *chain;
while (current_gd)
{
if (current_gd->desc == p)
{ /* found, so delete it from the chain */
*chain = current_gd->next;
hg_free_size((generic_ptr) current_gd, sizeof(proc_duet));
break;
}
chain = ¤t_gd->next;
current_gd = current_gd->next;
}
}
void
erase_module_props(property *prop_list)
{
register property *p;
while(prop_list)
{
p = prop_list->next_mod;
while (p->next_mod != prop_list)
p = p->next_mod;
p->next_mod = prop_list->next_mod;
p = prop_list;
prop_list = prop_list->next_prop;
free_prop_value((int) p->name, &p->property_value);
hg_free_size((generic_ptr) p, sizeof(property));
}
}
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_pri(pri *pd)
{
hg_free_size((generic_ptr)pd, sizeof(pri));
}
int
erase_modular_property(dident functor, int property_name, dident module, type mod_tag, int which)
{
register property *p, **prev_p;
int res;
module_item *pm;
if (which != GLOBAL_PROP && IsLocked(module)
&& !IsModuleTag(module, mod_tag))
{
return LOCKED;
}
/* this lookup must be before the lock */
if (which != GLOBAL_PROP)
pm = (module_item *) (get_property(module, MODULE_PROP))->val.ptr;
a_mutex_lock(&PropListLock);
/* get pointer to property list from atom */
prev_p = &(DidProperties(functor));
p = *prev_p;
/* scan property list until an entry for property is found or end */
while (p)
{
if (p->name == property_name)
{
if (which != GLOBAL_PROP)
{
register property *m, **prev_m;
prev_m = &(p->next_mod);
m = *prev_m;
while (m != p) /* scan module list */
{
if (m->module == module)
{ /* erase the local */
*prev_m = m->next_mod;
_rem_from_module_entry(m, pm);
free_prop_value(property_name, &m->property_value);
hg_free_size((generic_ptr) m, sizeof(property));
if (p->next_mod == p && p->module == D_UNKNOWN)
{ /* all erased, remove head descriptor */
*prev_p = p->next_prop;
hg_free_size((generic_ptr) p, sizeof(property));
/* this is not an error, it is a message
to notify that the property is erased
completely */
res = PFAIL;
goto _unlock_return_;
}
res = PSUCCEED;
goto _unlock_return_;
}
prev_m = &(m->next_mod);
m = *prev_m;
}
}
if (which != LOCAL_PROP && p->module != D_UNKNOWN)
{ /* erase the global */
free_prop_value(property_name, &p->property_value);
if (p->next_mod == p)
{ /* no locals: remove global descriptor */
*prev_p = p->next_prop;
hg_free_size((generic_ptr) p, sizeof(property));
/* this is not an error, it is a message to notify
that the property is erased completely */
res = PFAIL;
goto _unlock_return_;
}
else
p->module = D_UNKNOWN; /* just mark it unused */
res = PSUCCEED;
goto _unlock_return_;
}
res = PERROR;
goto _unlock_return_; /* should give a warning */
}
prev_p = &(p->next_prop);
p = *prev_p;
}
res = PERROR;
_unlock_return_:
a_mutex_unlock(&PropListLock);
return(res);
}
