value.c

Calc Software Package for Number Calc

		return;
	case V_COM:
		q1 = qmod(v1->v_com->real, v2->v_num, rnd);
		q2 = qmod(v1->v_com->imag, v2->v_num, rnd);
		if (qiszero(q2)) {
			qfree(q2);
			vres->v_type = V_NUM;
			vres->v_num = q1;
			return;
		}
		c = comalloc();
		qfree(c->real);
		qfree(c->imag);
		c->real = q1;
		c->imag = q2;
		vres->v_com = c;
		return;
	default:
		*vres = error_value(E_MOD);
		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(VALUE *vp)
{
	VALUE val;
	LISTELEM *ep;
	int i;

	switch (vp->v_type) {
	case V_NUM:
		return !qiszero(vp->v_num);
	case V_COM:
		return !ciszero(vp->v_com);
	case V_STR:
		return stringtest(vp->v_str);
	case V_MAT:
		return mattest(vp->v_mat);
	case V_LIST:
		for (ep = vp->v_list->l_first; ep; ep = ep->e_next) {
			if (testvalue(&ep->e_value))
				return TRUE;
		}
		return FALSE;
	case V_ASSOC:
		return (vp->v_assoc->a_count != 0);
	case V_FILE:
		return validid(vp->v_file);
	case V_NULL:
		break;	/* hack to get gcc on SunOS to be quiet */
	case V_OBJ:
		val = objcall(OBJ_TEST, vp, NULL_VALUE, NULL_VALUE);
		return (val.v_int != 0);
	case V_BLOCK:
		for (i=0; i < vp->v_block->datalen; ++i) {
			if (vp->v_block->data[i]) {
				return TRUE;
			}
		}
		return FALSE;
	case V_OCTET:
		return (*vp->v_octet != 0);
	case V_NBLOCK:
		if (vp->v_nblock->blk->data == NULL)
			return FALSE;
		for (i=0; i < vp->v_nblock->blk->datalen; ++i) {
			if (vp->v_nblock->blk->data[i]) {
				return TRUE;
			}
		}
		return FALSE;
	default:
		return TRUE;
	}
	/* hack to get gcc on SunOS to be quiet */
	return FALSE;
}


/*
 * Compare two values for equality.
 * Returns TRUE if the two values differ.
 */
BOOL
comparevalue(VALUE *v1, VALUE *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 ==  V_OCTET) {
		if (v2->v_type == V_OCTET)
			return (*v1->v_octet != *v2->v_octet);
		if (v2->v_type == V_STR)
			return (*v1->v_octet != (OCTET) *v2->v_str->s_str)
				|| (v2->v_str->s_len != 1);
		if (v2->v_type != V_NUM || qisfrac(v2->v_num) ||
			qisneg(v2->v_num) || v2->v_num->num.len > 1)
				return TRUE;
		return (*v2->v_num->num.v != *v1->v_octet);
	}
	if (v2->v_type == V_OCTET)
		return comparevalue(v2, v1);
	if (v1->v_type != v2->v_type)
		return TRUE;
	if (v1->v_type <= 0)
		return FALSE;
	switch (v1->v_type) {
	case V_NUM:
		r = qcmp(v1->v_num, v2->v_num);
		break;
	case V_COM:
		r = c_cmp(v1->v_com, v2->v_com);
		break;
	case V_STR:
		r = stringcmp(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_FILE:
		r = (v1->v_file != v2->v_file);
		break;
	case V_RAND:
		r = randcmp(v1->v_rand, v2->v_rand);
		break;
	case V_RANDOM:
		r = randomcmp(v1->v_random, v2->v_random);
		break;
	case V_CONFIG:
		r = config_cmp(v1->v_config, v2->v_config);
		break;
	case V_HASH:
		r = hash_cmp(v1->v_hash, v2->v_hash);
		break;
	case V_BLOCK:
		r = blk_cmp(v1->v_block, v2->v_block);
		break;
	case V_OCTET:
		r = (v1->v_octet != v2->v_octet);
		break;
	case V_NBLOCK:
		return (v1->v_nblock != v2->v_nblock);
	case V_VPTR:
		return (v1->v_addr != v2->v_addr);
	case V_OPTR:
		return (v1->v_octet != v2->v_octet);
	case V_SPTR:
		return (v1->v_str != v2->v_str);
	case V_NPTR:
		return (v1->v_num != v2->v_num);
	default:
		math_error("Illegal values for comparevalue");
		/*NOTREACHED*/
	}
	return (r != 0);
}

