value.c

早期freebsd实现

/*
 * Copyright (c) 1994 David I. Bell
 * Permission is granted to use, distribute, or modify this source,
 * provided that this copyright notice remains intact.
 *
 * Generic value manipulation routines.
 */

#include "value.h"
#include "opcodes.h"
#include "func.h"
#include "symbol.h"
#include "string.h"


/*
 * Free a value and set its type to undefined.
 */
void
freevalue(vp)
	register VALUE *vp;	/* value to be freed */
{
	int type;		/* type of value being freed */

	type = vp->v_type;
	vp->v_type = V_NULL;
	switch (type) {
		case V_NULL:
		case V_ADDR:
		case V_FILE:
			break;
		case V_STR:
			if (vp->v_subtype == V_STRALLOC)
				free(vp->v_str);
			break;
		case V_NUM:
			qfree(vp->v_num);
			break;
		case V_COM:
			comfree(vp->v_com);
			break;
		case V_MAT:
			matfree(vp->v_mat);
			break;
		case V_LIST:
			listfree(vp->v_list);
			break;
		case V_ASSOC:
			assocfree(vp->v_assoc);
			break;
		case V_OBJ:
			objfree(vp->v_obj);
			break;
		default:
			math_error("Freeing unknown value type");
	}
	vp->v_subtype = V_NOSUBTYPE;
}


/*
 * Copy a value from one location to another.
 * This overwrites the specified new value without checking it.
 */
void
copyvalue(oldvp, newvp)
	register VALUE *oldvp;		/* value to be copied from */
	register VALUE *newvp;		/* value to be copied into */
{
	newvp->v_type = V_NULL;
	switch (oldvp->v_type) {
		case V_NULL:
			break;
		case V_FILE:
			newvp->v_file = oldvp->v_file;
			break;
		case V_NUM:
			newvp->v_num = qlink(oldvp->v_num);
			break;
		case V_COM:
			newvp->v_com = clink(oldvp->v_com);
			break;
		case V_STR:
			newvp->v_str = oldvp->v_str;
			if (oldvp->v_subtype == V_STRALLOC) {
				newvp->v_str = (char *)malloc(strlen(oldvp->v_str) + 1);
				if (newvp->v_str == NULL)
					math_error("Cannot get memory for string copy");
				strcpy(newvp->v_str, oldvp->v_str);
			}
			break;
		case V_MAT:
			newvp->v_mat = matcopy(oldvp->v_mat);
			break;
		case V_LIST:
			newvp->v_list = listcopy(oldvp->v_list);
			break;
		case V_ASSOC:
			newvp->v_assoc = assoccopy(oldvp->v_assoc);
			break;
		case V_ADDR:
			newvp->v_addr = oldvp->v_addr;
			break;
		case V_OBJ:
			newvp->v_obj = objcopy(oldvp->v_obj);
			break;
		default:
			math_error("Copying unknown value type");
	}
	if (oldvp->v_type == V_STR) {
		newvp->v_subtype = oldvp->v_subtype;
	} else {
		newvp->v_subtype = V_NOSUBTYPE;
	}
	newvp->v_type = oldvp->v_type;

}


/*
 * Negate an arbitrary value.
 * Result is placed in the indicated location.
 */
void
negvalue(vp, vres)
	VALUE *vp, *vres;
{
	vres->v_type = V_NULL;
	switch (vp->v_type) {
		case V_NUM:
			vres->v_num = qneg(vp->v_num);
			vres->v_type = V_NUM;
			return;
		case V_COM:
			vres->v_com = cneg(vp->v_com);
			vres->v_type = V_COM;
			return;
		case V_MAT:
			vres->v_mat = matneg(vp->v_mat);
			vres->v_type = V_MAT;
			return;
		case V_OBJ:
			*vres = objcall(OBJ_NEG, vp, NULL_VALUE, NULL_VALUE);
			return;
		default:
			math_error("Illegal value for negation");
	}
}


