io.c

把fortran语言编的程序转为c语言编的程序, 运行环境linux

			frexpr(q);
		}
	}
	frchain( &p0 );
}

 int iocalladdr = TYADDR;	/* for fixing TYADDR in saveargtypes */
 int typeconv[TYERROR+1] = {
#ifdef TYQUAD
		0, 1, 11, 2, 3, 14, 4, 5, 6, 7, 12, 13, 8, 9, 10, 15
#else
		0, 1, 11, 2, 3,     4, 5, 6, 7, 12, 13, 8, 9, 10, 14
#endif
		};

 LOCAL void
#ifdef KR_headers
putio(nelt, addr)
	expptr nelt;
	register expptr addr;
#else
putio(expptr nelt, register expptr addr)
#endif
{
	int type;
	register expptr q;
	register Addrp c = 0;

	type = addr->headblock.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 = (expptr) putconst((Constp)addr);
		c = ALLOC(Addrblock);
		c->tag = TADDR;
		c->vtype = TYLENG;
		c->vstg = STGAUTO;
		c->ntempelt = 1;
		c->isarray = 1;
		c->memoffset = ICON(0);
		c->uname_tag = UNAM_IDENT;
		c->charleng = 1;
		sprintf(c->user.ident, "(ftnlen)sizeof(%s)", typename[type]);
		addr = mkexpr(OPCHARCAST, addr, ENULL);
		}

	nelt = fixtype( mkconv(tyioint,nelt) );
	if(ioformatted == LISTDIRECTED) {
		expptr mc = mkconv(tyioint, ICON(typeconv[type]));
		q = c	? call4(TYINT, "do_lio", mc, nelt, addr, (expptr)c)
			: call3(TYINT, "do_lio", mc, nelt, addr);
		}
	else {
		char *s = ioformatted==FORMATTED ? "do_fio" : "do_uio";
		q = c	? call3(TYINT, s, nelt, addr, (expptr)c)
			: call2(TYINT, s, nelt, addr);
		}
	iocalladdr = TYCHAR;
	putiocall(q);
	iocalladdr = TYADDR;
}



 void
endio(Void)
{
	if(skiplab)
	{
		if (ioformatted != NAMEDIRECTED)
			p1_label((long)(skiplabel - labeltab));
		if(ioendlab) {
			exif( mkexpr(OPLT, cpexpr(IOSTP), ICON(0)));
			exgoto(execlab(ioendlab));
			exendif();
			}
		if(ioerrlab) {
			exif( mkexpr(iostmt==IOREAD||iostmt==IOWRITE
					? OPGT : OPNE,
				cpexpr(IOSTP), ICON(0)));
			exgoto(execlab(ioerrlab));
			exendif();
			}
	}

	if(IOSTP)
		frexpr(IOSTP);
}



 LOCAL void
#ifdef KR_headers
putiocall(q)
	register expptr q;
#else
putiocall(register expptr q)
#endif
{
	int tyintsave;

	tyintsave = tyint;
	tyint = tyioint;	/* for -I2 and -i2 */

	if(IOSTP)
	{
		q->headblock.vtype = TYINT;
		q = fixexpr((Exprp)mkexpr(OPASSIGN, cpexpr(IOSTP), q));
	}
	putexpr(q);
	if(jumplab) {
		exif(mkexpr(OPNE, cpexpr(IOSTP), ICON(0)));
		exgoto(execlab(jumplab));
		exendif();
		}
	tyint = tyintsave;
}

 void
#ifdef KR_headers
fmtname(np, q)
	Namep np;
	register Addrp q;
#else
fmtname(Namep np, register Addrp q)
#endif
{
	register int k;
	register char *s, *t;
	extern chainp assigned_fmts;

	if (!np->vfmt_asg) {
		np->vfmt_asg = 1;
		assigned_fmts = mkchain((char *)np, assigned_fmts);
		}
	k = strlen(s = np->fvarname);
	if (k < IDENT_LEN - 4) {
		q->uname_tag = UNAM_IDENT;
		t = q->user.ident;
		}
	else {
		q->uname_tag = UNAM_CHARP;
		q->user.Charp = t = mem(k + 5,0);
		}
	sprintf(t, "%s_fmt", s);
	}

 LOCAL Addrp
#ifdef KR_headers
asg_addr(p)
	union Expression *p;
#else
asg_addr(union Expression *p)
#endif
{
	register Addrp q;

	if (p->tag != TPRIM)
		badtag("asg_addr", p->tag);
	q = ALLOC(Addrblock);
	q->tag = TADDR;
	q->vtype = TYCHAR;
	q->vstg = STGAUTO;
	q->ntempelt = 1;
	q->isarray = 0;
	q->memoffset = ICON(0);
	fmtname(p->primblock.namep, q);
	return q;
	}

 void
