static pri *
_find_export(dident functor, dident exporting_module, dident *last_module)
/* Locks: requires ProcListLock. aquires nothing. */
{
pri *pd;
for(pd=DidPtr(functor)->procedure; IsVisibilityPri(pd); pd=pd->nextproc)
{
if (pd->module_def == exporting_module)
{
switch (PriScope(pd))
{
case EXPORT:
*last_module = exporting_module;
return pd;
case IMPEXP:
return _find_export(functor, pd->module_ref, last_module);
default:
*last_module = exporting_module;
return 0;
}
}
}
*last_module = exporting_module;
return 0;
}
static void
_remove_incompatible_uses(pri *def) /* must be the definition module descriptor */
/* Locks: requires ProcListLock. acquires nothing. */
{
pri *use;
if (!PriExported(def))
return ;
for(use = DidPtr(PriDid(def))->procedure; use; use = use->nextproc)
{
if (PriIsProxy(use) && use->module_ref == def->module_ref)
{
if (!_compatible_def_use(def, use))
{
/* attempt to undo the impossible def-use link */
switch (PriScope(use))
{
case IMPORT: Pri_Set_Scope(use, LOCAL); break;
case IMPEXP: Pri_Set_Scope(use, EXPORT); break;
case QUALI: break;
}
use->module_ref = use->module_def;
}
}
}
}
static pri*
_new_visible_pri(dident functor, dident module, module_item *module_property, int visibility)
{
pri *pd = _new_pri(functor, module);
pd->flags |= VMCODE|ARGFIXEDWAM|visibility
|PriPriorityFlags(SUSP_EAGER_PRIO);
/* insert it at the beginning of the functor list */
pd->nextproc = DidPtr(functor)->procedure;
DidPtr(functor)->procedure = pd;
/* insert it at the beginning of the module list */
if (!module_property)
module_property = ModuleItem(module);
pd->next_in_mod = module_property->procedures;
module_property->procedures = pd;
return pd;
}
/*
* When a new IMPEXP descriptor is created, find all descriptors that point
* to it and forward their module_ref to the (now known) definition module.
*/
static void
_deref_chains(pri *new_impexp) /* a new IMPEXP maximally dereferenced */
/* Locks: requires ProcListLock. aquires nothing. */
{
pri *pd;
for(pd=DidPtr(new_impexp->did)->procedure; pd; pd=pd->nextproc)
{
if (PriIsProxy(pd) && pd->module_ref == new_impexp->module_def)
{
pd->module_ref = new_impexp->module_ref;
}
}
}
static pri *
_current_visible(dident functor, dident module)
/* Locks: requires ProcListLock. aquires nothing. */
{
pri *pd;
for(pd=DidPtr(functor)->procedure; IsVisibilityPri(pd); pd=pd->nextproc)
{
if (pd->module_def == module)
return pd;
}
return 0;
}
static void
_update_all_uses(pri *def) /* must be the definition module descriptor */
/* Locks: requires ProcListLock. acquires nothing. */
{
pri *use;
if (!PriExported(def))
return;
for(use = DidPtr(PriDid(def))->procedure; use; use = use->nextproc)
{
if (PriIsProxy(use) && use->module_ref == def->module_ref)
{
_update_def_use(def, use);
}
}
}
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_;
}
static int
_procedure_referenced(pri *pd)
/* Locks: requires nothing. acquires ProcListLock. */
{
dident definition_module;
if (PriReferenced(pd))
return 1;
if (!PriExported(pd))
return 0;
a_mutex_lock(&ProcListLock);
definition_module = pd->module_def;
for(pd = DidPtr(pd->did)->procedure; pd; pd = pd->nextproc)
{
if (pd->module_ref == definition_module && PriReferenced(pd))
{
a_mutex_unlock(&ProcListLock);
return 1;
}
}
a_mutex_unlock(&ProcListLock);
return 0;
}
/*
pr(Name/Arity)
prints on the current_output the properties of a predicate
in all modules.
*/
static int
p_pr(value v, type t)
{
pri *proc;
dident wdid;
dident module;
int flags;
int yes = 0;
Get_Proc_Did(v, t, wdid);
proc = DidPtr(wdid)->procedure;
while (proc)
{
module = proc->module_def;
if (!module
#ifndef PRINTAM
|| (IsLocked(module) && !PriExported(proc))
#endif
)
{
proc = proc->nextproc;
continue;
}
yes = 1;
p_fprintf(log_output_, "in %s: ", DidName(module));
if (SystemProc(proc))
p_fprintf(log_output_, "system ");
if (proc->flags & AUTOLOAD)
(void) ec_outfs(log_output_, "autoload ");
if (proc->flags & PROC_DYNAMIC) {
(void) ec_outfs(log_output_, "dynamic ");
} else {
(void) ec_outfs(log_output_, "static ");
}
switch(proc->flags & CODETYPE) {
case VMCODE:
(void) ec_outfs(log_output_, "vmcode ");
break;
case FUNPTR:
(void) ec_outfs(log_output_, "funptr ");
break;
default:
(void) ec_outfs(log_output_, "code? ");
break;
}
switch(proc->flags & ARGPASSING) {
case ARGFIXEDWAM:
(void) ec_outfs(log_output_, "argfixedwam ");
break;
case ARGFLEXWAM:
(void) ec_outfs(log_output_, "argflexwam ");
break;
default:
(void) ec_outfs(log_output_, "? ");
break;
}
if (proc->flags & EXTERN)
{
(void) ec_outfs(log_output_, "external");
switch(proc->flags & UNIFTYPE) {
case U_NONE:
(void) ec_outfs(log_output_, "_u_none ");
break;
case U_SIMPLE:
(void) ec_outfs(log_output_, "_u_simple ");
break;
case U_GROUND:
(void) ec_outfs(log_output_, "_u_ground ");
break;
case U_UNIFY: /* equal to fresh */
(void) ec_outfs(log_output_, "_u_unify ");
break;
case U_GLOBAL:
(void) ec_outfs(log_output_, "_u_global ");
break;
case U_DELAY:
(void) ec_outfs(log_output_, "_u_delay ");
break;
default:
(void) ec_outfs(log_output_, "_u_? ");
break;
}
}
else
{
(void) ec_outfs(log_output_, "prolog ");
}
flags = proc->flags;
if (flags & TOOL)
(void) ec_outfs(log_output_, "tool ");
switch (PriScope(proc))
{
case EXPORT:
(void) ec_outfs(log_output_, "exported "); break;
case LOCAL:
(void) ec_outfs(log_output_, "local "); break;
case IMPORT:
(void) ec_outfs(log_output_, "imported "); break;
case DEFAULT:
(void) ec_outfs(log_output_, "default "); break;
case QUALI:
(void) ec_outfs(log_output_, "qualified "); break;
}
p_fprintf(log_output_, "%s ", DidName(proc->module_ref));
if (flags & DEBUG_DB)
(void) ec_outfs(log_output_, "debugged ");
if (flags & DEBUG_ST)
(void) ec_outfs(log_output_, "start_tracing ");
if (flags & DEBUG_TR)
(void) ec_outfs(log_output_, "traceable ");
else
(void) ec_outfs(log_output_, "untraceable ");
if (flags & DEBUG_SP)
(void) ec_outfs(log_output_, "spied ");
if (flags & DEBUG_SK)
(void) ec_outfs(log_output_, "skipped ");
if (!PriReferenced(proc))
(void) ec_outfs(log_output_, "non_referenced ");
if (flags & CODE_DEFINED)
(void) ec_outfs(log_output_, "code_defined ");
proc = proc->nextproc;
(void) ec_outfs(log_output_, "\n");
}
if (yes)
{
Succeed_;
}
else
{
Fail_;
}
}
