static char rcsid[] = "$Header:exec.c 12.0$";
#include "defs"

exlab(n)
register int n;
{
if(n==0 && ((struct execblock *)thisexec)->labelno && !(((struct execblock *)thisexec)->labused))
	{
	((struct execblock *)thisexec)->labused = 1;
	n = ((struct execblock *)thisexec)->labelno;
	}

if(!prevbg || n!=0)  /* avoid empty statement */
	{
	if(comments && !afterif) putcomment();
	putic(ICBEGIN, n);
	putic(ICINDENT, ctllevel);
	if(n != 0)
		if(stnos[n] != 0)
			fatal("statement number changed");
		else	stnos[n] = ( nxtstno += tailor.deltastno) ;
	TEST fprintf(diagfile, "LABEL %d\n", n);
	((struct execblock *)thisexec)->nftnst++;
	afterif = 0;
	}
}


exgoto(n)
int n;
{
exlab(0);
exgo1(n);
}

exgoind(n)
int n;
{
exlab(0);
putic(ICKEYWORD,FGOTO);
putic(ICINDPTR,n);
TEST fprintf(diagfile, "goto indirect %o\n", n);
}



exgo1(n)
int n;
{
putic(ICKEYWORD,FGOTO);
putic(ICLABEL,n);
TEST fprintf(diagfile, "goto %d\n", n);
}


excompgoto(labs,index)
ptr labs;
register ptr index;
{
register int first;
register ptr p;

index = simple(LVAL,index);
if(tailor.ftn77)
	exlab(0);
else
	{
	int ncases = 0;
	for(p = labs ; p ; p = ((struct chain *)p)->nextp)
		++ncases;
	exif1( mknode(TLOGOP, OPAND,
		mknode(TRELOP,OPGT, cpexpr(index), mkint(0)),
		mknode(TRELOP,OPLE, cpexpr(index), mkint(ncases)) ));
	}

putic(ICKEYWORD, FGOTO);
putic(ICOP,OPLPAR);

first = 1;
for(p = labs ; p ; p = ((struct chain *)p)->nextp)
	{
	if(first)   first = 0;
	else   putic(ICOP,OPCOMMA);
	putic(ICLABEL,((struct chain *)p)->datap);
	}
putic(ICOP,OPRPAR);
frchain(&labs);

putic(ICOP,OPCOMMA);
prexpr(index);
frexpr(index);
TEST fprintf(diagfile, "computed goto\n");
}




excall(p)
register ptr p;
{
register ptr q1, q2, q3;
ptr mkholl(), exioop();

if(((struct headbits *)p)->tag==TNAME || ((struct headbits *)p)->tag==TFTNBLOCK)
	p = mkcall(p, PNULL);

if(((struct headbits *)p)->tag == TERROR)
	{
	frexpr(p);
	return;
	}
if(((struct headbits *)p)->tag != TCALL)
	badtag("excall", ((struct headbits *)p)->tag);

q1 = ((struct exprblock *)p)->leftp;
q2 = (((struct headbits *)q1)->tag==TFTNBLOCK ? q1 : ((struct stentry *)((struct varblock *)q1)->sthead)->varp);
if(((struct varblock *)q2)->vtype!=TYUNDEFINED && ((struct varblock *)q2)->vtype!=TYSUBR)
	{
	dclerr("attempt to use a variable as a subroutine", ((struct stentry *)((struct varblock *)p)->sthead)->namep);
	frexpr(p);
	return;
	}
((struct varblock *)q1)->vtype = ((struct varblock *)q2)->vtype = TYSUBR;
if(((struct varblock *)q1)->vdcldone==0)
	dclit(q1);

if(((struct headbits *)q1)->tag == TNAME)
	{
	if( equals(((struct stentry *)((struct varblock *)q2)->sthead)->namep, "stop") )
		{
		exlab(0);
		putic(ICKEYWORD, FSTOP);
		TEST fprintf(diagfile,"stop ");
		if( (q1 = ((struct exprblock *)p)->rightp) && (q1 = ((struct exprblock *)q1)->leftp) )
			prexpr( simple(RVAL, ((struct chain *)q1)->datap) );
		goto done;
		}
	if( ioop(((struct stentry *)((struct varblock *)q2)->sthead)->namep) )
		{
		exioop(p,NO);
		goto done;
		}
	}

p = simple(RVAL,p);
exlab(0);
putic(ICKEYWORD,FCALL);
TEST fprintf(diagfile, "call ");
/* replace character constant arguments with holleriths */
if( (q1=((struct exprblock *)p)->rightp) && tailor.hollincall)
	for(q1 = ((struct exprblock *)q1)->leftp ; q1 ; q1 = ((struct chain *)q1)->nextp)
		if( ((struct headbits *)(q2 = ((struct chain *)q1)->datap))->tag==TCONST
		    && ((struct varblock *)q2)->vtype==TYCHAR)
			{
			((struct varblock *)q2)->vtype = TYHOLLERITH;
			frexpr(((struct varblock *)q2)->vtypep);
			((struct varblock *)q2)->vtypep = 0;
			((struct exprblock *)q2)->leftp = mkholl(q3 = ((struct exprblock *)q2)->leftp);
			cfree(q3);
			}
prexpr( p );

done:	frexpr(p);
}