startrw(Void)
{
	register expptr p;
	register Namep np;
	register Addrp unitp, fmtp, recp;
	register expptr nump;
	int iostmt1;
	flag intfile, sequential, ok, varfmt;
	struct io_setup *ios;

	/* First look at all the parameters and determine what is to be done */

	ok = YES;
	statstruct = YES;

	intfile = NO;
	if(p = V(IOSUNIT))
	{
		if( ISINT(p->headblock.vtype) ) {
 int_unit:
			unitp = (Addrp) cpexpr(p);
			}
		else if(p->headblock.vtype == TYCHAR)
		{
			if (nioctl == 1 && iostmt == IOREAD) {
				/* kludge to recognize READ(format expr) */
				V(IOSFMT) = p;
				V(IOSUNIT) = p = (expptr) IOSTDIN;
				ioformatted = FORMATTED;
				goto int_unit;
				}
			intfile = YES;
			if(p->tag==TPRIM && p->primblock.argsp==NULL &&
			    (np = p->primblock.namep)->vdim!=NULL)
			{
				vardcl(np);
				if(nump = np->vdim->nelt)
				{
					nump = fixtype(cpexpr(nump));
					if( ! ISCONST(nump) ) {
						statstruct = NO;
						np->vlastdim = 0;
						}
				}
				else
				{
					err("attempt to use internal unit array of unknown size");
					ok = NO;
					nump = ICON(1);
				}
				unitp = mkscalar(np);
			}
			else	{
				nump = ICON(1);
				unitp = (Addrp /*pjw */) fixtype(cpexpr(p));
			}
			if(! isstatic((expptr)unitp) )
				statstruct = NO;
		}
		else {
			err("unit specifier not of type integer or character");
			ok = NO;
			}
	}
	else
	{
		err("bad unit specifier");
		ok = NO;
	}

	sequential = YES;
	if(p = V(IOSREC))
		if( ISINT(p->headblock.vtype) )
		{
			recp = (Addrp) cpexpr(p);
			sequential = NO;
		}
		else	{
			err("bad REC= clause");
			ok = NO;
		}
	else
		recp = NULL;


	varfmt = YES;
	fmtp = NULL;
	if(p = V(IOSFMT))
	{
		if(p->tag==TPRIM && p->primblock.argsp==NULL)
		{
			np = p->primblock.namep;
			if(np->vclass == CLNAMELIST)
			{
				ioformatted = NAMEDIRECTED;
				fmtp = (Addrp) fixtype(p);
				V(IOSFMT) = (expptr)fmtp;
				if (skiplab)
					jumplab = 0;
				goto endfmt;
			}
			vardcl(np);
			if(np->vdim)
			{
				if( ! ONEOF(np->vstg, MSKSTATIC) )
					statstruct = NO;
				fmtp = mkscalar(np);
				goto endfmt;
			}
			if( ISINT(np->vtype) )	/* ASSIGNed label */
			{
				statstruct = NO;
				varfmt = YES;
				fmtp = asg_addr(p);
				goto endfmt;
			}
		}
		p = V(IOSFMT) = fixtype(p);
		if(p->headblock.vtype == TYCHAR
			/* Since we allow write(6,n)		*/
			/* we may as well allow write(6,n(2))	*/
		|| p->tag == TADDR && ISINT(p->addrblock.vtype))
		{
			if( ! isstatic(p) )
				statstruct = NO;
			fmtp = (Addrp) cpexpr(p);
		}
		else if( ISICON(p) )
		{
			struct Labelblock *lp;
			lp = mklabel(p->constblock.Const.ci);
			if (fmtstmt(lp) > 0)
			{
				fmtp = (Addrp)mkaddcon(lp->stateno);
				/* lp->stateno for names fmt_nnn */
				lp->fmtlabused = 1;
				varfmt = NO;
			}
			else
				ioformatted = UNFORMATTED;
		}
		else	{
			err("bad format descriptor");
			ioformatted = UNFORMATTED;
			ok = NO;
		}
	}
	else
		fmtp = NULL;

endfmt:
	if(intfile) {
		if (ioformatted==UNFORMATTED) {
			err("unformatted internal I/O not allowed");
			ok = NO;
			}
		if (recp) {
			err("direct internal I/O not allowed");
			ok = NO;
			}
		}
	if(!sequential && ioformatted==LISTDIRECTED)
	{
		err("direct list-directed I/O not allowed");
		ok = NO;
	}
	if(!sequential && ioformatted==NAMEDIRECTED)
	{
		err("direct namelist I/O not allowed");
		ok = NO;
	}

	if( ! ok ) {
		statstruct = NO;
		return;
		}

	/*
   Now put out the I/O structure, statically if all the clauses
   are constants, dynamically otherwise
*/

	if (intfile) {
		ios = io_stuff + iostmt;
		iostmt1 = IOREAD;
		}
	else {
		ios = io_stuff;
		iostmt1 = 0;
		}
	io_fields = ios->fields;
	if(statstruct)
	{
		ioblkp = ALLOC(Addrblock);
		ioblkp->tag = TADDR;
		ioblkp->vtype = ios->type;
		ioblkp->vclass = CLVAR;
		ioblkp->vstg = STGINIT;
		ioblkp->memno = ++lastvarno;
		ioblkp->memoffset = ICON(0);
		ioblkp -> uname_tag = UNAM_IDENT;
		new_iob_data(ios,
			temp_name("io_", lastvarno, ioblkp->user.ident));			}
	else if(!(ioblkp = io_structs[iostmt1]))
		io_structs[iostmt1] = ioblkp =
			autovar(1, ios->type, ENULL, "");

	ioset(TYIOINT, XERR, ICON(errbit));
	if(iostmt == IOREAD)
		ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) );

	if(intfile)
	{
		ioset(TYIOINT, XIRNUM, nump);
		ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) );
		ioseta(XIUNIT, unitp);
	}
	else
		ioset(TYIOINT, XUNIT, (expptr) unitp);

	if(recp)
		ioset(TYIOINT, /* intfile ? XIREC : */ XREC, (expptr) recp);

	if(varfmt)
		ioseta( intfile ? XIFMT : XFMT , fmtp);
	else
		ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp);

	ioroutine[0] = 's';
	ioroutine[1] = '_';
	ioroutine[2] = iostmt==IOREAD ? 'r' : 'w';
	ioroutine[3] = "ds"[sequential];
	ioroutine[4] = "ufln"[ioformatted];
	ioroutine[5] = "ei"[intfile];
	ioroutine[6] = '\0';

	putiocall( call1(TYINT, ioroutine, cpexpr((expptr)ioblkp) ));

	if(statstruct)
	{
		frexpr((expptr)ioblkp);
		statstruct = NO;
		ioblkp = 0;	/* unnecessary */
	}
}



 LOCAL void
