io.c

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

/****************************************************************
Copyright 1990, 1991, 1993, 1994 by AT&T Bell Laboratories and Bellcore.

Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.

AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness.  In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
this software.
****************************************************************/

/* Routines to generate code for I/O statements.
   Some corrections and improvements due to David Wasley, U. C. Berkeley
*/

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

#include "defs.h"
#include "names.h"
#include "iob.h"

extern int inqmask;

static void dofclose Argdcl((void));
static void dofinquire Argdcl((void));
static void dofmove Argdcl((char*));
static void dofopen Argdcl((void));
static void doiolist Argdcl((chainp));
static void ioset Argdcl((int, int, expptr));
static void ioseta Argdcl((int, Addrp));
static void iosetc Argdcl((int, expptr));
static void iosetip Argdcl((int, int));
static void iosetlc Argdcl((int, int, int));
static void putio Argdcl((expptr, expptr));
static void putiocall Argdcl((expptr));

iob_data *iob_list;
Addrp io_structs[9];

LOCAL char ioroutine[12];

LOCAL long ioendlab;
LOCAL long ioerrlab;
LOCAL int endbit;
LOCAL int errbit;
LOCAL long jumplab;
LOCAL long skiplab;
LOCAL int ioformatted;
LOCAL int statstruct = NO;
LOCAL struct Labelblock *skiplabel;
Addrp ioblkp;

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

#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 },
	{ "end", M(IOREAD) },
	{ "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) },
	{ "nml", M(IOREAD) | M(IOWRITE) }
};

#define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1)

/* #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 IOSNML 23

#define IOSTP V(IOSIOSTAT)


/* 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 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

LOCAL char *cilist_names[] = {
	"cilist",
	"cierr",
	"ciunit",
	"ciend",
	"cifmt",
	"cirec"
	};
LOCAL char *icilist_names[] = {
	"icilist",
	"icierr",
	"iciunit",
	"iciend",
	"icifmt",
	"icirlen",
	"icirnum"
	};
LOCAL char *olist_names[] = {
	"olist",
	"oerr",
	"ounit",
	"ofnm",
	"ofnmlen",
	"osta",
	"oacc",
	"ofm",
	"orl",
	"oblnk"
	};
LOCAL char *cllist_names[] = {
	"cllist",
	"cerr",
	"cunit",
	"csta"
	};
LOCAL char *alist_names[] = {
	"alist",
	"aerr",
	"aunit"
	};
LOCAL char *inlist_names[] = {
	"inlist",
	"inerr",
	"inunit",
	"infile",
	"infilen",
	"inex",
	"inopen",
	"innum",
	"innamed",
	"inname",
	"innamlen",
	"inacc",
	"inacclen",
	"inseq",
	"inseqlen",
	"indir",
	"indirlen",
	"infmt",
	"infmtlen",
	"inform",
	"informlen",
	"inunf",
	"inunflen",
	"inrecl",
	"innrec",
	"inblank",
	"inblanklen"
	};

LOCAL char **io_fields;

#define zork(n,t) n, sizeof(n)/sizeof(char *) - 1, t

LOCAL io_setup io_stuff[] = {
	zork(cilist_names, TYCILIST),	/* external read/write */
	zork(inlist_names, TYINLIST),	/* inquire */
	zork(olist_names,  TYOLIST),	/* open */
	zork(cllist_names, TYCLLIST),	/* close */
	zork(alist_names,  TYALIST),	/* rewind */
	zork(alist_names,  TYALIST),	/* backspace */
	zork(alist_names,  TYALIST),	/* endfile */
	zork(icilist_names,TYICILIST),	/* internal read */
	zork(icilist_names,TYICILIST)	/* internal write */
	};

#undef zork

 int
#ifdef KR_headers
fmtstmt(lp)
	register struct Labelblock *lp;
#else
fmtstmt(register struct Labelblock *lp)
#endif
{
	if(lp == NULL)
	{
		execerr("unlabeled format statement" , CNULL);
		return(-1);
	}
	if(lp->labtype == LABUNKNOWN)
	{
		lp->labtype = LABFORMAT;
		lp->labelno = newlabel();
	}
	else if(lp->labtype != LABFORMAT)
	{
		execerr("bad format number", CNULL);
		return(-1);
	}
	return(lp->labelno);
}


 void
#ifdef KR_headers
setfmt(lp)
	struct Labelblock *lp;
