opcodes.c

Calc Software Package for Number Calc

/*
 * opcodes - opcode execution module
 *
 * Copyright (C) 1999-2006  David I. Bell and Ernest Bowen
 *
 * Primary author:  David I. Bell
 *
 * Calc is open software; you can redistribute it and/or modify it under
 * the terms of the version 2.1 of the GNU Lesser General Public License
 * as published by the Free Software Foundation.
 *
 * Calc is distributed in the hope that it will be useful, but WITHOUT
 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
 * or FITNESS FOR A PARTICULAR PURPOSE.	 See the GNU Lesser General
 * Public License for more details.
 *
 * A copy of version 2.1 of the GNU Lesser General Public License is
 * distributed with calc under the filename COPYING-LGPL.  You should have
 * received a copy with calc; if not, write to Free Software Foundation, Inc.
 * 59 Temple Place, Suite 330, Boston, MA  02111-1307, USA.
 *
 * @(#) $Revision: 29.12 $
 * @(#) $Id: opcodes.c,v 29.12 2006/06/25 22:05:38 chongo Exp $
 * @(#) $Source: /usr/local/src/cmd/calc/RCS/opcodes.c,v $
 *
 * Under source code control:	1990/02/15 01:48:19
 * File existed as early as:	before 1990
 *
 * Share and enjoy!  :-)	http://www.isthe.com/chongo/tech/comp/calc/
 */


#include <stdio.h>
#include <sys/types.h>
#include <setjmp.h>

#include "calc.h"
#include "opcodes.h"
#include "func.h"
#include "symbol.h"
#include "hist.h"
#include "file.h"
#include "zrand.h"
#include "zrandom.h"
#include "have_fpos.h"
#include "custom.h"
#include "math_error.h"
#include "block.h"
#include "string.h"

#include "have_unused.h"

#define QUICKLOCALS	20		/* local vars to handle quickly */


static VALUE stackarray[MAXSTACK];	/* storage for stack */
static VALUE oldvalue;			/* previous calculation value */
static BOOL saveval = TRUE;		/* to enable or disable saving */
static int calc_errno;			/* most recent error-number */
static int errcount;			/* counts calls to error_value */
static BOOL go;
static long calc_depth;

/*
 * global symbols
 */
VALUE *stack;			/* current location of top of stack */
int dumpnames;			/* names if TRUE, otherwise indices */
char *funcname;			/* function being executed */
long funcline;			/* function line being executed */


/*
 * forward declarations
 */
static void showsizes(void);
static void o_paramaddr(FUNC *fp, int argcnt, VALUE *args, long index);
static void o_getvalue(void);


/*
 * Types of opcodes (depends on arguments saved after the opcode).
 */
#define OPNUL	1	/* opcode has no arguments */
#define OPONE	2	/* opcode has one integer argument */
#define OPTWO	3	/* opcode has two integer arguments */
#define OPJMP	4	/* opcode is a jump (with one pointer argument) */
#define OPRET	5	/* opcode is a return (with no argument) */
#define OPGLB	6	/* opcode has global symbol pointer argument */
#define OPPAR	7	/* opcode has parameter index argument */
#define OPLOC	8	/* opcode needs local variable pointer (with one arg) */
#define OPSTR	9	/* opcode has a string constant arg */
#define OPARG	10	/* opcode is given number of arguments */
#define OPSTI	11	/* opcode is static initialization */


/*
 * opcode - info about each opcode
 */
struct opcode {
	void (*o_func)();	/* routine to call for opcode */
	int o_type;		/* type of opcode */
	char *o_name;		/* name of opcode */
};


/*
 * external configuration functions
 */
extern void config_value(CONFIG *cfg, int type, VALUE *ret);
extern void setconfig(int type, VALUE *vp);


/*
 * Initialize the stack.
 */