/*
 * Add two arbitrary values together.
 * Result is placed in the indicated location.
 */
void
addvalue(v1, v2, vres)
	VALUE *v1, *v2, *vres;
{
	COMPLEX *c;

	vres->v_type = V_NULL;
	switch (TWOVAL(v1->v_type, v2->v_type)) {
		case TWOVAL(V_NUM, V_NUM):
			vres->v_num = qadd(v1->v_num, v2->v_num);
			vres->v_type = V_NUM;
			return;
		case TWOVAL(V_COM, V_NUM):
			vres->v_com = caddq(v1->v_com, v2->v_num);
			vres->v_type = V_COM;
			return;
		case TWOVAL(V_NUM, V_COM):
			vres->v_com = caddq(v2->v_com, v1->v_num);
			vres->v_type = V_COM;
			return;
		case TWOVAL(V_COM, V_COM):
			vres->v_com = cadd(v1->v_com, v2->v_com);
			vres->v_type = V_COM;
			c = vres->v_com;
			if (!cisreal(c))
				return;
			vres->v_num = qlink(c->real);
			vres->v_type = V_NUM;
			comfree(c);
			return;
		case TWOVAL(V_MAT, V_MAT):
			vres->v_mat = matadd(v1->v_mat, v2->v_mat);
			vres->v_type = V_MAT;
			return;
		default:
			if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
				math_error("Non-compatible values for add");
			*vres = objcall(OBJ_ADD, v1, v2, NULL_VALUE);
			return;
	}
}


/*
 * Subtract one arbitrary value from another one.
 * Result is placed in the indicated location.
 */
void
subvalue(v1, v2, vres)
	VALUE *v1, *v2, *vres;
{
	COMPLEX *c;

	vres->v_type = V_NULL;
	switch (TWOVAL(v1->v_type, v2->v_type)) {
		case TWOVAL(V_NUM, V_NUM):
			vres->v_num = qsub(v1->v_num, v2->v_num);
			vres->v_type = V_NUM;
			return;
		case TWOVAL(V_COM, V_NUM):
			vres->v_com = csubq(v1->v_com, v2->v_num);
			vres->v_type = V_COM;
			return;
		case TWOVAL(V_NUM, V_COM):
			c = csubq(v2->v_com, v1->v_num);
			vres->v_com = cneg(c);
			comfree(c);
			vres->v_type = V_COM;
			return;
		case TWOVAL(V_COM, V_COM):
			vres->v_com = csub(v1->v_com, v2->v_com);
			vres->v_type = V_COM;
			c = vres->v_com;
			if (!cisreal(c))
				return;
			vres->v_num = qlink(c->real);
			vres->v_type = V_NUM;
			comfree(c);
			return;
		case TWOVAL(V_MAT, V_MAT):
			vres->v_mat = matsub(v1->v_mat, v2->v_mat);
			vres->v_type = V_MAT;
			return;
		default:
			if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
				math_error("Non-compatible values for subtract");
			*vres = objcall(OBJ_SUB, v1, v2, NULL_VALUE);
			return;
	}
}


/*
 * Multiply two arbitrary values together.
 * Result is placed in the indicated location.
 */
