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

#include "defs"

static int lastfmtchar;
static int writeop;
static int needcomma;


ptr mkiost(kwd,unit,list)
int kwd;
ptr unit;
ptr list;
{
register ptr p;

if(unit!=NULL && ((struct varblock *)unit)->vtype!=TYINT)
	{
	execerr("I/O unit must be an integer", "");
	return(NULL);
	}
p = allexpblock();
((struct headbits *)p)->tag = TIOSTAT;
((struct varblock *)p)->vtype = TYINT;
((struct iostblock *)p)->iokwd = kwd;
((struct iostblock *)p)->iounit = unit;
((struct iostblock *)p)->iolist = list;

return(p);
}




struct iogroup *mkiogroup(list, format, dop)
ptr list;
char *format;
ptr dop;
{
register struct iogroup *p;

p = ALLOC(iogroup);
((struct headbits *)p)->tag = TIOGROUP;
((struct iogroup *)p)->doptr = (struct doblock *)dop;
((struct iogroup *)p)->iofmt = format;
((struct iogroup *)p)->ioitems = list;
return(p);
}

ptr exio(iostp, errhandle)
struct iostblock *iostp;
int errhandle;
{
ptr unit, list;
int fmtlabel, errlabel, endlabel, jumplabel;
ptr errval;
int fmtio;

if(iostp == NULL)
	return( errnode() );
unit = ((struct iostblock *)iostp)->iounit;
list = ((struct iostblock *)iostp)->iolist;

/* kwd=	0  binary input 	2  formatted input
	1  binary output	3  formatted output
*/

writeop = ((struct iostblock *)iostp)->iokwd & 01;
if( fmtio = (((struct iostblock *)iostp)->iokwd & 02) )
	fmtlabel = nextlab() ;
frexpblock(iostp);

errval = 0;
endlabel = 0;
if(errhandle)
	{
	switch(tailor.errmode)
		{
		default:
			execerr("no error handling ", "");
			return( errnode() );

		case IOERRIBM:	/* ibm: err=, end= */
			jumplabel = nextlab();
			break;

		case IOERRFORT77:	/* New Fortran Standard: iostat= */
			break;

		}
	errval = gent(TYINT, PNULL);
	}
if(unit)
	unit = simple(RVAL, unit);
else	unit = mkint(writeop ? tailor.ftnout : tailor.ftnin);

if(((struct headbits *)unit)->tag!=TCONST && (((struct headbits *)unit)->tag!=TNAME || ((struct varblock *)unit)->vsubs!=0))
	unit = simple(LVAL, mknode(TASGNOP,OPASGN,gent(TYINT,PNULL),unit));

simlist(list);

exlab(0);
putic(ICKEYWORD, (writeop ? FWRITE : FREAD) );
putic(ICOP, OPLPAR);
prexpr(unit);
frexpr(unit);

if( fmtio )
	{
	putic(ICOP, OPCOMMA);
	putic(ICLABEL, fmtlabel);
	}

if(errhandle) switch(tailor.errmode)
	{
	case IOERRIBM:
		putic(ICOP,OPCOMMA);
		putsii(ICCONST, "err =");
		putic(ICLABEL, errlabel = nextlab() );
		if(!writeop)
			{
			putic(ICOP,OPCOMMA);
			putsii(ICCONST, "end =");
			putic(ICLABEL, endlabel = nextlab() );
			}
		break;

	case IOERRFORT77:
		putic(ICOP,OPCOMMA);
		putsii(ICCONST, "iostat =");
		putname(errval);
		break;
	}

putic(ICOP,OPRPAR);
putic(ICBLANK, 1);

needcomma = NO;
doiolist(list);
if(fmtio)
	{
	exlab(fmtlabel);
	putic(ICKEYWORD, FFORMAT);
	putic(ICOP, OPLPAR);
	lastfmtchar = '(';
	doformat(1, list);
	putic(ICOP, OPRPAR);
	}
friolist(list);

if(errhandle && tailor.errmode==IOERRIBM)
	{
	exasgn(cpexpr(errval), OPASGN, mkint(0) );
	exgoto(jumplabel);
	exlab(errlabel);
	exasgn(cpexpr(errval), OPASGN, mkint(1) );
	if(endlabel)
		{
		exgoto(jumplabel);
		exlab(endlabel);
		exasgn(cpexpr(errval), OPASGN,
			mknode(TNEGOP,OPMINUS,mkint(1),PNULL) );
		}
	exlab(jumplabel);
	}

return( errval );
}