void
initstack(void)
{
	unsigned int i;

	/* on first init, setup the stack array */
	if (stack == NULL) {
		for (i=0; i < sizeof(stackarray)/sizeof(stackarray[0]); ++i) {
			stackarray[i].v_type = V_NULL;
			stackarray[i].v_subtype = V_NOSUBTYPE;
		}
		stack = stackarray;

	/* on subsequent inits, free the old stack */
	} else {
		while (stack > stackarray) {
			freevalue(stack--);
		}
	}
	/* initialize calc_depth */

	calc_depth = 0;
}


/*
 * The various opcodes
 */
static void
o_nop(void)
{
}


static void
o_localaddr(FUNC *fp, VALUE *locals, long index)
{
	if ((unsigned long)index >= fp->f_localcount) {
		math_error("Bad local variable index");
		/*NOTREACHED*/
	}
	locals += index;
	stack++;
	stack->v_addr = locals;
	stack->v_type = V_ADDR;
	stack->v_subtype = V_NOSUBTYPE;
}


/*ARGSUSED*/
static void
o_globaladdr(FUNC UNUSED *fp, GLOBAL *sp)
{
	if (sp == NULL) {
		math_error("Global variable \"%s\" not initialized", sp->g_name);
		/*NOTREACHED*/
	}
	stack++;
	stack->v_addr = &sp->g_value;
	stack->v_type = V_ADDR;
	stack->v_subtype = V_NOSUBTYPE;
}


/*ARGSUSED*/
static void
o_paramaddr(FUNC UNUSED *fp, int argcount, VALUE *args, long index)
{
	if ((long)index >= argcount) {
		math_error("Bad parameter index");
		/*NOTREACHED*/
	}
	args += index;
	stack++;
	if (args->v_type == V_OCTET || args->v_type == V_ADDR) {
		*stack = *args;
		return;
	}
	stack->v_addr = args;
	stack->v_type = V_ADDR;
/*	stack->v_subtype = V_NOSUBTYPE; */ /* XXX ??? */
}


static void
o_localvalue(FUNC *fp, VALUE *locals, long index)
{
	if ((unsigned long)index >= fp->f_localcount) {
		math_error("Bad local variable index");
		/*NOTREACHED*/
	}
	locals += index;
	copyvalue(locals, ++stack);
}


/*ARGSUSED*/
static void
o_globalvalue(FUNC UNUSED *fp, GLOBAL *sp)
{
	if (sp == NULL) {
		math_error("Global variable not defined");
		/*NOTREACHED*/
	}
	copyvalue(&sp->g_value, ++stack);
}


/*ARGSUSED*/
static void
o_paramvalue(FUNC UNUSED *fp, int argcount, VALUE *args, long index)
{
	if ((long)index >= argcount) {
		math_error("Bad parameter index");
		/*NOTREACHED*/
	}
	args += index;
	if (args->v_type == V_ADDR)
		args = args->v_addr;
	copyvalue(args, ++stack);
}


static void
o_argvalue(FUNC *fp, int argcount, VALUE *args)
{
	VALUE *vp;
	long index;

	vp = stack;
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	if ((vp->v_type != V_NUM) || qisneg(vp->v_num) ||
		qisfrac(vp->v_num)) {
			math_error("Illegal argument for arg function");
			/*NOTREACHED*/
	}
	if (qiszero(vp->v_num)) {
		if (stack->v_type == V_NUM)
			qfree(stack->v_num);
		stack->v_num = itoq((long) argcount);
		stack->v_type = V_NUM;
		stack->v_subtype = V_NOSUBTYPE;
		return;
	}
	index = qtoi(vp->v_num) - 1;
	if (stack->v_type == V_NUM)
		qfree(stack->v_num);
	stack--;
	(void) o_paramaddr(fp, argcount, args, index);
}


/*ARGSUSED*/
static void
o_number(FUNC UNUSED *fp, long arg)
{
	NUMBER *q;

	q = constvalue(arg);
	if (q == NULL) {
		math_error("Numeric constant value not found");
		/*NOTREACHED*/
	}
	stack++;
	stack->v_num = qlink(q);
	stack->v_type = V_NUM;
	stack->v_subtype = V_NOSUBTYPE;
}


