/* Routines to generate code for I/O statements.
   Some corrections and improvements due to David Wasley, U. C. Berkeley
   Compile with -DKOSHER to force exact conformity with the ANSI std.
*/
/*
 * This module supports the ucb fixed libI77. Since it was done
 * on a Vax, some of the naming conventions were different. These were
 * changed to allow compilation on the 11/70 version. wfj 3/26/80
 * <UNTESTED>
 */
/* Modified to handle encode/decode statements.  
 * Other files modified to support this feature:
 *	lex.c	    "encode" & "decode" added to key[]
 *	tokens	    SENCODE & SDECODE added
 *	gram.io     modified in an obvious way.
 * John Sender, 7/23/80.
 */

#ifdef KOSHER
#define IOSRETURN 1  /* to force ANSI std return on iostat= */
#endif

/* TEMPORARY */
#define TYIOINT TYLONG
#define SZIOINT SZLONG

#include "defs"
#include "string_defs"

LOCAL char ioroutine[XL+1];

LOCAL int ioendlab;
LOCAL int ioerrlab;
LOCAL int iostest;
LOCAL int iosreturn;
LOCAL int jumplab;
LOCAL int skiplab;
LOCAL int ioformatted;
LOCAL expptr ioecdc;	/* encode/decode char cnt */	/* E-D */

#define UNFORMATTED 0
#define FORMATTED 1
#define LISTDIRECTED 2

#define V(z)	ioc[z].iocval

#define IOALL 07777

LOCAL struct ioclist
	{
	char *iocname;
	int iotype;
	expptr iocval;
	} ioc[ ] =
	{
		{ "", 0 },
		{ "unit", IOALL },
		{ "fmt", M(IOREAD) | M(IOWRITE) },
		{ "err", IOALL },
#ifdef KOSHER
		{ "end", M(IOREAD) },
#else
		{ "end", M(IOREAD) | M(IOWRITE) },
#endif
		{ "iostat", IOALL },
		{ "rec", M(IOREAD) | M(IOWRITE) },
		{ "recl", M(IOOPEN) | M(IOINQUIRE) },
		{ "file", M(IOOPEN) | M(IOINQUIRE) },
		{ "status", M(IOOPEN) | M(IOCLOSE) },
		{ "access", M(IOOPEN) | M(IOINQUIRE) },
		{ "form", M(IOOPEN) | M(IOINQUIRE) },
		{ "blank", M(IOOPEN) | M(IOINQUIRE) },
		{ "exist", M(IOINQUIRE) },
		{ "opened", M(IOINQUIRE) },
		{ "number", M(IOINQUIRE) },
		{ "named", M(IOINQUIRE) },
		{ "name", M(IOINQUIRE) },
		{ "sequential", M(IOINQUIRE) },
		{ "direct", M(IOINQUIRE) },
		{ "formatted", M(IOINQUIRE) },
		{ "unformatted", M(IOINQUIRE) },
		{ "nextrec", M(IOINQUIRE) }
	} ;

#define NIOS (sizeof(ioc)/sizeof(struct ioclist) - 1)
#define MAXIO	SZFLAG + 10*SZIOINT + 15*SZADDR

#define IOSUNIT 1
#define IOSFMT 2
#define IOSERR 3
#define IOSEND 4
#define IOSIOSTAT 5
#define IOSREC 6
#define IOSRECL 7
#define IOSFILE 8
#define IOSSTATUS 9
#define IOSACCESS 10
#define IOSFORM 11
#define IOSBLANK 12
#define IOSEXISTS 13
#define IOSOPENED 14
#define IOSNUMBER 15
#define IOSNAMED 16
#define IOSNAME 17
#define IOSSEQUENTIAL 18
#define IOSDIRECT 19
#define IOSFORMATTED 20
#define IOSUNFORMATTED 21
#define IOSNEXTREC 22

#define IOSTP V(IOSIOSTAT)
#define	IOSRW (iostmt==IOREAD || iostmt==IOWRITE)


/* offsets in generated structures */

#define SZFLAG SZIOINT

/* offsets for external READ and WRITE statements */

