static void
_update_def_use(pri *def, pri *use)
{
/* Note on memory management of code blocks:
* Undefined-code blocks are never shared between descriptors,
* so don't copy pointers to them.
* Defined-code is shared and pointed to from all descriptors.
*/
if ((PriCodeType(use) == VMCODE) && !(PriFlags(use) & CODE_DEFINED))
{
if (PriFlags(def) & CODE_DEFINED)
{
remove_procedure(use); /* undefined -> defined */
use->code = def->code;
}
else if (!use->code.vmc) /* undefined -> undefined */
_pri_init_vmcode(use, PriFlags(def)&TOOL);
/* else keep undefined-code field */
}
else
{
if ((PriCodeType(def) == VMCODE) && !(PriFlags(def) & CODE_DEFINED))
_pri_init_vmcode(use, PriFlags(def)&TOOL); /* defined -> undefined */
else
use->code = def->code; /* defined -> defined */
}
use->module_ref = def->module_def;
use->mode = def->mode;
use->trans_function = def->trans_function;
use->flags = (use->flags & DESCRIPTOR_FLAGS) | (def->flags & COMMON_FLAGS);
}
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_);
}
static int
_tool_body(pri *proci, dident *pdid, int *parity, dident *pmodule)
{
pri *procb;
int flags;
vmcode *code;
flags = proci->flags;
code = proci->code.vmc;
if (!(flags & CODE_DEFINED))
{
if (flags & AUTOLOAD)
{ Set_Bip_Error(NOT_LOADED); }
else
{ Set_Bip_Error(NOENTRY); }
return 0;
}
if (!(flags & TOOL))
{
Set_Bip_Error(NO_TOOL);
return 0;
}
if (PriCodeType(proci) == VMCODE)
{
if (DebugProc(proci))
procb = (pri *) *(code + DEBUG_LENGTH + 1);
else
procb = (pri *) *(code + 1);
*pdid = procb->did;
*parity = DidArity(procb->did);
*pmodule = procb->module_def;
}
else /* don't know how to get the tool body */
{
Set_Bip_Error(NO_TOOL);
return 0;
}
return 1;
}
/*
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
}
/*
_tool_code(proc, debug)
- makes the code for a tool interface
*/
static vmcode *
_tool_code(pri *procb, int debug)
{
vmcode *code;
vmcode *save;
if (PriCodeType(procb) & VMCODE)
{
Allocate_Default_Procedure(3 + (debug?DEBUG_LENGTH:0), PriDid(procb));
save = code;
if (debug) {
Store_3(Debug_call, procb, CALL_PORT|FIRST_CALL|LAST_CALL);
Store_4d(d_.empty,0,0,0);
}
Store_i(JmpdP);
Store_d(procb);
Store_i(Code_end);
return save;
}
else
{
return procb->code.vmc; /* use the body's code */
}
}