/*ARGSUSED*/
static void
o_imaginary(FUNC UNUSED *fp, long arg)
{
	NUMBER *q;
	COMPLEX *c;

	q = constvalue(arg);
	if (q == NULL) {
		math_error("Numeric constant value not found");
		/*NOTREACHED*/
	}
	stack++;
	stack->v_subtype = V_NOSUBTYPE;
	if (qiszero(q)) {
		stack->v_num = qlink(q);
		stack->v_type = V_NUM;
		return;
	}
	c = comalloc();
	qfree(c->imag);
	c->imag = qlink(q);
	stack->v_com = c;
	stack->v_type = V_COM;
}


/*ARGSUSED*/
static void
o_string(FUNC UNUSED *fp, long arg)
{
	stack++;
	stack->v_str = slink(findstring(arg));
	stack->v_type = V_STR;
	stack->v_subtype = V_NOSUBTYPE;
}


static void
o_undef(void)
{
	stack++;
	stack->v_type = V_NULL;
	stack->v_subtype = V_NOSUBTYPE;
}


/*ARGSUSED*/
static void
o_matcreate(FUNC UNUSED *fp, long dim)
{
	register MATRIX *mp;	/* matrix being defined */
	NUMBER *num1;		/* first number from stack */
	NUMBER *num2;		/* second number from stack */
	VALUE *v1, *v2;
	long min[MAXDIM];	/* minimum range */
	long max[MAXDIM];	/* maximum range */
	long i;			/* index */
	long tmp;		/* temporary */
	long size;		/* size of matrix */

	if ((dim < 0) || (dim > MAXDIM)) {
		math_error("Bad dimension %ld for matrix", dim);
		/*NOTREACHED*/
	}
	size = 1;
	for (i = dim - 1; i >= 0; i--) {
		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;
		if ((v1->v_type != V_NUM) || (v2->v_type != V_NUM)) {
			math_error("Non-numeric bounds for matrix");
			/*NOTREACHED*/
		}
		num1 = v1->v_num;
		num2 = v2->v_num;
		if (qisfrac(num1) || qisfrac(num2)) {
			math_error("Non-integral bounds for matrix");
			/*NOTREACHED*/
		}
		if (zge31b(num1->num) || zge31b(num2->num)) {
			math_error("Very large bounds for matrix");
			/*NOTREACHED*/
		}
		min[i] = qtoi(num1);
		max[i] = qtoi(num2);
		if (min[i] > max[i]) {
			tmp = min[i];
			min[i] = max[i];
			max[i] = tmp;
		}
		size *= (max[i] - min[i] + 1);
		if (size > 10000000) {
			math_error("Very large size for matrix");
			/*NOTREACHED*/
		}
		freevalue(stack--);
		freevalue(stack--);
	}
	mp = matalloc(size);
	mp->m_dim = dim;
	for (i = 0; i < dim; i++) {
		mp->m_min[i] = min[i];
		mp->m_max[i] = max[i];
	}
	stack++;
	stack->v_type = V_MAT;
	stack->v_subtype = V_NOSUBTYPE;
	stack->v_mat = mp;
}