BOOL
acceptvalue(VALUE *v1, VALUE *v2)
{
	long index;
	FUNC *fp;
	BOOL ret;

	index = adduserfunc("accept");
	fp = findfunc(index);
	if (fp) {
		++stack;
		stack->v_type = V_ADDR;
		stack->v_subtype = V_NOSUBTYPE;
		stack->v_addr = v1;
		++stack;
		stack->v_type = V_ADDR;
		stack->v_subtype = V_NOSUBTYPE;
		stack->v_addr = v2;
		calculate(fp, 2);
		ret = testvalue(stack);
		freevalue(stack--);
		return ret;
	}
	return (!comparevalue(v1, v2));
}


BOOL
precvalue(VALUE *v1, VALUE *v2)
{
	VALUE val;
	long index;
	int r = 0;
	FUNC *fp;
	BOOL ret;

	index = adduserfunc("precedes");
	fp = findfunc(index);
	if (fp) {
		++stack;
		stack->v_type = V_ADDR;
		stack->v_subtype = V_NOSUBTYPE;
		stack->v_addr = v1;
		++stack;
		stack->v_type = V_ADDR;
		stack->v_subtype = V_NOSUBTYPE;
		stack->v_addr = v2;
		calculate(fp, 2);
		ret = testvalue(stack);
		freevalue(stack--);
		return ret;
	}
	relvalue(v1, v2, &val);
	if ((val.v_type == V_NUM && qisneg(val.v_num)) ||
		(val.v_type == V_COM && qisneg(val.v_com->imag)))
		r = 1;
	if (val.v_type == V_NULL)
		r = (v1->v_type < v2->v_type);
	freevalue(&val);
	return r;
}


VALUE
signval(int r)
{
	VALUE val;

	val.v_type = V_NUM;
	val.v_subtype = V_NOSUBTYPE;
	if (r > 0)
		val.v_num = qlink(&_qone_);
	else if (r < 0)
		val.v_num = qlink(&_qnegone_);
	else
		val.v_num = qlink(&_qzero_);
	return val;
}


/*
 * Compare two values for their relative values.
 * Result is placed in the indicated location.
 */
void
relvalue(VALUE *v1, VALUE *v2, VALUE *vres)
{
	int r = 0;
	int i = 0;
	NUMBER *q;
	COMPLEX *c;

	vres->v_subtype = V_NOSUBTYPE;
	vres->v_type = V_NULL;
	if ((v1->v_type == V_OBJ) || (v2->v_type == V_OBJ)) {
		*vres = objcall(OBJ_REL, v1, v2, NULL_VALUE);
		return;
	}
	switch(v1->v_type) {
	case V_NUM:
		switch(v2->v_type) {
		case V_NUM:
			r = qrel(v1->v_num, v2->v_num);
			break;
		case V_OCTET:
			q = itoq((long) *v2->v_octet);
			r = qrel(v1->v_num, q);
			qfree(q);
			break;
		case V_COM:
			r = qrel(v1->v_num, v2->v_com->real);
			i = qrel(&_qzero_, v2->v_com->imag);
			break;
		default:
			return;
		}
		break;
	case V_COM:
		switch(v2->v_type) {
		case V_NUM:
			r = qrel(v1->v_com->real, v2->v_num);
			i = qrel(v1->v_com->imag, &_qzero_);
			break;
		case V_COM:
			r = qrel(v1->v_com->real, v2->v_com->real);
			i = qrel(v1->v_com->imag, v2->v_com->imag);
			break;
		case V_OCTET:
			q = itoq((long) *v2->v_octet);
			r = qrel(v1->v_com->real, q);
			qfree(q);
			i = qrel(v1->v_com->imag, &_qzero_);
			break;
		default:
			return;
		}
		break;
	case V_STR:
		switch(v2->v_type) {
		case V_STR:
			r = stringrel(v1->v_str, v2->v_str);
			break;
		case V_OCTET:
			r = (unsigned char) *v1->v_str->s_str
				- *v2->v_octet;
			if (r == 0) {
				if (v1->v_str->s_len == 0)
					r = -1;
				else
					r = (v1->v_str->s_len > 1);
			}
			break;
		default:
			return;
		}
		break;
	case V_OCTET:
		switch(v2->v_type) {
		case V_NUM:
			q = itoq((long) *v1->v_octet);
			r = qrel(q, v2->v_num);
			qfree(q);
			break;
		case V_COM:
			q = itoq((long) *v1->v_octet);
			r = qrel(q, v2->v_com->real);
			qfree(q);
			i = qrel(&_qzero_, v2->v_com->imag);
			break;
		case V_OCTET:
			r = *v1->v_octet - *v2->v_octet;
			break;
		case V_STR:
			r = *v1->v_octet -
				(unsigned char) *v2->v_str->s_str;
			if (r == 0) {
				if (v2->v_str->s_len == 0)
					r = 1;
				else
					r = -(v2->v_str->s_len > 1);
			}
			break;
		default:
			return;
		}
		break;
	case V_VPTR:
		if (v2->v_type != V_VPTR)
			return;
		r = (v1->v_addr - v2->v_addr);
		break;
	case V_OPTR:
		if (v2->v_type != V_OPTR)
			return;
		r = (v1->v_octet - v2->v_octet);
		break;
	default:
		return;
	}
	vres->v_type = V_NUM;
	*vres = signval(r);
	if (i == 0)
		return;
	c = comalloc();
	qfree(c->real);
	c->real = vres->v_num;
	*vres = signval(i);
	qfree(c->imag);
	c->imag = vres->v_num;
	vres->v_type = V_COM;
	vres->v_com = c;
	return;
}