#define XERR 0
#define XUNIT	SZFLAG
#define XEND	SZFLAG + SZIOINT
#define XFMT	2*SZFLAG + SZIOINT
#define XREC	2*SZFLAG + SZIOINT + SZADDR

/* offsets for internal READ and WRITE statements */

#define XIERR	0
#define XIUNIT	SZFLAG
#define XIEND	SZFLAG + SZADDR
#define XIFMT	2*SZFLAG + SZADDR
#define XIRLEN	2*SZFLAG + 2*SZADDR
#define XIRNUM	2*SZFLAG + 2*SZADDR + SZIOINT
#define XIREC	2*SZFLAG + 2*SZADDR + 2*SZIOINT

/* offsets for OPEN statements */

#define XFNAME	SZFLAG + SZIOINT
#define XFNAMELEN	SZFLAG + SZIOINT + SZADDR
#define XSTATUS	SZFLAG + 2*SZIOINT + SZADDR
#define XACCESS	SZFLAG + 2*SZIOINT + 2*SZADDR
#define XFORMATTED	SZFLAG + 2*SZIOINT + 3*SZADDR
#define XRECLEN	SZFLAG + 2*SZIOINT + 4*SZADDR
#define XBLANK	SZFLAG + 3*SZIOINT + 4*SZADDR

/* offset for CLOSE statement */

#define XCLSTATUS	SZFLAG + SZIOINT

/* offsets for INQUIRE statement */

#define XFILE	SZFLAG + SZIOINT
#define XFILELEN	SZFLAG + SZIOINT + SZADDR
#define XEXISTS	SZFLAG + 2*SZIOINT + SZADDR
#define XOPEN	SZFLAG + 2*SZIOINT + 2*SZADDR
#define XNUMBER	SZFLAG + 2*SZIOINT + 3*SZADDR
#define XNAMED	SZFLAG + 2*SZIOINT + 4*SZADDR
#define XNAME	SZFLAG + 2*SZIOINT + 5*SZADDR
#define XNAMELEN	SZFLAG + 2*SZIOINT + 6*SZADDR
#define XQACCESS	SZFLAG + 3*SZIOINT + 6*SZADDR
#define XQACCLEN	SZFLAG + 3*SZIOINT + 7*SZADDR
#define XSEQ	SZFLAG + 4*SZIOINT + 7*SZADDR
#define XSEQLEN	SZFLAG + 4*SZIOINT + 8*SZADDR
#define XDIRECT	SZFLAG + 5*SZIOINT + 8*SZADDR
#define XDIRLEN	SZFLAG + 5*SZIOINT + 9*SZADDR
#define XFORM	SZFLAG + 6*SZIOINT + 9*SZADDR
#define XFORMLEN	SZFLAG + 6*SZIOINT + 10*SZADDR
#define XFMTED	SZFLAG + 7*SZIOINT + 10*SZADDR
#define XFMTEDLEN	SZFLAG + 7*SZIOINT + 11*SZADDR
#define XUNFMT	SZFLAG + 8*SZIOINT + 11*SZADDR
#define XUNFMTLEN	SZFLAG + 8*SZIOINT + 12*SZADDR
#define XQRECL	SZFLAG + 9*SZIOINT + 12*SZADDR
#define XNEXTREC	SZFLAG + 9*SZIOINT + 13*SZADDR
#define XQBLANK	SZFLAG + 9*SZIOINT + 14*SZADDR
#define XQBLANKLEN	SZFLAG + 9*SZIOINT + 15*SZADDR

fmtstmt(lp)
register struct labelblock *lp;
{
if(lp == NULL)
	{
	error("unlabeled format statement" , 0,0,EXECERR);
	return(-1);
	}
if(lp->labtype == LABUNKNOWN)
	{
	lp->labtype = LABFORMAT;
	lp->labelno = newlabel();
	}
else if(lp->labtype != LABFORMAT)
	{
	error("bad format number", 0,0,EXECERR);
	return(-1);
	}
return(lp->labelno);
}



setfmt(lp)
struct labelblock *lp;
{
ftnint n;
char *s, *lexline();

s = lexline(&n);
preven(ALILONG);
prlabel(asmfile, lp->labelno);
putstr(asmfile, s, n);
flline();
}



