int
p_session_sql_dml(
/* + */ value v_session, type t_session,
/* + */ value v_SQL, type t_SQL,
/* - */ value v_rows, type t_rows
)
{
session_t * session;
cursor_t * cursor;
char * SQL;
word rows, *prows;
int res;
Check_String(t_SQL);
Check_Output_Integer(t_rows);
Get_Typed_Object(v_session,t_session,&session_handle_tid,session);
cursor = session_sql_prepare(session, StringStart(v_SQL), StringLength(v_SQL), 0);
if (NULL == cursor)
Bip_Error(dbi_errno);
if (res = cursor_sql_execute(cursor, 1))
{
cursor_free(cursor);
Bip_Error(Error_Code(res));
}
cursor_field_value(cursor, rows_processed_count, (void **)&prows);
rows = *prows;
cursor_free(cursor);
Return_Unify_Integer(v_rows, t_rows, rows);
}
static int
p_unlock2(value v, type t, value vl, type tl)
{
module_item *m;
Check_Atom_Or_Nil(v, t);
Check_String(tl);
if (!IsModule(v.did))
{
Bip_Error(MODULENAME);
}
if (!IsLocked(v.did))
{
Succeed_;
}
if (DidModule(v.did) == HARD_LOCK_MODULE)
{
Bip_Error(LOCKED);
}
m = ModuleItem(v.did);
if (!strcmp(m->lock, StringStart(vl)))
{
hg_free((generic_ptr) m->lock);
DidModule(v.did) = UNLOCK_MODULE;
m->lock = (char *) 0;
Succeed_;
}
else
{
Bip_Error(WRONG_UNLOCK_STRING);
}
}
static
p_char_int(value chval, type chtag, value ival, type itag)
{
/* Case of: converting an integer to a character. */
if (IsRef(chtag))
{
value v;
register char *s;
if (IsRef(itag))
{ Bip_Error(PDELAY_1_2); }
else if (!IsInteger(itag))
{ Bip_Error(TYPE_ERROR); }
if ((ival.nint < 0) || (ival.nint > 255))
{
Bip_Error(RANGE_ERROR)
}
Make_Stack_String(1, v, s);
*s++ = ival.nint;
*s = '\0';
Return_Unify_String(chval, chtag, v.ptr);
}
else if (IsString(chtag) && StringLength(chval) == 1)
static int
p_dbag_create(value vbag, type tbag)
{
dbag_descr_t *dbag_descr;
aport_id_t bag_aport_id;
#ifndef lint
if (sizeof(aport_id_t) > sizeof(value))
{
Bip_Error(UNIMPLEMENTED); /* can't pack aport_id in integer */
}
#endif
if (aport_allocate(&bag_aport_id, dbag_port_upcall) != AMSG_OK)
{ Bip_Error(MPS_ERROR); }
if (aport_set_option(bag_aport_id, APORT_NOTIFY_LEVEL, (aport_optval_t) 3)
!= AMSG_OK)
{ Bip_Error(MPS_ERROR); }
dbag_descr = (dbag_descr_t *) hp_alloc_size(sizeof(dbag_descr_t));
dbag_descr->last = dbag_descr->first.msg_data_hdr = &dbag_descr->first;
if (aport_set_option(bag_aport_id, APORT_DATA_PTR,
(aport_optval_t) dbag_descr) != AMSG_OK)
{ Bip_Error(MPS_ERROR); }
Return_Unify_Integer(vbag, tbag, (long) bag_aport_id);
}
/*
* 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_length(value sval, type stag, value nval, type ntag)
{
Check_Output_Integer(ntag);
if (IsRef(stag))
{ Bip_Error(PDELAY_1); }
else if (!IsString(stag))
{ Bip_Error(TYPE_ERROR); }
Return_Unify_Integer(nval, ntag, StringLength(sval));
}
static int
_heap_arr_set(t_ext_ptr h,
int i,
pword pw) /* expected to be dereferenced */
{
pword copy_pw;
pword *pheap;
int err, arity;
pheap = ((t_heap_array*)h)->array;
arity = DidArity(pheap[0].val.did);
if (i >= 1 && i <= arity)
{
if ((err = create_heapterm(©_pw, pw.val, pw.tag)) != PSUCCEED)
{ Bip_Error(err); }
a_mutex_lock(&SharedDataLock);
free_heapterm(&pheap[i]);
move_heapterm(©_pw, &pheap[i]);
a_mutex_unlock(&SharedDataLock);
}
else if (i == 0)
{
if (IsStructure(pw.tag) && pw.val.ptr->val.did == pheap[0].val.did)
{
pword *aux = TG;
Push_Struct_Frame(pheap[0].val.did);
for (i=1; i<=arity; ++i)
{
pword *parg = &pw.val.ptr[i];
Dereference_(parg);
if ((err = create_heapterm(aux+i, parg->val, parg->tag)) != PSUCCEED)
{
TG = aux;
Bip_Error(err);
}
}
a_mutex_lock(&SharedDataLock);
for (i=1; i<=arity; ++i)
{
free_heapterm(&pheap[i]);
move_heapterm(aux+i, &pheap[i]);
}
a_mutex_unlock(&SharedDataLock);
TG = aux;
}
else { Bip_Error(RANGE_ERROR); }
}
else
{ Bip_Error(RANGE_ERROR); }
Succeed_;
}
/*
* _erase_op(oper, module) erase the definition of an operator
*/
static int
_erase_op(dident oper, word assoc, int scope, dident module, type mod_tag)
{
opi *operator_prop;
int prop_type;
int res;
switch (assoc)
{
case XF:
case YF:
prop_type = POSTFIX_PROP;
break;
case FX:
case FY:
case FXX:
case FXY:
prop_type = PREFIX_PROP;
break;
case XFX:
case XFY:
case YFX:
prop_type = INFIX_PROP;
break;
}
a_mutex_lock(&PropertyLock);
operator_prop = OperatorItem(oper, module, mod_tag, scope, prop_type,&res);
if (!operator_prop)
{
if (res == PERROR)
res = UNDEF_OPERATOR;
a_mutex_unlock(&PropertyLock);
Bip_Error(res);
}
else if (operator_prop->tag.kernel == TEND)
{
a_mutex_unlock(&PropertyLock);
Bip_Error(UNDEF_OPERATOR);
}
if (erase_modular_property(oper, prop_type, module, mod_tag, scope)
== PFAIL) /* the property is completely erased for that atom */
{
DidIsOp(oper) &= ~PropToFix(prop_type);
}
a_mutex_unlock(&PropertyLock);
Succeed_;
}
int
p_session_start(
/* + */ value v_session, type t_session,
/* + */ value v_username, type t_username,
/* + */ value v_host, type t_host,
/* + */ value v_password, type t_password,
/* + */ value v_opts, type t_opts
)
{
session_t * session;
Get_Typed_Object(v_session,t_session,&session_handle_tid,session);
Check_String(t_username);
Check_String(t_host);
Check_String(t_password);
Check_Structure(t_opts);
if ( session_start( session,
StringStart(v_username),
StringStart(v_host),
StringStart(v_password),
v_opts) )
Bip_Error(dbi_errno);
Succeed;
}
static int
p_shelf_name(value vname, type tname, value vhandle, type thandle, value vmod, type tmod)
{
pword *prop;
dident name_did;
int err;
Get_Functor_Did(vname, tname, name_did);
prop = set_modular_property(name_did, SHELF_PROP, vmod.did, tmod,
LOCAL_PROP, &err);
if (prop)
{
t_heap_array *obj;
Get_Typed_Object(vhandle, thandle, &heap_array_tid, obj);
prop->tag.kernel = TPTR;
prop->val.wptr = (uword *) heap_array_tid.copy(obj);
Succeed_;
}
else if (err == PERROR)
{
Succeed_;
}
else
{
Bip_Error(err);
}
}
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);
}
/*
* error_id(+Number, ?Message)
*
* Returns the appropriate error message. Fails if the
* message string is empty or out of range, so that it
* can be used to check whether the given error exists.
*/
static int
p_error_id(value valn, type tagn, value vale, type tage)
{
Error_If_Ref(tagn);
Check_Output_String(tage);
if (IsInteger(tagn))
{
if
(
valn.nint < 1
||
valn.nint >= MAX_ERRORS
||
!ErrorMessage[valn.nint]
)
{
Fail_;
}
{
value v;
Cstring_To_Prolog(ErrorMessage[valn.nint], v);
Return_Unify_String(vale, tage, v.ptr);
}
}
else if (IsAtom(tagn))
{
Return_Unify_String(vale, tage, DidString(valn.did));
}
else
{
Bip_Error(TYPE_ERROR);
}
}
static int
p_set_par_goal(value v, type t)
{
pword *old_tg = TG;
pword term, *term_as_bytes;
amsg_data_t *msg_data;
if (par_goal_msg_)
(void) amsg_free(par_goal_msg_);
/* encode the term */
term.val.all = v.all;
term.tag.kernel = t.kernel;
term_as_bytes = term_to_dbformat(&term, D_UNKNOWN);
/* fill into a message buffer */
if (amsg_alloc((amsg_size_t) BufferSize(term_as_bytes), &msg_data, &par_goal_msg_)
!= AMSG_OK)
{
Bip_Error(MPS_ERROR);
}
bmem_cpy( (generic_ptr) msg_data,
(generic_ptr) BufferStart(term_as_bytes),
(bmem_size_t) BufferSize(term_as_bytes));
TG = old_tg; /* pop the temporary stack string */
Succeed_;
}
static int
p_tool_body(value vi, type ti, value vb, type tb, value vmb, type tmb, value vm, type tm)
{
dident di;
pri *procb, *proci;
int flags, arity;
dident module;
dident pdid;
pword *ptr = Gbl_Tg;
vmcode *code;
int err;
Prepare_Requests;
Check_Module(tm, vm);
Get_Proc_Did(vi, ti, di);
if (!IsRef(tb)
&& (!IsStructure(tb)
|| vb.ptr->val.did != d_.quotient))
{
Bip_Error(TYPE_ERROR);
}
Check_Output_Atom_Or_Nil(vmb, tmb);
if (!(proci = visible_procedure(di, vm.did, tm, PRI_CREATE)))
{
Get_Bip_Error(err);
Bip_Error(err);
}
if (!_tool_body(proci, &pdid, &arity, &module))
{
Get_Bip_Error(err);
Bip_Error(err);
}
Gbl_Tg += 3;
Check_Gc;
ptr[0].tag.kernel = TDICT;
ptr[0].val.did = d_.quotient;
ptr[1].tag.kernel = TDICT;
ptr[1].val.did = add_dict(pdid, 0);
ptr[2].tag.kernel = TINT;
ptr[2].val.nint = arity;
Request_Unify_Atom(vmb, tmb, module);
Request_Unify_Structure(vb, tb, ptr);
Return_Unify;
}
/*ARGSUSED*/
static int
p_op_(value vi, type ti, value vprec, type tprec, value vassoc, type tassoc, value v_op, type t_op, value vm, type tm)
{
word iassoc;
int scope = (vi.did == d_.local0 ? LOCAL_PROP : GLOBAL_PROP);
/* vi is supplied by the system so no need to test it. */
Check_Module(tm, vm);
Check_Atom_Or_Nil(v_op, t_op);
Check_Atom_Or_Nil(vassoc, tassoc);
Check_Integer(tprec);
if ((vprec.nint > 1200) || (vprec.nint < 0))
{
Bip_Error(RANGE_ERROR);
}
iassoc = _get_assoc(vassoc.did);
if (iassoc == NIL_OP)
{
Bip_Error(RANGE_ERROR);
}
if (ModuleSyntax(vm.did)->options & ISO_RESTRICTIONS)
{
if (iassoc >= FXX)
{
Bip_Error(RANGE_ERROR)
}
else if (v_op.did == d_comma0_
|| v_op.did == d_.nil
|| v_op.did == d_.nilcurbr
|| v_op.did == d_bar0_ && (
!(iassoc==XFY || iassoc==XFX || iassoc==YFX)
|| vprec.nint > 0 && vprec.nint <= 1000))
{
Bip_Error(ILLEGAL_OP_DEF)
}
}
if (vprec.nint == 0 && scope == GLOBAL_PROP)
/* precedence 0 is used to erase the operator but if it is
local, the descriptor is kept to hide a global operator */
return _erase_op(v_op.did, iassoc, scope, vm.did, tm);
else
return _insert_op(scope, vprec.nint, iassoc, v_op.did, vm.did, tm);
}
static int
p_atom_length(value aval, type atag, value nval, type ntag)
{
Check_Output_Integer(ntag);
if (IsRef(atag))
{ Bip_Error(PDELAY_1); }
Check_Output_Atom_Or_Nil(aval, atag);
Return_Unify_Integer(nval, ntag, DidLength(aval.did));
}
static int
p_shelf_inc(value vhandle, type thandle, value vi, type ti, value vmod, type tmod)
{
t_heap_array *obj;
pword *pw;
Get_Shelf(vhandle, thandle, vmod, tmod, obj);
Check_Integer(ti);
if (vi.nint < 1 || vi.nint > DidArity(obj->array[0].val.did))
{ Bip_Error(RANGE_ERROR); }
pw = &obj->array[vi.nint];
Check_Integer(pw->tag);
if (pw->val.nint == MAX_S_WORD)
{
Bip_Error(RANGE_ERROR);
}
++pw->val.nint;
Succeed_;
}
/*
* This is supposed to be called after the initialization goal has been
* executed and the proper reexecution starts. It sets the FO register.
*/
static int
p_install_pending_oracle(void)
{
if (FO || !PO)
{
Bip_Error(RECOMP_FAILED);
}
FO = PO;
NTRY = 0;
Succeed_;
}
/*
legal_current_op(?Precedence, ?Assoc, +Operator_atom, +Module)
checks that all arguments are valid for current_op_body/4.
*/
static int
p_legal_current_op(value v_prec, type t_prec, value v_assoc, type t_assoc, value v_op, type t_op, value v_mod, type t_mod)
{
if (!IsRef(t_op)) /* Operator name */
{
Check_Atom_Or_Nil(v_op, t_op);
#ifdef lint
/* v_op is set in Check_Atom_Or_Nil but not used */
if (v_op.nint) return v_op.nint;
#endif /* lint */
}
Check_Module(t_mod, v_mod); /* module */
Check_Module_Access(v_mod, t_mod);
if (IsAtom(t_assoc)) /* Associativity */
{
word iassoc = _get_assoc(v_assoc.did);
if (iassoc == NIL_OP ||
(iassoc > FXX && (ModuleSyntax(v_mod.did)->options & ISO_RESTRICTIONS)))
{
Bip_Error(RANGE_ERROR);
}
}
else if (!IsRef(t_assoc))
{
Bip_Error(TYPE_ERROR);
}
if (IsInteger(t_prec)) /* Precedence */
{
if (v_prec.nint < 0 || v_prec.nint > 1200)
{
Bip_Error(RANGE_ERROR);
}
}
else if (!IsRef(t_prec))
{
Bip_Error(TYPE_ERROR);
}
Succeed_;
}
/*
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
}
int
p_session_commit(
/* + */ value v_session, type t_session
)
{
session_t * session;
Get_Typed_Object(v_session,t_session,&session_handle_tid,session);
if (session_commit(session))
Bip_Error(dbi_errno);
Succeed;
}
static int
p_dbag_enter(value vbag, type tbag, value vterm, type tterm)
{
aport_id_t bag_aport_id;
pword term, *term_as_bytes;
pword *old_tg = TG;
amsg_size_t msg_size;
amsg_t msg;
amsg_data_t *msg_data;
Check_Integer(tbag);
bag_aport_id = (aport_id_t) vbag.nint;
/* encode the term */
term.val.all = vterm.all;
term.tag.kernel = tterm.kernel;
term_as_bytes = term_to_dbformat(&term, D_UNKNOWN);
/* fill into a message buffer */
msg_size = BufferSize(term_as_bytes) + sizeof(amsg_ref_t);
if (amsg_alloc(msg_size, &msg_data, &msg) != AMSG_OK)
{
Bip_Error(MPS_ERROR);
}
bmem_cpy((generic_ptr) ((char *) msg_data + sizeof(amsg_ref_t)),
(generic_ptr) BufferStart(term_as_bytes),
(bmem_size_t) BufferSize(term_as_bytes));
TG = old_tg; /* pop the temporary stack string */
/* send the message */
if (amsg_send(bag_aport_id, msg, MDT_BYTE, (amsg_count_t) msg_size, 0) != AMSG_OK)
{
Bip_Error(MPS_ERROR);
}
Succeed_;
}
int
p_session_rollback(
/* + */ value v_session, type t_session
)
{
session_t * session;
int res;
Get_Typed_Object(v_session,t_session,&session_handle_tid,session);
if (res = session_rollback(session))
Bip_Error(Error_Code(res));
Succeed;
}
static int
p_erase_module(value module, type module_tag, value from_mod, type tfrom_mod)
{
module_item *pm, *import_pm;
int i;
didlist *lib_scan;
pword *prop;
Check_Module(tfrom_mod, from_mod);
Check_Atom_Or_Nil(module, module_tag);
if (!IsModule(module.did))
{
Succeed_;
} else if (IsLocked(module.did)
&& (from_mod.did != d_.kernel_sepia
|| !IsModuleTag(from_mod.did, tfrom_mod)))
{
Bip_Error(LOCKED);
}
/*
* This is a big mess with respect to locking. The erased module's
* descriptor is unprotected. It should be first removed as property
* and then cleaned up.
*/
pm = ModuleItem(module.did);
/* first, clean the procedures, we can reclaim the space */
erase_module_procs(pm->procedures);
hg_free_size((generic_ptr) pm->syntax, sizeof(syntax_desc));
/* reclaim the properties */
erase_module_props(pm->properties);
/* reclaim module descriptor */
(void) erase_property(module.did, MODULE_PROP);
DidPtr(module.did)->module = 0;
Succeed_;
}
/*
abolish_op_(atom, assoc, module)
abolish the declaration of the operator 'atom' of associativity
'assoc' visible from 'module'.
*/
static int
p_abolish_op_(value v_op, type t_op, value v_assoc, type t_assoc, value v_mod, type t_mod)
{
word iassoc;
Check_Atom_Or_Nil(v_op, t_op);
Check_Atom_Or_Nil(v_assoc, t_assoc);
Check_Module(t_mod, v_mod);
iassoc = _get_assoc(v_assoc.did);
if (iassoc == NIL_OP)
{
Bip_Error(RANGE_ERROR);
}
return _erase_op(v_op.did, iassoc, VISIBLE_PROP, v_mod.did,t_mod);
}
static int
p_is_locked(value v, type t)
{
Check_Atom_Or_Nil(v, t);
if (!IsModule(v.did))
{
Bip_Error(MODULENAME)
}
if (IsLocked(v.did))
{
Succeed_;
}
else
{
Fail_;
}
}
static int
p_local(value v, type t, value vm, type tm)
{
dident d;
pri *proc;
int err;
Check_Module(tm, vm);
Get_Proc_Did(v, t, d);
proc = local_procedure(d, vm.did, tm, PRI_CREATE|PRI_DONTWARN);
if (!proc)
{
Get_Bip_Error(err);
Bip_Error(err);
}
Succeed_;
}
static int
p_export(value v, type t, value vm, type tm)
{
dident d;
pri *proc;
int err;
Check_Module(tm, vm);
Get_Proc_Did(v, t, d);
proc = export_procedure(d, vm.did, tm);
if (!proc)
{
Get_Bip_Error(err);
Bip_Error(err);
}
Succeed_;
}
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 );
}
