/*
* Must be called on the worker that created the bag, no check yet!
*/
static int
p_dbag_dissolve(value vdbag, type tdbag, value vl, type tl)
{
aport_id_t bag_aport_id;
dbag_descr_t *dbag_descr;
amsg_t this_msg;
amsg_ref_t *this_msg_data_hdr;
pword list;
register pword *car, *cdr;
Check_Integer(tdbag);
bag_aport_id = (aport_id_t) vdbag.nint;
Check_Output_List(tl);
if (aport_get_option(bag_aport_id, APORT_DATA_PTR,
(aport_optval_t *) &dbag_descr) != AMSG_OK)
{
Bip_Error(MPS_ERROR);
}
this_msg = dbag_descr->first.msg;
this_msg_data_hdr = dbag_descr->first.msg_data_hdr;
hp_free_size((generic_ptr) dbag_descr, sizeof(dbag_descr_t));
cdr = &list;
while (this_msg_data_hdr != &dbag_descr->first)
{
pword *pw1;
amsg_t old_msg;
car = TG;
Push_List_Frame();
Make_List(cdr, car);
cdr = car + 1;
pw1 = dbformat_to_term((char*)(this_msg_data_hdr+1), D_UNKNOWN, tdict);
if (!pw1)
{
value va;
va.did = d_.abort;
Bip_Throw(va, tdict);
}
car->val.ptr = pw1->val.ptr;
car->tag.kernel = pw1->tag.kernel;
old_msg = this_msg;
this_msg = this_msg_data_hdr->msg;
this_msg_data_hdr = this_msg_data_hdr->msg_data_hdr;
(void) amsg_free(old_msg);
}
Make_Nil(cdr);
if (aport_deallocate(bag_aport_id) != AMSG_OK)
{
Bip_Error(MPS_ERROR);
}
Return_Unify_Pw(vl, tl, list.val, list.tag);
}
static int
p_string_list(value vs, type ts, value vl, type tl)
{
register pword *pw, *list;
register char *s;
register int len;
pword *old_tg = Gbl_Tg;
if (IsRef(ts)) /* no string given */
{
if (IsRef(tl)) /* we need at least one */
{
Bip_Error(PDELAY_1_2);
}
else if (IsList(tl)) /* make a string from a list */
{
list = vl.ptr; /* space for the string header */
Push_Buffer(1); /* make minimum buffer */
s = (char *) BufferStart(old_tg); /* start of the new string */
for(;;) /* loop through the list */
{
pw = list++;
Dereference_(pw); /* get the list element */
if (IsRef(pw->tag)) /* check it */
{
Gbl_Tg = old_tg;
Push_var_delay(vs.ptr, ts.all);
Push_var_delay(pw, pw->tag.all);
Bip_Error(PDELAY);
}
else if (!IsInteger(pw->tag))
{
Gbl_Tg = old_tg;
Bip_Error(TYPE_ERROR);
}
else if (pw->val.nint < 0 || pw->val.nint > 255)
{
Gbl_Tg = old_tg;
Bip_Error(RANGE_ERROR);
}
*s++ = pw->val.nint;
if (s == (char *) Gbl_Tg) /* we need another pword */
{
Gbl_Tg += 1;
Check_Gc;
}
Dereference_(list); /* get the list tail */
if (IsRef(list->tag))
{
Gbl_Tg = old_tg;
Push_var_delay(vs.ptr, ts.all);
Push_var_delay(list, list->tag.all);
Bip_Error(PDELAY);
}
else if (IsList(list->tag))
list = list->val.ptr;
else if (IsNil(list->tag))
break; /* end of the list */
else
{
Gbl_Tg = old_tg;
Bip_Error(TYPE_ERROR);
}
}
*s = '\0'; /* terminate the string */
Set_Buffer_Size(old_tg, s - (char *)(old_tg + 1) + 1);
Kill_DE;
Return_Unify_String(vs, ts, old_tg);
}
else if (IsNil(tl))
{
Kill_DE;
Return_Unify_String(vs, ts, empty_string);
}
else
{
Bip_Error(TYPE_ERROR);
}
}
else if (IsString(ts))
{
Kill_DE;
Check_Output_List(tl);
s = StringStart(vs); /* get a pointer to the string */
len = StringLength(vs);
if (len == 0)
{
Return_Unify_Nil(vl, tl);
}
/* Additional a-priori overflow check because adding to TG may
* may wrap around the address space and break Check_Gc below
*/
Check_Available_Pwords(2*len);
pw = Gbl_Tg; /* reserve space for the list */
Gbl_Tg += 2*len;
Check_Gc;
pw->val.nint = *s++ & 0xFFL; /* construct the list */
pw++->tag.kernel = TINT;
while (--len > 0)
{
pw->val.ptr = pw + 1;
pw++->tag.kernel = TLIST;
pw->val.nint = *s++ & 0xFFL;
pw++->tag.kernel = TINT;
}
pw->tag.kernel = TNIL;
Return_Unify_List(vl, tl, old_tg);
}
else
{
Bip_Error(TYPE_ERROR);
}
}