/*
 * Find a value representing sign or signs in a value
 * Result is placed in the indicated location.
 */
void
sgnvalue(VALUE *vp, VALUE *vres)
{
	COMPLEX *c;

	vres->v_type = vp->v_type;
	switch (vp->v_type) {
	case V_NUM:
		vres->v_num = qsign(vp->v_num);
		vres->v_subtype = vp->v_subtype;
		return;
	case V_COM:
		c = comalloc();
		qfree(c->real);
		qfree(c->imag);
		c->real = qsign(vp->v_com->real);
		c->imag = qsign(vp->v_com->imag);
		vres->v_com = c;
		vres->v_type = V_COM;
		vres->v_subtype = V_NOSUBTYPE;
		return;
	case V_OCTET:
		vres->v_type = V_NUM;
		vres->v_subtype = V_NOSUBTYPE;
		vres->v_num = itoq((long) (*vp->v_octet != 0));
		return;
	case V_OBJ:
		*vres = objcall(OBJ_SGN, vp, NULL_VALUE, NULL_VALUE);
		return;
	default:
		if (vp->v_type > 0)
			*vres = error_value(E_SGN);
		return;
	}
}


int
userfunc(char *fname, VALUE *vp)
{
	FUNC *fp;

	fp = findfunc(adduserfunc(fname));
	if (fp == NULL)
		return 0;
	++stack;
	stack->v_addr = vp;
	stack->v_type = V_ADDR;
	stack->v_subtype = V_NOSUBTYPE;
	calculate(fp, 1);
	freevalue(stack--);
	return 1;
}


/*
 * 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(VALUE *vp, int flags)
{
	NUMBER *qtemp;
	int type;

	type = vp->v_type;
	if (type < 0) {
		if (userfunc("error_print", vp))
			return;
		if (-type >= E__BASE)
			math_fmt("Error %d", -type);
		else
			math_fmt("System error %d", -type);
		return;
	}
	switch (type) {
	case V_NUM:
		qprintnum(vp->v_num, MODE_DEFAULT);
		if (conf->traceflags & TRACE_LINKS)
			math_fmt("#%ld", vp->v_num->links);
		break;
	case V_COM:
		comprint(vp->v_com);
		if (conf->traceflags & TRACE_LINKS)
			math_fmt("##%ld", vp->v_com->links);
		break;
	case V_STR:
		if (flags & PRINT_UNAMBIG)
			math_chr('\"');
		math_str(vp->v_str->s_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:
		if (!userfunc("list_print", vp))
			listprint(vp->v_list,
			((flags & PRINT_SHORT) ? 0L : conf->maxprint));
		break;
	case V_ASSOC:
		assocprint(vp->v_assoc,
			((flags & PRINT_SHORT) ? 0L : conf->maxprint));
		break;
	case V_MAT:
		if (!userfunc("mat_print", vp))
			matprint(vp->v_mat,
			((flags & PRINT_SHORT) ? 0L : conf->maxprint));
		break;
	case V_FILE:
		if (!userfunc("file_print", vp))
			printid(vp->v_file, flags);
		break;
	case V_RAND:
		randprint(vp->v_rand, flags);
		break;
	case V_RANDOM:
		randomprint(vp->v_random, flags);
		break;
	case V_CONFIG:
		config_print(vp->v_config);
		break;
	case V_HASH:
		hash_print(vp->v_hash);
		break;
	case V_BLOCK:
		if (!userfunc("blk_print", vp))
			blk_print(vp->v_block);
		break;
	case V_OCTET:
		if (userfunc("octet_print", vp))
			break;
		qtemp = itoq((long) *vp->v_octet);
		qprintnum(qtemp, MODE_DEFAULT);
		qfree(qtemp);
		break;
	case V_OPTR:
		math_fmt("o-ptr: %p", vp->v_octet);
		break;
	case V_VPTR:
		math_fmt("v-ptr: %p", vp->v_addr);
		break;
	case V_SPTR:
		math_fmt("s_ptr: %p", vp->v_str);
		break;
	case V_NPTR:
		math_fmt("n_ptr: %p", vp->v_num);
		break;
	case V_NBLOCK:
		if (!userfunc("nblk_print", vp))
			nblock_print(vp->v_nblock);
		break;
	default:
		math_error("Printing unrecognized type of value");
		/*NOTREACHED*/
	}
}

