/*
 * BASIC by Phil Cockcroft
 */
#include        "bas.h"

/*
 *  This file contains the routines to get a variable from its name
 *  To dimension arrays and assignment to a variable.
 *
 *      A variable name consists of a letter followed by an optional
 *    letter or digit followed by the type specifier.
 *      A type specifier is a '%' for an integer a '$' for a string
 *    or is absent if the variable is a real ( Default ).
 *      An integer variable also has the top bit of its second letter
 *    set this is used to distinguish between real and integer variables.
 *      A variable name can be optionally followed by a subscript
 *    turning the variable into a subscripted variable.
 *    A subscript is specified by a list of indexes in square brackets
 *    e.g.  [1,2,3] , a maximum of three subscripts may be used.
 *    All arrays must be specified before use.
 *
 *      The variable to be accessed has its name in the array nm[],
 *    and its type in the variable 'vartype'.
 *
 *      'vartype' is very important as it is used all over the place
 *
 *      The value in 'vartype' can have the following values:-
 *              0:      real variable (Default ).
 *              1:      integer variable.
 *              2:      string variable.
 *
 */

#define LBRACK  '('
#define RBRACK  ')'

#ifdef	__STDC__
static	MEMP	getarray(struct entry *);
static	void	dim_one(void);
static	void	bdeftype(int);
static	int	nam_read(CHAR *, int *);
static	struct	entry	*new_entry(CHAR *, int, int, struct entry *, int);
#else
static	MEMP	getarray();
static	void	dim_one();
static	void	bdeftype();
static	int	nam_read();
static	struct	entry	*new_entry();
#endif

#ifdef	__STDC__
#if	defined(mips) && !defined(lint) && !defined(CDS_COMPILER)
static const union entry_vals entry_zero;	/* should be zero */
#else
static const union entry_vals entry_zero = { 0 };
#endif
#else
static union entry_vals entry_zero;		/* should be zero */
#endif

static	int
nam_read(nam, lp)
CHAR	*nam;
int	*lp;
{
	register int	c;
	register CHAR	*p = nam;
	register int	l;

	c = getch();
	if(!isletter(c))
		error(VARREQD);
	vartype = (char)tcharmap[c - 'A'];
	for(*p++ = (CHAR)(l = c), c = UC(*point); isnchar(c); c = UC(*++point)){
		l += c;
		*p++ = (CHAR)c;
	}
	*p = 0;
	if(c==D_STR){
		point++;
		vartype = SVAL;
	}
	else if(c==D_INT){
		point++;
		vartype = IVAL;
	}
	else if(c==D_FLT){
		point++;
		vartype = RVAL;
	}
	*lp = l;
	return(p - nam);
}

static	struct	entry	*
new_entry(nam, namlen, l, np, vtype)
CHAR	*nam;
int	namlen, l;
struct	entry	*np;
int	vtype;
{
	register struct	entry	*ep;

	ep = (struct entry *)mmalloc((ival)(sizeof(struct entry)+namlen));
	ep->link = 0;
	if(!np)
		hshtab.hasht[MKhash(l)] = ep;
	else
		np->link = ep;
	VOID strmov(ep->_name, nam, namlen+1);
	ep->ln_hash = l;
	ep->namlen = (char)namlen;
	ep->vtype = (char)vtype;
	ep->flags = 0;
	ep->dimens = 0;
	ep->d = entry_zero;
	return(ep);
}

/*
 * getnm will return with nm[] and vartype set appropriately but without
 * any regard for subscript parameters. Called by dimensio() only.
 */

struct	entry	*
getnm(isfunc, mknew)
int	isfunc;
int	mknew;
{
	register struct entry   *ep;
	register CHAR   *p,*q;
	register struct entry   *np;
	int    l;
	char	vtype;
	int	namlen;	/* it would be better if this was a char... */
	int	lbrak;
	CHAR	nam[MAXLIN];

	namlen = nam_read(nam, &l);
	vtype = vartype | isfunc;
	lbrak = (*point != LBRACK);
	for(np = 0,ep=hshtab.hasht[MKhash(l)]; ep ; np = ep,ep=ep->link)
		if(l == ep->ln_hash && namlen==ep->namlen && vtype ==ep->vtype){
			if(!isfunc && lbrak != !ep->dimens)
				continue;
			for(p = ep->_name,q = nam ; *q == *p++ ; )
				if(!*q++)
					return(ep);
		}

	if(mknew)
		newentry = new_entry(nam, namlen, l, np, UNK_VAL);
	return(0);
}