startioctl()
{
register int i;

ioecdc = NULL;						/* E-D */
inioctl = YES;
nioctl = 0;
ioformatted = UNFORMATTED;
for(i = 1 ; i<=NIOS ; ++i)
	V(i) = NULL;
}



iosetecdc(e)						/* E-D */
expptr e;						/* E-D */
{							/* E-D */
	ioecdc = e;					/* E-D */
}							/* E-D */



endioctl()
{
int i;
expptr p;
struct labelblock *mklabel();

inioctl = NO;
if(ioblkp == NULL)
	ioblkp = autovar( (MAXIO+SZIOINT-1)/SZIOINT , TYIOINT, NULL);

/* set up for error recovery */

ioerrlab = ioendlab = jumplab = 0;
skiplab = iosreturn = NO;

if(p = V(IOSEND))
	if(ISICON(p))
		ioendlab = mklabel(p->const.ci)->labelno;
	else
		error("bad end= clause",0,0,ERR);

if(p = V(IOSERR))
	if(ISICON(p))
		ioerrlab = mklabel(p->const.ci)->labelno;
	else
		error("bad err= clause",0,0,ERR);

if(IOSTP)
	if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->vtype) )
		{
		error("iostat must be an integer variable",0,0,ERR);
		frexpr(IOSTP);
		IOSTP = NULL;
		}
#ifdef IOSRETURN
	else
		iosreturn = YES;

if(iosreturn && IOSRW && !(ioerrlab && ioendlab) )
	{
	jumplab = newlabel();
	iostest = OPEQ;
	if(ioerrlab || ioendlab) skiplab = YES;
	}
else if(ioerrlab && !ioendlab)

#else
if(ioerrlab && !ioendlab)
#endif
	{
	jumplab = ioerrlab;
	iostest = IOSRW ? OPLE : OPEQ;
	}
else if(!ioerrlab && ioendlab)
	{
	jumplab = ioendlab;
	iostest = OPGE;
	}
else if(ioerrlab && ioendlab)
	{
	iostest = OPEQ;
	if(ioerrlab == ioendlab)
		jumplab = ioerrlab;
	else
		{
		if(!IOSTP) IOSTP = mktemp(TYINT, NULL);
		jumplab = newlabel();
		skiplab = YES;
		}
	}
/*else if(IOSTP)  /* the standard requires this return! */
/*	{
/*	iosreturn = YES;
/*	if(iostmt==IOREAD || iostmt==IOWRITE)
/*		{
/*		jumplab = newlabel();
/*		iostest = OPEQ;
/*		}
/*	}
 */


ioset(TYIOINT, XERR, ICON(ioerrlab!=0 || iosreturn) );

switch(iostmt)
	{
	case IOOPEN:
		dofopen();  break;

	case IOCLOSE:
		dofclose();  break;

	case IOINQUIRE:
		dofinquire();  break;

	case IOBACKSPACE:
		dofmove("f_back"); break;

	case IOREWIND:
		dofmove("f_rew");  break;

	case IOENDFILE:
		dofmove("f_end");  break;

	case IOREAD:
	case IOWRITE:
		startrw();  break;

	default:
		error("impossible iostmt %d", iostmt,0,FATAL1);
	}
for(i = 1 ; i<=NIOS ; ++i)
	if(i!=IOSIOSTAT && V(i)!=NULL)
		frexpr(V(i));
}



iocname()
{
register int i;
int found, mask;

found = 0;
mask = M(iostmt);
for(i = 1 ; i <= NIOS ; ++i)
	if(toklen==strlen(ioc[i].iocname) && eqn(toklen, token, ioc[i].iocname))
		if(ioc[i].iotype & mask)
			return(i);
		else	found = i;
if(found)
	error("invalid control %s for statement", ioc[found].iocname,0,ERR1);
else
	error("unknown iocontrol %s", varstr(toklen, token),0,ERR1 );
return(IOSBAD);
}


