obj.c

Calc Software Package for Number Calc

	i = op1->o_actions->oa_count;
	while (--i >= 0) {
		if (comparevalue(&op1->o_table[i], &op2->o_table[i]))
			return TRUE;
	}
	return FALSE;
}


/*
 * Raise an object to an integral power.
 * This is the default routine if the user's is not defined.
 * Negative powers mean the positive power of the inverse.
 * Zero means the multiplicative identity.
 *
 * given:
 *	vp		value to be powered
 *	q		power to raise number to
 */
static VALUE
objpowi(VALUE *vp, NUMBER *q)
{
	VALUE res, tmp;
	long power;		/* power to raise to */
	FULL bit;		/* current bit value */

	if (qisfrac(q)) {
		math_error("Raising object to non-integral power");
		/*NOTREACHED*/
	}
	if (zge31b(q->num)) {
		math_error("Raising object to very large power");
		/*NOTREACHED*/
	}
	power = ztolong(q->num);
	if (qisneg(q))
		power = -power;
	/*
	 * Handle some low powers specially
	 */
	if ((power <= 2) && (power >= -2)) {
		switch ((int) power) {
		case 0:
			return objcall(OBJ_ONE, vp, NULL_VALUE, NULL_VALUE);
		case 1:
			res.v_obj = objcopy(vp->v_obj);
			res.v_type = V_OBJ;
			res.v_subtype = V_NOSUBTYPE;
			return res;
		case -1:
			return objcall(OBJ_INV, vp, NULL_VALUE, NULL_VALUE);
		case 2:
			return objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE);
		}
	}
	if (power < 0)
		power = -power;
	/*
	 * Compute the power by squaring and multiplying.
	 * This uses the left to right method of power raising.
	 */
	bit = TOPFULL;
	while ((bit & power) == 0)
		bit >>= 1L;
	bit >>= 1L;
	res = objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE);
	if (bit & power) {
		tmp = objcall(OBJ_MUL, &res, vp, NULL_VALUE);
		objfree(res.v_obj);
		res = tmp;
	}
	bit >>= 1L;
	while (bit) {
		tmp = objcall(OBJ_SQUARE, &res, NULL_VALUE, NULL_VALUE);
		objfree(res.v_obj);
		res = tmp;
		if (bit & power) {
			tmp = objcall(OBJ_MUL, &res, vp, NULL_VALUE);
			objfree(res.v_obj);
			res = tmp;
		}
		bit >>= 1L;
	}
	if (qisneg(q)) {
		tmp = objcall(OBJ_INV, &res, NULL_VALUE, NULL_VALUE);
		objfree(res.v_obj);
		return tmp;
	}
	return res;
}


/*
 * Define a (possibly) new class of objects.
 * The list of indexes for the element names is also specified here,
 * and the number of elements defined for the object.
 *
 * given:
 *	name		name of object type
 *	indices		table of indices for elements
 *	count		number of elements defined for the object
 */
int
defineobject(char *name, int indices[], int count)
{
	OBJECTACTIONS *oap;	/* object definition structure */
	STRINGHEAD *hp;
	OBJECTACTIONS **newobjects;
	int index;

	hp = &objectnames;
	if (hp->h_list == NULL)
		initstr(hp);
	index = findstr(hp, name);
	if (index >= 0) {
		/*
		 * Object is already defined.  Give an error unless this
		 * new definition is exactly the same as the old one.
		 */
		oap = objects[index];
		if (oap->oa_count == count) {
			for (index = 0; ; index++) {
				if (index >= count)
					return 0;
				if (oap->oa_elements[index] != indices[index])
					break;
			}
		}
		return 1;
	}

	if (hp->h_count >= maxobjcount) {
		if (maxobjcount == 0) {
			newobjects = (OBJECTACTIONS **) malloc(
				OBJALLOC * sizeof(OBJECTACTIONS *));
			maxobjcount = OBJALLOC;
		} else {
			maxobjcount += OBJALLOC;
			newobjects = (OBJECTACTIONS **) realloc(objects,
				maxobjcount * sizeof(OBJECTACTIONS *));
		}
		if (newobjects == NULL) {
			math_error("Allocation failure for new object type");
			/*NOTREACHED*/
		}
		objects = newobjects;
	}

	oap = (OBJECTACTIONS *) malloc(objectactionsize(count));
	name = addstr(hp, name);
	if ((oap == NULL) || (name == NULL)) {
		math_error("Cannot allocate object type");
		/*NOTREACHED*/
	}
	oap->oa_count = count;
	for (index = OBJ_MAXFUNC; index >= 0; index--)
		oap->oa_indices[index] = -1;
	for (index = 0; index < count; index++)
		oap->oa_elements[index] = indices[index];
	index = findstr(hp, name);
	oap->oa_index = index;
	objects[index] = oap;
	return 0;
}


