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 ); }