doiolist(list)
ptr list;
{
register ptr p, q;
register struct doblock *dop;
for(p = list ; p ; p = ((struct chain *)p)->nextp)
	{
	switch( ((struct headbits *)(q = ((struct chain *)p)->datap) )->tag)
		{
		case TIOGROUP:
			if(dop = ((struct iogroup *)q)->doptr)
				{
				if(needcomma)
					putic(ICOP, OPCOMMA);
				putic(ICOP, OPLPAR);
				needcomma = NO;
				}
			doiolist(((struct iogroup *)q)->ioitems);
			if(dop)
				{
				putic(ICOP,OPCOMMA);
				prexpr(((struct doblock *)dop)->dovar);
				putic(ICOP, OPEQUALS);
				prexpr(((struct doblock *)dop)->dopar[0]);
				putic(ICOP, OPCOMMA);
				prexpr(((struct doblock *)dop)->dopar[1]);
				if(((struct doblock *)dop)->dopar[2])
					{
					putic(ICOP, OPCOMMA);
					prexpr(((struct doblock *)dop)->dopar[2]);
					}
				putic(ICOP, OPRPAR);
				needcomma = YES;
				}
			break;

		case TIOITEM:
			if(((struct ioitem *)q)->ioexpr)
				{
				if(needcomma)
					putic(ICOP, OPCOMMA);
				prexpr(((struct ioitem *)q)->ioexpr);
				needcomma = YES;
				}
			break;

		default:
			badtag("doiolist", ((struct headbits *)q)->tag);
		}
	}
}

doformat(nrep, list)
int nrep;
ptr list;
{
register ptr p, q;
int k;
ptr arrsize();

if(nrep > 1)
	{
	fmtnum(nrep);
	fmtop(OPLPAR);
	}

for(p = list ; p ; p = ((struct chain *)p)->nextp)
	switch( ((struct headbits *)(q = ((struct chain *)p)->datap) )->tag)
		{
		case TIOGROUP:
			if(((struct iogroup *)q)->iofmt)
				prfmt(((struct iogroup *)q)->nrep, ((struct iogroup *)q)->iofmt);
			else	{
				doformat(((struct iogroup *)q)->nrep>0 ? ((struct iogroup *)q)->nrep :
					(((struct iogroup *)q)->doptr ? repfac(((struct iogroup *)q)->doptr) : 1),
					((struct iogroup *)q)->ioitems);
				}
			break;

		case TIOITEM:
			if(((struct iogroup *)q)->iofmt == NULL)
				break;

			if(((struct iogroup *)q)->nrep==0 && ((struct ioitem *)q)->ioexpr && ((struct varblock *)((struct ioitem *)q)->ioexpr)->vdim)
				{
				if( ! isicon(arrsize(((struct ioitem *)q)->ioexpr), &k) )
					execerr("io of adjustable array", "");
				else
					prfmt(k, ((struct iogroup *)q)->iofmt);
				}
			else
				prfmt(((struct iogroup *)q)->nrep, ((struct iogroup *)q)->iofmt);
		}
if(nrep > 1)
	fmtop(OPRPAR);
}

fmtop(op)
register int op;
{
register c;

c = (op==OPLPAR ? '(' : (op==OPRPAR ? ')' : 'x') );
fmtcom(c);
putic(ICOP, op);
lastfmtchar = c;
}




fmtnum(k)
int k;
{
fmtcom('1');
prexpr( mkint(k) );
lastfmtchar = ',';	/* prevent further comma after factor*/
}








