value.c

早期freebsd实现

			vres->v_type = V_COM;
			break;
		case V_COM:
			vres->v_com = csqrt(v1->v_com, q);
			vres->v_type = V_COM;
			break;
		case V_OBJ:
			*vres = objcall(OBJ_SQRT, v1, v2, NULL_VALUE);
			return;
		default:
			math_error("Bad value for taking square root");
	}
	c = vres->v_com;
	if (cisreal(c)) {
		vres->v_num = qlink(c->real);
		vres->v_type = V_NUM;
		comfree(c);
	}
}


/*
 * Take the Nth root of an arbitrary value within the specified error.
 * Result is placed in the indicated location.
 */
void
rootvalue(v1, v2, v3, vres)
	VALUE *v1;		/* value to take root of */
	VALUE *v2;		/* value specifying root to take */
	VALUE *v3;		/* value specifying error */
	VALUE *vres;
{
	NUMBER *q1, *q2;
	COMPLEX ctmp;

	if ((v2->v_type != V_NUM) || (v3->v_type != V_NUM))
		math_error("Non-real arguments for root");
	q1 = v2->v_num;
	q2 = v3->v_num;
	if (qisneg(q1) || qiszero(q1) || qisfrac(q1))
		math_error("Non-positive or non-integral root");
	if (qisneg(q2) || qiszero(q2))
		math_error("Non-positive epsilon for root");
	switch (v1->v_type) {
		case V_NUM:
			if (!qisneg(v1->v_num) || zisodd(q1->num)) {
				vres->v_num = qroot(v1->v_num, q1, q2);
				vres->v_type = V_NUM;
				return;
			}
			ctmp.real = v1->v_num;
			ctmp.imag = &_qzero_;
			ctmp.links = 1;
			vres->v_com = croot(&ctmp, q1, q2);
			vres->v_type = V_COM;
			return;
		case V_COM:
			vres->v_com = croot(v1->v_com, q1, q2);
			vres->v_type = V_COM;
			return;
		case V_OBJ:
			*vres = objcall(OBJ_ROOT, v1, v2, v3);
			return;
		default:
			math_error("Taking root of bad value");
	}
}


/*
 * Take the absolute value of an arbitrary value within the specified error.
 * Result is placed in the indicated location.
 */
void
absvalue(v1, v2, vres)
	VALUE *v1, *v2, *vres;
{
	static NUMBER *q;
	NUMBER *epsilon;

	if (v2->v_type != V_NUM)
		math_error("Bad epsilon type for abs");
	epsilon = v2->v_num;
	if (qiszero(epsilon) || qisneg(epsilon))
		math_error("Non-positive epsilon for abs");
	switch (v1->v_type) {
		case V_NUM:
			if (qisneg(v1->v_num))
				q = qneg(v1->v_num);
			else
				q = qlink(v1->v_num);
			break;
		case V_COM:
			q = qhypot(v1->v_com->real, v1->v_com->imag, epsilon);
			break;
		case V_OBJ:
			*vres = objcall(OBJ_ABS, v1, v2, NULL_VALUE);
			return;
		default:
			math_error("Illegal value for absolute value");
	}
	vres->v_num = q;
	vres->v_type = V_NUM;
}


/*
 * Calculate the norm of an arbitrary value.
 * Result is placed in the indicated location.
 * The norm is the square of the absolute value.
 */
void
normvalue(vp, vres)
	VALUE *vp, *vres;
{
	NUMBER *q1, *q2;

	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:
			q1 = qsquare(vp->v_com->real);
			q2 = qsquare(vp->v_com->imag);
			vres->v_num = qadd(q1, q2);
			vres->v_type = V_NUM;
			qfree(q1);
			qfree(q2);
			return;
		case V_OBJ:
			*vres = objcall(OBJ_NORM, vp, NULL_VALUE, NULL_VALUE);
			return;
		default:
			math_error("Illegal value for norm");
	}
}


/*
 * Shift a value left or right by the specified number of bits.
 * Negative shift value means shift the direction opposite the selected dir.
 * Right shifts are defined to lose bits off the low end of the number.
 * Result is placed in the indicated location.
 */
