static char rcsid[] = "$Header:simple.c 12.0$";
#include <ctype.h>
#include "defs"


/* basic simplifying procedure */

ptr simple(t,e)
int t;	/* take on the values LVAL, RVAL, and SUBVAL */
register ptr e;	/* points to an expression */
{
int tag, subtype;
ptr lp, rp;
int ltag;
int lsubt;
ptr p, e1;
ptr exio(), exioop(), dblop(), setfield(), gentemp();
int a,b,c;

top:

if(e == 0) return(0);

tag = ((struct headbits *)e)->tag;
subtype = ((struct headbits *)e)->subtype;
if(lp = ((struct exprblock *)e)->leftp)
	{
	ltag = ((struct headbits *)lp)->tag;
	lsubt = ((struct headbits *)lp)->subtype;
	}
rp = ((struct exprblock *)e)->rightp;

TEST fprintf(diagfile, "simple(%d; tag %d,%d)\n", t,tag,subtype);

switch(tag){

case TNOTOP:
	switch(ltag) {

	case TNOTOP:	/* not not = yes */
		frexpblock(e);
		e = ((struct exprblock *)lp)->leftp;
		frexpblock(lp);
		goto top;

	case TLOGOP:	/* de Morgan's Law */
		((struct headbits *)lp)->subtype = (OPOR+OPAND) - ((struct headbits *)lp)->subtype;
		((struct exprblock *)lp)->leftp = mknode(TNOTOP,OPNOT,((struct exprblock *)lp)->leftp, PNULL);
		((struct exprblock *)lp)->rightp=mknode(TNOTOP,OPNOT,((struct exprblock *)lp)->rightp, PNULL);
		frexpblock(e);
		e = lp;
		goto top;

	case TRELOP:	/* reverse the condition */
		((struct headbits *)lp)->subtype = (OPEQ+OPNE) - ((struct headbits *)lp)->subtype;
		frexpblock(e);
		e = lp;
		goto top;

	case TCALL:
	case TASGNOP:
		((struct exprblock *)e)->leftp = simple(RVAL,lp);

	case TNAME:
	case TFTNBLOCK:
		lp = simple(RVAL,lp);

	case TTEMP:
		if(t == LVAL)
			e = simple(LVAL,
			      mknode(TASGNOP,0, gentemp(((struct exprblock *)e)->leftp), e));
		break;

	case TCONST:
		if(equals(((struct exprblock *)lp)->leftp, ".false."))
			((struct exprblock *)e)->leftp = (ptr)copys(".true.");
		else if(equals(((struct exprblock *)lp)->leftp, ".true."))
			((struct exprblock *)e)->leftp = (ptr)copys(".false.");
		else goto typerr;

		((struct headbits *)e)->tag = TCONST;
		((struct headbits *)e)->subtype = 0;
		cfree(((struct exprblock *)lp)->leftp);
		frexpblock(lp);
		break;

	default:  goto typerr;
		}
	break;




case TLOGOP: switch(subtype) {
		case OPOR:
		case OPAND:
			goto binop;

		case OP2OR:
		case OP2AND:
			lp = ((struct exprblock *)e)->leftp = simple(RVAL, lp);
			if(((struct headbits *)lp)->tag != TTEMP)
				lp = simple(RVAL,
					mknode(TASGNOP,0, gent(TYLOG,0),lp));
			return( simple(LVAL, mknode(TASGNOP,subtype,lp,rp)) );
		default:
			fatal("impossible logical operator");
		}

case TNEGOP:
	lp = ((struct exprblock *)e)->leftp = simple(RVAL,lp);
	ltag = ((struct headbits *)lp)->tag;
	lsubt = ((struct headbits *)lp)->subtype;

	if(ltag==TNEGOP)
		{
		frexpblock(e);
		e = ((struct exprblock *)lp)->leftp;
		frexpblock(lp);
		goto top;
		}
	else	goto lvcheck;

case TAROP:
case TRELOP:

binop:

	((struct exprblock *)e)->leftp = simple(RVAL,lp);
	lp = ((struct exprblock *)e)->leftp;
	ltag = ((struct headbits *)lp)->tag;
	lsubt = ((struct headbits *)lp)->subtype;

	((struct exprblock *)e)->rightp= simple(RVAL,rp);
	rp = ((struct exprblock *)e)->rightp;

	if(tag==TAROP && isicon(rp,&b) )
		{  /* simplify a*1, a/1 , a+0, a-0  */
		if( ((subtype==OPSTAR||subtype==OPSLASH) && b==1) ||
		    ((subtype==OPPLUS||subtype==OPMINUS) && b==0) )
			{
			frexpr(rp);
			mvexpr(lp,e);
			goto top;
			}

		if(isicon(lp, &a))	 /* try folding const op const */
			{
			e1 = fold(e);
			if(e1!=e || ((struct headbits *)e1)->tag!=TAROP)
				{
				e = e1;
				goto top;
				}
			}
		if(ltag==TAROP && ((struct varblock *)lp)->needpar==0 && isicon(((struct exprblock *)lp)->rightp,&a) )
			{ /* look for cases of (e op const ) op' const */

			if( (subtype==OPPLUS||subtype==OPMINUS) &&
			    (lsubt==OPPLUS||lsubt==OPMINUS) )
				{ /*  (e +- const) +- const */
				c = (subtype==OPPLUS ? 1 : -1) * b +
				    (lsubt==OPPLUS? 1 : -1) * a;
				if(c > 0)
					subtype = OPPLUS;
				else	{
					subtype = OPMINUS;
					c = -c;
					}
			fixexpr:
				frexpr(rp);
				frexpr(((struct exprblock *)lp)->rightp);
				frexpblock(e);
				e = lp;
				((struct headbits *)e)->subtype = subtype;
				((struct exprblock *)e)->rightp = mkint(c);
				goto top;
				}

			else if(lsubt==OPSTAR &&
				( (subtype==OPSTAR) ||
				    (subtype==OPSLASH && a%b==0)) )
					{ /* (e * const ) (* or /) const */
					c = (subtype==OPSTAR ? a*b : a/b );
					subtype = OPSTAR;
					goto fixexpr;
					}
			}
		if(ltag==TAROP && (lsubt==OPPLUS || lsubt==OPMINUS) &&
			subtype==OPSLASH && divides(lp,conval(rp)) )
			{
			((struct exprblock *)e)->leftp = mknode(TAROP,OPSLASH,((struct exprblock *)lp)->leftp, cpexpr(rp));
			((struct exprblock *)e)->rightp = mknode(TAROP,OPSLASH,((struct exprblock *)lp)->rightp, rp);
			((struct headbits *)e)->subtype = lsubt;
			goto top;
			}
		}

	else if( tag==TRELOP && isicon(lp,&a) && isicon(rp,&b) )
		{
		e1 = fold(e);
		if(e1!=e || ((struct headbits *)e1)->tag!=TRELOP)
			{
			e = e1;
			goto top;
			}
		}

lvcheck:
	if(t == LVAL)
		e = simple(LVAL, mknode(TASGNOP,0, gentemp(e),e));
	else if(t == SUBVAL)
		{  /* test for legal Fortran c*v +-c  form */
		if(tag==TAROP && (subtype==OPPLUS || subtype==OPMINUS))
			if(((struct headbits *)rp)->tag==TCONST && ((struct varblock *)rp)->vtype==TYINT)
				{
				if(!cvform(lp))
					((struct exprblock *)e)->leftp = simple(SUBVAL, lp);
				}
			else goto makesub;
		else if( !cvform(e) ) goto makesub;
		}
	break;

case TCALL:
	if( ((struct headbits *)lp)->tag!=TFTNBLOCK && ioop(((struct stentry *)((struct varblock *)lp)->sthead)->namep) )
		{
		e = exioop(e, YES);
		exlab(0);
		break;
		}
	((struct exprblock *)e)->rightp = simple(RVAL, rp);
	if(t == SUBVAL)
		goto makesub;
	if(t == LVAL)
		e = simple(RVAL, mknode(TASGNOP,0, gentemp(e),e));
	break;


case TNAME:
	if(((struct varblock *)e)->voffset)
		fixsubs(e);
	if(((struct varblock *)e)->vsubs)
		((struct varblock *)e)->vsubs = simple(SUBVAL, ((struct varblock *)e)->vsubs);
	if(t==SUBVAL && !vform(e))
		goto makesub;

case TTEMP:
case TFTNBLOCK:
case TCONST:
	if(t==SUBVAL && ((struct varblock *)e)->vtype!=TYINT)
		goto makesub;
	break;

case TASGNOP:
	lp = ((struct exprblock *)e)->leftp = simple(LVAL,lp);
	if(subtype==OP2OR || subtype==OP2AND)
		e = dblop(e);

	else	{
		rp = ((struct exprblock *)e)->rightp = simple(RVAL,rp);
		if(((struct varblock *)e)->vtype == TYCHAR)
			excall(mkcall(mkftnblock(TYSUBR,"ef1asc"), arg4(cpexpr(lp),rp)));
		else if(((struct varblock *)e)->vtype == TYSTRUCT)
			{
			if(((struct typeblock *)((struct varblock *)lp)->vtypep)->strsize != ((struct typeblock *)((struct varblock *)rp)->vtypep)->strsize)
				fatal("simple: attempt to assign incompatible structures");
			e1 = (ptr)mkchain(cpexpr(lp),mkchain(rp,
				mkchain(mkint(((struct typeblock *)((struct varblock *)lp)->vtypep)->strsize),CHNULL)));
			excall(mkcall(mkftnblock(TYSUBR,"ef1ass"),
				mknode(TLIST, 0, e1, PNULL) ));
			}
		else if(((struct varblock *)lp)->vtype == TYFIELD)
			lp = setfield(e);
		else	{
			if(subtype != OPASGN)	/* but is one of += etc */
				{
				rp = ((struct exprblock *)e)->rightp = simple(RVAL, mknode(
					(subtype<=OPPOWER?TAROP:TLOGOP),subtype,
					cpexpr(((struct exprblock *)e)->leftp),((struct exprblock *)e)->rightp));
				((struct headbits *)e)->subtype = OPASGN;
				}
			exlab(0);
			prexpr(e);
			frexpr(rp);
			}
		frexpblock(e);
		e = lp;
		if(t == SUBVAL) goto top;
		}

	break;

case TLIST:
	for(p=lp ; p ; p = ((struct chain *)p)->nextp)
		((struct chain *)p)->datap = simple(t, ((struct chain *)p)->datap);
	break;

case TIOSTAT:
	e = exio(e, 1);
	break;

default:
	break;
	}

return(e);


typerr:
	exprerr("type match error", CNULL);
	return(e);

makesub:
	if(t==SUBVAL && ((struct varblock *)e)->vtype!=TYINT)
		warn1("Line %d. Non-integer subscript", yylineno);
	return( simple(RVAL, mknode(TASGNOP,0,gent(TYINT,PNULL),e)) );
}