void
mulvalue(v1, v2, vres)
	VALUE *v1, *v2, *vres;
{
	COMPLEX *c;

	vres->v_type = V_NULL;
	switch (TWOVAL(v1->v_type, v2->v_type)) {
		case TWOVAL(V_NUM, V_NUM):
			vres->v_num = qmul(v1->v_num, v2->v_num);
			vres->v_type = V_NUM;
			return;
		case TWOVAL(V_COM, V_NUM):
			vres->v_com = cmulq(v1->v_com, v2->v_num);
			vres->v_type = V_COM;
			break;
		case TWOVAL(V_NUM, V_COM):
			vres->v_com = cmulq(v2->v_com, v1->v_num);
			vres->v_type = V_COM;
			break;
		case TWOVAL(V_COM, V_COM):
			vres->v_com = cmul(v1->v_com, v2->v_com);
			vres->v_type = V_COM;
			break;
		case TWOVAL(V_MAT, V_MAT):
			vres->v_mat = matmul(v1->v_mat, v2->v_mat);
			vres->v_type = V_MAT;
			return;
		case TWOVAL(V_MAT, V_NUM):
		case TWOVAL(V_MAT, V_COM):
			vres->v_mat = matmulval(v1->v_mat, v2);
			vres->v_type = V_MAT;
			return;
		case TWOVAL(V_NUM, V_MAT):
		case TWOVAL(V_COM, V_MAT):
			vres->v_mat = matmulval(v2->v_mat, v1);
			vres->v_type = V_MAT;
			return;
		default:
			if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
				math_error("Non-compatible values for multiply");
			*vres = objcall(OBJ_MUL, v1, v2, NULL_VALUE);
			return;
	}
	c = vres->v_com;
	if (cisreal(c)) {
		vres->v_num = qlink(c->real);
		vres->v_type = V_NUM;
		comfree(c);
	}
}


/*
 * Square an arbitrary value.
 * Result is placed in the indicated location.
 */
void
squarevalue(vp, vres)
	VALUE *vp, *vres;
{
	COMPLEX *c;

	vres->v_type = V_NULL;
	switch (vp->v_type) {
		case V_NUM:
			vres->v_num = qsquare(vp->v_num);
			vres->v_type = V_NUM;
			return;
		case V_COM:
			vres->v_com = csquare(vp->v_com);
			vres->v_type = V_COM;
			c = vres->v_com;
			if (!cisreal(c))
				return;
			vres->v_num = qlink(c->real);
			vres->v_type = V_NUM;
			comfree(c);
			return;
		case V_MAT:
			vres->v_mat = matsquare(vp->v_mat);
			vres->v_type = V_MAT;
			return;
		case V_OBJ:
			*vres = objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE);
			return;
		default:
			math_error("Illegal value for squaring");
	}
}


/*
 * Invert an arbitrary value.
 * Result is placed in the indicated location.
 */
void
invertvalue(vp, vres)
	VALUE *vp, *vres;
{
	vres->v_type = V_NULL;
	switch (vp->v_type) {
		case V_NUM:
			vres->v_num = qinv(vp->v_num);
			vres->v_type = V_NUM;
			return;
		case V_COM:
			vres->v_com = cinv(vp->v_com);
			vres->v_type = V_COM;
			return;
		case V_MAT:
			vres->v_mat = matinv(vp->v_mat);
			vres->v_type = V_MAT;
			return;
		case V_OBJ:
			*vres = objcall(OBJ_INV, vp, NULL_VALUE, NULL_VALUE);
			return;
		default:
			math_error("Illegal value for inverting");
	}
}


/*
 * Round an arbitrary value to the specified number of decimal places.
 * Result is placed in the indicated location.
 */
void
roundvalue(v1, v2, vres)
	VALUE *v1, *v2, *vres;
{
	long places = -1;
	NUMBER *q;
	COMPLEX *c;

	switch (v2->v_type) {
		case V_NUM:
			q = v2->v_num;
			if (qisfrac(q) || zisbig(q->num))
				math_error("Bad number of places for round");
			places = qtoi(q);
			break;
		case V_INT:
			places = v2->v_int;
			break;
		default:
			math_error("Bad value type for places in round");
	}
	if (places < 0)
		math_error("Negative number of places in round");
	vres->v_type = V_NULL;
	switch (v1->v_type) {
		case V_NUM:
			if (qisint(v1->v_num))
				vres->v_num = qlink(v1->v_num);
			else
				vres->v_num = qround(v1->v_num, places);
			vres->v_type = V_NUM;
			return;
		case V_COM:
			if (cisint(v1->v_com)) {
				vres->v_com = clink(v1->v_com);
				vres->v_type = V_COM;
				return;
			}
			vres->v_com = cround(v1->v_com, places);
			vres->v_type = V_COM;
			c = vres->v_com;
			if (cisreal(c)) {
				vres->v_num = qlink(c->real);
				vres->v_type = V_NUM;
				comfree(c);
			}
			return;
		case V_MAT:
			vres->v_mat = matround(v1->v_mat, places);
			vres->v_type = V_MAT;
			return;
		case V_OBJ:
			*vres = objcall(OBJ_ROUND, v1, v2, NULL_VALUE);
			return;
		default:
			math_error("Illegal value for round");
	}
}