#else
setfmt(struct Labelblock *lp)
#endif
{
	int n;
	char *s0;
	register char *s, *se, *t;
	register k;

	s0 = s = lexline(&n);
	se = t = s + n;

	/* warn of trivial errors, e.g. "  11 CONTINUE" (one too few spaces) */
	/* following FORMAT... */

	if (n <= 0)
		warn("No (...) after FORMAT");
	else if (*s != '(')
		warni("%c rather than ( after FORMAT", *s);
	else if (se[-1] != ')') {
		*se = 0;
		while(--t > s && *t != ')') ;
		if (t <= s)
			warn("No ) at end of FORMAT statement");
		else if (se - t > 30)
			warn1("Extraneous text at end of FORMAT: ...%s", se-12);
		else
			warn1("Extraneous text at end of FORMAT: %s", t+1);
		t = se;
		}

	/* fix MYQUOTES (\002's) and \\'s */

	while(s < se)
		switch(*s++) {
			case 2:
				if (*s == 2) {
					t -= 2;
					++s;
					}
				else
					t += 3;
				break;
			case '"':
			case '\\':
				t++; break;
			}
	s = s0;
	if (lp) {
		lp->fmtstring = t = mem((int)(t - s + 1), 0);
		while(s < se)
			switch(k = *s++) {
				case 2:
					if (*s == 2)
						s++;
					else {
						t[0] = '\\';
						t[1] = '0';
						t[2] = '0';
						t[3] = '2';
						t += 4;
						}
					break;
				case '"':
				case '\\':
					*t++ = '\\';
					/* no break */
				default:
					*t++ = k;
				}
		*t = 0;
		}
	flline();
}


 void
#ifdef KR_headers
startioctl()
#else
startioctl()
#endif
{
	register int i;

	inioctl = YES;
	nioctl = 0;
	ioformatted = UNFORMATTED;
	for(i = 1 ; i<=NIOS ; ++i)
		V(i) = NULL;
}

 static long
newiolabel(Void) {
	long rv;
	rv = ++lastiolabno;
	skiplabel = mklabel(rv);
	skiplabel->labdefined = 1;
	return rv;
	}

 void
endioctl(Void)
{
	int i;
	expptr p;
	struct io_setup *ios;

	inioctl = NO;

	/* set up for error recovery */

	ioerrlab = ioendlab = skiplab = jumplab = 0;

	if(p = V(IOSEND))
		if(ISICON(p))
			execlab(ioendlab = p->constblock.Const.ci);
		else
			err("bad end= clause");

	if(p = V(IOSERR))
		if(ISICON(p))
			execlab(ioerrlab = p->constblock.Const.ci);
		else
			err("bad err= clause");

	if(IOSTP)
		if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) )
		{
			err("iostat must be an integer variable");
			frexpr(IOSTP);
			IOSTP = NULL;
		}

	if(iostmt == IOREAD)
	{
		if(IOSTP)
		{
			if(ioerrlab && ioendlab && ioerrlab==ioendlab)
				jumplab = ioerrlab;
			else
				skiplab = jumplab = newiolabel();
		}
		else	{
			if(ioerrlab && ioendlab && ioerrlab!=ioendlab)
			{
				IOSTP = (expptr) mktmp(TYINT, ENULL);
				skiplab = jumplab = newiolabel();
			}
			else
				jumplab = (ioerrlab ? ioerrlab : ioendlab);
		}
	}
	else if(iostmt == IOWRITE)
	{
		if(IOSTP && !ioerrlab)
			skiplab = jumplab = newiolabel();
		else
			jumplab = ioerrlab;
	}
	else
		jumplab = ioerrlab;

	endbit = IOSTP!=NULL || ioendlab!=0;	/* for use in startrw() */
	errbit = IOSTP!=NULL || ioerrlab!=0;
	if (jumplab && !IOSTP)
		IOSTP = (expptr) mktmp(TYINT, ENULL);

	if(iostmt!=IOREAD && iostmt!=IOWRITE)
	{
		ios = io_stuff + iostmt;
		io_fields = ios->fields;
		ioblkp = io_structs[iostmt];
		if(ioblkp == NULL)
			io_structs[iostmt] = ioblkp =
				autovar(1, ios->type, ENULL, "");
		ioset(TYIOINT, XERR, ICON(errbit));
	}

	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:
		fatali("impossible iostmt %d", iostmt);
	}
	for(i = 1 ; i<=NIOS ; ++i)
		if(i!=IOSIOSTAT && V(i)!=NULL)
			frexpr(V(i));
}


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

	found = 0;
	mask = M(iostmt);
	for(i = 1 ; i <= NIOS ; ++i)
		if(!strcmp(ioc[i].iocname, token))
			if(ioc[i].iotype & mask)
				return(i);
			else {
				found = i;
				break;
				}
	if(found) {
		if (iostmt == IOOPEN && !strcmp(ioc[i].iocname, "name")) {
			NOEXT("open with \"name=\" treated as \"file=\"");
			for(i = 1; strcmp(ioc[i].iocname, "file"); i++);
			return i;
			}
		errstr("invalid control %s for statement", ioc[found].iocname);
		}
	else
		errstr("unknown iocontrol %s", token);
	return(IOSBAD);
}


 void