ptr fold(e)
register ptr e;
{
int a, b, c;
register ptr lp, rp;

lp = ((struct exprblock *)e)->leftp;
rp = ((struct exprblock *)e)->rightp;

if(((struct headbits *)lp)->tag!=TCONST && ((struct headbits *)lp)->tag!=TNEGOP)
	return(e);

if(((struct headbits *)rp)->tag!=TCONST && ((struct headbits *)rp)->tag!=TNEGOP)
	return(e);


switch(((struct headbits *)e)->tag)
	{
	case TAROP:
		if( !isicon(lp,&a) || !isicon(rp,&b) )
			return(e);

		switch(((struct headbits *)e)->subtype)
			{
			case OPPLUS:
				c = a + b;break;
			case OPMINUS:
				c = a - b; break;
			case OPSTAR:
				c = a * b; break;
			case OPSLASH:
				if(a%b!=0 && (a<0 || b<0) )
					return(e);
				c = a / b; break;
			case OPPOWER:
				return(e);
			default:
				fatal("fold: illegal binary operator");
			}
		frexpr(e);

		if(c >= 0)
			return( mkint(c) );
		else	return(mknode(TNEGOP,OPMINUS, mkint(-c), PNULL) );

	case TRELOP:
		if( !isicon(lp,&a) || !isicon(rp,&b) )
			return(e);
		frexpr(e);

		switch(((struct headbits *)e)->subtype)
			{
			case OPEQ:
				c =  a == b; break;
			case OPLT:
				c = a < b ; break;
			case OPGT:
				c = a > b; break;
			case OPLE:
				c = a <= b; break;
			case OPGE:
				c = a >= b; break;
			case OPNE:
				c = a != b; break;
			default:
				fatal("fold: invalid relational operator");
			}
		return( mkconst(TYLOG, (c ? ".true." : ".false.")) );


	case TLOGOP:
		if(((struct varblock *)lp)->vtype!=TYLOG || ((struct varblock *)rp)->vtype!=TYLOG)
			return(e);
		a = equals(((struct exprblock *)lp)->leftp, ".true.");
		b = equals(((struct exprblock *)rp)->leftp, ".true.");
		frexpr(e);

		switch(((struct headbits *)e)->subtype)
			{
			case OPAND:
			case OP2AND:
				c = a & b; break;
			case OPOR:
			case OP2OR:
				c = a | b; break;
			default:
				fatal("fold: invalid logical operator");
			}
		return( mkconst(TYLOG, (c? ".true." : ".false")) );

	default:
		return(e);
	}
}