/* separate formats with comma unless already a slash*/
fmtcom(c)
int c;
{
if( c!='/' && c!=')' && lastfmtchar!='/' && lastfmtchar!='(' && lastfmtchar!=',' )
	{
	putic(ICOP, OPCOMMA);
	lastfmtchar = ',';
	}
}

prfmt(nrep, str)
int nrep;
char *str;
{
char fmt[20];
register int k, k0, k1, k2;
register char *t;

fmtcom(nrep>1 ? '1' : str[0]);

if(nrep > 1)
	{
	fmtnum(nrep);
	fmtop(OPLPAR);
	}

switch(str[0])
	{
	case 'd':
	case 'e':
	case 'g':
		if(writeop)
			{
			putsii(ICCONST, "1p");
			break;
			}
	
	case 'f':
		putsii(ICCONST, "0p");
		break;
		
	case 'c':
		k = convci(str+1);
		k0 = tailor.ftnchwd;
		k1 = k / k0;
		k2 = k % k0;
		if(k1>0 && k2>0)
			sprintf(fmt, "(%da%d,a%d)",k1,k0,k2);
		else if(k1>1)
			sprintf(fmt, "(%da%d)", k1, k0);
		else	sprintf(fmt, "a%d", k);
		putsii(ICCONST, fmt);
		lastfmtchar = 'f';	/* last char isnt operator */
		goto close;

	default:
		break;
	}
putsii(ICCONST,str);
/* if the format is an nH, act as if it ended with a non-operator character */
if( isdigit(str[0]) )
	{
	for(t = str+1 ; isdigit(*t) ; ++t);
		;
	if(*t=='h' || *t=='H')
		{
		lastfmtchar = 'f';
		goto close;
		}
	}
lastfmtchar = str[ strlen(str)-1 ];

close:
	if(nrep > 1)
		fmtop(OPRPAR);
}

friolist(list)
ptr list;
{
register ptr p, q;
register struct doblock *dop;

for(p = list; p; p = ((struct chain *)p)->nextp)
	{
	switch ( ((struct headbits *)(q = ((struct chain *)p)->datap) )->tag)
		{
		case TIOGROUP:
			if(dop = ((struct iogroup *)q)->doptr)
				{
				frexpr(((struct doblock *)dop)->dovar);
				frexpr(((struct doblock *)dop)->dopar[0]);
				frexpr(((struct doblock *)dop)->dopar[1]);
				if(((struct doblock *)dop)->dopar[2])
					frexpr(((struct doblock *)dop)->dopar[2]);
				cfree(dop);
				}
			friolist(((struct iogroup *)q)->ioitems);
			break;

		case TIOITEM:
			if(((struct ioitem *)q)->ioexpr)
				frexpr(((struct ioitem *)q)->ioexpr);
			break;

		default:
			badtag("friolist", ((struct headbits *)q)->tag);
		}
	if(((struct iogroup *)q)->iofmt)
		cfree(((struct iogroup *)q)->iofmt);
	cfree(q);
	}
frchain( &list );
}

simlist(p)
register ptr p;
{
register ptr q, ep;
struct iogroup *enloop();

for( ; p ; p = ((struct chain *)p)->nextp)
	switch( ((struct headbits *)(q = ((struct chain *)p)->datap) )->tag )
		{
		case TIOGROUP:
			simlist(((struct iogroup *)q)->ioitems);
			break;

		case TIOITEM:
			if(ep = ((struct ioitem *)q)->ioexpr)
				{
				/* if element is a subaggregate, need
				   an implied do loop */
				if( (((struct varblock *)ep)->voffset || ((struct varblock *)ep)->vsubs) &&
				    (((struct varblock *)ep)->vdim || ((struct varblock *)ep)->vtypep) )
					((struct chain *)p)->datap = (ptr)enloop(q);
				else
					((struct ioitem *)q)->ioexpr = simple(LVAL,ep);
				}
			break;

		default:
			badtag("ioblock", ((struct headbits *)q)->tag);
		}
}




/* replace an aggregate by an implied do loop of elements */