/*
 * Check an object name to see if it is currently defined.
 * If so, the index for the object type is returned.
 * If the object name is currently unknown, then -1 is returned.
 */
int
checkobject(char *name)
{
	STRINGHEAD *hp;

	hp = &objectnames;
	if (hp->h_list == NULL)
		return -1;
	return findstr(hp, name);
}


/*
 * Define a (possibly) new element name for an object.
 * Returns an index which identifies the element name.
 */
int
addelement(char *name)
{
	STRINGHEAD *hp;
	int index;

	hp = &elements;
	if (hp->h_list == NULL)
		initstr(hp);
	index = findstr(hp, name);
	if (index >= 0)
		return index;
	if (addstr(hp, name) == NULL) {
		math_error("Cannot allocate element name");
		/*NOTREACHED*/
	}
	return findstr(hp, name);
}


/*
 * Return the index which identifies an element name.
 * Returns minus one if the element name is unknown.
 *
 * given:
 *	name		element name
 */
int
findelement(char *name)
{
	if (elements.h_list == NULL)
		return -1;
	return findstr(&elements, name);
}


/*
 * Returns the name of object type with specified index
 */
char *
objtypename(unsigned long index)
{
	return namestr(&objectnames, (long)index);
}


/*
 * Return the value table offset to be used for an object element name.
 * This converts the element index from the element table into an offset
 * into the object value array.	 Returns -1 if the element index is unknown.
 */
int
objoffset(OBJECT *op, long index)
{
	register OBJECTACTIONS *oap;
	int offset;			/* offset into value array */

	oap = op->o_actions;
	for (offset = oap->oa_count - 1; offset >= 0; offset--) {
		if (oap->oa_elements[offset] == index)
			return offset;
	}
	return -1;
}


/*
 * Allocate a new object structure with the specified index.
 */
OBJECT *
objalloc(long index)
{
	OBJECTACTIONS *oap;
	OBJECT *op;
	VALUE *vp;
	int i;

	if (index < 0 || index > maxobjcount) {
		math_error("Allocating bad object index");
		/*NOTREACHED*/
	}
	oap = objects[index];
	if (oap == NULL) {
		math_error("Object type not defined");
		/*NOTREACHED*/
	}
	i = oap->oa_count;
	if (i < USUAL_ELEMENTS)
		i = USUAL_ELEMENTS;
	if (i == USUAL_ELEMENTS)
		op = (OBJECT *) malloc(sizeof(OBJECT));
	else
		op = (OBJECT *) malloc(objectsize(i));
	if (op == NULL) {
		math_error("Cannot allocate object");
		/*NOTREACHED*/
	}
	op->o_actions = oap;
	vp = op->o_table;
	for (i = oap->oa_count; i-- > 0; vp++) {
		vp->v_num = qlink(&_qzero_);
		vp->v_type = V_NUM;
		vp->v_subtype = V_NOSUBTYPE;
	}
	return op;
}


/*
 * Free an object structure.
 */
void
objfree(OBJECT *op)
{
	VALUE *vp;
	int i;

	vp = op->o_table;
	for (i = op->o_actions->oa_count; i-- > 0; vp++) {
		if (vp->v_type == V_NUM) {
			qfree(vp->v_num);
		} else {
			freevalue(vp);
		}
	}
	if (op->o_actions->oa_count <= USUAL_ELEMENTS)
		free(op);
	else
		free((char *) op);
}


/*
 * Copy an object value
 */
OBJECT *
objcopy(OBJECT *op)
{
	VALUE *v1, *v2;
	OBJECT *np;
	int i;

	i = op->o_actions->oa_count;
	if (i < USUAL_ELEMENTS)
		i = USUAL_ELEMENTS;
	if (i == USUAL_ELEMENTS)
		np = (OBJECT *) malloc(sizeof(OBJECT));
	else
		np = (OBJECT *) malloc(objectsize(i));
	if (np == NULL) {
		math_error("Cannot allocate object");
		/*NOTREACHED*/
	}
	np->o_actions = op->o_actions;
	v1 = op->o_table;
	v2 = np->o_table;
	for (i = op->o_actions->oa_count; i-- > 0; v1++, v2++) {
		copyvalue(v1, v2);
	}
	return np;
}


/*
 * Show object types that have been defined.
 */
void
showobjtypes(void)
{
	STRINGHEAD *hp;
	OBJECTACTIONS *oap;
	STRINGHEAD *ep;
	int index, i;

	hp = &objectnames;
	ep = &elements;
	if (hp->h_count == 0) {
		printf("No object types defined\n");
		return;
	}
	for (index = 0; index < hp->h_count; index++) {
		oap = objects[index];
		printf("\t%s\t{", namestr(&objectnames, index));
		for (i = 0; i < oap->oa_count; i++) {
			if (i) printf(",");
			printf("%s", namestr(ep, oap->oa_elements[i]));
		}
		printf("}\n");
	}

}


/* END CODE */