opcodes.c

Calc Software Package for Number Calc

static void
o_isobjtype(void)
{
	VALUE *vp;
	long index;

	vp = stack;
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	if (vp->v_type != V_STR) {
		math_error("Non-string argument for isobjtype");
		/*NOTREACHED*/
	}
	index = checkobject(vp->v_str->s_str);
	freevalue(stack);
	stack->v_num = itoq(index >= 0);
	stack->v_type = V_NUM;
	stack->v_subtype = V_NOSUBTYPE;
}


static void
o_issimple(void)
{
	VALUE *vp;
	int r;

	vp = stack;
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	r = 0;
	switch (vp->v_type) {
	case V_NULL:
	case V_NUM:
	case V_COM:
	case V_STR:
		r = 1;
	}
	freevalue(stack);
	stack->v_num = (r ? qlink(&_qone_) : qlink(&_qzero_));
	stack->v_type = V_NUM;
	stack->v_subtype = V_NOSUBTYPE;
}


static void
o_isodd(void)
{
	VALUE *vp;

	vp = stack;
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	if ((vp->v_type == V_NUM) && qisodd(vp->v_num)) {
		if (stack->v_type == V_NUM)
			qfree(stack->v_num);
		stack->v_num = qlink(&_qone_);
		stack->v_type = V_NUM;
		stack->v_subtype = V_NOSUBTYPE;
		return;
	}
	freevalue(stack);
	stack->v_num = qlink(&_qzero_);
	stack->v_type = V_NUM;
	stack->v_subtype = V_NOSUBTYPE;
}


static void
o_iseven(void)
{
	VALUE *vp;

	vp = stack;
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	if ((vp->v_type == V_NUM) && qiseven(vp->v_num)) {
		if (stack->v_type == V_NUM)
			qfree(stack->v_num);
		stack->v_num = qlink(&_qone_);
		stack->v_type = V_NUM;
		stack->v_subtype = V_NOSUBTYPE;
		return;
	}
	freevalue(stack);
	stack->v_num = qlink(&_qzero_);
	stack->v_type = V_NUM;
	stack->v_subtype = V_NOSUBTYPE;
}


static void
o_isreal(void)
{
	VALUE *vp;

	vp = stack;
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	if (vp->v_type == V_NUM) {
		if (stack->v_type == V_NUM)
			qfree(stack->v_num);
		stack->v_num = qlink(&_qone_);
		stack->v_type = V_NUM;
		stack->v_subtype = V_NOSUBTYPE;
		return;
	}
	freevalue(stack);
	stack->v_num = qlink(&_qzero_);
	stack->v_type = V_NUM;
	stack->v_subtype = V_NOSUBTYPE;
}


static void
o_isnull(void)
{
	VALUE *vp;

	vp = stack;
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	if (vp->v_type != V_NULL) {
		freevalue(stack);
		stack->v_num = qlink(&_qzero_);
		stack->v_type = V_NUM;
		stack->v_subtype = V_NOSUBTYPE;
		return;
	}
	freevalue(stack);
	stack->v_num = qlink(&_qone_);
	stack->v_type = V_NUM;
	stack->v_subtype = V_NOSUBTYPE;
}


static void
o_re(void)
{
	VALUE *vp;
	NUMBER *q;

	vp = stack;
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	if (vp->v_type == V_NUM) {
		if (stack->v_type == V_ADDR) {
			stack->v_num = qlink(vp->v_num);
			stack->v_type = V_NUM;
			stack->v_subtype = V_NOSUBTYPE;
		}
		return;
	}
	if (vp->v_type != V_COM) {
		math_error("Taking real part of non-number");
		/*NOTREACHED*/
	}
	q = qlink(vp->v_com->real);
	if (stack->v_type == V_COM)
		comfree(stack->v_com);
	stack->v_num = q;
	stack->v_type = V_NUM;
	stack->v_subtype = V_NOSUBTYPE;
}