/*
 *      getname() will return a pointer to a variable with vartype
 *    set to the correct type. If the variable is subscripted getarray
 *    is called and the subscripts are evaluated and depending upon
 *    the type of variable the index into that array is returned.
 *      Any simple variable that is not already declared is defined
 *    and has a value of 0 or null (for strings) assigned to it.
 *      In all instances a valid pointer is returned.
 */

#define	FNTYPOK(ep, isfunc) 	(((ep)->vtype & ISFUNC) && \
		((isfunc & IS_MPR) != 0) == ((ep)->_deffn->mline == IS_MPR))

MEMP
getname(isfunc)
#ifdef	mips
volatile int	isfunc;
#else
int	isfunc;
#endif
{
	register struct entry   *ep;
	register CHAR   *p,*q;
	struct  entry   *np = 0;
	int	l;
	int	namlen;
	CHAR	nam[MAXLIN];
	char	xisfunc = (char)~(isfunc & ISFUNC);
	struct	entry	*xap = 0;


	namlen = nam_read(nam, &l);
	ep = hshtab.hasht[MKhash(l)];
	if(*point==LBRACK){
		for(; ep ; np = ep, ep = ep->link)
			if(l == ep->ln_hash && namlen == ep->namlen &&
					vartype == (char)(ep->vtype & xisfunc))
				for(p = ep->_name,q = nam ; *q == *p++ ; )
					if(!*q++){
						if(isfunc){
							if(FNTYPOK(ep, isfunc)){
								curentry = ep;
								return((MEMP)0);
							}
							if(ep->dimens)
								xap = ep;
						}
						else if(ep->dimens)
							return(getarray(ep));
						break;
					}
		if( (ep = xap) == 0){
			/*
			 * get here if no defined array.
			 * auto define an array of 10 elements
			 */
			ep = new_entry(nam, namlen, l, np, UNK_VAL);
			curentry = ep;
			def_darr(ep, DEF_AR_SIZ, 0);
		}
		return(getarray(ep));
	}
	for(; ep ; np = ep , ep = ep->link)
		if(l == ep->ln_hash && namlen == ep->namlen && !ep->dimens &&
					vartype == (char)(ep->vtype & xisfunc))
			for(p = ep->_name,q = nam ; *q == *p++ ; )
				if(!*q++){
					curentry = ep;
					if(isfunc){
						if(FNTYPOK(ep, isfunc))
							return( (MEMP)0);
						if((ep->vtype & ISFUNC) == 0)
							xap = ep;
						break;
					}
					if(vartype == SVAL)
						return( (MEMP)&ep->_dst);
					else
						return( (MEMP)&ep->_dval);
				}
	if( (ep = xap) == 0)
		ep = new_entry(nam, namlen, l, np, (int)vartype);
	curentry = ep;

/*
	if(vartype == SVAL){
		ep->_dstr = 0;
		ep->_dslen = 0;
		return( (MEMP) &ep->_dst);
	}
	else if(vartype == IVAL)
		ep->_dval.i = 0;
	else
		ep->_dval.f = ZERO;
*/
	if(vartype == SVAL)
		return( (MEMP) &ep->_dst);
	return( (MEMP) &ep->_dval);
}

void
def_darr(ep, siz1, siz2)
register struct	entry	*ep;
int	siz1, siz2;
{
	register ival	l;

	l = TYP_SIZ(vartype) * siz1;
	if(siz2)
		l *= siz2;
	ep->_darr = (memp)mmalloc( (ival)(l +
				(siz2 ? (sizeof(ival) * 2) : sizeof(ival))));
	/*LINTED*/
	ep->_dims = (ival *)(ep->_darr + l);
	ep->_dims[0] = siz1;
	if(siz2){
		ep->_dims[1] = siz2;
		ep->dimens = 2;	/* double dimension array */
	}
	else
		ep->dimens = 1;	/* single dimension array */
	clr_mem( (memp)ep->_darr, (ival)l);
	ep->vtype = vartype;
}