/*ARGSUSED*/
static void
o_eleminit(FUNC UNUSED *fp, long index)
{
	VALUE *vp;
	static VALUE *oldvp;
	VALUE tmp;
	OCTET *ptr;
	BLOCK *blk;
	unsigned short subtype;

	vp = &stack[-1];
	if (vp->v_type == V_ADDR)
		vp = vp->v_addr;
	if (vp->v_type < 0) {
		freevalue(stack--);
		error_value(E_INIT1);
		return;
	}
	if (vp->v_subtype & V_NOCOPYTO) {
		freevalue(stack--);
		error_value(E_INIT2);
		return;
	}
	switch (vp->v_type) {
	case V_MAT:
		if ((index < 0) || (index >= vp->v_mat->m_size)) {
			freevalue(stack--);
			error_value(E_INIT3);
			return;
		}
		oldvp = &vp->v_mat->m_table[index];
		break;
	case V_OBJ:
		if (index < 0 || index >= vp->v_obj->o_actions->oa_count) {
			freevalue(stack--);
			error_value(E_INIT3);
			return;
		}
		oldvp = &vp->v_obj->o_table[index];
		break;
	case V_LIST:
		oldvp = listfindex(vp->v_list, index);
		if (oldvp == NULL) {
			freevalue(stack--);
			error_value(E_INIT3);
			return;
		}
		break;
	case V_STR:
		if (index < 0 || (size_t)index >= vp->v_str->s_len) {
			freevalue(stack--);
			error_value(E_INIT3);
			return;
		}
		ptr = (OCTET *)(&vp->v_str->s_str[index]);
		vp = stack;
		if (vp->v_type == V_ADDR)
			vp = vp->v_addr;
		copy2octet(vp, ptr);
		freevalue(stack--);
		return;
	case V_NBLOCK:
	case V_BLOCK:
		if (vp->v_type == V_NBLOCK) {
			blk = vp->v_nblock->blk;
			if (blk->data == NULL) {
				freevalue(stack--);
				error_value(E_INIT4);
				return;
			}
		}
		else
			blk = vp->v_block;
		if (index >= blk->maxsize) {
			freevalue(stack--);
			error_value(E_INIT3);
			return;
		}
		ptr = blk->data + index;
		vp = stack;
		if (vp->v_type == V_ADDR)
			vp = vp->v_addr;
		copy2octet(vp, ptr);
		if (index >= blk->datalen)
			blk->datalen = index + 1;
		freevalue(stack--);
		return;
	default:
		freevalue(stack--);
		error_value(E_INIT5);
		return;
	}
	vp = stack--;
	subtype = oldvp->v_subtype;
	if (subtype & V_NOASSIGNTO) {
		freevalue(vp);
		error_value(E_INIT6);
		return;
	}
	if (vp->v_type == V_ADDR) {
		vp = vp->v_addr;
		if (vp == oldvp)
			return;
		copyvalue(vp, &tmp);
	}
	else
		tmp = *vp;
	if ((subtype & V_NONEWVALUE) && comparevalue(oldvp, &tmp)) {
		freevalue(&tmp);
		error_value(E_INIT7);
		return;
	}
	if ((subtype & V_NONEWTYPE) && oldvp->v_type != tmp.v_type) {
		freevalue(&tmp);
		error_value(E_INIT8);
		return;
	}
	if ((subtype & V_NOERROR) && tmp.v_type < 0) {
		error_value(E_INIT9);
		return;
	}
	if (tmp.v_subtype & (V_NOASSIGNFROM | V_NOCOPYFROM)) {
		freevalue(&tmp);
		error_value(E_INIT10);
		return;
	}
	tmp.v_subtype |= oldvp->v_subtype;
	freevalue(oldvp);
	*oldvp = tmp;
}


/*
 * o_indexaddr
 *
 * given:
 *	fp		function to calculate
 *	dim		dimension of matrix
 *	writeflag	nonzero if element will be written
 */