static void
o_im(void)
{
	VALUE *vp;
	NUMBER *q;

	vp = stack;
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	if (vp->v_type == V_NUM) {
		if (stack->v_type == V_NUM)
			qfree(stack->v_num);
		stack->v_num = qlink(&_qzero_);
		stack->v_type = V_NUM;
		stack->v_subtype = V_NOSUBTYPE;
		return;
	}
	if (vp->v_type != V_COM) {
		math_error("Taking imaginary part of non-number");
		/*NOTREACHED*/
	}
	q = qlink(vp->v_com->imag);
	if (stack->v_type == V_COM)
		comfree(stack->v_com);
	stack->v_num = q;
	stack->v_type = V_NUM;
	stack->v_subtype = V_NOSUBTYPE;
}


static void
o_conjugate(void)
{
	VALUE *vp;
	VALUE tmp;

	vp = stack;
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	if (vp->v_type == V_NUM) {
		if (stack->v_type == V_ADDR) {
			stack->v_num = qlink(vp->v_num);
			stack->v_type = V_NUM;
			stack->v_subtype = V_NOSUBTYPE;
		}
		return;
	}
	conjvalue(vp, &tmp);
	freevalue(stack);
	*stack = tmp;
}


static void
o_fiaddr(void)
{
	register MATRIX *m;	/* current matrix element */
	LIST *lp;		/* list header */
	ASSOC *ap;		/* association header */
	VALUE *vp;		/* stack value */
	long index;		/* index value as an integer */
	VALUE *res;

	vp = stack;
	res = NULL;
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	if (vp->v_type != V_NUM || qisfrac(vp->v_num)) {
		math_error("Fast indexing by non-integer");
		/*NOTREACHED*/
	}
	index = qtoi(vp->v_num);
	if (zge31b(vp->v_num->num) || (index < 0)) {
		math_error("Index out of range for fast indexing");
		/*NOTREACHED*/
	}
	if (stack->v_type == V_NUM)
		qfree(stack->v_num);
	stack--;
	vp = stack;
	if (vp->v_type != V_ADDR) {
		math_error("Non-pointer for fast indexing");
		/*NOTREACHED*/
	}
	vp = vp->v_addr;
	switch (vp->v_type) {
	case V_OBJ:
		if (index >= vp->v_obj->o_actions->oa_count) {
			math_error("Index out of bounds for object");
			/*NOTREACHED*/
		}
		res = vp->v_obj->o_table + index;
		break;
	case V_MAT:
		m = vp->v_mat;
		if (index >= m->m_size) {
			math_error("Index out of bounds for matrix");
			/*NOTREACHED*/
		}
		res = m->m_table + index;
		break;
	case V_LIST:
		lp = vp->v_list;
		res = listfindex(lp, index);
		if (res == NULL) {
			math_error("Index out of bounds for list");
			/*NOTREACHED*/
		}
		break;
	case V_ASSOC:
		ap = vp->v_assoc;
		res = assocfindex(ap, index);
		if (res == NULL) {
			math_error("Index out of bounds for association");
			/*NOTREACHED*/
		}
		break;
	default:
		math_error("Bad variable type for fast indexing");
		/*NOTREACHED*/
	}
	stack->v_addr = res;
}


static void
o_fivalue(void)
{
	(void) o_fiaddr();
	(void) o_getvalue();
}


static void
o_sgn(void)
{
	VALUE *vp;
	NUMBER *q;
	VALUE tmp;

	vp = stack;
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	if (vp->v_type == V_NUM) {
		q = qsign(vp->v_num);
		if (stack->v_type == V_NUM)
			qfree(vp->v_num);
		stack->v_num = q;
		stack->v_type = V_NUM;
		stack->v_subtype = V_NOSUBTYPE;
		return;
	}
	sgnvalue(vp, &tmp);
	freevalue(stack);
	*stack = tmp;
}


static void
o_numerator(void)
{
	VALUE *vp;
	NUMBER *q;

	vp = stack;
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	if (vp->v_type != V_NUM) {
		math_error("Numerator of non-number");
		/*NOTREACHED*/
	}
	if ((stack->v_type == V_NUM) && qisint(vp->v_num))
		return;
	q = qnum(vp->v_num);
	if (stack->v_type == V_NUM)
		qfree(stack->v_num);
	stack->v_num = q;
	stack->v_type = V_NUM;
	stack->v_subtype = V_NOSUBTYPE;
}