#define TO   + 100*


ptr coerce(t,e)	/* coerce expression  e  to type  t */
int t;
register ptr e;
{
register int et;
int econst;
char buff[100];
char *s, *s1;
ptr conrep(), xfixf();

if(((struct headbits *)e)->tag == TNEGOP)
	{
	((struct exprblock *)e)->leftp = coerce(t, ((struct exprblock *)e)->leftp);
	goto settype;
	}

et = ((struct varblock *)e)->vtype;
econst = (((struct headbits *)e)->tag == TCONST);
TEST fprintf(diagfile, "coerce type %d to type %d\n", et, t);
if(t == et)
	return(e);

switch( et TO t )
	{
	case TYCOMPLEX TO TYINT:
	case TYLREAL TO TYINT:
		e = coerce(TYREAL,e);
	case TYREAL TO TYINT:
		if(econst)
			e = xfixf(e);
		if(((struct varblock *)e)->vtype != TYINT)
			e = mkcall(builtin(TYINT,"ifix"), arg1(e));
		break;

	case TYINT TO TYREAL:
		if(econst)
			{
			((struct exprblock *)e)->leftp = conrep(((struct exprblock *)e)->leftp, ".");
			goto settype;
			}
		e = mkcall(builtin(TYREAL,"float"), arg1(e));
		break;

	case TYLREAL TO TYREAL:
		if(econst)
			{
			for(s=(char *)((struct exprblock *)e)->leftp ; *s && *s!='d';++s)
				;
			*s = 'e';
			goto settype;
			}
		e = mkcall(builtin(TYREAL,"sngl"), arg1(e));
		break;

	case TYCOMPLEX TO TYREAL:
		if(econst)
			{
			s1 = (char *)(((struct exprblock *)e)->leftp) + 1;
			s = buff;
			while(*s1!=',' && *s1!='\0')
				*s1++ = *s++;
			*s = '\0';
			cfree(((struct exprblock *)e)->leftp);
			((struct exprblock *)e)->leftp = (ptr)copys(buff);
			goto settype;
			}
		else
			e = mkcall(mkftnblock(TYREAL,"real"), arg1(e));
		break;

	case TYINT TO TYLREAL:
		if(econst)
			{
			((struct exprblock *)e)->leftp = conrep(((struct exprblock *)e)->leftp,"d0");
			goto settype;
			}
	case TYCOMPLEX TO TYLREAL:
		e = coerce(TYREAL,e);
	case TYREAL TO TYLREAL:
		if(econst)
			{
			for(s=(char *)((struct exprblock *)e)->leftp ; *s && *s!='e'; ++s)
				;
			if(*s == 'e')
				*s = 'd';
			else	((struct exprblock *)e)->leftp = conrep(((struct exprblock *)e)->leftp,"d0");
			goto settype;
			}
		e = mkcall(builtin(TYLREAL,"dble"), arg1(e));
		break;

	case TYINT TO TYCOMPLEX:
	case TYLREAL TO TYCOMPLEX:
		e = coerce(TYREAL, e);
	case TYREAL TO TYCOMPLEX:
		if(((struct headbits *)e)->tag == TCONST)
			{
			sprintf(buff, "(%s,0.)", ((struct exprblock *)e)->leftp);
			cfree(((struct exprblock *)e)->leftp);
			((struct exprblock *)e)->leftp = (ptr)copys(buff);
			goto settype;
			}
		else
			e = mkcall(builtin(TYCOMPLEX,"cmplx"),
				arg2(e, mkconst(TYREAL,"0.")));
		break;


	default:
		goto mismatch;
	}

return(e);


mismatch:
	exprerr("impossible conversion", "");
	frexpr(e);
	return( errnode() );


settype:
	((struct varblock *)e)->vtype = t;
	return(e);
}



