int
p_member(value velt, type telt,
value vlist, type tlist)
{
pword *p;
/* we require a list or nil */
Check_List(tlist);
/* if the list is empty, we fail */
if(IsNil(tlist))
{
Fail;
}
/* the tail of the list */
p = vlist.ptr + 1;
/* must be dereferenced! */
Dereference(p);
/*
* on backtracking we will get the tail of the list
* instead of the list itself
*/
Remember(2, p->val, p->tag);
/*
* and we behave as the unification
* of the element and the head
*/
Return_Unify_Pw(velt, telt,
vlist.ptr->val, vlist.ptr->tag);
}
static int
p_shelf_create2(value vinit, type tinit, value vbag, type tbag)
{
pword bag;
pword *pheap, *pglobal;
t_heap_array *obj;
int i, err;
Check_Ref(tbag);
Check_Structure(tinit);
pglobal = vinit.ptr;
i = DidArity(pglobal->val.did);
/* INSTANCE INITIALISATION */
obj = (t_heap_array *) hg_alloc_size(
sizeof(t_heap_array) + i*sizeof(pword));
obj->ref_ctr = 1;
pheap = obj->array;
pheap[0] = pglobal[0];
for (; i > 0; --i)
{
pword *parg = &pglobal[i];
Dereference_(parg);
err = create_heapterm(&pheap[i], parg->val, parg->tag);
Return_If_Not_Success(err);
}
bag = ec_handle(&heap_array_tid, (t_ext_ptr) obj);
Return_Unify_Pw(vbag, tbag, bag.val, bag.tag);
}
static int
p_shelf_create3(value vkey, type tkey, value vinit, type tinit, value vbag, type tbag)
{
dident key_did;
pword *p, bag;
t_heap_array *obj;
int i;
Check_Ref(tbag);
Get_Functor_Did(vkey, tkey, key_did);
i = DidArity(key_did);
if (i < 1)
{ Bip_Error(RANGE_ERROR); }
/* INSTANCE INITIALISATION */
obj = (t_heap_array *) hg_alloc_size(
sizeof(t_heap_array) + i*sizeof(pword));
obj->ref_ctr = 1;
p = obj->array;
for (; i > 0; --i)
{
int err = create_heapterm(&p[i], vinit, tinit);
Return_If_Not_Success(err);
}
p[0].val.did = key_did;
p[0].tag.kernel = TDICT;
bag = ec_handle(&heap_array_tid, (t_ext_ptr) obj);
Return_Unify_Pw(vbag, tbag, bag.val, bag.tag);
}
/*
* 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_errno_id1(value sval, type stag)
{
pword pw;
char buf[1024];
Check_Output_String(stag);
Make_String(&pw, ec_os_err_string(ec_os_errno_, ec_os_errgrp_, buf, 1024));
Return_Unify_Pw(sval, stag, pw.val, pw.tag);
}
static int
p_default_module(value v, type t)
{
if (IsRef(t)) {
pword pw;
pw.val.did = d_.default_module;
pw.tag.kernel = ModuleTag(d_.default_module);
Return_Unify_Pw(v, t, pw.val, pw.tag);
}
Check_Module_And_Access(v, t);
d_.default_module = v.did;
Succeed_;
}
static int
p_get_par_goal(value v, type t)
{
pword *pw1;
if (!par_goal_msg_) { Fail_; }
pw1 = dbformat_to_term((char*) amsg_data(par_goal_msg_), D_UNKNOWN, tdict);
if (!pw1)
{
value va;
va.did = d_.abort;
Bip_Throw(va, tdict);
}
Return_Unify_Pw(v, t, pw1->val, pw1->tag);
}
static int
p_shelf_get(value vhandle, type thandle, value vi, type ti, value vval, type tval, value vmod, type tmod)
{
t_heap_array *obj;
pword pw;
pw.val = vval;
pw.tag = tval;
Get_Shelf(vhandle, thandle, vmod, tmod, obj);
Check_Integer(ti);
if (vi.nint < 0 || vi.nint > DidArity(obj->array[0].val.did))
{ Bip_Error(RANGE_ERROR); }
pw = _heap_arr_get(obj, vi.nint);
if (IsRef(pw.tag))
{
Succeed_; /* nothing to unify */
}
Return_Unify_Pw(vval, tval, pw.val, pw.tag);
}
int
p_session_init(
/* - */ value v_session, type t_session
)
{
session_t * session;
pword p_session;
session_init( &session);
if (session == NULL)
{
Bip_Error(dbi_errno);
}
session->refs = 1;
p_session = ec_handle(&session_handle_tid, session);
Return_Unify_Pw(v_session, t_session, p_session.val, p_session.tag );
}
static int
p_text_to_string(value v, type t, value vs, type ts)
{
pword *pw, *list;
char *s;
int len;
pword *old_tg = Gbl_Tg;
if (IsRef(t))
{
Bip_Error(PDELAY_1);
}
if (IsString(t))
{
Kill_DE;
Return_Unify_Pw(v, t, vs, ts);
}
if (IsAtom(t)) /* not including [] ! */
{
Kill_DE;
Return_Unify_String(vs, ts, DidString(v.did));
}
if (IsNil(t))
{
Kill_DE;
Return_Unify_String(vs, ts, empty_string);
}
if (IsList(t)) /* make a string from a list */
{
int element_type = 0;
list = v.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 */
{
int c;
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)) /* char code */
{
element_type |= 1;
c = pw->val.nint;
if (c < 0 || 255 < c)
{
Gbl_Tg = old_tg;
Bip_Error(RANGE_ERROR);
}
}
else if (IsAtom(pw->tag)) /* char atom */
{
element_type |= 2;
if (DidLength(pw->val.did) != 1)
{
Gbl_Tg = old_tg;
Bip_Error(RANGE_ERROR);
}
c = DidName(pw->val.did)[0];
}
else
{
Gbl_Tg = old_tg;
Bip_Error(TYPE_ERROR);
}
*s++ = c;
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);
}
}
if (element_type != 1 && element_type != 2) /* mixed type list? */
{
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);
}
Bip_Error(TYPE_ERROR);
}