/*
 * Print an exact text representation of a value
 */
void
printestr(VALUE *vp)
{
	LISTELEM *ep;
	MATRIX *mp;
	OBJECT *op;
	BLOCK *bp;
	int mode;
	long i, min, max;
	USB8 *cp;

	if (vp->v_type < 0) {
		math_fmt("error(%d)", -vp->v_type);
		return;
	}
	switch(vp->v_type) {
		case V_NULL:
			math_str("\"\"");
			return;
		case V_STR:
			math_chr('"');
			strprint(vp->v_str);
			math_chr('"');
			return;
		case V_NUM:
			qprintnum(vp->v_num, MODE_FRAC);
			return;
		case V_COM:
			mode = math_setmode(MODE_FRAC);
			comprint(vp->v_com);
			math_setmode(mode);
			return;
		case V_LIST:
			math_str("list(");
			ep = vp->v_list->l_first;
			if (ep) {
				printestr(&ep->e_value);
				while ((ep = ep->e_next)) {
					math_chr(',');
					printestr(&ep->e_value);
				}
			}
			math_chr(')');
			return;
		case V_MAT:
			mp = vp->v_mat;
			if (mp->m_dim == 0)
				math_str("(mat[])");
			else {
				math_str("mat[");
				for (i = 0; i < mp->m_dim; i++) {
					min = mp->m_min[i];
					max = mp->m_max[i];
					if (i > 0)
						math_chr(',');
					if (min)
						math_fmt("%ld:%ld", min, max);
					else
						math_fmt("%ld", max + 1);
				}
				math_chr(']');
			}
			i = mp->m_size;
			vp = mp->m_table;
			break;
		case V_OBJ:
			op = vp->v_obj;
			math_fmt("obj %s",objtypename(op->o_actions->oa_index));
			i = op->o_actions->oa_count;
			vp = op->o_table;
			break;
		case V_BLOCK:
		case V_NBLOCK:
			math_str("blk(");
			if (vp->v_type == V_BLOCK)
				bp = vp->v_block;
			else {
				math_fmt("\"%s\",", vp->v_nblock->name);
				bp = vp->v_nblock->blk;
			}
			i = bp->datalen;
			math_fmt("%d,%d)", i, bp->blkchunk);
			cp = bp->data;
			if (i > 0) {
				math_str("={");
				math_fmt("%d", *cp);
				while (--i > 0) {
					math_chr(',');
					math_fmt("%d", *++cp);
				}
				math_chr('}');
			}
			return;

		default:
			math_str("\"???\"");
			return;
	}
	if (i > 0) {
		math_str("={");
		printestr(vp);
		while (--i > 0) {
			math_chr(',');
			printestr(++vp);
		}
		math_chr('}');
	}
}


/*
 * config_print - print a configuration value
 *
 * given:
 *	cfg		what to print
 */
void
config_print(CONFIG *cfg)
{
	NAMETYPE *cp;
	VALUE tmp;
	int tab_over;		/* TRUE => ok move over one tab stop */
	size_t len;

	/*
	 * firewall
	 */
	if (cfg == NULL || cfg->epsilon == NULL || cfg->prompt1 == NULL ||
	    cfg->prompt2 == NULL) {
		math_error("CONFIG value is invalid");
		/*NOTREACHED*/
	}

	/*
	 * print each element
	 */
	tab_over = FALSE;
	for (cp = configs; cp->name; cp++) {

		/* skip if special all or duplicate maxerr value */
		if (cp->type == CONFIG_ALL || strcmp(cp->name, "maxerr") == 0 ||
		    strcmp(cp->name, "ctrl-d") == 0)
			continue;

		/* print tab if allowed */
		if (tab_over) {
			math_str("\t");
		} else if (conf->tab_ok) {
			tab_over = TRUE;	/* tab next time */
		}

		/* print name and spaces */
		math_fmt("%s", cp->name);
		len = 16 - strlen(cp->name);
		while (len-- > 0)
			math_str(" ");

		/* print value */
		config_value(cfg, cp->type, &tmp);
		printvalue(&tmp, PRINT_SHORT | PRINT_UNAMBIG);
		freevalue(&tmp);
		if ((cp+1)->name)
			math_str("\n");
	}
}