Exemple #1
0
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(&copy_pw, pw.val, pw.tag)) != PSUCCEED)
	    { Bip_Error(err); }
	a_mutex_lock(&SharedDataLock);
	free_heapterm(&pheap[i]);
	move_heapterm(&copy_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;
    }
}
Exemple #3
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);
}
Exemple #8
0
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_;
}
Exemple #9
0
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;
}
Exemple #10
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;
}