ptr mkholl(p)
register char *p;
{
register char *q, *t, *s;
int n;

n = strlen(p);
q = convic(n);
s = t = (char *)calloc(n + 2 + strlen(q) , 1);
while(*q)
	*t++ = *q++;
*t++ = 'h';
while(*t++ = *p++ )
	;
return((ptr)s);
}


ptr ifthen()
{
ptr p;
ptr addexec();

p = addexec();
((struct execblock *)thisexec)->brnchend = 0;
if(((struct execblock *)thisexec)->nftnst == 0)
	{
	exlab(0);
	putic(ICKEYWORD,FCONTINUE);
	((struct execblock *)thisexec)->nftnst = 1;
	}
if(((struct execblock *)thisexec)->nftnst>1 || ((struct execblock *)thisexec)->labeled || ((struct execblock *)thisexec)->uniffable )
	{
	if(((struct ctlblock *)thisctl)->breaklab == 0)
		((struct ctlblock *)thisctl)->breaklab = nextlab();
	indifs[((struct ctlblock *)thisctl)->indifn] = ((struct ctlblock *)thisctl)->breaklab;
	}
else	((struct ctlblock *)thisctl)->breaklab = 0;
return(p);
}



exasgn(l,o,r)
ptr l;
int o;
ptr r;
{
exlab(0);
if(((struct varblock *)l)->vdcldone == 0)
	dclit(l);
frexpr( simple(LVAL , mknode(TASGNOP,o,l,r)) );
}

exretn(p)
ptr p;
{
if(p)
	{
	if(procname && ((struct varblock *)procname)->vtype && ((struct varblock *)procname)->vtype!=TYCHAR &&
	  (((struct varblock *)procname)->vtype!=TYLCOMPLEX || tailor.lngcxtype!=NULL) )
		{
		if(((struct headbits *)p)->tag!=TNAME || ((struct varblock *)p)->sthead!=((struct varblock *)procname)->sthead)
			exasgn( cpexpr(procname) , OPASGN, p);
		}
	else execerr("can only return values in a function", PNULL);
	}
else if(procname && ((struct varblock *)procname)->vtype)
	 warn("function return without data value");
exlab(0);
putic(ICKEYWORD, FRETURN);

TEST {fprintf(diagfile, "exec: return( " );  prexpr(p);  fprintf(diagfile, ")\n" );  }
}


exnull()
{
if(((struct execblock *)thisexec)->labelno && !(((struct execblock *)thisexec)->labused) )
	{
	exlab(0);
	putic(ICKEYWORD,FCONTINUE);
	}
}




exbrk(opnext,levskip,btype)
int opnext;
ptr levskip;
int btype;
{

if(opnext && (btype==STSWITCH || btype==STPROC))
	execerr("illegal next", PNULL);
else if(!opnext && btype==STPROC)
	exretn(PNULL);
else  brknxtlab(opnext,levskip,btype);
TEST fprintf(diagfile, "exec: %s\n", (opnext ? "next" : "exit"));

}



exif(e)
register ptr e;
{
int tag;

if( (tag = ((struct headbits *)e)->tag)==TERROR || ((struct varblock *)e)->vtype!=TYLOG)
	{
	frexpr(e);
	e = mkconst(TYLOG, ".true.");
	if(tag != TERROR)
		execerr("non-logical conditional expression in if", PNULL);
	}
TEST fprintf(diagfile, "exif called\n");
e = simple(RVAL,e);
exlab(0);
putic(ICKEYWORD,FIF2);
indifs[((struct ctlblock *)thisctl)->indifn = nextindif()] = 0;
putic(ICINDPTR, ((struct ctlblock *)thisctl)->indifn);
putic(ICOP,OPLPAR);
prexpr(e);
putic(ICOP,OPRPAR);
putic(ICMARK,0);
putic(ICOP,OPLPAR);
prexpr(e = simple(RVAL, mknode(TNOTOP,OPNOT,e,PNULL)));
putic(ICOP,OPRPAR);
putic(ICMARK,0);
afterif = 1;
frexpr(e);
}