struct iogroup *enloop(p)
struct ioitem *p;
{
register struct doblock *dop;
struct iogroup *gp;
ptr np, q, v, arrsize(), mkioitem();
int nrep, k, nwd;

q = ((struct ioitem *)p)->ioexpr;
np = arrsize(q);
if( ! isicon(np, &nrep) )
	nrep = 0;

if(((struct varblock *)q)->vtype == TYCHAR)
	{
	nwd = ceil(conval(((struct varblock *)q)->vtypep), tailor.ftnchwd);
	if(nwd != 1)
		np = simple(LVAL, mknode(TAROP,OPSTAR,np,mkint(nwd)));
	}
else
	nwd = 0;

if( isicon(np, &k) && k==1)
	return((struct iogroup *)p);

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

((struct doblock *)dop)->dovar = v = gent(TYINT, PNULL);
((struct doblock *)dop)->dopar[0] = mkint(1);
((struct doblock *)dop)->dopar[1] = simple(SUBVAL, np);
((struct doblock *)dop)->dopar[2] = NULL;

q = simple(LVAL, q);
if(((struct varblock *)q)->vsubs == NULL)
	((struct varblock *)q)->vsubs = mknode(TLIST,0, mkchain(cpexpr(v),CHNULL), PNULL);
else
	((struct chain *)((struct exprblock *)((struct varblock *)q)->vsubs)->leftp)->datap = simple(SUBVAL, mknode(TAROP,OPPLUS, cpexpr(v),
		     mknode(TAROP,OPMINUS,((struct chain *)((struct exprblock *)((struct varblock *)q)->vsubs)->leftp)->datap,mkint(1))));
((struct varblock *)q)->vdim = NULL;
gp = mkiogroup( mkchain(mkioitem(q,CNULL), CHNULL), ((struct iogroup *)p)->iofmt, dop);
((struct iogroup *)gp)->nrep = nrep;
cfree(p);
return(gp);
}

ptr mkformat(letter, n1, n2)
char letter;
register ptr n1, n2;
{
char f[20], *fp, *s;
int k;

if(letter == 's')
	{
	if(n1)
		{
		k = conval(n1);
		frexpr(n1);
		}
	else	k = 1;

	for(fp = f; k-->0 ; )
		*fp++ = '/';
	*fp = '\0';
	return( (ptr)copys(f) );
	}

f[0] = letter;
fp = f+1;

if(n1)	{
	n1 = simple(RVAL,n1);
	if(((struct headbits *)n1)->tag==TCONST && ((struct varblock *)n1)->vtype==TYINT)
		{
		for(s = (char *)((struct exprblock *)n1)->leftp ; *s; )
			*fp++ = *s++;
		}
	else	execerr("bad format component %s", ((struct exprblock *)n1)->leftp);
	frexpr(n1);
	}

if(n2)	{
	if(((struct headbits *)n2)->tag==TCONST && ((struct varblock *)n2)->vtype==TYINT)
		{
		*fp++ = '.';
		for(s = (char *)((struct exprblock *)n2)->leftp ; *s; )
			*fp++ = *s++;
		}
	else	execerr("bad format component %s", ((struct exprblock *)n2)->leftp);
	frexpr(n2);
	}

if( letter == 'x' )
	{
	if(n1 == 0)
		*fp++ = '1';
	fp[0] = 'x';
	fp[1] = '\0';
	return( (ptr)copys(f+1) );
	}
else	{
	*fp = '\0';
	return( (ptr)copys(f) );
	}
}

