static vmcode *
_print_init_mask(vmcode *code, int name)
{
long pos = (*code++)/(long)sizeof(pword);
unsigned init_mask = *code++;
if (name)
{
if (IsTag(*code,TNAME))
p_fprintf(current_output_,"%s-", DidName(TagDid(*code)));
code++;
}
p_fprintf(current_output_,"Y%d ", pos++);
while (init_mask)
{
if (init_mask & 1)
{
if (name)
{
if (IsTag(*code,TNAME))
p_fprintf(current_output_,"%s-", DidName(TagDid(*code)));
code++;
}
p_fprintf(current_output_,"Y%d ", pos);
}
init_mask >>= 1;
pos++;
}
return code;
}
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_;
}
pword *
term_to_dbformat(pword *parg, dident mod)
{
pword **save_tt = TT;
register word arity = 1, len;
register word curr_offset = 0, top_offset = 2; /* in 'word's */
register pword *queue_tail = (pword *) 0;
pword *queue_head = (pword *) 0;
register pword *pw;
register char *dest, *stop;
pword *header;
temp_area meta_attr;
int flag = 0;
Temp_Create(meta_attr, 4 * ATTR_IO_TERM_SIZE * sizeof(pword));
header = TG;
dest = (char *) (header + 1) + 4; /* space for the TBUFFER pword and for
* the external format header */
for(;;) /* handle <arity> consecutive pwords, starting at <parg> */
{
do /* handle the pword pointed to by parg */
{
pw = parg;
/* I need here a slightly modified version of Dereference_(pw)
* that stops also at MARKed words. Not very nice, I know.
*/
while (IsRef(pw->tag) && !(pw->tag.kernel & MARK) && !IsSelfRef(pw))
pw = pw->val.ptr;
Reserve_Space(6);
if (pw->tag.kernel & MARK)
{
if (SameTypeC(pw->tag,TDE)) /* a suspension */
{
Store_Byte(Tag(pw->tag.kernel));
Store_Int32((pw[SUSP_FLAGS].tag.kernel & ~MARK));
if (SuspDead(pw)) {
curr_offset += Words(SUSP_HEADER_SIZE-1);
parg += SUSP_HEADER_SIZE-1;
arity -= SUSP_HEADER_SIZE-1;
} else {
Store_Byte(SuspPrio(pw) + (SuspRunPrio(pw) << 4));
curr_offset += Words(SUSP_GOAL-1);
parg += SUSP_GOAL-1;
arity -= SUSP_GOAL-1;
}
}
else if (pw->val.nint == curr_offset) /* a nonstd variable */
{
Store_Byte(Tag(pw->tag.kernel));
Store_Int(pw->val.nint);
if (!IsNamed(pw->tag.kernel))
{
Store_Byte(0);
}
else /* store its name */
{
dident vdid = TagDid(pw->tag.kernel);
len = DidLength(vdid);
Store_Int(len);
Reserve_Space(len);
Store_String(len, DidName(vdid));
}
}
else /* just a reference to an already encountered variable */
{
Store_Byte(Tag(TVAR_TAG));
Store_Int(pw->val.nint);
}
}
else switch (TagType(pw->tag))
{
case TINT:
#if SIZEOF_CHAR_P > 4
if (pw->val.nint < WSUF(-2147483648) || WSUF(2147483648) <= pw->val.nint)
{
/* store as a bignum (to be readable on 32bit machines) */
len = tag_desc[pw->tag.kernel].string_size(pw->val, pw->tag, 1);
Store_Byte(TBIG);
Store_Int(len);
Reserve_Space(len+1);
stop = dest+len;
dest += tag_desc[pw->tag.kernel].to_string(pw->val, pw->tag,
dest, 1);
while (dest <= stop) /* pad and terminate */
*dest++ = 0;
break;
}
#endif
Store_Byte(TINT);
#ifdef OLD_FORMAT
Store_Int32(pw->val.nint);
#else
Store_Int(pw->val.nint);
#endif
break;
case TNIL:
Store_Byte(Tag(pw->tag.kernel));
break;
case TDICT:
len = DidLength(pw->val.did);
Store_Byte(TDICT);
Store_Int(DidArity(pw->val.did));
Store_Int(len);
Reserve_Space(len);
Store_String(len, DidName(pw->val.did));
break;
case TDBL:
{
ieee_double d;
d.as_dbl = Dbl(pw->val);
Store_Byte(TDBL);
Store_Byte(sizeof(double)-1); /* backward compat */
Reserve_Space(sizeof(double));
Store_Int32(d.as_struct.mant1);
Store_Int32(d.as_struct.mant0);
break;
}
case TIVL:
{
ieee_double dlwb, dupb;
dlwb.as_dbl = IvlLwb(pw->val.ptr);
dupb.as_dbl = IvlUpb(pw->val.ptr);
Store_Byte(TIVL);
Reserve_Space(2*sizeof(double));
Store_Int32(dlwb.as_struct.mant1);
Store_Int32(dlwb.as_struct.mant0);
Store_Int32(dupb.as_struct.mant1);
Store_Int32(dupb.as_struct.mant0);
break;
}
case TSTRG:
len = StringLength(pw->val);
Store_Byte(TSTRG);
Store_Int(len);
Reserve_Space(len);
Store_String(len, StringStart(pw->val));
break;
case TVAR_TAG: /* standard variable */
Store_Byte(Tag(TVAR_TAG));
Store_Int(curr_offset);
Trail_(pw);
pw->val.nint = curr_offset;
pw->tag.kernel |= MARK;
break;
case TNAME:
case TUNIV:
Store_Byte(Tag(TVAR_TAG));
Store_Int(top_offset);
Trail_Tag(pw);
pw->val.nint = top_offset;
pw->tag.kernel |= MARK;
top_offset += 2;
EnQueue_(pw, 1, 0);
break;
case TMETA:
Store_Byte(Tag(TVAR_TAG));
Store_Int(top_offset);
Trail_Tag(pw);
pw->val.nint = top_offset;
pw->tag.kernel |= MARK;
top_offset += 4;
EnQueue_(pw, 2, QUEUE_MASK_META);
break;
case TSUSP:
Store_Byte(Tag(TSUSP));
pw = pw->val.ptr;
if (pw->tag.kernel & MARK) /* not the first encounter */
{
Store_Int(pw->val.nint);
}
else
{
Store_Int(top_offset);
Trail_Pword(pw);
pw->tag.kernel |= MARK;
pw->val.nint = top_offset;
if (SuspDead(pw))
{
top_offset += Words(SUSP_HEADER_SIZE); /* for TDE */
EnQueue_(pw, SUSP_HEADER_SIZE, 0);
}
else
{
top_offset += Words(SUSP_SIZE); /* for TDE */
EnQueue_(pw, SUSP_SIZE, 0);
}
}
break;
case TLIST:
Store_Byte(Tag(TLIST));
Store_Int(top_offset);
top_offset += 4;
EnQueue_(pw->val.ptr, 2, 0);
break;
case TCOMP:
Store_Byte(Tag(TCOMP));
Store_Int(top_offset);
if (flag) {
pword pw_out;
(void) transf_meta_out(pw->val, pw->tag,
(pword *) TempAlloc(meta_attr, ATTR_IO_TERM_SIZE * sizeof(pword)),
D_UNKNOWN, &pw_out);
pw = pw_out.val.ptr;
len = 1 + DidArity(pw->val.did);
EnQueue_(pw, len, 0);
} else {
len = 1 + DidArity(pw->val.ptr->val.did);
EnQueue_(pw->val.ptr, len, 0);
}
top_offset += 2*len;
break;
default:
if (TagType(pw->tag) >= 0 && TagType(pw->tag) <= NTYPES)
{
len = tag_desc[TagType(pw->tag)].string_size(pw->val, pw->tag, 1);
Store_Byte(Tag(pw->tag.kernel));
Store_Int(len);
Reserve_Space(len+1);
stop = dest+len;
dest += tag_desc[TagType(pw->tag)].to_string(pw->val, pw->tag,
dest, 1);
while (dest <= stop) /* pad and terminate */
*dest++ = 0;
}
else
{
p_fprintf(current_err_,
"bad type in term_to_dbformat: 0x%x\n",
pw->tag.kernel);
}
break;
}
curr_offset += Words(1);
++parg;
} while (--arity);
if (EmptyQueue())
break;
DeQueue_(parg, arity, flag);
}
/* # bytes of external representation */
Store_Byte(0); /* add a terminating 0 */
Set_Buffer_Size(header, dest - (char*) header - sizeof(pword));
header->tag.kernel = TBUFFER;
Align(); /* align the global stack pointer */
TG = (pword *) dest;
dest = (char *) (header + 1); /* fill in the external format header */
Store_Int32(top_offset); /* (size of term after restoring) */
Untrail_Variables(save_tt);
Temp_Destroy(meta_attr);
return header;
}