struct entry	*
getmat(mk)
int	mk;
{
	register struct entry   *ep;
	register CHAR   *p,*q;
	struct  entry   *np = 0;
	int	l;
	int	namlen;
	CHAR	nam[MAXLIN];

	namlen = nam_read(nam, &l);
	if(vartype == SVAL)
		error(19);

	ep = hshtab.hasht[MKhash(l)];
	for(; ep ; np = ep, ep = ep->link)
		if(l == ep->ln_hash && namlen == ep->namlen && ep->dimens &&
							vartype == ep->vtype)
			for(p = ep->_name,q = nam ; *q == *p++ ; )
				if(!*q++){
					if(ep->dimens > 2)
						error(59);
					return(ep);
				}
	/*
	 * get here if no defined array.
	 * auto define an array of 10 elements
	 */
	ep = new_entry(nam, namlen, l, np, UNK_VAL);
	if(mk){
		newentry = ep;
		return(0);
	}
	def_darr(ep, DEF_AR_SIZ, 0);
	return(ep);
}

/*
 *      getarray() evaluates the subscripts of an array and the tries
 *    to access it. getarray() returns different things dependent
 *    on the type of variable. For an integer or real then the pointer to
 *    the element of the array is returned.
 *      For a string array element then the nm[] array is filled out
 *    with a unique number and then getstring() is called to access it.
 *      The variable hash (in the strarr structure ) is used as the
 *    offset to the next array if the array is real or integer, but
 *    is the base for the unique number to access the string structure.
 *
 *      This is a piece of 'hairy' codeing.
 */

static	MEMP
getarray(ep)
register struct	entry	*ep;
{
	register itype	l;
	itype   *m;
	int     c;
	int     i=1;
	register ival   j=0;

	point++;
	m = ep->_dims + ep->dimens - 1;
	i=1;
	do{
		l = evalint() - baseval;
		if(l >= *m || l < 0)
			error(17);
		j= l + j * *m;
		if( (c = getch()) != ',')
			break;
		m--,i++;
	} while(i <= ep->dimens);
	if(i != ep->dimens || c != RBRACK)
		error(16);
	vartype = ep->vtype;
	curentry = ep;
	j *= TYP_SIZ(ep->vtype);
	return( (MEMP)(ep->_darr + j));
}

/*
 *      dimensio() executes the dim command. It sets up the strarr structure
 *    as needed. If the array is a string array then only the structure
 *    is filled in. This means that elements of a string array do not have
 *    storage allocated until assigned to. If the array is real or integer
 *    then the array is allocated space as well as the strarr array.
 *      This is why the hash element is needed so as to be able to access
 *    the next array.
 */

int
dimensio()
{
	register struct	entry	*ep;

	do {
		ep = getnm(0, 1);
		if(ep != 0)
			error(20);
		if(*point++ != LBRACK)
			error(SYNTAX);
		dim_one();
	}while(getch() == ',');
	point--;
	normret;
}

static	void
dim_one()
{
	itype   dims[MAXDIMS];
	long    j;
	int     c;
	char    vty;
	register int     i;
	register itype   *r;
	register struct	entry	*ep;
	int	ii;

	ep = newentry;
	vty = vartype;            /* save copy of type of array */

	for(i = 0, j = 1, r = dims; i < MAXDIMS; i++, r++){
		if( (*r = evalint()) <= 0)
			error(17);
		if(!baseval)
			++*r;
#ifndef pdp11
#ifdef	BIG_INTS
		j =  (long)mmult_ply( (itype)j, *r, 17);
		if(j > MAX_ARRAY)
			error(17);
#else
		if((j *= *r) <= 0 || j > 32767)
			error(17);
#endif
#else
		if( (j=dimmul( (int)j , *r)) <= 0)
			error(17);
#endif
		if((c=getch())!=',')
			break;
	}
	if(i == MAXDIMS || c!=RBRACK)
		error(16);
	i++;
	j *= TYP_SIZ(vty);
	if(!mtestalloc( (ival)(j + (i * sizeof(ival)))))
		error(24);
	ep->_darr = (memp)mmalloc((ival)(j + (i * sizeof(ival))));
	/*LINTED*/
	ep->_dims = (ival *)(ep->_darr + j);
	ep->dimens = (char)i;
	ep->vtype = vty;
	for(ii = 0, i-- ; i >= 0 ; i--, ii++)
		ep->_dims[ii] = dims[i];
	clr_mem( (memp)ep->_darr, (ival)j);
	newentry = 0;
}