void
shiftvalue(v1, v2, rightshift, vres)
	VALUE *v1, *v2, *vres;
	BOOL rightshift;	/* TRUE if shift right instead of left */
{
	COMPLEX *c;
	long n = 0;
	VALUE tmp;

	if (v2->v_type != V_NUM)
		math_error("Non-real shift value");
 	if (qisfrac(v2->v_num))
		math_error("Non-integral shift value");
	if (v1->v_type != V_OBJ) {
		if (zisbig(v2->v_num->num))
			math_error("Very large shift value");
		n = qtoi(v2->v_num);
	}
	if (rightshift)
		n = -n;
	switch (v1->v_type) {
		case V_NUM:
			vres->v_num = qshift(v1->v_num, n);
			vres->v_type = V_NUM;
			return;
		case V_COM:
			c = cshift(v1->v_com, n);
			if (!cisreal(c)) {
				vres->v_com = c;
				vres->v_type = V_COM;
				return;
			}
			vres->v_num = qlink(c->real);
			vres->v_type = V_NUM;
			comfree(c);
			return;
		case V_MAT:
			vres->v_mat = matshift(v1->v_mat, n);
			vres->v_type = V_MAT;
			return;
		case V_OBJ:
			if (!rightshift) {
				*vres = objcall(OBJ_SHIFT, v1, v2, NULL_VALUE);
				return;
			}
			tmp.v_num = qneg(v2->v_num);
			tmp.v_type = V_NUM;
			*vres = objcall(OBJ_SHIFT, v1, &tmp, NULL_VALUE);
			qfree(tmp.v_num);
			return;
		default:
			math_error("Bad value for shifting");
	}
}


/*
 * Scale a value by a power of two.
 * Result is placed in the indicated location.
 */
void
scalevalue(v1, v2, vres)
	VALUE *v1, *v2, *vres;
{
	long n = 0;

	if (v2->v_type != V_NUM)
		math_error("Non-real scaling factor");
	if (qisfrac(v2->v_num))
		math_error("Non-integral scaling factor");
	if (v1->v_type != V_OBJ) {
		if (zisbig(v2->v_num->num))
			math_error("Very large scaling factor");
		n = qtoi(v2->v_num);
	}
	switch (v1->v_type) {
		case V_NUM:
			vres->v_num = qscale(v1->v_num, n);
			vres->v_type = V_NUM;
			return;
		case V_COM:
			vres->v_com = cscale(v1->v_com, n);
			vres->v_type = V_NUM;
			return;
		case V_MAT:
			vres->v_mat = matscale(v1->v_mat, n);
			vres->v_type = V_MAT;
			return;
		case V_OBJ:
			*vres = objcall(OBJ_SCALE, v1, v2, NULL_VALUE);
			return;
		default:
			math_error("Bad value for scaling");
	}
}


/*
 * Raise a value to an integral power.
 * Result is placed in the indicated location.
 */
void
powivalue(v1, v2, vres)
	VALUE *v1, *v2, *vres;
{
	NUMBER *q;
	COMPLEX *c;

	vres->v_type = V_NULL;
	if (v2->v_type != V_NUM)
		math_error("Raising value to non-real power");
	q = v2->v_num;
	if (qisfrac(q))
		math_error("Raising value to non-integral power");
	switch (v1->v_type) {
		case V_NUM:
			vres->v_num = qpowi(v1->v_num, q);
			vres->v_type = V_NUM;
			return;
		case V_COM:
			vres->v_com = cpowi(v1->v_com, q);
			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 = matpowi(v1->v_mat, q);
			vres->v_type = V_MAT;
			return;
		case V_OBJ:
			*vres = objcall(OBJ_POW, v1, v2, NULL_VALUE);
			return;
		default:
			math_error("Illegal value for raising to integer power");
	}
}


/*
 * Raise one value to another value's power, within the specified error.
 * Result is placed in the indicated location.
 */
void
powervalue(v1, v2, v3, vres)
	VALUE *v1, *v2, *v3, *vres;
{
	NUMBER *epsilon;
	COMPLEX *c, ctmp;

	vres->v_type = V_NULL;
	if (v3->v_type != V_NUM)
		math_error("Non-real epsilon value for power");
	epsilon = v3->v_num;
	if (qisneg(epsilon) || qiszero(epsilon))
		math_error("Non-positive epsilon value for power");
	switch (TWOVAL(v1->v_type, v2->v_type)) {
		case TWOVAL(V_NUM, V_NUM):
			vres->v_num = qpower(v1->v_num, v2->v_num, epsilon);
			vres->v_type = V_NUM;
			return;
		case TWOVAL(V_NUM, V_COM):
			ctmp.real = v1->v_num;
			ctmp.imag = &_qzero_;
			ctmp.links = 1;
			vres->v_com = cpower(&ctmp, v2->v_com, epsilon);
			break;
		case TWOVAL(V_COM, V_NUM):
			ctmp.real = v2->v_num;
			ctmp.imag = &_qzero_;
			ctmp.links = 1;
			vres->v_com = cpower(v1->v_com, &ctmp, epsilon);
			break;
		case TWOVAL(V_COM, V_COM):
			vres->v_com = cpower(v1->v_com, v2->v_com, epsilon);
			break;
		default:
			math_error("Illegal value for raising to power");
	}
	/*
	 * Here for any complex result.
	 */
	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);
}


