pri *
pri_home(pri *pd)
{
type tm;
if (pd->module_ref == pd->module_def)
return pd;
if (pd->module_ref == D_UNKNOWN)
{
Set_Bip_Error(NOENTRY);
return 0;
}
tm.kernel = ModuleTag(pd->module_ref);
return visible_procedure(pd->did, pd->module_ref, tm, PRI_DONTIMPORT);
}
static int
p_tool_body(value vi, type ti, value vb, type tb, value vmb, type tmb, value vm, type tm)
{
dident di;
pri *procb, *proci;
int flags, arity;
dident module;
dident pdid;
pword *ptr = Gbl_Tg;
vmcode *code;
int err;
Prepare_Requests;
Check_Module(tm, vm);
Get_Proc_Did(vi, ti, di);
if (!IsRef(tb)
&& (!IsStructure(tb)
|| vb.ptr->val.did != d_.quotient))
{
Bip_Error(TYPE_ERROR);
}
Check_Output_Atom_Or_Nil(vmb, tmb);
if (!(proci = visible_procedure(di, vm.did, tm, PRI_CREATE)))
{
Get_Bip_Error(err);
Bip_Error(err);
}
if (!_tool_body(proci, &pdid, &arity, &module))
{
Get_Bip_Error(err);
Bip_Error(err);
}
Gbl_Tg += 3;
Check_Gc;
ptr[0].tag.kernel = TDICT;
ptr[0].val.did = d_.quotient;
ptr[1].tag.kernel = TDICT;
ptr[1].val.did = add_dict(pdid, 0);
ptr[2].tag.kernel = TINT;
ptr[2].val.nint = arity;
Request_Unify_Atom(vmb, tmb, module);
Request_Unify_Structure(vb, tb, ptr);
Return_Unify;
}
/*
tool_(Name/Arity, SourceModule)
set the tool flag of Name/Arity in SourceModule.
*/
static int
p_tool1(value vi, type ti, value vm, type tm)
{
#if 0
dident di;
pri *proci, *pd;
int err;
Check_Module(tm, vm);
Get_Proc_Did(vi, ti, di);
proci = visible_procedure(di, vm.did, tm, PRI_CREATE);
if (!proci)
{
Get_Bip_Error(err);
Bip_Error(err);
}
if (proci->flags & TOOL)
{
Succeed_;
}
err = pri_compatible_flags(proci, TOOL, TOOL);
if (err != PSUCCEED)
{
Bip_Error(err);
}
pri_change_flags(proci, TOOL, TOOL);
if (PriCodeType(proci) == VMCODE)
{
/* keep the old code, e.g. autoload_code... */
/* update the code header, important for saving the arguments
* in the event mechanism */
Incr_Code_Arity(PriCode(proci));
}
Succeed_;
#else
Bip_Error(NOT_IMPLEMENTED);
#endif
}
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_;
}