/*
 * Round an arbitrary value to the specified number of binary places.
 * Result is placed in the indicated location.
 */
void
broundvalue(v1, v2, vres)
	VALUE *v1, *v2, *vres;
{
	long places = -1;
	NUMBER *q;
	COMPLEX *c;

	switch (v2->v_type) {
		case V_NUM:
			q = v2->v_num;
			if (qisfrac(q) || zisbig(q->num))
				math_error("Bad number of places for bround");
			places = qtoi(q);
			break;
		case V_INT:
			places = v2->v_int;
			break;
		default:
			math_error("Bad value type for places in bround");
	}
	if (places < 0)
		math_error("Negative number of places in bround");
	vres->v_type = V_NULL;
	switch (v1->v_type) {
		case V_NUM:
			if (qisint(v1->v_num))
				vres->v_num = qlink(v1->v_num);
			else
				vres->v_num = qbround(v1->v_num, places);
			vres->v_type = V_NUM;
			return;
		case V_COM:
			if (cisint(v1->v_com)) {
				vres->v_com = clink(v1->v_com);
				vres->v_type = V_COM;
				return;
			}
			vres->v_com = cbround(v1->v_com, places);
			vres->v_type = V_COM;
			c = vres->v_com;
			if (cisreal(c)) {
				vres->v_num = qlink(c->real);
				vres->v_type = V_NUM;
				comfree(c);
			}
			return;
		case V_MAT:
			vres->v_mat = matbround(v1->v_mat, places);
			vres->v_type = V_MAT;
			return;
		case V_OBJ:
			*vres = objcall(OBJ_BROUND, v1, v2, NULL_VALUE);
			return;
		default:
			math_error("Illegal value for bround");
	}
}


/*
 * Take the integer part of an arbitrary value.
 * Result is placed in the indicated location.
 */
void
intvalue(vp, vres)
	VALUE *vp, *vres;
{
	COMPLEX *c;

	vres->v_type = V_NULL;
	switch (vp->v_type) {
		case V_NUM:
			if (qisint(vp->v_num))
				vres->v_num = qlink(vp->v_num);
			else
				vres->v_num = qint(vp->v_num);
			vres->v_type = V_NUM;
			return;
		case V_COM:
			if (cisint(vp->v_com)) {
				vres->v_com = clink(vp->v_com);
				vres->v_type = V_COM;
				return;
			}
			vres->v_com = cint(vp->v_com);
			vres->v_type = V_COM;
			c = vres->v_com;
			if (cisreal(c)) {
				vres->v_num = qlink(c->real);
				vres->v_type = V_NUM;
				comfree(c);
			}
			return;
		case V_MAT:
			vres->v_mat = matint(vp->v_mat);
			vres->v_type = V_MAT;
			return;
		case V_OBJ:
			*vres = objcall(OBJ_INT, vp, NULL_VALUE, NULL_VALUE);
			return;
		default:
			math_error("Illegal value for int");
	}
}


/*
 * Take the fractional part of an arbitrary value.
 * Result is placed in the indicated location.
 */