/*
 * Divide one arbitrary value by another one.
 * Result is placed in the indicated location.
 */
void
divvalue(v1, v2, vres)
	VALUE *v1, *v2, *vres;
{
	COMPLEX *c;
	COMPLEX ctmp;
	VALUE tmpval;

	vres->v_type = V_NULL;
	switch (TWOVAL(v1->v_type, v2->v_type)) {
		case TWOVAL(V_NUM, V_NUM):
			vres->v_num = qdiv(v1->v_num, v2->v_num);
			vres->v_type = V_NUM;
			return;
		case TWOVAL(V_COM, V_NUM):
			vres->v_com = cdivq(v1->v_com, v2->v_num);
			vres->v_type = V_COM;
			return;
		case TWOVAL(V_NUM, V_COM):
			if (qiszero(v1->v_num)) {
				vres->v_num = qlink(&_qzero_);
				vres->v_type = V_NUM;
				return;
			}
			ctmp.real = v1->v_num;
			ctmp.imag = &_qzero_;
			ctmp.links = 1;
			vres->v_com = cdiv(&ctmp, v2->v_com);
			vres->v_type = V_COM;
			return;
		case TWOVAL(V_COM, V_COM):
			vres->v_com = cdiv(v1->v_com, v2->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 TWOVAL(V_MAT, V_NUM):
		case TWOVAL(V_MAT, V_COM):
			invertvalue(v2, &tmpval);
			vres->v_mat = matmulval(v1->v_mat, &tmpval);
			vres->v_type = V_MAT;
			freevalue(&tmpval);
			return;
		default:
			if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
				math_error("Non-compatible values for divide");
			*vres = objcall(OBJ_DIV, v1, v2, NULL_VALUE);
			return;
	}
}


/*
 * Divide one arbitrary value by another one keeping only the integer part.
 * Result is placed in the indicated location.
 */
void
quovalue(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 = qquo(v1->v_num, v2->v_num);
			vres->v_type = V_NUM;
			return;
		case TWOVAL(V_COM, V_NUM):
			vres->v_com = cquoq(v1->v_com, v2->v_num);
			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 TWOVAL(V_MAT, V_NUM):
		case TWOVAL(V_MAT, V_COM):
			vres->v_mat = matquoval(v1->v_mat, v2);
			vres->v_type = V_MAT;
			return;
		default:
			if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
				math_error("Non-compatible values for quotient");
			*vres = objcall(OBJ_QUO, v1, v2, NULL_VALUE);
			return;
	}
}


/*
 * Divide one arbitrary value by another one keeping only the remainder.
 * Result is placed in the indicated location.
 */
void
modvalue(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 = qmod(v1->v_num, v2->v_num);
			vres->v_type = V_NUM;
			return;
		case TWOVAL(V_COM, V_NUM):
			vres->v_com = cmodq(v1->v_com, v2->v_num);
			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 TWOVAL(V_MAT, V_NUM):
		case TWOVAL(V_MAT, V_COM):
			vres->v_mat = matmodval(v1->v_mat, v2);
			vres->v_type = V_MAT;
			return;
		default:
			if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
				math_error("Non-compatible values for mod");
			*vres = objcall(OBJ_MOD, v1, v2, NULL_VALUE);
			return;
	}
}


/*
 * Test an arbitrary value to see if it is equal to "zero".
 * The definition of zero varies depending on the value type.  For example,
 * the null string is "zero", and a matrix with zero values is "zero".
 * Returns TRUE if value is not equal to zero.
 */
BOOL
testvalue(vp)
	VALUE *vp;
{
	VALUE val;

	switch (vp->v_type) {
		case V_NUM:
			return !qiszero(vp->v_num);
		case V_COM:
			return !ciszero(vp->v_com);
		case V_STR:
			return (vp->v_str[0] != '\0');
		case V_MAT:
			return mattest(vp->v_mat);
		case V_LIST:
			return (vp->v_list->l_count != 0);
		case V_ASSOC:
			return (vp->v_assoc->a_count != 0);
		case V_FILE:
			return validid(vp->v_file);
		case V_NULL:
			return FALSE;
		case V_OBJ:
			val = objcall(OBJ_TEST, vp, NULL_VALUE, NULL_VALUE);
			return (val.v_int != 0);
		default:
			return TRUE;
	}
}


/*
 * Compare two values for equality.
 * Returns TRUE if the two values differ.
 */