#ifdef KR_headers
ioclause(n, p)
	register int n;
	register expptr p;
#else
ioclause(register int n, register expptr p)
#endif
{
	struct Ioclist *iocp;

	++nioctl;
	if(n == IOSBAD)
		return;
	if(n == IOSPOSITIONAL)
		{
		n = nioctl;
		if (n == IOSFMT) {
			if (iostmt == IOOPEN) {
				n = IOSFILE;
				NOEXT("file= specifier omitted from open");
				}
			else if (iostmt < IOREAD)
				goto illegal;
			}
		else if(n > IOSFMT)
			{
 illegal:
			err("illegal positional iocontrol");
			return;
			}
		}
	else if (n == IOSNML)
		n = IOSFMT;

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

	iocp = & ioc[n];
	if(iocp->iocval == NULL)
	{
		if(n!=IOSFMT && ( n!=IOSUNIT || (p && p->headblock.vtype!=TYCHAR) ) )
			p = fixtype(p);
		else if (p && p->tag == TPRIM
			   && p->primblock.namep->vclass == CLUNKNOWN) {
			/* kludge made necessary by attempt to infer types
			 * for untyped external parameters: given an error
			 * in calling sequences, an integer argument might
			 * tentatively be assumed TYCHAR; this would otherwise
			 * be corrected too late in startrw after startrw
			 * had decided this to be an internal file.
			 */
			vardcl(p->primblock.namep);
			p->primblock.vtype = p->primblock.namep->vtype;
			}
		iocp->iocval = p;
	}
	else
		errstr("iocontrol %s repeated", iocp->iocname);
}

/* io list item */

 void
#ifdef KR_headers
doio(list)
	chainp list;
#else
doio(chainp list)
#endif
{
	if(ioformatted == NAMEDIRECTED)
	{
		if(list)
			err("no I/O list allowed in NAMELIST read/write");
	}
	else
	{
		doiolist(list);
		ioroutine[0] = 'e';
		if (skiplab)
			jumplab = 0;
		putiocall( call0(TYINT, ioroutine) );
	}
}





 LOCAL void
#ifdef KR_headers
doiolist(p0)
	chainp p0;
#else
doiolist(chainp p0)
#endif
{
	chainp p;
	register tagptr q;
	register expptr qe;
	register Namep qn;
	Addrp tp;
	int range;
	extern char *ohalign;

	for (p = p0 ; p ; p = p->nextp)
	{
		q = (tagptr)p->datap;
		if(q->tag == TIMPLDO)
		{
			exdo(range=newlabel(), (Namep)0,
				q->impldoblock.impdospec);
			doiolist(q->impldoblock.datalist);
			enddo(range);
			free( (charptr) q);
		}
		else	{
			if(q->tag==TPRIM && q->primblock.argsp==NULL
			    && q->primblock.namep->vdim!=NULL)
			{
				vardcl(qn = q->primblock.namep);
				if(qn->vdim->nelt) {
					putio( fixtype(cpexpr(qn->vdim->nelt)),
					    (expptr)mkscalar(qn) );
					qn->vlastdim = 0;
					}
				else
					err("attempt to i/o array of unknown size");
			}
			else if(q->tag==TPRIM && q->primblock.argsp==NULL &&
			    (qe = (expptr) memversion(q->primblock.namep)) )
				putio(ICON(1),qe);
			else if (ISCONST(q) && q->constblock.vtype == TYCHAR) {
				halign = 0;
				putio(ICON(1), qe = fixtype(cpexpr(q)));
				halign = ohalign;
				}
			else if(((qe = fixtype(cpexpr(q)))->tag==TADDR &&
			    (qe->addrblock.uname_tag != UNAM_CONST ||
			    !ISCOMPLEX(qe -> addrblock.vtype))) ||
			    (qe -> tag == TCONST && !ISCOMPLEX(qe ->
			    headblock.vtype))) {
				if (qe -> tag == TCONST)
					qe = (expptr) putconst((Constp)qe);
				putio(ICON(1), qe);
			}
			else if(qe->headblock.vtype != TYERROR)
			{
				if(iostmt == IOWRITE)
				{
					expptr qvl;
					qvl = NULL;
					if( ISCHAR(qe) )
					{
						qvl = (expptr)
						    cpexpr(qe->headblock.vleng);
						tp = mktmp(qe->headblock.vtype,
						    ICON(lencat(qe)));
					}
					else
						tp = mktmp(qe->headblock.vtype,
						    qe->headblock.vleng);
					puteq( cpexpr((expptr)tp), qe);
					if(qvl)	/* put right length on block */
					{
						frexpr(tp->vleng);
						tp->vleng = qvl;
					}
					putio(ICON(1), (expptr)tp);
				}
				else
					err("non-left side in READ list");
			}