/*ARGSUSED*/
static void
o_indexaddr(FUNC UNUSED *fp, long dim, long writeflag)
{
	int i;
	BOOL flag;
	VALUE *val;
	VALUE *vp;
	VALUE indices[MAXDIM];	/* index values */
	long index;		/* single dimension index for blocks */
	VALUE ret;		/* OCTET from as indexed from a block */
	BLOCK *blk;

	flag = (writeflag != 0);
	if (dim < 0)  {
		math_error("Negative dimension for indexing");
		/*NOTREACHED*/
	}
	val = &stack[-dim];
	if (val->v_type != V_NBLOCK && val->v_type != V_FILE) {
		if (val->v_type != V_ADDR) {
			math_error("Non-pointer for indexaddr");
			/*NOTREACHED*/
		}
		val = val->v_addr;
	}
	blk = NULL;
	vp = &stack[-dim + 1];
	for (i = 0; i < dim; i++) {
		if (vp->v_type == V_ADDR)
			indices[i] = vp->v_addr[0];
		else
			indices[i] = vp[0];
		vp++;
	}

	switch (val->v_type) {
	case V_MAT:
		vp = matindex(val->v_mat, flag, dim, indices);
		break;
	case V_ASSOC:
		vp = associndex(val->v_assoc, flag, dim, indices);
		break;
	case V_NBLOCK:
	case V_BLOCK:
		if (val->v_type == V_BLOCK)
			blk = val->v_block;
		else
			blk = val->v_nblock->blk;
		if (blk->data == NULL) {
			math_error("Freed block");
			/*NOTREACHED*/
		}

		/*
		 * obtain single dimensional block index
		 */
		if (dim != 1) {
			math_error("block has only one dimension");
			/*NOTREACHED*/
		}
		if (indices[0].v_type != V_NUM) {
			math_error("Non-numeric index for block");
			/*NOTREACHED*/
		}
		if (qisfrac(indices[0].v_num)) {
			math_error("Non-integral index for block");
			/*NOTREACHED*/
		}
		if (zge31b(indices[0].v_num->num) ||
		    zisneg(indices[0].v_num->num)) {
			math_error("Index out of bounds for block");
			/*NOTREACHED*/
		}
		index = ztoi(indices[0].v_num->num);

		if (index >= blk->maxsize) {
			math_error("Index out of bounds for block");
			/*NOTREACHED*/
		}
		if (index >= blk->datalen)
			blk->datalen = index + 1;
		ret.v_type = V_OCTET;
		ret.v_subtype = val->v_subtype;
		ret.v_octet = &blk->data[index];
		freevalue(stack--);
		*stack = ret;
		return;
	case V_STR:
		if (dim != 1) {
			math_error("string has only one dimension");
			/*NOTREACHED*/
		}
		if (indices[0].v_type != V_NUM) {
			math_error("Non-numeric index for string");
			/*NOTREACHED*/
		}
		if (qisfrac(indices[0].v_num)) {
			math_error("Non-integral index for string");
			/*NOTREACHED*/
		}
		if (zge31b(indices[0].v_num->num) ||
		    zisneg(indices[0].v_num->num)) {
			math_error("Index out of bounds for string");
			/*NOTREACHED*/
		}
		index = ztoi(indices[0].v_num->num);
		if (index < 0 || (size_t)index >= val->v_str->s_len) {
			math_error("Index out of bounds for string");
			/*NOTREACHED*/
		}
		ret.v_type = V_OCTET;
		ret.v_subtype = val->v_subtype;
		ret.v_octet = (OCTET *)(val->v_str->s_str + index);
		freevalue(stack--);
		*stack = ret;
		return;
	case V_LIST:
		if (dim != 1) {
			math_error("list has only one dimension");
			/*NOTREACHED*/
		}
		if (indices[0].v_type != V_NUM) {
			math_error("Non-numeric index for list");
			/*NOTREACHED*/
		}
		if (qisfrac(indices[0].v_num)) {
			math_error("Non-integral index for list");
			/*NOTREACHED*/
		}
		if (zge31b(indices[0].v_num->num) ||
		    zisneg(indices[0].v_num->num)) {
			math_error("Index out of bounds for list");
			/*NOTREACHED*/
		}
		index = ztoi(indices[0].v_num->num);
		vp = listfindex(val->v_list, index);
		if (vp == NULL) {
			math_error("Index out of bounds for list");
			/*NOTREACHED*/
		}
		break;
	default:
		math_error("Illegal value for indexing");
		/*NOTREACHED*/
	}
	while (dim-- > 0)
		freevalue(stack--);
	stack->v_type = V_ADDR;
	stack->v_addr = vp;
}


/*ARGSUSED*/
static void
o_elemaddr(FUNC UNUSED *fp, long index)
{
	VALUE *vp;
	MATRIX *mp;
	OBJECT *op;
	int offset;

	vp = stack;
	if (vp->v_type == V_ADDR)
		vp = stack->v_addr;
	switch (vp->v_type) {
	case V_MAT:
		mp = vp->v_mat;
		if ((index < 0) || (index >= mp->m_size)) {
			math_error("Non-existent element for matrix");
			/*NOTREACHED*/
		}
		vp = &mp->m_table[index];
		break;
	case V_OBJ:
		op = vp->v_obj;