static void
o_denominator(void)
{
	VALUE *vp;
	NUMBER *q;

	vp = stack;
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	if (vp->v_type != V_NUM) {
		math_error("Denominator of non-number");
		/*NOTREACHED*/
	}
	q = qden(vp->v_num);
	if (stack->v_type == V_NUM)
		qfree(stack->v_num);
	stack->v_num = q;
	stack->v_type = V_NUM;
	stack->v_subtype = V_NOSUBTYPE;
}


static void
o_duplicate(void)
{
	VALUE *vp;

	vp = stack++;
	*stack = *vp;
}


static void
o_dupvalue(void)
{
	if (stack->v_type == V_ADDR)
		copyvalue(stack->v_addr, stack + 1);
	else
		copyvalue(stack, stack + 1);
	stack++;
}


static void
o_pop(void)
{
	freevalue(stack--);
}


static void
o_return(void)
{
}


/*ARGSUSED*/
static void
o_jumpz(FUNC UNUSED *fp, BOOL *dojump)
{
	VALUE *vp;
	int i;			/* result of comparison */

	vp = stack;
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	if (vp->v_type == V_NUM) {
		i = !qiszero(vp->v_num);
		if (stack->v_type == V_NUM)
			qfree(stack->v_num);
	} else {
		i = testvalue(vp);
		freevalue(stack);
	}
	stack--;
	if (!i)
		*dojump = TRUE;
}


/*ARGSUSED*/
static void
o_jumpnz(FUNC UNUSED *fp, BOOL *dojump)
{
	VALUE *vp;
	int i;			/* result of comparison */

	vp = stack;
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	if (vp->v_type == V_NUM) {
		i = !qiszero(vp->v_num);
		if (stack->v_type == V_NUM)
			qfree(stack->v_num);
	} else {
		i = testvalue(vp);
		freevalue(stack);
	}
	stack--;
	if (i)
		*dojump = TRUE;
}


/*
 * jumpnn invokes a jump if top value points to a null value
 */
/*ARGSUSED*/
static void
o_jumpnn(FUNC UNUSED *fp, BOOL *dojump)
{
	if (stack->v_addr->v_type) {
		*dojump = TRUE;
		stack--;
	}
}


/*ARGSUSED*/
static void
o_condorjump(FUNC UNUSED *fp, BOOL *dojump)
{
	VALUE *vp;

	vp = stack;
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	if (vp->v_type == V_NUM) {
		if (!qiszero(vp->v_num)) {
			*dojump = TRUE;
			return;
		}
		if (stack->v_type == V_NUM)
			qfree(stack->v_num);
		stack--;
		return;
	}
	if (testvalue(vp))
		*dojump = TRUE;
	else
		freevalue(stack--);
}


/*ARGSUSED*/
static void
o_condandjump(FUNC UNUSED *fp, BOOL *dojump)
{
	VALUE *vp;

	vp = stack;
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	if (vp->v_type == V_NUM) {
		if (qiszero(vp->v_num)) {
			*dojump = TRUE;
			return;
		}
		if (stack->v_type == V_NUM)
			qfree(stack->v_num);
		stack--;
		return;
	}
	if (!testvalue(vp))
		*dojump = TRUE;
	else
		freevalue(stack--);
}


/*
 * Compare the top two values on the stack for equality and jump if they are
 * different, popping off the top element, leaving the first one on the stack.
 * If they are equal, pop both values and do not jump.
 */
/*ARGSUSED*/
static void
o_casejump(FUNC UNUSED *fp, BOOL *dojump)
{
	VALUE *v1, *v2;
	int r;

	v1 = &stack[-1];
	v2 = &stack[0];
	if (v1->v_type == V_ADDR)
		v1 = v1->v_addr;
	if (v2->v_type == V_ADDR)
		v2 = v2->v_addr;
	r = comparevalue(v1, v2);
	freevalue(stack--);
	if (r)
		*dojump = TRUE;
	else
		freevalue(stack--);
}


/*ARGSUSED*/
static void
o_jump(FUNC UNUSED *fp, BOOL *dojump)
{
	*dojump = TRUE;
}


