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 *
_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;
}
void
print_pri(pri *pd)
{
switch(PriScope(pd))
{
case QUALI: p_fprintf(current_output_, "QUALI "); break;
case LOCAL: p_fprintf(current_output_, "LOCAL "); break;
case EXPORT: p_fprintf(current_output_, "EXPORT "); break;
case IMPORT: p_fprintf(current_output_, "IMPORT "); break;
case DEFAULT: p_fprintf(current_output_, "DEFAUL "); break;
case IMPEXP: p_fprintf(current_output_, "IMPEXP "); break;
default: p_fprintf(current_output_, "?????? "); break;
}
p_fprintf(current_output_, "in %12s from %12s",
DidName(pd->module_def),
pd->module_ref? DidName(pd->module_ref) : "UNKNOWN");
p_fprintf(current_output_, " %c%c%c %c %c%c%c%c%c %c%c%c%c%c %c%c%c %01x p%d",
pd->flags&SYSTEM ? 'S' : '_',
pd->flags&NOREFERENCE ? 'N' : '_',
pd->flags&CODE_DEFINED ? 'C' : '_',
pd->flags&TO_EXPORT ? 'X' : '_',
pd->flags&PROC_PARALLEL ? 'P' : '_',
pd->flags&PROC_DEMON ? 'D' : '_',
pd->flags&TOOL ? 'T' : '_',
pd->flags&AUTOLOAD ? 'A' : '_',
pd->flags&PROC_DYNAMIC ? 'Y' : '_',
pd->flags&DEBUG_TR ? 'T' : '_',
pd->flags&DEBUG_SP ? 'P' : '_',
pd->flags&DEBUG_SK ? 'K' : '_',
pd->flags&DEBUG_DB ? 'D' : '_',
pd->flags&DEBUG_ST ? 'S' : '_',
(pd->flags&(CODETYPE)) == VMCODE ? 'v' : 'f',
(pd->flags&(ARGPASSING)) == ARGFIXEDWAM ? 'a' :
(pd->flags&(ARGPASSING)) == ARGFLEXWAM ? 'f' : '?',
pd->flags&EXTERN ? 'X' : '_',
pd->flags&(UNIFTYPE),
PriPriority(pd));
if (!PriCode(pd))
p_fprintf(current_output_, " null_code");
else if ((PriCodeType(pd) == VMCODE) && IsUndefined(PriCode(pd)))
p_fprintf(current_output_, " undef_code");
else
p_fprintf(current_output_, " 0x%x", PriCode(pd));
ec_newline(current_output_);
}
void
pri_statistics(void)
{
int idx = 0;
dident mod;
int count[6];
while (next_functor(&idx, &mod))
{
if (IsModule(mod))
{
pri *pd;
int i;
for(i=0;i<6;++i) count[i] = 0;
for (pd = ModuleItem(mod)->procedures; pd; pd = pd->next_in_mod)
{
switch(PriScope(pd))
{
case QUALI: ++count[0]; break;
case LOCAL: ++count[1]; break;
case EXPORT: ++count[2]; break;
case IMPORT: ++count[3]; break;
case DEFAULT: ++count[4]; break;
case IMPEXP: ++count[5]; break;
default: p_fprintf(current_err_, "Illegal scope %s\n", PriScope(pd)); break;
}
}
p_fprintf(log_output_, "\nModule: %s\n", DidName(mod));
p_fprintf(log_output_, " QUALI=%d", count[0]);
p_fprintf(log_output_, " LOCAL=%d", count[1]);
p_fprintf(log_output_, " EXPORT=%d", count[2]);
p_fprintf(log_output_, " IMPORT=%d", count[3]);
p_fprintf(log_output_, " DEFAULT=%d", count[4]);
p_fprintf(log_output_, " IMPEXP=%d", count[5]);
ec_newline(log_output_);
}
}
}
static int
p_tool2(value vi, type ti, value vb, type tb, value vm, type tm)
{
dident di, db;
pri *procb, *proci;
uint32 changed_flags, new_flags;
pri_code_t pricode;
int err;
Check_Module(tm, vm);
Get_Proc_Did(vi, ti, di);
Get_Proc_Did(vb, tb, db);
if (DidArity(di) + 1 != DidArity(db))
{
Bip_Error(RANGE_ERROR);
}
if (vm.did == d_.kernel_sepia)
proci = export_procedure(di, vm.did, tm);
else
proci = local_procedure(di, vm.did, tm, PRI_CREATE);
if (!proci)
{
Get_Bip_Error(err);
Bip_Error(err);
}
procb = visible_procedure(db, vm.did, tm, PRI_CREATE);
if (!procb)
{
Get_Bip_Error(err);
Bip_Error(err);
}
/* Incompatbilities of being a TOOL */
if (DynamicProc(proci))
{
Bip_Error(INCONSISTENCY);
}
/* Incompatbilities of being a tool body */
if (PriFlags(procb) & TOOL)
{
Bip_Error(INCONSISTENCY);
}
changed_flags = TOOL|TOOL_INHERIT_FLAGS|DEBUG_DB|SYSTEM;
new_flags = TOOL
|(TOOL_INHERIT_FLAGS & procb->flags)
|(GlobalFlags & DBGCOMP ? DEBUG_DB : 0)
|(vm.did == d_.kernel_sepia ? SYSTEM : 0);
err = pri_compatible_flags(proci, changed_flags, new_flags);
if (err != PSUCCEED)
{
Bip_Error(err);
}
pri_change_flags(proci, changed_flags & ~CODETYPE, new_flags & ~CODETYPE);
Pri_Set_Reference(procb);
proci->mode = procb->mode;
pricode.vmc = _tool_code(procb, GlobalFlags & DBGCOMP);
pri_define_code(proci, procb->flags & CODETYPE, pricode);
/* make sure the tool body is exported or reexported, so it can
* be invoked with a qualified call with lookup module vm */
if (!PriAnyExp(procb) && !PriWillExport(procb))
{
if (PriScope(procb) == IMPORT)
procb = reexport_procedure(db, vm.did, tm, PriHomeModule(procb));
else
procb = export_procedure(db, vm.did, tm);
if (!procb)
{
Get_Bip_Error(err);
Bip_Error(err);
}
}
Succeed_;
}
/*
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_;
}
}