ioclause(n, p)
register int n;
register expptr p;
{
struct ioclist *iocp;

++nioctl;
if(n == IOSBAD)
	return;
if(n == IOSPOSITIONAL)
	{
	if(nioctl > IOSFMT)
		{
		error("illegal positional iocontrol",0,0,ERR);
		return;
		}
	n = nioctl;
	}

if(p == NULL)
	{
	if(n == IOSUNIT)
		p = (iostmt==IOREAD ? IOSTDIN : IOSTDOUT);
	else if(n != IOSFMT)
		{
		error("illegal * iocontrol",0,0,ERR);
		return;
		}
	}
if(n == IOSFMT)
	ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED);

iocp = & ioc[n];
if(iocp->iocval == NULL)
	{
	if( !ioecdc )					/* E-D */
		if(n!=IOSFMT && ( n!=IOSUNIT || (p!=NULL && p->vtype!=TYCHAR) ) )
			p = fixtype(p);
	iocp->iocval = p;
}
else
	error("iocontrol %s repeated", iocp->iocname,0,ERR1);
}

/* io list item */

doio(list)
chainp list;
{
struct exprblock *call0();
doiolist(list);
ioroutine[0] = 'e';
putiocall( call0(TYINT, ioroutine) );
}





LOCAL doiolist(p0)
chainp p0;
{
chainp p;
register tagptr q;
register expptr qe;
register struct nameblock *qn;
struct addrblock *tp, *mkscalar();
int range;

for (p = p0 ; p ; p = p->nextp)
	{
	q = p->datap;
	if(q->tag == TIMPLDO)
		{
		exdo(range=newlabel(), q->varnp);
		doiolist(q->datalist);
		enddo(range);
		free(q);
		}
	else	{
		if(q->tag==TPRIM && q->argsp==NULL
		    && q->namep->vdim!=NULL)
			{
			vardcl(qn = q->namep);
			if(qn->vdim->nelt)
				putio( fixtype(cpexpr(qn->vdim->nelt)),
					mkscalar(qn) );
			else
				error("attempt to i/o array of unknown size",0,0,ERR);
			}
		else if(q->tag==TPRIM && q->argsp==NULL &&
		    (qe = memversion(q->namep)) )
			putio(ICON(1),qe);
		else if( (qe = fixtype(cpexpr(q)))->tag==TADDR)
			putio(ICON(1), qe);
		else if(qe->vtype != TYERROR)
			{
			if(iostmt == IOWRITE)
				{
				tp = mktemp(qe->vtype, qe->vleng);
				puteq( cpexpr(tp), qe);
				putio(ICON(1), tp);
				}
			else
/*				error("non-left side in READ list",0,0,ERR);
*/
/*! changed error message PLWard 10/80 */
				error("function in READ list",0,0,ERR);
			}
		frexpr(q);
		}
	}
frchain( &p0 );
}





LOCAL putio(nelt, addr)
expptr nelt;
register expptr addr;
{
int type;
register struct exprblock *q;
struct exprblock *call2(), *call3();

type = addr->vtype;
if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) )
	{
	nelt = mkexpr(OPSTAR, ICON(2), nelt);
	type -= (TYCOMPLEX-TYREAL);
	}

/* pass a length with every item.  for noncharacter data, fake one */
if(type != TYCHAR)
	{
	if( ISCONST(addr) )
		addr = putconst(addr);
	addr->vtype = TYCHAR;
	addr->vleng = ICON( typesize[type] );
	}

nelt = fixtype( mkconv(TYLENG,nelt) );
if(ioformatted == LISTDIRECTED)
	q = call3(TYINT, "do_lio", mkconv(TYLONG, ICON(type)), nelt, addr);
else
	q = call2(TYINT, (ioformatted==FORMATTED ? "do_fio" : "do_uio"),
		nelt, addr);
putiocall(q);
}




endio()
{
if(skiplab)
	{
	putlabel(jumplab);
	if(ioendlab) putif( mkexpr(OPGE, cpexpr(IOSTP), ICON(0)), ioendlab);
	if(ioerrlab) putif( mkexpr(OPLE, cpexpr(IOSTP), ICON(0)), ioerrlab);
	}
else if(iosreturn && jumplab)
	putlabel(jumplab);
if(IOSTP)
	frexpr(IOSTP);
}



