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);
}
/*
Add 'module' to the chain of module pointed to by '*scan'.
The module is added at the beginning of the chain.
A reference of '*scan' is passed (**scan) to be able to modify it.
*/
static void
_add_module(dident module, didlist **start)
{
didlist *new_mod;
new_mod = (didlist *) hg_alloc_size(sizeof(didlist));
new_mod->name = module;
new_mod->next = *start;
*start = new_mod;
}
void
add_proc_to_chain(pri *p, proc_duet **chain)
/* Locks: requires ProcChainLock. aquires nothing. */
{
proc_duet *gd;
gd = (proc_duet *) hg_alloc_size(sizeof(proc_duet));
gd->desc = p;
gd->next = *chain;
*chain = gd;
}
static pri*
_new_pri(dident functor, dident module)
{
pri *pd = (pri*) hg_alloc_size(sizeof(pri));
pd->did = functor;
pd->flags = NOREFERENCE|DEBUG_DF;
pd->module_def = module;
pd->module_ref = pd->trans_function = D_UNKNOWN;
pd->nextproc = pd->next_in_mod = 0;
pd->mode = 0;
pd->code.vmc = 0;
return pd;
}
void
error_init(int flags)
{
if (flags & INIT_SHARED)
{
int i;
/*
* Due to the user entries, part of the message array is
* mutable and must be in shared memory.
*/
ErrorMessage = (char **) hg_alloc_size(sizeof(char *) * MAX_ERRORS);
for(i=0; i<MAX_ERRORS; i++)
{
ErrorMessage[i] = ec_error_message[i];
}
(void) built_in(in_dict("error_id", 2), p_error_id, B_UNSAFE|U_SIMPLE);
(void) local_built_in(in_dict("max_error", 1), p_max_error, B_UNSAFE|U_SIMPLE);
(void) local_built_in(in_dict("set_last_errno", 1), p_set_last_errno, B_SAFE);
(void) local_built_in(in_dict("get_last_errno", 1), p_get_last_errno, B_UNSAFE|U_SIMPLE);
(void) built_in(in_dict("errno_id", 1), p_errno_id1, B_UNSAFE|U_SIMPLE);
(void) built_in(in_dict("errno_id", 2), p_errno_id, B_UNSAFE|U_SIMPLE);
}
}
pword *
set_modular_property(dident functor, int property_name, dident module, type mod_tag, int flag, int *err_ref)
{
register property *p, *head;
module_item *pm;
if (flag == LOCAL_PROP && IsLocked(module)
&& !IsModuleTag(module, mod_tag))
{
Property_Error(err_ref, LOCKED);
}
/* get pointer to property list from atom */
a_mutex_lock(&PropListLock);
head = p = DidProperties(functor);
while (p && p->name != property_name) /* find the right one */
{
head = p;
p = p->next_prop;
}
if (!p) /* no such property yet */
{
p = (property *) hg_alloc_size(sizeof(property));
p->name = property_name;
p->next_prop = (property *) NULL;
p->next_mod = p;
p->module = D_UNKNOWN;
if (head)
head->next_prop = p;
else
DidProperties(functor) = p;
}
if (flag == GLOBAL_PROP)
{
if (p->module == D_UNKNOWN)
{
p->module = module; /* fill unused descriptor */
p->property_value.tag.kernel = TEND;
a_mutex_unlock(&PropListLock);
return &p->property_value;
}
else
{
a_mutex_unlock(&PropListLock);
Property_Error(err_ref, PERROR)/* global exists already */
}
}
/* else if (flag == LOCAL_PROP) */
head = p;
for(p = head->next_mod; p != head; p = p->next_mod)
{
if (p->module == module)
{
a_mutex_unlock(&PropListLock);
Property_Error(err_ref, PERROR); /* a local exists */
}
}
/* insert a new descriptor at the beginning */
p = (property *) hg_alloc_size(sizeof(property));
p->name = property_name;
p->module = module;
p->property_value.tag.kernel = TEND;
p->next_mod = head->next_mod;
head->next_mod = p;
a_mutex_unlock(&PropListLock);
a_mutex_lock(&ModuleLock);
pm = (module_item *) (get_property(module, MODULE_PROP))->val.ptr;
p->next_prop = pm->properties;
pm->properties = p;
a_mutex_unlock(&ModuleLock);
return &p->property_value;
}