ptr mkioitem(e,f)
register ptr e;
char *f;
{
register ptr p;
char fmt[10];
ptr gentemp();

p = (ptr)ALLOC(ioitem);
((struct headbits *)p)->tag = TIOITEM;
if(e!=NULL && ((struct headbits *)e)->tag==TCONST)
	if(((struct varblock *)e)->vtype==TYCHAR && (f==0 || (f[0]=='c' && f[1]=='\0') ))
		{
		((struct ioitem *)p)->ioexpr = 0;
		sprintf(msg, "%dh%s", strlen(((struct exprblock *)e)->leftp), ((struct exprblock *)e)->leftp);
		((struct iogroup *)p)->iofmt = copys(msg);
		frexpr(e);
		return(p);
		}
	else	e = mknode(TASGNOP,OPASGN,gentemp(e),e);

if(e && ((struct varblock *)e)->vtype==TYCHAR && f && f[0]=='c' && f[1]=='\0')
	f = NULL;
if(f == NULL)
	{
	switch(((struct varblock *)e)->vtype)
		{
		case TYINT:
		case TYREAL:
		case TYLREAL:
		case TYCOMPLEX:
		case TYLOG:
			f = copys( tailor.dfltfmt[((struct varblock *)e)->vtype] );
			break;

		case TYCHAR:
			if(((struct headbits *)((struct varblock *)e)->vtypep)->tag != TCONST)
				{
				execerr("no adjustable character formats", "");
				f = 0;
				}
			else	{
				sprintf(fmt, "c%s", ((struct exprblock *)((struct varblock *)e)->vtypep)->leftp);
				f = copys(fmt);
				}
			break;

		default:
			execerr("cannot do I/O on structures", "");
			f = 0;
			break;
		}
	}

((struct ioitem *)p)->ioexpr = e;
((struct iogroup *)p)->iofmt = f;
return(p);
}



ptr arrsize(p)
ptr p;
{
register ptr b;
ptr f, q;

q = mkint(1);

if(b = ((struct varblock *)p)->vdim)
    for(b = ((struct chain *)b)->datap ; b ; b = ((struct chain *)b)->nextp)
	{
	if(((struct dimblock *)b)->upperb == 0) continue;
	f = cpexpr(((struct dimblock *)b)->upperb);
	if(((struct dimblock *)b)->lowerb)
		f = mknode(TAROP,OPPLUS,f,
			mknode(TAROP,OPMINUS,mkint(1),cpexpr(((struct dimblock *)b)->lowerb)));
	q = simple(RVAL, mknode(TAROP,OPSTAR,q,f));
	}
return(q);
}




repfac(dop)
register struct doblock *dop;
{
int m1, m2, m3;

m3 = 1;
if( isicon(((struct doblock *)dop)->dopar[0],&m1) &&  isicon(((struct doblock *)dop)->dopar[1],&m2) &&
  (((struct doblock *)dop)->dopar[2]==NULL || isicon(((struct doblock *)dop)->dopar[2],&m3)) )
	{
	if(m3 > 0)
		return(1 + (m2-m1)/m3);
	}
else	execerr("nonconstant implied do", "");
return(1);
}



ioop(s)
char *s;
{
if( equals(s, "backspace") )
	return(FBACKSPACE);
if( equals(s, "rewind") )
	return(FREWIND);
if( equals(s, "endfile") )
	return(FENDFILE);
return(0);
}




ptr exioop(p, errcheck)
register struct exprblock *p;
int errcheck;
{
register ptr q, t;

if( (q = ((struct exprblock *)p)->rightp)==NULL || (q = ((struct exprblock *)q)->leftp)==NULL  )
	{
	execerr("bad I/O operation", "");
	return(NULL);
	}
q = simple(LVAL, cpexpr(((struct chain *)q)->datap) );

exlab(0);
putic(ICKEYWORD, ioop(((struct stentry *)((struct varblock *)((struct exprblock *)p)->leftp)->sthead)->namep));

if(errcheck)
	{
	if(tailor.errmode != IOERRFORT77)
		{
		execerr("cannot test value of IOOP without ftn77", "");
		return( errnode() );
		}
	putic(ICOP, OPLPAR);
	prexpr(q);
	putic(ICOP, OPCOMMA);
	putsii(ICCONST, "iostat =");
	prexpr(cpexpr( t = gent(TYINT,PNULL)));
	putic(ICOP, OPRPAR);
	return( t );
	}
else	{
	putic(ICBLANK, 1);
	prexpr(q);
	}
}