exifgo(e,l)
ptr e;
int l;
{
exlab(0);
exif1(e);
exgo1(l);
}


exif1(e)
register ptr e;
{
e = simple(RVAL,e);
exlab(0);
putic(ICKEYWORD,FIF1);
putic(ICOP,OPLPAR);
TEST fprintf(diagfile, "if1 ");
prexpr( e );
frexpr(e);
putic(ICOP,OPRPAR);
putic(ICBLANK, 1);
}







brkcase()
{
ptr bgnexec();

if(ncases==0 /* && ((struct execblock *)((struct execblock *)thisexec)->prevexec)->brnchend==0 */ )
	{
	exbrk(0, PNULL, 0);
	addexec();
	bgnexec();
	}
ncases = 1;
}


brknxtlab(opnext, levp, btype)
int opnext;
ptr levp;
int btype;
{
register ptr p;
int levskip;

levskip = ( levp ? convci(((struct exprblock *)levp)->leftp) : 1);
if(levskip <= 0)
	{
	execerr("illegal break count %d", levskip);
	return;
	}

for(p = thisctl ; p!=0 ; p = ((struct ctlblock *)p)->prevctl)
	if( (btype==0 || ((struct headbits *)p)->subtype==btype) &&
	    ((struct headbits *)p)->subtype!=STIF && ((struct headbits *)p)->subtype!=STPROC &&
	    (!opnext || ((struct headbits *)p)->subtype!=STSWITCH) )
		if(--levskip == 0) break;

if(p == 0)
	{
	execerr("invalid break/next", PNULL);
	return;
	}

if(((struct headbits *)p)->subtype==STREPEAT && opnext)
	exgoind(((struct ctlblock *)p)->indifn);
else if(opnext)
	exgoto(((struct ctlblock *)p)->nextlab);
else	{
	if(((struct ctlblock *)p)->breaklab == 0)
		((struct ctlblock *)p)->breaklab = nextlab();
	exgoto(((struct ctlblock *)p)->breaklab);
	}
}



ptr doloop(p1,p2,p3)
ptr p1;
ptr p2;
ptr p3;
{
register ptr p, q;
register int i;
int val[3];

p = (ptr)ALLOC(doblock);
((struct headbits *)p)->tag = TDOBLOCK;

if(((struct headbits *)p1)->tag!=TASGNOP || ((struct headbits *)p1)->subtype!=OPASGN || ((struct headbits *)((struct exprblock *)p1)->leftp)->tag!=TNAME)
	{
	((struct doblock *)p)->dovar = gent(TYINT, PNULL);
	((struct doblock *)p)->dopar[0] = p1;
	}
else	{
	((struct doblock *)p)->dovar = ((struct exprblock *)p1)->leftp;
	((struct doblock *)p)->dopar[0] = ((struct exprblock *)p1)->rightp;
	frexpblock(p1);
	}
if(p2 == 0)
	{
	((struct doblock *)p)->dopar[1] = ((struct doblock *)p)->dopar[0];
	((struct doblock *)p)->dopar[0] = mkint(1);
	}
else	((struct doblock *)p)->dopar[1] = p2;
((struct doblock *)p)->dopar[2] = p3;

for(i = 0; i<3 ; ++i)
	{
	if(q = ((struct doblock *)p)->dopar[i])
		{
		if( (((struct headbits *)q)->tag==TNAME || ((struct headbits *)q)->tag==TTEMP) &&
		   (((struct varblock *)q)->vsubs || ((struct varblock *)q)->voffset) )
			((struct doblock *)p)->dopar[i] = simple(RVAL,mknode(TASGNOP,0,
				gent(TYINT,PNULL), q));
		else
			((struct doblock *)p)->dopar[i] = simple(LVAL, coerce(TYINT, q) );

		if(isicon(((struct doblock *)p)->dopar[i], &val[i]))
			{
			if(val[i] <= 0)
				execerr("do parameter out of range", PNULL);
			}
		else	val[i] = -1;
		}
	}

if(val[0]>0 && val[1]>0 && val[0]>val[1])
	execerr("do parameters out of order", PNULL);
return(p);
}