LOCAL putiocall(q)
register struct exprblock *q;
{
if(IOSTP)
	{
	q->vtype = TYINT;
	q = fixexpr( mkexpr(OPASSIGN, cpexpr(IOSTP), q));
	}

if(jumplab)
	putif( mkexpr(iostest, q, ICON(0) ), jumplab);
else
	putexpr(q);
}


startrw()
{
register expptr p;
register struct nameblock *np;
register struct addrblock *unitp, *nump;
struct constblock *mkaddcon();
int k, fmtoff;
int intfile, sequential;

intfile = NO;
if(p = V(IOSUNIT))
	{
	if( ISINT(p->vtype) )
		ioset(TYIOINT, XUNIT, cpexpr(p) );
	else if( ioecdc || p->vtype == TYCHAR)		/* E-D */
		{
		intfile = YES;
		if(p->tag==TPRIM && p->argsp==NULL &&
		    (np = p->namep)->vdim!=NULL)
			{
			vardcl(np);
			if( ioecdc )			/* E-D */
				nump = ICON(1);		/* E-D */
			else if(np->vdim->nelt)		/* E-D */
				nump = cpexpr(np->vdim->nelt);
			else
				{
				error("attempt to use internal unit array of unknown size",0,0,ERR);
				nump = ICON(1);
				}
			unitp = mkscalar(np);
			}
		else	{
			nump = ICON(1);
			unitp = fixtype(cpexpr(p));
			}
		if( ioecdc )				/* E-D */
			{				/* E-D */
			frexpr( unitp->vleng );		/* E-D */
			unitp->vleng = ioecdc;		/* E-D */
			}				/* E-D */
		ioset(TYIOINT, XIRNUM, nump);
		ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) );
		ioset(TYADDR, XIUNIT, addrof(unitp) );
		}
	}
else
	error("bad unit specifier",0,0,ERR);

sequential = YES;
if(p = V(IOSREC))
	if( ISINT(p->vtype) )
		{
		ioset(TYIOINT, (intfile ? XIREC : XREC), cpexpr(p) );
		sequential = NO;
		}
	else
		error("bad REC= clause",0,0,ERR);

ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(ioendlab!=0 || iosreturn) );

fmtoff = (intfile ? XIFMT : XFMT);

if(p = V(IOSFMT))
	{
	if(p->tag==TPRIM && p->argsp==NULL)
		{
		vardcl(np = p->namep);
		if(np->vdim)
			{
			ioset(TYADDR, fmtoff, addrof(mkscalar(np)) );
			goto endfmt;
			}
		if( ISINT(np->vtype) )
			{
			ioset(TYADDR, fmtoff, p);
			goto endfmt;
			}
		}
	p = V(IOSFMT) = fixtype(p);
	if(p->vtype == TYCHAR)
		ioset(TYADDR, fmtoff, addrof(cpexpr(p)) );
	else if( ISICON(p) )
		{
		if( (k = fmtstmt( mklabel(p->const.ci) )) > 0 )
			ioset(TYADDR, fmtoff, mkaddcon(k) );
		else
			ioformatted = UNFORMATTED;
		}
	else	{
		error("bad format descriptor",0,0,ERR);
		ioformatted = UNFORMATTED;
		}
	}
else
	ioset(TYADDR, fmtoff, ICON(0) );

endfmt:
	if(intfile && ioformatted==UNFORMATTED)
		error("unformatted internal I/O not allowed",0,0,ERR);
	if(!sequential && ioformatted==LISTDIRECTED)
		error("direct list-directed I/O not allowed",0,0,ERR);

ioroutine[0] = 's';
ioroutine[1] = '_';
ioroutine[2] = (iostmt==IOREAD ? 'r' : 'w');
ioroutine[3] = (sequential ? 's' : 'd');
ioroutine[4] = "ufl" [ioformatted];
ioroutine[5] = (intfile ? 'i' : 'e');
ioroutine[6] = '\0';
putiocall( call1(TYINT, ioroutine, cpexpr(ioblkp) ));
}