/* check whether expression is in form c, v, or v*c */
cvform(p)
register ptr p;
{
switch(((struct headbits *)p)->tag)
	{
	case TCONST:
		return(((struct varblock *)p)->vtype == TYINT);

	case TNAME:
		return(vform(p));

	case TAROP:
		if(((struct headbits *)p)->subtype==OPSTAR && ((struct headbits *)((struct exprblock *)p)->rightp)->tag==TCONST
		    && ((struct varblock *)((struct exprblock *)p)->rightp)->vtype==TYINT && vform(((struct exprblock *)p)->leftp))
			return(1);

	default:
		return(0);
	}
}




/* is p a simple integer variable */
vform(p)
register ptr p;
{
return( ((struct headbits *)p)->tag==TNAME && ((struct varblock *)p)->vtype==TYINT && ((struct varblock *)p)->vdim==0
     && ((struct varblock *)p)->voffset==0 && ((struct varblock *)p)->vsubs==0) ;
}



ptr dblop(p)
ptr p;
{
ptr q;

bgnexec();
if(((struct headbits *)p)->subtype == OP2OR)
	q = mknode(TNOTOP,OPNOT, cpexpr(((struct exprblock *)p)->leftp), PNULL);
else	q = cpexpr(((struct exprblock *)p)->leftp);

pushctl(STIF, q);
bgnexec();
exasgn(cpexpr(((struct exprblock *)p)->leftp), OPASGN,  ((struct exprblock *)p)->rightp);
ifthen();
popctl();
addexec();
return(((struct exprblock *)p)->leftp);
}