BOOL
comparevalue(v1, v2)
	VALUE *v1, *v2;
{
	int r = FALSE;
	VALUE val;

	if ((v1->v_type == V_OBJ) || (v2->v_type == V_OBJ)) {
		val = objcall(OBJ_CMP, v1, v2, NULL_VALUE);
		return (val.v_int != 0);
	}
	if (v1 == v2)
		return FALSE;
	if (v1->v_type != v2->v_type)
		return TRUE;
	switch (v1->v_type) {
		case V_NUM:
			r = qcmp(v1->v_num, v2->v_num);
			break;
		case V_COM:
			r = ccmp(v1->v_com, v2->v_com);
			break;
		case V_STR:
			r = ((v1->v_str != v2->v_str) &&
				((v1->v_str[0] - v2->v_str[0]) ||
				strcmp(v1->v_str, v2->v_str)));
			break;
		case V_MAT:
			r = matcmp(v1->v_mat, v2->v_mat);
			break;
		case V_LIST:
			r = listcmp(v1->v_list, v2->v_list);
			break;
		case V_ASSOC:
			r = assoccmp(v1->v_assoc, v2->v_assoc);
			break;
		case V_NULL:
			break;
		case V_FILE:
			r = (v1->v_file != v2->v_file);
			break;
		default:
			math_error("Illegal values for comparevalue");
	}
	return (r != 0);
}


/*
 * Compare two values for their relative values.
 * Returns minus one if the first value is less than the second one,
 * one if the first value is greater than the second one, and
 * zero if they are equal.
 */
FLAG
relvalue(v1, v2)
	VALUE *v1, *v2;
{
	int r = 0;
	VALUE val;

	if ((v1->v_type == V_OBJ) || (v2->v_type == V_OBJ)) {
		val = objcall(OBJ_REL, v1, v2, NULL_VALUE);
		return val.v_int;
	}
	if (v1 == v2)
		return 0;
	if (v1->v_type != v2->v_type)
		math_error("Relative comparison of differing types");
	switch (v1->v_type) {
		case V_NUM:
			r = qrel(v1->v_num, v2->v_num);
			break;
		case V_STR:
			r = strcmp(v1->v_str, v2->v_str);
			break;
		case V_NULL:
			break;
		default:
			math_error("Illegal value for relative comparison");
	}
	if (r < 0)
		return -1;
	return (r != 0);
}


/*
 * Calculate a hash value for a value.
 * The hash does not have to be a perfect one, it is only used for
 * making associations faster.
 */
HASH
hashvalue(vp)
	VALUE *vp;
{
	switch (vp->v_type) {
		case V_INT:
			return ((long) vp->v_int);
		case V_NUM:
			return qhash(vp->v_num);
		case V_COM:
			return chash(vp->v_com);
		case V_STR:
			return hashstr(vp->v_str);
		case V_NULL:
			return 0;
		case V_OBJ:
			return objhash(vp->v_obj);
		case V_LIST:
			return listhash(vp->v_list);
		case V_ASSOC:
			return assochash(vp->v_assoc);
		case V_MAT:
			return mathash(vp->v_mat);
		case V_FILE:
			return ((long) vp->v_file);
		default:
			math_error("Hashing unknown value");
	}
	return 0;
}


/*
 * Print the value of a descriptor in one of several formats.
 * If flags contains PRINT_SHORT, then elements of arrays and lists
 * will not be printed.  If flags contains PRINT_UNAMBIG, then quotes
 * are placed around strings and the null value is explicitly printed.
 */
void
printvalue(vp, flags)
	VALUE *vp;
	int flags;
{
	switch (vp->v_type) {
		case V_NUM:
			qprintnum(vp->v_num, MODE_DEFAULT);
			break;
		case V_COM:
			comprint(vp->v_com);
			break;
		case V_STR:
			if (flags & PRINT_UNAMBIG)
				math_chr('\"');
			math_str(vp->v_str);
			if (flags & PRINT_UNAMBIG)
				math_chr('\"');
			break;
		case V_NULL:
			if (flags & PRINT_UNAMBIG)
				math_str("NULL");
			break;
		case V_OBJ:
			(void) objcall(OBJ_PRINT, vp, NULL_VALUE, NULL_VALUE);
			break;
		case V_LIST:
			listprint(vp->v_list,
				((flags & PRINT_SHORT) ? 0L : maxprint));
			break;
		case V_ASSOC:
			assocprint(vp->v_assoc,
				((flags & PRINT_SHORT) ? 0L : maxprint));
			break;
		case V_MAT:
			matprint(vp->v_mat,
				((flags & PRINT_SHORT) ? 0L : maxprint));
			break;
		case V_FILE:
			printid(vp->v_file, flags);
			break;
		default:
			math_error("Printing unknown value");
	}
}

/* END CODE */