LOCAL dofopen()
{
register expptr p;

if( (p = V(IOSUNIT)) && ISINT(p->vtype) )
	ioset(TYIOINT, XUNIT, cpexpr(p) );
else
	error("bad unit in open",0,0,ERR);
if( (p = V(IOSFILE)) )
	if(p->vtype == TYCHAR)
		ioset(TYIOINT, XFNAMELEN, cpexpr(p->vleng) );
	else
		error("bad file in open",0,0,ERR);

iosetc(XFNAME, p);

if(p = V(IOSRECL))
	if( ISINT(p->vtype) )
		ioset(TYIOINT, XRECLEN, cpexpr(p) );
	else
		error("bad recl",0,0,ERR);
else
	ioset(TYIOINT, XRECLEN, ICON(0) );

iosetc(XSTATUS, V(IOSSTATUS));
iosetc(XACCESS, V(IOSACCESS));
iosetc(XFORMATTED, V(IOSFORM));
iosetc(XBLANK, V(IOSBLANK));

putiocall( call1(TYINT, "f_open", cpexpr(ioblkp) ));
}


LOCAL dofclose()
{
register expptr p;

if( (p = V(IOSUNIT)) && ISINT(p->vtype) )
	{
	ioset(TYIOINT, XUNIT, cpexpr(p) );
	iosetc(XCLSTATUS, V(IOSSTATUS));
	putiocall( call1(TYINT, "f_clos", cpexpr(ioblkp)) );
	}
else
	error("bad unit in close statement",0,0,ERR);
}


LOCAL dofinquire()
{
register expptr p;
if(p = V(IOSUNIT))
	{
	if( V(IOSFILE) )
		error("inquire by unit or by file, not both",0,0,ERR);
	ioset(TYIOINT, XUNIT, cpexpr(p) );
	}
else if( ! V(IOSFILE) )
	error("must inquire by unit or by file",0,0,ERR);
iosetlc(IOSFILE, XFILE, XFILELEN);
iosetip(IOSEXISTS, XEXISTS);
iosetip(IOSOPENED, XOPEN);
iosetip(IOSNUMBER, XNUMBER);
iosetip(IOSNAMED, XNAMED);
iosetlc(IOSNAME, XNAME, XNAMELEN);
iosetlc(IOSACCESS, XQACCESS, XQACCLEN);
iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN);
iosetlc(IOSDIRECT, XDIRECT, XDIRLEN);
iosetlc(IOSFORM, XFORM, XFORMLEN);
iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN);
iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN);
iosetip(IOSRECL, XQRECL);
iosetip(IOSNEXTREC, XNEXTREC);
iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN);

putiocall( call1(TYINT,  "f_inqu", cpexpr(ioblkp) ));
}



LOCAL dofmove(subname)
char *subname;
{
register expptr p;

if( (p = V(IOSUNIT)) && ISINT(p->vtype) )
	{
	ioset(TYIOINT, XUNIT, cpexpr(p) );
	putiocall( call1(TYINT, subname, cpexpr(ioblkp) ));
	}
else
	error("bad unit in I/O motion statement",0,0,ERR);
}



LOCAL ioset(type, offset, p)
int type, offset;
expptr p;
{
register struct addrblock *q;

q = cpexpr(ioblkp);
q->vtype = type;
q->memoffset = fixtype( mkexpr(OPPLUS, q->memoffset, ICON(offset)) );
puteq(q, p);
}




LOCAL iosetc(offset, p)
int offset;
register expptr p;
{
if(p == NULL)
	ioset(TYADDR, offset, ICON(0) );
else if(p->vtype == TYCHAR)
	ioset(TYADDR, offset, addrof(cpexpr(p) ));
else
	error("non-character control clause",0,0,ERR);
}



LOCAL iosetip(i, offset)
int i, offset;
{
register expptr p;

if(p = V(i))
	if(p->tag==TADDR &&
	    ONEOF(p->vtype, M(TYLONG)|M(TYLOGICAL)) )
		ioset(TYADDR, offset, addrof(cpexpr(p)) );
	else
		error("impossible inquire parameter %s", ioc[i].iocname,0,ERR1);
else
	ioset(TYADDR, offset, ICON(0) );
}



LOCAL iosetlc(i, offp, offl)
int i, offp, offl;
{
register expptr p;
if( (p = V(i)) && p->vtype==TYCHAR)
	ioset(TYIOINT, offl, cpexpr(p->vleng) );
iosetc(offp, p);
}