divides(a,b)
ptr a;
int b;
{
if(((struct varblock *)a)->vtype!=TYINT)
	return(0);

switch(((struct headbits *)a)->tag)
	{
	case TNEGOP:
		return( divides(((struct exprblock *)a)->leftp,b) );

	case TCONST:
		return( conval(a) % b == 0);

	case TAROP:
		switch(((struct headbits *)a)->subtype)
			{
			case OPPLUS:
			case OPMINUS:
				return(divides(((struct exprblock *)a)->leftp,b)&&
					   divides(((struct exprblock *)a)->rightp,b) );

			case OPSTAR:
				return(divides(((struct exprblock *)a)->rightp,b));

			default:
				return(0);
			}
	default:
		return(0);
	}
/* NOTREACHED */
}

/* truncate floating point constant to integer */

#define MAXD 100

ptr xfixf(e)
struct exprblock *e;
{
char digit[MAXD+1];	/* buffer into which digits are placed */
char *first;	/* points to first nonzero digit */
register char *end;	/* points at position past last digit */
register char *dot;	/* decimal point is immediately to left of this digit */
register char *s;
int expon;

dot = NULL;
end = digit;
expon = 0;

for(s = (char *)((struct exprblock *)e)->leftp ; *s; ++s)
	if( isdigit(*s) )
		{
		if(end-digit > MAXD)
			return((ptr)e);
		*end++ = *s;
		}
	else if(*s == '.')
		dot = end;
	else if(*s=='d' || *s=='e')
		{
		expon = convci(s+1);
		break;
		}
	else fatal1("impossible character %d in floating constant", *s);

if(dot == NULL)
	dot = end;
dot += expon;
if(dot-digit > MAXD)
	return((ptr)e);
for(first = digit; first<end && *first=='0' ; ++first)
	;
if(dot<=first)
	{
	dot = first+1;
	*first = '0';
	}
else	while(end < dot)
		*end++ = '0';
*dot = '\0';
cfree(((struct exprblock *)e)->leftp);
((struct exprblock *)e)->leftp = (ptr)copys(first);
((struct varblock *)e)->vtype = TYINT;
return((ptr)e);
}
