static void
_print_label(vmcode **ptr)
{
char *instr;
int inst;
p_fprintf(current_output_,"%d(", (word) (*ptr)
#ifndef PRINTAM
& 0xfff
#endif
);
if (InvalidAddress(*ptr))
ec_outfs(current_output_, "BAD ADDRESS");
else {
inst = Get_Int_Opcode(*ptr);
if (inst < 0 || inst > NUMBER_OP)
inst = Inst_Error;
instr = inst_name[inst];
while (*instr != ' ')
(void) ec_outfc(current_output_, *instr++);
}
(void) ec_outfc(current_output_, ')');
}
ppw(pword *pw) /* print prolog words */
{
int arity = 1;
pword *queue_head = (pword *) 0;
pword *queue_tail = (pword *) 0;
for (;;)
{
char region;
int t = TagType(pw->tag);
if (t < TFORWARD || t > TBUFFER)
t = TUNKNOWN;
if (TG_ORIG <= pw && pw < TG) region = 'g';
else if (SP <= pw && pw < SP_ORIG) region = 'l';
else if (B_ORIG <= pw && pw < B.args) region = 'c';
else if (TT <= (pword **) pw && (pword **) pw < TT_ORIG) region = 't';
else if (address_in_heap(&global_heap, (generic_ptr) pw)) region = 'h';
else region = '?';
p_fprintf(current_output_, "%c 0x%08x: 0x%08x 0x%08x %s ", region,
pw, pw->val.all, pw->tag.all, tag_string[t-TUNKNOWN]);
switch (t)
{
case TFORWARD:
case TMETA:
case TNAME:
if (pw != pw->val.ptr)
{
ec_outfs(current_output_, "--->");
EnQueue_(pw->val.ptr, 1);
}
else
{
ec_outfs(current_output_, IsNamed(pw->tag.kernel) ?
DidName(TagDid(pw->tag.kernel)) : "_");
}
break;
case TVAR_TAG:
if (pw != pw->val.ptr)
{
ec_outfs(current_output_, "--->");
EnQueue_(pw->val.ptr, 1);
}
else
ec_outfs(current_output_, "_");
break;
case TLIST:
EnQueue_(pw->val.ptr, 2);
break;
case TCOMP:
if (pw->val.ptr)
EnQueue_(pw->val.ptr, DidArity(pw->val.ptr->val.did)+1);
break;
case TSTRG:
ec_outfs(current_output_, StringStart(pw->val));
break;
case TSUSP:
break;
case TDE:
break;
case THANDLE:
break;
case TNIL:
break;
case TINT:
p_fprintf(current_output_, "%d", pw->val.nint);
break;
case TDICT:
ec_outfs(current_output_, DidName(pw->val.did));
if (DidArity(pw->val.did))
p_fprintf(current_output_, "/%d", DidArity(pw->val.did));
break;
case TPTR:
break;
case TPROC:
case TEND:
case TVARNUM:
case TGRS:
case TGRL:
case TEXTERN:
case TBUFFER:
break;
case TDBL:
p_fprintf(current_output_, "%f", Dbl(pw->val));
break;
case TBIG:
case TRAT:
default:
if (t >= 0 && t <= NTYPES)
{
(void) tag_desc[t].write(QUOTED, current_output_,
pw->val, pw->tag);
}
break;
}
ec_newline(current_output_);
if (--arity > 0)
{
pw++;
continue;
}
ec_newline(current_output_);
if (EmptyQueue())
break;
DeQueue_(pw, arity);
}
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_;
}
}