dofopen(Void)
{
	register expptr p;

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

	iosetc(XFNAME, p);

	if(p = V(IOSRECL))
		if( ISINT(p->headblock.vtype) )
			ioset(TYIOINT, XRECLEN, cpexpr(p) );
		else
			err("bad recl");
	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((expptr)ioblkp) ));
}


 LOCAL void
dofclose(Void)
{
	register expptr p;

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


 LOCAL void
dofinquire(Void)
{
	register expptr p;
	if(p = V(IOSUNIT))
	{
		if( V(IOSFILE) )
			err("inquire by unit or by file, not both");
		ioset(TYIOINT, XUNIT, cpexpr(p) );
	}
	else if( ! V(IOSFILE) )
		err("must inquire by unit or by file");
	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((expptr)ioblkp) ));
}



 LOCAL void
#ifdef KR_headers
dofmove(subname)
	char *subname;
#else
dofmove(char *subname)
#endif
{
	register expptr p;

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

static int ioset_assign = OPASSIGN;

 LOCAL void
#ifdef KR_headers
ioset(type, offset, p)
	int type;
	int offset;
	register expptr p;
#else
ioset(int type, int offset, register expptr p)
#endif
{
	offset /= SZLONG;
	if(statstruct && ISCONST(p)) {
		register char *s;
		switch(type) {
			case TYADDR:	/* stmt label */
				s = "fmt_";
				break;
			case TYIOINT:
				s = "";
				break;
			default:
				badtype("ioset", type);
			}
		iob_list->fields[offset] =
			string_num(s, p->constblock.Const.ci);
		frexpr(p);
		}
	else {
		register Addrp q;

		q = ALLOC(Addrblock);
		q->tag = TADDR;
		q->vtype = type;
		q->vstg = STGAUTO;
		q->ntempelt = 1;
		q->isarray = 0;
		q->memoffset = ICON(0);
		q->uname_tag = UNAM_IDENT;
		sprintf(q->user.ident, "%s.%s",
			statstruct ? iob_list->name : ioblkp->user.ident,
			io_fields[offset + 1]);
		if (type == TYADDR && p->tag == TCONST
				   && p->constblock.vtype == TYADDR) {
			/* kludge */
			register Addrp p1;
			p1 = ALLOC(Addrblock);
			p1->tag = TADDR;
			p1->vtype = type;
			p1->vstg = STGAUTO;	/* wrong, but who cares? */
			p1->ntempelt = 1;
			p1->isarray = 0;
			p1->memoffset = ICON(0);
			p1->uname_tag = UNAM_IDENT;
			sprintf(p1->user.ident, "fmt_%ld",
				p->constblock.Const.ci);
			frexpr(p);
			p = (expptr)p1;
			}
		if (type == TYADDR && p->headblock.vtype == TYCHAR)
			q->vtype = TYCHAR;
		putexpr(mkexpr(ioset_assign, (expptr)q, p));
		}
}




 LOCAL void
#ifdef KR_headers
iosetc(offset, p)
	int offset;
	register expptr p;
#else
iosetc(int offset, register expptr p)
#endif
{
	if(p == NULL)
		ioset(TYADDR, offset, ICON(0) );
	else if(p->headblock.vtype == TYCHAR) {
		p = putx(fixtype((expptr)putchop(cpexpr(p))));
		ioset(TYADDR, offset, addrof(p));
		}
	else
		err("non-character control clause");
}



 LOCAL void
#ifdef KR_headers
ioseta(offset, p)
	int offset;
	register Addrp p;
#else
ioseta(int offset, register Addrp p)
#endif
{
	char *s, *s1;
	static char who[] = "ioseta";
	expptr e, mo;
	Namep np;
	ftnint ci;
	int k;
	char buf[24], buf1[24];
	Extsym *comm;
	extern int usedefsforcommon;

	if(statstruct)
	{
		if (!p)
			return;
		if (p->tag != TADDR)
			badtag(who, p->tag);
		offset /= SZLONG;
		switch(p->uname_tag) {
		    case UNAM_NAME:
			mo = p->memoffset;
			if (mo->tag != TCONST)
				badtag("ioseta/memoffset", mo->tag);
			np = p->user.name;
			np->visused = 1;
			ci = mo->constblock.Const.ci - np->voffset;
			if (np->vstg == STGCOMMON
			&& !np->vcommequiv
			&& !usedefsforcommon) {
				comm = &extsymtab[np->vardesc.varno];
				sprintf(buf, "%d.", comm->curno);
				k = strlen(buf) + strlen(comm->cextname)
					+ strlen(np->cvarname);
				if (ci) {
					sprintf(buf1, "+%ld", ci);
					k += strlen(buf1);
					}
				else
					buf1[0] = 0;
				s = mem(k + 1, 0);
				sprintf(s, "%s%s%s%s", comm->cextname, buf,
					np->cvarname, buf1);
				}
			else if (ci) {
				sprintf(buf,"%ld", ci);
				s1 = p->user.name->cvarname;
				k = strlen(buf) + strlen(s1);
				sprintf(s = mem(k+2,0), "%s+%s", s1, buf);
				}
			else
				s = cpstring(np->cvarname);
			break;
		    case UNAM_CONST:
			s = tostring(p->user.Const.ccp1.ccp0,
				(int)p->vleng->constblock.Const.ci);
			break;
		    default:
			badthing("uname_tag", who, p->uname_tag);
		    }
		/* kludge for Hollerith */
		if (p->vtype != TYCHAR) {
			s1 = mem(strlen(s)+10,0);
			sprintf(s1, "(char *)%s%s", p->isarray ? "" : "&", s);
			s = s1;
			}
		iob_list->fields[offset] = s;
	}
	else {
		if (!p)
			e = ICON(0);
		else if (p->vtype != TYCHAR) {
			NOEXT("non-character variable as format or internal unit");
			e = mkexpr(OPCHARCAST, (expptr)p, ENULL);
			}
		else
			e = addrof((expptr)p);
		ioset(TYADDR, offset, e);
		}
}




 LOCAL void
#ifdef KR_headers
iosetip(i, offset)
	int i;
	int offset;
#else
iosetip(int i, int offset)
#endif
{
	register expptr p;

	if(p = V(i))
		if(p->tag==TADDR &&
		    ONEOF(p->addrblock.vtype, inqmask) ) {
			ioset_assign = OPASSIGNI;
			ioset(TYADDR, offset, addrof(cpexpr(p)) );
			ioset_assign = OPASSIGN;
			}
		else
			errstr("impossible inquire parameter %s", ioc[i].iocname);
	else
		ioset(TYADDR, offset, ICON(0) );
}



 LOCAL void
#ifdef KR_headers
iosetlc(i, offp, offl)
	int i;
	int offp;
	int offl;
#else
iosetlc(int i, int offp, int offl)
#endif
{
	register expptr p;
	if( (p = V(i)) && p->headblock.vtype==TYCHAR)
		ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) );
	iosetc(offp, p);
}