static void
o_usercall(FUNC *fp, long index, long argcount)
{
	fp = findfunc(index);
	if (fp == NULL) {
		math_error("Function \"%s\" is undefined", namefunc(index));
		/*NOTREACHED*/
	}
	calculate(fp, (int) argcount);
}


/*ARGSUSED*/
static void
o_call(FUNC UNUSED *fp, long index, long argcount)
{
	VALUE result;

	result = builtinfunc(index, (int) argcount, stack);
	while (--argcount >= 0)
		freevalue(stack--);
	stack++;
	*stack = result;
}


static void
o_getvalue(void)
{
	if (stack->v_type == V_ADDR)
		copyvalue(stack->v_addr, stack);
}


static void
o_cmp(void)
{
	VALUE *v1, *v2;
	VALUE tmp;

	v1 = &stack[-1];
	v2 = &stack[0];
	if (v1->v_type == V_ADDR)
		v1 = v1->v_addr;
	if (v2->v_type == V_ADDR)
		v2 = v2->v_addr;
	relvalue(v1, v2, &tmp);
	freevalue(stack--);
	freevalue(stack);
	*stack = tmp;
}


static void
o_eq(void)
{
	VALUE *v1, *v2;
	int r;

	v1 = &stack[-1];
	v2 = &stack[0];
	if (v1->v_type == V_ADDR)
		v1 = v1->v_addr;
	if (v2->v_type == V_ADDR)
		v2 = v2->v_addr;
	r = comparevalue(v1, v2);
	freevalue(stack--);
	freevalue(stack);
	stack->v_num = itoq((long) (r == 0));
	stack->v_type = V_NUM;
	stack->v_subtype = V_NOSUBTYPE;
}


static void
o_ne(void)
{
	VALUE *v1, *v2;
	int r;

	v1 = &stack[-1];
	v2 = &stack[0];
	if (v1->v_type == V_ADDR)
		v1 = v1->v_addr;
	if (v2->v_type == V_ADDR)
		v2 = v2->v_addr;
	r = comparevalue(v1, v2);
	freevalue(stack--);
	freevalue(stack);
	stack->v_num = itoq((long) (r != 0));
	stack->v_type = V_NUM;
	stack->v_subtype = V_NOSUBTYPE;
}


static void
o_le(void)
{
	VALUE *v1, *v2;
	VALUE tmp;

	v1 = &stack[-1];
	v2 = &stack[0];
	if (v1->v_type == V_ADDR)
		v1 = v1->v_addr;
	if (v2->v_type == V_ADDR)
		v2 = v2->v_addr;
	relvalue(v1, v2, &tmp);
	freevalue(stack--);
	freevalue(stack);

	stack->v_type = V_NUM;
	stack->v_subtype = V_NOSUBTYPE;
	if (tmp.v_type == V_NUM) {
		stack->v_num =	!qispos(tmp.v_num) ? qlink(&_qone_):
				qlink(&_qzero_);
	} else if (tmp.v_type == V_COM) {
		stack->v_num = qlink(&_qzero_);
	} else {
		stack->v_type = V_NULL;
	}
	freevalue(&tmp);
}


static void
o_ge(void)
{
	VALUE *v1, *v2;
	VALUE tmp;

	v1 = &stack[-1];
	v2 = &stack[0];
	if (v1->v_type == V_ADDR)
		v1 = v1->v_addr;
	if (v2->v_type == V_ADDR)
		v2 = v2->v_addr;
	relvalue(v1, v2, &tmp);
	freevalue(stack--);
	freevalue(stack);
	stack->v_type = V_NUM;
	stack->v_subtype = V_NOSUBTYPE;
	if (tmp.v_type == V_NUM) {
		stack->v_num =	!qisneg(tmp.v_num) ? qlink(&_qone_):
				qlink(&_qzero_);
	} else if (tmp.v_type == V_COM) {
		stack->v_num = qlink(&_qzero_);
	} else {
		stack->v_type = V_NULL;
	}
	freevalue(&tmp);
}


static void
o_lt(void)
{
	VALUE *v1, *v2;
	VALUE tmp;

	v1 = &stack[-1];
	v2 = &stack[0];
	if (v1->v_type == V_ADDR)
		v1 = v1->v_addr;
	if (v2->v_type == V_ADDR)
		v2 = v2->v_addr;