void
fracvalue(vp, vres)
	VALUE *vp, *vres;
{
	vres->v_type = V_NULL;
	switch (vp->v_type) {
		case V_NUM:
			if (qisint(vp->v_num))
				vres->v_num = qlink(&_qzero_);
			else
				vres->v_num = qfrac(vp->v_num);
			vres->v_type = V_NUM;
			return;
		case V_COM:
			if (cisint(vp->v_com)) {
				vres->v_num = clink(&_qzero_);
				vres->v_type = V_NUM;
				return;
			}
			vres->v_com = cfrac(vp->v_com);
			vres->v_type = V_COM;
			return;
		case V_MAT:
			vres->v_mat = matfrac(vp->v_mat);
			vres->v_type = V_MAT;
			return;
		case V_OBJ:
			*vres = objcall(OBJ_FRAC, vp, NULL_VALUE, NULL_VALUE);
			return;
		default:
			math_error("Illegal value for frac function");
	}
}


/*
 * Increment an arbitrary value by one.
 * Result is placed in the indicated location.
 */
void
incvalue(vp, vres)
	VALUE *vp, *vres;
{
	switch (vp->v_type) {
		case V_NUM:
			vres->v_num = qinc(vp->v_num);
			vres->v_type = V_NUM;
			return;
		case V_COM:
			vres->v_com = caddq(vp->v_com, &_qone_);
			vres->v_type = V_COM;
			return;
		case V_OBJ:
			*vres = objcall(OBJ_INC, vp, NULL_VALUE, NULL_VALUE);
			return;
		default:
			math_error("Illegal value for incrementing");
	}
}


/*
 * Decrement an arbitrary value by one.
 * Result is placed in the indicated location.
 */
void
decvalue(vp, vres)
	VALUE *vp, *vres;
{
	switch (vp->v_type) {
		case V_NUM:
			vres->v_num = qdec(vp->v_num);
			vres->v_type = V_NUM;
			return;
		case V_COM:
			vres->v_com = caddq(vp->v_com, &_qnegone_);
			vres->v_type = V_COM;
			return;
		case V_OBJ:
			*vres = objcall(OBJ_DEC, vp, NULL_VALUE, NULL_VALUE);
			return;
		default:
			math_error("Illegal value for decrementing");
	}
}


/*
 * Produce the 'conjugate' of an arbitrary value.
 * Result is placed in the indicated location.
 * (Example: complex conjugate.)
 */
void
conjvalue(vp, vres)
	VALUE *vp, *vres;
{
	vres->v_type = V_NULL;
	switch (vp->v_type) {
		case V_NUM:
			vres->v_num = qlink(vp->v_num);
			vres->v_type = V_NUM;
			return;
		case V_COM:
			vres->v_com = comalloc();
			vres->v_com->real = qlink(vp->v_com->real);
			vres->v_com->imag = qneg(vp->v_com->imag);
			vres->v_type = V_COM;
			return;
		case V_MAT:
			vres->v_mat = matconj(vp->v_mat);
			vres->v_type = V_MAT;
			return;
		case V_OBJ:
			*vres = objcall(OBJ_CONJ, vp, NULL_VALUE, NULL_VALUE);
			return;
		default:
			math_error("Illegal value for conjugation");
	}
}


/*
 * Take the square root of an arbitrary value within the specified error.
 * Result is placed in the indicated location.
 */
void
sqrtvalue(v1, v2, vres)
	VALUE *v1, *v2, *vres;
{
	NUMBER *q, *tmp;
	COMPLEX *c;

	if (v2->v_type != V_NUM)
		math_error("Non-real epsilon for sqrt");
	q = v2->v_num;
	if (qisneg(q) || qiszero(q))
		math_error("Illegal epsilon value for sqrt");
	switch (v1->v_type) {
		case V_NUM:
			if (!qisneg(v1->v_num)) {
				vres->v_num = qsqrt(v1->v_num, q);
				vres->v_type = V_NUM;
				return;
			}
			tmp = qneg(v1->v_num);
			c = comalloc();
			c->imag = qsqrt(tmp, q);
			qfree(tmp);
			vres->v_com = c;