void
drop_val(dap, tofree)
struct	entry	*dap;
int	tofree;
{
	register struct	entry	*ep, *np;
	int	i = MKhash(dap->ln_hash);

	for(np = 0, ep = hshtab.hasht[i]; ep ; np = ep, ep = ep->link)
		if(ep == dap){
			if(!np)
				hshtab.hasht[i] = dap->link;
			else
				np->link = dap->link;
			if(tofree)
				mfree( (MEMP)dap);
			break;
		}
}

int
berase()
{
	struct	entry	*ep;

	do {
		ep = getnm(0, 0);
		if(*point == LBRACK){
			point++;
			if(getch() != RBRACK)
				error(SYNTAX);
		}
		if(ep != 0){
			drop_val(ep, 0);
			free_entry(ep);
		}
	} while(getch() == ',');
	point--;
	normret;
}

/*
 *      Assign() is called if there is no keyword at the start of a
 *    statement ( Default assignment statement ) and by let.
 *    it just calls the relevent evaluation routine and leaves all the
 *    hard work to stringassign() and putin() to actualy assign the variables.
 */

typedef	struct	{
	valp	val;
	struct entry *eptr;
} as_part;

void
assign(isfunc)
int	isfunc;
{
	register as_part *ap;
	register int	npart;
	register valp	p;
	char   vty;
	int    c;
	STR	st, fstr;
	as_part	aparts[MAXLIN/2];

	p= (valp)getname(isfunc);
	if(p == 0){
		ffn(curentry, (STR)0);
		return;
	}
	vty = vartype;
	ap = aparts;
	ap->val = p;
	ap->eptr = curentry;
	npart = 1;
	while( (c = getch()) == ','){
		npart++;
		ap++;
		ap->val = (valp)getname(0);
		ap->eptr = curentry;
		if(vartype != vty)
			error(4);
	}
	if(c != '=')
		error(4);
	if(vty == SVAL){
		st = stringeval();
		while(npart > 1){
			/*
			 * must duplicate st and then do a stringassign
			 */
			fstr = ALLOC_STR( (ival)0);
			fstr->strlen = st->strlen;
			fstr->strval = st->strval;
			RESERVE_SPACE(fstr, fstr->strlen);
			
			/*LINTED*/
			stringassign( (stringp)ap->val, ap->eptr, fstr, 0);
			ap--;
			npart--;
		}
		/*LINTED*/
		stringassign( (stringp)ap->val, ap->eptr, st, 0);
		return;
	}
	eval();
	putin(p, (int)vty);
	if(--npart > 0){
		if(vty == RVAL)
			for(; npart ; npart--, ap--)
				*ap->val = *p;
		else {
			for(; npart ; npart--, ap--)
				ap->val->i = p->i;
		}
	}
}

void
bvarptr()
{
	valp	p;
	MEMP	rvl;

	p = (valp)getname(0);
	if(vartype == SVAL)
		rvl = (MEMP)(((stringp)p)->str);
	else if(vartype != RVAL)
		rvl = (MEMP)&p->i;
	else
		rvl = (MEMP)p;
	vartype = IVAL;
	res.i = (ival)rvl;
}
	
int
bdefint()
{
	bdeftype(IVAL);
	normret;
}

int
bdefstr()
{
	bdeftype(SVAL);
	normret;
}

int
bdefdbl()
{
	bdeftype(RVAL);
	normret;
}

#define	set_let(c, val)	(tcharmap[(c) - 'A'] = val)

static	void
bdeftype(vty)
int	vty;
{
	int	c, c1;
	int	first = 1;

	for(;;){
		c = getch();
		if(istermin(c)){
			if(first)
				error(SYNTAX);
			point--;
			break;
		}
		first = 0;
		if(!isletter(c))
			error(SYNTAX);
		c1 = getch();
		if(c1 == '-'){
			c1 = getch();
			if(!isletter(c1))
				error(SYNTAX);
			if(c1 - c > 'z' - 'a' || c1 < c)
				error(SYNTAX);
			/*
			 * range set
			 */
			while(c <= c1){
				set_let(c, (CHAR)vty);
				c++;
			}
		}
		else if(isletter(c1) || istermin(c1)){
			set_let(c, (CHAR)vty);
			/*
			 * single character set
			 */
			point--;
		}
		else if(c1 != ',')
			error(SYNTAX);
	}
}

