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_;
}
/*
* The locking done here is rather useless:
* We are not allowed to return a pointer to a (shared heap) opi
* without holding the lock. But this would be just too much to fix...
* Most of the other properties have the same bug.
*/
static opi *
_visible_anyfix_op(int fixity, dident atom, dident module, type mod_tag, int *res)
{
opi *operator_prop;
if (atom == D_UNKNOWN
|| !(DidIsOp(atom) & fixity))
{
*res = PERROR;
return 0;
}
a_mutex_lock(&PropertyLock);
operator_prop = OperatorItem(atom, module, mod_tag,
VISIBLE_PROP, FixToProp(fixity), res);
if (!operator_prop)
{
a_mutex_unlock(&PropertyLock);
*res = PERROR;
return 0;
}
if (operator_prop->tag.kernel != TEND)
{
a_mutex_unlock(&PropertyLock); /* THIS IS WRONG! */
return operator_prop;
}
else
{
a_mutex_unlock(&PropertyLock);
*res = PERROR;
return 0;
}
}
static pword
_heap_arr_get(t_ext_ptr h, int i) /* assumed to return dereferenced result */
{
pword result;
pword *pheap;
int arity;
pheap = ((t_heap_array*)h)->array;
arity = DidArity(pheap[0].val.did);
a_mutex_lock(&SharedDataLock);
if (i > 0 && i <= arity)
{
get_heapterm(&pheap[i], &result);
}
else /* get the whole array-term */
{
Make_Struct(&result,TG);
Push_Struct_Frame(pheap[0].val.did);
for (i=1; i<=arity; ++i)
{
get_heapterm(&pheap[i], &result.val.ptr[i]);
}
}
a_mutex_unlock(&SharedDataLock);
return result;
}
/*
* is_visible_op(atom, module, mod_tag) returns 1 iff there is an
* operator attached to 'atom', returns 0 otherwise.
*
* Must be called in an interrupt protected area.
*/
int
is_visible_op(dident atom, dident module, type mod_tag)
{
opi *operator_prop;
int err = PERROR;
int res;
if (atom == D_UNKNOWN || !DidIsOp(atom))
{
Set_Bip_Error(PERROR);
return 0;
}
a_mutex_lock(&PropertyLock);
/* DidIsOp may be out of date, ie. it may be set even when there
* is no longer such an operator. That's why we have to check. */
if ((DidIsOp(atom) & IS_PREFIX_OP)
&& (operator_prop = OperatorItem(atom, module, mod_tag,
VISIBLE_PROP, PREFIX_PROP, &res))
&& operator_prop->tag.kernel != TEND
&& GetOpiPreced(operator_prop))
{
a_mutex_unlock(&PropertyLock);
return 1;
}
else if ((DidIsOp(atom) & IS_INFIX_OP)
&& (operator_prop = OperatorItem(atom, module, mod_tag,
VISIBLE_PROP, INFIX_PROP,&res))
&& operator_prop->tag.kernel != TEND
&& GetOpiPreced(operator_prop))
{
a_mutex_unlock(&PropertyLock);
return 1;
}
else if ((DidIsOp(atom) & IS_POSTFIX_OP)
&& (operator_prop = OperatorItem(atom, module, mod_tag,
VISIBLE_PROP, POSTFIX_PROP,&res))
&& operator_prop->tag.kernel != TEND
&& GetOpiPreced(operator_prop))
{
a_mutex_unlock(&PropertyLock);
return 1;
}
else
{
Set_Bip_Error(err);
a_mutex_unlock(&PropertyLock);
return 0;
}
}
/*
* _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_;
}
/*
* Quick routine to get a module-independent property.
* Does not return a pointer into the property, therefore no lock
* necessary around call.
*/
int
get_simple_property(dident functor, int property_name, pword *result)
{
property *p;
a_mutex_lock(&PropListLock);
for (p = DidProperties(functor); p; p = p->next_prop)
{
if (p->name == property_name)
{
a_mutex_unlock(&PropListLock);
*result = p->property_value;
return PSUCCEED;
}
}
a_mutex_unlock(&PropListLock);
return PFAIL;
}
pword *
get_modular_property(dident functor, int property_name, dident module, type mod_tag, int which, int *res)
{
register property *p, *m;
if (which != GLOBAL_PROP && IsLocked(module)
&& !IsModuleTag(module, mod_tag))
{
Property_Error(res, LOCKED);
}
/* scan property list until an entry for property is found or end */
a_mutex_lock(&PropListLock);
for (p = DidProperties(functor); p; p = p->next_prop)
{
if (p->name == property_name)
{
if (which != GLOBAL_PROP)
for (m = p->next_mod; m != p; m = m->next_mod)
{
if (m->module == module) {
*res = LOCAL_PROP;
a_mutex_unlock(&PropListLock);
return(&m->property_value); /* return the local */
}
}
a_mutex_unlock(&PropListLock);
if (which != LOCAL_PROP && p->module != D_UNKNOWN) {
*res = GLOBAL_PROP;
return(&p->property_value); /* return the global */
}
else
{
Property_Error(res, PERROR); /* no global */
}
}
}
a_mutex_unlock(&PropListLock);
Property_Error(res, PERROR);
}
int
ec_create_module(dident module_did) /* also called from megalog */
{
pword *prop;
module_item *m;
/* Not quite right, should be atomic lookup & enter */
a_mutex_lock(&ModuleLock);
if (IsModule(module_did))
{
a_mutex_unlock(&ModuleLock);
Bip_Error(MODULE_EXISTS);
}
DidModule(module_did) = UNLOCK_MODULE;
prop = (pword *) get_property(module_did, MODULE_PROP);
if (!prop)
{
prop = (pword *) set_property(module_did, MODULE_PROP);
/* the module did not exist before, no need to test prop */
m = (module_item *) hg_alloc(sizeof(module_item));
prop->tag.kernel = TPTR;
prop->val.ptr = (pword *) m;
}
else
m = (module_item *) prop->val.ptr;
m->syntax = copy_syntax_desc(default_syntax);
m->lock = (char *) 0;
m->procedures = 0;
m->properties = 0;
m->imports = 0;
a_mutex_unlock(&ModuleLock);
Succeed_;
}
static int
_procedure_referenced(pri *pd)
/* Locks: requires nothing. acquires ProcListLock. */
{
dident definition_module;
if (PriReferenced(pd))
return 1;
if (!PriExported(pd))
return 0;
a_mutex_lock(&ProcListLock);
definition_module = pd->module_def;
for(pd = DidPtr(pd->did)->procedure; pd; pd = pd->nextproc)
{
if (pd->module_ref == definition_module && PriReferenced(pd))
{
a_mutex_unlock(&ProcListLock);
return 1;
}
}
a_mutex_unlock(&ProcListLock);
return 0;
}
/*ARGSUSED*/
static int
p_import(value library, type tlib, value import_mod, type tim)
{
module_item *export_prop, *import_prop;
pri *pe, *pi;
didlist *lib_scan;
Check_Module_And_Access(import_mod, tim);
Check_Module(tlib, library);
a_mutex_lock(&ModuleLock);
export_prop = ModuleItem(library.did);
import_prop = ModuleItem(import_mod.did);
/* check that the module is not already imported */
lib_scan = import_prop->imports;
while (lib_scan)
{
if (lib_scan->name == library.did)
{
a_mutex_unlock(&ModuleLock);
Succeed_; /* the library is already imported */
}
lib_scan = lib_scan->next;
}
/* add library to the lists of the mods imported by import_mod */
_add_module(library.did, &(import_prop->imports));
/* now perform the pending imports */
resolve_pending_imports(import_prop->procedures);
a_mutex_unlock(&ModuleLock);
Succeed_;
}
/*
_insert_op( scope, preced, assoc, oper, module, mod_tag)
An insertion is made in the operator property list if there are
no conflict of associativity (postfix and infix).
However a local postfix/infix hide a global one so that
the conflict is impossible between a local and a global.
A local operator can not be modified in a locked module if the
module tag is not signed.
The precedence 0 is used to hide a global operator.
*/
static int
_insert_op(int scope, word preced, word assoc, dident oper, dident module, type mod_tag)
{
opi *operator_prop;
int prop_type;
int arity;
int res;
switch (assoc)
{
case XF:
case YF:
prop_type = POSTFIX_PROP;
arity = 1;
break;
case FX:
case FY:
prop_type = PREFIX_PROP;
arity = 1;
break;
case FXX:
case FXY:
prop_type = PREFIX_PROP;
arity = 2;
break;
case XFX:
case XFY:
case YFX:
prop_type = INFIX_PROP;
arity = 2;
break;
}
/* Disallow infix/postfix, if required by the module syntax */
if (prop_type != PREFIX_PROP && ModuleSyntax(module)->options & ISO_RESTRICTIONS)
{
if (OperatorItem(oper, module, mod_tag, VISIBLE_PROP,
(prop_type==INFIX_PROP? POSTFIX_PROP : INFIX_PROP), &res))
{
Bip_Error(ILLEGAL_OP_DEF);
}
}
a_mutex_lock(&PropertyLock);
res = PERROR;
operator_prop = OperatorItem(oper, module, mod_tag, scope, prop_type, &res);
if (operator_prop) /* same scope operator exists already */
{
if (preced && (GetOpiAssoc(operator_prop) != assoc ||
GetOpiPreced(operator_prop) != preced)) {
res = REDEF_OPERATOR;
} else {
res = PSUCCEED;
}
}
else
{
if (res != PERROR)
{
a_mutex_unlock(&PropertyLock);
Bip_Error(res);
}
/* No proper scope operator exists yet */
/* For locals, check hiding */
if (scope == LOCAL_PROP &&
OperatorItem(oper, module, mod_tag, GLOBAL_PROP, prop_type, &res))
res = HIDING_OPERATOR;
else
res = PSUCCEED;
operator_prop = NewOperatorItem(oper, module, mod_tag,
scope, prop_type, &res);
if (!operator_prop)
{
a_mutex_unlock(&PropertyLock);
Bip_Error(res);
}
}
/* now update the descriptor */
operator_prop->tag.kernel = TDICT;
Set_Opi_Assoc(operator_prop, assoc);
Set_Opi_Preced(operator_prop, preced);
OpiDid(operator_prop) = add_dict(oper, arity);
DidIsOp(oper) |= PropToFix(prop_type);
a_mutex_unlock(&PropertyLock);
if (res < 0)
{Bip_Error(res)}
return res;
}
int
erase_modular_property(dident functor, int property_name, dident module, type mod_tag, int which)
{
register property *p, **prev_p;
int res;
module_item *pm;
if (which != GLOBAL_PROP && IsLocked(module)
&& !IsModuleTag(module, mod_tag))
{
return LOCKED;
}
/* this lookup must be before the lock */
if (which != GLOBAL_PROP)
pm = (module_item *) (get_property(module, MODULE_PROP))->val.ptr;
a_mutex_lock(&PropListLock);
/* get pointer to property list from atom */
prev_p = &(DidProperties(functor));
p = *prev_p;
/* scan property list until an entry for property is found or end */
while (p)
{
if (p->name == property_name)
{
if (which != GLOBAL_PROP)
{
register property *m, **prev_m;
prev_m = &(p->next_mod);
m = *prev_m;
while (m != p) /* scan module list */
{
if (m->module == module)
{ /* erase the local */
*prev_m = m->next_mod;
_rem_from_module_entry(m, pm);
free_prop_value(property_name, &m->property_value);
hg_free_size((generic_ptr) m, sizeof(property));
if (p->next_mod == p && p->module == D_UNKNOWN)
{ /* all erased, remove head descriptor */
*prev_p = p->next_prop;
hg_free_size((generic_ptr) p, sizeof(property));
/* this is not an error, it is a message
to notify that the property is erased
completely */
res = PFAIL;
goto _unlock_return_;
}
res = PSUCCEED;
goto _unlock_return_;
}
prev_m = &(m->next_mod);
m = *prev_m;
}
}
if (which != LOCAL_PROP && p->module != D_UNKNOWN)
{ /* erase the global */
free_prop_value(property_name, &p->property_value);
if (p->next_mod == p)
{ /* no locals: remove global descriptor */
*prev_p = p->next_prop;
hg_free_size((generic_ptr) p, sizeof(property));
/* this is not an error, it is a message to notify
that the property is erased completely */
res = PFAIL;
goto _unlock_return_;
}
else
p->module = D_UNKNOWN; /* just mark it unused */
res = PSUCCEED;
goto _unlock_return_;
}
res = PERROR;
goto _unlock_return_; /* should give a warning */
}
prev_p = &(p->next_prop);
p = *prev_p;
}
res = PERROR;
_unlock_return_:
a_mutex_unlock(&PropListLock);
return(res);
}
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;
}