int
bcommon()
{
	struct	entry	*ep;
	do {
		ep = getnm(0, 1);
		if(!ep){
			ep = newentry;
			if(*point == LBRACK){
				if(*++point != RBRACK)
					error(SYNTAX);
				/*
				 * common arrays must first be defined
				 * using dim. So give an error here.
				 */
				error(19);
			}
			else
				ep->vtype = vartype;
			newentry = 0;
		}
		else {
			if(ep->flags & (IS_LOCAL|IS_FSTRING))
				error(55);
			if(*point == LBRACK){
				if(*(point+1) != RBRACK)
					error(SYNTAX);
				point+=2;
				if(ep->dimens == 0)
					error(19);
			}
			else if(ep->dimens != 0 || (ep->flags & ISFUNC))
				error(2);
		}
		ep->flags |= IS_COMMON;
	} while(getch() == ',');
	point--;
	normret;
}

int
blocal()
{
	register forstp	fp;
	register  struct entry	*ep;
	loc_sav_t	*lp;
	struct	loc_sav_e	loc;
	struct	entry	*todrop;

	for(fp = estack ; fp ; fp = fp->prev)
		if(fp->fortyp == FNTYP)
			break;
	if(!fp)
		error(54);
	lp = fp->fnLOCAL;
	do {
		ep = getnm(0, 1);
		loc.lentry = 0;
		loc.hentry = 0;
		todrop = 0;
		if(!ep){
			ep = newentry;
			if(*point == LBRACK){
				if(*++point != RBRACK)
					dim_one();
				else {
					point++;
					/*
					 * allocate a default array for this
					 * var, I suppose this is justified
					 */
					def_darr(ep, DEF_AR_SIZ, 0);
				}
			}
			else
				ep->vtype = vartype;
			newentry = 0;
			loc.hentry = ep;
		}
		else {
			loc.lentry = ep;
			if(*point == LBRACK){
				if(*(point+1) != RBRACK)
					error(SYNTAX);
				point+=2;
/*
				if(ep->dimens == 0)
					error(19);
*/
			}
			else if(ep->dimens != 0 || (ep->flags & ISFUNC))
				error(2);
			loc.hentry = dup_var(ep);
			add_entry(loc.hentry);
			todrop = ep;
		}
		if(lp == 0 || lp->narg >= LOC_SAV_E){
			lp = (loc_sav_t *)mmalloc((ival)sizeof(loc_sav_t));
			lp->narg = 0;
			lp->next = fp->fnLOCAL;
			fp->fnLOCAL = lp;
		}
		loc.hentry->flags |= IS_LOCAL;
		if(todrop)
			drop_val(todrop, 0);
		lp->arg[lp->narg++] = loc;
	} while(getch() == ',');
	point--;
	normret;
}

struct	entry	*
dup_var(oep)
struct	entry	*oep;
{
	register struct	entry	*ep;
	register ival	i, j, siz;

	ep = (struct entry *)mmalloc( (ival)(sizeof(struct entry)+oep->namlen));
	*ep = *oep;
	ep->link = 0;
	VOID strmov(ep->_name, oep->_name, ep->namlen+1);
	if(ep->dimens){
		/* work out size of the array and allocate again */
		j = TYP_SIZ(ep->vtype);

		for(i = 0 ; i < ep->dimens ; i++)
			j *= ep->_dims[i];
		siz = j + (ep->dimens * sizeof(ival));
		/*
		 * Check to see if we have enough space
		 */
		if(!mtestalloc(siz)){
			mfree( (MEMP)ep);
			error(24);
		}
		/*
		 * reallocate the array and the indexes
		 */
		ep->_darr = (memp)mmalloc(siz);
		/*LINTED*/
		ep->_dims = (ival *)(ep->_darr + j);
		for(i = 0 ; i < ep->dimens ; i++)
			ep->_dims[i] = oep->_dims[i];
		clr_mem(ep->_darr, j);
	}
	else
		ep->d = entry_zero;
	ep->flags &= ~(IS_COMMON|IS_FSTRING);
	return(ep);
}