# to unbundle, sh this file (in an empty directory)
echo Notice 1>&2
sed >Notice <<'//GO.SYSIN DD Notice' 's/^-//'
-/****************************************************************
-Copyright 1990, 1991, 1992 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.
-****************************************************************/
-
//GO.SYSIN DD Notice
echo README 1>&2
sed >README <<'//GO.SYSIN DD README' 's/^-//'
-Type "make" to check the validity of the f2c source and compile f2c.
-
-If (in accordance with what follows) you need to modify the makefile
-or any of the source files, first issue a "make xsum.out" to check
-the validity of the f2c source, then make your changes, then type
-"make f2c".
-
-The file usignal.h is for the benefit of strictly ANSI include files
-on a UNIX system -- the ANSI signal.h does not define SIGHUP or SIGQUIT.
-You may need to modify usignal.h if you are not running f2c on a UNIX
-system.
-
-Should you get the message "xsum0.out xsum1.out differ", see what lines
-are different (`diff xsum0.out xsum1.out`) and ask netlib to send you
-the files in question "from f2c/src".  For example, if exec.c and
-expr.c have incorrect check sums, you would send netlib the message
-	send exec.c expr.c from f2c/src
-
-On some systems, the malloc and free in malloc.c let f2c run faster
-than do the standard malloc and free.  Other systems cannot tolerate
-redefinition of malloc and free.  If yours is such a system, you may
-either modify the makefile appropriately, or simply execute
-	cc -c -DCRAY malloc.c
-before typing "make".  Still other systems have a -lmalloc that
-provides performance competitive with that from malloc.c; you may
-wish to compare the two on your system.
-
-On some BSD systems, you may need to create a file named "string.h"
-whose single line is
-#include <strings.h>
-you may need to add " -Dstrchr=index" to the "CFLAGS =" assignment
-in the makefile, and you may need to add " memset.o" to the "OBJECTS ="
-assignment in the makefile -- see the comments in memset.c .
-
-For non-UNIX systems, you may need to change some things in sysdep.c,
-such as the choice of intermediate file names.
-
-On some systems, you may need to modify parts of sysdep.h (which is
-included by defs.h).  In particular, for Sun 4.1 systems and perhaps
-some others, you need to comment out the typedef of size_t.  For some
-systems (e.g., IRIX 4.0.1 and AIX) it is better to add
-#define ANSI_Libraries
-to the beginning of sysdep.h (or to supply -DANSI_Libraries in the
-makefile).
-
-Alas, some systems #define __STDC__ but do not provide a true standard
-(ANSI or ISO) C environment, e.g. do not provide stdlib.h .  If yours
-is such a system, then (a) you should complain loudly to your vendor
-about __STDC__ being erroneously defined, and (b) you should insert
-#undef __STDC__
-at the beginning of sysdep.h .  You may need to make other adjustments.
-
-For some non-ANSI versions of stdio, you must change the values given
-to binread and binwrite in sysdep.c from "rb" and "wb" to "r" and "w".
-You may need to make this change if you run f2c and get an error
-message of the form
-	Compiler error ... cannot open intermediate file ...
-
-On many systems, it is best to combine libF77 and libI77 into a single
-library, say libf2c, as suggested in "readme from f2c".  If you do this,
-then you should adjust the definition of link_msg in sysdep.c
-appropriately (e.g., replacing "-lF77 -lI77" by "-lf2c").
-
-Some older C compilers object to
-	typedef void (*foo)();
-or to
-	typedef void zap;
-	zap (*foo)();
-If yours is such a compiler, change the definition of VOID in
-f2c.h from void to int.
-
-Please send bug reports to dmg@research.att.com .  The old index file
-(now called "readme" due to unfortunate changes in netlib conventions:
-"send readme from f2c") will report recent changes in the recent-change
-log at its end; all changes will be shown in the "changes" file
-("send changes from f2c").  To keep current source, you will need to
-request xsum0.out and version.c, in addition to the changed source
-files.
//GO.SYSIN DD README
echo cds.c 1>&2
sed >cds.c <<'//GO.SYSIN DD cds.c' 's/^-//'
-/****************************************************************
-Copyright 1990 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.
-****************************************************************/
-
-/* Put strings representing decimal floating-point numbers
- * into canonical form: always have a decimal point or
- * exponent field; if using an exponent field, have the
- * number before it start with a digit and decimal point
- * (if the number has more than one digit); only have an
- * exponent field if it saves space.
- *
- * Arrange that the return value, rv, satisfies rv[0] == '-' || rv[-1] == '-' .
- */
-
-#include "sysdep.h"
-
- char *
-cds(s, z0)
- char *s, *z0;
-{
-	int ea, esign, et, i, k, nd = 0, sign = 0, tz;
-	char c, *z;
-	char ebuf[24];
-	long ex = 0;
-	static char etype[Table_size], *db;
-	static int dblen = 64;
-
-	if (!db) {
-		etype['E'] = 1;
-		etype['e'] = 1;
-		etype['D'] = 1;
-		etype['d'] = 1;
-		etype['+'] = 2;
-		etype['-'] = 3;
-		db = Alloc(dblen);
-		}
-
-	while((c = *s++) == '0');
-	if (c == '-')
-		{ sign = 1; c = *s++; }
-	else if (c == '+')
-		c = *s++;
-	k = strlen(s) + 2;
-	if (k >= dblen) {
-		do dblen <<= 1;
-			while(k >= dblen);
-		free(db);
-		db = Alloc(dblen);
-		}
-	if (etype[(unsigned char)c] >= 2)
-		while(c == '0') c = *s++;
-	tz = 0;
-	while(c >= '0' && c <= '9') {
-		if (c == '0')
-			tz++;
-		else {
-			if (nd)
-				for(; tz; --tz)
-					db[nd++] = '0';
-			else
-				tz = 0;
-			db[nd++] = c;
-			}
-		c = *s++;
-		}
-	ea = -tz;
-	if (c == '.') {
-		while((c = *s++) >= '0' && c <= '9') {
-			if (c == '0')
-				tz++;
-			else {
-				if (tz) {
-					ea += tz;
-					if (nd)
-						for(; tz; --tz)
-							db[nd++] = '0';
-					else
-						tz = 0;
-					}
-				db[nd++] = c;
-				ea++;
-				}
-			}
-		}
-	if (et = etype[(unsigned char)c]) {
-		esign = et == 3;
-		c = *s++;
-		if (et == 1) {
-			if(etype[(unsigned char)c] > 1) {
-				if (c == '-')
-					esign = 1;
-				c = *s++;
-				}
-			}
-		while(c >= '0' && c <= '9') {
-			ex = 10*ex + (c - '0');
-			c = *s++;
-			}
-		if (esign)
-			ex = -ex;
-		}
-	/* debug */ if (c)
-	/* debug*/	Fatal("unexpected character in cds");
-	ex -= ea;
-	if (!nd) {
-		if (!z0)
-			z0 = mem(4,0);
-		strcpy(z0, "-0.");
-		sign = 0;
-		}
-	else if (ex > 2 || ex + nd < -2) {
-		sprintf(ebuf, "%ld", ex + nd - 1);
-		k = strlen(ebuf) + nd + 3;
-		if (nd > 1)
-			k++;
-		if (!z0)
-			z0 = mem(k,0);
-		z = z0;
-		*z++ = '-';
-		*z++ = *db;
-		if (nd > 1) {
-			*z++ = '.';
-			for(k = 1; k < nd; k++)
-				*z++ = db[k];
-			}
-		*z++ = 'e';
-		strcpy(z, ebuf);
-		}
-	else {
-		k = (int)(ex + nd);
-		i = nd + 3;
-		if (k < 0)
-			i -= k;
-		else if (ex > 0)
-			i += ex;
-		if (!z0)
-			z0 = mem(i,0);
-		z = z0;
-		*z++ = '-';
-		if (ex >= 0) {
-			for(k = 0; k < nd; k++)
-				*z++ = db[k];
-			while(--ex >= 0)
-				*z++ = '0';
-			*z++ = '.';
-			}
-		else {
-			for(i = 0; i < k;)
-				*z++ = db[i++];
-			*z++ = '.';
-			while(++k <= 0)
-				*z++ = '0';
-			while(i < nd)
-				*z++ = db[i++];
-			}
-		*z = 0;
-		}
-	return sign ? z0 : z0+1;
-	}
//GO.SYSIN DD cds.c
echo data.c 1>&2
sed >data.c <<'//GO.SYSIN DD data.c' 's/^-//'
-/****************************************************************
-Copyright 1990 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.
-****************************************************************/
-
-#include "defs.h"
-
-/* ROUTINES CALLED DURING DATA AND PARAMETER STATEMENT PROCESSING */
-
-static char datafmt[] = "%s\t%09ld\t%d";
-static char *cur_varname;
-
-/* another initializer, called from parser */
-dataval(repp, valp)
-register expptr repp, valp;
-{
-	int i, nrep;
-	ftnint elen;
-	register Addrp p;
-	Addrp nextdata();
-
-	if (parstate < INDATA) {
-		frexpr(repp);
-		goto ret;
-		}
-	if(repp == NULL)
-		nrep = 1;
-	else if (ISICON(repp) && repp->constblock.Const.ci >= 0)
-		nrep = repp->constblock.Const.ci;
-	else
-	{
-		err("invalid repetition count in DATA statement");
-		frexpr(repp);
-		goto ret;
-	}
-	frexpr(repp);
-
-	if( ! ISCONST(valp) )
-	{
-		err("non-constant initializer");
-		goto ret;
-	}
-
-	if(toomanyinit) goto ret;
-	for(i = 0 ; i < nrep ; ++i)
-	{
-		p = nextdata(&elen);
-		if(p == NULL)
-		{
-			err("too many initializers");
-			toomanyinit = YES;
-			goto ret;
-		}
-		setdata((Addrp)p, (Constp)valp, elen);
-		frexpr((expptr)p);
-	}
-
-ret:
-	frexpr(valp);
-}
-
-
-Addrp nextdata(elenp)
-ftnint *elenp;
-{
-	register struct Impldoblock *ip;
-	struct Primblock *pp;
-	register Namep np;
-	register struct Rplblock *rp;
-	tagptr p;
-	expptr neltp;
-	register expptr q;
-	int skip;
-	ftnint off, vlen;
-
-	while(curdtp)
-	{
-		p = (tagptr)curdtp->datap;
-		if(p->tag == TIMPLDO)
-		{
-			ip = &(p->impldoblock);
-			if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL)
-				fatali("bad impldoblock 0%o", (int) ip);
-			if(ip->isactive)
-				ip->varvp->Const.ci += ip->impdiff;
-			else
-			{
-				q = fixtype(cpexpr(ip->implb));
-				if( ! ISICON(q) )
-					goto doerr;
-				ip->varvp = (Constp) q;
-
-				if(ip->impstep)
-				{
-					q = fixtype(cpexpr(ip->impstep));
-					if( ! ISICON(q) )
-						goto doerr;
-					ip->impdiff = q->constblock.Const.ci;
-					frexpr(q);
-				}
-				else
-					ip->impdiff = 1;
-
-				q = fixtype(cpexpr(ip->impub));
-				if(! ISICON(q))
-					goto doerr;
-				ip->implim = q->constblock.Const.ci;
-				frexpr(q);
-
-				ip->isactive = YES;
-				rp = ALLOC(Rplblock);
-				rp->rplnextp = rpllist;
-				rpllist = rp;
-				rp->rplnp = ip->varnp;
-				rp->rplvp = (expptr) (ip->varvp);
-				rp->rpltag = TCONST;
-			}
-
-			if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim))
-			    || (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) )
-			{ /* start new loop */
-				curdtp = ip->datalist;
-				goto next;
-			}
-
-			/* clean up loop */
-
-			if(rpllist)
-			{
-				rp = rpllist;
-				rpllist = rpllist->rplnextp;
-				free( (charptr) rp);
-			}
-			else
-				Fatal("rpllist empty");
-
-			frexpr((expptr)ip->varvp);
-			ip->isactive = NO;
-			curdtp = curdtp->nextp;
-			goto next;
-		}
-
-		pp = (struct Primblock *) p;
-		np = pp->namep;
-		cur_varname = np->fvarname;
-		skip = YES;
-
-		if(p->primblock.argsp==NULL && np->vdim!=NULL)
-		{   /* array initialization */
-			q = (expptr) mkaddr(np);
-			off = typesize[np->vtype] * curdtelt;
-			if(np->vtype == TYCHAR)
-				off *= np->vleng->constblock.Const.ci;
-			q->addrblock.memoffset =
-			    mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) );
-			if( (neltp = np->vdim->nelt) && ISCONST(neltp))
-			{
-				if(++curdtelt < neltp->constblock.Const.ci)
-					skip = NO;
-			}
-			else
-				err("attempt to initialize adjustable array");
-		}
-		else
-			q = mklhs( (struct Primblock *)cpexpr((expptr)pp) );
-		if(skip)
-		{
-			curdtp = curdtp->nextp;
-			curdtelt = 0;
-		}
-		if(q->headblock.vtype == TYCHAR)
-			if(ISICON(q->headblock.vleng))
-				*elenp = q->headblock.vleng->constblock.Const.ci;
-			else	{
-				err("initialization of string of nonconstant length");
-				continue;
-			}
-		else	*elenp = typesize[q->headblock.vtype];
-
-		if (np->vstg == STGBSS) {
-			vlen = np->vtype==TYCHAR
-				? np->vleng->constblock.Const.ci
-				: typesize[np->vtype];
-			if(vlen > 0)
-				np->vstg = STGINIT;
-			}
-		return( (Addrp) q );
-
-doerr:
-		err("nonconstant implied DO parameter");
-		frexpr(q);
-		curdtp = curdtp->nextp;
-
-next:
-		curdtelt = 0;
-	}
-
-	return(NULL);
-}
-
-
-
-LOCAL FILEP dfile;
-
-
-setdata(varp, valp, elen)
-register Addrp varp;
-ftnint elen;
-register Constp valp;
-{
-	struct Constblock con;
-	register int type;
-	int i, k, valtype;
-	ftnint offset;
-	char *dataname(), *varname;
-	static Addrp badvar;
-	register unsigned char *s;
-	static int last_lineno;
-	static char *last_varname;
-
-	if (varp->vstg == STGCOMMON) {
-		if (!(dfile = blkdfile))
-			dfile = blkdfile = opf(blkdfname, textwrite);
-		}
-	else {
-		if (procclass == CLBLOCK) {
-			if (varp != badvar) {
-				badvar = varp;
-				warn1("%s is not in a COMMON block",
-					varp->uname_tag == UNAM_NAME
-					? varp->user.name->fvarname
-					: "???");
-				}
-			return;
-			}
-		if (!(dfile = initfile))
-			dfile = initfile = opf(initfname, textwrite);
-		}
-	varname = dataname(varp->vstg, varp->memno);
-	offset = varp->memoffset->constblock.Const.ci;
-	type = varp->vtype;
-	valtype = valp->vtype;
-	if(type!=TYCHAR && valtype==TYCHAR)
-	{
-		if(! ftn66flag
-		&& (last_varname != cur_varname || last_lineno != lineno)) {
-			/* prevent multiple warnings */
-			last_lineno = lineno;
-			warn1(
-	"non-character datum %.42s initialized with character string",
-				last_varname = cur_varname);
-			}
-		varp->vleng = ICON(typesize[type]);
-		varp->vtype = type = TYCHAR;
-	}
-	else if( (type==TYCHAR && valtype!=TYCHAR) ||
-	    (cktype(OPASSIGN,type,valtype) == TYERROR) )
-	{
-		err("incompatible types in initialization");
-		return;
-	}
-	if(type == TYADDR)
-		con.Const.ci = valp->Const.ci;
-	else if(type != TYCHAR)
-	{
-		if(valtype == TYUNKNOWN)
-			con.Const.ci = valp->Const.ci;
-		else	consconv(type, &con, valp);
-	}
-
-	k = 1;
-
-	switch(type)
-	{
-	case TYLOGICAL:
-		if (tylogical != TYLONG)
-			type = tylogical;
-	case TYSHORT:
-	case TYLONG:
-		dataline(varname, offset, type);
-		prconi(dfile, con.Const.ci);
-		break;
-
-	case TYADDR:
-		dataline(varname, offset, type);
-		prcona(dfile, con.Const.ci);
-		break;
-
-	case TYCOMPLEX:
-	case TYDCOMPLEX:
-		k = 2;
-	case TYREAL:
-	case TYDREAL:
-		dataline(varname, offset, type);
-		prconr(dfile, &con, k);
-		break;
-
-	case TYCHAR:
-		k = valp -> vleng -> constblock.Const.ci;
-		if (elen < k)
-			k = elen;
-		s = (unsigned char *)valp->Const.ccp;
-		for(i = 0 ; i < k ; ++i) {
-			dataline(varname, offset++, TYCHAR);
-			fprintf(dfile, "\t%d\n", *s++);
-			}
-		k = elen - valp->vleng->constblock.Const.ci;
-		if(k > 0) {
-			dataline(varname, offset, TYBLANK);
-			fprintf(dfile, "\t%d\n", k);
-			}
-		break;
-
-	default:
-		badtype("setdata", type);
-	}
-
-}
-
-
-
-/*
-   output form of name is padded with blanks and preceded
-   with a storage class digit
-*/
-char *dataname(stg,memno)
- int stg;
- long memno;
-{
-	static char varname[64];
-	register char *s, *t;
-	char buf[16], *memname();
-
-	if (stg == STGCOMMON) {
-		varname[0] = '2';
-		sprintf(s = buf, "Q.%ld", memno);
-		}
-	else {
-		varname[0] = stg==STGEQUIV ? '1' : '0';
-		s = memname(stg, memno);
-		}
-	t = varname + 1;
-	while(*t++ = *s++);
-	*t = 0;
-	return(varname);
-}
-
-
-
-
-
-frdata(p0)
-chainp p0;
-{
-	register struct Chain *p;
-	register tagptr q;
-
-	for(p = p0 ; p ; p = p->nextp)
-	{
-		q = (tagptr)p->datap;
-		if(q->tag == TIMPLDO)
-		{
-			if(q->impldoblock.isbusy)
-				return;	/* circular chain completed */
-			q->impldoblock.isbusy = YES;
-			frdata(q->impldoblock.datalist);
-			free( (charptr) q);
-		}
-		else
-			frexpr(q);
-	}
-
-	frchain( &p0);
-}
-
-
-
-dataline(varname, offset, type)
-char *varname;
-ftnint offset;
-int type;
-{
-	fprintf(dfile, datafmt, varname, offset, type);
-}
-
- void
-make_param(p, e)
- register struct Paramblock *p;
- expptr e;
-{
-	register expptr q;
-
-	p->vclass = CLPARAM;
-	impldcl((Namep)p);
-	p->paramval = q = mkconv(p->vtype, e);
-	if (p->vtype == TYCHAR) {
-		if (q->tag == TEXPR)
-			p->paramval = q = fixexpr(q);
-		if (!ISCONST(q) || q->constblock.vtype != TYCHAR) {
-			errstr("invalid value for character parameter %s",
-				p->fvarname);
-			return;
-			}
-		if (!(e = p->vleng))
-			p->vleng = ICON(q->constblock.vleng->constblock.Const.ci
-					+ q->constblock.Const.ccp1.blanks);
-		else if (q->constblock.vleng->constblock.Const.ci
-				> e->constblock.Const.ci) {
-			q->constblock.vleng->constblock.Const.ci
-				= e->constblock.Const.ci;
-			q->constblock.Const.ccp1.blanks = 0;
-			}
-		else
-			q->constblock.Const.ccp1.blanks
-				= e->constblock.Const.ci
-				- q->constblock.vleng->constblock.Const.ci;
-		}
-	}
//GO.SYSIN DD data.c
echo defines.h 1>&2
sed >defines.h <<'//GO.SYSIN DD defines.h' 's/^-//'
-#define PDP11 4
-
-#define BIGGEST_SHORT	0x7fff		/* Assumes 32-bit arithmetic */
-#define BIGGEST_LONG	0x7fffffff	/* Assumes 32-bit arithmetic */
-
-#define M(x) (1<<x)	/* Mask (x) returns 2^x */
-
-#define ALLOC(x)	(struct x *) ckalloc((int)sizeof(struct x))
-#define ALLEXPR		(expptr) ckalloc((int)sizeof(union Expression) )
-typedef int *ptr;
-typedef char *charptr;
-typedef FILE *FILEP;
-typedef int flag;
-typedef char field;	/* actually need only 4 bits */
-typedef long int ftnint;
-#define LOCAL static
-
-#define NO 0
-#define YES 1
-
-#define CNULL (char *) 0	/* Character string null */
-#define PNULL (ptr) 0
-#define CHNULL (chainp) 0	/* Chain null */
-#define ENULL (expptr) 0
-
-
-/* BAD_MEMNO - used to distinguish between long string constants and other
-   constants in the table */
-
-#define BAD_MEMNO -32768
-
-
-/* block tag values -- syntactic stuff */
-
-#define TNAME 1
-#define TCONST 2
-#define TEXPR 3
-#define TADDR 4
-#define TPRIM 5		/* Primitive datum - should not appear in an
-			   expptr variable, it should have already been
-			   identified */
-#define TLIST 6
-#define TIMPLDO 7
-#define TERROR 8
-
-
-/* parser states - order is important, since there are several tests for
-   state < INDATA   */
-
-#define OUTSIDE 0
-#define INSIDE 1
-#define INDCL 2
-#define INDATA 3
-#define INEXEC 4
-
-/* procedure classes */
-
-#define PROCMAIN 1
-#define PROCBLOCK 2
-#define PROCSUBR 3
-#define PROCFUNCT 4
-
-
-/* storage classes -- vstg values.  BSS and INIT are used in the later
-   merge pass over identifiers; and they are entered differently into the
-   symbol table */
-
-#define STGUNKNOWN 0
-#define STGARG 1	/* adjustable dimensions */
-#define STGAUTO 2	/* for stack references */
-#define STGBSS 3	/* uninitialized storage (normal variables) */
-#define STGINIT 4	/* initialized storage */
-#define STGCONST 5
-#define STGEXT 6	/* external storage */
-#define STGINTR 7	/* intrinsic (late decision) reference.  See
-			   chapter 5 of the Fortran 77 standard */
-#define STGSTFUNCT 8
-#define STGCOMMON 9
-#define STGEQUIV 10
-#define STGREG 11	/* register - the outermost DO loop index will be
-			   in a register (because the compiler is one
-			   pass, it can't know where the innermost loop is
-			   */
-#define STGLENG 12
-#define STGNULL 13
-#define STGMEMNO 14	/* interemediate-file pointer to constant table */
-
-/* name classes -- vclass values, also   procclass   values */
-
-#define CLUNKNOWN 0
-#define CLPARAM 1	/* Parameter - macro definition */
-#define CLVAR 2		/* variable */
-#define CLENTRY 3
-#define CLMAIN 4
-#define CLBLOCK 5
-#define CLPROC 6
-#define CLNAMELIST 7	/* in data with this tag, the   vdcldone   flag should
-			   be ignored (according to vardcl()) */
-
-
-/* vprocclass values -- there is some overlap with the vclass values given
-   above */
-
-#define PUNKNOWN 0
-#define PEXTERNAL 1
-#define PINTRINSIC 2
-#define PSTFUNCT 3
-#define PTHISPROC 4	/* here to allow recursion - further distinction
-			   is given in the CL tag (those just above).
-			   This applies to the presence of the name of a
-			   function used within itself.  The function name
-			   means either call the function again, or assign
-			   some value to the storage allocated to the
-			   function's return value. */
-
-/* control stack codes - these are part of a state machine which handles
-   the nesting of blocks (i.e. what to do about the ELSE statement) */
-
-#define CTLDO 1
-#define CTLIF 2
-#define CTLELSE 3
-#define CTLIFX 4
-
-
-/* operators for both Fortran input and C output.  They are common because
-   so many are shared between the trees */
-
-#define OPPLUS 1
-#define OPMINUS 2
-#define OPSTAR 3
-#define OPSLASH 4
-#define OPPOWER 5
-#define OPNEG 6
-#define OPOR 7
-#define OPAND 8
-#define OPEQV 9
-#define OPNEQV 10
-#define OPNOT 11
-#define OPCONCAT 12
-#define OPLT 13
-#define OPEQ 14
-#define OPGT 15
-#define OPLE 16
-#define OPNE 17
-#define OPGE 18
-#define OPCALL 19
-#define OPCCALL 20
-#define OPASSIGN 21
-#define OPPLUSEQ 22
-#define OPSTAREQ 23
-#define OPCONV 24
-#define OPLSHIFT 25
-#define OPMOD 26
-#define OPCOMMA 27
-#define OPQUEST 28
-#define OPCOLON 29
-#define OPABS 30
-#define OPMIN 31
-#define OPMAX 32
-#define OPADDR 33
-#define OPCOMMA_ARG 34
-#define OPBITOR 35
-#define OPBITAND 36
-#define OPBITXOR 37
-#define OPBITNOT 38
-#define OPRSHIFT 39
-#define OPWHATSIN 40		/* dereferencing operator */
-#define OPMINUSEQ 41		/* assignment operators */
-#define OPSLASHEQ 42
-#define OPMODEQ 43
-#define OPLSHIFTEQ 44
-#define OPRSHIFTEQ 45
-#define OPBITANDEQ 46
-#define OPBITXOREQ 47
-#define OPBITOREQ 48
-#define OPPREINC 49		/* Preincrement (++x) operator */
-#define OPPREDEC 50		/* Predecrement (--x) operator */
-#define OPDOT 51		/* structure field reference */
-#define OPARROW 52		/* structure pointer field reference */
-#define OPNEG1 53		/* simple negation under forcedouble */
-#define OPDMIN 54		/* min(a,b) macro under forcedouble */
-#define OPDMAX 55		/* max(a,b) macro under forcedouble */
-#define OPASSIGNI 56		/* assignment for inquire stmt */
-#define OPIDENTITY 57		/* for turning TADDR into TEXPR */
-#define OPCHARCAST 58		/* for casting to char * (in I/O stmts) */
-#define OPDABS 59		/* abs macro under forcedouble */
-#define OPMIN2 60		/* min(a,b) macro */
-#define OPMAX2 61		/* max(a,b) macro */
-
-/* label type codes -- used with the ASSIGN statement */
-
-#define LABUNKNOWN 0
-#define LABEXEC 1
-#define LABFORMAT 2
-#define LABOTHER 3
-
-
-/* INTRINSIC function codes*/
-
-#define INTREND 0
-#define INTRCONV 1
-#define INTRMIN 2
-#define INTRMAX 3
-#define INTRGEN 4	/* General intrinsic, e.g. cos v. dcos, zcos, ccos */
-#define INTRSPEC 5
-#define INTRBOOL 6
-#define INTRCNST 7	/* constants, e.g. bigint(1.0) v. bigint (1d0) */
-
-
-/* I/O statement codes - these all form Integer Constants, and are always
-   reevaluated */
-
-#define IOSTDIN ICON(5)
-#define IOSTDOUT ICON(6)
-#define IOSTDERR ICON(0)
-
-#define IOSBAD (-1)
-#define IOSPOSITIONAL 0
-#define IOSUNIT 1
-#define IOSFMT 2
-
-#define IOINQUIRE 1
-#define IOOPEN 2
-#define IOCLOSE 3
-#define IOREWIND 4
-#define IOBACKSPACE 5
-#define IOENDFILE 6
-#define IOREAD 7
-#define IOWRITE 8
-
-
-/* User name tags -- these identify the form of the original identifier
-   stored in a   struct Addrblock   structure (in the   user   field). */
-
-#define UNAM_UNKNOWN 0		/* Not specified */
-#define UNAM_NAME 1		/* Local symbol, store in the hash table */
-#define UNAM_IDENT 2		/* Character string not stored elsewhere */
-#define UNAM_EXTERN 3		/* External reference; check symbol table
-				   using   memno   as index */
-#define UNAM_CONST 4		/* Constant value */
-#define UNAM_CHARP 5		/* pointer to string */
-
-
-#define IDENT_LEN 31		/* Maximum length user.ident */
-
-/* type masks - TYLOGICAL defined in   ftypes   */
-
-#define MSKLOGICAL	M(TYLOGICAL)
-#define MSKADDR	M(TYADDR)
-#define MSKCHAR	M(TYCHAR)
-#define MSKINT	M(TYSHORT)|M(TYLONG)
-#define MSKREAL	M(TYREAL)|M(TYDREAL)	/* DREAL means Double Real */
-#define MSKCOMPLEX	M(TYCOMPLEX)|M(TYDCOMPLEX)
-#define MSKSTATIC (M(STGINIT)|M(STGBSS)|M(STGCOMMON)|M(STGEQUIV)|M(STGCONST))
-
-/* miscellaneous macros */
-
-/* ONEOF (x, y) -- x is the number of one of the OR'ed masks in y (i.e., x is
-   the log of one of the OR'ed masks in y) */
-
-#define ONEOF(x,y) (M(x) & (y))
-#define ISCOMPLEX(z) ONEOF(z, MSKCOMPLEX)
-#define ISREAL(z) ONEOF(z, MSKREAL)
-#define ISNUMERIC(z) ONEOF(z, MSKINT|MSKREAL|MSKCOMPLEX)
-#define ISICON(z) (z->tag==TCONST && ISINT(z->constblock.vtype))
-
-/* ISCHAR assumes that   z   has some kind of structure, i.e. is not null */
-
-#define ISCHAR(z) (z->headblock.vtype==TYCHAR)
-#define ISINT(z)   ONEOF(z, MSKINT)	/*   z   is a tag, i.e. a mask number */
-#define ISCONST(z) (z->tag==TCONST)
-#define ISERROR(z) (z->tag==TERROR)
-#define ISPLUSOP(z) (z->tag==TEXPR && z->exprblock.opcode==OPPLUS)
-#define ISSTAROP(z) (z->tag==TEXPR && z->exprblock.opcode==OPSTAR)
-#define ISONE(z) (ISICON(z) && z->constblock.Const.ci==1)
-#define INT(z) ONEOF(z, MSKINT|MSKCHAR)	/* has INT storage in real life */
-#define ICON(z) mkintcon( (ftnint)(z) )
-
-/* NO66 -- F77 feature is being used
-   NOEXT -- F77 extension is being used */
-
-#define NO66(s)	if(no66flag) err66(s)
-#define NOEXT(s)	if(noextflag) errext(s)
-
-/* round a up to the nearest multiple of b:
-
-   a = b * floor ( (a + (b - 1)) / b )*/
-
-#define roundup(a,b)    ( b * ( (a+b-1)/b) )
//GO.SYSIN DD defines.h
echo defs.h 1>&2
sed >defs.h <<'//GO.SYSIN DD defs.h' 's/^-//'
-/****************************************************************
-Copyright 1990, 1991 by AT&T Bell Laboratories, 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.
-****************************************************************/
-
-#include "sysdep.h"
-
-#include "ftypes.h"
-#include "defines.h"
-#include "machdefs.h"
-
-#define MAXDIM 20
-#define MAXINCLUDES 10
-#define MAXLITERALS 200		/* Max number of constants in the literal
-				   pool */
-#define MAXTOKENLEN 302		/* length of longest token */
-#define MAXCTL 20
-#define MAXHASH 401
-#define MAXSTNO 801
-#define MAXEXT 200
-#define MAXEQUIV 150
-#define MAXLABLIST 125		/* Max number of labels in an alternate
-				   return CALL */
-
-/* These are the primary pointer types used in the compiler */
-
-typedef union Expression *expptr, *tagptr;
-typedef struct Chain *chainp;
-typedef struct Addrblock *Addrp;
-typedef struct Constblock *Constp;
-typedef struct Exprblock *Exprp;
-typedef struct Nameblock *Namep;
-
-extern FILEP opf();
-extern FILEP infile;
-extern FILEP diagfile;
-extern FILEP textfile;
-extern FILEP asmfile;
-extern FILEP c_file;		/* output file for all functions; extern
-				   declarations will have to be prepended */
-extern FILEP pass1_file;	/* Temp file to hold the function bodies
-				   read on pass 1 */
-extern FILEP expr_file;		/* Debugging file */
-extern FILEP initfile;		/* Intermediate data file pointer */
-extern FILEP blkdfile;		/* BLOCK DATA file */
-
-extern int current_ftn_file;
-
-extern char *blkdfname, *initfname, *sortfname;
-extern long int headoffset;	/* Since the header block requires data we
-				   don't know about until AFTER each
-				   function has been processed, we keep a
-				   pointer to the current (dummy) header
-				   block (at the top of the assembly file)
-				   here */
-
-extern char main_alias[];	/* name given to PROGRAM psuedo-op */
-extern char token [ ];
-extern int toklen;
-extern long lineno;
-extern char *infname;
-extern int needkwd;
-extern struct Labelblock *thislabel;
-
-/* Used to allow runtime expansion of internal tables.  In particular,
-   these values can exceed their associated constants */
-
-extern int maxctl;
-extern int maxequiv;
-extern int maxstno;
-extern int maxhash;
-extern int maxext;
-
-extern flag nowarnflag;
-extern flag ftn66flag;		/* Generate warnings when weird f77
-				   features are used (undeclared dummy
-				   procedure, non-char initialized with
-				   string, 1-dim subscript in EQUIV) */
-extern flag no66flag;		/* Generate an error when a generic
-				   function (f77 feature) is used */
-extern flag noextflag;		/* Generate an error when an extension to
-				   Fortran 77 is used (hex/oct/bin
-				   constants, automatic, static, double
-				   complex types) */
-extern flag zflag;		/* enable double complex intrinsics */
-extern flag shiftcase;
-extern flag undeftype;
-extern flag shortsubs;		/* Use short subscripts on arrays? */
-extern flag onetripflag;	/* if true, always execute DO loop body */
-extern flag checksubs;
-extern flag debugflag;
-extern int nerr;
-extern int nwarn;
-
-extern int parstate;
-extern flag headerdone;		/* True iff the current procedure's header
-				   data has been written */
-extern int blklevel;
-extern flag saveall;
-extern flag substars;		/* True iff some formal parameter is an
-				   asterisk */
-extern int impltype[ ];
-extern ftnint implleng[ ];
-extern int implstg[ ];
-
-extern int tycomplex, tyint, tyioint, tyreal;
-extern int tylogical;		/* TY____ of the implementation of   logical.
-				   This will be LONG unless '-2' is given
-				   on the command line */
-extern int type_choice[];
-extern char *typename[];
-
-extern int typesize[];	/* size (in bytes) of an object of each
-				   type.  Indexed by TY___ macros */
-extern int typealign[];
-extern int proctype;	/* Type of return value in this procedure */
-extern char * procname;	/* External name of the procedure, or last ENTRY name */
-extern int rtvlabel[ ];	/* Return value labels, indexed by TY___ macros */
-extern Addrp retslot;
-extern Addrp xretslot[];
-extern int cxslot;	/* Complex return argument slot (frame pointer offset)*/
-extern int chslot;	/* Character return argument slot (fp offset) */
-extern int chlgslot;	/* Argument slot for length of character buffer */
-extern int procclass;	/* Class of the current procedure:  either CLPROC,
-			   CLMAIN, CLBLOCK or CLUNKNOWN */
-extern ftnint procleng;	/* Length of function return value (e.g. char
-			   string length).  If this is -1, then the length is
-			   not known at compile time */
-extern int nentry;	/* Number of entry points (other than the original
-			   function call) into this procedure */
-extern flag multitype;	/* YES iff there is more than one return value
-			   possible */
-extern int blklevel;
-extern long lastiolabno;
-extern int lastlabno;
-extern int lastvarno;
-extern int lastargslot;	/* integer offset pointing to the next free
-			   location for an argument to the current routine */
-extern int argloc;
-extern int autonum[];		/* for numbering
-				   automatic variables, e.g. temporaries */
-extern int retlabel;
-extern int ret0label;
-extern int dorange;		/* Number of the label which terminates
-				   the innermost DO loop */
-extern int regnum[ ];		/* Numbers of DO indicies named in
-				   regnamep   (below) */
-extern Namep regnamep[ ];	/* List of DO indicies in registers */
-extern int maxregvar;		/* number of elts in   regnamep   */
-extern int highregvar;		/* keeps track of the highest register
-				   number used by DO index allocator */
-extern int nregvar;		/* count of DO indicies in registers */
-
-extern chainp templist[];
-extern int maxdim;
-extern chainp earlylabs;
-extern chainp holdtemps;
-extern struct Entrypoint *entries;
-extern struct Rplblock *rpllist;
-extern struct Chain *curdtp;
-extern ftnint curdtelt;
-extern chainp allargs;		/* union of args in entries */
-extern int nallargs;		/* total number of args */
-extern int nallchargs;		/* total number of character args */
-extern flag toomanyinit;	/* True iff too many initializers in a
-				   DATA statement */
-
-extern flag inioctl;
-extern int iostmt;
-extern Addrp ioblkp;
-extern int nioctl;
-extern int nequiv;
-extern int eqvstart;	/* offset to eqv number to guarantee uniqueness
-			   and prevent <something> from going negative */
-extern int nintnames;
-
-/* Chain of tagged blocks */
-
-struct Chain
-	{
-	chainp nextp;
-	char * datap;		/* Tagged block */
-	};
-
-extern chainp chains;
-
-/* Recall that   field   is intended to hold four-bit characters */
-
-/* This structure exists only to defeat the type checking */
-
-struct Headblock
-	{
-	field tag;
-	field vtype;
-	field vclass;
-	field vstg;
-	expptr vleng;		/* Expression for length of char string -
-				   this may be a constant, or an argument
-				   generated by mkarg() */
-	} ;
-
-/* Control construct info (for do loops, else, etc) */
-
-struct Ctlframe
-	{
-	unsigned ctltype:8;
-	unsigned dostepsign:8;	/* 0 - variable, 1 - pos, 2 - neg */
-	unsigned dowhile:1;
-	int ctlabels[4];	/* Control labels, defined below */
-	int dolabel;		/* label marking end of this DO loop */
-	Namep donamep;		/* DO index variable */
-	expptr domax;		/* constant or temp variable holding MAX
-				   loop value; or expr of while(expr) */
-	expptr dostep;		/* expression */
-	Namep loopname;
-	};
-#define endlabel ctlabels[0]
-#define elselabel ctlabels[1]
-#define dobodylabel ctlabels[1]
-#define doposlabel ctlabels[2]
-#define doneglabel ctlabels[3]
-extern struct Ctlframe *ctls;		/* Keeps info on DO and BLOCK IF
-					   structures - this is the stack
-					   bottom */
-extern struct Ctlframe *ctlstack;	/* Pointer to current nesting
-					   level */
-extern struct Ctlframe *lastctl;	/* Point to end of
-					   dynamically-allocated array */
-
-typedef struct {
-	int type;
-	chainp cp;
-	} Atype;
-
-typedef struct {
-	int defined, dnargs, nargs, changes;
-	Atype atypes[1];
-	} Argtypes;
-
-/* External Symbols */
-
-struct Extsym
-	{
-	char *fextname;		/* Fortran version of external name */
-	char *cextname;		/* C version of external name */
-	field extstg;		/* STG -- should be COMMON, UNKNOWN or EXT
-				   */
-	unsigned extype:4;	/* for transmitting type to output routines */
-	unsigned used_here:1;	/* Boolean - true on the second pass
-				   through a function if the block has
-				   been referenced */
-	unsigned exused:1;	/* Has been used (for help with error msgs
-				   about externals typed differently in
-				   different modules) */
-	unsigned exproto:1;	/* type specified in a .P file */
-	unsigned extinit:1;	/* Procedure has been defined,
-				   or COMMON has DATA */
-	unsigned extseen:1;	/* True if previously referenced */
-	chainp extp;		/* List of identifiers in the common
-				   block for this function, stored as
-				   Namep (hash table pointers) */
-	chainp allextp;		/* List of lists of identifiers; we keep one
-				   list for each layout of this common block */
-	int curno;		/* current number for this common block,
-				   used for constructing appending _nnn
-				   to the common block name */
-	int maxno;		/* highest curno value for this common block */
-	ftnint extleng;
-	ftnint maxleng;
-	Argtypes *arginfo;
-	};
-typedef struct Extsym Extsym;
-
-extern Extsym *extsymtab;	/* External symbol table */
-extern Extsym *nextext;
-extern Extsym *lastext;
-extern int complex_seen, dcomplex_seen;
-
-/* Statement labels */
-
-struct Labelblock
-	{
-	int labelno;		/* Internal label */
-	unsigned blklevel:8;	/* level of nesting , for branch-in-loop
-				   checking */
-	unsigned labused:1;
-	unsigned fmtlabused:1;
-	unsigned labinacc:1;	/* inaccessible? (i.e. has its scope
-				   vanished) */
-	unsigned labdefined:1;	/* YES or NO */
-	unsigned labtype:2;	/* LAB{FORMAT,EXEC,etc} */
-	ftnint stateno;		/* Original label */
-	char *fmtstring;	/* format string */
-	};
-
-extern struct Labelblock *labeltab;	/* Label table - keeps track of
-					   all labels, including undefined */
-extern struct Labelblock *labtabend;
-extern struct Labelblock *highlabtab;
-
-/* Entry point list */
-
-struct Entrypoint
-	{
-	struct Entrypoint *entnextp;
-	Extsym *entryname;	/* Name of this ENTRY */
-	chainp arglist;
-	int typelabel;			/* Label for function exit; this
-					   will return the proper type of
-					   object */
-	Namep enamep;			/* External name */
-	};
-
-/* Primitive block, or Primary block.  This is a general template returned
-   by the parser, which will be interpreted in context.  It is a template
-   for an identifier (variable name, function name), parenthesized
-   arguments (array subscripts, function parameters) and substring
-   specifications. */
-
-struct Primblock
-	{
-	field tag;
-	field vtype;
-	Namep namep;			/* Pointer to structure Nameblock */
-	struct Listblock *argsp;
-	expptr fcharp;			/* first-char-index-pointer (in
-					   substring) */
-	expptr lcharp;			/* last-char-index-pointer (in
-					   substring) */
-	};
-
-
-struct Hashentry
-	{
-	int hashval;
-	Namep varp;
-	};
-extern struct Hashentry *hashtab;	/* Hash table */
-extern struct Hashentry *lasthash;
-
-struct Intrpacked	/* bits for intrinsic function description */
-	{
-	unsigned f1:3;
-	unsigned f2:4;
-	unsigned f3:7;
-	unsigned f4:1;
-	};
-
-struct Nameblock
-	{
-	field tag;
-	field vtype;
-	field vclass;
-	field vstg;
-	expptr vleng;		/* length of character string, if applicable */
-	char *fvarname;		/* name in the Fortran source */
-	char *cvarname;		/* name in the resulting C */
-	chainp vlastdim;	/* datap points to new_vars entry for the */
-				/* system variable, if any, storing the final */
-				/* dimension; we zero the datap if this */
-				/* variable is needed */
-	unsigned vprocclass:3;	/* P____ macros - selects the   varxptr
-				   field below */
-	unsigned vdovar:1;	/* "is it a DO variable?" for register
-				   and multi-level loop	checking */
-	unsigned vdcldone:1;	/* "do I think I'm done?" - set when the
-				   context is sufficient to determine its
-				   status */
-	unsigned vadjdim:1;	/* "adjustable dimension?" - needed for
-				   information about copies */
-	unsigned vsave:1;
-	unsigned vimpldovar:1;	/* used to prevent erroneous error messages
-				   for variables used only in DATA stmt
-				   implicit DOs */
-	unsigned vis_assigned:1;/* True if this variable has had some
-				   label ASSIGNED to it; hence
-				   varxptr.assigned_values is valid */
-	unsigned vimplstg:1;	/* True if storage type is assigned implicitly;
-				   this allows a COMMON variable to participate
-				   in a DIMENSION before the COMMON declaration.
-				   */
-	unsigned vcommequiv:1;	/* True if EQUIVALENCEd onto STGCOMMON */
-	unsigned vfmt_asg:1;	/* True if char *var_fmt needed */
-	unsigned vpassed:1;	/* True if passed as a character-variable arg */
-	unsigned vknownarg:1;	/* True if seen in a previous entry point */
-	unsigned visused:1;	/* True if variable is referenced -- so we */
-				/* can omit variables that only appear in DATA */
-	unsigned vnamelist:1;	/* Appears in a NAMELIST */
-	unsigned vimpltype:1;	/* True if implicitly typed and not
-				   invoked as a function or subroutine
-				   (so we can consistently type procedures
-				   declared external and passed as args
-				   but never invoked).
-				   */
-	unsigned vtypewarned:1;	/* so we complain just once about
-				   changed types of external procedures */
-	unsigned vinftype:1;	/* so we can restore implicit type to a
-				   procedure if it is invoked as a function
-				   after being given a different type by -it */
-	unsigned vinfproc:1;	/* True if -it infers this to be a procedure */
-	unsigned vcalled:1;	/* has been invoked */
-	unsigned vdimfinish:1;	/* need to invoke dim_finish() */
-
-/* The   vardesc   union below is used to store the number of an intrinsic
-   function (when vstg == STGINTR and vprocclass == PINTRINSIC), or to
-   store the index of this external symbol in   extsymtab   (when vstg ==
-   STGEXT and vprocclass == PEXTERNAL) */
-
-	union	{
-		int varno;		/* Return variable for a function.
-					   This is used when a function is
-					   assigned a return value.  Also
-					   used to point to the COMMON
-					   block, when this is a field of
-					   that block.  Also points to
-					   EQUIV block when STGEQUIV */
-		struct Intrpacked intrdesc;	/* bits for intrinsic function*/
-		} vardesc;
-	struct Dimblock *vdim;	/* points to the dimensions if they exist */
-	ftnint voffset;		/* offset in a storage block (the variable
-				   name will be "v.%d", voffset in a
-				   common blck on the vax).  Also holds
-				   pointers for automatic variables.  When
-				   STGEQUIV, this is -(offset from array
-				   base) */
-	union	{
-		chainp namelist;	/* points to names in the NAMELIST,
-					   if this is a NAMELIST name */
-		chainp vstfdesc;	/* points to (formals, expr) pair */
-		chainp assigned_values;	/* list of integers, each being a
-					   statement label assigned to
-					   this variable in the current function */
-		} varxptr;
-	int argno;		/* for multiple entries */
-	Argtypes *arginfo;
-	};
-
-
-/* PARAMETER statements */
-
-struct Paramblock
-	{
-	field tag;
-	field vtype;
-	field vclass;
-	field vstg;
-	expptr vleng;
-	char *fvarname;
-	char *cvarname;
-	expptr paramval;
-	} ;
-
-
-/* Expression block */
-
-struct Exprblock
-	{
-	field tag;
-	field vtype;
-	field vclass;
-	field vstg;
-	expptr vleng;		/* in the case of a character expression, this
-				   value is inherited from the children */
-	unsigned opcode;
-	expptr leftp;
-	expptr rightp;
-	};
-
-
-union Constant
-	{
-	struct {
-		char *ccp0;
-		ftnint blanks;
-		} ccp1;
-	ftnint ci;		/* Constant long integer */
-	double cd[2];
-	char *cds[2];
-	};
-#define ccp ccp1.ccp0
-
-struct Constblock
-	{
-	field tag;
-	field vtype;
-	field vclass;
-	field vstg;		/* vstg = 1 when using Const.cds */
-	expptr vleng;
-	union Constant Const;
-	};
-
-
-struct Listblock
-	{
-	field tag;
-	field vtype;
-	chainp listp;
-	};
-
-
-
-/* Address block - this is the FINAL form of identifiers before being
-   sent to pass 2.  We'll want to add the original identifier here so that it can
-   be preserved in the translation.
-
-   An example identifier is q.7.  The "q" refers to the storage class
-   (field vstg), the 7 to the variable number (int memno). */
-
-struct Addrblock
-	{
-	field tag;
-	field vtype;
-	field vclass;
-	field vstg;
-	expptr vleng;
-	/* put union...user here so the beginning of an Addrblock
-	 * is the same as a Constblock.
-	 */
-	union {
-	    Namep name;		/* contains a pointer into the hash table */
-	    char ident[IDENT_LEN + 1];	/* C string form of identifier */
-	    char *Charp;
-	    union Constant Const;	/* Constant value */
-	    struct {
-		double dfill[2];
-		field vstg1;
-		} kludge;	/* so we can distinguish string vs binary
-				 * floating-point constants */
-	} user;
-	long memno;		/* when vstg == STGCONST, this is the
-				   numeric part of the assembler label
-				   where the constant value is stored */
-	expptr memoffset;	/* used in subscript computations, usually */
-	unsigned istemp:1;	/* used in stack management of temporary
-				   variables */
-	unsigned isarray:1;	/* used to show that memoffset is
-				   meaningful, even if zero */
-	unsigned ntempelt:10;	/* for representing temporary arrays, as
-				   in concatenation */
-	unsigned dbl_builtin:1;	/* builtin to be declared double */
-	unsigned charleng:1;	/* so saveargtypes can get i/o calls right */
-	ftnint varleng;		/* holds a copy of a constant length which
-				   is stored in the   vleng   field (e.g.
-				   a double is 8 bytes) */
-	int uname_tag;		/* Tag describing which of the unions()
-				   below to use */
-	char *Field;		/* field name when dereferencing a struct */
-}; /* struct Addrblock */
-
-
-/* Errorbock - placeholder for errors, to allow the compilation to
-   continue */
-
-struct Errorblock
-	{
-	field tag;
-	field vtype;
-	};
-
-
-/* Implicit DO block, especially related to DATA statements.  This block
-   keeps track of the compiler's location in the implicit DO while it's
-   running.  In particular, the   isactive and isbusy   flags tell where
-   it is */
-
-struct Impldoblock
-	{
-	field tag;
-	unsigned isactive:1;
-	unsigned isbusy:1;
-	Namep varnp;
-	Constp varvp;
-	chainp impdospec;
-	expptr implb;
-	expptr impub;
-	expptr impstep;
-	ftnint impdiff;
-	ftnint implim;
-	struct Chain *datalist;
-	};
-
-
-/* Each of these components has a first field called   tag.   This union
-   exists just for allocation simplicity */
-
-union Expression
-	{
-	field tag;
-	struct Addrblock addrblock;
-	struct Constblock constblock;
-	struct Errorblock errorblock;
-	struct Exprblock exprblock;
-	struct Headblock headblock;
-	struct Impldoblock impldoblock;
-	struct Listblock listblock;
-	struct Nameblock nameblock;
-	struct Paramblock paramblock;
-	struct Primblock primblock;
-	} ;
-
-
-
-struct Dimblock
-	{
-	int ndim;
-	expptr nelt;		/* This is NULL if the array is unbounded */
-	expptr baseoffset;	/* a constant or local variable holding
-				   the offset in this procedure */
-	expptr basexpr;		/* expression for comuting the offset, if
-				   it's not constant.  If this is
-				   non-null, the register named in
-				   baseoffset will get initialized to this
-				   value in the procedure's prolog */
-	struct
-		{
-		expptr dimsize;	/* constant or register holding the size
-				   of this dimension */
-		expptr dimexpr;	/* as above in basexpr, this is an
-				   expression for computing a variable
-				   dimension */
-		} dims[1];	/* Dimblocks are allocated with enough
-				   space for this to become dims[ndim] */
-	};
-
-
-/* Statement function identifier stack - this holds the name and value of
-   the parameters in a statement function invocation.  For example,
-
-	f(x,y,z)=x+y+z
-		.
-		.
-	y = f(1,2,3)
-
-   generates a stack of depth 3, with <x 1>, <y 2>, <z 3> AT THE INVOCATION, NOT
-   at the definition */
-
-struct Rplblock	/* name replacement block */
-	{
-	struct Rplblock *rplnextp;
-	Namep rplnp;		/* Name of the formal parameter */
-	expptr rplvp;		/* Value of the actual parameter */
-	expptr rplxp;		/* Initialization of temporary variable,
-				   if required; else null */
-	int rpltag;		/* Tag on the value of the actual param */
-	};
-
-
-
-/* Equivalence block */
-
-struct Equivblock
-	{
-	struct Eqvchain *equivs;	/* List (Eqvchain) of primblocks
-					   holding variable identifiers */
-	flag eqvinit;
-	long int eqvtop;
-	long int eqvbottom;
-	int eqvtype;
-	} ;
-#define eqvleng eqvtop
-
-extern struct Equivblock *eqvclass;
-
-
-struct Eqvchain
-	{
-	struct Eqvchain *eqvnextp;
-	union
-		{
-		struct Primblock *eqvlhs;
-		Namep eqvname;
-		} eqvitem;
-	long int eqvoffset;
-	} ;
-
-
-
-/* For allocation purposes only, and to keep lint quiet.  In particular,
-   don't count on the tag being able to tell you which structure is used */
-
-
-/* There is a tradition in Fortran that the compiler not generate the same
-   bit pattern more than is necessary.  This structure is used to do just
-   that; if two integer constants have the same bit pattern, just generate
-   it once.  This could be expanded to optimize without regard to type, by
-   removing the type check in   putconst()   */
-
-struct Literal
-	{
-	short littype;
-	short litnum;			/* numeric part of the assembler
-					   label for this constant value */
-	int lituse;		/* usage count */
-	union	{
-		ftnint litival;
-		double litdval[2];
-		ftnint litival2[2];	/* length, nblanks for strings */
-		} litval;
-	char *cds[2];
-	};
-
-extern struct Literal *litpool;
-extern int maxliterals, nliterals;
-extern char Letters[];
-#define letter(x) Letters[x]
-
-struct Dims { expptr lb, ub; };
-
-
-/* popular functions with non integer return values */
-
-
-int *ckalloc();
-char *varstr(), *nounder(), *addunder();
-char *copyn(), *copys();
-chainp hookup(), mkchain(), revchain();
-ftnint convci();
-char *convic();
-char *setdoto();
-double convcd();
-Namep mkname();
-struct Labelblock *mklabel(), *execlab();
-Extsym *mkext(), *newentry();
-expptr addrof(), call1(), call2(), call3(), call4();
-Addrp builtin(), mktmp(), mktmp0(), mktmpn(), autovar();
-Addrp mkplace(), mkaddr(), putconst(), memversion();
-expptr mkprim(), mklhs(), mkexpr(), mkconv(), mkfunct(), fixexpr(), fixtype();
-expptr errnode(), mkaddcon(), mkintcon(), putcxop();
-tagptr cpexpr();
-ftnint lmin(), lmax(), iarrlen();
-char *dbconst(), *flconst();
-
-void puteq (), putex1 ();
-expptr putx (), putsteq (), putassign ();
-
-extern int forcedouble;		/* force real functions to double */
-extern int doin_setbound;	/* special handling for array bounds */
-extern int Ansi;
-extern char *cds(), *cpstring(), *dtos(), *string_num();
-extern char *c_type_decl();
-extern char hextoi_tab[];
-#define hextoi(x) hextoi_tab[(x) & 0xff]
-extern char *casttypes[], *ftn_types[], *protorettypes[], *usedcasts[];
-extern int Castargs, infertypes;
-extern FILE *protofile;
-extern void exit(), inferdcl(), protowrite(), save_argtypes();
-extern char binread[], binwrite[], textread[], textwrite[];
-extern char *ei_first, *ei_last, *ei_next;
-extern char *wh_first, *wh_last, *wh_next;
-extern void putwhile();
-extern char *halign;
//GO.SYSIN DD defs.h
echo equiv.c 1>&2
sed >equiv.c <<'//GO.SYSIN DD equiv.c' 's/^-//'
-/****************************************************************
-Copyright 1990 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.
-****************************************************************/
-
-#include "defs.h"
-
-LOCAL eqvcommon(), eqveqv(), nsubs();
-
-/* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */
-
-/* called at end of declarations section to process chains
-   created by EQUIVALENCE statements
- */
-doequiv()
-{
-	register int i;
-	int inequiv;			/* True if one namep occurs in
-					   several EQUIV declarations */
-	int comno;		/* Index into Extsym table of the last
-				   COMMON block seen (implicitly assuming
-				   that only one will be given) */
-	int ovarno;
-	ftnint comoffset;	/* Index into the COMMON block */
-	ftnint offset;		/* Offset from array base */
-	ftnint leng;
-	register struct Equivblock *equivdecl;
-	register struct Eqvchain *q;
-	struct Primblock *primp;
-	register Namep np;
-	int k, k1, ns, pref, t;
-	chainp cp;
-	extern int type_pref[];
-
-	for(i = 0 ; i < nequiv ; ++i)
-	{
-
-/* Handle each equivalence declaration */
-
-		equivdecl = &eqvclass[i];
-		equivdecl->eqvbottom = equivdecl->eqvtop = 0;
-		comno = -1;
-
-
-
-		for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
-		{
-			offset = 0;
-			primp = q->eqvitem.eqvlhs;
-			vardcl(np = primp->namep);
-			if(primp->argsp || primp->fcharp)
-			{
-				expptr offp, suboffset();
-
-/* Pad ones onto the end of an array declaration when needed */
-
-				if(np->vdim!=NULL && np->vdim->ndim>1 &&
-				    nsubs(primp->argsp)==1 )
-				{
-					if(! ftn66flag)
-						warni
-			("1-dim subscript in EQUIVALENCE, %d-dim declared",
-						    np -> vdim -> ndim);
-					cp = NULL;
-					ns = np->vdim->ndim;
-					while(--ns > 0)
-						cp = mkchain((char *)ICON(1), cp);
-					primp->argsp->listp->nextp = cp;
-				}
-
-				offp = suboffset(primp);
-				if(ISICON(offp))
-					offset = offp->constblock.Const.ci;
-				else	{
-					dclerr
-			("nonconstant subscript in equivalence ",
-					    np);
-					np = NULL;
-				}
-				frexpr(offp);
-			}
-
-/* Free up the primblock, since we now have a hash table (Namep) entry */
-
-			frexpr((expptr)primp);
-
-			if(np && (leng = iarrlen(np))<0)
-			{
-				dclerr("adjustable in equivalence", np);
-				np = NULL;
-			}
-
-			if(np) switch(np->vstg)
-			{
-			case STGUNKNOWN:
-			case STGBSS:
-			case STGEQUIV:
-				break;
-
-			case STGCOMMON:
-
-/* The code assumes that all COMMON references in a given EQUIVALENCE will
-   be to the same COMMON block, and will all be consistent */
-
-				comno = np->vardesc.varno;
-				comoffset = np->voffset + offset;
-				break;
-
-			default:
-				dclerr("bad storage class in equivalence", np);
-				np = NULL;
-				break;
-			}
-
-			if(np)
-			{
-				q->eqvoffset = offset;
-
-/* eqvbottom   gets the largest difference between the array base address
-   and the address specified in the EQUIV declaration */
-
-				equivdecl->eqvbottom =
-				    lmin(equivdecl->eqvbottom, -offset);
-
-/* eqvtop   gets the largest difference between the end of the array and
-   the address given in the EQUIVALENCE */
-
-				equivdecl->eqvtop =
-				    lmax(equivdecl->eqvtop, leng-offset);
-			}
-			q->eqvitem.eqvname = np;
-		}
-
-/* Now all equivalenced variables are in the hash table with the proper
-   offset, and   eqvtop and eqvbottom   are set. */
-
-		if(comno >= 0)
-
-/* Get rid of all STGEQUIVS, they will be mapped onto STGCOMMON variables
-   */
-
-			eqvcommon(equivdecl, comno, comoffset);
-		else for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
-		{
-			if(np = q->eqvitem.eqvname)
-			{
-				inequiv = NO;
-				if(np->vstg==STGEQUIV)
-					if( (ovarno = np->vardesc.varno) == i)
-					{
-
-/* Can't EQUIV different elements of the same array */
-
-						if(np->voffset + q->eqvoffset != 0)
-							dclerr
-			("inconsistent equivalence", np);
-					}
-					else	{
-						offset = np->voffset;
-						inequiv = YES;
-					}
-
-				np->vstg = STGEQUIV;
-				np->vardesc.varno = i;
-				np->voffset = - q->eqvoffset;
-
-				if(inequiv)
-
-/* Combine 2 equivalence declarations */
-
-					eqveqv(i, ovarno, q->eqvoffset + offset);
-			}
-		}
-	}
-
-/* Now each equivalence declaration is distinct (all connections have been
-   merged in eqveqv()), and some may be empty. */
-
-	for(i = 0 ; i < nequiv ; ++i)
-	{
-		equivdecl = & eqvclass[i];
-		if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) {
-
-/* a live chain */
-
-			k = TYCHAR;
-			pref = 1;
-			for(q = equivdecl->equivs ; q; q = q->eqvnextp)
-			    if (np = q->eqvitem.eqvname){
-				np->voffset -= equivdecl->eqvbottom;
-				t = typealign[k1 = np->vtype];
-				if (pref < type_pref[k1]) {
-					k = k1;
-					pref = type_pref[k1];
-					}
-				if(np->voffset % t != 0) {
-					dclerr("bad alignment forced by equivalence", np);
-					--nerr; /* don't give bad return code for this */
-					}
-				}
-			equivdecl->eqvtype = k;
-		}
-		freqchain(equivdecl);
-	}
-}
-
-
-
-
-
-/* put equivalence chain p at common block comno + comoffset */
-
-LOCAL eqvcommon(p, comno, comoffset)
-struct Equivblock *p;
-int comno;
-ftnint comoffset;
-{
-	int ovarno;
-	ftnint k, offq;
-	register Namep np;
-	register struct Eqvchain *q;
-
-	if(comoffset + p->eqvbottom < 0)
-	{
-		errstr("attempt to extend common %s backward",
-		    extsymtab[comno].fextname);
-		freqchain(p);
-		return;
-	}
-
-	if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng)
-		extsymtab[comno].extleng = k;
-
-
-	for(q = p->equivs ; q ; q = q->eqvnextp)
-		if(np = q->eqvitem.eqvname)
-		{
-			switch(np->vstg)
-			{
-			case STGUNKNOWN:
-			case STGBSS:
-				np->vstg = STGCOMMON;
-				np->vcommequiv = 1;
-				np->vardesc.varno = comno;
-
-/* np -> voffset   will point to the base of the array */
-
-				np->voffset = comoffset - q->eqvoffset;
-				break;
-
-			case STGEQUIV:
-				ovarno = np->vardesc.varno;
-
-/* offq   will point to the current element, even if it's in an array */
-
-				offq = comoffset - q->eqvoffset - np->voffset;
-				np->vstg = STGCOMMON;
-				np->vcommequiv = 1;
-				np->vardesc.varno = comno;
-
-/* np -> voffset   will point to the base of the array */
-
-				np->voffset += offq;
-				if(ovarno != (p - eqvclass))
-					eqvcommon(&eqvclass[ovarno], comno, offq);
-				break;
-
-			case STGCOMMON:
-				if(comno != np->vardesc.varno ||
-				    comoffset != np->voffset+q->eqvoffset)
-					dclerr("inconsistent common usage", np);
-				break;
-
-
-			default:
-				badstg("eqvcommon", np->vstg);
-			}
-		}
-
-	freqchain(p);
-	p->eqvbottom = p->eqvtop = 0;
-}
-
-
-/* Move all items on ovarno chain to the front of   nvarno   chain.
- * adjust offsets of ovarno elements and top and bottom of nvarno chain
- */
-
-LOCAL eqveqv(nvarno, ovarno, delta)
-int ovarno, nvarno;
-ftnint delta;
-{
-	register struct Equivblock *neweqv, *oldeqv;
-	register Namep np;
-	struct Eqvchain *q, *q1;
-
-	neweqv = eqvclass + nvarno;
-	oldeqv = eqvclass + ovarno;
-	neweqv->eqvbottom = lmin(neweqv->eqvbottom, oldeqv->eqvbottom - delta);
-	neweqv->eqvtop = lmax(neweqv->eqvtop, oldeqv->eqvtop - delta);
-	oldeqv->eqvbottom = oldeqv->eqvtop = 0;
-
-	for(q = oldeqv->equivs ; q ; q = q1)
-	{
-		q1 = q->eqvnextp;
-		if( (np = q->eqvitem.eqvname) && np->vardesc.varno==ovarno)
-		{
-			q->eqvnextp = neweqv->equivs;
-			neweqv->equivs = q;
-			q->eqvoffset += delta;
-			np->vardesc.varno = nvarno;
-			np->voffset -= delta;
-		}
-		else	free( (charptr) q);
-	}
-	oldeqv->equivs = NULL;
-}
-
-
-
-
-freqchain(p)
-register struct Equivblock *p;
-{
-	register struct Eqvchain *q, *oq;
-
-	for(q = p->equivs ; q ; q = oq)
-	{
-		oq = q->eqvnextp;
-		free( (charptr) q);
-	}
-	p->equivs = NULL;
-}
-
-
-
-
-
-/* nsubs -- number of subscripts in this arglist (just the length of the
-   list) */
-
-LOCAL nsubs(p)
-register struct Listblock *p;
-{
-	register int n;
-	register chainp q;
-
-	n = 0;
-	if(p)
-		for(q = p->listp ; q ; q = q->nextp)
-			++n;
-
-	return(n);
-}
//GO.SYSIN DD equiv.c
echo error.c 1>&2
sed >error.c <<'//GO.SYSIN DD error.c' 's/^-//'
-/****************************************************************
-Copyright 1990 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.
-****************************************************************/
-
-#include "defs.h"
-
-warni(s,t)
- char *s;
- int t;
-{
-	char buf[100];
-	sprintf(buf,s,t);
-	warn(buf);
-	}
-
-warn1(s,t)
-char *s, *t;
-{
-	char buff[100];
-	sprintf(buff, s, t);
-	warn(buff);
-}
-
-
-warn(s)
-char *s;
-{
-	if(nowarnflag)
-		return;
-	if (infname && *infname)
-		fprintf(diagfile, "Warning on line %ld of %s: %s\n",
-			lineno, infname, s);
-	else
-		fprintf(diagfile, "Warning on line %ld: %s\n", lineno, s);
-	fflush(diagfile);
-	++nwarn;
-}
-
-
-errstr(s, t)
-char *s, *t;
-{
-	char buff[100];
-	sprintf(buff, s, t);
-	err(buff);
-}
-
-
-
-erri(s,t)
-char *s;
-int t;
-{
-	char buff[100];
-	sprintf(buff, s, t);
-	err(buff);
-}
-
-errl(s,t)
-char *s;
-long t;
-{
-	char buff[100];
-	sprintf(buff, s, t);
-	err(buff);
-}
-
- char *err_proc = 0;
-
-err(s)
-char *s;
-{
-	if (err_proc)
-		fprintf(diagfile,
-			"Error processing %s before line %ld",
-			err_proc, lineno);
-	else
-		fprintf(diagfile, "Error on line %ld", lineno);
-	if (infname && *infname)
-		fprintf(diagfile, " of %s", infname);
-	fprintf(diagfile, ": %s\n", s);
-	fflush(diagfile);
-	++nerr;
-}
-
-
-yyerror(s)
-char *s;
-{
-	err(s);
-}
-
-
-
-dclerr(s, v)
-char *s;
-Namep v;
-{
-	char buff[100];
-
-	if(v)
-	{
-		sprintf(buff, "Declaration error for %s: %s", v->fvarname, s);
-		err(buff);
-	}
-	else
-		errstr("Declaration error %s", s);
-}
-
-
-
-execerr(s, n)
-char *s, *n;
-{
-	char buf1[100], buf2[100];
-
-	sprintf(buf1, "Execution error %s", s);
-	sprintf(buf2, buf1, n);
-	err(buf2);
-}
-
-
-Fatal(t)
-char *t;
-{
-	fprintf(diagfile, "Compiler error line %ld", lineno);
-	if (infname)
-		fprintf(diagfile, " of %s", infname);
-	fprintf(diagfile, ": %s\n", t);
-	done(3);
-}
-
-
-
-
-fatalstr(t,s)
-char *t, *s;
-{
-	char buff[100];
-	sprintf(buff, t, s);
-	Fatal(buff);
-}
-
-
-
-fatali(t,d)
-char *t;
-int d;
-{
-	char buff[100];
-	sprintf(buff, t, d);
-	Fatal(buff);
-}
-
-
-
-badthing(thing, r, t)
-char *thing, *r;
-int t;
-{
-	char buff[50];
-	sprintf(buff, "Impossible %s %d in routine %s", thing, t, r);
-	Fatal(buff);
-}
-
-
-
-badop(r, t)
-char *r;
-int t;
-{
-	badthing("opcode", r, t);
-}
-
-
-
-badtag(r, t)
-char *r;
-int t;
-{
-	badthing("tag", r, t);
-}
-
-
-
-
-
-badstg(r, t)
-char *r;
-int t;
-{
-	badthing("storage class", r, t);
-}
-
-
-
-
-badtype(r, t)
-char *r;
-int t;
-{
-	badthing("type", r, t);
-}
-
-
-many(s, c, n)
-char *s, c;
-int n;
-{
-	char buff[250];
-
-	sprintf(buff,
-	    "Too many %s.\nTable limit now %d.\nTry recompiling using the -N%c%d option\n",
-	    s, n, c, 2*n);
-	Fatal(buff);
-}
-
-
-err66(s)
-char *s;
-{
-	errstr("Fortran 77 feature used: %s", s);
-	--nerr;
-}
-
-
-
-errext(s)
-char *s;
-{
-	errstr("F77 compiler extension used: %s", s);
-	--nerr;
-}
//GO.SYSIN DD error.c
echo exec.c 1>&2
sed >exec.c <<'//GO.SYSIN DD exec.c' 's/^-//'
-/****************************************************************
-Copyright 1990 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.
-****************************************************************/
-
-#include "defs.h"
-#include "p1defs.h"
-#include "names.h"
-
-LOCAL void exar2(), popctl(), pushctl();
-
-/*   Logical IF codes
-*/
-
-
-exif(p)
-expptr p;
-{
-    pushctl(CTLIF);
-    putif(p, 0);	/* 0 => if, not elseif */
-}
-
-
-
-exelif(p)
-expptr p;
-{
-    if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
-	putif(p, 1);	/* 1 ==> elseif */
-    else
-	execerr("elseif out of place", CNULL);
-}
-
-
-
-
-
-exelse()
-{
-	register struct Ctlframe *c;
-
-	for(c = ctlstack; c->ctltype == CTLIFX; --c);
-	if(c->ctltype == CTLIF) {
-		p1_else ();
-		c->ctltype = CTLELSE;
-		}
-	else
-		execerr("else out of place", CNULL);
-	}
-
-
-exendif()
-{
-	while(ctlstack->ctltype == CTLIFX) {
-		popctl();
-		p1else_end();
-		}
-	if(ctlstack->ctltype == CTLIF) {
-		popctl();
-		p1_endif ();
-		}
-	else if(ctlstack->ctltype == CTLELSE) {
-		popctl();
-		p1else_end ();
-		}
-	else
-		execerr("endif out of place", CNULL);
-	}
-
-
-new_endif()
-{
-	if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
-		pushctl(CTLIFX);
-	else
-		err("new_endif bug");
-	}
-
-/* pushctl -- Start a new control construct, initialize the labels (to
-   zero) */
-
- LOCAL void
-pushctl(code)
- int code;
-{
-	register int i;
-
-	if(++ctlstack >= lastctl)
-		many("loops or if-then-elses", 'c', maxctl);
-	ctlstack->ctltype = code;
-	for(i = 0 ; i < 4 ; ++i)
-		ctlstack->ctlabels[i] = 0;
-	ctlstack->dowhile = 0;
-	++blklevel;
-}
-
-
- LOCAL void
-popctl()
-{
-	if( ctlstack-- < ctls )
-		Fatal("control stack empty");
-	--blklevel;
-}
-
-
-
-/* poplab -- update the flags in   labeltab   */
-
-LOCAL poplab()
-{
-	register struct Labelblock  *lp;
-
-	for(lp = labeltab ; lp < highlabtab ; ++lp)
-		if(lp->labdefined)
-		{
-			/* mark all labels in inner blocks unreachable */
-			if(lp->blklevel > blklevel)
-				lp->labinacc = YES;
-		}
-		else if(lp->blklevel > blklevel)
-		{
-			/* move all labels referred to in inner blocks out a level */
-			lp->blklevel = blklevel;
-		}
-}
-
-
-/*  BRANCHING CODE
-*/
-
-exgoto(lab)
-struct Labelblock *lab;
-{
-	lab->labused = 1;
-	p1_goto (lab -> stateno);
-}
-
-
-
-
-
-
-
-exequals(lp, rp)
-register struct Primblock *lp;
-register expptr rp;
-{
-	if(lp->tag != TPRIM)
-	{
-		err("assignment to a non-variable");
-		frexpr((expptr)lp);
-		frexpr(rp);
-	}
-	else if(lp->namep->vclass!=CLVAR && lp->argsp)
-	{
-		if(parstate >= INEXEC)
-			err("statement function amid executables");
-		mkstfunct(lp, rp);
-	}
-	else
-	{
-		expptr new_lp, new_rp;
-
-		if(parstate < INDATA)
-			enddcl();
-		new_lp = mklhs (lp);
-		new_rp = fixtype (rp);
-		puteq(new_lp, new_rp);
-	}
-}
-
-
-
-/* Make Statement Function */
-
-long laststfcn = -1, thisstno;
-int doing_stmtfcn;
-
-mkstfunct(lp, rp)
-struct Primblock *lp;
-expptr rp;
-{
-	register struct Primblock *p;
-	register Namep np;
-	chainp args;
-
-	laststfcn = thisstno;
-	np = lp->namep;
-	if(np->vclass == CLUNKNOWN)
-		np->vclass = CLPROC;
-	else
-	{
-		dclerr("redeclaration of statement function", np);
-		return;
-	}
-	np->vprocclass = PSTFUNCT;
-	np->vstg = STGSTFUNCT;
-
-/* Set the type of the function */
-
-	impldcl(np);
-	if (np->vtype == TYCHAR && !np->vleng)
-		err("character statement function with length (*)");
-	args = (lp->argsp ? lp->argsp->listp : CHNULL);
-	np->varxptr.vstfdesc = mkchain((char *)args, (chainp)rp);
-
-	for(doing_stmtfcn = 1 ; args ; args = args->nextp)
-
-/* It is an error for the formal parameters to have arguments or
-   subscripts */
-
-		if( ((tagptr)(args->datap))->tag!=TPRIM ||
-		    (p = (struct Primblock *)(args->datap) )->argsp ||
-		    p->fcharp || p->lcharp )
-			err("non-variable argument in statement function definition");
-		else
-		{
-
-/* Replace the name on the left-hand side */
-
-			args->datap = (char *)p->namep;
-			vardcl(p -> namep);
-			free((char *)p);
-		}
-	doing_stmtfcn = 0;
-}
-
- static void
-mixed_type(np)
- Namep np;
-{
-	char buf[128];
-	sprintf(buf, "%s function %.90s invoked as subroutine",
-		ftn_types[np->vtype], np->fvarname);
-	warn(buf);
-	}
-
-
-excall(name, args, nstars, labels)
-Namep name;
-struct Listblock *args;
-int nstars;
-struct Labelblock *labels[ ];
-{
-	register expptr p;
-
-	if (name->vtype != TYSUBR) {
-		if (name->vinfproc && !name->vcalled) {
-			name->vtype = TYSUBR;
-			frexpr(name->vleng);
-			name->vleng = 0;
-			}
-		else if (!name->vimpltype && name->vtype != TYUNKNOWN)
-			mixed_type(name);
-		else
-			settype(name, TYSUBR, (ftnint)0);
-		}
-	p = mkfunct( mkprim(name, args, CHNULL) );
-
-/* Subroutines and their identifiers acquire the type INT */
-
-	p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
-
-/* Handle the alternate return mechanism */
-
-	if(nstars > 0)
-		putcmgo(putx(fixtype(p)), nstars, labels);
-	else
-		putexpr(p);
-}
-
-
-
-exstop(stop, p)
-int stop;
-register expptr p;
-{
-	char *str;
-	int n;
-	expptr mkstrcon();
-
-	if(p)
-	{
-		if( ! ISCONST(p) )
-		{
-			execerr("pause/stop argument must be constant", CNULL);
-			frexpr(p);
-			p = mkstrcon(0, CNULL);
-		}
-		else if( ISINT(p->constblock.vtype) )
-		{
-			str = convic(p->constblock.Const.ci);
-			n = strlen(str);
-			if(n > 0)
-			{
-				p->constblock.Const.ccp = copyn(n, str);
-				p->constblock.Const.ccp1.blanks = 0;
-				p->constblock.vtype = TYCHAR;
-				p->constblock.vleng = (expptr) ICON(n);
-			}
-			else
-				p = (expptr) mkstrcon(0, CNULL);
-		}
-		else if(p->constblock.vtype != TYCHAR)
-		{
-			execerr("pause/stop argument must be integer or string", CNULL);
-			p = (expptr) mkstrcon(0, CNULL);
-		}
-	}
-	else	p = (expptr) mkstrcon(0, CNULL);
-
-    {
-	expptr subr_call;
-
-	subr_call = call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p);
-	putexpr( subr_call );
-    }
-}
-
-/* DO LOOP CODE */
-
-#define DOINIT	par[0]
-#define DOLIMIT	par[1]
-#define DOINCR	par[2]
-
-
-/* Macros for   ctlstack -> dostepsign   */
-
-#define VARSTEP	0
-#define POSSTEP	1
-#define NEGSTEP	2
-
-
-/* exdo -- generate DO loop code.  In the case of a variable increment,
-   positive increment tests are placed above the body, negative increment
-   tests are placed below (see   enddo()   ) */
-
-exdo(range, loopname, spec)
-int range;			/* end label */
-Namep loopname;
-chainp spec;			/* input spec must have at least 2 exprs */
-{
-	register expptr p;
-	register Namep np;
-	chainp cp;		/* loops over the fields in   spec */
-	register int i;
-	int dotype;		/* type of the index variable */
-	int incsign;		/* sign of the increment, if it's constant
-				   */
-	Addrp dovarp;		/* loop index variable */
-	expptr doinit;		/* constant or register for init param */
-	expptr par[3];		/* local specification parameters */
-
-	expptr init, test, inc;	/* Expressions in the resulting FOR loop */
-
-
-	test = ENULL;
-
-	pushctl(CTLDO);
-	dorange = ctlstack->dolabel = range;
-	ctlstack->loopname = loopname;
-
-/* Declare the loop index */
-
-	np = (Namep)spec->datap;
-	ctlstack->donamep = NULL;
-	if (!np) { /* do while */
-		ctlstack->dowhile = 1;
-#if 0
-		if (loopname) {
-			if (loopname->vtype == TYUNKNOWN) {
-				loopname->vdcldone = 1;
-				loopname->vclass = CLLABEL;
-				loopname->vprocclass = PLABEL;
-				loopname->vtype = TYLABEL;
-				}
-			if (loopname->vtype == TYLABEL)
-				if (loopname->vdovar)
-					dclerr("already in use as a loop name",
-						loopname);
-				else
-					loopname->vdovar = 1;
-			else
-				dclerr("already declared; cannot be a loop name",
-					loopname);
-			}
-#endif
-		putwhile((expptr)spec->nextp);
-		NOEXT("do while");
-		spec->nextp = 0;
-		frchain(&spec);
-		return;
-		}
-	if(np->vdovar)
-	{
-		errstr("nested loops with variable %s", np->fvarname);
-		ctlstack->donamep = NULL;
-		return;
-	}
-
-/* Create a memory-resident version of the index variable */
-
-	dovarp = mkplace(np);
-	if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) )
-	{
-		err("bad type on do variable");
-		return;
-	}
-	ctlstack->donamep = np;
-
-	np->vdovar = YES;
-
-/* Now   dovarp   points to the index to be used within the loop,   dostgp
-   points to the one which may need to be stored */
-
-	dotype = dovarp->vtype;
-
-/* Count the input specifications and type-check each one independently;
-   this just eliminates non-numeric values from the specification */
-
-	for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
-	{
-		p = par[i++] = fixtype((tagptr)cp->datap);
-		if( ! ONEOF(p->headblock.vtype, MSKINT|MSKREAL) )
-		{
-			err("bad type on DO parameter");
-			return;
-		}
-	}
-
-	frchain(&spec);
-	switch(i)
-	{
-	case 0:
-	case 1:
-		err("too few DO parameters");
-		return;
-
-	default:
-		err("too many DO parameters");
-		return;
-
-	case 2:
-		DOINCR = (expptr) ICON(1);
-
-	case 3:
-		break;
-	}
-
-
-/* Now all of the local specification fields are set, but their types are
-   not yet consistent */
-
-/* Declare the loop initialization value, casting it properly and declaring a
-   register if need be */
-
-	if (ISCONST (DOINIT) || !onetripflag)
-/* putx added 6-29-89 (mwm), not sure if fixtype is required, but I doubt it
-   since mkconv is called just before */
-		doinit = putx (mkconv (dotype, DOINIT));
-	else {
-	    doinit = (expptr) mktmp(dotype, ENULL);
-	    puteq (cpexpr (doinit), DOINIT);
-	} /* else */
-
-/* Declare the loop ending value, casting it to the type of the index
-   variable */
-
-	if( ISCONST(DOLIMIT) )
-		ctlstack->domax = mkconv(dotype, DOLIMIT);
-	else {
-		ctlstack->domax = (expptr) mktmp0(dotype, ENULL);
-		puteq (cpexpr (ctlstack -> domax), DOLIMIT);
-	} /* else */
-
-/* Declare the loop increment value, casting it to the type of the index
-   variable */
-
-	if( ISCONST(DOINCR) )
-	{
-		ctlstack->dostep = mkconv(dotype, DOINCR);
-		if( (incsign = conssgn(ctlstack->dostep)) == 0)
-			err("zero DO increment");
-		ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
-	}
-	else
-	{
-		ctlstack->dostep = (expptr) mktmp0(dotype, ENULL);
-		ctlstack->dostepsign = VARSTEP;
-		puteq (cpexpr (ctlstack -> dostep), DOINCR);
-	}
-
-/* All data is now properly typed and in the   ctlstack,   except for the
-   initial value.  Assignments of temps have been generated already */
-
-	switch (ctlstack -> dostepsign) {
-	    case VARSTEP:
-		test = mkexpr (OPQUEST, mkexpr (OPLT,
-			cpexpr (ctlstack -> dostep), ICON(0)),
-			mkexpr (OPCOLON,
-			    mkexpr (OPGE, cpexpr((expptr)dovarp),
-				    cpexpr (ctlstack -> domax)),
-			    mkexpr (OPLE, cpexpr((expptr)dovarp),
-				    cpexpr (ctlstack -> domax))));
-		break;
-	    case POSSTEP:
-	        test = mkexpr (OPLE, cpexpr((expptr)dovarp),
-			cpexpr (ctlstack -> domax));
-	        break;
-	    case NEGSTEP:
-	        test = mkexpr (OPGE, cpexpr((expptr)dovarp),
-			cpexpr (ctlstack -> domax));
-	        break;
-	    default:
-	        erri ("exdo:  bad dostepsign '%d'", ctlstack -> dostepsign);
-	        break;
-	} /* switch (ctlstack -> dostepsign) */
-
-	if (onetripflag)
-	    test = mkexpr (OPOR, test,
-		    mkexpr (OPEQ, cpexpr((expptr)dovarp), cpexpr (doinit)));
-	init = mkexpr (OPASSIGN, cpexpr((expptr)dovarp), doinit);
-	inc = mkexpr (OPPLUSEQ, (expptr)dovarp, cpexpr (ctlstack -> dostep));
-
-	if (!onetripflag && ISCONST (ctlstack -> domax) && ISCONST (doinit)
-		&& ctlstack -> dostepsign != VARSTEP) {
-	    expptr tester;
-
-	    tester = mkexpr (OPMINUS, cpexpr (doinit),
-		    cpexpr (ctlstack -> domax));
-	    if (incsign == conssgn (tester))
-		warn ("DO range never executed");
-	    frexpr (tester);
-	} /* if !onetripflag && */
-
-	p1_for (init, test, inc);
-}
-
-exenddo(np)
- Namep np;
-{
-	Namep np1;
-	int here;
-	struct Ctlframe *cf;
-
-	if( ctlstack < ctls )
-		Fatal("control stack empty");
-	here = ctlstack->dolabel;
-	if (ctlstack->ctltype != CTLDO
-	|| here >= 0 && (!thislabel || thislabel->labelno != here)) {
-		err("misplaced ENDDO");
-		return;
-		}
-	if (np != ctlstack->loopname) {
-		if (np1 = ctlstack->loopname)
-			errstr("expected \"enddo %s\"", np1->fvarname);
-		else
-			err("expected unnamed ENDDO");
-		for(cf = ctls; cf < ctlstack; cf++)
-			if (cf->ctltype == CTLDO && cf->loopname == np) {
-				here = cf->dolabel;
-				break;
-				}
-		}
-	enddo(here);
-	}
-
-
-enddo(here)
-int here;
-{
-	register struct Ctlframe *q;
-	Namep np;			/* name of the current DO index */
-	Addrp ap;
-	register int i;
-	register expptr e;
-
-/* Many DO's can end at the same statement, so keep looping over all
-   nested indicies */
-
-	while(here == dorange)
-	{
-		if(np = ctlstack->donamep)
-			{
-			p1for_end ();
-
-/* Now we're done with all of the tests, and the loop has terminated.
-   Store the index value back in long-term memory */
-
-			if(ap = memversion(np))
-				puteq((expptr)ap, (expptr)mkplace(np));
-			for(i = 0 ; i < 4 ; ++i)
-				ctlstack->ctlabels[i] = 0;
-			deregister(ctlstack->donamep);
-			ctlstack->donamep->vdovar = NO;
-			e = ctlstack->dostep;
-			if (e->tag == TADDR && e->addrblock.istemp)
-				frtemp((Addrp)e);
-			else
-				frexpr(e);
-			e = ctlstack->domax;
-			if (e->tag == TADDR && e->addrblock.istemp)
-				frtemp((Addrp)e);
-			else
-				frexpr(e);
-			}
-		else if (ctlstack->dowhile)
-			p1for_end ();
-
-/* Set   dorange   to the closing label of the next most enclosing DO loop
-   */
-
-		popctl();
-		poplab();
-		dorange = 0;
-		for(q = ctlstack ; q>=ctls ; --q)
-			if(q->ctltype == CTLDO)
-			{
-				dorange = q->dolabel;
-				break;
-			}
-	}
-}
-
-exassign(vname, labelval)
- register Namep vname;
-struct Labelblock *labelval;
-{
-	Addrp p;
-	expptr mkaddcon();
-	register Addrp q;
-	static char nullstr[] = "";
-	char *fs;
-	register chainp cp, cpprev;
-	register ftnint k, stno;
-
-	p = mkplace(vname);
-	if( ! ONEOF(p->vtype, MSKINT|MSKADDR) ) {
-		err("noninteger assign variable");
-		return;
-		}
-
-	/* If the label hasn't been defined, then we do things twice:
-	 * once for an executable stmt label, once for a format
-	 */
-
-	/* code for executable label... */
-
-/* Now store the assigned value in a list associated with this variable.
-   This will be used later to generate a switch() statement in the C output */
-
-	if (!labelval->labdefined || !labelval->fmtstring) {
-
-		if (vname -> vis_assigned == 0) {
-			vname -> varxptr.assigned_values = CHNULL;
-			vname -> vis_assigned = 1;
-			}
-
-		/* don't duplicate labels... */
-
-		stno = labelval->stateno;
-		cpprev = 0;
-		for(k = 0, cp = vname->varxptr.assigned_values;
-				cp; cpprev = cp, cp = cp->nextp, k++)
-			if ((ftnint)cp->datap == stno)
-				break;
-		if (!cp) {
-			cp = mkchain((char *)stno, CHNULL);
-			if (cpprev)
-				cpprev->nextp = cp;
-			else
-				vname->varxptr.assigned_values = cp;
-			labelval->labused = 1;
-			}
-		putout(mkexpr(OPASSIGN, (expptr)p, mkintcon(k)));
-		}
-
-	/* Code for FORMAT label... */
-
-	fs = labelval->fmtstring;
-	if (!labelval->labdefined || fs && fs != nullstr) {
-		extern void fmtname();
-
-		if (!fs)
-			labelval->fmtstring = nullstr;
-		labelval->fmtlabused = 1;
-		p = ALLOC(Addrblock);
-		p->tag = TADDR;
-		p->vtype = TYCHAR;
-		p->vstg = STGAUTO;
-		p->memoffset = ICON(0);
-		fmtname(vname, p);
-		q = ALLOC(Addrblock);
-		q->tag = TADDR;
-		q->vtype = TYCHAR;
-		q->vstg = STGAUTO;
-		q->ntempelt = 1;
-		q->memoffset = ICON(0);
-		q->uname_tag = UNAM_IDENT;
-		sprintf(q->user.ident, "fmt_%ld", labelval->stateno);
-		putout(mkexpr(OPASSIGN, (expptr)p, (expptr)q));
-		}
-
-} /* exassign */
-
-
-
-exarif(expr, neglab, zerlab, poslab)
-expptr expr;
-struct Labelblock *neglab, *zerlab, *poslab;
-{
-    register int lm, lz, lp;
-
-    lm = neglab->stateno;
-    lz = zerlab->stateno;
-    lp = poslab->stateno;
-    expr = fixtype(expr);
-
-    if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) )
-    {
-        err("invalid type of arithmetic if expression");
-        frexpr(expr);
-    }
-    else
-    {
-        if (lm == lz && lz == lp)
-            exgoto (neglab);
-        else if(lm == lz)
-            exar2(OPLE, expr, neglab, poslab);
-        else if(lm == lp)
-            exar2(OPNE, expr, neglab, zerlab);
-        else if(lz == lp)
-            exar2(OPGE, expr, zerlab, neglab);
-        else {
-            expptr t;
-
-	    if (!addressable (expr)) {
-		t = (expptr) mktmp(expr -> headblock.vtype, ENULL);
-		expr = mkexpr (OPASSIGN, cpexpr (t), expr);
-	    } else
-		t = (expptr) cpexpr (expr);
-
-	    p1_if(putx(fixtype(mkexpr (OPLT, expr, ICON (0)))));
-	    exgoto(neglab);
-	    p1_elif (mkexpr (OPEQ, t, ICON (0)));
-	    exgoto(zerlab);
-	    p1_else ();
-	    exgoto(poslab);
-	    p1else_end ();
-        } /* else */
-    }
-}
-
-
-
-/* exar2 -- Do arithmetic IF for only 2 distinct labels;   if !(e.op.0)
-   goto l2 else goto l1.  If this seems backwards, that's because it is,
-   in order to make the 1 pass algorithm work. */
-
- LOCAL void
-exar2(op, e, l1, l2)
- int op;
- expptr e;
- struct Labelblock *l1, *l2;
-{
-	expptr comp;
-
-	comp = mkexpr (op, e, ICON (0));
-	p1_if(putx(fixtype(comp)));
-	exgoto(l1);
-	p1_else ();
-	exgoto(l2);
-	p1else_end ();
-}
-
-
-/* exreturn -- return the value in   p  from a SUBROUTINE call -- used to
-   implement the alternate return mechanism */
-
-exreturn(p)
-register expptr p;
-{
-	if(procclass != CLPROC)
-		warn("RETURN statement in main or block data");
-	if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
-	{
-		err("alternate return in nonsubroutine");
-		p = 0;
-	}
-
-	if (p || proctype == TYSUBR) {
-		if (p == ENULL) p = ICON (0);
-		p = mkconv (TYLONG, fixtype (p));
-		p1_subr_ret (p);
-	} /* if p || proctype == TYSUBR */
-	else
-	    p1_subr_ret((expptr)retslot);
-}
-
-
-exasgoto(labvar)
-Namep labvar;
-{
-	register Addrp p;
-	void p1_asgoto();
-
-	p = mkplace(labvar);
-	if( ! ISINT(p->vtype) )
-		err("assigned goto variable must be integer");
-	else {
-		p1_asgoto (p);
-	} /* else */
-}
//GO.SYSIN DD exec.c
echo expr.c 1>&2
sed >expr.c <<'//GO.SYSIN DD expr.c' 's/^-//'
-/****************************************************************
-Copyright 1990, 1991, 1992 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.
-****************************************************************/
-
-#include "defs.h"
-#include "output.h"
-#include "names.h"
-
-LOCAL void conspower(), consbinop(), zdiv();
-LOCAL expptr fold(), mkpower(), stfcall();
-#ifndef stfcall_MAX
-#define stfcall_MAX 144
-#endif
-
-typedef struct { double dreal, dimag; } dcomplex;
-
-extern char dflttype[26];
-
-/* little routines to create constant blocks */
-
-Constp mkconst(t)
-register int t;
-{
-	register Constp p;
-
-	p = ALLOC(Constblock);
-	p->tag = TCONST;
-	p->vtype = t;
-	return(p);
-}
-
-
-/* mklogcon -- Make Logical Constant */
-
-expptr mklogcon(l)
-register int l;
-{
-	register Constp  p;
-
-	p = mkconst(TYLOGICAL);
-	p->Const.ci = l;
-	return( (expptr) p );
-}
-
-
-
-/* mkintcon -- Make Integer Constant */
-
-expptr mkintcon(l)
-ftnint l;
-{
-	register Constp p;
-
-	p = mkconst(tyint);
-	p->Const.ci = l;
-	return( (expptr) p );
-}
-
-
-
-
-/* mkaddcon -- Make Address Constant, given integer value */
-
-expptr mkaddcon(l)
-register long l;
-{
-	register Constp p;
-
-	p = mkconst(TYADDR);
-	p->Const.ci = l;
-	return( (expptr) p );
-}
-
-
-
-/* mkrealcon -- Make Real Constant.  The type t is assumed
-   to be TYREAL or TYDREAL */
-
-expptr mkrealcon(t, d)
- register int t;
- char *d;
-{
-	register Constp p;
-
-	p = mkconst(t);
-	p->Const.cds[0] = cds(d,CNULL);
-	p->vstg = 1;
-	return( (expptr) p );
-}
-
-
-/* mkbitcon -- Make bit constant.  Reads the input string, which is
-   assumed to correctly specify a number in base 2^shift (where   shift
-   is the input parameter).   shift   may not exceed 4, i.e. only binary,
-   quad, octal and hex bases may be input.  Constants may not exceed 32
-   bits, or whatever the size of (struct Constblock).ci may be. */
-
-expptr mkbitcon(shift, leng, s)
-int shift;
-int leng;
-char *s;
-{
-	register Constp p;
-	register long x;
-
-	p = mkconst(TYLONG);
-	x = 0;
-	while(--leng >= 0)
-		if(*s != ' ')
-			x = (x << shift) | hextoi(*s++);
-	/* mwm wanted to change the type to short for short constants,
-	 * but this is dangerous -- there is no syntax for long constants
-	 * with small values.
-	 */
-	p->Const.ci = x;
-	return( (expptr) p );
-}
-
-
-
-
-
-/* mkstrcon -- Make string constant.  Allocates storage and initializes
-   the memory for a copy of the input Fortran-string. */
-
-expptr mkstrcon(l,v)
-int l;
-register char *v;
-{
-	register Constp p;
-	register char *s;
-
-	p = mkconst(TYCHAR);
-	p->vleng = ICON(l);
-	p->Const.ccp = s = (char *) ckalloc(l+1);
-	p->Const.ccp1.blanks = 0;
-	while(--l >= 0)
-		*s++ = *v++;
-	*s = '\0';
-	return( (expptr) p );
-}
-
-
-
-/* mkcxcon -- Make complex contsant.  A complex number is a pair of
-   values, each of which may be integer, real or double. */
-
-expptr mkcxcon(realp,imagp)
-register expptr realp, imagp;
-{
-	int rtype, itype;
-	register Constp p;
-	expptr errnode();
-
-	rtype = realp->headblock.vtype;
-	itype = imagp->headblock.vtype;
-
-	if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
-	{
-		p = mkconst( (rtype==TYDREAL||itype==TYDREAL)
-				? TYDCOMPLEX : tycomplex);
-		if (realp->constblock.vstg || imagp->constblock.vstg) {
-			p->vstg = 1;
-			p->Const.cds[0] = ISINT(rtype)
-				? string_num("", realp->constblock.Const.ci)
-				: realp->constblock.vstg
-					? realp->constblock.Const.cds[0]
-					: dtos(realp->constblock.Const.cd[0]);
-			p->Const.cds[1] = ISINT(itype)
-				? string_num("", imagp->constblock.Const.ci)
-				: imagp->constblock.vstg
-					? imagp->constblock.Const.cds[0]
-					: dtos(imagp->constblock.Const.cd[0]);
-			}
-		else {
-			p->Const.cd[0] = ISINT(rtype)
-				? realp->constblock.Const.ci
-				: realp->constblock.Const.cd[0];
-			p->Const.cd[1] = ISINT(itype)
-				? imagp->constblock.Const.ci
-				: imagp->constblock.Const.cd[0];
-			}
-	}
-	else
-	{
-		err("invalid complex constant");
-		p = (Constp)errnode();
-	}
-
-	frexpr(realp);
-	frexpr(imagp);
-	return( (expptr) p );
-}
-
-
-/* errnode -- Allocate a new error block */
-
-expptr errnode()
-{
-	struct Errorblock *p;
-	p = ALLOC(Errorblock);
-	p->tag = TERROR;
-	p->vtype = TYERROR;
-	return( (expptr) p );
-}
-
-
-
-
-
-/* mkconv -- Make type conversion.  Cast expression   p   into type   t.
-   Note that casting to a character copies only the first sizeof(char)
-   bytes. */
-
-expptr mkconv(t, p)
-register int t;
-register expptr p;
-{
-	register expptr q;
-	register int pt, charwarn = 1;
-	expptr opconv();
-
-	if (t >= 100) {
-		t -= 100;
-		charwarn = 0;
-		}
-	if(t==TYUNKNOWN || t==TYERROR)
-		badtype("mkconv", t);
-	pt = p->headblock.vtype;
-
-/* Casting to the same type is a no-op */
-
-	if(t == pt)
-		return(p);
-
-/* If we're casting a constant which is not in the literal table ... */
-
-	else if( ISCONST(p) && pt!=TYADDR && pt != TYCHAR)
-	{
-		if (ISINT(t) && ISINT(pt) || ISREAL(t) && ISREAL(pt)) {
-			/* avoid trouble with -i2 */
-			p->headblock.vtype = t;
-			return p;
-			}
-		q = (expptr) mkconst(t);
-		consconv(t, &q->constblock, &p->constblock );
-		frexpr(p);
-	}
-	else {
-		if (pt == TYCHAR && t != TYADDR && charwarn)
-			warn(
-		 "ichar([first char. of] char. string) assumed for conversion to numeric");
-		q = opconv(p, t);
-		}
-
-	if(t == TYCHAR)
-		q->constblock.vleng = ICON(1);
-	return(q);
-}
-
-
-
-/* opconv -- Convert expression   p   to type   t   using the main
-   expression evaluator; returns an OPCONV expression, I think  14-jun-88 mwm */
-
-expptr opconv(p, t)
-expptr p;
-int t;
-{
-	register expptr q;
-
-	if (t == TYSUBR)
-		err("illegal use of subroutine name");
-	q = mkexpr(OPCONV, p, ENULL);
-	q->headblock.vtype = t;
-	return(q);
-}
-
-
-
-/* addrof -- Create an ADDR expression operation */
-
-expptr addrof(p)
-expptr p;
-{
-	return( mkexpr(OPADDR, p, ENULL) );
-}
-
-
-
-/* cpexpr - Returns a new copy of input expression   p   */
-
-tagptr cpexpr(p)
-register tagptr p;
-{
-	register tagptr e;
-	int tag;
-	register chainp ep, pp;
-	tagptr cpblock();
-
-/* This table depends on the ordering of the T macros, e.g. TNAME */
-
-	static int blksize[ ] =
-	{
-		0,
-		sizeof(struct Nameblock),
-		sizeof(struct Constblock),
-		sizeof(struct Exprblock),
-		sizeof(struct Addrblock),
-		sizeof(struct Primblock),
-		sizeof(struct Listblock),
-		sizeof(struct Impldoblock),
-		sizeof(struct Errorblock)
-	};
-
-	if(p == NULL)
-		return(NULL);
-
-/* TNAMEs are special, and don't get copied.  Each name in the current
-   symbol table has a unique TNAME structure. */
-
-	if( (tag = p->tag) == TNAME)
-		return(p);
-
-	e = cpblock(blksize[p->tag], (char *)p);
-
-	switch(tag)
-	{
-	case TCONST:
-		if(e->constblock.vtype == TYCHAR)
-		{
-			e->constblock.Const.ccp =
-			    copyn((int)e->constblock.vleng->constblock.Const.ci+1,
-				e->constblock.Const.ccp);
-			e->constblock.vleng =
-			    (expptr) cpexpr(e->constblock.vleng);
-		}
-	case TERROR:
-		break;
-
-	case TEXPR:
-		e->exprblock.leftp =  (expptr) cpexpr(p->exprblock.leftp);
-		e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp);
-		break;
-
-	case TLIST:
-		if(pp = p->listblock.listp)
-		{
-			ep = e->listblock.listp =
-			    mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL);
-			for(pp = pp->nextp ; pp ; pp = pp->nextp)
-				ep = ep->nextp =
-				    mkchain((char *)cpexpr((tagptr)pp->datap),
-						CHNULL);
-		}
-		break;
-
-	case TADDR:
-		e->addrblock.vleng = (expptr)  cpexpr(e->addrblock.vleng);
-		e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset);
-		e->addrblock.istemp = NO;
-		break;
-
-	case TPRIM:
-		e->primblock.argsp = (struct Listblock *)
-		    cpexpr((expptr)e->primblock.argsp);
-		e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp);
-		e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp);
-		break;
-
-	default:
-		badtag("cpexpr", tag);
-	}
-
-	return(e);
-}
-
-/* frexpr -- Free expression -- frees up memory used by expression   p   */
-
-frexpr(p)
-register tagptr p;
-{
-	register chainp q;
-
-	if(p == NULL)
-		return;
-
-	switch(p->tag)
-	{
-	case TCONST:
-		if( ISCHAR(p) )
-		{
-			free( (charptr) (p->constblock.Const.ccp) );
-			frexpr(p->constblock.vleng);
-		}
-		break;
-
-	case TADDR:
-		if (p->addrblock.vtype > TYERROR)	/* i/o block */
-			break;
-		frexpr(p->addrblock.vleng);
-		frexpr(p->addrblock.memoffset);
-		break;
-
-	case TERROR:
-		break;
-
-/* TNAME blocks don't get free'd - probably because they're pointed to in
-   the hash table. 14-Jun-88 -- mwm */
-
-	case TNAME:
-		return;
-
-	case TPRIM:
-		frexpr((expptr)p->primblock.argsp);
-		frexpr(p->primblock.fcharp);
-		frexpr(p->primblock.lcharp);
-		break;
-
-	case TEXPR:
-		frexpr(p->exprblock.leftp);
-		if(p->exprblock.rightp)
-			frexpr(p->exprblock.rightp);
-		break;
-
-	case TLIST:
-		for(q = p->listblock.listp ; q ; q = q->nextp)
-			frexpr((tagptr)q->datap);
-		frchain( &(p->listblock.listp) );
-		break;
-
-	default:
-		badtag("frexpr", p->tag);
-	}
-
-	free( (charptr) p );
-}
-
- void
-wronginf(np)
- Namep np;
-{
-	int c, k;
-	warn1("fixing wrong type inferred for %.65s", np->fvarname);
-	np->vinftype = 0;
-	c = letter(np->fvarname[0]);
-	if ((np->vtype = impltype[c]) == TYCHAR
-	&& (k = implleng[c]))
-		np->vleng = ICON(k);
-	}
-
-/* fix up types in expression; replace subtrees and convert
-   names to address blocks */
-
-expptr fixtype(p)
-register tagptr p;
-{
-
-	if(p == 0)
-		return(0);
-
-	switch(p->tag)
-	{
-	case TCONST:
-		if(ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR|
-		    MSKREAL) )
-			return( (expptr) p);
-
-		return( (expptr) putconst((Constp)p) );
-
-	case TADDR:
-		p->addrblock.memoffset = fixtype(p->addrblock.memoffset);
-		return( (expptr) p);
-
-	case TERROR:
-		return( (expptr) p);
-
-	default:
-		badtag("fixtype", p->tag);
-
-/* This case means that   fixexpr   can't call   fixtype   with any expr,
-   only a subexpr of its parameter. */
-
-	case TEXPR:
-		return( fixexpr((Exprp)p) );
-
-	case TLIST:
-		return( (expptr) p );
-
-	case TPRIM:
-		if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR)
-		{
-			if(p->primblock.namep->vtype == TYSUBR)
-			{
-				err("function invocation of subroutine");
-				return( errnode() );
-			}
-			else {
-				if (p->primblock.namep->vinftype)
-					wronginf(p->primblock.namep);
-				return( mkfunct(p) );
-				}
-		}
-
-/* The lack of args makes   p   a function name, substring reference
-   or variable name. */
-
-		else	return( mklhs((struct Primblock *) p) );
-	}
-}
-
-
- int
-badchleng(p) register expptr p;
-{
-	if (!p->headblock.vleng) {
-		if (p->headblock.tag == TADDR
-		&& p->addrblock.uname_tag == UNAM_NAME)
-			errstr("bad use of character*(*) variable %.60s",
-				p->addrblock.user.name->fvarname);
-		else
-			err("Bad use of character*(*)");
-		return 1;
-		}
-	return 0;
-	}
-
-
- static expptr
-cplenexpr(p)
- expptr p;
-{
-	expptr rv;
-
-	if (badchleng(p))
-		return ICON(1);
-	rv = cpexpr(p->headblock.vleng);
-	if (ISCONST(p) && p->constblock.vtype == TYCHAR)
-		rv->constblock.Const.ci += p->constblock.Const.ccp1.blanks;
-	return rv;
-	}
-
-
-/* special case tree transformations and cleanups of expression trees.
-   Parameter   p   should have a TEXPR tag at its root, else an error is
-   returned */
-
-expptr fixexpr(p)
-register Exprp p;
-{
-	expptr lp;
-	register expptr rp;
-	register expptr q;
-	int opcode, ltype, rtype, ptype, mtype;
-
-	if( ISERROR(p) )
-		return( (expptr) p );
-	else if(p->tag != TEXPR)
-		badtag("fixexpr", p->tag);
-	opcode = p->opcode;
-
-/* First set the types of the left and right subexpressions */
-
-	lp = p->leftp;
-	if (!ISCONST(lp) || lp->constblock.vtype != TYCHAR)
-		lp = p->leftp = fixtype(lp);
-	ltype = lp->headblock.vtype;
-
-	if(opcode==OPASSIGN && lp->tag!=TADDR)
-	{
-		err("left side of assignment must be variable");
-		frexpr((expptr)p);
-		return( errnode() );
-	}
-
-	if(rp = p->rightp)
-	{
-		if (!ISCONST(rp) || rp->constblock.vtype != TYCHAR)
-			rp = p->rightp = fixtype(rp);
-		rtype = rp->headblock.vtype;
-	}
-	else
-		rtype = 0;
-
-	if(ltype==TYERROR || rtype==TYERROR)
-	{
-		frexpr((expptr)p);
-		return( errnode() );
-	}
-
-/* Now work on the whole expression */
-
-	/* force folding if possible */
-
-	if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
-	{
-		q = opcode == OPCONV && lp->constblock.vtype == p->vtype
-			? lp : mkexpr(opcode, lp, rp);
-
-/* mkexpr is expected to reduce constant expressions */
-
-		if( ISCONST(q) ) {
-			p->leftp = p->rightp = 0;
-			frexpr((expptr)p);
-			return(q);
-			}
-		free( (charptr) q );	/* constants did not fold */
-	}
-
-	if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
-	{
-		frexpr((expptr)p);
-		return( errnode() );
-	}
-
-	if (ltype == TYCHAR && ISCONST(lp))
-		p->leftp =  lp = (expptr)putconst((Constp)lp);
-	if (rtype == TYCHAR && ISCONST(rp))
-		p->rightp = rp = (expptr)putconst((Constp)rp);
-
-	switch(opcode)
-	{
-	case OPCONCAT:
-		if(p->vleng == NULL)
-			p->vleng = mkexpr(OPPLUS, cplenexpr(lp),
-					cplenexpr(rp) );
-		break;
-
-	case OPASSIGN:
-		if (rtype == TYREAL)
-			break;
-	case OPPLUSEQ:
-	case OPSTAREQ:
-		if(ltype == rtype)
-			break;
-		if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
-			break;
-		if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
-			break;
-		if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
-		    && typesize[ltype]>=typesize[rtype] )
-			    break;
-
-/* Cast the right hand side to match the type of the expression */
-
-		p->rightp = fixtype( mkconv(ptype, rp) );
-		break;
-
-	case OPSLASH:
-		if( ISCOMPLEX(rtype) )
-		{
-			p = (Exprp) call2(ptype,
-
-/* Handle double precision complex variables */
-
-			    ptype == TYCOMPLEX ? "c_div" : "z_div",
-			    mkconv(ptype, lp), mkconv(ptype, rp) );
-			break;
-		}
-	case OPPLUS:
-	case OPMINUS:
-	case OPSTAR:
-	case OPMOD:
-		if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
-		    (rtype==TYREAL && ! ISCONST(rp) ) ))
-			break;
-		if( ISCOMPLEX(ptype) )
-			break;
-
-/* Cast both sides of the expression to match the type of the whole
-   expression.  */
-
-		if(ltype != ptype && (ltype < TYSHORT || ptype > TYDREAL))
-			p->leftp = fixtype(mkconv(ptype,lp));
-		if(rtype != ptype && (rtype < TYSHORT || ptype > TYDREAL))
-			p->rightp = fixtype(mkconv(ptype,rp));
-		break;
-
-	case OPPOWER:
-		return( mkpower((expptr)p) );
-
-	case OPLT:
-	case OPLE:
-	case OPGT:
-	case OPGE:
-	case OPEQ:
-	case OPNE:
-		if(ltype == rtype)
-			break;
-		mtype = cktype(OPMINUS, ltype, rtype);
-		if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) ||
-		    (rtype==TYREAL && ! ISCONST(rp)) ))
-			break;
-		if( ISCOMPLEX(mtype) )
-			break;
-		if(ltype != mtype)
-			p->leftp = fixtype(mkconv(mtype,lp));
-		if(rtype != mtype)
-			p->rightp = fixtype(mkconv(mtype,rp));
-		break;
-
-	case OPCONV:
-		ptype = cktype(OPCONV, p->vtype, ltype);
-		if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA
-		 && !ISCOMPLEX(ptype))
-		{
-			lp->exprblock.rightp =
-			    fixtype( mkconv(ptype, lp->exprblock.rightp) );
-			free( (charptr) p );
-			p = (Exprp) lp;
-		}
-		break;
-
-	case OPADDR:
-		if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR)
-			Fatal("addr of addr");
-		break;
-
-	case OPCOMMA:
-	case OPQUEST:
-	case OPCOLON:
-		break;
-
-	case OPMIN:
-	case OPMAX:
-	case OPMIN2:
-	case OPMAX2:
-	case OPDMIN:
-	case OPDMAX:
-	case OPABS:
-	case OPDABS:
-		ptype = p->vtype;
-		break;
-
-	default:
-		break;
-	}
-
-	p->vtype = ptype;
-	return((expptr) p);
-}
-
-
-/* fix an argument list, taking due care for special first level cases */
-
-fixargs(doput, p0)
-int doput;	/* doput is true if constants need to be passed by reference */
-struct Listblock *p0;
-{
-	register chainp p;
-	register tagptr q, t;
-	register int qtag;
-	int nargs;
-	Addrp mkscalar();
-
-	nargs = 0;
-	if(p0)
-		for(p = p0->listp ; p ; p = p->nextp)
-		{
-			++nargs;
-			q = (tagptr)p->datap;
-			qtag = q->tag;
-			if(qtag == TCONST)
-			{
-
-/* Call putconst() to store values in a constant table.  Since even
-   constants must be passed by reference, this can optimize on the storage
-   required */
-
-				p->datap = doput ? (char *)putconst((Constp)q)
-						 : (char *)q;
-			}
-
-/* Take a function name and turn it into an Addr.  This only happens when
-   nothing else has figured out the function beforehand */
-
-			else if(qtag==TPRIM && q->primblock.argsp==0 &&
-			    q->primblock.namep->vclass==CLPROC &&
-			    q->primblock.namep->vprocclass != PTHISPROC)
-				p->datap = (char *)mkaddr(q->primblock.namep);
-
-			else if(qtag==TPRIM && q->primblock.argsp==0 &&
-			    q->primblock.namep->vdim!=NULL)
-				p->datap = (char *)mkscalar(q->primblock.namep);
-
-			else if(qtag==TPRIM && q->primblock.argsp==0 &&
-			    q->primblock.namep->vdovar &&
-			    (t = (tagptr) memversion(q->primblock.namep)) )
-				p->datap = (char *)fixtype(t);
-			else
-				p->datap = (char *)fixtype(q);
-		}
-	return(nargs);
-}
-
-
-
-/* mkscalar -- only called by   fixargs   above, and by some routines in
-   io.c */
-
-Addrp mkscalar(np)
-register Namep np;
-{
-	register Addrp ap;
-
-	vardcl(np);
-	ap = mkaddr(np);
-
-	/* The prolog causes array arguments to point to the
-	 * (0,...,0) element, unless subscript checking is on.
-	 */
-	if( !checksubs && np->vstg==STGARG)
-	{
-		register struct Dimblock *dp;
-		dp = np->vdim;
-		frexpr(ap->memoffset);
-		ap->memoffset = mkexpr(OPSTAR,
-		    (np->vtype==TYCHAR ?
-		    cpexpr(np->vleng) :
-		    (tagptr)ICON(typesize[np->vtype]) ),
-		    cpexpr(dp->baseoffset) );
-	}
-	return(ap);
-}
-
-
- static void
-adjust_arginfo(np)	/* adjust arginfo to omit the length arg for the
-			   arg that we now know to be a character-valued
-			   function */
- register Namep np;
-{
-	struct Entrypoint *ep;
-	register chainp args;
-	Argtypes *at;
-
-	for(ep = entries; ep; ep = ep->entnextp)
-		for(args = ep->arglist; args; args = args->nextp)
-			if (np == (Namep)args->datap
-			&& (at = ep->entryname->arginfo))
-				--at->nargs;
-	}
-
-
-
-expptr mkfunct(p0)
- expptr p0;
-{
-	register struct Primblock *p = (struct Primblock *)p0;
-	struct Entrypoint *ep;
-	Addrp ap;
-	Extsym *extp;
-	register Namep np;
-	register expptr q;
-	expptr intrcall();
-	extern chainp new_procs;
-	int k, nargs;
-	int class;
-
-	if(p->tag != TPRIM)
-		return( errnode() );
-
-	np = p->namep;
-	class = np->vclass;
-
-
-	if(class == CLUNKNOWN)
-	{
-		np->vclass = class = CLPROC;
-		if(np->vstg == STGUNKNOWN)
-		{
-			if(np->vtype!=TYSUBR && (k = intrfunct(np->fvarname))
-				&& (zflag || !(*(struct Intrpacked *)&k).f4
-					|| dcomplex_seen))
-			{
-				np->vstg = STGINTR;
-				np->vardesc.varno = k;
-				np->vprocclass = PINTRINSIC;
-			}
-			else
-			{
-				extp = mkext(np->fvarname,
-					addunder(np->cvarname));
-				extp->extstg = STGEXT;
-				np->vstg = STGEXT;
-				np->vardesc.varno = extp - extsymtab;
-				np->vprocclass = PEXTERNAL;
-			}
-		}
-		else if(np->vstg==STGARG)
-		{
-		    if(np->vtype == TYCHAR) {
-			adjust_arginfo(np);
-			if (np->vpassed) {
-				char wbuf[160], *who;
-				who = np->fvarname;
-				sprintf(wbuf, "%s%s%s\n\t%s%s%s",
-					"Character-valued dummy procedure ",
-					who, " not declared EXTERNAL.",
-			"Code may be wrong for previous function calls having ",
-					who, " as a parameter.");
-				warn(wbuf);
-				}
-			}
-		    np->vprocclass = PEXTERNAL;
-		}
-	}
-
-	if(class != CLPROC) {
-		if (np->vstg == STGCOMMON)
-			fatalstr(
-			 "Cannot invoke common variable %.50s as a function.",
-				np->fvarname);
-		fatali("invalid class code %d for function", class);
-		}
-
-/* F77 doesn't allow subscripting of function calls */
-
-	if(p->fcharp || p->lcharp)
-	{
-		err("no substring of function call");
-		goto error;
-	}
-	impldcl(np);
-	np->vimpltype = 0;	/* invoking as function ==> inferred type */
-	np->vcalled = 1;
-	nargs = fixargs( np->vprocclass!=PINTRINSIC,  p->argsp);
-
-	switch(np->vprocclass)
-	{
-	case PEXTERNAL:
-		if(np->vtype == TYUNKNOWN)
-		{
-			dclerr("attempt to use untyped function", np);
-			np->vtype = dflttype[letter(np->fvarname[0])];
-		}
-		ap = mkaddr(np);
-		if (!extsymtab[np->vardesc.varno].extseen) {
-			new_procs = mkchain((char *)np, new_procs);
-			extsymtab[np->vardesc.varno].extseen = 1;
-			}
-call:
-		q = mkexpr(OPCALL, (expptr)ap, (expptr)p->argsp);
-		q->exprblock.vtype = np->vtype;
-		if(np->vleng)
-			q->exprblock.vleng = (expptr) cpexpr(np->vleng);
-		break;
-
-	case PINTRINSIC:
-		q = intrcall(np, p->argsp, nargs);
-		break;
-
-	case PSTFUNCT:
-		q = stfcall(np, p->argsp);
-		break;
-
-	case PTHISPROC:
-		warn("recursive call");
-
-/* entries   is the list of multiple entry points */
-
-		for(ep = entries ; ep ; ep = ep->entnextp)
-			if(ep->enamep == np)
-				break;
-		if(ep == NULL)
-			Fatal("mkfunct: impossible recursion");
-
-		ap = builtin(np->vtype, ep->entryname->cextname, -2);
-		/* the negative last arg prevents adding */
-		/* this name to the list of used builtins */
-		goto call;
-
-	default:
-		fatali("mkfunct: impossible vprocclass %d",
-		    (int) (np->vprocclass) );
-	}
-	free( (charptr) p );
-	return(q);
-
-error:
-	frexpr((expptr)p);
-	return( errnode() );
-}
-
-
-
-LOCAL expptr stfcall(np, actlist)
-Namep np;
-struct Listblock *actlist;
-{
-	register chainp actuals;
-	int nargs;
-	chainp oactp, formals;
-	int type;
-	expptr Ln, Lq, q, q1, rhs, ap;
-	Namep tnp;
-	register struct Rplblock *rp;
-	struct Rplblock *tlist;
-	static int inv_count;
-
-	if (++inv_count > stfcall_MAX)
-		Fatal("Loop invoking recursive statement function?");
-	if(actlist)
-	{
-		actuals = actlist->listp;
-		free( (charptr) actlist);
-	}
-	else
-		actuals = NULL;
-	oactp = actuals;
-
-	nargs = 0;
-	tlist = NULL;
-	if( (type = np->vtype) == TYUNKNOWN)
-	{
-		dclerr("attempt to use untyped statement function", np);
-		type = np->vtype = dflttype[letter(np->fvarname[0])];
-	}
-	formals = (chainp) np->varxptr.vstfdesc->datap;
-	rhs = (expptr) (np->varxptr.vstfdesc->nextp);
-
-	/* copy actual arguments into temporaries */
-	while(actuals!=NULL && formals!=NULL)
-	{
-		rp = ALLOC(Rplblock);
-		rp->rplnp = tnp = (Namep) formals->datap;
-		ap = fixtype((tagptr)actuals->datap);
-		if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR
-		    && (ap->tag==TCONST || ap->tag==TADDR) )
-		{
-
-/* If actuals are constants or variable names, no temporaries are required */
-			rp->rplvp = (expptr) ap;
-			rp->rplxp = NULL;
-			rp->rpltag = ap->tag;
-		}
-		else	{
-			rp->rplvp = (expptr) mktmp(tnp->vtype, tnp->vleng);
-			rp -> rplxp = NULL;
-			putexpr ( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap));
-			if((rp->rpltag = rp->rplvp->tag) == TERROR)
-				err("disagreement of argument types in statement function call");
-		}
-		rp->rplnextp = tlist;
-		tlist = rp;
-		actuals = actuals->nextp;
-		formals = formals->nextp;
-		++nargs;
-	}
-
-	if(actuals!=NULL || formals!=NULL)
-		err("statement function definition and argument list differ");
-
-	/*
-   now push down names involved in formal argument list, then
-   evaluate rhs of statement function definition in this environment
-*/
-
-	if(tlist)	/* put tlist in front of the rpllist */
-	{
-		for(rp = tlist; rp->rplnextp; rp = rp->rplnextp)
-			;
-		rp->rplnextp = rpllist;
-		rpllist = tlist;
-	}
-
-/* So when the expression finally gets evaled, that evaluator must read
-   from the globl   rpllist   14-jun-88 mwm */
-
-	q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) );
-
-	/* get length right of character-valued statement functions... */
-	if (type == TYCHAR
-	 && (Ln = np->vleng)
-	 && q->tag != TERROR
-	 && (Lq = q->exprblock.vleng)
-	 && (Lq->tag != TCONST
-		|| Ln->constblock.Const.ci != Lq->constblock.Const.ci)) {
-		q1 = (expptr) mktmp(type, Ln);
-		putexpr ( mkexpr(OPASSIGN, cpexpr(q1), q));
-		q = q1;
-		}
-
-	/* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
-	while(--nargs >= 0)
-	{
-		if(rpllist->rplxp)
-			q = mkexpr(OPCOMMA, rpllist->rplxp, q);
-		rp = rpllist->rplnextp;
-		frexpr(rpllist->rplvp);
-		free((char *)rpllist);
-		rpllist = rp;
-	}
-	frchain( &oactp );
-	--inv_count;
-	return(q);
-}
-
-
-static int replaced;
-
-/* mkplace -- Figure out the proper storage class for the input name and
-   return an addrp with the appropriate stuff */
-
-Addrp mkplace(np)
-register Namep np;
-{
-	register Addrp s;
-	register struct Rplblock *rp;
-	int regn;
-
-	/* is name on the replace list? */
-
-	for(rp = rpllist ; rp ; rp = rp->rplnextp)
-	{
-		if(np == rp->rplnp)
-		{
-			replaced = 1;
-			if(rp->rpltag == TNAME)
-			{
-				np = (Namep) (rp->rplvp);
-				break;
-			}
-			else	return( (Addrp) cpexpr(rp->rplvp) );
-		}
-	}
-
-	/* is variable a DO index in a register ? */
-
-	if(np->vdovar && ( (regn = inregister(np)) >= 0) )
-		if(np->vtype == TYERROR)
-			return((Addrp) errnode() );
-		else
-		{
-			s = ALLOC(Addrblock);
-			s->tag = TADDR;
-			s->vstg = STGREG;
-			s->vtype = TYIREG;
-			s->memno = regn;
-			s->memoffset = ICON(0);
-			s -> uname_tag = UNAM_NAME;
-			s -> user.name = np;
-			return(s);
-		}
-
-	if (np->vclass == CLPROC && np->vprocclass != PTHISPROC)
-		errstr("external %.60s used as a variable", np->fvarname);
-	vardcl(np);
-	return(mkaddr(np));
-}
-
-
- static int doing_vleng;
-
-/* mklhs -- Compute the actual address of the given expression; account
-   for array subscripts, stack offset, and substring offsets.  The f -> C
-   translator will need this only to worry about the subscript stuff */
-
-expptr mklhs(p)
-register struct Primblock *p;
-{
-	expptr suboffset();
-	register Addrp s;
-	Namep np;
-
-	if(p->tag != TPRIM)
-		return( (expptr) p );
-	np = p->namep;
-
-	replaced = 0;
-	s = mkplace(np);
-	if(s->tag!=TADDR || s->vstg==STGREG)
-	{
-		free( (charptr) p );
-		return( (expptr) s );
-	}
-
-	/* compute the address modified by subscripts */
-
-	if (!replaced)
-		s->memoffset = mkexpr(OPPLUS, s->memoffset, suboffset(p) );
-	frexpr((expptr)p->argsp);
-	p->argsp = NULL;
-
-	/* now do substring part */
-
-	if(p->fcharp || p->lcharp)
-	{
-		if(np->vtype != TYCHAR)
-			errstr("substring of noncharacter %s", np->fvarname);
-		else	{
-			if(p->lcharp == NULL)
-				p->lcharp = (expptr) cpexpr(s->vleng);
-			if(p->fcharp) {
-				doing_vleng = 1;
-				s->vleng = fixtype(mkexpr(OPMINUS,
-						p->lcharp,
-					mkexpr(OPMINUS, p->fcharp, ICON(1) )));
-				doing_vleng = 0;
-				}
-			else	{
-				frexpr(s->vleng);
-				s->vleng = p->lcharp;
-			}
-		}
-	}
-
-	s->vleng = fixtype( s->vleng );
-	s->memoffset = fixtype( s->memoffset );
-	free( (charptr) p );
-	return( (expptr) s );
-}
-
-
-
-
-
-/* deregister -- remove a register allocation from the list; assumes that
-   names are deregistered in stack order (LIFO order - Last In First Out) */
-
-deregister(np)
-Namep np;
-{
-	if(nregvar>0 && regnamep[nregvar-1]==np)
-	{
-		--nregvar;
-	}
-}
-
-
-
-
-/* memversion -- moves a DO index REGISTER into a memory location; other
-   objects are passed through untouched */
-
-Addrp memversion(np)
-register Namep np;
-{
-	register Addrp s;
-
-	if(np->vdovar==NO || (inregister(np)<0) )
-		return(NULL);
-	np->vdovar = NO;
-	s = mkplace(np);
-	np->vdovar = YES;
-	return(s);
-}
-
-
-
-/* inregister -- looks for the input name in the global list   regnamep */
-
-inregister(np)
-register Namep np;
-{
-	register int i;
-
-	for(i = 0 ; i < nregvar ; ++i)
-		if(regnamep[i] == np)
-			return( regnum[i] );
-	return(-1);
-}
-
-
-
-/* suboffset -- Compute the offset from the start of the array, given the
-   subscripts as arguments */
-
-expptr suboffset(p)
-register struct Primblock *p;
-{
-	int n;
-	expptr si, size;
-	chainp cp;
-	expptr e, e1, offp, prod;
-	expptr subcheck();
-	struct Dimblock *dimp;
-	expptr sub[MAXDIM+1];
-	register Namep np;
-
-	np = p->namep;
-	offp = ICON(0);
-	n = 0;
-	if(p->argsp)
-		for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
-		{
-			si = fixtype(cpexpr((tagptr)cp->datap));
-			if (!ISINT(si->headblock.vtype)) {
-				NOEXT("non-integer subscript");
-				si = mkconv(TYLONG, si);
-				}
-			sub[n++] = si;
-			if(n > maxdim)
-			{
-				erri("more than %d subscripts", maxdim);
-				break;
-			}
-		}
-
-	dimp = np->vdim;
-	if(n>0 && dimp==NULL)
-		errstr("subscripts on scalar variable %.68s", np->fvarname);
-	else if(dimp && dimp->ndim!=n)
-		errstr("wrong number of subscripts on %.68s", np->fvarname);
-	else if(n > 0)
-	{
-		prod = sub[--n];
-		while( --n >= 0)
-			prod = mkexpr(OPPLUS, sub[n],
-			    mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
-		if(checksubs || np->vstg!=STGARG)
-			prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
-
-/* Add in the run-time bounds check */
-
-		if(checksubs)
-			prod = subcheck(np, prod);
-		size = np->vtype == TYCHAR ?
-		    (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]);
-		prod = mkexpr(OPSTAR, prod, size);
-		offp = mkexpr(OPPLUS, offp, prod);
-	}
-
-/* Check for substring indicator */
-
-	if(p->fcharp && np->vtype==TYCHAR) {
-		e = p->fcharp;
-		e1 = mkexpr(OPMINUS, cpexpr(e), ICON(1));
-		if (!ISCONST(e) && (e->tag != TPRIM || e->primblock.argsp)) {
-			e = (expptr)mktmp(TYLONG, ENULL);
-			putout(putassign(cpexpr(e), e1));
-			p->fcharp = mkexpr(OPPLUS, cpexpr(e), ICON(1));
-			e1 = e;
-			}
-		offp = mkexpr(OPPLUS, offp, e1);
-		}
-	return(offp);
-}
-
-
-
-
-expptr subcheck(np, p)
-Namep np;
-register expptr p;
-{
-	struct Dimblock *dimp;
-	expptr t, checkvar, checkcond, badcall;
-
-	dimp = np->vdim;
-	if(dimp->nelt == NULL)
-		return(p);	/* don't check arrays with * bounds */
-	np->vlastdim = 0;
-	if( ISICON(p) )
-	{
-
-/* check for negative (constant) offset */
-
-		if(p->constblock.Const.ci < 0)
-			goto badsub;
-		if( ISICON(dimp->nelt) )
-
-/* see if constant offset exceeds the array declaration */
-
-			if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci)
-				return(p);
-			else
-				goto badsub;
-	}
-
-/* We know that the subscript offset   p   or   dimp -> nelt   is not a constant.
-   Now find a register to use for run-time bounds checking */
-
-	if(p->tag==TADDR && p->addrblock.vstg==STGREG)
-	{
-		checkvar = (expptr) cpexpr(p);
-		t = p;
-	}
-	else	{
-		checkvar = (expptr) mktmp(p->headblock.vtype, ENULL);
-		t = mkexpr(OPASSIGN, cpexpr(checkvar), p);
-	}
-	checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) );
-	if( ! ISICON(p) )
-		checkcond = mkexpr(OPAND, checkcond,
-		    mkexpr(OPLE, ICON(0), cpexpr(checkvar)) );
-
-/* Construct the actual test */
-
-	badcall = call4(p->headblock.vtype, "s_rnge",
-	    mkstrcon(strlen(np->fvarname), np->fvarname),
-	    mkconv(TYLONG,  cpexpr(checkvar)),
-	    mkstrcon(strlen(procname), procname),
-	    ICON(lineno) );
-	badcall->exprblock.opcode = OPCCALL;
-	p = mkexpr(OPQUEST, checkcond,
-	    mkexpr(OPCOLON, checkvar, badcall));
-
-	return(p);
-
-badsub:
-	frexpr(p);
-	errstr("subscript on variable %s out of range", np->fvarname);
-	return ( ICON(0) );
-}
-
-
-
-
-Addrp mkaddr(p)
-register Namep p;
-{
-	Extsym *extp;
-	register Addrp t;
-	Addrp intraddr();
-	int k;
-
-	switch( p->vstg)
-	{
-	case STGAUTO:
-		if(p->vclass == CLPROC && p->vprocclass == PTHISPROC)
-			return (Addrp) cpexpr((expptr)xretslot[p->vtype]);
-		goto other;
-
-	case STGUNKNOWN:
-		if(p->vclass != CLPROC)
-			break;	/* Error */
-		extp = mkext(p->fvarname, addunder(p->cvarname));
-		extp->extstg = STGEXT;
-		p->vstg = STGEXT;
-		p->vardesc.varno = extp - extsymtab;
-		p->vprocclass = PEXTERNAL;
-		if ((extp->exproto || infertypes)
-		&& (p->vtype == TYUNKNOWN || p->vimpltype)
-		&& (k = extp->extype))
-			inferdcl(p, k);
-
-
-	case STGCOMMON:
-	case STGEXT:
-	case STGBSS:
-	case STGINIT:
-	case STGEQUIV:
-	case STGARG:
-	case STGLENG:
- other:
-		t = ALLOC(Addrblock);
-		t->tag = TADDR;
-
-		t->vclass = p->vclass;
-		t->vtype = p->vtype;
-		t->vstg = p->vstg;
-		t->memno = p->vardesc.varno;
-		t->memoffset = ICON(p->voffset);
-		if (p->vdim)
-		    t->isarray = 1;
-		if(p->vleng)
-		{
-			t->vleng = (expptr) cpexpr(p->vleng);
-			if( ISICON(t->vleng) )
-				t->varleng = t->vleng->constblock.Const.ci;
-		}
-
-/* Keep the original name around for the C code generation */
-
-		t -> uname_tag = UNAM_NAME;
-		t -> user.name = p;
-		return(t);
-
-	case STGINTR:
-
-		return ( intraddr (p));
-	}
-	badstg("mkaddr", p->vstg);
-	/* NOT REACHED */ return 0;
-}
-
-
-
-
-/* mkarg -- create storage for a new parameter.  This is called when a
-   function returns a string (for the return value, which is the first
-   parameter), or when a variable-length string is passed to a function. */
-
-Addrp mkarg(type, argno)
-int type, argno;
-{
-	register Addrp p;
-
-	p = ALLOC(Addrblock);
-	p->tag = TADDR;
-	p->vtype = type;
-	p->vclass = CLVAR;
-
-/* TYLENG is the type of the field holding the length of a character string */
-
-	p->vstg = (type==TYLENG ? STGLENG : STGARG);
-	p->memno = argno;
-	return(p);
-}
-
-
-
-
-/* mkprim -- Create a PRIM (primary/primitive) block consisting of a
-   Nameblock (or Paramblock), arguments (actual params or array
-   subscripts) and substring bounds.  Requires that   v   have lots of
-   extra (uninitialized) storage, since it could be a paramblock or
-   nameblock */
-
-expptr mkprim(v0, args, substr)
- Namep v0;
- struct Listblock *args;
- chainp substr;
-{
-	typedef union {
-		struct Paramblock paramblock;
-		struct Nameblock nameblock;
-		struct Headblock headblock;
-		} *Primu;
-	register Primu v = (Primu)v0;
-	register struct Primblock *p;
-
-	if(v->headblock.vclass == CLPARAM)
-	{
-
-/* v   is to be a Paramblock */
-
-		if(args || substr)
-		{
-			errstr("no qualifiers on parameter name %s",
-			    v->paramblock.fvarname);
-			frexpr((expptr)args);
-			if(substr)
-			{
-				frexpr((tagptr)substr->datap);
-				frexpr((tagptr)substr->nextp->datap);
-				frchain(&substr);
-			}
-			frexpr((expptr)v);
-			return( errnode() );
-		}
-		return( (expptr) cpexpr(v->paramblock.paramval) );
-	}
-
-	p = ALLOC(Primblock);
-	p->tag = TPRIM;
-	p->vtype = v->nameblock.vtype;
-
-/* v   is to be a Nameblock */
-
-	p->namep = (Namep) v;
-	p->argsp = args;
-	if(substr)
-	{
-		p->fcharp = (expptr) substr->datap;
-		p->lcharp = (expptr) substr->nextp->datap;
-		frchain(&substr);
-	}
-	return( (expptr) p);
-}
-
-
-
-/* vardcl -- attempt to fill out the Name template for variable   v.
-   This function is called on identifiers known to be variables or
-   recursive references to the same function */
-
-vardcl(v)
-register Namep v;
-{
-	struct Dimblock *t;
-	expptr neltp;
-	extern int doing_stmtfcn;
-
-	if(v->vclass == CLUNKNOWN) {
-		v->vclass = CLVAR;
-		if (v->vinftype) {
-			v->vtype = TYUNKNOWN;
-			if (v->vdcldone) {
-				v->vdcldone = 0;
-				impldcl(v);
-				}
-			}
-		}
-	if(v->vdcldone)
-		return;
-	if(v->vclass == CLNAMELIST)
-		return;
-
-	if(v->vtype == TYUNKNOWN)
-		impldcl(v);
-	else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC)
-	{
-		dclerr("used as variable", v);
-		return;
-	}
-	if(v->vstg==STGUNKNOWN) {
-		if (doing_stmtfcn) {
-			/* neither declare this variable if its only use */
-			/* is in defining a stmt function, nor complain  */
-			/* that it is never used */
-			v->vimpldovar = 1;
-			return;
-			}
-		v->vstg = implstg[ letter(v->fvarname[0]) ];
-		v->vimplstg = 1;
-		}
-
-/* Compute the actual storage location, i.e. offsets from base addresses,
-   possibly the stack pointer */
-
-	switch(v->vstg)
-	{
-	case STGBSS:
-		v->vardesc.varno = ++lastvarno;
-		break;
-	case STGAUTO:
-		if(v->vclass==CLPROC && v->vprocclass==PTHISPROC)
-			break;
-		if(t = v->vdim)
-			if( (neltp = t->nelt) && ISCONST(neltp) ) ;
-			else
-				dclerr("adjustable automatic array", v);
-		break;
-
-	default:
-		break;
-	}
-	v->vdcldone = YES;
-}
-
-
-
-/* Set the implicit type declaration of parameter   p   based on its first
-   letter */
-
-impldcl(p)
-register Namep p;
-{
-	register int k;
-	int type;
-	ftnint leng;
-
-	if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) )
-		return;
-	if(p->vtype == TYUNKNOWN)
-	{
-		k = letter(p->fvarname[0]);
-		type = impltype[ k ];
-		leng = implleng[ k ];
-		if(type == TYUNKNOWN)
-		{
-			if(p->vclass == CLPROC)
-				return;
-			dclerr("attempt to use undefined variable", p);
-			type = dflttype[k];
-			leng = 0;
-		}
-		settype(p, type, leng);
-		p->vimpltype = 1;
-	}
-}
-
- void
-inferdcl(np,type)
- Namep np;
- int type;
-{
-	int k = impltype[letter(np->fvarname[0])];
-	if (k != type) {
-		np->vinftype = 1;
-		np->vtype = type;
-		frexpr(np->vleng);
-		np->vleng = 0;
-		}
-	np->vimpltype = 0;
-	np->vinfproc = 1;
-	}
-
-
-#define ICONEQ(z, c)  (ISICON(z) && z->constblock.Const.ci==c)
-#define COMMUTE	{ e = lp;  lp = rp;  rp = e; }
-
-
-
-/* mkexpr -- Make expression, and simplify constant subcomponents (tree
-   order is not preserved).  Assumes that   lp   is nonempty, and uses
-   fold()   to simplify adjacent constants */
-
-expptr mkexpr(opcode, lp, rp)
-int opcode;
-register expptr lp, rp;
-{
-	register expptr e, e1;
-	int etype;
-	int ltype, rtype;
-	int ltag, rtag;
-	long L;
-
-	ltype = lp->headblock.vtype;
-	ltag = lp->tag;
-	if(rp && opcode!=OPCALL && opcode!=OPCCALL)
-	{
-		rtype = rp->headblock.vtype;
-		rtag = rp->tag;
-	}
-	else rtype = 0;
-
-	etype = cktype(opcode, ltype, rtype);
-	if(etype == TYERROR)
-		goto error;
-
-	switch(opcode)
-	{
-		/* check for multiplication by 0 and 1 and addition to 0 */
-
-	case OPSTAR:
-		if( ISCONST(lp) )
-			COMMUTE
-
-			    if( ISICON(rp) )
-			{
-				if(rp->constblock.Const.ci == 0)
-					goto retright;
-				goto mulop;
-			}
-		break;
-
-	case OPSLASH:
-	case OPMOD:
-		if( ICONEQ(rp, 0) )
-		{
-			err("attempted division by zero");
-			rp = ICON(1);
-			break;
-		}
-		if(opcode == OPMOD)
-			break;
-
-/* Handle multiplying or dividing by 1, -1 */
-
-mulop:
-		if( ISICON(rp) )
-		{
-			if(rp->constblock.Const.ci == 1)
-				goto retleft;
-
-			if(rp->constblock.Const.ci == -1)
-			{
-				frexpr(rp);
-				return( mkexpr(OPNEG, lp, ENULL) );
-			}
-		}
-
-/* Group all constants together.  In particular,
-
-	(x * CONST1) * CONST2 ==> x * (CONST1 * CONST2)
-	(x * CONST1) / CONST2 ==> x * (CONST1 / CONST2)
-*/
-
-		if (lp->tag != TEXPR || !lp->exprblock.rightp
-				|| !ISICON(lp->exprblock.rightp))
-			break;
-
-		if (lp->exprblock.opcode == OPLSHIFT) {
-			L = 1 << lp->exprblock.rightp->constblock.Const.ci;
-			if (opcode == OPSTAR || ISICON(rp) &&
-					!(L % rp->constblock.Const.ci)) {
-				lp->exprblock.opcode = OPSTAR;
-				lp->exprblock.rightp->constblock.Const.ci = L;
-				}
-			}
-
-		if (lp->exprblock.opcode == OPSTAR) {
-			if(opcode == OPSTAR)
-				e = mkexpr(OPSTAR, lp->exprblock.rightp, rp);
-			else if(ISICON(rp) &&
-			    (lp->exprblock.rightp->constblock.Const.ci %
-			    rp->constblock.Const.ci) == 0)
-				e = mkexpr(OPSLASH, lp->exprblock.rightp, rp);
-			else	break;
-
-			e1 = lp->exprblock.leftp;
-			free( (charptr) lp );
-			return( mkexpr(OPSTAR, e1, e) );
-			}
-		break;
-
-
-	case OPPLUS:
-		if( ISCONST(lp) )
-			COMMUTE
-			    goto addop;
-
-	case OPMINUS:
-		if( ICONEQ(lp, 0) )
-		{
-			frexpr(lp);
-			return( mkexpr(OPNEG, rp, ENULL) );
-		}
-
-		if( ISCONST(rp) && is_negatable((Constp)rp))
-		{
-			opcode = OPPLUS;
-			consnegop((Constp)rp);
-		}
-
-/* Group constants in an addition expression (also subtraction, since the
-   subtracted value was negated above).  In particular,
-
-	(x + CONST1) + CONST2 ==> x + (CONST1 + CONST2)
-*/
-
-addop:
-		if( ISICON(rp) )
-		{
-			if(rp->constblock.Const.ci == 0)
-				goto retleft;
-			if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) )
-			{
-				e = mkexpr(OPPLUS, lp->exprblock.rightp, rp);
-				e1 = lp->exprblock.leftp;
-				free( (charptr) lp );
-				return( mkexpr(OPPLUS, e1, e) );
-			}
-		}
-		if (opcode == OPMINUS && (ISINT(etype) || doing_vleng)) {
-			/* check for (i [+const]) - (i [+const]) */
-			if (lp->tag == TPRIM)
-				e = lp;
-			else if (lp->tag == TEXPR && lp->exprblock.opcode == OPPLUS
-					&& lp->exprblock.rightp->tag == TCONST) {
-				e = lp->exprblock.leftp;
-				if (e->tag != TPRIM)
-					break;
-				}
-			else
-				break;
-			if (e->primblock.argsp)
-				break;
-			if (rp->tag == TPRIM)
-				e1 = rp;
-			else if (rp->tag == TEXPR && rp->exprblock.opcode == OPPLUS
-					&& rp->exprblock.rightp->tag == TCONST) {
-				e1 = rp->exprblock.leftp;
-				if (e1->tag != TPRIM)
-					break;
-				}
-			else
-				break;
-			if (e->primblock.namep != e1->primblock.namep
-					|| e1->primblock.argsp)
-				break;
-			L = e == lp ? 0 : lp->exprblock.rightp->constblock.Const.ci;
-			if (e1 != rp)
-				L -= rp->exprblock.rightp->constblock.Const.ci;
-			frexpr(lp);
-			frexpr(rp);
-			return ICON(L);
-			}
-
-		break;
-
-
-	case OPPOWER:
-		break;
-
-/* Eliminate outermost double negations */
-
-	case OPNEG:
-	case OPNEG1:
-		if(ltag==TEXPR && lp->exprblock.opcode==OPNEG)
-		{
-			e = lp->exprblock.leftp;
-			free( (charptr) lp );
-			return(e);
-		}
-		break;
-
-/* Eliminate outermost double NOTs */
-
-	case OPNOT:
-		if(ltag==TEXPR && lp->exprblock.opcode==OPNOT)
-		{
-			e = lp->exprblock.leftp;
-			free( (charptr) lp );
-			return(e);
-		}
-		break;
-
-	case OPCALL:
-	case OPCCALL:
-		etype = ltype;
-		if(rp!=NULL && rp->listblock.listp==NULL)
-		{
-			free( (charptr) rp );
-			rp = NULL;
-		}
-		break;
-
-	case OPAND:
-	case OPOR:
-		if( ISCONST(lp) )
-			COMMUTE
-
-			    if( ISCONST(rp) )
-			{
-				if(rp->constblock.Const.ci == 0)
-					if(opcode == OPOR)
-						goto retleft;
-					else
-						goto retright;
-				else if(opcode == OPOR)
-					goto retright;
-				else
-					goto retleft;
-			}
-	case OPEQV:
-	case OPNEQV:
-
-	case OPBITAND:
-	case OPBITOR:
-	case OPBITXOR:
-	case OPBITNOT:
-	case OPLSHIFT:
-	case OPRSHIFT:
-
-	case OPLT:
-	case OPGT:
-	case OPLE:
-	case OPGE:
-	case OPEQ:
-	case OPNE:
-
-	case OPCONCAT:
-		break;
-	case OPMIN:
-	case OPMAX:
-	case OPMIN2:
-	case OPMAX2:
-	case OPDMIN:
-	case OPDMAX:
-
-	case OPASSIGN:
-	case OPASSIGNI:
-	case OPPLUSEQ:
-	case OPSTAREQ:
-	case OPMINUSEQ:
-	case OPSLASHEQ:
-	case OPMODEQ:
-	case OPLSHIFTEQ:
-	case OPRSHIFTEQ:
-	case OPBITANDEQ:
-	case OPBITXOREQ:
-	case OPBITOREQ:
-
-	case OPCONV:
-	case OPADDR:
-	case OPWHATSIN:
-
-	case OPCOMMA:
-	case OPCOMMA_ARG:
-	case OPQUEST:
-	case OPCOLON:
-	case OPDOT:
-	case OPARROW:
-	case OPIDENTITY:
-	case OPCHARCAST:
-	case OPABS:
-	case OPDABS:
-		break;
-
-	default:
-		badop("mkexpr", opcode);
-	}
-
-	e = (expptr) ALLOC(Exprblock);
-	e->exprblock.tag = TEXPR;
-	e->exprblock.opcode = opcode;
-	e->exprblock.vtype = etype;
-	e->exprblock.leftp = lp;
-	e->exprblock.rightp = rp;
-	if(ltag==TCONST && (rp==0 || rtag==TCONST) )
-		e = fold(e);
-	return(e);
-
-retleft:
-	frexpr(rp);
-	return(lp);
-
-retright:
-	frexpr(lp);
-	return(rp);
-
-error:
-	frexpr(lp);
-	if(rp && opcode!=OPCALL && opcode!=OPCCALL)
-		frexpr(rp);
-	return( errnode() );
-}
-
-#define ERR(s)   { errs = s; goto error; }
-
-/* cktype -- Check and return the type of the expression */
-
-cktype(op, lt, rt)
-register int op, lt, rt;
-{
-	char *errs;
-
-	if(lt==TYERROR || rt==TYERROR)
-		goto error1;
-
-	if(lt==TYUNKNOWN)
-		return(TYUNKNOWN);
-	if(rt==TYUNKNOWN)
-
-/* If not unary operation, return UNKNOWN */
-
-		if(!is_unary_op (op) && op != OPCALL && op != OPCCALL)
-			return(TYUNKNOWN);
-
-	switch(op)
-	{
-	case OPPLUS:
-	case OPMINUS:
-	case OPSTAR:
-	case OPSLASH:
-	case OPPOWER:
-	case OPMOD:
-		if( ISNUMERIC(lt) && ISNUMERIC(rt) )
-			return( maxtype(lt, rt) );
-		ERR("nonarithmetic operand of arithmetic operator")
-
-	case OPNEG:
-	case OPNEG1:
-		if( ISNUMERIC(lt) )
-			return(lt);
-		ERR("nonarithmetic operand of negation")
-
-	case OPNOT:
-		if(lt == TYLOGICAL)
-			return(TYLOGICAL);
-		ERR("NOT of nonlogical")
-
-	case OPAND:
-	case OPOR:
-	case OPEQV:
-	case OPNEQV:
-		if(lt==TYLOGICAL && rt==TYLOGICAL)
-			return(TYLOGICAL);
-		ERR("nonlogical operand of logical operator")
-
-	case OPLT:
-	case OPGT:
-	case OPLE:
-	case OPGE:
-	case OPEQ:
-	case OPNE:
-		if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
-		{
-			if(lt != rt)
-				ERR("illegal comparison")
-		}
-
-		else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
-		{
-			if(op!=OPEQ && op!=OPNE)
-				ERR("order comparison of complex data")
-		}
-
-		else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
-			ERR("comparison of nonarithmetic data")
-			    return(TYLOGICAL);
-
-	case OPCONCAT:
-		if(lt==TYCHAR && rt==TYCHAR)
-			return(TYCHAR);
-		ERR("concatenation of nonchar data")
-
-	case OPCALL:
-	case OPCCALL:
-	case OPIDENTITY:
-		return(lt);
-
-	case OPADDR:
-	case OPCHARCAST:
-		return(TYADDR);
-
-	case OPCONV:
-		if(rt == 0)
-			return(0);
-		if(lt==TYCHAR && ISINT(rt) )
-			return(TYCHAR);
-	case OPASSIGN:
-	case OPASSIGNI:
-	case OPMINUSEQ:
-	case OPPLUSEQ:
-	case OPSTAREQ:
-	case OPSLASHEQ:
-	case OPMODEQ:
-	case OPLSHIFTEQ:
-	case OPRSHIFTEQ:
-	case OPBITANDEQ:
-	case OPBITXOREQ:
-	case OPBITOREQ:
-		if( ISINT(lt) && rt==TYCHAR)
-			return(lt);
-		if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
-			if((op!=OPASSIGN && op != OPPLUSEQ && op != OPMINUSEQ)
-			    || (lt!=rt))
-			{
-				ERR("impossible conversion")
-			}
-		return(lt);
-
-	case OPMIN:
-	case OPMAX:
-	case OPDMIN:
-	case OPDMAX:
-	case OPMIN2:
-	case OPMAX2:
-	case OPBITOR:
-	case OPBITAND:
-	case OPBITXOR:
-	case OPBITNOT:
-	case OPLSHIFT:
-	case OPRSHIFT:
-	case OPWHATSIN:
-	case OPABS:
-	case OPDABS:
-		return(lt);
-
-	case OPCOMMA:
-	case OPCOMMA_ARG:
-	case OPQUEST:
-	case OPCOLON:		/* Only checks the rightmost type because
-				   of C language definition (rightmost
-				   comma-expr is the value of the expr) */
-		return(rt);
-
-	case OPDOT:
-	case OPARROW:
-	    return (lt);
-	    break;
-	default:
-		badop("cktype", op);
-	}
-error:
-	err(errs);
-error1:
-	return(TYERROR);
-}
-
-/* fold -- simplifies constant expressions; it assumes that e -> leftp and
-   e -> rightp are TCONST or NULL */
-
- LOCAL expptr
-fold(e)
- register expptr e;
-{
-	Constp p;
-	register expptr lp, rp;
-	int etype, mtype, ltype, rtype, opcode;
-	int i, bl, ll, lr;
-	char *q, *s;
-	struct Constblock lcon, rcon;
-	long L;
-	double d;
-
-	opcode = e->exprblock.opcode;
-	etype = e->exprblock.vtype;
-
-	lp = e->exprblock.leftp;
-	ltype = lp->headblock.vtype;
-	rp = e->exprblock.rightp;
-
-	if(rp == 0)
-		switch(opcode)
-		{
-		case OPNOT:
-			lp->constblock.Const.ci = ! lp->constblock.Const.ci;
- retlp:
-			e->exprblock.leftp = 0;
-			frexpr(e);
-			return(lp);
-
-		case OPBITNOT:
-			lp->constblock.Const.ci = ~ lp->constblock.Const.ci;
-			goto retlp;
-
-		case OPNEG:
-		case OPNEG1:
-			consnegop((Constp)lp);
-			goto retlp;
-
-		case OPCONV:
-		case OPADDR:
-			return(e);
-
-		case OPABS:
-		case OPDABS:
-			switch(ltype) {
-			    case TYSHORT:
-			    case TYLONG:
-				if ((L = lp->constblock.Const.ci) < 0)
-					lp->constblock.Const.ci = -L;
-				goto retlp;
-			    case TYREAL:
-			    case TYDREAL:
-				if (lp->constblock.vstg) {
-				    s = lp->constblock.Const.cds[0];
-				    if (*s == '-')
-					lp->constblock.Const.cds[0] = s + 1;
-				    goto retlp;
-				}
-				if ((d = lp->constblock.Const.cd[0]) < 0.)
-					lp->constblock.Const.cd[0] = -d;
-			    case TYCOMPLEX:
-			    case TYDCOMPLEX:
-				return e;	/* lazy way out */
-			    }
-		default:
-			badop("fold", opcode);
-		}
-
-	rtype = rp->headblock.vtype;
-
-	p = ALLOC(Constblock);
-	p->tag = TCONST;
-	p->vtype = etype;
-	p->vleng = e->exprblock.vleng;
-
-	switch(opcode)
-	{
-	case OPCOMMA:
-	case OPCOMMA_ARG:
-	case OPQUEST:
-	case OPCOLON:
-		return(e);
-
-	case OPAND:
-		p->Const.ci = lp->constblock.Const.ci &&
-		    rp->constblock.Const.ci;
-		break;
-
-	case OPOR:
-		p->Const.ci = lp->constblock.Const.ci ||
-		    rp->constblock.Const.ci;
-		break;
-
-	case OPEQV:
-		p->Const.ci = lp->constblock.Const.ci ==
-		    rp->constblock.Const.ci;
-		break;
-
-	case OPNEQV:
-		p->Const.ci = lp->constblock.Const.ci !=
-		    rp->constblock.Const.ci;
-		break;
-
-	case OPBITAND:
-		p->Const.ci = lp->constblock.Const.ci &
-		    rp->constblock.Const.ci;
-		break;
-
-	case OPBITOR:
-		p->Const.ci = lp->constblock.Const.ci |
-		    rp->constblock.Const.ci;
-		break;
-
-	case OPBITXOR:
-		p->Const.ci = lp->constblock.Const.ci ^
-		    rp->constblock.Const.ci;
-		break;
-
-	case OPLSHIFT:
-		p->Const.ci = lp->constblock.Const.ci <<
-		    rp->constblock.Const.ci;
-		break;
-
-	case OPRSHIFT:
-		p->Const.ci = lp->constblock.Const.ci >>
-		    rp->constblock.Const.ci;
-		break;
-
-	case OPCONCAT:
-		ll = lp->constblock.vleng->constblock.Const.ci;
-		lr = rp->constblock.vleng->constblock.Const.ci;
-		bl = lp->constblock.Const.ccp1.blanks;
-		p->Const.ccp = q = (char *) ckalloc(ll+lr+bl);
-		p->Const.ccp1.blanks = rp->constblock.Const.ccp1.blanks;
-		p->vleng = ICON(ll+lr+bl);
-		s = lp->constblock.Const.ccp;
-		for(i = 0 ; i < ll ; ++i)
-			*q++ = *s++;
-		for(i = 0 ; i < bl ; i++)
-			*q++ = ' ';
-		s = rp->constblock.Const.ccp;
-		for(i = 0; i < lr; ++i)
-			*q++ = *s++;
-		break;
-
-
-	case OPPOWER:
-		if( ! ISINT(rtype) )
-			return(e);
-		conspower(p, (Constp)lp, rp->constblock.Const.ci);
-		break;
-
-
-	default:
-		if(ltype == TYCHAR)
-		{
-			lcon.Const.ci = cmpstr(lp->constblock.Const.ccp,
-			    rp->constblock.Const.ccp,
-			    lp->constblock.vleng->constblock.Const.ci,
-			    rp->constblock.vleng->constblock.Const.ci);
-			rcon.Const.ci = 0;
-			mtype = tyint;
-		}
-		else	{
-			mtype = maxtype(ltype, rtype);
-			consconv(mtype, &lcon, &lp->constblock);
-			consconv(mtype, &rcon, &rp->constblock);
-		}
-		consbinop(opcode, mtype, p, &lcon, &rcon);
-		break;
-	}
-
-	frexpr(e);
-	return( (expptr) p );
-}
-
-
-
-/* assign constant l = r , doing coercion */
-
-consconv(lt, lc, rc)
- int lt;
- register Constp lc, rc;
-{
-	int rt = rc->vtype;
-	register union Constant *lv = &lc->Const, *rv = &rc->Const;
-
-	lc->vtype = lt;
-	if (ONEOF(lt, MSKREAL|MSKCOMPLEX) && ONEOF(rt, MSKREAL|MSKCOMPLEX)) {
-		memcpy((char *)lv, (char *)rv, sizeof(union Constant));
-		lc->vstg = rc->vstg;
-		if (ISCOMPLEX(lt) && ISREAL(rt)) {
-			if (rc->vstg)
-				lv->cds[1] = cds("0",CNULL);
-			else
-				lv->cd[1] = 0.;
-			}
-		return;
-		}
-	lc->vstg = 0;
-
-	switch(lt)
-	{
-
-/* Casting to character means just copying the first sizeof (character)
-   bytes into a new 1 character string.  This is weird. */
-
-	case TYCHAR:
-		*(lv->ccp = (char *) ckalloc(1)) = rv->ci;
-		lv->ccp1.blanks = 0;
-		break;
-
-	case TYSHORT:
-	case TYLONG:
-		if(rt == TYCHAR)
-			lv->ci = rv->ccp[0];
-		else if( ISINT(rt) )
-			lv->ci = rv->ci;
-		else	lv->ci = rc->vstg ? atof(rv->cds[0]) : rv->cd[0];
-
-		break;
-
-	case TYCOMPLEX:
-	case TYDCOMPLEX:
-		lv->cd[1] = 0.;
-		lv->cd[0] = rv->ci;
-		break;
-
-	case TYREAL:
-	case TYDREAL:
-		lv->cd[0] = rv->ci;
-		break;
-
-	case TYLOGICAL:
-		lv->ci = rv->ci;
-		break;
-	}
-}
-
-
-
-/* Negate constant value -- changes the input node's value */
-
-consnegop(p)
-register Constp p;
-{
-	register char *s;
-
-	if (p->vstg) {
-		if (ISCOMPLEX(p->vtype)) {
-			s = p->Const.cds[1];
-			p->Const.cds[1] = *s == '-' ? s+1
-					: *s == '0' ? s : s-1;
-			}
-		s = p->Const.cds[0];
-		p->Const.cds[0] = *s == '-' ? s+1
-				: *s == '0' ? s : s-1;
-		return;
-		}
-	switch(p->vtype)
-	{
-	case TYSHORT:
-	case TYLONG:
-		p->Const.ci = - p->Const.ci;
-		break;
-
-	case TYCOMPLEX:
-	case TYDCOMPLEX:
-		p->Const.cd[1] = - p->Const.cd[1];
-		/* fall through and do the real parts */
-	case TYREAL:
-	case TYDREAL:
-		p->Const.cd[0] = - p->Const.cd[0];
-		break;
-	default:
-		badtype("consnegop", p->vtype);
-	}
-}
-
-
-
-/* conspower -- Expand out an exponentiation */
-
- LOCAL void
-conspower(p, ap, n)
- Constp p, ap;
- ftnint n;
-{
-	register union Constant *powp = &p->Const;
-	register int type;
-	struct Constblock x, x0;
-
-	if (n == 1) {
-		memcpy((char *)powp, (char *)&ap->Const, sizeof(ap->Const));
-		return;
-		}
-
-	switch(type = ap->vtype)	/* pow = 1 */
-	{
-	case TYSHORT:
-	case TYLONG:
-		powp->ci = 1;
-		break;
-	case TYCOMPLEX:
-	case TYDCOMPLEX:
-		powp->cd[1] = 0;
-	case TYREAL:
-	case TYDREAL:
-		powp->cd[0] = 1;
-		break;
-	default:
-		badtype("conspower", type);
-	}
-
-	if(n == 0)
-		return;
-	switch(type)	/* x0 = ap */
-	{
-	case TYSHORT:
-	case TYLONG:
-		x0.Const.ci = ap->Const.ci;
-		break;
-	case TYCOMPLEX:
-	case TYDCOMPLEX:
-		x0.Const.cd[1] =
-			ap->vstg ? atof(ap->Const.cds[1]) : ap->Const.cd[1];
-	case TYREAL:
-	case TYDREAL:
-		x0.Const.cd[0] =
-			ap->vstg ? atof(ap->Const.cds[0]) : ap->Const.cd[0];
-		break;
-	}
-	x0.vtype = type;
-	x0.vstg = 0;
-	if(n < 0)
-	{
-		if( ISINT(type) )
-		{
-			err("integer ** negative number");
-			return;
-		}
-		else if (!x0.Const.cd[0]
-				&& (!ISCOMPLEX(type) || !x0.Const.cd[1])) {
-			err("0.0 ** negative number");
-			return;
-			}
-		n = -n;
-		consbinop(OPSLASH, type, &x, p, &x0);
-	}
-	else
-		consbinop(OPSTAR, type, &x, p, &x0);
-
-	for( ; ; )
-	{
-		if(n & 01)
-			consbinop(OPSTAR, type, p, p, &x);
-		if(n >>= 1)
-			consbinop(OPSTAR, type, &x, &x, &x);
-		else
-			break;
-	}
-}
-
-
-
-/* do constant operation cp = a op b -- assumes that   ap and bp   have data
-   matching the input   type */
-
- LOCAL void
-zerodiv()
-{ Fatal("division by zero during constant evaluation; cannot recover"); }
-
- LOCAL void
-consbinop(opcode, type, cpp, app, bpp)
- int opcode, type;
- Constp cpp, app, bpp;
-{
-	register union Constant *ap = &app->Const,
-				*bp = &bpp->Const,
-				*cp = &cpp->Const;
-	int k;
-	double ad[2], bd[2], temp;
-
-	cpp->vstg = 0;
-
-	if (ONEOF(type, MSKREAL|MSKCOMPLEX)) {
-		ad[0] = app->vstg ? atof(ap->cds[0]) : ap->cd[0];
-		bd[0] = bpp->vstg ? atof(bp->cds[0]) : bp->cd[0];
-		if (ISCOMPLEX(type)) {
-			ad[1] = app->vstg ? atof(ap->cds[1]) : ap->cd[1];
-			bd[1] = bpp->vstg ? atof(bp->cds[1]) : bp->cd[1];
-			}
-		}
-	switch(opcode)
-	{
-	case OPPLUS:
-		switch(type)
-		{
-		case TYSHORT:
-		case TYLONG:
-			cp->ci = ap->ci + bp->ci;
-			break;
-		case TYCOMPLEX:
-		case TYDCOMPLEX:
-			cp->cd[1] = ad[1] + bd[1];
-		case TYREAL:
-		case TYDREAL:
-			cp->cd[0] = ad[0] + bd[0];
-			break;
-		}
-		break;
-
-	case OPMINUS:
-		switch(type)
-		{
-		case TYSHORT:
-		case TYLONG:
-			cp->ci = ap->ci - bp->ci;
-			break;
-		case TYCOMPLEX:
-		case TYDCOMPLEX:
-			cp->cd[1] = ad[1] - bd[1];
-		case TYREAL:
-		case TYDREAL:
-			cp->cd[0] = ad[0] - bd[0];
-			break;
-		}
-		break;
-
-	case OPSTAR:
-		switch(type)
-		{
-		case TYSHORT:
-		case TYLONG:
-			cp->ci = ap->ci * bp->ci;
-			break;
-		case TYREAL:
-		case TYDREAL:
-			cp->cd[0] = ad[0] * bd[0];
-			break;
-		case TYCOMPLEX:
-		case TYDCOMPLEX:
-			temp = ad[0] * bd[0]  -  ad[1] * bd[1] ;
-			cp->cd[1] = ad[0] * bd[1]  +  ad[1] * bd[0] ;
-			cp->cd[0] = temp;
-			break;
-		}
-		break;
-	case OPSLASH:
-		switch(type)
-		{
-		case TYSHORT:
-		case TYLONG:
-			if (!bp->ci)
-				zerodiv();
-			cp->ci = ap->ci / bp->ci;
-			break;
-		case TYREAL:
-		case TYDREAL:
-			if (!bd[0])
-				zerodiv();
-			cp->cd[0] = ad[0] / bd[0];
-			break;
-		case TYCOMPLEX:
-		case TYDCOMPLEX:
-			if (!bd[0] && !bd[1])
-				zerodiv();
-			zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd);
-			break;
-		}
-		break;
-
-	case OPMOD:
-		if( ISINT(type) )
-		{
-			cp->ci = ap->ci % bp->ci;
-			break;
-		}
-		else
-			Fatal("inline mod of noninteger");
-
-	case OPMIN2:
-	case OPDMIN:
-		switch(type)
-		{
-		case TYSHORT:
-		case TYLONG:
-			cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci;
-			break;
-		case TYREAL:
-		case TYDREAL:
-			cp->cd[0] = ad[0] <= bd[0] ? ad[0] : bd[0];
-			break;
-		default:
-			Fatal("inline min of exected type");
-		}
-		break;
-
-	case OPMAX2:
-	case OPDMAX:
-		switch(type)
-		{
-		case TYSHORT:
-		case TYLONG:
-			cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci;
-			break;
-		case TYREAL:
-		case TYDREAL:
-			cp->cd[0] = ad[0] >= bd[0] ? ad[0] : bd[0];
-			break;
-		default:
-			Fatal("inline max of exected type");
-		}
-		break;
-
-	default:	  /* relational ops */
-		switch(type)
-		{
-		case TYSHORT:
-		case TYLONG:
-			if(ap->ci < bp->ci)
-				k = -1;
-			else if(ap->ci == bp->ci)
-				k = 0;
-			else	k = 1;
-			break;
-		case TYREAL:
-		case TYDREAL:
-			if(ad[0] < bd[0])
-				k = -1;
-			else if(ad[0] == bd[0])
-				k = 0;
-			else	k = 1;
-			break;
-		case TYCOMPLEX:
-		case TYDCOMPLEX:
-			if(ad[0] == bd[0] &&
-			    ad[1] == bd[1] )
-				k = 0;
-			else	k = 1;
-			break;
-		}
-
-		switch(opcode)
-		{
-		case OPEQ:
-			cp->ci = (k == 0);
-			break;
-		case OPNE:
-			cp->ci = (k != 0);
-			break;
-		case OPGT:
-			cp->ci = (k == 1);
-			break;
-		case OPLT:
-			cp->ci = (k == -1);
-			break;
-		case OPGE:
-			cp->ci = (k >= 0);
-			break;
-		case OPLE:
-			cp->ci = (k <= 0);
-			break;
-		}
-		break;
-	}
-}
-
-
-
-/* conssgn - returns the sign of a Fortran constant */
-
-conssgn(p)
-register expptr p;
-{
-	register char *s;
-
-	if( ! ISCONST(p) )
-		Fatal( "sgn(nonconstant)" );
-
-	switch(p->headblock.vtype)
-	{
-	case TYSHORT:
-	case TYLONG:
-		if(p->constblock.Const.ci > 0) return(1);
-		if(p->constblock.Const.ci < 0) return(-1);
-		return(0);
-
-	case TYREAL:
-	case TYDREAL:
-		if (p->constblock.vstg) {
-			s = p->constblock.Const.cds[0];
-			if (*s == '-')
-				return -1;
-			if (*s == '0')
-				return 0;
-			return 1;
-			}
-		if(p->constblock.Const.cd[0] > 0) return(1);
-		if(p->constblock.Const.cd[0] < 0) return(-1);
-		return(0);
-
-
-/* The sign of a complex number is 0 iff the number is 0 + 0i, else it's 1 */
-
-	case TYCOMPLEX:
-	case TYDCOMPLEX:
-		if (p->constblock.vstg)
-			return *p->constblock.Const.cds[0] != '0'
-			    && *p->constblock.Const.cds[1] != '0';
-		return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0);
-
-	default:
-		badtype( "conssgn", p->constblock.vtype);
-	}
-	/* NOT REACHED */ return 0;
-}
-
-char *powint[ ] = {
-	"pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" };
-
-LOCAL expptr mkpower(p)
-register expptr p;
-{
-	register expptr q, lp, rp;
-	int ltype, rtype, mtype, tyi;
-
-	lp = p->exprblock.leftp;
-	rp = p->exprblock.rightp;
-	ltype = lp->headblock.vtype;
-	rtype = rp->headblock.vtype;
-
-	if(ISICON(rp))
-	{
-		if(rp->constblock.Const.ci == 0)
-		{
-			frexpr(p);
-			if( ISINT(ltype) )
-				return( ICON(1) );
-			else if (ISREAL (ltype))
-				return mkconv (ltype, ICON (1));
-			else
-				return( (expptr) putconst((Constp)
-					mkconv(ltype, ICON(1))) );
-		}
-		if(rp->constblock.Const.ci < 0)
-		{
-			if( ISINT(ltype) )
-			{
-				frexpr(p);
-				err("integer**negative");
-				return( errnode() );
-			}
-			rp->constblock.Const.ci = - rp->constblock.Const.ci;
-			p->exprblock.leftp = lp
-				= fixexpr((Exprp)mkexpr(OPSLASH, ICON(1), lp));
-		}
-		if(rp->constblock.Const.ci == 1)
-		{
-			frexpr(rp);
-			free( (charptr) p );
-			return(lp);
-		}
-
-		if( ONEOF(ltype, MSKINT|MSKREAL) ) {
-			p->exprblock.vtype = ltype;
-			return(p);
-		}
-	}
-	if( ISINT(rtype) )
-	{
-		if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
-			q = call2(TYSHORT, "pow_hh", lp, rp);
-		else	{
-			if(ltype == TYSHORT)
-			{
-				ltype = TYLONG;
-				lp = mkconv(TYLONG,lp);
-			}
-			rp = mkconv(TYLONG,rp);
-			if (ISCONST(rp)) {
-				tyi = tyint;
-				tyint = TYLONG;
-				rp = (expptr)putconst((Constp)rp);
-				tyint = tyi;
-				}
-			q = call2(ltype, powint[ltype-TYLONG], lp, rp);
-		}
-	}
-	else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) {
-		extern int callk_kludge;
-		callk_kludge = TYDREAL;
-		q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
-		callk_kludge = 0;
-		}
-	else	{
-		q  = call2(TYDCOMPLEX, "pow_zz",
-		    mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
-		if(mtype == TYCOMPLEX)
-			q = mkconv(TYCOMPLEX, q);
-	}
-	free( (charptr) p );
-	return(q);
-}
-
-
-/* Complex Division.  Same code as in Runtime Library
-*/
-
-
- LOCAL void
-zdiv(c, a, b)
- register dcomplex *a, *b, *c;
-{
-	double ratio, den;
-	double abr, abi;
-
-	if( (abr = b->dreal) < 0.)
-		abr = - abr;
-	if( (abi = b->dimag) < 0.)
-		abi = - abi;
-	if( abr <= abi )
-	{
-		if(abi == 0)
-			Fatal("complex division by zero");
-		ratio = b->dreal / b->dimag ;
-		den = b->dimag * (1 + ratio*ratio);
-		c->dreal = (a->dreal*ratio + a->dimag) / den;
-		c->dimag = (a->dimag*ratio - a->dreal) / den;
-	}
-
-	else
-	{
-		ratio = b->dimag / b->dreal ;
-		den = b->dreal * (1 + ratio*ratio);
-		c->dreal = (a->dreal + a->dimag*ratio) / den;
-		c->dimag = (a->dimag - a->dreal*ratio) / den;
-	}
-}
//GO.SYSIN DD expr.c
echo f2c.1 1>&2
sed >f2c.1 <<'//GO.SYSIN DD f2c.1' 's/^-//'
-
-     F2C(1)							F2C(1)
-
-     NAME
-	  f2c -	Convert	Fortran	77 to C	or C++
-
-     SYNOPSIS
-	  f2c [	option ... ] file ...
-
-     DESCRIPTION
-	  F2c converts Fortran 77 source code in files with names end-
-	  ing in `.f' or `.F' to C (or C++) source files in the	cur-
-	  rent directory, with `.c' substituted	for the	final `.f' or
-	  `.F'.	 If no Fortran files are named,	f2c reads Fortran from
-	  standard input and writes C on standard output.  File	names
-	  that end with	`.p' or	`.P' are taken to be prototype files,
-	  as produced by option	`-P', and are read first.
-
-	  The following	options	have the same meaning as in f77(1).
-
-	  -C   Compile code to check that subscripts are within
-	       declared	array bounds.
-
-	  -I2  Render INTEGER and LOGICAL as short, INTEGER*4 as long
-	       int.  Assume the	default	libF77 and libI77:  allow only
-	       INTEGER*4 (and no LOGICAL) variables in INQUIREs.
-	       Option `-I4' confirms the default rendering of INTEGER
-	       as long int.
-
-	  -onetrip
-	       Compile DO loops	that are performed at least once if
-	       reached.	 (Fortran 77 DO	loops are not performed	at all
-	       if the upper limit is smaller than the lower limit.)
-
-	  -U   Honor the case of variable and external names.  Fortran
-	       keywords	must be	in lower case.
-
-	  -u   Make the	default	type of	a variable `undefined' rather
-	       than using the default Fortran rules.
-
-	  -w   Suppress	all warning messages.  If the option is
-	       `-w66', only Fortran 66 compatibility warnings are sup-
-	       pressed.
-
-	  The following	options	are peculiar to	f2c.
-
-	  -A   Produce ANSI C.	Default	is old-style C.
-
-	  -a   Make local variables automatic rather than static
-	       unless they appear in a DATA, EQUIVALENCE, NAMELIST, or
-	       SAVE statement.
-
-	  -C++ Output C++ code.
-
-	  -c   Include original	Fortran	source as comments.
-
-     Page 1			   Local	     (printed 5/24/92)
-
-     F2C(1)							F2C(1)
-
-	  -E   Declare uninitialized COMMON to be Extern (overridably
-	       defined in f2c.h	as extern).
-
-	  -ec  Place uninitialized COMMON blocks in separate files:
-	       COMMON /ABC/ appears in file abc_com.c.	Option `-e1c'
-	       bundles the separate files into the output file,	with
-	       comments	that give an unbundling	sed(1) script.
-
-	  -ext Complain	about f77(1) extensions.
-
-	  -f   Assume free-format input: accept	text after column 72
-	       and do not pad fixed-format lines shorter than 72 char-
-	       acters with blanks.
-
-	  -72  Treat text appearing after column 72 as an error.
-
-	  -g   Include original	Fortran	line numbers in	#line lines.
-
-	  -h   Try to align character strings on word (or, if the
-	       option is `-hd',	on double-word)	boundaries.
-
-	  -i2  Similar to -I2, but assume a modified libF77 and	libI77
-	       (compiled with -Df2c_i2), so INTEGER and	LOGICAL	vari-
-	       ables may be assigned by	INQUIRE	and array lengths are
-	       stored in short ints.
-
-	  -kr  Use temporary values to enforce Fortran expression
-	       evaluation where	K&R (first edition) parenthesization
-	       rules allow rearrangement.  If the option is `-krd',
-	       use double precision temporaries	even for single-
-	       precision operands.
-
-	  -P   Write a file.P of ANSI (or C++) prototypes for proce-
-	       dures defined in	each input file.f or file.F.  When
-	       reading Fortran from standard input, write prototypes
-	       at the beginning	of standard output.  Implies -A	unless
-	       option `-C++' is	present.  Option -Ps implies -P	, and
-	       gives exit status 4 if rerunning	f2c may	change proto-
-	       types or	declarations.
-
-	  -p   Supply preprocessor definitions to make common-block
-	       members look like local variables.
-
-	  -R   Do not promote REAL functions and operations to DOUBLE
-	       PRECISION.  Option `-!R'	confirms the default, which
-	       imitates	f77.
-
-	  -r   Cast values of REAL functions (including	intrinsics) to
-	       REAL.
-
-	  -r8  Promote REAL to DOUBLE PRECISION, COMPLEX to DOUBLE
-	       COMPLEX.
-
-     Page 2			   Local	     (printed 5/24/92)
-
-     F2C(1)							F2C(1)
-
-	  -Tdir
-	       Put temporary files in directory	dir.
-
-	  -w8  Suppress	warnings when COMMON or	EQUIVALENCE forces
-	       odd-word	alignment of doubles.
-
-	  -Wn  Assume n	characters/word	(default 4) when initializing
-	       numeric variables with character	data.
-
-	  -z   Do not implicitly recognize DOUBLE COMPLEX.
-
-	  -!bs Do not recognize	backslash escapes (\", \', \0, \\, \b,
-	       \f, \n, \r, \t, \v) in character	strings.
-
-	  -!c  Inhibit C output, but produce -P	output.
-
-	  -!I  Reject include statements.
-
-	  -!it Don't infer types of untyped EXTERNAL procedures	from
-	       use as parameters to previously defined or prototyped
-	       procedures.
-
-	  -!P  Do not attempt to infer ANSI or C++ prototypes from
-	       usage.
-
-	  The resulting	C invokes the support routines of f77; object
-	  code should be loaded	by f77 or with ld(1) or	cc(1) options
-	  -lF77	-lI77 -lm.  Calling conventions	are those of f77: see
-	  the reference	below.
-
-     FILES
-	  file.[fF]
-	       input file
-
-	  *.c  output file
-
-	  /usr/include/f2c.h
-	       header file
-
-	  /usr/lib/libF77.a
-	       intrinsic function library
-
-	  /usr/lib/libI77.a
-	       Fortran I/O library
-
-	  /lib/libc.a
-	       C library, see section 3
-
-     SEE ALSO
-	  S. I.	Feldman	and P. J. Weinberger, `A Portable Fortran 77
-	  Compiler', UNIX Time Sharing System Programmer's Manual,
-	  Tenth	Edition, Volume	2, AT&T	Bell Laboratories, 1990.
-
-     Page 3			   Local	     (printed 5/24/92)
-
-     F2C(1)							F2C(1)
-
-     DIAGNOSTICS
-	  The diagnostics produced by f2c are intended to be self-
-	  explanatory.
-
-     BUGS
-	  Floating-point constant expressions are simplified in	the
-	  floating-point arithmetic of the machine running f2c,	so
-	  they are typically accurate to at most 16 or 17 decimal
-	  places.
-	  Untypable EXTERNAL functions are declared int.
-
-     Page 4			   Local	     (printed 5/24/92)
-
//GO.SYSIN DD f2c.1
echo f2c.1t 1>&2
sed >f2c.1t <<'//GO.SYSIN DD f2c.1t' 's/^-//'
-. \" Definitions of F, L and LR for the benefit of systems
-. \" whose -man lacks them...
-.de F
-.nh
-.if n \%\&\\$1
-.if t \%\&\f(CW\\$1\fR
-.hy 14
-..
-.de L
-.nh
-.if n \%`\\$1'
-.if t \%\&\f(CW\\$1\fR
-.hy 14
-..
-.de LR
-.nh
-.if n \%`\\$1'\\$2
-.if t \%\&\f(CW\\$1\fR\\$2
-.hy 14
-..
-.TH F2C 1
-.CT 1 prog_other
-.SH NAME
-f\^2c \(mi Convert Fortran 77 to C or C++
-.SH SYNOPSIS
-.B f\^2c
-[
-.I option ...
-]
-.I file ...
-.SH DESCRIPTION
-.I F2c
-converts Fortran 77 source code in
-.I files
-with names ending in
-.L .f
-or
-.L .F
-to C (or C++) source files in the
-current directory, with
-.L .c
-substituted
-for the final
-.L .f
-or
-.LR .F .
-If no Fortran files are named,
-.I f\^2c
-reads Fortran from standard input and
-writes C on standard output.
-.I File
-names that end with
-.L .p
-or
-.L .P
-are taken to be prototype
-files, as produced by option
-.LR -P ,
-and are read first.
-.PP
-The following options have the same meaning as in
-.IR f\^77 (1).
-.TP
-.B -C
-Compile code to check that subscripts are within declared array bounds.
-.TP
-.B -I2
-Render INTEGER and LOGICAL as short,
-INTEGER\(**4 as long int.  Assume the default \fIlibF77\fR
-and \fIlibI77\fR:  allow only INTEGER\(**4 (and no LOGICAL)
-variables in INQUIREs.  Option
-.L -I4
-confirms the default rendering of INTEGER as long int.
-.TP
-.B -onetrip
-Compile DO loops that are performed at least once if reached.
-(Fortran 77 DO loops are not performed at all if the upper limit is smaller than the lower limit.)
-.TP
-.B -U
-Honor the case of variable and external names.  Fortran keywords must be in
-.I
-lower
-case.
-.TP
-.B -u
-Make the default type of a variable `undefined' rather than using the default Fortran rules.
-.TP
-.B -w
-Suppress all warning messages.
-If the option is
-.LR -w66 ,
-only Fortran 66 compatibility warnings are suppressed.
-.PP
-The following options are peculiar to
-.IR f\^2c .
-.TP
-.B -A
-Produce
-.SM ANSI
-C.
-Default is old-style C.
-.TP
-.B -a
-Make local variables automatic rather than static
-unless they appear in a
-.SM "DATA, EQUIVALENCE, NAMELIST,"
-or
-.SM SAVE
-statement.
-.TP
-.B -C++
-Output C++ code.
-.TP
-.B -c
-Include original Fortran source as comments.
-.TP
-.B -E
-Declare uninitialized
-.SM COMMON
-to be
-.B Extern
-(overridably defined in
-.F f2c.h
-as
-.B extern).
-.TP
-.B -ec
-Place uninitialized
-.SM COMMON
-blocks in separate files:
-.B COMMON /ABC/
-appears in file
-.BR abc_com.c .
-Option
-.LR -e1c
-bundles the separate files
-into the output file, with comments that give an unbundling
-.IR sed (1)
-script.
-.TP
-.B -ext
-Complain about
-.IR f\^77 (1)
-extensions.
-.TP
-.B -f
-Assume free-format input: accept text after column 72 and do not
-pad fixed-format lines shorter than 72 characters with blanks.
-.TP
-.B -72
-Treat text appearing after column 72 as an error.
-.TP
-.B -g
-Include original Fortran line numbers in \f(CW#line\fR lines.
-.TP
-.B -h
-Try to align character strings on word (or, if the option is
-.LR -hd ,
-on double-word) boundaries.
-.TP
-.B -i2
-Similar to
-.BR -I2 ,
-but assume a modified
-.I libF77
-and
-.I libI77
-(compiled with
-.BR -Df\^2c_i2 ),
-so
-.SM INTEGER
-and
-.SM LOGICAL
-variables may be assigned by
-.SM INQUIRE
-and array lengths are stored in short ints.
-.TP
-.B -kr
-Use temporary values to enforce Fortran expression evaluation
-where K&R (first edition) parenthesization rules allow rearrangement.
-If the option is
-.LR -krd ,
-use double precision temporaries even for single-precision operands.
-.TP
-.B -P
-Write a
-.IB file .P
-of ANSI (or C++) prototypes
-for procedures defined in each input
-.IB file .f
-or
-.IB file .F .
-When reading Fortran from standard input, write prototypes
-at the beginning of standard output.
-Implies
-.B -A
-unless option
-.L -C++
-is present.  Option
-.B -Ps
-implies
-.B -P ,
-and gives exit status 4 if rerunning
-.I f\^2c
-may change prototypes or declarations.
-.TP
-.B -p
-Supply preprocessor definitions to make common-block members
-look like local variables.
-.TP
-.B -R
-Do not promote
-.SM REAL
-functions and operations to
-.SM DOUBLE PRECISION.
-Option
-.L -!R
-confirms the default, which imitates
-.IR f\^77 .
-.TP
-.B -r
-Cast values of REAL functions (including intrinsics) to REAL.
-.TP
-.B -r8
-Promote
-.SM REAL
-to
-.SM DOUBLE PRECISION, COMPLEX
-to
-.SM DOUBLE COMPLEX.
-.TP
-.BI -T dir
-Put temporary files in directory
-.I dir.
-.TP
-.B -w8
-Suppress warnings when
-.SM COMMON
-or
-.SM EQUIVALENCE
-forces odd-word alignment of doubles.
-.TP
-.BI -W n
-Assume
-.I n
-characters/word (default 4)
-when initializing numeric variables with character data.
-.TP
-.B -z
-Do not implicitly recognize
-.SM DOUBLE COMPLEX.
-.TP
-.B -!bs
-Do not recognize \fIb\fRack\fIs\fRlash escapes
-(\e", \e', \e0, \e\e, \eb, \ef, \en, \er, \et, \ev) in character strings.
-.TP
-.B -!c
-Inhibit C output, but produce
-.B -P
-output.
-.TP
-.B -!I
-Reject
-.B include
-statements.
-.TP
-.B -!it
-Don't infer types of untyped
-.SM EXTERNAL
-procedures from use as parameters to previously defined or prototyped
-procedures.
-.TP
-.B -!P
-Do not attempt to infer
-.SM ANSI
-or C++
-prototypes from usage.
-.PP
-The resulting C invokes the support routines of
-.IR f\^77 ;
-object code should be loaded by
-.I f\^77
-or with
-.IR ld (1)
-or
-.IR cc (1)
-options
-.BR "-lF77 -lI77 -lm" .
-Calling conventions
-are those of
-.IR f\&77 :
-see the reference below.
-.br
-.SH FILES
-.TP
-.IB file .[fF]
-input file
-.TP
-.B *.c
-output file
-.TP
-.F /usr/include/f2c.h
-header file
-.TP
-.F /usr/lib/libF77.a
-intrinsic function library
-.TP
-.F /usr/lib/libI77.a
-Fortran I/O library
-.TP
-.F /lib/libc.a
-C library, see section 3
-.SH "SEE ALSO"
-S. I. Feldman and
-P. J. Weinberger,
-`A Portable Fortran 77 Compiler',
-\fIUNIX Time Sharing System Programmer's Manual\fR,
-Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990.
-.SH DIAGNOSTICS
-The diagnostics produced by
-.I f\^2c
-are intended to be
-self-explanatory.
-.SH BUGS
-Floating-point constant expressions are simplified in
-the floating-point arithmetic of the machine running
-.IR f\^2c ,
-so they are typically accurate to at most 16 or 17 decimal places.
-.br
-Untypable
-.SM EXTERNAL
-functions are declared
-.BR int .
//GO.SYSIN DD f2c.1t
echo f2c.h 1>&2
sed >f2c.h <<'//GO.SYSIN DD f2c.h' 's/^-//'
-/* f2c.h  --  Standard Fortran to C header file */
-
-/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
-
-	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
-
-#ifndef F2C_INCLUDE
-#define F2C_INCLUDE
-
-typedef long int integer;
-typedef char *address;
-typedef short int shortint;
-typedef float real;
-typedef double doublereal;
-typedef struct { real r, i; } complex;
-typedef struct { doublereal r, i; } doublecomplex;
-typedef long int logical;
-typedef short int shortlogical;
-
-#define TRUE_ (1)
-#define FALSE_ (0)
-
-/* Extern is for use with -E */
-#ifndef Extern
-#define Extern extern
-#endif
-
-/* I/O stuff */
-
-#ifdef f2c_i2
-/* for -i2 */
-typedef short flag;
-typedef short ftnlen;
-typedef short ftnint;
-#else
-typedef long flag;
-typedef long ftnlen;
-typedef long ftnint;
-#endif
-
-/*external read, write*/
-typedef struct
-{	flag cierr;
-	ftnint ciunit;
-	flag ciend;
-	char *cifmt;
-	ftnint cirec;
-} cilist;
-
-/*internal read, write*/
-typedef struct
-{	flag icierr;
-	char *iciunit;
-	flag iciend;
-	char *icifmt;
-	ftnint icirlen;
-	ftnint icirnum;
-} icilist;
-
-/*open*/
-typedef struct
-{	flag oerr;
-	ftnint ounit;
-	char *ofnm;
-	ftnlen ofnmlen;
-	char *osta;
-	char *oacc;
-	char *ofm;
-	ftnint orl;
-	char *oblnk;
-} olist;
-
-/*close*/
-typedef struct
-{	flag cerr;
-	ftnint cunit;
-	char *csta;
-} cllist;
-
-/*rewind, backspace, endfile*/
-typedef struct
-{	flag aerr;
-	ftnint aunit;
-} alist;
-
-/* inquire */
-typedef struct
-{	flag inerr;
-	ftnint inunit;
-	char *infile;
-	ftnlen infilen;
-	ftnint	*inex;	/*parameters in standard's order*/
-	ftnint	*inopen;
-	ftnint	*innum;
-	ftnint	*innamed;
-	char	*inname;
-	ftnlen	innamlen;
-	char	*inacc;
-	ftnlen	inacclen;
-	char	*inseq;
-	ftnlen	inseqlen;
-	char 	*indir;
-	ftnlen	indirlen;
-	char	*infmt;
-	ftnlen	infmtlen;
-	char	*inform;
-	ftnint	informlen;
-	char	*inunf;
-	ftnlen	inunflen;
-	ftnint	*inrecl;
-	ftnint	*innrec;
-	char	*inblank;
-	ftnlen	inblanklen;
-} inlist;
-
-#define VOID void
-
-union Multitype {	/* for multiple entry points */
-	shortint h;
-	integer i;
-	real r;
-	doublereal d;
-	complex c;
-	doublecomplex z;
-	};
-
-typedef union Multitype Multitype;
-
-typedef long Long;	/* No longer used; formerly in Namelist */
-
-struct Vardesc {	/* for Namelist */
-	char *name;
-	char *addr;
-	ftnlen *dims;
-	int  type;
-	};
-typedef struct Vardesc Vardesc;
-
-struct Namelist {
-	char *name;
-	Vardesc **vars;
-	int nvars;
-	};
-typedef struct Namelist Namelist;
-
-#define abs(x) ((x) >= 0 ? (x) : -(x))
-#define dabs(x) (doublereal)abs(x)
-#define min(a,b) ((a) <= (b) ? (a) : (b))
-#define max(a,b) ((a) >= (b) ? (a) : (b))
-#define dmin(a,b) (doublereal)min(a,b)
-#define dmax(a,b) (doublereal)max(a,b)
-
-/* procedure parameter types for -A and -C++ */
-
-#define F2C_proc_par_types 1
-#ifdef __cplusplus
-typedef int /* Unknown procedure type */ (*U_fp)(...);
-typedef shortint (*J_fp)(...);
-typedef integer (*I_fp)(...);
-typedef real (*R_fp)(...);
-typedef doublereal (*D_fp)(...), (*E_fp)(...);
-typedef /* Complex */ VOID (*C_fp)(...);
-typedef /* Double Complex */ VOID (*Z_fp)(...);
-typedef logical (*L_fp)(...);
-typedef shortlogical (*K_fp)(...);
-typedef /* Character */ VOID (*H_fp)(...);
-typedef /* Subroutine */ int (*S_fp)(...);
-#else
-typedef int /* Unknown procedure type */ (*U_fp)();
-typedef shortint (*J_fp)();
-typedef integer (*I_fp)();
-typedef real (*R_fp)();
-typedef doublereal (*D_fp)(), (*E_fp)();
-typedef /* Complex */ VOID (*C_fp)();
-typedef /* Double Complex */ VOID (*Z_fp)();
-typedef logical (*L_fp)();
-typedef shortlogical (*K_fp)();
-typedef /* Character */ VOID (*H_fp)();
-typedef /* Subroutine */ int (*S_fp)();
-#endif
-/* E_fp is for real functions when -R is not specified */
-typedef VOID C_f;	/* complex function */
-typedef VOID H_f;	/* character function */
-typedef VOID Z_f;	/* double complex function */
-typedef doublereal E_f;	/* real function with -R not specified */
-
-/* undef any lower-case symbols that your C compiler predefines, e.g.: */
-
-#ifndef Skip_f2c_Undefs
-#undef cray
-#undef gcos
-#undef mc68010
-#undef mc68020
-#undef mips
-#undef pdp11
-#undef sgi
-#undef sparc
-#undef sun
-#undef sun2
-#undef sun3
-#undef sun4
-#undef u370
-#undef u3b
-#undef u3b2
-#undef u3b5
-#undef unix
-#undef vax
-#endif
-#endif
//GO.SYSIN DD f2c.h
echo format.c 1>&2
sed >format.c <<'//GO.SYSIN DD format.c' 's/^-//'
-/****************************************************************
-Copyright 1990, 1991, 1992 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.
-****************************************************************/
-
-/* Format.c -- this file takes an intermediate file (generated by pass 1
-   of the translator) and some state information about the contents of that
-   file, and generates C program text. */
-
-#include "defs.h"
-#include "p1defs.h"
-#include "format.h"
-#include "output.h"
-#include "names.h"
-#include "iob.h"
-
-int c_output_line_length = DEF_C_LINE_LENGTH;
-
-int last_was_label;	/* Boolean used to generate semicolons
-				   when a label terminates a block */
-static char this_proc_name[52];	/* Name of the current procedure.  This is
-				   probably too simplistic to handle
-				   multiple entry points */
-
-static int p1getd(), p1gets(), p1getf(), get_p1_token();
-static int p1get_const(), p1getn();
-static expptr do_format(), do_p1_name_pointer(), do_p1_const();
-static expptr do_p1_expr(), do_p1_ident(), do_p1_charp(), do_p1_extern();
-static expptr do_p1_head(), do_p1_list(), do_p1_literal();
-static void do_p1_label(), do_p1_asgoto(), do_p1_goto();
-static void do_p1_if(), do_p1_else(), do_p1_elif(), do_p1_endif();
-static void do_p1_endelse(), do_p1_subr_ret(), do_p1_comp_goto();
-static void do_p1_for(), do_p1_end_for(), do_p1_fortran();
-static void do_p1_1while(), do_p1_2while(), do_p1_elseifstart();
-static void do_p1_comment(), do_p1_set_line();
-static expptr do_p1_addr();
-static void proto();
-void list_arg_types();
-chainp length_comp();
-void listargs();
-extern chainp assigned_fmts;
-extern long first_lineno;
-static char filename[P1_FILENAME_MAX];
-extern int gflag;
-int gflag1;
-extern char *parens;
-
-start_formatting ()
-{
-    FILE *infile;
-    static int wrote_one = 0;
-    extern int usedefsforcommon;
-    extern char *p1_file, *p1_bakfile;
-
-    this_proc_name[0] = '\0';
-    last_was_label = 0;
-    ei_next = ei_first;
-    wh_next = wh_first;
-
-    (void) fclose (pass1_file);
-    if ((infile = fopen (p1_file, binread)) == NULL)
-	Fatal("start_formatting:  couldn't open the intermediate file\n");
-
-    if (wrote_one)
-	nice_printf (c_file, "\n");
-
-    while (!feof (infile)) {
-	expptr this_expr;
-
-	this_expr = do_format (infile, c_file);
-	if (this_expr) {
-	    out_and_free_statement (c_file, this_expr);
-	} /* if this_expr */
-    } /* while !feof infile */
-
-    (void) fclose (infile);
-
-    if (last_was_label)
-	nice_printf (c_file, ";\n");
-
-    prev_tab (c_file);
-    gflag1 = 0;
-    if (this_proc_name[0])
-	nice_printf (c_file, "} /* %s */\n", this_proc_name);
-
-
-/* Write the #undefs for common variable reference */
-
-    if (usedefsforcommon) {
-	Extsym *ext;
-	int did_one = 0;
-
-	for (ext = extsymtab; ext < nextext; ext++)
-	    if (ext -> extstg == STGCOMMON && ext -> used_here) {
-		ext -> used_here = 0;
-		if (!did_one)
-		    nice_printf (c_file, "\n");
-		wr_abbrevs(c_file, 0, ext->extp);
-		did_one = 1;
-		ext -> extp = CHNULL;
-	    } /* if */
-
-	if (did_one)
-	    nice_printf (c_file, "\n");
-    } /* if usedefsforcommon */
-
-    other_undefs(c_file);
-
-    wrote_one = 1;
-
-/* For debugging only */
-
-    if (debugflag && (pass1_file = fopen (p1_bakfile, binwrite)))
-	if (infile = fopen (p1_file, binread)) {
-	    ffilecopy (infile, pass1_file);
-	    fclose (infile);
-	    fclose (pass1_file);
-	} /* if infile */
-
-/* End of "debugging only" */
-
-    scrub(p1_file);	/* optionally unlink */
-
-    if ((pass1_file = fopen (p1_file, binwrite)) == NULL)
-	err ("start_formatting:  couldn't reopen the pass1 file");
-
-} /* start_formatting */
-
-
- static void
-put_semi(outfile)
- FILE *outfile;
-{
-	nice_printf (outfile, ";\n");
-	last_was_label = 0;
-	}
-
-#define SEM_CHECK(x) if (last_was_label) put_semi(x)
-
-/* do_format -- takes an input stream (a file in pass1 format) and writes
-   the appropriate C code to   outfile   when possible.  When reading an
-   expression, the expression tree is returned instead. */
-
-static expptr do_format (infile, outfile)
-FILE *infile, *outfile;
-{
-    int token_type, was_c_token;
-    expptr retval = ENULL;
-
-    token_type = get_p1_token (infile);
-    was_c_token = 1;
-    switch (token_type) {
-	case P1_COMMENT:
-	    do_p1_comment (infile, outfile);
-	    was_c_token = 0;
-	    break;
-	case P1_SET_LINE:
-	    do_p1_set_line (infile);
-	    was_c_token = 0;
-	    break;
-	case P1_FILENAME:
-	    p1gets(infile, filename, P1_FILENAME_MAX);
-	    was_c_token = 0;
-	    break;
-	case P1_NAME_POINTER:
-	    retval = do_p1_name_pointer (infile);
-	    break;
-	case P1_CONST:
-	    retval = do_p1_const (infile);
-	    break;
-	case P1_EXPR:
-	    retval = do_p1_expr (infile, outfile);
-	    break;
-	case P1_IDENT:
-	    retval = do_p1_ident(infile);
-	    break;
-	case P1_CHARP:
-		retval = do_p1_charp(infile);
-		break;
-	case P1_EXTERN:
-	    retval = do_p1_extern (infile);
-	    break;
-	case P1_HEAD:
-	    gflag1 = 0;
-	    retval = do_p1_head (infile, outfile);
-	    gflag1 = gflag;
-	    lineno = first_lineno;
-	    break;
-	case P1_LIST:
-	    retval = do_p1_list (infile, outfile);
-	    break;
-	case P1_LITERAL:
-	    retval = do_p1_literal (infile);
-	    break;
-	case P1_LABEL:
-	    do_p1_label (infile, outfile);
-	    /* last_was_label = 1; -- now set in do_p1_label */
-	    was_c_token = 0;
-	    break;
-	case P1_ASGOTO:
-	    do_p1_asgoto (infile, outfile);
-	    break;
-	case P1_GOTO:
-	    do_p1_goto (infile, outfile);
-	    break;
-	case P1_IF:
-	    do_p1_if (infile, outfile);
-	    break;
-	case P1_ELSE:
-	    SEM_CHECK(outfile);
-	    do_p1_else (outfile);
-	    break;
-	case P1_ELIF:
-	    SEM_CHECK(outfile);
-	    do_p1_elif (infile, outfile);
-	    break;
-	case P1_ENDIF:
-	    SEM_CHECK(outfile);
-	    do_p1_endif (outfile);
-	    break;
-	case P1_ENDELSE:
-	    SEM_CHECK(outfile);
-	    do_p1_endelse (outfile);
-	    break;
-	case P1_ADDR:
-	    retval = do_p1_addr (infile, outfile);
-	    break;
-	case P1_SUBR_RET:
-	    do_p1_subr_ret (infile, outfile);
-	    break;
-	case P1_COMP_GOTO:
-	    do_p1_comp_goto (infile, outfile);
-	    break;
-	case P1_FOR:
-	    do_p1_for (infile, outfile);
-	    break;
-	case P1_ENDFOR:
-	    SEM_CHECK(outfile);
-	    do_p1_end_for (outfile);
-	    break;
-	case P1_WHILE1START:
-		do_p1_1while(outfile);
-		break;
-	case P1_WHILE2START:
-		do_p1_2while(infile, outfile);
-		break;
-	case P1_PROCODE:
-		procode(outfile);
-		break;
-	case P1_ELSEIFSTART:
-		SEM_CHECK(outfile);
-		do_p1_elseifstart(outfile);
-		break;
-	case P1_FORTRAN:
-		do_p1_fortran(infile, outfile);
-		/* no break; */
-	case P1_EOF:
-	    was_c_token = 0;
-	    break;
-	case P1_UNKNOWN:
-	    Fatal("do_format:  Unknown token type in intermediate file");
-	    break;
-	default:
-	    Fatal("do_format:  Bad token type in intermediate file");
-	    break;
-   } /* switch */
-
-    if (was_c_token)
-	last_was_label = 0;
-    return retval;
-} /* do_format */
-
-
- static void
-do_p1_comment (infile, outfile)
-FILE *infile, *outfile;
-{
-    extern int c_output_line_length, in_comment;
-
-    char storage[COMMENT_BUFFER_SIZE + 1];
-    int length;
-
-    if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1))
-	return;
-
-    length = strlen (storage);
-
-    gflag1 = 0;
-    in_comment = 1;
-    if (length > c_output_line_length - 6)
-	margin_printf (outfile, "/*%s*/\n", storage);
-    else
-	margin_printf (outfile, length ? "/* %s */\n" : "\n", storage);
-    in_comment = 0;
-    gflag1 = gflag;
-} /* do_p1_comment */
-
- static void
-do_p1_set_line (infile)
-FILE *infile;
-{
-    int status;
-    long new_line_number = -1;
-
-    status = p1getd (infile, &new_line_number);
-
-    if (status == EOF)
-	err ("do_p1_set_line:  Missing line number at end of file\n");
-    else if (status == 0 || new_line_number == -1)
-	errl("do_p1_set_line:  Illegal line number in intermediate file: %ld\n",
-		new_line_number);
-    else {
-	lineno = new_line_number;
-	}
-} /* do_p1_set_line */
-
-
-static expptr do_p1_name_pointer (infile)
-FILE *infile;
-{
-    Namep namep = (Namep) NULL;
-    int status;
-
-    status = p1getd (infile, (long *) &namep);
-
-    if (status == EOF)
-	err ("do_p1_name_pointer:  Missing pointer at end of file\n");
-    else if (status == 0 || namep == (Namep) NULL)
-	erri ("do_p1_name_pointer:  Illegal name pointer in p1 file: '%x'\n",
-		(int) namep);
-
-    return (expptr) namep;
-} /* do_p1_name_pointer */
-
-
-
-static expptr do_p1_const (infile)
-FILE *infile;
-{
-    struct Constblock *c = (struct Constblock *) NULL;
-    long type = -1;
-    int status;
-
-    status = p1getd (infile, &type);
-
-    if (status == EOF)
-	err ("do_p1_const:  Missing constant type at end of file\n");
-    else if (status == 0)
-	errl("do_p1_const:  Illegal constant type in p1 file: %ld\n", type);
-    else {
-	status = p1get_const (infile, (int)type, &c);
-
-	if (status == EOF) {
-	    err ("do_p1_const:  Missing constant value at end of file\n");
-	    c = (struct Constblock *) NULL;
-	} else if (status == 0) {
-	    err ("do_p1_const:  Illegal constant value in p1 file\n");
-	    c = (struct Constblock *) NULL;
-	} /* else */
-    } /* else */
-    return (expptr) c;
-} /* do_p1_const */
-
-
-static expptr do_p1_literal (infile)
-FILE *infile;
-{
-    int status;
-    long memno;
-    Addrp addrp;
-
-    status = p1getd (infile, &memno);
-
-    if (status == EOF)
-	err ("do_p1_literal:  Missing memno at end of file");
-    else if (status == 0)
-	err ("do_p1_literal:  Missing memno in p1 file");
-    else {
-	struct Literal *litp, *lastlit;
-
-	addrp = ALLOC (Addrblock);
-	addrp -> tag = TADDR;
-	addrp -> vtype = TYUNKNOWN;
-	addrp -> Field = NULL;
-
-	lastlit = litpool + nliterals;
-	for (litp = litpool; litp < lastlit; litp++)
-	    if (litp -> litnum == memno) {
-		addrp -> vtype = litp -> littype;
-		*((union Constant *) &(addrp -> user)) =
-			*((union Constant *) &(litp -> litval));
-		break;
-	    } /* if litp -> litnum == memno */
-
-	addrp -> memno = memno;
-	addrp -> vstg = STGMEMNO;
-	addrp -> uname_tag = UNAM_CONST;
-    } /* else */
-
-    return (expptr) addrp;
-} /* do_p1_literal */
-
-
-static void do_p1_label (infile, outfile)
-FILE *infile, *outfile;
-{
-    int status;
-    ftnint stateno;
-    char *user_label ();
-    struct Labelblock *L;
-    char *fmt;
-
-    status = p1getd (infile, &stateno);
-
-    if (status == EOF)
-	err ("do_p1_label:  Missing label at end of file");
-    else if (status == 0)
-	err ("do_p1_label:  Missing label in p1 file ");
-    else if (stateno < 0) {	/* entry */
-	margin_printf(outfile, "\n%s:\n", user_label(stateno));
-	last_was_label = 1;
-	}
-    else {
-	L = labeltab + stateno;
-	if (L->labused) {
-		fmt = "%s:\n";
-		last_was_label = 1;
-		}
-	else
-		fmt = "/* %s: */\n";
-	margin_printf(outfile, fmt, user_label(L->stateno));
-    } /* else */
-} /* do_p1_label */
-
-
-
-static void do_p1_asgoto (infile, outfile)
-FILE *infile, *outfile;
-{
-    expptr expr;
-
-    expr = do_format (infile, outfile);
-    out_asgoto (outfile, expr);
-
-} /* do_p1_asgoto */
-
-
-static void do_p1_goto (infile, outfile)
-FILE *infile, *outfile;
-{
-    int status;
-    long stateno;
-    char *user_label ();
-
-    status = p1getd (infile, &stateno);
-
-    if (status == EOF)
-	err ("do_p1_goto:  Missing goto label at end of file");
-    else if (status == 0)
-	err ("do_p1_goto:  Missing goto label in p1 file");
-    else {
-	nice_printf (outfile, "goto %s;\n", user_label (stateno));
-    } /* else */
-} /* do_p1_goto */
-
-
-static void do_p1_if (infile, outfile)
-FILE *infile, *outfile;
-{
-    expptr cond;
-
-    do {
-        cond = do_format (infile, outfile);
-    } while (cond == ENULL);
-
-    out_if (outfile, cond);
-} /* do_p1_if */
-
-
-static void do_p1_else (outfile)
-FILE *outfile;
-{
-    out_else (outfile);
-} /* do_p1_else */
-
-
-static void do_p1_elif (infile, outfile)
-FILE *infile, *outfile;
-{
-    expptr cond;
-
-    do {
-        cond = do_format (infile, outfile);
-    } while (cond == ENULL);
-
-    elif_out (outfile, cond);
-} /* do_p1_elif */
-
-static void do_p1_endif (outfile)
-FILE *outfile;
-{
-    endif_out (outfile);
-} /* do_p1_endif */
-
-
-static void do_p1_endelse (outfile)
-FILE *outfile;
-{
-    end_else_out (outfile);
-} /* do_p1_endelse */
-
-
-static expptr do_p1_addr (infile, outfile)
-FILE *infile, *outfile;
-{
-    Addrp addrp = (Addrp) NULL;
-    int status;
-
-    status = p1getn (infile, (int)sizeof(struct Addrblock), (char **) &addrp);
-
-    if (status == EOF)
-	err ("do_p1_addr:  Missing Addrp at end of file");
-    else if (status == 0)
-	err ("do_p1_addr:  Missing Addrp in p1 file");
-    else if (addrp == (Addrp) NULL)
-	err ("do_p1_addr:  Null addrp in p1 file");
-    else if (addrp -> tag != TADDR)
-	erri ("do_p1_addr: bad tag in p1 file '%d'", addrp -> tag);
-    else {
-	addrp -> vleng = do_format (infile, outfile);
-	addrp -> memoffset = do_format (infile, outfile);
-    }
-
-    return (expptr) addrp;
-} /* do_p1_addr */
-
-
-
-static void do_p1_subr_ret (infile, outfile)
-FILE *infile, *outfile;
-{
-    expptr retval;
-
-    nice_printf (outfile, "return ");
-    retval = do_format (infile, outfile);
-    if (!multitype)
-	if (retval)
-		expr_out (outfile, retval);
-
-    nice_printf (outfile, ";\n");
-} /* do_p1_subr_ret */
-
-
-
-static void do_p1_comp_goto (infile, outfile)
-FILE *infile, *outfile;
-{
-    expptr index;
-    expptr labels;
-
-    index = do_format (infile, outfile);
-
-    if (index == ENULL) {
-	err ("do_p1_comp_goto:  no expression for computed goto");
-	return;
-    } /* if index == ENULL */
-
-    labels = do_format (infile, outfile);
-
-    if (labels && labels -> tag != TLIST)
-	erri ("do_p1_comp_goto:  expected list, got tag '%d'", labels -> tag);
-    else
-	compgoto_out (outfile, index, labels);
-} /* do_p1_comp_goto */
-
-
-static void do_p1_for (infile, outfile)
-FILE *infile, *outfile;
-{
-    expptr init, test, inc;
-
-    init = do_format (infile, outfile);
-    test = do_format (infile, outfile);
-    inc = do_format (infile, outfile);
-
-    out_for (outfile, init, test, inc);
-} /* do_p1_for */
-
-static void do_p1_end_for (outfile)
-FILE *outfile;
-{
-    out_end_for (outfile);
-} /* do_p1_end_for */
-
-
- static void
-do_p1_fortran(infile, outfile)
- FILE *infile, *outfile;
-{
-	char buf[P1_STMTBUFSIZE];
-	if (!p1gets(infile, buf, P1_STMTBUFSIZE))
-		return;
-	/* bypass nice_printf nonsense */
-	fprintf(outfile, "/*< %s >*/\n", buf+1);	/* + 1 to skip by '$' */
-	}
-
-
-static expptr do_p1_expr (infile, outfile)
-FILE *infile, *outfile;
-{
-    int status;
-    long opcode, type;
-    struct Exprblock *result = (struct Exprblock *) NULL;
-
-    status = p1getd (infile, &opcode);
-
-    if (status == EOF)
-	err ("do_p1_expr:  Missing expr opcode at end of file");
-    else if (status == 0)
-	err ("do_p1_expr:  Missing expr opcode in p1 file");
-    else {
-
-	status = p1getd (infile, &type);
-
-	if (status == EOF)
-	    err ("do_p1_expr:  Missing expr type at end of file");
-	else if (status == 0)
-	    err ("do_p1_expr:  Missing expr type in p1 file");
-	else if (opcode == 0)
-	    return ENULL;
-	else {
-	    result = ALLOC (Exprblock);
-
-	    result -> tag = TEXPR;
-	    result -> vtype = type;
-	    result -> opcode = opcode;
-	    result -> vleng = do_format (infile, outfile);
-
-	    if (is_unary_op (opcode))
-		result -> leftp = do_format (infile, outfile);
-	    else if (is_binary_op (opcode)) {
-		result -> leftp = do_format (infile, outfile);
-		result -> rightp = do_format (infile, outfile);
-	    } else
-		errl("do_p1_expr:  Illegal opcode %ld", opcode);
-	} /* else */
-    } /* else */
-
-    return (expptr) result;
-} /* do_p1_expr */
-
-
-static expptr do_p1_ident(infile)
-FILE *infile;
-{
-	Addrp addrp;
-	int status;
-	long vtype, vstg;
-
-	addrp = ALLOC (Addrblock);
-	addrp -> tag = TADDR;
-
-	status = p1getd (infile, &vtype);
-	if (status == EOF)
-	    err ("do_p1_ident:  Missing identifier type at end of file\n");
-	else if (status == 0 || vtype < 0 || vtype >= NTYPES)
-	    errl("do_p1_ident:  Bad type in intermediate file: %ld\n", vtype);
-	else
-	    addrp -> vtype = vtype;
-
-	status = p1getd (infile, &vstg);
-	if (status == EOF)
-	    err ("do_p1_ident:  Missing identifier storage at end of file\n");
-	else if (status == 0 || vstg < 0 || vstg > STGNULL)
-	    errl("do_p1_ident:  Bad storage in intermediate file: %ld\n", vtype);
-	else
-	    addrp -> vstg = vstg;
-
-	status = p1gets(infile, addrp->user.ident, IDENT_LEN);
-
-	if (status == EOF)
-	    err ("do_p1_ident:  Missing ident string at end of file");
-	else if (status == 0)
-	    err ("do_p1_ident:  Missing ident string in intermediate file");
-	addrp->uname_tag = UNAM_IDENT;
-	return (expptr) addrp;
-} /* do_p1_ident */
-
-static expptr do_p1_charp(infile)
-FILE *infile;
-{
-	Addrp addrp;
-	int status;
-	long vtype, vstg;
-	char buf[64];
-
-	addrp = ALLOC (Addrblock);
-	addrp -> tag = TADDR;
-
-	status = p1getd (infile, &vtype);
-	if (status == EOF)
-	    err ("do_p1_ident:  Missing identifier type at end of file\n");
-	else if (status == 0 || vtype < 0 || vtype >= NTYPES)
-	    errl("do_p1_ident:  Bad type in intermediate file: %ld\n", vtype);
-	else
-	    addrp -> vtype = vtype;
-
-	status = p1getd (infile, &vstg);
-	if (status == EOF)
-	    err ("do_p1_ident:  Missing identifier storage at end of file\n");
-	else if (status == 0 || vstg < 0 || vstg > STGNULL)
-	    errl("do_p1_ident:  Bad storage in intermediate file: %ld\n", vtype);
-	else
-	    addrp -> vstg = vstg;
-
-	status = p1gets(infile, buf, (int)sizeof(buf));
-
-	if (status == EOF)
-	    err ("do_p1_ident:  Missing charp ident string at end of file");
-	else if (status == 0)
-	    err ("do_p1_ident:  Missing charp ident string in intermediate file");
-	addrp->uname_tag = UNAM_CHARP;
-	addrp->user.Charp = strcpy(mem(strlen(buf)+1,0), buf);
-	return (expptr) addrp;
-}
-
-
-static expptr do_p1_extern (infile)
-FILE *infile;
-{
-    Addrp addrp;
-
-    addrp = ALLOC (Addrblock);
-    if (addrp) {
-	int status;
-
-	addrp->tag = TADDR;
-	addrp->vstg = STGEXT;
-	addrp->uname_tag = UNAM_EXTERN;
-	status = p1getd (infile, &(addrp -> memno));
-	if (status == EOF)
-	    err ("do_p1_extern:  Missing memno at end of file");
-	else if (status == 0)
-	    err ("do_p1_extern:  Missing memno in intermediate file");
-	if (addrp->vtype = extsymtab[addrp->memno].extype)
-		addrp->vclass = CLPROC;
-    } /* if addrp */
-
-    return (expptr) addrp;
-} /* do_p1_extern */
-
-
-
-static expptr do_p1_head (infile, outfile)
-FILE *infile, *outfile;
-{
-    int status;
-    int add_n_;
-    long class;
-    char storage[256];
-
-    status = p1getd (infile, &class);
-    if (status == EOF)
-	err ("do_p1_head:  missing header class at end of file");
-    else if (status == 0)
-	err ("do_p1_head:  missing header class in p1 file");
-    else {
-	status = p1gets (infile, storage, (int)sizeof(storage));
-	if (status == EOF || status == 0)
-	    storage[0] = '\0';
-    } /* else */
-
-    if (class == CLPROC || class == CLMAIN) {
-	chainp lengths;
-
-	add_n_ = nentry > 1;
-	lengths = length_comp(entries, add_n_);
-
-	if (!add_n_ && protofile && class != CLMAIN)
-		protowrite(protofile, proctype, storage, entries, lengths);
-
-	if (class == CLMAIN)
-	    nice_printf (outfile, "/* Main program */ ");
-	else
-	    nice_printf(outfile, "%s ", multitype ? "VOID"
-			: c_type_decl(proctype, 1));
-
-	nice_printf(outfile, add_n_ ? "%s0_" : "%s", storage);
-	if (!Ansi) {
-		listargs(outfile, entries, add_n_, lengths);
-		nice_printf (outfile, "\n");
-		}
-	list_arg_types (outfile, entries, lengths, add_n_, "\n");
-	nice_printf (outfile, "{\n");
-	frchain(&lengths);
-	next_tab (outfile);
-	strcpy(this_proc_name, storage);
-	list_decls (outfile);
-
-    } else if (class == CLBLOCK)
-        next_tab (outfile);
-    else
-	errl("do_p1_head: got class %ld", class);
-
-    return NULL;
-} /* do_p1_head */
-
-
-static expptr do_p1_list (infile, outfile)
-FILE *infile, *outfile;
-{
-    long tag, type, count;
-    int status;
-    expptr result;
-
-    status = p1getd (infile, &tag);
-    if (status == EOF)
-	err ("do_p1_list:  missing list tag at end of file");
-    else if (status == 0)
-	err ("do_p1_list:  missing list tag in p1 file");
-    else {
-	status = p1getd (infile, &type);
-	if (status == EOF)
-	    err ("do_p1_list:  missing list type at end of file");
-	else if (status == 0)
-	    err ("do_p1_list:  missing list type in p1 file");
-	else {
-	    status = p1getd (infile, &count);
-	    if (status == EOF)
-		err ("do_p1_list:  missing count at end of file");
-	    else if (status == 0)
-		err ("do_p1_list:  missing count in p1 file");
-	} /* else */
-    } /* else */
-
-    result = (expptr) ALLOC (Listblock);
-    if (result) {
-	chainp pointer;
-
-	result -> tag = tag;
-	result -> listblock.vtype = type;
-
-/* Assume there will be enough data */
-
-	if (count--) {
-	    pointer = result->listblock.listp =
-		mkchain((char *)do_format(infile, outfile), CHNULL);
-	    while (count--) {
-		pointer -> nextp =
-			mkchain((char *)do_format(infile, outfile), CHNULL);
-		pointer = pointer -> nextp;
-	    } /* while (count--) */
-	} /* if (count) */
-    } /* if (result) */
-
-    return result;
-} /* do_p1_list */
-
-
-chainp length_comp(e, add_n)	/* get lengths of characters args */
- struct Entrypoint *e;
- int add_n;
-{
-	chainp lengths;
-	chainp args, args1;
-	Namep arg, np;
-	int nchargs;
-	Argtypes *at;
-	Atype *a;
-	extern int init_ac[TYSUBR+1];
-
-	args = args1 = add_n ? allargs : e->arglist;
-	nchargs = 0;
-	for (lengths = NULL; args; args = args -> nextp)
-		if (arg = (Namep)args->datap) {
-			if (arg->vclass == CLUNKNOWN)
-				arg->vclass = CLVAR;
-			if (arg->vtype == TYCHAR && arg->vclass != CLPROC) {
-				lengths = mkchain((char *)arg, lengths);
-				nchargs++;
-				}
-			}
-	if (!add_n && (np = e->enamep)) {
-		/* one last check -- by now we know all we ever will
-		 * about external args...
-		 */
-		save_argtypes(e->arglist, &e->entryname->arginfo,
-			&np->arginfo, 0, np->fvarname, STGEXT, nchargs,
-			np->vtype, 1);
-		at = e->entryname->arginfo;
-		a = at->atypes + init_ac[np->vtype];
-		for(; args1; a++, args1 = args1->nextp) {
-			frchain(&a->cp);
-			if (arg = (Namep)args1->datap)
-			    switch(arg->vclass) {
-				case CLPROC:
-					if (arg->vimpltype
-					&& a->type >= 300)
-						a->type = TYUNKNOWN + 200;
-					break;
-				case CLUNKNOWN:
-					a->type %= 100;
-				}
-			}
-		}
-	return revchain(lengths);
-	}
-
-void listargs(outfile, entryp, add_n_, lengths)
- FILE *outfile;
- struct Entrypoint *entryp;
- int add_n_;
- chainp lengths;
-{
-	chainp args;
-	char *s;
-	Namep arg;
-	int did_one = 0;
-
-	nice_printf (outfile, "(");
-
-	if (add_n_) {
-		nice_printf(outfile, "n__");
-		did_one = 1;
-		args = allargs;
-		}
-	else
-		args = entryp->arglist;
-
-	if (multitype)
-		{
-		nice_printf(outfile, ", ret_val");
-		did_one = 1;
-		args = allargs;
-		}
-	else if (ONEOF(proctype, MSKCOMPLEX|MSKCHAR))
-		{
-		s = xretslot[proctype]->user.ident;
-		nice_printf(outfile, did_one ? ", %s" : "%s",
-			*s == '(' /*)*/ ? "r_v" : s);
-		did_one = 1;
-		if (proctype == TYCHAR)
-			nice_printf (outfile, ", ret_val_len");
-		}
-	for (; args; args = args -> nextp)
-		if (arg = (Namep)args->datap) {
-			nice_printf (outfile, "%s", did_one ? ", " : "");
-			out_name (outfile, arg);
-			did_one = 1;
-			}
-
-	for (args = lengths; args; args = args -> nextp)
-		nice_printf(outfile, ", %s",
-			new_arg_length((Namep)args->datap));
-	nice_printf (outfile, ")");
-} /* listargs */
-
-
-void list_arg_types(outfile, entryp, lengths, add_n_, finalnl)
-FILE *outfile;
-struct Entrypoint *entryp;
-chainp lengths;
-int add_n_;
-char *finalnl;
-{
-    chainp args;
-    int last_type = -1, last_class = -1;
-    int did_one = 0, done_one, is_ext;
-    char *s, *sep = "", *sep1;
-
-    if (outfile == (FILE *) NULL) {
-	err ("list_arg_types:  null output file");
-	return;
-    } else if (entryp == (struct Entrypoint *) NULL) {
-	err ("list_arg_types:  null procedure entry pointer");
-	return;
-    } /* else */
-
-    if (Ansi) {
-	done_one = 0;
-	sep1 = ", ";
-	nice_printf(outfile, "(" /*)*/);
-	}
-    else {
-	done_one = 1;
-	sep1 = ";\n";
-	}
-    args = entryp->arglist;
-    if (add_n_) {
-	nice_printf(outfile, "int n__");
-	did_one = done_one;
-	sep = sep1;
-	args = allargs;
-	}
-    if (multitype) {
-	nice_printf(outfile, "%sMultitype *ret_val", sep);
-	did_one = done_one;
-	sep = sep1;
-	}
-    else if (ONEOF (proctype, MSKCOMPLEX|MSKCHAR)) {
-	s = xretslot[proctype]->user.ident;
-	nice_printf(outfile, "%s%s *%s", sep, c_type_decl(proctype, 0),
-			*s == '(' /*)*/ ? "r_v" : s);
-	did_one = done_one;
-	sep = sep1;
-	if (proctype == TYCHAR)
-	    nice_printf (outfile, "%sftnlen ret_val_len", sep);
-    } /* if ONEOF proctype */
-    for (; args; args = args -> nextp) {
-	Namep arg = (Namep) args->datap;
-
-/* Scalars are passed by reference, and arrays will have their lower bound
-   adjusted, so nearly everything is printed with a star in front.  The
-   exception is character lengths, which are passed by value. */
-
-	if (arg) {
-	    int type = arg -> vtype, class = arg -> vclass;
-
-	    if (class == CLPROC)
-		if (arg->vimpltype)
-			type = Castargs ? TYUNKNOWN : TYSUBR;
-		else if (type == TYREAL && forcedouble && !Castargs)
-			type = TYDREAL;
-
-	    if (type == last_type && class == last_class && did_one)
-		nice_printf (outfile, ", ");
-	    else
-		if ((is_ext = class == CLPROC) && Castargs)
-			nice_printf(outfile, "%s%s ", sep,
-				usedcasts[type] = casttypes[type]);
-		else
-			nice_printf(outfile, "%s%s ", sep,
-				c_type_decl(type, is_ext));
-	    if (class == CLPROC)
-		if (Castargs)
-			out_name(outfile, arg);
-		else {
-			nice_printf(outfile, "(*");
-			out_name(outfile, arg);
-			nice_printf(outfile, ") %s", parens);
-			}
-	    else {
-		nice_printf (outfile, "*");
-		out_name (outfile, arg);
-		}
-
-	    last_type = type;
-	    last_class = class;
-	    did_one = done_one;
-	    sep = sep1;
-	} /* if (arg) */
-    } /* for args = entryp -> arglist */
-
-    for (args = lengths; args; args = args -> nextp)
-	nice_printf(outfile, "%sftnlen %s", sep,
-			new_arg_length((Namep)args->datap));
-    if (did_one)
-	nice_printf (outfile, ";\n");
-    else if (Ansi)
-	nice_printf(outfile,
-		/*((*/ sep != sep1 && Ansi == 1 ? "void)%s" : ")%s",
-		finalnl);
-} /* list_arg_types */
-
- static void
-write_formats(outfile)
- FILE *outfile;
-{
-	register struct Labelblock *lp;
-	int first = 1;
-	char *fs;
-
-	for(lp = labeltab ; lp < highlabtab ; ++lp)
-		if (lp->fmtlabused) {
-			if (first) {
-				first = 0;
-				nice_printf(outfile, "/* Format strings */\n");
-				}
-			nice_printf(outfile, "static char fmt_%ld[] = \"",
-				lp->stateno);
-			if (!(fs = lp->fmtstring))
-				fs = "";
-			nice_printf(outfile, "%s\";\n", fs);
-			}
-	if (!first)
-		nice_printf(outfile, "\n");
-	}
-
- static void
-write_ioblocks(outfile)
- FILE *outfile;
-{
-	register iob_data *L;
-	register char *f, **s, *sep;
-
-	nice_printf(outfile, "/* Fortran I/O blocks */\n");
-	L = iob_list = (iob_data *)revchain((chainp)iob_list);
-	do {
-		nice_printf(outfile, "static %s %s = { ",
-			L->type, L->name);
-		sep = 0;
-		for(s = L->fields; f = *s; s++) {
-			if (sep)
-				nice_printf(outfile, sep);
-			sep = ", ";
-			if (*f == '"') {	/* kludge */
-				nice_printf(outfile, "\"");
-				nice_printf(outfile, "%s\"", f+1);
-				}
-			else
-				nice_printf(outfile, "%s", f);
-			}
-		nice_printf(outfile, " };\n");
-		}
-		while(L = L->next);
-	nice_printf(outfile, "\n\n");
-	}
-
- static void
-write_assigned_fmts(outfile)
- FILE *outfile;
-{
-	register chainp cp;
-	Namep np;
-	int did_one = 0;
-
-	cp = assigned_fmts = revchain(assigned_fmts);
-	nice_printf(outfile, "/* Assigned format variables */\nchar ");
-	do {
-		np = (Namep)cp->datap;
-		if (did_one)
-			nice_printf(outfile, ", ");
-		did_one = 1;
-		nice_printf(outfile, "*%s_fmt", np->fvarname);
-		}
-		while(cp = cp->nextp);
-	nice_printf(outfile, ";\n\n");
-	}
-
- static char *
-to_upper(s)
- register char *s;
-{
-	static char buf[64];
-	register char *t = buf;
-	register int c;
-	while(*t++ = (c = *s++) >= 'a' && c <= 'z' ? c + 'A' - 'a' : c);
-	return buf;
-	}
-
-
-/* This routine creates static structures representing a namelist.
-   Declarations of the namelist and related structures are:
-
-	struct Vardesc {
-		char *name;
-		char *addr;
-		ftnlen *dims;	/* laid out as struct dimensions below *//*
-		int  type;
-		};
-	typedef struct Vardesc Vardesc;
-
-	struct Namelist {
-		char *name;
-		Vardesc **vars;
-		int nvars;
-		};
-
-	struct dimensions
-		{
-		ftnlen numberofdimensions;
-		ftnlen numberofelements
-		ftnlen baseoffset;
-		ftnlen span[numberofdimensions-1];
-		};
-
-   If dims is not null, then the corner element of the array is at
-   addr.  However,  the element with subscripts (i1,...,in) is at
-   addr + sizeoftype * (i1+span[0]*(i2+span[1]*...) - dimp->baseoffset)
-*/
-
- static void
-write_namelists(nmch, outfile)
- chainp nmch;
- FILE *outfile;
-{
-	Namep var;
-	struct Hashentry *entry;
-	struct Dimblock *dimp;
-	int i, nd, type;
-	char *comma, *name;
-	register chainp q;
-	register Namep v;
-
-	nice_printf(outfile, "/* Namelist stuff */\n\n");
-	for (entry = hashtab; entry < lasthash; ++entry) {
-		if (!(v = entry->varp) || !v->vnamelist)
-			continue;
-		type = v->vtype;
-		name = v->cvarname;
-		if (dimp = v->vdim) {
-			nd = dimp->ndim;
-			nice_printf(outfile,
-				"static ftnlen %s_dims[] = { %d, %ld, %ld",
-				name, nd,
-				dimp->nelt->constblock.Const.ci,
-				dimp->baseoffset->constblock.Const.ci);
-			for(i = 0, --nd; i < nd; i++)
-				nice_printf(outfile, ", %ld",
-				  dimp->dims[i].dimsize->constblock.Const.ci);
-			nice_printf(outfile, " };\n");
-			}
-		nice_printf(outfile, "static Vardesc %s_dv = { \"%s\", %s",
-			name, to_upper(v->fvarname),
-			type == TYCHAR ? "" : dimp ? "(char *)" : "(char *)&");
-		out_name(outfile, v);
-		nice_printf(outfile, dimp ? ", %s_dims" : ", (ftnlen *)0", name);
-		nice_printf(outfile, ", %ld };\n",
-			type != TYCHAR  ? (long)type
-					: -v->vleng->constblock.Const.ci);
-		}
-
-	do {
-		var = (Namep)nmch->datap;
-		name = var->cvarname;
-		nice_printf(outfile, "\nstatic Vardesc *%s_vl[] = ", name);
-		comma = "{";
-		i = 0;
-		for(q = var->varxptr.namelist ; q ; q = q->nextp) {
-			v = (Namep)q->datap;
-			if (!v->vnamelist)
-				continue;
-			i++;
-			nice_printf(outfile, "%s &%s_dv", comma, v->cvarname);
-			comma = ",";
-			}
-		nice_printf(outfile, " };\n");
-		nice_printf(outfile,
-			"static Namelist %s = { \"%s\", %s_vl, %d };\n",
-			name, to_upper(var->fvarname), name, i);
-		}
-		while(nmch = nmch->nextp);
-	nice_printf(outfile, "\n");
-	}
-
-/* fixextype tries to infer from usage in previous procedures
-   the type of an external procedure declared
-   external and passed as an argument but never typed or invoked.
- */
-
- static int
-fixexttype(var)
- Namep var;
-{
-	Extsym *e;
-	int type, type1;
-	extern void changedtype();
-
-	type = var->vtype;
-	e = &extsymtab[var->vardesc.varno];
-	if ((type1 = e->extype) && type == TYUNKNOWN)
-		return var->vtype = type1;
-	if (var->visused) {
-		if (e->exused && type != type1)
-			changedtype(var);
-		e->exused = 1;
-		e->extype = type;
-		}
-	return type;
-	}
-
-list_decls (outfile)
-FILE *outfile;
-{
-    extern chainp used_builtins;
-    extern struct Hashentry *hashtab;
-    extern ftnint wr_char_len();
-    struct Hashentry *entry;
-    int write_header = 1;
-    int last_class = -1, last_stg = -1;
-    Namep var;
-    int Alias, Define, did_one, last_type, type;
-    extern int def_equivs, useauto;
-    extern chainp new_vars;	/* Compiler-generated locals */
-    chainp namelists = 0;
-    char *ctype;
-    int useauto1 = useauto && !saveall;
-    long x;
-    extern int hsize;
-
-/* First write out the statically initialized data */
-
-    if (initfile)
-	list_init_data(&initfile, initfname, outfile);
-
-/* Next come formats */
-    write_formats(outfile);
-
-/* Now write out the system-generated identifiers */
-
-    if (new_vars || nequiv) {
-	chainp args, next_var, this_var;
-	chainp nv[TYVOID], nv1[TYVOID];
-	int i, j;
-	Addrp Var;
-	Namep arg;
-
-	/* zap unused dimension variables */
-
-	for(args = allargs; args; args = args->nextp) {
-		arg = (Namep)args->datap;
-		if (this_var = arg->vlastdim) {
-			frexpr((tagptr)this_var->datap);
-			this_var->datap = 0;
-			}
-		}
-
-	/* sort new_vars by type, skipping entries just zapped */
-
-	for(i = TYADDR; i < TYVOID; i++)
-		nv[i] = 0;
-	for(this_var = new_vars; this_var; this_var = next_var) {
-		next_var = this_var->nextp;
-		if (Var = (Addrp)this_var->datap) {
-			if (!(this_var->nextp = nv[j = Var->vtype]))
-				nv1[j] = this_var;
-			nv[j] = this_var;
-			}
-		else {
-			this_var->nextp = 0;
-			frchain(&this_var);
-			}
-		}
-	new_vars = 0;
-	for(i = TYVOID; --i >= TYADDR;)
-		if (this_var = nv[i]) {
-			nv1[i]->nextp = new_vars;
-			new_vars = this_var;
-			}
-
-	/* write the declarations */
-
-	did_one = 0;
-	last_type = -1;
-
-	for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
-	    Var = (Addrp) this_var->datap;
-
-	    if (Var == (Addrp) NULL)
-		err ("list_decls:  null variable");
-	    else if (Var -> tag != TADDR)
-		erri ("list_decls:  bad tag on new variable '%d'",
-			Var -> tag);
-
-	    type = nv_type (Var);
-	    if (Var->vstg == STGINIT
-	    ||  Var->uname_tag == UNAM_IDENT
-			&& *Var->user.ident == ' '
-			&& multitype)
-		continue;
-	    if (!did_one)
-		nice_printf (outfile, "/* System generated locals */\n");
-
-	    if (last_type == type && did_one)
-		nice_printf (outfile, ", ");
-	    else {
-		if (did_one)
-		    nice_printf (outfile, ";\n");
-		nice_printf (outfile, "%s ",
-			c_type_decl (type, Var -> vclass == CLPROC));
-	    } /* else */
-
-/* Character type is really a string type.  Put out a '*' for parameters
-   with unknown length and functions returning character */
-
-	    if (Var -> vtype == TYCHAR && (!ISICON ((Var -> vleng))
-		    || Var -> vclass == CLPROC))
-		nice_printf (outfile, "*");
-
-	    write_nv_ident(outfile, (Addrp)this_var->datap);
-	    if (Var -> vtype == TYCHAR && Var->vclass != CLPROC &&
-		    ISICON((Var -> vleng))
-			&& (i = Var->vleng->constblock.Const.ci) > 0)
-		nice_printf (outfile, "[%d]", i);
-
-	    did_one = 1;
-	    last_type = nv_type (Var);
-	} /* for this_var */
-
-/* Handle the uninitialized equivalences */
-
-	do_uninit_equivs (outfile, &did_one);
-
-	if (did_one)
-	    nice_printf (outfile, ";\n\n");
-    } /* if new_vars */
-
-/* Write out builtin declarations */
-
-    if (used_builtins) {
-	chainp cp;
-	Extsym *es;
-
-	last_type = -1;
-	did_one = 0;
-
-	nice_printf (outfile, "/* Builtin functions */");
-
-	for (cp = used_builtins; cp; cp = cp -> nextp) {
-	    Addrp e = (Addrp)cp->datap;
-
-	    switch(type = e->vtype) {
-		case TYDREAL:
-		case TYREAL:
-			/* if (forcedouble || e->dbl_builtin) */
-			/* libF77 currently assumes everything double */
-			type = TYDREAL;
-			ctype = "double";
-			break;
-		case TYCOMPLEX:
-		case TYDCOMPLEX:
-			type = TYVOID;
-			/* no break */
-		default:
-			ctype = c_type_decl(type, 0);
-		}
-
-	    if (did_one && last_type == type)
-		nice_printf(outfile, ", ");
-	    else
-		nice_printf(outfile, "%s\n%s ", did_one ? ";" : "", ctype);
-
-	    extern_out(outfile, es = &extsymtab[e -> memno]);
-	    proto(outfile, es->arginfo, es->fextname);
-	    last_type = type;
-	    did_one = 1;
-	} /* for cp = used_builtins */
-
-	nice_printf (outfile, ";\n\n");
-    } /* if used_builtins */
-
-    last_type = -1;
-    for (entry = hashtab; entry < lasthash; ++entry) {
-	var = entry -> varp;
-
-	if (var) {
-	    int procclass = var -> vprocclass;
-	    char *comment = NULL;
-	    int stg = var -> vstg;
-	    int class = var -> vclass;
-	    type = var -> vtype;
-
-	    if (ONEOF(stg, M(STGARG)|M(STGLENG)|M(STGINIT)))
-		continue;
-
-	    if (useauto1 && stg == STGBSS && !var->vsave)
-		stg = STGAUTO;
-
-	    switch (class) {
-	        case CLVAR:
-		    break;
-		case CLPROC:
-		    switch(procclass) {
-			case PTHISPROC:
-				extsymtab[var->vardesc.varno].extype = type;
-				continue;
-			case PSTFUNCT:
-			case PINTRINSIC:
-				continue;
-			case PUNKNOWN:
-				err ("list_decls:  unknown procedure class");
-				continue;
-			case PEXTERNAL:
-				if (stg == STGUNKNOWN) {
-					warn1(
-					"%.64s declared EXTERNAL but never used.",
-						var->fvarname);
-					/* to retain names declared EXTERNAL */
-					/* but not referenced, change
-					/* "continue" to "stg = STGEXT" */
-					continue;
-					}
-				else
-					type = fixexttype(var);
-			}
-		    break;
-		case CLUNKNOWN:
-			/* declared but never used */
-			continue;
-		case CLPARAM:
-			continue;
-		case CLNAMELIST:
-			if (var->visused)
-				namelists = mkchain((char *)var, namelists);
-			continue;
-		default:
-		    erri("list_decls:  can't handle class '%d' yet",
-			    class);
-		    Fatal(var->fvarname);
-		    continue;
-	    } /* switch */
-
-	    /* Might be equivalenced to a common.  If not, don't process */
-	    if (stg == STGCOMMON && !var->vcommequiv)
-		continue;
-
-/* Only write the header if system-generated locals, builtins, or
-   uninitialized equivs were already output */
-
-	    if (write_header == 1 && (new_vars || nequiv || used_builtins)
-		    && oneof_stg ( var, stg,
-		    M(STGBSS)|M(STGEXT)|M(STGAUTO)|M(STGCOMMON)|M(STGEQUIV))) {
-		nice_printf (outfile, "/* Local variables */\n");
-		write_header = 2;
-		}
-
-
-	    Alias = oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON));
-	    if (Define = (Alias && def_equivs)) {
-		if (!write_header)
-			nice_printf(outfile, ";\n");
-		def_start(outfile, var->cvarname, CNULL, "(");
-		goto Alias1;
-		}
-	    else if (type == last_type && class == last_class &&
-		    stg == last_stg && !write_header)
-		nice_printf (outfile, ", ");
-	    else {
-		if (!write_header && ONEOF(stg, M(STGBSS)|
-		    M(STGEXT)|M(STGAUTO)|M(STGEQUIV)|M(STGCOMMON)))
-		    nice_printf (outfile, ";\n");
-
-		switch (stg) {
-		    case STGARG:
-		    case STGLENG:
-			/* Part of the argument list, don't write them out
-			   again */
-			continue;	    /* Go back to top of the loop */
-		    case STGBSS:
-		    case STGEQUIV:
-		    case STGCOMMON:
-			nice_printf (outfile, "static ");
-			break;
-		    case STGEXT:
-			nice_printf (outfile, "extern ");
-			break;
-		    case STGAUTO:
-			break;
-		    case STGINIT:
-		    case STGUNKNOWN:
-			/* Don't want to touch the initialized data, that will
-			   be handled elsewhere.  Unknown data have
-			   already been complained about, so skip them */
-			continue;
-		    default:
-			erri("list_decls:  can't handle storage class %d",
-				stg);
-			continue;
-		} /* switch */
-
-		if (type == TYCHAR && halign && class != CLPROC
-		&& ISICON(var->vleng)) {
-			nice_printf(outfile, "struct { %s fill; char val",
-				halign);
-			x = wr_char_len(outfile, var->vdim,
-				var->vleng->constblock.Const.ci, 1);
-			if (x %= hsize)
-				nice_printf(outfile, "; char fill2[%ld]",
-					hsize - x);
-			nice_printf(outfile, "; } %s_st;\n", var->cvarname);
-			def_start(outfile, var->cvarname, CNULL, var->cvarname);
-			ind_printf(0, outfile, "_st.val\n");
-			last_type = -1;
-			write_header = 2;
-			continue;
-			}
-		nice_printf(outfile, "%s ",
-			c_type_decl(type, class == CLPROC));
-	    } /* else */
-
-/* Character type is really a string type.  Put out a '*' for variable
-   length strings, and also for equivalences */
-
-	    if (type == TYCHAR && class != CLPROC
-		    && (!var->vleng || !ISICON (var -> vleng))
-	    || oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON)))
-		nice_printf (outfile, "*%s", var->cvarname);
-	    else {
-		nice_printf (outfile, "%s", var->cvarname);
-		if (class == CLPROC) {
-			Argtypes *at;
-			if (!(at = var->arginfo)
-			 && var->vprocclass == PEXTERNAL)
-				at = extsymtab[var->vardesc.varno].arginfo;
-			proto(outfile, at, var->fvarname);
-			}
-		else if (type == TYCHAR && ISICON ((var -> vleng)))
-			wr_char_len(outfile, var->vdim,
-				(int)var->vleng->constblock.Const.ci, 0);
-		else if (var -> vdim &&
-		    !oneof_stg (var, stg, M(STGEQUIV)|M(STGCOMMON)))
-			comment = wr_ardecls(outfile, var->vdim, 1L);
-		}
-
-	    if (comment)
-		nice_printf (outfile, "%s", comment);
- Alias1:
-	    if (Alias) {
-		char *amp, *lp, *name, *rp;
-		char *equiv_name ();
-		ftnint voff = var -> voffset;
-		int et0, expr_type, k;
-		Extsym *E;
-		struct Equivblock *eb;
-		char buf[16];
-
-/* We DON'T want to use oneof_stg here, because we need to distinguish
-   between them */
-
-		if (stg == STGEQUIV) {
-			name = equiv_name(k = var->vardesc.varno, CNULL);
-			eb = eqvclass + k;
-			if (eb->eqvinit) {
-				amp = "&";
-				et0 = TYERROR;
-				}
-			else {
-				amp = "";
-				et0 = eb->eqvtype;
-				}
-			expr_type = et0;
-		    }
-		else {
-			E = &extsymtab[var->vardesc.varno];
-			sprintf(name = buf, "%s%d", E->cextname, E->curno);
-			expr_type = type;
-			et0 = -1;
-			amp = "&";
-		} /* else */
-
-		if (!Define)
-			nice_printf (outfile, " = ");
-		if (voff) {
-			k = typesize[type];
-			switch((int)(voff % k)) {
-				case 0:
-					voff /= k;
-					expr_type = type;
-					break;
-				case SZSHORT:
-				case SZSHORT+SZLONG:
-					expr_type = TYSHORT;
-					voff /= SZSHORT;
-					break;
-				case SZLONG:
-					expr_type = TYLONG;
-					voff /= SZLONG;
-					break;
-				default:
-					expr_type = TYCHAR;
-				}
-			}
-
-		if (expr_type == type) {
-			lp = rp = "";
-			if (et0 == -1 && !voff)
-				goto cast;
-			}
-		else {
-			lp = "(";
-			rp = ")";
- cast:
-			nice_printf(outfile, "(%s *)", c_type_decl(type, 0));
-			}
-
-/* Now worry about computing the offset */
-
-		if (voff) {
-		    if (expr_type == et0)
-			nice_printf (outfile, "%s%s + %ld%s",
-				lp, name, voff, rp);
-		    else
-			nice_printf(outfile, "%s(%s *)%s%s + %ld%s", lp,
-				c_type_decl (expr_type, 0), amp,
-				name, voff, rp);
-		} else
-		    nice_printf(outfile, "%s%s", amp, name);
-/* Always put these at the end of the line */
-		last_type = last_class = last_stg = -1;
-		write_header = 0;
-		if (Define) {
-			ind_printf(0, outfile, ")\n");
-			write_header = 2;
-			}
-		continue;
-		}
-	    write_header = 0;
-	    last_type = type;
-	    last_class = class;
-	    last_stg = stg;
-	} /* if (var) */
-    } /* for (entry = hashtab */
-
-    if (!write_header)
-	nice_printf (outfile, ";\n\n");
-    else if (write_header == 2)
-	nice_printf(outfile, "\n");
-
-/* Next, namelists, which may reference equivs */
-
-    if (namelists) {
-	write_namelists(namelists = revchain(namelists), outfile);
-	frchain(&namelists);
-	}
-
-/* Finally, ioblocks (which may reference equivs and namelists) */
-    if (iob_list)
-	write_ioblocks(outfile);
-    if (assigned_fmts)
-	write_assigned_fmts(outfile);
-} /* list_decls */
-
-do_uninit_equivs (outfile, did_one)
-FILE *outfile;
-int *did_one;
-{
-    extern int nequiv;
-    struct Equivblock *eqv, *lasteqv = eqvclass + nequiv;
-    int k, last_type = -1, t;
-
-    for (eqv = eqvclass; eqv < lasteqv; eqv++)
-	if (!eqv -> eqvinit && eqv -> eqvtop != eqv -> eqvbottom) {
-	    if (!*did_one)
-		nice_printf (outfile, "/* System generated locals */\n");
-	    t = eqv->eqvtype;
-	    if (last_type == t)
-		nice_printf (outfile, ", ");
-	    else {
-		if (*did_one)
-		    nice_printf (outfile, ";\n");
-		nice_printf (outfile, "static %s ", c_type_decl(t, 0));
-		k = typesize[t];
-	    } /* else */
-	    nice_printf(outfile, "%s", equiv_name((int)(eqv - eqvclass), CNULL));
-	    nice_printf(outfile, "[%ld]",
-		(eqv->eqvtop - eqv->eqvbottom + k - 1) / k);
-	    last_type = t;
-	    *did_one = 1;
-	} /* if !eqv -> eqvinit */
-} /* do_uninit_equivs */
-
-
-/* wr_ardecls -- Writes the brackets and size for an array
-   declaration.  Because of the inner workings of the compiler,
-   multi-dimensional arrays get mapped directly into a one-dimensional
-   array, so we have to compute the size of the array here.  When the
-   dimension is greater than 1, a string comment about the original size
-   is returned */
-
-char *wr_ardecls(outfile, dimp, size)
-FILE *outfile;
-struct Dimblock *dimp;
-long size;
-{
-    int i, k;
-    static char buf[1000];
-
-    if (dimp == (struct Dimblock *) NULL)
-	return NULL;
-
-    sprintf(buf, "\t/* was ");	/* would like to say  k = sprintf(...), but */
-    k = strlen(buf);		/* BSD doesn't return char transmitted count */
-
-    for (i = 0; i < dimp -> ndim; i++) {
-	expptr this_size = dimp -> dims[i].dimsize;
-
-	if (!ISICON (this_size))
-	    err ("wr_ardecls:  nonconstant array size");
-	else {
-	    size *= this_size -> constblock.Const.ci;
-	    sprintf(buf+k, "[%ld]", this_size -> constblock.Const.ci);
-	    k += strlen(buf+k);	/* BSD prevents combining this with prev stmt */
-	} /* else */
-    } /* for i = 0 */
-
-    nice_printf (outfile, "[%ld]", size);
-    strcat(buf+k, " */");
-
-    return (i > 1) ? buf : NULL;
-} /* wr_ardecls */
-
-
-
-/* ----------------------------------------------------------------------
-
-	The following routines read from the p1 intermediate file.  If
-   that format changes, only these routines need be changed
-
-   ---------------------------------------------------------------------- */
-
-static int get_p1_token (infile)
-FILE *infile;
-{
-    int token = P1_UNKNOWN;
-
-/* NOT PORTABLE!! */
-
-    if (fscanf (infile, "%d", &token) == EOF)
-	return P1_EOF;
-
-/* Skip over the ": " */
-
-    if (getc (infile) != '\n')
-	getc (infile);
-
-    return token;
-} /* get_p1_token */
-
-
-
-/* Returns a (null terminated) string from the input file */
-
-static int p1gets (fp, str, size)
-FILE *fp;
-char *str;
-int size;
-{
-    char *fgets ();
-    char c;
-
-    if (str == NULL)
-	return 0;
-
-    if ((c = getc (fp)) != ' ')
-	ungetc (c, fp);
-
-    if (fgets (str, size, fp)) {
-	int length;
-
-	str[size - 1] = '\0';
-	length = strlen (str);
-
-/* Get rid of the newline */
-
-	if (str[length - 1] == '\n')
-	    str[length - 1] = '\0';
-	return 1;
-
-    } else if (feof (fp))
-	return EOF;
-    else
-	return 0;
-} /* p1gets */
-
-
-static int p1get_const (infile, type, resultp)
-FILE *infile;
-int type;
-struct Constblock **resultp;
-{
-    int status;
-    struct Constblock *result;
-
-	if (type != TYCHAR) {
-		*resultp = result = ALLOC(Constblock);
-		result -> tag = TCONST;
-		result -> vtype = type;
-		}
-
-    switch (type) {
-        case TYSHORT:
-	case TYLONG:
-	case TYLOGICAL:
-	    status = p1getd (infile, &(result -> Const.ci));
-	    break;
-	case TYREAL:
-	case TYDREAL:
-	    status = p1getf(infile, &result->Const.cds[0]);
-	    result->vstg = 1;
-	    break;
-	case TYCOMPLEX:
-	case TYDCOMPLEX:
-	    status = p1getf(infile, &result->Const.cds[0]);
-	    if (status && status != EOF)
-		status = p1getf(infile, &result->Const.cds[1]);
-	    result->vstg = 1;
-	    break;
-	case TYCHAR:
-	    status = fscanf(infile, "%lx", resultp);
-	    break;
-	default:
-	    erri ("p1get_const:  bad constant type '%d'", type);
-	    status = 0;
-	    break;
-    } /* switch */
-
-    return status;
-} /* p1get_const */
-
-static int p1getd (infile, result)
-FILE *infile;
-long *result;
-{
-    return fscanf (infile, "%ld", result);
-} /* p1getd */
-
- static int
-p1getf(infile, result)
- FILE *infile;
- char **result;
-{
-
-	char buf[1324];
-	register int k;
-
-	k = fscanf (infile, "%s", buf);
-	if (k < 1)
-		k = EOF;
-	else
-		strcpy(*result = mem(strlen(buf)+1,0), buf);
-	return k;
-}
-
-static int p1getn (infile, count, result)
-FILE *infile;
-int count;
-char **result;
-{
-
-    char *bufptr;
-    extern ptr ckalloc ();
-
-    bufptr = (char *) ckalloc (count);
-
-    if (result)
-	*result = bufptr;
-
-    for (; !feof (infile) && count > 0; count--)
-	*bufptr++ = getc (infile);
-
-    return feof (infile) ? EOF : 1;
-} /* p1getn */
-
- static void
-proto(outfile, at, fname)
- FILE *outfile;
- Argtypes *at;
- char *fname;
-{
-	int i, j, k, n;
-	char *comma;
-	Atype *atypes;
-	Namep np;
-	chainp cp;
-	extern void bad_atypes();
-
-	if (at) {
-		/* Correct types that we learn on the fly, e.g.
-			subroutine gotcha(foo)
-			external foo
-			call zap(...,foo,...)
-			call foo(...)
-		*/
-		atypes = at->atypes;
-		n = at->defined ? at->dnargs : at->nargs;
-		for(i = 0; i++ < n; atypes++) {
-			if (!(cp = atypes->cp))
-				continue;
-			j = atypes->type;
-			do {
-				np = (Namep)cp->datap;
-				k = np->vtype;
-				if (np->vclass == CLPROC) {
-					if (!np->vimpltype && k)
-						k += 200;
-					else {
-						if (j >= 300)
-							j = TYUNKNOWN + 200;
-						continue;
-						}
-					}
-				if (j == k)
-					continue;
-				if (j >= 300
-				||  j == 200 && k >= 200)
-					j = k;
-				else {
-					if (at->nargs >= 0)
-					   bad_atypes(at,fname,i,j,k,""," and");
-					goto break2;
-					}
-				}
-				while(cp = cp->nextp);
-			atypes->type = j;
-			frchain(&atypes->cp);
-			}
-		}
- break2:
-	if (parens) {
-		nice_printf(outfile, parens);
-		return;
-		}
-
-	if (!at || (n = at-> defined ? at->dnargs : at->nargs) < 0) {
-		nice_printf(outfile, Ansi == 1 ? "()" : "(...)");
-		return;
-		}
-
-	if (n == 0) {
-		nice_printf(outfile, Ansi == 1 ? "(void)" : "()");
-		return;
-		}
-
-	atypes = at->atypes;
-	nice_printf(outfile, "(");
-	comma = "";
-	for(; --n >= 0; atypes++) {
-		k = atypes->type;
-		if (k == TYADDR)
-			nice_printf(outfile, "%schar **", comma);
-		else if (k >= 200) {
-			k -= 200;
-			nice_printf(outfile, "%s%s", comma,
-				usedcasts[k] = casttypes[k]);
-			}
-		else if (k >= 100)
-			nice_printf(outfile,
-					k == TYCHAR + 100 ? "%s%s *" : "%s%s",
-					comma, c_type_decl(k-100, 0));
-		else
-			nice_printf(outfile, "%s%s *", comma,
-					c_type_decl(k, 0));
-		comma = ", ";
-		}
-	nice_printf(outfile, ")");
-	}
-
- void
-protowrite(protofile, type, name, e, lengths)
- FILE *protofile;
- char *name;
- struct Entrypoint *e;
- chainp lengths;
-{
-	extern char used_rets[];
-
-	nice_printf(protofile, "extern %s %s", protorettypes[type], name);
-	list_arg_types(protofile, e, lengths, 0, ";\n");
-	used_rets[type] = 1;
-	}
-
- static void
-do_p1_1while(outfile)
- FILE *outfile;
-{
-	if (*wh_next) {
-		nice_printf(outfile,
-			"for(;;) { /* while(complicated condition) */\n" /*}*/ );
-		next_tab(outfile);
-		}
-	else
-		nice_printf(outfile, "while(" /*)*/ );
-	}
-
- static void
-do_p1_2while(infile, outfile)
- FILE *infile, *outfile;
-{
-	expptr test;
-
-	test = do_format(infile, outfile);
-	if (*wh_next)
-		nice_printf(outfile, "if (!(");
-	expr_out(outfile, test);
-	if (*wh_next++)
-		nice_printf(outfile, "))\n\tbreak;\n");
-	else {
-		nice_printf(outfile, /*(*/ ") {\n");
-		next_tab(outfile);
-		}
-	}
-
- static void
-do_p1_elseifstart(outfile)
- FILE *outfile;
-{
-	if (*ei_next++) {
-		prev_tab(outfile);
-		nice_printf(outfile, /*{*/
-			"} else /* if(complicated condition) */ {\n" /*}*/ );
-		next_tab(outfile);
-		}
-	}
//GO.SYSIN DD format.c
echo format.h 1>&2
sed >format.h <<'//GO.SYSIN DD format.h' 's/^-//'
-#define DEF_C_LINE_LENGTH 77
-/* actual max will be 79 */
-
-extern int c_output_line_length;	/* max # chars per line in C source
-					   code */
-
-char *wr_ardecls (/* FILE *, struct Dimblock * */);
-void list_init_data (), wr_one_init (), wr_output_values ();
-int do_init_data ();
-chainp data_value ();
//GO.SYSIN DD format.h
echo formatdata.c 1>&2
sed >formatdata.c <<'//GO.SYSIN DD formatdata.c' 's/^-//'
-/****************************************************************
-Copyright 1990, 1991 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.
-****************************************************************/
-
-#include "defs.h"
-#include "output.h"
-#include "names.h"
-#include "format.h"
-
-#define MAX_INIT_LINE 100
-#define NAME_MAX 64
-
-static int memno2info();
-
-extern char *initbname;
-extern void def_start();
-
-void list_init_data(Infile, Inname, outfile)
- FILE **Infile, *outfile;
- char *Inname;
-{
-    FILE *sortfp;
-    int status;
-
-    fclose(*Infile);
-    *Infile = 0;
-
-    if (status = dsort(Inname, sortfname))
-	fatali ("sort failed, status %d", status);
-
-    scrub(Inname); /* optionally unlink Inname */
-
-    if ((sortfp = fopen(sortfname, textread)) == NULL)
-	Fatal("Couldn't open sorted initialization data");
-
-    do_init_data(outfile, sortfp);
-    fclose(sortfp);
-    scrub(sortfname);
-
-/* Insert a blank line after any initialized data */
-
-	nice_printf (outfile, "\n");
-
-    if (debugflag && infname)
-	 /* don't back block data file up -- it won't be overwritten */
-	backup(initfname, initbname);
-} /* list_init_data */
-
-
-
-/* do_init_data -- returns YES when at least one declaration has been
-   written */
-
-int do_init_data(outfile, infile)
-FILE *outfile, *infile;
-{
-    char varname[NAME_MAX], ovarname[NAME_MAX];
-    ftnint offset;
-    ftnint type;
-    int vargroup;	/* 0 --> init, 1 --> equiv, 2 --> common */
-    int did_one = 0;		/* True when one has been output */
-    chainp values = CHNULL;	/* Actual data values */
-    int keepit = 0;
-    Namep np;
-
-    ovarname[0] = '\0';
-
-    while (rdname (infile, &vargroup, varname) && rdlong (infile, &offset)
-	    && rdlong (infile, &type)) {
-	if (strcmp (varname, ovarname)) {
-
-	/* If this is a new variable name, the old initialization has been
-	   completed */
-
-		wr_one_init(outfile, ovarname, &values, keepit);
-
-		strcpy (ovarname, varname);
-		values = CHNULL;
-		if (vargroup == 0) {
-			if (memno2info(atoi(varname+2), &np)) {
-				if (((Addrp)np)->uname_tag != UNAM_NAME) {
-					err("do_init_data: expected NAME");
-					goto Keep;
-					}
-				np = ((Addrp)np)->user.name;
-				}
-			if (!(keepit = np->visused) && !np->vimpldovar)
-				warn1("local variable %s never used",
-					np->fvarname);
-			}
-		else {
- Keep:
-			keepit = 1;
-			}
-		if (keepit && !did_one) {
-			nice_printf (outfile, "/* Initialized data */\n\n");
-			did_one = YES;
-			}
-	} /* if strcmp */
-
-	values = mkchain((char *)data_value(infile, offset, (int)type), values);
-    } /* while */
-
-/* Write out the last declaration */
-
-    wr_one_init (outfile, ovarname, &values, keepit);
-
-    return did_one;
-} /* do_init_data */
-
-
- ftnint
-wr_char_len(outfile, dimp, n, extra1)
- FILE *outfile;
- int n;
- struct Dimblock *dimp;
- int extra1;
-{
-	int i, nd;
-	expptr e;
-	ftnint rv;
-
-	if (!dimp) {
-		nice_printf (outfile, extra1 ? "[%d+1]" : "[%d]", n);
-		return n + extra1;
-		}
-	nice_printf(outfile, "[%d", n);
-	nd = dimp->ndim;
-	rv = n;
-	for(i = 0; i < nd; i++) {
-		e = dimp->dims[i].dimsize;
-		if (!ISICON (e))
-			err ("wr_char_len:  nonconstant array size");
-		else {
-			nice_printf(outfile, "*%ld", e->constblock.Const.ci);
-			rv *= e->constblock.Const.ci;
-			}
-		}
-	/* extra1 allows for stupid C compilers that complain about
-	 * too many initializers in
-	 *	char x[2] = "ab";
-	 */
-	nice_printf(outfile, extra1 ? "+1]" : "]");
-	return extra1 ? rv+1 : rv;
-	}
-
- static int ch_ar_dim = -1; /* length of each element of char string array */
- static int eqvmemno;	/* kludge */
-
- static void
-write_char_init(outfile, Values, namep)
- FILE *outfile;
- chainp *Values;
- Namep namep;
-{
-	struct Equivblock *eqv;
-	long size;
-	struct Dimblock *dimp;
-	int i, nd, type;
-	expptr ds;
-
-	if (!namep)
-		return;
-	if(nequiv >= maxequiv)
-		many("equivalences", 'q', maxequiv);
-	eqv = &eqvclass[nequiv];
-	eqv->eqvbottom = 0;
-	type = namep->vtype;
-	size = type == TYCHAR
-		? namep->vleng->constblock.Const.ci
-		: typesize[type];
-	if (dimp = namep->vdim)
-		for(i = 0, nd = dimp->ndim; i < nd; i++) {
-			ds = dimp->dims[i].dimsize;
-			if (!ISICON(ds))
-				err("write_char_values: nonconstant array size");
-			else
-				size *= ds->constblock.Const.ci;
-			}
-	*Values = revchain(*Values);
-	eqv->eqvtop = size;
-	eqvmemno = ++lastvarno;
-	eqv->eqvtype = type;
-	wr_equiv_init(outfile, nequiv, Values, 0);
-	def_start(outfile, namep->cvarname, CNULL, "");
-	if (type == TYCHAR)
-		ind_printf(0, outfile, "((char *)&equiv_%d)\n\n", eqvmemno);
-	else
-		ind_printf(0, outfile, dimp
-			? "((%s *)&equiv_%d)\n\n" : "(*(%s *)&equiv_%d)\n\n",
-			c_type_decl(type,0), eqvmemno);
-	}
-
-/* wr_one_init -- outputs the initialization of the variable pointed to
-   by   info.   When   is_addr   is true,   info   is an Addrp; otherwise,
-   treat it as a Namep */
-
-void wr_one_init (outfile, varname, Values, keepit)
-FILE *outfile;
-char *varname;
-chainp *Values;
-int keepit;
-{
-    static int memno;
-    static union {
-	Namep name;
-	Addrp addr;
-    } info;
-    Namep namep;
-    int is_addr, size, type;
-    ftnint last, loc;
-    int is_scalar = 0;
-    char *array_comment = NULL, *name;
-    chainp cp, values;
-    extern char datachar[];
-    static int e1[3] = {1, 0, 1};
-    ftnint x;
-    extern int hsize;
-
-    if (!keepit)
-	goto done;
-    if (varname == NULL || varname[1] != '.')
-	goto badvar;
-
-/* Get back to a meaningful representation; find the given   memno in one
-   of the appropriate tables (user-generated variables in the hash table,
-   system-generated variables in a separate list */
-
-    memno = atoi(varname + 2);
-    switch(varname[0]) {
-	case 'q':
-		/* Must subtract eqvstart when the source file
-		 * contains more than one procedure.
-		 */
-		wr_equiv_init(outfile, eqvmemno = memno - eqvstart, Values, 0);
-		goto done;
-	case 'Q':
-		/* COMMON initialization (BLOCK DATA) */
-		wr_equiv_init(outfile, memno, Values, 1);
-		goto done;
-	case 'v':
-		break;
-	default:
- badvar:
-		errstr("wr_one_init:  unknown variable name '%s'", varname);
-		goto done;
-	}
-
-    is_addr = memno2info (memno, &info.name);
-    if (info.name == (Namep) NULL) {
-	err ("wr_one_init -- unknown variable");
-	return;
-	}
-    if (is_addr) {
-	if (info.addr -> uname_tag != UNAM_NAME) {
-	    erri ("wr_one_init -- couldn't get name pointer; tag is %d",
-		    info.addr -> uname_tag);
-	    namep = (Namep) NULL;
-	    nice_printf (outfile, " /* bad init data */");
-	} else
-	    namep = info.addr -> user.name;
-    } else
-	namep = info.name;
-
-	/* check for character initialization */
-
-    *Values = values = revchain(*Values);
-    type = info.name->vtype;
-    if (type == TYCHAR) {
-	for(last = 0; values; values = values->nextp) {
-		cp = (chainp)values->datap;
-		loc = (ftnint)cp->datap;
-		if (loc > last) {
-			write_char_init(outfile, Values, namep);
-			goto done;
-			}
-		last = (int)cp->nextp->datap == TYBLANK
-			? loc + (int)cp->nextp->nextp->datap
-			: loc + 1;
-		}
-	if (halign && info.name->tag == TNAME) {
-		nice_printf(outfile, "static struct { %s fill; char val",
-			halign);
-		x = wr_char_len(outfile, namep->vdim, ch_ar_dim =
-			info.name -> vleng -> constblock.Const.ci, 1);
-		if (x %= hsize)
-			nice_printf(outfile, "; char fill2[%ld]", hsize - x);
-		name = info.name->cvarname;
-		nice_printf(outfile, "; } %s_st = { 0,", name);
-		wr_output_values(outfile, namep, *Values);
-		nice_printf(outfile, " };\n");
-		ch_ar_dim = -1;
-		def_start(outfile, name, CNULL, name);
-		ind_printf(0, outfile, "_st.val\n");
-		goto done;
-		}
-	}
-    else {
-	size = typesize[type];
-	loc = 0;
-	for(; values; values = values->nextp) {
-		if ((int)((chainp)values->datap)->nextp->datap == TYCHAR) {
-			write_char_init(outfile, Values, namep);
-			goto done;
-			}
-		last = ((long) ((chainp) values->datap)->datap) / size;
-		if (last - loc > 4) {
-			write_char_init(outfile, Values, namep);
-			goto done;
-			}
-		loc = last;
-		}
-	}
-    values = *Values;
-
-    nice_printf (outfile, "static %s ", c_type_decl (type, 0));
-
-    if (is_addr)
-	write_nv_ident (outfile, info.addr);
-    else
-	out_name (outfile, info.name);
-
-    if (namep)
-	is_scalar = namep -> vdim == (struct Dimblock *) NULL;
-
-    if (namep && !is_scalar)
-	array_comment = type == TYCHAR
-		? 0 : wr_ardecls(outfile, namep->vdim, 1L);
-
-    if (type == TYCHAR)
-	if (ISICON (info.name -> vleng))
-
-/* We'll make single strings one character longer, so that we can use the
-   standard C initialization.  All this does is pad an extra zero onto the
-   end of the string */
-		wr_char_len(outfile, namep->vdim, ch_ar_dim =
-			info.name -> vleng -> constblock.Const.ci, e1[Ansi]);
-	else
-		err ("variable length character initialization");
-
-    if (array_comment)
-	nice_printf (outfile, "%s", array_comment);
-
-    nice_printf (outfile, " = ");
-    wr_output_values (outfile, namep, values);
-    ch_ar_dim = -1;
-    nice_printf (outfile, ";\n");
- done:
-    frchain(Values);
-} /* wr_one_init */
-
-
-
-
-chainp data_value (infile, offset, type)
-FILE *infile;
-ftnint offset;
-int type;
-{
-    char line[MAX_INIT_LINE + 1], *pointer;
-    chainp vals, prev_val;
-    long atol();
-    char *newval;
-
-    if (fgets (line, MAX_INIT_LINE, infile) == NULL) {
-	err ("data_value:  error reading from intermediate file");
-	return CHNULL;
-    } /* if fgets */
-
-/* Get rid of the trailing newline */
-
-    if (line[0])
-	line[strlen (line) - 1] = '\0';
-
-#define iswhite(x) (isspace (x) || (x) == ',')
-
-    pointer = line;
-    prev_val = vals = CHNULL;
-
-    while (*pointer) {
-	register char *end_ptr, old_val;
-
-/* Move   pointer   to the start of the next word */
-
-	while (*pointer && iswhite (*pointer))
-	    pointer++;
-	if (*pointer == '\0')
-	    break;
-
-/* Move   end_ptr   to the end of the current word */
-
-	for (end_ptr = pointer + 1; *end_ptr && !iswhite (*end_ptr);
-		end_ptr++)
-	    ;
-
-	old_val = *end_ptr;
-	*end_ptr = '\0';
-
-/* Add this value to the end of the list */
-
-	if (ONEOF(type, MSKREAL|MSKCOMPLEX))
-		newval = cpstring(pointer);
-	else
-		newval = (char *)atol(pointer);
-	if (vals) {
-	    prev_val->nextp = mkchain(newval, CHNULL);
-	    prev_val = prev_val -> nextp;
-	} else
-	    prev_val = vals = mkchain(newval, CHNULL);
-	*end_ptr = old_val;
-	pointer = end_ptr;
-    } /* while *pointer */
-
-    return mkchain((char *)offset, mkchain((char *)LONG_CAST type, vals));
-} /* data_value */
-
- static void
-overlapping()
-{
-	extern char *filename0;
-	static int warned = 0;
-
-	if (warned)
-		return;
-	warned = 1;
-
-	fprintf(stderr, "Error");
-	if (filename0)
-		fprintf(stderr, " in file %s", filename0);
-	fprintf(stderr, ": overlapping initializations\n");
-	nerr++;
-	}
-
- static void make_one_const();
- static long charlen;
-
-void wr_output_values (outfile, namep, values)
-FILE *outfile;
-Namep namep;
-chainp values;
-{
-	int type = TYUNKNOWN;
-	struct Constblock Const;
-	static expptr Vlen;
-
-	if (namep)
-		type = namep -> vtype;
-
-/* Handle array initializations away from scalars */
-
-	if (namep && namep -> vdim)
-		wr_array_init (outfile, namep -> vtype, values);
-
-	else if (values->nextp && type != TYCHAR)
-		overlapping();
-
-	else {
-		make_one_const(type, &Const.Const, values);
-		Const.vtype = type;
-		Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX);
-		if (type== TYCHAR) {
-			if (!Vlen)
-				Vlen = ICON(0);
-			Const.vleng = Vlen;
-			Vlen->constblock.Const.ci = charlen;
-			out_const (outfile, &Const);
-			free (Const.Const.ccp);
-			}
-		else
-			out_const (outfile, &Const);
-		}
-	}
-
-
-wr_array_init (outfile, type, values)
-FILE *outfile;
-int type;
-chainp values;
-{
-    int size = typesize[type];
-    long index, main_index = 0;
-    int k;
-
-    if (type == TYCHAR) {
-	nice_printf(outfile, "\"");
-	k = 0;
-	if (Ansi != 1)
-		ch_ar_dim = -1;
-	}
-    else
-	nice_printf (outfile, "{ ");
-    while (values) {
-	struct Constblock Const;
-
-	index = ((long) ((chainp) values->datap)->datap) / size;
-	while (index > main_index) {
-
-/* Fill with zeros.  The structure shorthand works because the compiler
-   will expand the "0" in braces to fill the size of the entire structure
-   */
-
-	    switch (type) {
-	        case TYREAL:
-		case TYDREAL:
-		    nice_printf (outfile, "0.0,");
-		    break;
-		case TYCOMPLEX:
-		case TYDCOMPLEX:
-		    nice_printf (outfile, "{0},");
-		    break;
-		case TYCHAR:
-			nice_printf(outfile, " ");
-			break;
-		default:
-		    nice_printf (outfile, "0,");
-		    break;
-	    } /* switch */
-	    main_index++;
-	} /* while index > main_index */
-
-	if (index < main_index)
-		overlapping();
-	else switch (type) {
-	    case TYCHAR:
-		{ int this_char;
-
-		if (k == ch_ar_dim) {
-			nice_printf(outfile, "\" \"");
-			k = 0;
-			}
-		this_char = (int) ((chainp) values->datap)->
-				nextp->nextp->datap;
-		if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
-			main_index += this_char;
-			k += this_char;
-			while(--this_char >= 0)
-				nice_printf(outfile, " ");
-			values = values -> nextp;
-			continue;
-			}
-		nice_printf(outfile, str_fmt[this_char], this_char);
-		k++;
-		} /* case TYCHAR */
-	        break;
-
-	    case TYSHORT:
-	    case TYLONG:
-	    case TYREAL:
-	    case TYDREAL:
-	    case TYLOGICAL:
-	    case TYCOMPLEX:
-	    case TYDCOMPLEX:
-		make_one_const(type, &Const.Const, values);
-		Const.vtype = type;
-		Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX);
-		out_const(outfile, &Const);
-	        break;
-	    default:
-	        erri("wr_array_init: bad type '%d'", type);
-	        break;
-	} /* switch */
-	values = values->nextp;
-
-	main_index++;
-	if (values && type != TYCHAR)
-	    nice_printf (outfile, ",");
-    } /* while values */
-
-    if (type == TYCHAR) {
-	nice_printf(outfile, "\"");
-	}
-    else
-	nice_printf (outfile, " }");
-} /* wr_array_init */
-
-
- static void
-make_one_const(type, storage, values)
- int type;
- union Constant *storage;
- chainp values;
-{
-    union Constant *Const;
-    register char **L;
-
-    if (type == TYCHAR) {
-	char *str, *str_ptr;
-	chainp v, prev;
-	int b = 0, k, main_index = 0;
-
-/* Find the max length of init string, by finding the highest offset
-   value stored in the list of initial values */
-
-	for(k = 1, prev = CHNULL, v = values; v; prev = v, v = v->nextp)
-	    ;
-	if (prev != CHNULL)
-	    k = ((int) (((chainp) prev->datap)->datap)) + 2;
-		/* + 2 above for null char at end */
-	str = Alloc (k);
-	for (str_ptr = str; values; str_ptr++) {
-	    int index = (int) (((chainp) values->datap)->datap);
-
-	    if (index < main_index)
-		overlapping();
-	    while (index > main_index++)
-		*str_ptr++ = ' ';
-
-		k = (int) (((chainp) values->datap)->nextp->nextp->datap);
-		if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
-			b = k;
-			break;
-			}
-		*str_ptr = k;
-		values = values -> nextp;
-	} /* for str_ptr */
-	*str_ptr = '\0';
-	Const = storage;
-	Const -> ccp = str;
-	Const -> ccp1.blanks = b;
-	charlen = str_ptr - str;
-    } else {
-	int i = 0;
-	chainp vals;
-
-	vals = ((chainp)values->datap)->nextp->nextp;
-	if (vals) {
-		L = (char **)storage;
-		do L[i++] = vals->datap;
-			while(vals = vals->nextp);
-		}
-
-    } /* else */
-
-} /* make_one_const */
-
-
-
-rdname (infile, vargroupp, name)
-FILE *infile;
-int *vargroupp;
-char *name;
-{
-    register int i, c;
-
-    c = getc (infile);
-
-    if (feof (infile))
-	return NO;
-
-    *vargroupp = c - '0';
-    for (i = 1;; i++) {
-	if (i >= NAME_MAX)
-		Fatal("rdname: oversize name");
-	c = getc (infile);
-	if (feof (infile))
-	    return NO;
-	if (c == '\t')
-		break;
-	*name++ = c;
-    }
-    *name = 0;
-    return YES;
-} /* rdname */
-
-rdlong (infile, n)
-FILE *infile;
-ftnint *n;
-{
-    register int c;
-
-    for (c = getc (infile); !feof (infile) && isspace (c); c = getc (infile))
-	;
-
-    if (feof (infile))
-	return NO;
-
-    for (*n = 0; isdigit (c); c = getc (infile))
-	*n = 10 * (*n) + c - '0';
-    return YES;
-} /* rdlong */
-
-
- static int
-memno2info (memno, info)
- int memno;
- Namep *info;
-{
-    chainp this_var;
-    extern chainp new_vars;
-    extern struct Hashentry *hashtab, *lasthash;
-    struct Hashentry *entry;
-
-    for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
-	Addrp var = (Addrp) this_var->datap;
-
-	if (var == (Addrp) NULL)
-	    Fatal("memno2info:  null variable");
-	else if (var -> tag != TADDR)
-	    Fatal("memno2info:  bad tag");
-	if (memno == var -> memno) {
-	    *info = (Namep) var;
-	    return 1;
-	} /* if memno == var -> memno */
-    } /* for this_var = new_vars */
-
-    for (entry = hashtab; entry < lasthash; ++entry) {
-	Namep var = entry -> varp;
-
-	if (var && var -> vardesc.varno == memno && var -> vstg == STGINIT) {
-	    *info = (Namep) var;
-	    return 0;
-	} /* if entry -> vardesc.varno == memno */
-    } /* for entry = hashtab */
-
-    Fatal("memno2info:  couldn't find memno");
-    return 0;
-} /* memno2info */
-
- static chainp
-do_string(outfile, v, nloc)
- FILEP outfile;
- register chainp v;
- ftnint *nloc;
-{
-	register chainp cp, v0;
-	ftnint dloc, k, loc;
-	unsigned long uk;
-	char buf[8], *comma;
-
-	nice_printf(outfile, "{");
-	cp = (chainp)v->datap;
-	loc = (ftnint)cp->datap;
-	comma = "";
-	for(v0 = v;;) {
-		switch((int)cp->nextp->datap) {
-			case TYBLANK:
-				k = (ftnint)cp->nextp->nextp->datap;
-				loc += k;
-				while(--k >= 0) {
-					nice_printf(outfile, "%s' '", comma);
-					comma = ", ";
-					}
-				break;
-			case TYCHAR:
-				uk = (ftnint)cp->nextp->nextp->datap;
-				sprintf(buf, chr_fmt[uk], uk);
-				nice_printf(outfile, "%s'%s'", comma, buf);
-				comma = ", ";
-				loc++;
-				break;
-			default:
-				goto done;
-			}
-		v0 = v;
-		if (!(v = v->nextp))
-			break;
-		cp = (chainp)v->datap;
-		dloc = (ftnint)cp->datap;
-		if (loc != dloc)
-			break;
-		}
- done:
-	nice_printf(outfile, "}");
-	*nloc = loc;
-	return v0;
-	}
-
- static chainp
-Ado_string(outfile, v, nloc)
- FILEP outfile;
- register chainp v;
- ftnint *nloc;
-{
-	register chainp cp, v0;
-	ftnint dloc, k, loc;
-
-	nice_printf(outfile, "\"");
-	cp = (chainp)v->datap;
-	loc = (ftnint)cp->datap;
-	for(v0 = v;;) {
-		switch((int)cp->nextp->datap) {
-			case TYBLANK:
-				k = (ftnint)cp->nextp->nextp->datap;
-				loc += k;
-				while(--k >= 0)
-					nice_printf(outfile, " ");
-				break;
-			case TYCHAR:
-				k = (ftnint)cp->nextp->nextp->datap;
-				nice_printf(outfile, str_fmt[k], k);
-				loc++;
-				break;
-			default:
-				goto done;
-			}
-		v0 = v;
-		if (!(v = v->nextp))
-			break;
-		cp = (chainp)v->datap;
-		dloc = (ftnint)cp->datap;
-		if (loc != dloc)
-			break;
-		}
- done:
-	nice_printf(outfile, "\"");
-	*nloc = loc;
-	return v0;
-	}
-
- static char *
-Len(L,type)
- long L;
- int type;
-{
-	static char buf[24];
-	if (L == 1 && type != TYCHAR)
-		return "";
-	sprintf(buf, "[%ld]", L);
-	return buf;
-	}
-
-wr_equiv_init(outfile, memno, Values, iscomm)
- FILE *outfile;
- int memno;
- chainp *Values;
- int iscomm;
-{
-	struct Equivblock *eqv;
-	char *equiv_name ();
-	int curtype, dtype, filltype, filltype1, j, k, wasblank, xtype;
-	static char Blank[] = "";
-	register char *comma = Blank;
-	register chainp cp, v;
-	chainp sentinel, values, v1;
-	ftnint L, L1, dL, dloc, loc, loc0;
-	union Constant Const;
-	char imag_buf[50], real_buf[50];
-	int szshort = typesize[TYSHORT];
-	static char typepref[] = {0, 0, TYSHORT, TYLONG, TYREAL, TYDREAL,
-				  TYREAL, TYDREAL, TYLOGICAL, TYCHAR};
-	extern int htype;
-	char *z;
-
-	/* add sentinel */
-	if (iscomm) {
-		L = extsymtab[memno].maxleng;
-		xtype = extsymtab[memno].extype;
-		}
-	else {
-		eqv = &eqvclass[memno];
-		L = eqv->eqvtop - eqv->eqvbottom;
-		xtype = eqv->eqvtype;
-		}
-
-	if (halign && typealign[typepref[xtype]] < typealign[htype])
-		xtype = htype;
-
-	if (xtype != TYCHAR) {
-
-		/* unless the data include a value of the appropriate
-		 * type, we add an extra element in an attempt
-		 * to force correct alignment */
-
-		for(v = *Values;;v = v->nextp) {
-			if (!v) {
-				dtype = typepref[xtype];
-				z = ISREAL(dtype) ? cpstring("0.") : (char *)0;
-				k = typesize[dtype];
-				if (j = L % k)
-					L += k - j;
-				v = mkchain((char *)L,
-					mkchain((char *)LONG_CAST dtype,
-						mkchain(z, CHNULL)));
-				*Values = mkchain((char *)v, *Values);
-				L += k;
-				break;
-				}
-			if ((int)((chainp)v->datap)->nextp->datap == xtype)
-				break;
-			}
-		}
-
-	sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL));
-	*Values = values = revchain(mkchain((char *)sentinel, *Values));
-
-	/* use doublereal fillers only if there are doublereal values */
-
-	k = TYLONG;
-	for(v = values; v; v = v->nextp)
-		if (ONEOF((int)((chainp)v->datap)->nextp->datap,
-				M(TYDREAL)|M(TYDCOMPLEX))) {
-			k = TYDREAL;
-			break;
-			}
-	type_choice[0] = k;
-
-	nice_printf(outfile, "%sstruct {\n", iscomm ? "" : "static ");
-	next_tab(outfile);
-	loc = loc0 = k = 0;
-	curtype = -1;
-	for(v = values; v; v = v->nextp) {
-		cp = (chainp)v->datap;
-		dloc = (ftnint)cp->datap;
-		L = dloc - loc;
-		if (L < 0) {
-			overlapping();
-			v1 = cp;
-			frchain(&v1);
-			v->datap = 0;
-			continue;
-			}
-		dtype = (int)cp->nextp->datap;
-		if (dtype == TYBLANK) {
-			dtype = TYCHAR;
-			wasblank = 1;
-			}
-		else
-			wasblank = 0;
-		if (curtype != dtype || L > 0) {
-			if (curtype != -1) {
-				L1 = (loc - loc0)/dL;
-				nice_printf(outfile, "%s e_%d%s;\n",
-					typename[curtype], ++k,
-					Len(L1,curtype));
-				}
-			curtype = dtype;
-			loc0 = dloc;
-			}
-		if (L > 0) {
-			if (xtype == TYCHAR)
-				filltype = TYCHAR;
-			else {
-				filltype = L % szshort ? TYCHAR
-						: type_choice[L/szshort % 4];
-				filltype1 = loc % szshort ? TYCHAR
-						: type_choice[loc/szshort % 4];
-				if (typesize[filltype] > typesize[filltype1])
-					filltype = filltype1;
-				}
-			L1 = L / typesize[filltype];
-			nice_printf(outfile, "%s fill_%d[%ld];\n",
-				typename[filltype], ++k, L1);
-			loc = dloc;
-			}
-		if (wasblank) {
-			loc += (ftnint)cp->nextp->nextp->datap;
-			dL = 1;
-			}
-		else {
-			dL = typesize[dtype];
-			loc += dL;
-			}
-		}
-	nice_printf(outfile, "} %s = { ", iscomm
-		? extsymtab[memno].cextname
-		: equiv_name(eqvmemno, CNULL));
-	loc = 0;
-	for(v = values; ; v = v->nextp) {
-		cp = (chainp)v->datap;
-		if (!cp)
-			continue;
-		dtype = (int)cp->nextp->datap;
-		if (dtype == TYERROR)
-			break;
-		dloc = (ftnint)cp->datap;
-		if (dloc > loc) {
-			nice_printf(outfile, "%s{0}", comma);
-			comma = ", ";
-			loc = dloc;
-			}
-		if (comma != Blank)
-			nice_printf(outfile, ", ");
-		comma = ", ";
-		if (dtype == TYCHAR || dtype == TYBLANK) {
-			v =  Ansi == 1  ? Ado_string(outfile, v, &loc)
-					:  do_string(outfile, v, &loc);
-			continue;
-			}
-		make_one_const(dtype, &Const, v);
-		switch(dtype) {
-			case TYLOGICAL:
-				if (Const.ci < 0 || Const.ci > 1)
-					errl(
-			  "wr_equiv_init: unexpected logical value %ld",
-						Const.ci);
-				nice_printf(outfile,
-					Const.ci ? "TRUE_" : "FALSE_");
-				break;
-			case TYSHORT:
-			case TYLONG:
-				nice_printf(outfile, "%ld", Const.ci);
-				break;
-			case TYREAL:
-				nice_printf(outfile, "%s",
-					flconst(real_buf, Const.cds[0]));
-				break;
-			case TYDREAL:
-				nice_printf(outfile, "%s", Const.cds[0]);
-				break;
-			case TYCOMPLEX:
-				nice_printf(outfile, "%s, %s",
-					flconst(real_buf, Const.cds[0]),
-					flconst(imag_buf, Const.cds[1]));
-				break;
-			case TYDCOMPLEX:
-				nice_printf(outfile, "%s, %s",
-					Const.cds[0], Const.cds[1]);
-				break;
-			default:
-				erri("unexpected type %d in wr_equiv_init",
-					dtype);
-			}
-		loc += typesize[dtype];
-		}
-	nice_printf(outfile, " };\n\n");
-	prev_tab(outfile);
-	frchain(&sentinel);
-	}
//GO.SYSIN DD formatdata.c
echo ftypes.h 1>&2
sed >ftypes.h <<'//GO.SYSIN DD ftypes.h' 's/^-//'
-
-/* variable types (stored in the   vtype  field of   expptr)
- * numeric assumptions:
- *	int < reals < complexes
- *	TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX
- */
-
-#define TYUNKNOWN 0
-#define TYADDR 1
-#define TYSHORT 2
-#define TYLONG 3
-#define TYREAL 4
-#define TYDREAL 5
-#define TYCOMPLEX 6
-#define TYDCOMPLEX 7
-#define TYLOGICAL 8
-#define TYCHAR 9
-#define TYSUBR 10
-#define TYERROR 11
-#define TYCILIST 12
-#define TYICILIST 13
-#define TYOLIST 14
-#define TYCLLIST 15
-#define TYALIST 16
-#define TYINLIST 17
-#define TYVOID 18
-#define TYLABEL 19
-#define TYFTNLEN 20
-/* TYVOID is not in any tables. */
-
-/* NTYPES, NTYPES0 -- Total number of types, used to allocate tables indexed by
-   type.  Such tables can include the size (in bytes) of objects of a given
-   type, or labels for returning objects of different types from procedures
-   (see array   rtvlabels)   */
-
-#define NTYPES TYVOID
-#define NTYPES0 TYCILIST
-#define TYBLANK TYSUBR		/* Huh? */
-
//GO.SYSIN DD ftypes.h
echo gram.dcl 1>&2
sed >gram.dcl <<'//GO.SYSIN DD gram.dcl' 's/^-//'
-spec:	  dcl
-	| common
-	| external
-	| intrinsic
-	| equivalence
-	| data
-	| implicit
-	| namelist
-	| SSAVE
-		{ NO66("SAVE statement");
-		  saveall = YES; }
-	| SSAVE savelist
-		{ NO66("SAVE statement"); }
-	| SFORMAT
-		{ fmtstmt(thislabel); setfmt(thislabel); }
-	| SPARAM in_dcl SLPAR paramlist SRPAR
-		{ NO66("PARAMETER statement"); }
-	;
-
-dcl:	  type opt_comma name in_dcl new_dcl dims lengspec
-		{ settype($3, $1, $7);
-		  if(ndim>0) setbound($3,ndim,dims);
-		}
-	| dcl SCOMMA name dims lengspec
-		{ settype($3, $1, $5);
-		  if(ndim>0) setbound($3,ndim,dims);
-		}
-	| dcl SSLASHD datainit vallist SSLASHD
-		{ if (new_dcl == 2) {
-			err("attempt to give DATA in type-declaration");
-			new_dcl = 1;
-			}
-		}
-	;
-
-new_dcl:	{ new_dcl = 2; }
-
-type:	  typespec lengspec
-		{ varleng = $2;
-		  if (vartype == TYLOGICAL && varleng == 1) {
-			varleng = 0;
-			err("treating LOGICAL*1 as LOGICAL");
-			--nerr;	/* allow generation of .c file */
-			}
-		}
-	;
-
-typespec:  typename
-		{ varleng = ($1<0 || $1==TYLONG ? 0 : typesize[$1]);
-		  vartype = $1; }
-	;
-
-typename:    SINTEGER	{ $$ = TYLONG; }
-	| SREAL		{ $$ = tyreal; }
-	| SCOMPLEX	{ ++complex_seen; $$ = tycomplex; }
-	| SDOUBLE	{ $$ = TYDREAL; }
-	| SDCOMPLEX	{ ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); $$ = TYDCOMPLEX; }
-	| SLOGICAL	{ $$ = TYLOGICAL; }
-	| SCHARACTER	{ NO66("CHARACTER statement"); $$ = TYCHAR; }
-	| SUNDEFINED	{ $$ = TYUNKNOWN; }
-	| SDIMENSION	{ $$ = TYUNKNOWN; }
-	| SAUTOMATIC	{ NOEXT("AUTOMATIC statement"); $$ = - STGAUTO; }
-	| SSTATIC	{ NOEXT("STATIC statement"); $$ = - STGBSS; }
-	;
-
-lengspec:
-		{ $$ = varleng; }
-	| SSTAR intonlyon expr intonlyoff
-		{
-		expptr p;
-		p = $3;
-		NO66("length specification *n");
-		if( ! ISICON(p) || p->constblock.Const.ci <= 0 )
-			{
-			$$ = 0;
-			dclerr("length must be a positive integer constant",
-				NPNULL);
-			}
-		else {
-			if (vartype == TYCHAR)
-				$$ = p->constblock.Const.ci;
-			else switch((int)p->constblock.Const.ci) {
-				case 1:	$$ = 1; break;
-				case 2: $$ = typesize[TYSHORT];	break;
-				case 4: $$ = typesize[TYLONG];	break;
-				case 8: $$ = typesize[TYDREAL];	break;
-				case 16: $$ = typesize[TYDCOMPLEX]; break;
-				default:
-					dclerr("invalid length",NPNULL);
-					$$ = varleng;
-				}
-			}
-		}
-	| SSTAR intonlyon SLPAR SSTAR SRPAR intonlyoff
-		{ NO66("length specification *(*)"); $$ = -1; }
-	;
-
-common:	  SCOMMON in_dcl var
-		{ incomm( $$ = comblock("") , $3 ); }
-	| SCOMMON in_dcl comblock var
-		{ $$ = $3;  incomm($3, $4); }
-	| common opt_comma comblock opt_comma var
-		{ $$ = $3;  incomm($3, $5); }
-	| common SCOMMA var
-		{ incomm($1, $3); }
-	;
-
-comblock:  SCONCAT
-		{ $$ = comblock(""); }
-	| SSLASH SNAME SSLASH
-		{ $$ = comblock(token); }
-	;
-
-external: SEXTERNAL in_dcl name
-		{ setext($3); }
-	| external SCOMMA name
-		{ setext($3); }
-	;
-
-intrinsic:  SINTRINSIC in_dcl name
-		{ NO66("INTRINSIC statement"); setintr($3); }
-	| intrinsic SCOMMA name
-		{ setintr($3); }
-	;
-
-equivalence:  SEQUIV in_dcl equivset
-	| equivalence SCOMMA equivset
-	;
-
-equivset:  SLPAR equivlist SRPAR
-		{
-		struct Equivblock *p;
-		if(nequiv >= maxequiv)
-			many("equivalences", 'q', maxequiv);
-		p  =  & eqvclass[nequiv++];
-		p->eqvinit = NO;
-		p->eqvbottom = 0;
-		p->eqvtop = 0;
-		p->equivs = $2;
-		}
-	;
-
-equivlist:  lhs
-		{ $$=ALLOC(Eqvchain);
-		  $$->eqvitem.eqvlhs = (struct Primblock *)$1;
-		}
-	| equivlist SCOMMA lhs
-		{ $$=ALLOC(Eqvchain);
-		  $$->eqvitem.eqvlhs = (struct Primblock *) $3;
-		  $$->eqvnextp = $1;
-		}
-	;
-
-data:	  SDATA in_data datalist
-	| data opt_comma datalist
-	;
-
-in_data:
-		{ if(parstate == OUTSIDE)
-			{
-			newproc();
-			startproc(ESNULL, CLMAIN);
-			}
-		  if(parstate < INDATA)
-			{
-			enddcl();
-			parstate = INDATA;
-			datagripe = 1;
-			}
-		}
-	;
-
-datalist:  datainit datavarlist SSLASH datapop vallist SSLASH
-		{ ftnint junk;
-		  if(nextdata(&junk) != NULL)
-			err("too few initializers");
-		  frdata($2);
-		  frrpl();
-		}
-	;
-
-datainit: /* nothing */ { frchain(&datastack); curdtp = 0; }
-
-datapop: /* nothing */ { pop_datastack(); }
-
-vallist:  { toomanyinit = NO; }  val
-	| vallist SCOMMA val
-	;
-
-val:	  value
-		{ dataval(ENULL, $1); }
-	| simple SSTAR value
-		{ dataval($1, $3); }
-	;
-
-value:	  simple
-	| addop simple
-		{ if( $1==OPMINUS && ISCONST($2) )
-			consnegop((Constp)$2);
-		  $$ = $2;
-		}
-	| complex_const
-	;
-
-savelist: saveitem
-	| savelist SCOMMA saveitem
-	;
-
-saveitem: name
-		{ int k;
-		  $1->vsave = YES;
-		  k = $1->vstg;
-		if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) )
-			dclerr("can only save static variables", $1);
-		}
-	| comblock
-	;
-
-paramlist:  paramitem
-	| paramlist SCOMMA paramitem
-	;
-
-paramitem:  name SEQUALS expr
-		{ if($1->vclass == CLUNKNOWN)
-			make_param((struct Paramblock *)$1, $3);
-		  else dclerr("cannot make into parameter", $1);
-		}
-	;
-
-var:	  name dims
-		{ if(ndim>0) setbound($1, ndim, dims); }
-	;
-
-datavar:	  lhs
-		{ Namep np;
-		  np = ( (struct Primblock *) $1) -> namep;
-		  vardcl(np);
-		  if(np->vstg == STGCOMMON)
-			extsymtab[np->vardesc.varno].extinit = YES;
-		  else if(np->vstg==STGEQUIV)
-			eqvclass[np->vardesc.varno].eqvinit = YES;
-		  else if(np->vstg!=STGINIT && np->vstg!=STGBSS)
-			dclerr("inconsistent storage classes", np);
-		  $$ = mkchain((char *)$1, CHNULL);
-		}
-	| SLPAR datavarlist SCOMMA dospec SRPAR
-		{ chainp p; struct Impldoblock *q;
-		pop_datastack();
-		q = ALLOC(Impldoblock);
-		q->tag = TIMPLDO;
-		(q->varnp = (Namep) ($4->datap))->vimpldovar = 1;
-		p = $4->nextp;
-		if(p)  { q->implb = (expptr)(p->datap); p = p->nextp; }
-		if(p)  { q->impub = (expptr)(p->datap); p = p->nextp; }
-		if(p)  { q->impstep = (expptr)(p->datap); }
-		frchain( & ($4) );
-		$$ = mkchain((char *)q, CHNULL);
-		q->datalist = hookup($2, $$);
-		}
-	;
-
-datavarlist: datavar
-		{ if (!datastack)
-			curdtp = 0;
-		  datastack = mkchain((char *)curdtp, datastack);
-		  curdtp = $1; curdtelt = 0;
-		  }
-	| datavarlist SCOMMA datavar
-		{ $$ = hookup($1, $3); }
-	;
-
-dims:
-		{ ndim = 0; }
-	| SLPAR dimlist SRPAR
-	;
-
-dimlist:   { ndim = 0; }   dim
-	| dimlist SCOMMA dim
-	;
-
-dim:	  ubound
-		{
-		  if(ndim == maxdim)
-			err("too many dimensions");
-		  else if(ndim < maxdim)
-			{ dims[ndim].lb = 0;
-			  dims[ndim].ub = $1;
-			}
-		  ++ndim;
-		}
-	| expr SCOLON ubound
-		{
-		  if(ndim == maxdim)
-			err("too many dimensions");
-		  else if(ndim < maxdim)
-			{ dims[ndim].lb = $1;
-			  dims[ndim].ub = $3;
-			}
-		  ++ndim;
-		}
-	;
-
-ubound:	  SSTAR
-		{ $$ = 0; }
-	| expr
-	;
-
-labellist: label
-		{ nstars = 1; labarray[0] = $1; }
-	| labellist SCOMMA label
-		{ if(nstars < MAXLABLIST)  labarray[nstars++] = $3; }
-	;
-
-label:	  SICON
-		{ $$ = execlab( convci(toklen, token) ); }
-	;
-
-implicit:  SIMPLICIT in_dcl implist
-		{ NO66("IMPLICIT statement"); }
-	| implicit SCOMMA implist
-	;
-
-implist:  imptype SLPAR letgroups SRPAR
-	| imptype
-		{ if (vartype != TYUNKNOWN)
-			dclerr("-- expected letter range",NPNULL);
-		  setimpl(vartype, varleng, 'a', 'z'); }
-	;
-
-imptype:   { needkwd = 1; } type
-		/* { vartype = $2; } */
-	;
-
-letgroups: letgroup
-	| letgroups SCOMMA letgroup
-	;
-
-letgroup:  letter
-		{ setimpl(vartype, varleng, $1, $1); }
-	| letter SMINUS letter
-		{ setimpl(vartype, varleng, $1, $3); }
-	;
-
-letter:  SNAME
-		{ if(toklen!=1 || token[0]<'a' || token[0]>'z')
-			{
-			dclerr("implicit item must be single letter", NPNULL);
-			$$ = 0;
-			}
-		  else $$ = token[0];
-		}
-	;
-
-namelist:	SNAMELIST
-	| namelist namelistentry
-	;
-
-namelistentry:  SSLASH name SSLASH namelistlist
-		{
-		if($2->vclass == CLUNKNOWN)
-			{
-			$2->vclass = CLNAMELIST;
-			$2->vtype = TYINT;
-			$2->vstg = STGBSS;
-			$2->varxptr.namelist = $4;
-			$2->vardesc.varno = ++lastvarno;
-			}
-		else dclerr("cannot be a namelist name", $2);
-		}
-	;
-
-namelistlist:  name
-		{ $$ = mkchain((char *)$1, CHNULL); }
-	| namelistlist SCOMMA name
-		{ $$ = hookup($1, mkchain((char *)$3, CHNULL)); }
-	;
-
-in_dcl:
-		{ switch(parstate)
-			{
-			case OUTSIDE:	newproc();
-					startproc(ESNULL, CLMAIN);
-			case INSIDE:	parstate = INDCL;
-			case INDCL:	break;
-
-			case INDATA:
-				if (datagripe) {
-					errstr(
-				"Statement order error: declaration after DATA",
-						CNULL);
-					datagripe = 0;
-					}
-				break;
-
-			default:
-				dclerr("declaration among executables", NPNULL);
-			}
-		}
-	;
//GO.SYSIN DD gram.dcl
echo gram.exec 1>&2
sed >gram.exec <<'//GO.SYSIN DD gram.exec' 's/^-//'
-exec:	  iffable
-	| SDO end_spec intonlyon label intonlyoff opt_comma dospecw
-		{
-		if($4->labdefined)
-			execerr("no backward DO loops", CNULL);
-		$4->blklevel = blklevel+1;
-		exdo($4->labelno, NPNULL, $7);
-		}
-	| SDO end_spec opt_comma dospecw
-		{
-		exdo((int)(ctls - ctlstack - 2), NPNULL, $4);
-		NOEXT("DO without label");
-		}
-	| SENDDO
-		{ exenddo(NPNULL); }
-	| logif iffable
-		{ exendif();  thiswasbranch = NO; }
-	| logif STHEN
-	| SELSEIF end_spec SLPAR expr SRPAR STHEN
-		{ exelif($4); lastwasbranch = NO; }
-	| SELSE end_spec
-		{ exelse(); lastwasbranch = NO; }
-	| SENDIF end_spec
-		{ exendif(); lastwasbranch = NO; }
-	;
-
-logif:	  SLOGIF end_spec SLPAR expr SRPAR
-		{ exif($4); }
-	;
-
-dospec:	  name SEQUALS exprlist
-		{ $$ = mkchain((char *)$1, $3); }
-	;
-
-dospecw:  dospec
-	| SWHILE SLPAR expr SRPAR
-		{ $$ = mkchain(CNULL, (chainp)$3); }
-	;
-
-iffable:  let lhs SEQUALS expr
-		{ exequals((struct Primblock *)$2, $4); }
-	| SASSIGN end_spec assignlabel STO name
-		{ exassign($5, $3); }
-	| SCONTINUE end_spec
-	| goto
-	| io
-		{ inioctl = NO; }
-	| SARITHIF end_spec SLPAR expr SRPAR label SCOMMA label SCOMMA label
-		{ exarif($4, $6, $8, $10);  thiswasbranch = YES; }
-	| call
-		{ excall($1, LBNULL, 0, labarray); }
-	| call SLPAR SRPAR
-		{ excall($1, LBNULL, 0, labarray); }
-	| call SLPAR callarglist SRPAR
-		{ if(nstars < MAXLABLIST)
-			excall($1, mklist(revchain($3)), nstars, labarray);
-		  else
-			err("too many alternate returns");
-		}
-	| SRETURN end_spec opt_expr
-		{ exreturn($3);  thiswasbranch = YES; }
-	| stop end_spec opt_expr
-		{ exstop($1, $3);  thiswasbranch = $1; }
-	;
-
-assignlabel:   SICON
-		{ $$ = mklabel( convci(toklen, token) ); }
-	;
-
-let:	  SLET
-		{ if(parstate == OUTSIDE)
-			{
-			newproc();
-			startproc(ESNULL, CLMAIN);
-			}
-		}
-	;
-
-goto:	  SGOTO end_spec label
-		{ exgoto($3);  thiswasbranch = YES; }
-	| SASGOTO end_spec name
-		{ exasgoto($3);  thiswasbranch = YES; }
-	| SASGOTO end_spec name opt_comma SLPAR labellist SRPAR
-		{ exasgoto($3);  thiswasbranch = YES; }
-	| SCOMPGOTO end_spec SLPAR labellist SRPAR opt_comma expr
-		{ if(nstars < MAXLABLIST)
-			putcmgo(putx(fixtype($7)), nstars, labarray);
-		  else
-			err("computed GOTO list too long");
-		}
-	;
-
-opt_comma:
-	| SCOMMA
-	;
-
-call:	  SCALL end_spec name
-		{ nstars = 0; $$ = $3; }
-	;
-
-callarglist:  callarg
-		{ $$ = $1 ? mkchain((char *)$1,CHNULL) : CHNULL; }
-	| callarglist SCOMMA callarg
-		{ $$ = $3 ? mkchain((char *)$3, $1) : $1; }
-	;
-
-callarg:  expr
-	| SSTAR label
-		{ if(nstars<MAXLABLIST) labarray[nstars++] = $2; $$ = 0; }
-	;
-
-stop:	  SPAUSE
-		{ $$ = 0; }
-	| SSTOP
-		{ $$ = 2; }
-	;
-
-exprlist:  expr
-		{ $$ = mkchain((char *)$1, CHNULL); }
-	| exprlist SCOMMA expr
-		{ $$ = hookup($1, mkchain((char *)$3,CHNULL) ); }
-	;
-
-end_spec:
-		{ if(parstate == OUTSIDE)
-			{
-			newproc();
-			startproc(ESNULL, CLMAIN);
-			}
-
-/* This next statement depends on the ordering of the state table encoding */
-
-		  if(parstate < INDATA) enddcl();
-		}
-	;
-
-intonlyon:
-		{ intonly = YES; }
-	;
-
-intonlyoff:
-		{ intonly = NO; }
-	;
//GO.SYSIN DD gram.exec
echo gram.expr 1>&2
sed >gram.expr <<'//GO.SYSIN DD gram.expr' 's/^-//'
-funarglist:
-		{ $$ = 0; }
-	| funargs
-		{ $$ = revchain($1); }
-	;
-
-funargs:  expr
-		{ $$ = mkchain((char *)$1, CHNULL); }
-	| funargs SCOMMA expr
-		{ $$ = mkchain((char *)$3, $1); }
-	;
-
-
-expr:	  uexpr
-	| SLPAR expr SRPAR	{ $$ = $2; }
-	| complex_const
-	;
-
-uexpr:	  lhs
-	| simple_const
-	| expr addop expr   %prec SPLUS
-		{ $$ = mkexpr($2, $1, $3); }
-	| expr SSTAR expr
-		{ $$ = mkexpr(OPSTAR, $1, $3); }
-	| expr SSLASH expr
-		{ $$ = mkexpr(OPSLASH, $1, $3); }
-	| expr SPOWER expr
-		{ $$ = mkexpr(OPPOWER, $1, $3); }
-	| addop expr  %prec SSTAR
-		{ if($1 == OPMINUS)
-			$$ = mkexpr(OPNEG, $2, ENULL);
-		  else 	$$ = $2;
-		}
-	| expr relop expr  %prec SEQ
-		{ $$ = mkexpr($2, $1, $3); }
-	| expr SEQV expr
-		{ NO66(".EQV. operator");
-		  $$ = mkexpr(OPEQV, $1,$3); }
-	| expr SNEQV expr
-		{ NO66(".NEQV. operator");
-		  $$ = mkexpr(OPNEQV, $1, $3); }
-	| expr SOR expr
-		{ $$ = mkexpr(OPOR, $1, $3); }
-	| expr SAND expr
-		{ $$ = mkexpr(OPAND, $1, $3); }
-	| SNOT expr
-		{ $$ = mkexpr(OPNOT, $2, ENULL); }
-	| expr SCONCAT expr
-		{ NO66("concatenation operator //");
-		  $$ = mkexpr(OPCONCAT, $1, $3); }
-	;
-
-addop:	  SPLUS		{ $$ = OPPLUS; }
-	| SMINUS	{ $$ = OPMINUS; }
-	;
-
-relop:	  SEQ	{ $$ = OPEQ; }
-	| SGT	{ $$ = OPGT; }
-	| SLT	{ $$ = OPLT; }
-	| SGE	{ $$ = OPGE; }
-	| SLE	{ $$ = OPLE; }
-	| SNE	{ $$ = OPNE; }
-	;
-
-lhs:	 name
-		{ $$ = mkprim($1, LBNULL, CHNULL); }
-	| name substring
-		{ NO66("substring operator :");
-		  $$ = mkprim($1, LBNULL, $2); }
-	| name SLPAR funarglist SRPAR
-		{ $$ = mkprim($1, mklist($3), CHNULL); }
-	| name SLPAR funarglist SRPAR substring
-		{ NO66("substring operator :");
-		  $$ = mkprim($1, mklist($3), $5); }
-	;
-
-substring:  SLPAR opt_expr SCOLON opt_expr SRPAR
-		{ $$ = mkchain((char *)$2, mkchain((char *)$4,CHNULL)); }
-	;
-
-opt_expr:
-		{ $$ = 0; }
-	| expr
-	;
-
-simple:	  name
-		{ if($1->vclass == CLPARAM)
-			$$ = (expptr) cpexpr(
-				( (struct Paramblock *) ($1) ) -> paramval);
-		}
-	| simple_const
-	;
-
-simple_const:   STRUE	{ $$ = mklogcon(1); }
-	| SFALSE	{ $$ = mklogcon(0); }
-	| SHOLLERITH  { $$ = mkstrcon(toklen, token); }
-	| SICON	= { $$ = mkintcon( convci(toklen, token) ); }
-	| SRCON	= { $$ = mkrealcon(tyreal, token); }
-	| SDCON	= { $$ = mkrealcon(TYDREAL, token); }
-	| bit_const
-	;
-
-complex_const:  SLPAR uexpr SCOMMA uexpr SRPAR
-		{ $$ = mkcxcon($2,$4); }
-	;
-
-bit_const:  SHEXCON
-		{ NOEXT("hex constant");
-		  $$ = mkbitcon(4, toklen, token); }
-	| SOCTCON
-		{ NOEXT("octal constant");
-		  $$ = mkbitcon(3, toklen, token); }
-	| SBITCON
-		{ NOEXT("binary constant");
-		  $$ = mkbitcon(1, toklen, token); }
-	;
-
-fexpr:	  unpar_fexpr
-	| SLPAR fexpr SRPAR
-		{ $$ = $2; }
-	;
-
-unpar_fexpr:	  lhs
-	| simple_const
-	| fexpr addop fexpr   %prec SPLUS
-		{ $$ = mkexpr($2, $1, $3); }
-	| fexpr SSTAR fexpr
-		{ $$ = mkexpr(OPSTAR, $1, $3); }
-	| fexpr SSLASH fexpr
-		{ $$ = mkexpr(OPSLASH, $1, $3); }
-	| fexpr SPOWER fexpr
-		{ $$ = mkexpr(OPPOWER, $1, $3); }
-	| addop fexpr  %prec SSTAR
-		{ if($1 == OPMINUS)
-			$$ = mkexpr(OPNEG, $2, ENULL);
-		  else	$$ = $2;
-		}
-	| fexpr SCONCAT fexpr
-		{ NO66("concatenation operator //");
-		  $$ = mkexpr(OPCONCAT, $1, $3); }
-	;
//GO.SYSIN DD gram.expr
echo gram.head 1>&2
sed >gram.head <<'//GO.SYSIN DD gram.head' 's/^-//'
-/****************************************************************
-Copyright 1990 by AT&T Bell Laboratories, 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.
-****************************************************************/
-
-%{
-#	include "defs.h"
-#	include "p1defs.h"
-
-static int nstars;			/* Number of labels in an
-					   alternate return CALL */
-static int datagripe;
-static int ndim;
-static int vartype;
-int new_dcl;
-static ftnint varleng;
-static struct Dims dims[MAXDIM+1];
-static struct Labelblock *labarray[MAXLABLIST];	/* Labels in an alternate
-						   return CALL */
-
-/* The next two variables are used to verify that each statement might be reached
-   during runtime.   lastwasbranch   is tested only in the defintion of the
-   stat:   nonterminal. */
-
-int lastwasbranch = NO;
-static int thiswasbranch = NO;
-extern ftnint yystno;
-extern flag intonly;
-static chainp datastack;
-extern long laststfcn, thisstno;
-extern int can_include;	/* for netlib */
-
-ftnint convci();
-Addrp nextdata();
-expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon();
-expptr mkcxcon();
-struct Listblock *mklist();
-struct Listblock *mklist();
-struct Impldoblock *mkiodo();
-Extsym *comblock();
-#define ESNULL (Extsym *)0
-#define NPNULL (Namep)0
-#define LBNULL (struct Listblock *)0
-extern void freetemps(), make_param();
-
- static void
-pop_datastack() {
-	chainp d0 = datastack;
-	if (d0->datap)
-		curdtp = (chainp)d0->datap;
-	datastack = d0->nextp;
-	d0->nextp = 0;
-	frchain(&d0);
-	}
-
-%}
-
-/* Specify precedences and associativities. */
-
-%union	{
-	int ival;
-	ftnint lval;
-	char *charpval;
-	chainp chval;
-	tagptr tagval;
-	expptr expval;
-	struct Labelblock *labval;
-	struct Nameblock *namval;
-	struct Eqvchain *eqvval;
-	Extsym *extval;
-	}
-
-%left SCOMMA
-%nonassoc SCOLON
-%right SEQUALS
-%left SEQV SNEQV
-%left SOR
-%left SAND
-%left SNOT
-%nonassoc SLT SGT SLE SGE SEQ SNE
-%left SCONCAT
-%left SPLUS SMINUS
-%left SSTAR SSLASH
-%right SPOWER
-
-%start program
-%type <labval> thislabel label assignlabel
-%type <tagval> other inelt
-%type <ival> type typespec typename dcl letter addop relop stop nameeq
-%type <lval> lengspec
-%type <charpval> filename
-%type <chval> datavar datavarlist namelistlist funarglist funargs
-%type <chval> dospec dospecw
-%type <chval> callarglist arglist args exprlist inlist outlist out2 substring
-%type <namval> name arg call var
-%type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr
-%type <expval> ubound simple value callarg complex_const simple_const bit_const
-%type <extval> common comblock entryname progname
-%type <eqvval> equivlist
-
-%%
-
-program:
-	| program stat SEOS
-	;
-
-stat:	  thislabel  entry
-		{
-/* stat:   is the nonterminal for Fortran statements */
-
-		  lastwasbranch = NO; }
-	| thislabel  spec
-	| thislabel  exec
-		{ /* forbid further statement function definitions... */
-		  if (parstate == INDATA && laststfcn != thisstno)
-			parstate = INEXEC;
-		  thisstno++;
-		  if($1 && ($1->labelno==dorange))
-			enddo($1->labelno);
-		  if(lastwasbranch && thislabel==NULL)
-			warn("statement cannot be reached");
-		  lastwasbranch = thiswasbranch;
-		  thiswasbranch = NO;
-		  if($1)
-			{
-			if($1->labtype == LABFORMAT)
-				err("label already that of a format");
-			else
-				$1->labtype = LABEXEC;
-			}
-		  freetemps();
-		}
-	| thislabel SINCLUDE filename
-		{ if (can_include)
-			doinclude( $3 );
-		  else {
-			fprintf(diagfile, "Cannot open file %s\n", $3);
-			done(1);
-			}
-		}
-	| thislabel  SEND  end_spec
-		{ if ($1)
-			lastwasbranch = NO;
-		  endproc(); /* lastwasbranch = NO; -- set in endproc() */
-		}
-	| thislabel SUNKNOWN
-		{ extern void unclassifiable();
-		  unclassifiable();
-
-/* flline flushes the current line, ignoring the rest of the text there */
-
-		  flline(); };
-	| error
-		{ flline();  needkwd = NO;  inioctl = NO;
-		  yyerrok; yyclearin; }
-	;
-
-thislabel:  SLABEL
-		{
-		if(yystno != 0)
-			{
-			$$ = thislabel =  mklabel(yystno);
-			if( ! headerdone ) {
-				if (procclass == CLUNKNOWN)
-					procclass = CLMAIN;
-				puthead(CNULL, procclass);
-				}
-			if(thislabel->labdefined)
-				execerr("label %s already defined",
-					convic(thislabel->stateno) );
-			else	{
-				if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel
-				    && thislabel->labtype!=LABFORMAT)
-					warn1("there is a branch to label %s from outside block",
-					      convic( (ftnint) (thislabel->stateno) ) );
-				thislabel->blklevel = blklevel;
-				thislabel->labdefined = YES;
-				if(thislabel->labtype != LABFORMAT)
-					p1_label((long)(thislabel - labeltab));
-				}
-			}
-		else    $$ = thislabel = NULL;
-		}
-	;
-
-entry:	  SPROGRAM new_proc progname
-		   {startproc($3, CLMAIN); }
-	| SPROGRAM new_proc progname progarglist
-		   {	warn("ignoring arguments to main program");
-			/* hashclear(); */
-			startproc($3, CLMAIN); }
-	| SBLOCK new_proc progname
-		{ if($3) NO66("named BLOCKDATA");
-		  startproc($3, CLBLOCK); }
-	| SSUBROUTINE new_proc entryname arglist
-		{ entrypt(CLPROC, TYSUBR, (ftnint) 0,  $3, $4); }
-	| SFUNCTION new_proc entryname arglist
-		{ entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); }
-	| type SFUNCTION new_proc entryname arglist
-		{ entrypt(CLPROC, $1, varleng, $4, $5); }
-	| SENTRY entryname arglist
-		 { if(parstate==OUTSIDE || procclass==CLMAIN
-			|| procclass==CLBLOCK)
-				execerr("misplaced entry statement", CNULL);
-		  entrypt(CLENTRY, 0, (ftnint) 0, $2, $3);
-		}
-	;
-
-new_proc:
-		{ newproc(); }
-	;
-
-entryname:  name
-		{ $$ = newentry($1, 1); }
-	;
-
-name:	  SNAME
-		{ $$ = mkname(token); }
-	;
-
-progname:		{ $$ = NULL; }
-	| entryname
-	;
-
-progarglist:
-	  SLPAR SRPAR
-	| SLPAR progargs SRPAR
-	;
-
-progargs: progarg
-	| progargs SCOMMA progarg
-	;
-
-progarg:  SNAME
-	| SNAME SEQUALS SNAME
-	;
-
-arglist:
-		{ $$ = 0; }
-	| SLPAR SRPAR
-		{ NO66(" () argument list");
-		  $$ = 0; }
-	| SLPAR args SRPAR
-		{$$ = $2; }
-	;
-
-args:	  arg
-		{ $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL ); }
-	| args SCOMMA arg
-		{ if($3) $1 = $$ = mkchain((char *)$3, $1); }
-	;
-
-arg:	  name
-		{ if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG)
-			dclerr("name declared as argument after use", $1);
-		  $1->vstg = STGARG;
-		}
-	| SSTAR
-		{ NO66("altenate return argument");
-
-/* substars   means that '*'ed formal parameters should be replaced.
-   This is used to specify alternate return labels; in theory, only
-   parameter slots which have '*' should accept the statement labels.
-   This compiler chooses to ignore the '*'s in the formal declaration, and
-   always return the proper value anyway.
-
-   This variable is only referred to in   proc.c   */
-
-		  $$ = 0;  substars = YES; }
-	;
-
-
-
-filename:   SHOLLERITH
-		{
-		char *s;
-		s = copyn(toklen+1, token);
-		s[toklen] = '\0';
-		$$ = s;
-		}
-	;
//GO.SYSIN DD gram.head
echo gram.io 1>&2
sed >gram.io <<'//GO.SYSIN DD gram.io' 's/^-//'
-  /*  Input/Output Statements */
-
-io:	  io1
-		{ endio(); }
-	;
-
-io1:	  iofmove ioctl
-	| iofmove unpar_fexpr
-		{ ioclause(IOSUNIT, $2); endioctl(); }
-	| iofmove SSTAR
-		{ ioclause(IOSUNIT, ENULL); endioctl(); }
-	| iofmove SPOWER
-		{ ioclause(IOSUNIT, IOSTDERR); endioctl(); }
-	| iofctl ioctl
-	| read ioctl
-		{ doio(CHNULL); }
-	| read infmt
-		{ doio(CHNULL); }
-	| read ioctl inlist
-		{ doio(revchain($3)); }
-	| read infmt SCOMMA inlist
-		{ doio(revchain($4)); }
-	| read ioctl SCOMMA inlist
-		{ doio(revchain($4)); }
-	| write ioctl
-		{ doio(CHNULL); }
-	| write ioctl outlist
-		{ doio(revchain($3)); }
-	| print
-		{ doio(CHNULL); }
-	| print SCOMMA outlist
-		{ doio(revchain($3)); }
-	;
-
-iofmove:   fmkwd end_spec in_ioctl
-	;
-
-fmkwd:	  SBACKSPACE
-		{ iostmt = IOBACKSPACE; }
-	| SREWIND
-		{ iostmt = IOREWIND; }
-	| SENDFILE
-		{ iostmt = IOENDFILE; }
-	;
-
-iofctl:  ctlkwd end_spec in_ioctl
-	;
-
-ctlkwd:	  SINQUIRE
-		{ iostmt = IOINQUIRE; }
-	| SOPEN
-		{ iostmt = IOOPEN; }
-	| SCLOSE
-		{ iostmt = IOCLOSE; }
-	;
-
-infmt:	  unpar_fexpr
-		{
-		ioclause(IOSUNIT, ENULL);
-		ioclause(IOSFMT, $1);
-		endioctl();
-		}
-	| SSTAR
-		{
-		ioclause(IOSUNIT, ENULL);
-		ioclause(IOSFMT, ENULL);
-		endioctl();
-		}
-	;
-
-ioctl:	  SLPAR fexpr SRPAR
-		{
-		  ioclause(IOSUNIT, $2);
-		  endioctl();
-		}
-	| SLPAR ctllist SRPAR
-		{ endioctl(); }
-	;
-
-ctllist:  ioclause
-	| ctllist SCOMMA ioclause
-	;
-
-ioclause:  fexpr
-		{ ioclause(IOSPOSITIONAL, $1); }
-	| SSTAR
-		{ ioclause(IOSPOSITIONAL, ENULL); }
-	| SPOWER
-		{ ioclause(IOSPOSITIONAL, IOSTDERR); }
-	| nameeq expr
-		{ ioclause($1, $2); }
-	| nameeq SSTAR
-		{ ioclause($1, ENULL); }
-	| nameeq SPOWER
-		{ ioclause($1, IOSTDERR); }
-	;
-
-nameeq:  SNAMEEQ
-		{ $$ = iocname(); }
-	;
-
-read:	  SREAD end_spec in_ioctl
-		{ iostmt = IOREAD; }
-	;
-
-write:	  SWRITE end_spec in_ioctl
-		{ iostmt = IOWRITE; }
-	;
-
-print:	  SPRINT end_spec fexpr in_ioctl
-		{
-		iostmt = IOWRITE;
-		ioclause(IOSUNIT, ENULL);
-		ioclause(IOSFMT, $3);
-		endioctl();
-		}
-	| SPRINT end_spec SSTAR in_ioctl
-		{
-		iostmt = IOWRITE;
-		ioclause(IOSUNIT, ENULL);
-		ioclause(IOSFMT, ENULL);
-		endioctl();
-		}
-	;
-
-inlist:	  inelt
-		{ $$ = mkchain((char *)$1, CHNULL); }
-	| inlist SCOMMA inelt
-		{ $$ = mkchain((char *)$3, $1); }
-	;
-
-inelt:	  lhs
-		{ $$ = (tagptr) $1; }
-	| SLPAR inlist SCOMMA dospec SRPAR
-		{ $$ = (tagptr) mkiodo($4,revchain($2)); }
-	;
-
-outlist:  uexpr
-		{ $$ = mkchain((char *)$1, CHNULL); }
-	| other
-		{ $$ = mkchain((char *)$1, CHNULL); }
-	| out2
-	;
-
-out2:	  uexpr SCOMMA uexpr
-		{ $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); }
-	| uexpr SCOMMA other
-		{ $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); }
-	| other SCOMMA uexpr
-		{ $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); }
-	| other SCOMMA other
-		{ $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); }
-	| out2  SCOMMA uexpr
-		{ $$ = mkchain((char *)$3, $1); }
-	| out2  SCOMMA other
-		{ $$ = mkchain((char *)$3, $1); }
-	;
-
-other:	  complex_const
-		{ $$ = (tagptr) $1; }
-	| SLPAR expr SRPAR
-		{ $$ = (tagptr) $2; }
-	| SLPAR uexpr SCOMMA dospec SRPAR
-		{ $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); }
-	| SLPAR other SCOMMA dospec SRPAR
-		{ $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); }
-	| SLPAR out2  SCOMMA dospec SRPAR
-		{ $$ = (tagptr) mkiodo($4, revchain($2)); }
-	;
-
-in_ioctl:
-		{ startioctl(); }
-	;
//GO.SYSIN DD gram.io
echo init.c 1>&2
sed >init.c <<'//GO.SYSIN DD init.c' 's/^-//'
-/****************************************************************
-Copyright 1990 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.
-****************************************************************/
-
-#include "defs.h"
-#include "output.h"
-#include "iob.h"
-
-/* State required for the C output */
-char *fl_fmt_string;		/* Float format string */
-char *db_fmt_string;	    	/* Double format string */
-char *cm_fmt_string;		/* Complex format string */
-char *dcm_fmt_string;		/* Double complex format string */
-
-chainp new_vars = CHNULL;	/* List of newly created locals in this
-				   function.  These may have identifiers
-				   which have underscores and more than VL
-				   characters */
-chainp used_builtins = CHNULL;	/* List of builtins used by this function.
-				   These are all Addrps with UNAM_EXTERN
-				   */
-chainp assigned_fmts = CHNULL;	/* assigned formats */
-chainp allargs;			/* union of args in all entry points */
-chainp earlylabs;		/* labels seen before enddcl() */
-char main_alias[52];		/* PROGRAM name, if any is given */
-int tab_size = 4;
-
-
-FILEP infile;
-FILEP diagfile;
-
-FILEP c_file;
-FILEP pass1_file;
-FILEP initfile;
-FILEP blkdfile;
-
-
-char token[MAXTOKENLEN];
-int toklen;
-long lineno;			/* Current line in the input file, NOT the
-				   Fortran statement label number */
-char *infname;
-int needkwd;
-struct Labelblock *thislabel	= NULL;
-int nerr;
-int nwarn;
-
-flag saveall;
-flag substars;
-int parstate	= OUTSIDE;
-flag headerdone	= NO;
-int blklevel;
-int doin_setbound;
-int impltype[26];
-ftnint implleng[26];
-int implstg[26];
-
-int tyint	= TYLONG ;
-int tylogical	= TYLONG;
-int typesize[NTYPES] = {
-	1, SZADDR, SZSHORT, SZLONG, SZLONG, 2*SZLONG,
-	    2*SZLONG, 4*SZLONG, SZLONG, 1, 1, 0,
-		4*SZLONG + SZADDR,	/* sizeof(cilist) */
-		4*SZLONG + 2*SZADDR,	/* sizeof(icilist) */
-		4*SZLONG + 5*SZADDR,	/* sizeof(olist) */
-		2*SZLONG + SZADDR,	/* sizeof(cllist) */
-		2*SZLONG,		/* sizeof(alist) */
-		11*SZLONG + 15*SZADDR	/* sizeof(inlist) */
-		};
-
-int typealign[NTYPES] = {
-	1, ALIADDR, ALISHORT, ALILONG, ALILONG, ALIDOUBLE,
-	ALILONG, ALIDOUBLE, ALILONG, 1, 1, 1,
-	ALILONG, ALILONG, ALILONG, ALILONG, ALILONG, ALILONG};
-
-int type_choice[4] = { TYDREAL, TYSHORT, TYLONG,  TYSHORT };
-
-char *typename[] = {
-	"<<unknown>>",
-	"address",
-	"shortint",
-	"integer",
-	"real",
-	"doublereal",
-	"complex",
-	"doublecomplex",
-	"logical",
-	"char"	/* character */
-	};
-
-int type_pref[NTYPES] = { 0, 0, 2, 4, 5, 7, 6, 8, 3, 1 };
-
-char *protorettypes[] = {
-	"?", "??", "shortint", "integer", "real", "doublereal",
-	"C_f", "Z_f", "logical", "H_f", "int"
-	};
-
-char *casttypes[TYSUBR+1] = {
-	"U_fp", "??bug??",
-	"J_fp", "I_fp", "R_fp",
-	"D_fp", "C_fp", "Z_fp",
-	"L_fp", "H_fp", "S_fp"
-	};
-char *usedcasts[TYSUBR+1];
-
-char *dfltarg[] = {
-	0, 0,
-	"(shortint *)0", "(integer *)0", "(real *)0",
-	"(doublereal *)0", "(complex *)0", "(doublecomplex *)0",
-	"(logical *)0", "(char *)0"
-	};
-
-static char *dflt0proc[] = {
-	0, 0,
-	"(shortint (*)())0", "(integer (*)())0", "(real (*)())0",
-	"(doublereal (*)())0", "(complex (*)())0", "(doublecomplex (*)())0",
-	"(logical (*)())0", "(char (*)())0", "(int (*)())0"
-	};
-
-char *dflt1proc[] = { "(U_fp)0", "(??bug??)0",
-	"(J_fp)0", "(I_fp)0", "(R_fp)0",
-	"(D_fp)0", "(C_fp)0", "(Z_fp)0",
-	"(L_fp)0", "(H_fp)0", "(S_fp)0"
-	};
-
-char **dfltproc = dflt0proc;
-
-static char Bug[] = "bug";
-
-char *ftn_types[] = { "external", "??",
-	"integer*2", "integer", "real",
-	"double precision", "complex", "double complex",
-	"logical", "character", "subroutine",
-	Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug, "ftnlen"
-	};
-
-int init_ac[TYSUBR+1] = { 0,0,0,0,0,0, 1, 1, 0, 2};
-
-int proctype	= TYUNKNOWN;
-char *procname;
-int rtvlabel[NTYPES0];
-Addrp retslot;			/* Holds automatic variable which was
-				   allocated the function return value
-				   */
-Addrp xretslot[NTYPES0];	/* for multiple entry points */
-int cxslot	= -1;
-int chslot	= -1;
-int chlgslot	= -1;
-int procclass	= CLUNKNOWN;
-int nentry;
-int nallargs;
-int nallchargs;
-flag multitype;
-ftnint procleng;
-long lastiolabno;
-int lastlabno;
-int lastvarno;
-int lastargslot;
-int autonum[TYVOID];
-char *av_pfix[TYVOID] = {"??TYUNKNOWN??", "a","s","i","r","d","q","z","L","ch",
-			 "??TYSUBR??", "??TYERROR??","ci", "ici",
-			 "o", "cl", "al", "ioin" };
-
-extern int maxctl;
-struct Ctlframe *ctls;
-struct Ctlframe *ctlstack;
-struct Ctlframe *lastctl;
-
-Namep regnamep[MAXREGVAR];
-int highregvar;
-int nregvar;
-
-extern int maxext;
-Extsym *extsymtab;
-Extsym *nextext;
-Extsym *lastext;
-
-extern int maxequiv;
-struct Equivblock *eqvclass;
-
-extern int maxhash;
-struct Hashentry *hashtab;
-struct Hashentry *lasthash;
-
-extern int maxstno;		/* Maximum number of statement labels */
-struct Labelblock *labeltab;
-struct Labelblock *labtabend;
-struct Labelblock *highlabtab;
-
-int maxdim	= MAXDIM;
-struct Rplblock *rpllist	= NULL;
-struct Chain *curdtp	= NULL;
-flag toomanyinit;
-ftnint curdtelt;
-chainp templist[TYVOID];
-chainp holdtemps;
-int dorange	= 0;
-struct Entrypoint *entries	= NULL;
-
-chainp chains	= NULL;
-
-flag inioctl;
-int iostmt;
-int nioctl;
-int nequiv	= 0;
-int eqvstart	= 0;
-int nintnames	= 0;
-
-struct Literal *litpool;
-int nliterals;
-
-char dflttype[26];
-char hextoi_tab[Table_size], Letters[Table_size];
-char *ei_first, *ei_next, *ei_last;
-char *wh_first, *wh_next, *wh_last;
-
-#define ALLOCN(n,x)	(struct x *) ckalloc((n)*sizeof(struct x))
-
-fileinit()
-{
-	register char *s;
-	register int i, j;
-	extern void fmt_init(), mem_init(), np_init();
-
-	lastiolabno = 100000;
-	lastlabno = 0;
-	lastvarno = 0;
-	nliterals = 0;
-	nerr = 0;
-
-	infile = stdin;
-
-	memset(dflttype, tyreal, 26);
-	memset(dflttype + 'i' - 'a', tyint, 6);
-	memset(hextoi_tab, 16, sizeof(hextoi_tab));
-	for(i = 0, s = "0123456789abcdef"; *s; i++, s++)
-		hextoi(*s) = i;
-	for(i = 10, s = "ABCDEF"; *s; i++, s++)
-		hextoi(*s) = i;
-	for(j = 0, s = "abcdefghijklmnopqrstuvwxyz"; i = *s++; j++)
-		Letters[i] = Letters[i+'A'-'a'] = j;
-
-	ctls = ALLOCN(maxctl+1, Ctlframe);
-	extsymtab = ALLOCN(maxext, Extsym);
-	eqvclass = ALLOCN(maxequiv, Equivblock);
-	hashtab = ALLOCN(maxhash, Hashentry);
-	labeltab = ALLOCN(maxstno, Labelblock);
-	litpool = ALLOCN(maxliterals, Literal);
-	fmt_init();
-	mem_init();
-	np_init();
-
-	ctlstack = ctls++;
-	lastctl = ctls + maxctl;
-	nextext = extsymtab;
-	lastext = extsymtab + maxext;
-	lasthash = hashtab + maxhash;
-	labtabend = labeltab + maxstno;
-	highlabtab = labeltab;
-	main_alias[0] = '\0';
-	if (forcedouble)
-		dfltproc[TYREAL] = dfltproc[TYDREAL];
-
-/* Initialize the routines for providing C output */
-
-	out_init ();
-}
-
-hashclear()	/* clear hash table */
-{
-	register struct Hashentry *hp;
-	register Namep p;
-	register struct Dimblock *q;
-	register int i;
-
-	for(hp = hashtab ; hp < lasthash ; ++hp)
-		if(p = hp->varp)
-		{
-			frexpr(p->vleng);
-			if(q = p->vdim)
-			{
-				for(i = 0 ; i < q->ndim ; ++i)
-				{
-					frexpr(q->dims[i].dimsize);
-					frexpr(q->dims[i].dimexpr);
-				}
-				frexpr(q->nelt);
-				frexpr(q->baseoffset);
-				frexpr(q->basexpr);
-				free( (charptr) q);
-			}
-			if(p->vclass == CLNAMELIST)
-				frchain( &(p->varxptr.namelist) );
-			free( (charptr) p);
-			hp->varp = NULL;
-		}
-	}
-
-procinit()
-{
-	register struct Labelblock *lp;
-	struct Chain *cp;
-	int i;
-	struct memblock;
-	extern struct memblock *curmemblock, *firstmemblock;
-	extern char *mem_first, *mem_next, *mem_last, *mem0_last;
-	extern void frexchain();
-
-	curmemblock = firstmemblock;
-	mem_next = mem_first;
-	mem_last = mem0_last;
-	ei_next = ei_first = ei_last = 0;
-	wh_next = wh_first = wh_last = 0;
-	iob_list = 0;
-	for(i = 0; i < 9; i++)
-		io_structs[i] = 0;
-
-	parstate = OUTSIDE;
-	headerdone = NO;
-	blklevel = 1;
-	saveall = NO;
-	substars = NO;
-	nwarn = 0;
-	thislabel = NULL;
-	needkwd = 0;
-
-	proctype = TYUNKNOWN;
-	procname = "MAIN_";
-	procclass = CLUNKNOWN;
-	nentry = 0;
-	nallargs = nallchargs = 0;
-	multitype = NO;
-	retslot = NULL;
-	for(i = 0; i < NTYPES0; i++) {
-		frexpr((expptr)xretslot[i]);
-		xretslot[i] = 0;
-		}
-	cxslot = -1;
-	chslot = -1;
-	chlgslot = -1;
-	procleng = 0;
-	blklevel = 1;
-	lastargslot = 0;
-
-	for(lp = labeltab ; lp < labtabend ; ++lp)
-		lp->stateno = 0;
-
-	hashclear();
-
-/* Clear the list of newly generated identifiers from the previous
-   function */
-
-	frexchain(&new_vars);
-	frexchain(&used_builtins);
-	frchain(&assigned_fmts);
-	frchain(&allargs);
-	frchain(&earlylabs);
-
-	nintnames = 0;
-	highlabtab = labeltab;
-
-	ctlstack = ctls - 1;
-	for(i = TYADDR; i < TYVOID; i++) {
-		for(cp = templist[i]; cp ; cp = cp->nextp)
-			free( (charptr) (cp->datap) );
-		frchain(templist + i);
-		autonum[i] = 0;
-		}
-	holdtemps = NULL;
-	dorange = 0;
-	nregvar = 0;
-	highregvar = 0;
-	entries = NULL;
-	rpllist = NULL;
-	inioctl = NO;
-	eqvstart += nequiv;
-	nequiv = 0;
-	dcomplex_seen = 0;
-
-	for(i = 0 ; i<NTYPES0 ; ++i)
-		rtvlabel[i] = 0;
-
-	if(undeftype)
-		setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z');
-	else
-	{
-		setimpl(tyreal, (ftnint) 0, 'a', 'z');
-		setimpl(tyint,  (ftnint) 0, 'i', 'n');
-	}
-	setimpl(-STGBSS, (ftnint) 0, 'a', 'z');	/* set class */
-	setlog();
-}
-
-
-
-
-setimpl(type, length, c1, c2)
-int type;
-ftnint length;
-int c1, c2;
-{
-	int i;
-	char buff[100];
-
-	if(c1==0 || c2==0)
-		return;
-
-	if(c1 > c2) {
-		sprintf(buff, "characters out of order in implicit:%c-%c", c1, c2);
-		err(buff);
-		}
-	else {
-		c1 = letter(c1);
-		c2 = letter(c2);
-		if(type < 0)
-			for(i = c1 ; i<=c2 ; ++i)
-				implstg[i] = - type;
-		else {
-			type = lengtype(type, length);
-			if(type == TYCHAR) {
-				if (length < 0) {
-					err("length (*) in implicit");
-					length = 1;
-					}
-				}
-			else if (type != TYLONG)
-				length = 0;
-			for(i = c1 ; i<=c2 ; ++i) {
-				impltype[i] = type;
-				implleng[i] = length;
-				}
-			}
-		}
-	}
//GO.SYSIN DD init.c
echo intr.c 1>&2
sed >intr.c <<'//GO.SYSIN DD intr.c' 's/^-//'
-/****************************************************************
-Copyright 1990 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.
-****************************************************************/
-
-#include "defs.h"
-#include "names.h"
-
-void cast_args ();
-
-union
-	{
-	int ijunk;
-	struct Intrpacked bits;
-	} packed;
-
-struct Intrbits
-	{
-	char intrgroup /* :3 */;
-	char intrstuff /* result type or number of generics */;
-	char intrno /* :7 */;
-	char dblcmplx;
-	char dblintrno;	/* for -r8 */
-	};
-
-/* List of all intrinsic functions.  */
-
-LOCAL struct Intrblock
-	{
-	char intrfname[8];
-	struct Intrbits intrval;
-	} intrtab[ ] =
-{
-"int", 		{ INTRCONV, TYLONG },
-"real", 	{ INTRCONV, TYREAL, 1 },
-		/* 1 ==> real(TYDCOMPLEX) yields TYDREAL */
-"dble", 	{ INTRCONV, TYDREAL },
-"cmplx", 	{ INTRCONV, TYCOMPLEX },
-"dcmplx", 	{ INTRCONV, TYDCOMPLEX, 0, 1 },
-"ifix", 	{ INTRCONV, TYLONG },
-"idint", 	{ INTRCONV, TYLONG },
-"float", 	{ INTRCONV, TYREAL },
-"dfloat",	{ INTRCONV, TYDREAL },
-"sngl", 	{ INTRCONV, TYREAL },
-"ichar", 	{ INTRCONV, TYLONG },
-"iachar", 	{ INTRCONV, TYLONG },
-"char", 	{ INTRCONV, TYCHAR },
-"achar", 	{ INTRCONV, TYCHAR },
-
-/* any MAX or MIN can be used with any types; the compiler will cast them
-   correctly.  So rules against bad syntax in these expressions are not
-   enforced */
-
-"max", 		{ INTRMAX, TYUNKNOWN },
-"max0", 	{ INTRMAX, TYLONG },
-"amax0", 	{ INTRMAX, TYREAL },
-"max1", 	{ INTRMAX, TYLONG },
-"amax1", 	{ INTRMAX, TYREAL },
-"dmax1", 	{ INTRMAX, TYDREAL },
-
-"and",		{ INTRBOOL, TYUNKNOWN, OPBITAND },
-"or",		{ INTRBOOL, TYUNKNOWN, OPBITOR },
-"xor",		{ INTRBOOL, TYUNKNOWN, OPBITXOR },
-"not",		{ INTRBOOL, TYUNKNOWN, OPBITNOT },
-"lshift",	{ INTRBOOL, TYUNKNOWN, OPLSHIFT },
-"rshift",	{ INTRBOOL, TYUNKNOWN, OPRSHIFT },
-
-"min", 		{ INTRMIN, TYUNKNOWN },
-"min0", 	{ INTRMIN, TYLONG },
-"amin0", 	{ INTRMIN, TYREAL },
-"min1", 	{ INTRMIN, TYLONG },
-"amin1", 	{ INTRMIN, TYREAL },
-"dmin1", 	{ INTRMIN, TYDREAL },
-
-"aint", 	{ INTRGEN, 2, 0 },
-"dint", 	{ INTRSPEC, TYDREAL, 1 },
-
-"anint", 	{ INTRGEN, 2, 2 },
-"dnint", 	{ INTRSPEC, TYDREAL, 3 },
-
-"nint", 	{ INTRGEN, 4, 4 },
-"idnint", 	{ INTRGEN, 2, 6 },
-
-"abs", 		{ INTRGEN, 6, 8 },
-"iabs", 	{ INTRGEN, 2, 9 },
-"dabs", 	{ INTRSPEC, TYDREAL, 11 },
-"cabs", 	{ INTRSPEC, TYREAL, 12, 0, 13 },
-"zabs", 	{ INTRSPEC, TYDREAL, 13, 1 },
-
-"mod", 		{ INTRGEN, 4, 14 },
-"amod", 	{ INTRSPEC, TYREAL, 16, 0, 17 },
-"dmod", 	{ INTRSPEC, TYDREAL, 17 },
-
-"sign", 	{ INTRGEN, 4, 18 },
-"isign", 	{ INTRGEN, 2, 19 },
-"dsign", 	{ INTRSPEC, TYDREAL, 21 },
-
-"dim", 		{ INTRGEN, 4, 22 },
-"idim", 	{ INTRGEN, 2, 23 },
-"ddim", 	{ INTRSPEC, TYDREAL, 25 },
-
-"dprod", 	{ INTRSPEC, TYDREAL, 26 },
-
-"len", 		{ INTRSPEC, TYLONG, 27 },
-"index", 	{ INTRSPEC, TYLONG, 29 },
-
-"imag", 	{ INTRGEN, 2, 31 },
-"aimag", 	{ INTRSPEC, TYREAL, 31, 0, 32 },
-"dimag", 	{ INTRSPEC, TYDREAL, 32 },
-
-"conjg", 	{ INTRGEN, 2, 33 },
-"dconjg", 	{ INTRSPEC, TYDCOMPLEX, 34, 1 },
-
-"sqrt", 	{ INTRGEN, 4, 35 },
-"dsqrt", 	{ INTRSPEC, TYDREAL, 36 },
-"csqrt", 	{ INTRSPEC, TYCOMPLEX, 37, 0, 38 },
-"zsqrt", 	{ INTRSPEC, TYDCOMPLEX, 38, 1 },
-
-"exp", 		{ INTRGEN, 4, 39 },
-"dexp", 	{ INTRSPEC, TYDREAL, 40 },
-"cexp", 	{ INTRSPEC, TYCOMPLEX, 41, 0, 42 },
-"zexp", 	{ INTRSPEC, TYDCOMPLEX, 42, 1 },
-
-"log", 		{ INTRGEN, 4, 43 },
-"alog", 	{ INTRSPEC, TYREAL, 43, 0, 44 },
-"dlog", 	{ INTRSPEC, TYDREAL, 44 },
-"clog", 	{ INTRSPEC, TYCOMPLEX, 45, 0, 46 },
-"zlog", 	{ INTRSPEC, TYDCOMPLEX, 46, 1 },
-
-"log10", 	{ INTRGEN, 2, 47 },
-"alog10", 	{ INTRSPEC, TYREAL, 47, 0, 48 },
-"dlog10", 	{ INTRSPEC, TYDREAL, 48 },
-
-"sin", 		{ INTRGEN, 4, 49 },
-"dsin", 	{ INTRSPEC, TYDREAL, 50 },
-"csin", 	{ INTRSPEC, TYCOMPLEX, 51, 0, 52 },
-"zsin", 	{ INTRSPEC, TYDCOMPLEX, 52, 1 },
-
-"cos", 		{ INTRGEN, 4, 53 },
-"dcos", 	{ INTRSPEC, TYDREAL, 54 },
-"ccos", 	{ INTRSPEC, TYCOMPLEX, 55, 0, 56 },
-"zcos", 	{ INTRSPEC, TYDCOMPLEX, 56, 1 },
-
-"tan", 		{ INTRGEN, 2, 57 },
-"dtan", 	{ INTRSPEC, TYDREAL, 58 },
-
-"asin", 	{ INTRGEN, 2, 59 },
-"dasin", 	{ INTRSPEC, TYDREAL, 60 },
-
-"acos", 	{ INTRGEN, 2, 61 },
-"dacos", 	{ INTRSPEC, TYDREAL, 62 },
-
-"atan", 	{ INTRGEN, 2, 63 },
-"datan", 	{ INTRSPEC, TYDREAL, 64 },
-
-"atan2", 	{ INTRGEN, 2, 65 },
-"datan2", 	{ INTRSPEC, TYDREAL, 66 },
-
-"sinh", 	{ INTRGEN, 2, 67 },
-"dsinh", 	{ INTRSPEC, TYDREAL, 68 },
-
-"cosh", 	{ INTRGEN, 2, 69 },
-"dcosh", 	{ INTRSPEC, TYDREAL, 70 },
-
-"tanh", 	{ INTRGEN, 2, 71 },
-"dtanh", 	{ INTRSPEC, TYDREAL, 72 },
-
-"lge",		{ INTRSPEC, TYLOGICAL, 73},
-"lgt",		{ INTRSPEC, TYLOGICAL, 75},
-"lle",		{ INTRSPEC, TYLOGICAL, 77},
-"llt",		{ INTRSPEC, TYLOGICAL, 79},
-
-#if 0
-"epbase",	{ INTRCNST, 4, 0 },
-"epprec",	{ INTRCNST, 4, 4 },
-"epemin",	{ INTRCNST, 2, 8 },
-"epemax",	{ INTRCNST, 2, 10 },
-"eptiny",	{ INTRCNST, 2, 12 },
-"ephuge",	{ INTRCNST, 4, 14 },
-"epmrsp",	{ INTRCNST, 2, 18 },
-#endif
-
-"fpexpn",	{ INTRGEN, 4, 81 },
-"fpabsp",	{ INTRGEN, 2, 85 },
-"fprrsp",	{ INTRGEN, 2, 87 },
-"fpfrac",	{ INTRGEN, 2, 89 },
-"fpmake",	{ INTRGEN, 2, 91 },
-"fpscal",	{ INTRGEN, 2, 93 },
-
-"" };
-
-
-LOCAL struct Specblock
-	{
-	char atype;		/* Argument type; every arg must have
-				   this type */
-	char rtype;		/* Result type */
-	char nargs;		/* Number of arguments */
-	char spxname[8];	/* Name of the function in Fortran */
-	char othername;		/* index into callbyvalue table */
-	} spectab[ ] =
-{
-	{ TYREAL,TYREAL,1,"r_int" },
-	{ TYDREAL,TYDREAL,1,"d_int" },
-
-	{ TYREAL,TYREAL,1,"r_nint" },
-	{ TYDREAL,TYDREAL,1,"d_nint" },
-
-	{ TYREAL,TYSHORT,1,"h_nint" },
-	{ TYREAL,TYLONG,1,"i_nint" },
-
-	{ TYDREAL,TYSHORT,1,"h_dnnt" },
-	{ TYDREAL,TYLONG,1,"i_dnnt" },
-
-	{ TYREAL,TYREAL,1,"r_abs" },
-	{ TYSHORT,TYSHORT,1,"h_abs" },
-	{ TYLONG,TYLONG,1,"i_abs" },
-	{ TYDREAL,TYDREAL,1,"d_abs" },
-	{ TYCOMPLEX,TYREAL,1,"c_abs" },
-	{ TYDCOMPLEX,TYDREAL,1,"z_abs" },
-
-	{ TYSHORT,TYSHORT,2,"h_mod" },
-	{ TYLONG,TYLONG,2,"i_mod" },
-	{ TYREAL,TYREAL,2,"r_mod" },
-	{ TYDREAL,TYDREAL,2,"d_mod" },
-
-	{ TYREAL,TYREAL,2,"r_sign" },
-	{ TYSHORT,TYSHORT,2,"h_sign" },
-	{ TYLONG,TYLONG,2,"i_sign" },
-	{ TYDREAL,TYDREAL,2,"d_sign" },
-
-	{ TYREAL,TYREAL,2,"r_dim" },
-	{ TYSHORT,TYSHORT,2,"h_dim" },
-	{ TYLONG,TYLONG,2,"i_dim" },
-	{ TYDREAL,TYDREAL,2,"d_dim" },
-
-	{ TYREAL,TYDREAL,2,"d_prod" },
-
-	{ TYCHAR,TYSHORT,1,"h_len" },
-	{ TYCHAR,TYLONG,1,"i_len" },
-
-	{ TYCHAR,TYSHORT,2,"h_indx" },
-	{ TYCHAR,TYLONG,2,"i_indx" },
-
-	{ TYCOMPLEX,TYREAL,1,"r_imag" },
-	{ TYDCOMPLEX,TYDREAL,1,"d_imag" },
-	{ TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" },
-	{ TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" },
-
-	{ TYREAL,TYREAL,1,"r_sqrt", 1 },
-	{ TYDREAL,TYDREAL,1,"d_sqrt", 1 },
-	{ TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" },
-	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" },
-
-	{ TYREAL,TYREAL,1,"r_exp", 2 },
-	{ TYDREAL,TYDREAL,1,"d_exp", 2 },
-	{ TYCOMPLEX,TYCOMPLEX,1,"c_exp" },
-	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" },
-
-	{ TYREAL,TYREAL,1,"r_log", 3 },
-	{ TYDREAL,TYDREAL,1,"d_log", 3 },
-	{ TYCOMPLEX,TYCOMPLEX,1,"c_log" },
-	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_log" },
-
-	{ TYREAL,TYREAL,1,"r_lg10" },
-	{ TYDREAL,TYDREAL,1,"d_lg10" },
-
-	{ TYREAL,TYREAL,1,"r_sin", 4 },
-	{ TYDREAL,TYDREAL,1,"d_sin", 4 },
-	{ TYCOMPLEX,TYCOMPLEX,1,"c_sin" },
-	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" },
-
-	{ TYREAL,TYREAL,1,"r_cos", 5 },
-	{ TYDREAL,TYDREAL,1,"d_cos", 5 },
-	{ TYCOMPLEX,TYCOMPLEX,1,"c_cos" },
-	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" },
-
-	{ TYREAL,TYREAL,1,"r_tan", 6 },
-	{ TYDREAL,TYDREAL,1,"d_tan", 6 },
-
-	{ TYREAL,TYREAL,1,"r_asin", 7 },
-	{ TYDREAL,TYDREAL,1,"d_asin", 7 },
-
-	{ TYREAL,TYREAL,1,"r_acos", 8 },
-	{ TYDREAL,TYDREAL,1,"d_acos", 8 },
-
-	{ TYREAL,TYREAL,1,"r_atan", 9 },
-	{ TYDREAL,TYDREAL,1,"d_atan", 9 },
-
-	{ TYREAL,TYREAL,2,"r_atn2", 10 },
-	{ TYDREAL,TYDREAL,2,"d_atn2", 10 },
-
-	{ TYREAL,TYREAL,1,"r_sinh", 11 },
-	{ TYDREAL,TYDREAL,1,"d_sinh", 11 },
-
-	{ TYREAL,TYREAL,1,"r_cosh", 12 },
-	{ TYDREAL,TYDREAL,1,"d_cosh", 12 },
-
-	{ TYREAL,TYREAL,1,"r_tanh", 13 },
-	{ TYDREAL,TYDREAL,1,"d_tanh", 13 },
-
-	{ TYCHAR,TYLOGICAL,2,"hl_ge" },
-	{ TYCHAR,TYLOGICAL,2,"l_ge" },
-
-	{ TYCHAR,TYLOGICAL,2,"hl_gt" },
-	{ TYCHAR,TYLOGICAL,2,"l_gt" },
-
-	{ TYCHAR,TYLOGICAL,2,"hl_le" },
-	{ TYCHAR,TYLOGICAL,2,"l_le" },
-
-	{ TYCHAR,TYLOGICAL,2,"hl_lt" },
-	{ TYCHAR,TYLOGICAL,2,"l_lt" },
-
-	{ TYREAL,TYSHORT,1,"hr_expn" },
-	{ TYREAL,TYLONG,1,"ir_expn" },
-	{ TYDREAL,TYSHORT,1,"hd_expn" },
-	{ TYDREAL,TYLONG,1,"id_expn" },
-
-	{ TYREAL,TYREAL,1,"r_absp" },
-	{ TYDREAL,TYDREAL,1,"d_absp" },
-
-	{ TYREAL,TYDREAL,1,"r_rrsp" },
-	{ TYDREAL,TYDREAL,1,"d_rrsp" },
-
-	{ TYREAL,TYREAL,1,"r_frac" },
-	{ TYDREAL,TYDREAL,1,"d_frac" },
-
-	{ TYREAL,TYREAL,2,"r_make" },
-	{ TYDREAL,TYDREAL,2,"d_make" },
-
-	{ TYREAL,TYREAL,2,"r_scal" },
-	{ TYDREAL,TYDREAL,2,"d_scal" },
-	{ 0 }
-} ;
-
-#if 0
-LOCAL struct Incstblock
-	{
-	char atype;
-	char rtype;
-	char constno;
-	} consttab[ ] =
-{
-	{ TYSHORT, TYLONG, 0 },
-	{ TYLONG, TYLONG, 1 },
-	{ TYREAL, TYLONG, 2 },
-	{ TYDREAL, TYLONG, 3 },
-
-	{ TYSHORT, TYLONG, 4 },
-	{ TYLONG, TYLONG, 5 },
-	{ TYREAL, TYLONG, 6 },
-	{ TYDREAL, TYLONG, 7 },
-
-	{ TYREAL, TYLONG, 8 },
-	{ TYDREAL, TYLONG, 9 },
-
-	{ TYREAL, TYLONG, 10 },
-	{ TYDREAL, TYLONG, 11 },
-
-	{ TYREAL, TYREAL, 0 },
-	{ TYDREAL, TYDREAL, 1 },
-
-	{ TYSHORT, TYLONG, 12 },
-	{ TYLONG, TYLONG, 13 },
-	{ TYREAL, TYREAL, 2 },
-	{ TYDREAL, TYDREAL, 3 },
-
-	{ TYREAL, TYREAL, 4 },
-	{ TYDREAL, TYDREAL, 5 }
-};
-#endif
-
-char *callbyvalue[ ] =
-	{0,
-	"sqrt",
-	"exp",
-	"log",
-	"sin",
-	"cos",
-	"tan",
-	"asin",
-	"acos",
-	"atan",
-	"atan2",
-	"sinh",
-	"cosh",
-	"tanh"
-	};
-
- void
-r8fix()	/* adjust tables for -r8 */
-{
-	register struct Intrblock *I;
-	register struct Specblock *S;
-
-	for(I = intrtab; I->intrfname[0]; I++)
-		if (I->intrval.intrgroup != INTRGEN)
-		    switch(I->intrval.intrstuff) {
-			case TYREAL:
-				I->intrval.intrstuff = TYDREAL;
-				I->intrval.intrno = I->intrval.dblintrno;
-				break;
-			case TYCOMPLEX:
-				I->intrval.intrstuff = TYDCOMPLEX;
-				I->intrval.intrno = I->intrval.dblintrno;
-				I->intrval.dblcmplx = 1;
-			}
-
-	for(S = spectab; S->atype; S++)
-	    switch(S->atype) {
-		case TYCOMPLEX:
-			S->atype = TYDCOMPLEX;
-			if (S->rtype == TYREAL)
-				S->rtype = TYDREAL;
-			else if (S->rtype == TYCOMPLEX)
-				S->rtype = TYDCOMPLEX;
-			switch(S->spxname[0]) {
-				case 'r':
-					S->spxname[0] = 'd';
-					break;
-				case 'c':
-					S->spxname[0] = 'z';
-					break;
-				default:
-					Fatal("r8fix bug");
-				}
-			break;
-		case TYREAL:
-			S->atype = TYDREAL;
-			switch(S->rtype) {
-			    case TYREAL:
-				S->rtype = TYDREAL;
-				if (S->spxname[0] != 'r')
-					Fatal("r8fix bug");
-				S->spxname[0] = 'd';
-			    case TYDREAL:	/* d_prod */
-				break;
-
-			    case TYSHORT:
-				if (!strcmp(S->spxname, "hr_expn"))
-					S->spxname[1] = 'd';
-				else if (!strcmp(S->spxname, "h_nint"))
-					strcpy(S->spxname, "h_dnnt");
-				else Fatal("r8fix bug");
-				break;
-
-			    case TYLONG:
-				if (!strcmp(S->spxname, "ir_expn"))
-					S->spxname[1] = 'd';
-				else if (!strcmp(S->spxname, "i_nint"))
-					strcpy(S->spxname, "i_dnnt");
-				else Fatal("r8fix bug");
-				break;
-
-			    default:
-				Fatal("r8fix bug");
-			    }
-		}
-	}
-
-expptr intrcall(np, argsp, nargs)
-Namep np;
-struct Listblock *argsp;
-int nargs;
-{
-	int i, rettype;
-	Addrp ap;
-	register struct Specblock *sp;
-	register struct Chain *cp;
-	expptr Inline(), mkcxcon(), mkrealcon();
-	expptr q, ep;
-	int mtype;
-	int op;
-	int f1field, f2field, f3field;
-
-	packed.ijunk = np->vardesc.varno;
-	f1field = packed.bits.f1;
-	f2field = packed.bits.f2;
-	f3field = packed.bits.f3;
-	if(nargs == 0)
-		goto badnargs;
-
-	mtype = 0;
-	for(cp = argsp->listp ; cp ; cp = cp->nextp)
-	{
-		ep = (expptr)cp->datap;
-		if( ISCONST(ep) && ep->headblock.vtype==TYSHORT )
-			cp->datap = (char *) mkconv(tyint, ep);
-		mtype = maxtype(mtype, ep->headblock.vtype);
-	}
-
-	switch(f1field)
-	{
-	case INTRBOOL:
-		op = f3field;
-		if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
-			goto badtype;
-		if(op == OPBITNOT)
-		{
-			if(nargs != 1)
-				goto badnargs;
-			q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL);
-		}
-		else
-		{
-			if(nargs != 2)
-				goto badnargs;
-			q = mkexpr(op, (expptr)argsp->listp->datap,
-			    		(expptr)argsp->listp->nextp->datap);
-		}
-		frchain( &(argsp->listp) );
-		free( (charptr) argsp);
-		return(q);
-
-	case INTRCONV:
-		rettype = f2field;
-		if(rettype == TYLONG)
-			rettype = tyint;
-		if( ISCOMPLEX(rettype) && nargs==2)
-		{
-			expptr qr, qi;
-			qr = (expptr) argsp->listp->datap;
-			qi = (expptr) argsp->listp->nextp->datap;
-			if(ISCONST(qr) && ISCONST(qi))
-				q = mkcxcon(qr,qi);
-			else	q = mkexpr(OPCONV,mkconv(rettype-2,qr),
-			    mkconv(rettype-2,qi));
-		}
-		else if(nargs == 1) {
-			if (f3field && ((Exprp)argsp->listp->datap)->vtype
-					== TYDCOMPLEX)
-				rettype = TYDREAL;
-			q = mkconv(rettype+100, (expptr)argsp->listp->datap);
-			}
-		else goto badnargs;
-
-		q->headblock.vtype = rettype;
-		frchain(&(argsp->listp));
-		free( (charptr) argsp);
-		return(q);
-
-
-#if 0
-	case INTRCNST:
-
-/* Machine-dependent f77 stuff that f2c omits:
-
-intcon contains
-	radix for short int
-	radix for long int
-	radix for single precision
-	radix for double precision
-	precision for short int
-	precision for long int
-	precision for single precision
-	precision for double precision
-	emin for single precision
-	emin for double precision
-	emax for single precision
-	emax for double prcision
-	largest short int
-	largest long int
-
-realcon contains
-	tiny for single precision
-	tiny for double precision
-	huge for single precision
-	huge for double precision
-	mrsp (epsilon) for single precision
-	mrsp (epsilon) for double precision
-*/
-	{	register struct Incstblock *cstp;
-		extern ftnint intcon[14];
-		extern double realcon[6];
-
-		cstp = consttab + f3field;
-		for(i=0 ; i<f2field ; ++i)
-			if(cstp->atype == mtype)
-				goto foundconst;
-			else
-				++cstp;
-		goto badtype;
-
-foundconst:
-		switch(cstp->rtype)
-		{
-		case TYLONG:
-			return(mkintcon(intcon[cstp->constno]));
-
-		case TYREAL:
-		case TYDREAL:
-			return(mkrealcon(cstp->rtype,
-			    realcon[cstp->constno]) );
-
-		default:
-			Fatal("impossible intrinsic constant");
-		}
-	}
-#endif
-
-	case INTRGEN:
-		sp = spectab + f3field;
-		if(no66flag)
-			if(sp->atype == mtype)
-				goto specfunct;
-			else err66("generic function");
-
-		for(i=0; i<f2field ; ++i)
-			if(sp->atype == mtype)
-				goto specfunct;
-			else
-				++sp;
-		warn1 ("bad argument type to intrinsic %s", np->fvarname);
-
-/* Made this a warning rather than an error so things like "log (5) ==>
-   log (5.0)" can be accommodated.  When none of these cases matches, the
-   argument is cast up to the first type in the spectab list; this first
-   type is assumed to be the "smallest" type, e.g. REAL before DREAL
-   before COMPLEX, before DCOMPLEX */
-
-		sp = spectab + f3field;
-		mtype = sp -> atype;
-		goto specfunct;
-
-	case INTRSPEC:
-		sp = spectab + f3field;
-specfunct:
-		if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL))
-		    && (sp+1)->atype==sp->atype)
-			++sp;
-
-		if(nargs != sp->nargs)
-			goto badnargs;
-		if(mtype != sp->atype)
-			goto badtype;
-
-/* NOTE!!  I moved fixargs (YES) into the ELSE branch so that constants in
-   the inline expression wouldn't get put into the constant table */
-
-		fixargs (NO, argsp);
-		cast_args (mtype, argsp -> listp);
-
-		if(q = Inline((int)(sp-spectab), mtype, argsp->listp))
-		{
-			frchain( &(argsp->listp) );
-			free( (charptr) argsp);
-		} else {
-
-		    if(sp->othername) {
-			/* C library routines that return double... */
-			/* sp->rtype might be TYREAL */
-			ap = builtin(sp->rtype,
-				callbyvalue[sp->othername], 1);
-			q = fixexpr((Exprp)
-				mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );
-		    } else {
-			fixargs(YES, argsp);
-			ap = builtin(sp->rtype, sp->spxname, 0);
-			q = fixexpr((Exprp)
-				mkexpr(OPCALL, (expptr)ap, (expptr)argsp) );
-		    } /* else */
-		} /* else */
-		return(q);
-
-	case INTRMIN:
-	case INTRMAX:
-		if(nargs < 2)
-			goto badnargs;
-		if( ! ONEOF(mtype, MSKINT|MSKREAL) )
-			goto badtype;
-		argsp->vtype = mtype;
-		q = mkexpr( (f1field==INTRMIN ? OPMIN : OPMAX), (expptr)argsp, ENULL);
-
-		q->headblock.vtype = mtype;
-		rettype = f2field;
-		if(rettype == TYLONG)
-			rettype = tyint;
-		else if(rettype == TYUNKNOWN)
-			rettype = mtype;
-		return( mkconv(rettype, q) );
-
-	default:
-		fatali("intrcall: bad intrgroup %d", f1field);
-	}
-badnargs:
-	errstr("bad number of arguments to intrinsic %s", np->fvarname);
-	goto bad;
-
-badtype:
-	errstr("bad argument type to intrinsic %s", np->fvarname);
-
-bad:
-	return( errnode() );
-}
-
-
-
-
-intrfunct(s)
-char *s;
-{
-	register struct Intrblock *p;
-
-	for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p)
-	{
-		if( !strcmp(s, p->intrfname) )
-		{
-			packed.bits.f1 = p->intrval.intrgroup;
-			packed.bits.f2 = p->intrval.intrstuff;
-			packed.bits.f3 = p->intrval.intrno;
-			packed.bits.f4 = p->intrval.dblcmplx;
-			return(packed.ijunk);
-		}
-	}
-
-	return(0);
-}
-
-
-
-
-
-Addrp intraddr(np)
-Namep np;
-{
-	Addrp q;
-	register struct Specblock *sp;
-	int f3field;
-
-	if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC)
-		fatalstr("intraddr: %s is not intrinsic", np->fvarname);
-	packed.ijunk = np->vardesc.varno;
-	f3field = packed.bits.f3;
-
-	switch(packed.bits.f1)
-	{
-	case INTRGEN:
-		/* imag, log, and log10 arent specific functions */
-		if(f3field==31 || f3field==43 || f3field==47)
-			goto bad;
-
-	case INTRSPEC:
-		sp = spectab + f3field;
-		if (tyint == TYLONG
-		&& (sp->rtype == TYSHORT || sp->rtype == TYLOGICAL))
-			++sp;
-		q = builtin(sp->rtype, sp->spxname,
-			sp->othername ? 1 : 0);
-		return(q);
-
-	case INTRCONV:
-	case INTRMIN:
-	case INTRMAX:
-	case INTRBOOL:
-	case INTRCNST:
-bad:
-		errstr("cannot pass %s as actual", np->fvarname);
-		return((Addrp)errnode());
-	}
-	fatali("intraddr: impossible f1=%d\n", (int) packed.bits.f1);
-	/* NOT REACHED */ return 0;
-}
-
-
-
-void cast_args (maxtype, args)
-int maxtype;
-chainp args;
-{
-    for (; args; args = args -> nextp) {
-	expptr e = (expptr) args->datap;
-	if (e -> headblock.vtype != maxtype)
-	    if (e -> tag == TCONST)
-		args->datap = (char *) mkconv(maxtype, e);
-	    else {
-		Addrp temp = mktmp(maxtype, ENULL);
-
-		puteq(cpexpr((expptr)temp), e);
-		args->datap = (char *)temp;
-	    } /* else */
-    } /* for */
-} /* cast_args */
-
-
-
-expptr Inline(fno, type, args)
-int fno;
-int type;
-struct Chain *args;
-{
-	register expptr q, t, t1;
-
-	switch(fno)
-	{
-	case 8:	/* real abs */
-	case 9:	/* short int abs */
-	case 10:	/* long int abs */
-	case 11:	/* double precision abs */
-		if( addressable(q = (expptr) args->datap) )
-		{
-			t = q;
-			q = NULL;
-		}
-		else
-			t = (expptr) mktmp(type,ENULL);
-		t1 = mkexpr(type == TYREAL && forcedouble ? OPDABS : OPABS,
-			cpexpr(t), ENULL);
-		if(q)
-			t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1);
-		frexpr(t);
-		return(t1);
-
-	case 26:	/* dprod */
-		q = mkexpr(OPSTAR, mkconv(TYDREAL,(expptr)args->datap),
-			(expptr)args->nextp->datap);
-		return(q);
-
-	case 27:	/* len of character string */
-		q = (expptr) cpexpr(((tagptr)args->datap)->headblock.vleng);
-		frexpr((expptr)args->datap);
-		return(q);
-
-	case 14:	/* half-integer mod */
-	case 15:	/* mod */
-		return mkexpr(OPMOD, (expptr) args->datap,
-		    		(expptr) args->nextp->datap);
-	}
-	return(NULL);
-}
//GO.SYSIN DD intr.c
echo io.c 1>&2
sed >io.c <<'//GO.SYSIN DD io.c' 's/^-//'
-/****************************************************************
-Copyright 1990, 1991 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;
-
-LOCAL void dofclose(), dofinquire(), dofinquire(), dofmove(), dofopen(),
-	doiolist(), ioset(), ioseta(), iosetc(), iosetip(), iosetlc(),
-	putio(), putiocall();
-
-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 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 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
-#define XRLEN	2*SZFLAG + 2*SZADDR
-#define XRNUM	2*SZFLAG + 2*SZADDR + SZIOINT
-
-/* 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
-
-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
-
-
-fmtstmt(lp)
-register struct Labelblock *lp;
-{
-	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);
-}
-
-
-setfmt(lp)
-struct Labelblock *lp;
-{
-	int n;
-	char *s0, *lexline();
-	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:
-				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:
-					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();
-}
-
-
-
-startioctl()
-{
-	register int i;
-
-	inioctl = YES;
-	nioctl = 0;
-	ioformatted = UNFORMATTED;
-	for(i = 1 ; i<=NIOS ; ++i)
-		V(i) = NULL;
-}
-
- static long
-newiolabel() {
-	long rv;
-	rv = ++lastiolabno;
-	skiplabel = mklabel(rv);
-	skiplabel->labdefined = 1;
-	return rv;
-	}
-
-
-endioctl()
-{
-	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));
-}
-
-
-
-iocname()
-{
-	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);
-}
-
-
-ioclause(n, p)
-register int n;
-register expptr p;
-{
-	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 */
-
-doio(list)
-chainp list;
-{
-	expptr call0();
-
-	if(ioformatted == NAMEDIRECTED)
-	{
-		if(list)
-			err("no I/O list allowed in NAMELIST read/write");
-	}
-	else
-	{
-		doiolist(list);
-		ioroutine[0] = 'e';
-		if (skiplab || ioroutine[4] == 'l')
-			jumplab = 0;
-		putiocall( call0(TYINT, ioroutine) );
-	}
-}
-
-
-
-
-
- LOCAL void
-doiolist(p0)
- chainp p0;
-{
-	chainp p;
-	register tagptr q;
-	register expptr qe;
-	register Namep qn;
-	Addrp tp, mkscalar();
-	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)
-				{
-					ftnint lencat();
-					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");
-			}
-			frexpr(q);
-		}
-	}
-	frchain( &p0 );
-}
-
- int iocalladdr = TYADDR;	/* for fixing TYADDR in saveargtypes */
-
- LOCAL void
-putio(nelt, addr)
- expptr nelt;
- register expptr addr;
-{
-	int type;
-	register expptr q;
-	extern Constp mkconst();
-	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(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;
-}
-
-
-
-
-endio()
-{
-	extern void p1_label();
-
-	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
-putiocall(q)
- register expptr q;
-{
-	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
-fmtname(np, q)
- Namep np;
- register Addrp q;
-{
-	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 asg_addr(p)
- union Expression *p;
-{
-	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;
-	}
-
-startrw()
-{
-	register expptr p;
-	register Namep np;
-	register Addrp unitp, fmtp, recp;
-	register expptr nump;
-	Addrp mkscalar();
-	expptr mkaddcon();
-	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()
-{
-	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()
-{
-	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()
-{
-	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
-dofmove(subname)
- char *subname;
-{
-	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
-ioset(type, offset, p)
- int type, offset;
- register expptr p;
-{
-	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
-iosetc(offset, p)
- int offset;
- register expptr p;
-{
-	extern Addrp putchop();
-
-	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
-ioseta(offset, p)
- int offset;
- register Addrp p;
-{
-	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
-iosetip(i, offset)
- int i, offset;
-{
-	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
-iosetlc(i, offp, offl)
- int i, offp, offl;
-{
-	register expptr p;
-	if( (p = V(i)) && p->headblock.vtype==TYCHAR)
-		ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) );
-	iosetc(offp, p);
-}
//GO.SYSIN DD io.c
echo iob.h 1>&2
sed >iob.h <<'//GO.SYSIN DD iob.h' 's/^-//'
-struct iob_data {
-	struct iob_data *next;
-	char *type;
-	char *name;
-	char *fields[1];
-	};
-struct io_setup {
-	char **fields;
-	int nelt, type;
-	};
-
-struct defines {
-	struct defines *next;
-	char defname[1];
-	};
-
-typedef struct iob_data iob_data;
-typedef struct io_setup io_setup;
-typedef struct defines defines;
-
-extern iob_data *iob_list;
-extern struct Addrblock *io_structs[9];
-extern void def_start(), new_iob_data(), other_undefs();
-extern char *tostring();
//GO.SYSIN DD iob.h
echo lex.c 1>&2
sed >lex.c <<'//GO.SYSIN DD lex.c' 's/^-//'
-/****************************************************************
-Copyright 1990, 1992 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.
-****************************************************************/
-
-#include "defs.h"
-#include "tokdefs.h"
-#include "p1defs.h"
-
-#define BLANK	' '
-#define MYQUOTE (2)
-#define SEOF 0
-
-/* card types */
-
-#define STEOF 1
-#define STINITIAL 2
-#define STCONTINUE 3
-
-/* lex states */
-
-#define NEWSTMT	1
-#define FIRSTTOKEN	2
-#define OTHERTOKEN	3
-#define RETEOS	4
-
-
-LOCAL int stkey;	/* Type of the current statement (DO, END, IF, etc) */
-extern char token[];	/* holds the actual token text */
-static int needwkey;
-ftnint yystno;
-flag intonly;
-extern int new_dcl;
-LOCAL long int stno;
-LOCAL long int nxtstno;	/* Statement label */
-LOCAL int parlev;	/* Parentheses level */
-LOCAL int parseen;
-LOCAL int expcom;
-LOCAL int expeql;
-LOCAL char *nextch;
-LOCAL char *lastch;
-LOCAL char *nextcd 	= NULL;
-LOCAL char *endcd;
-LOCAL long prevlin;
-LOCAL long thislin;
-LOCAL int code;		/* Card type; INITIAL, CONTINUE or EOF */
-LOCAL int lexstate	= NEWSTMT;
-LOCAL char sbuf[1390];	/* Main buffer for Fortran source input.  The number
-			   comes from lines of at most 66 characters, with at
-			   most 20 continuation cards (or something); this is
-			   part of the defn of the standard */
-LOCAL char *send	= sbuf+20*66;
-LOCAL int nincl	= 0;	/* Current number of include files */
-LOCAL long firstline;
-LOCAL char *laststb, *stb0;
-extern int addftnsrc;
-#define CONTMAX 100	/* max continuation lines for ! processing */
-char *linestart[CONTMAX];
-LOCAL int ncont;
-LOCAL char comstart[Table_size];
-#define USC (unsigned char *)
-
-static char anum_buf[Table_size];
-#define isalnum_(x) anum_buf[x]
-#define isalpha_(x) (anum_buf[x] == 1)
-
-#define COMMENT_BUF_STORE 4088
-
-typedef struct comment_buf {
-	struct comment_buf *next;
-	char *last;
-	char buf[COMMENT_BUF_STORE];
-	} comment_buf;
-static comment_buf *cbfirst, *cbcur;
-static char *cbinit, *cbnext, *cblast;
-static void flush_comments();
-extern flag use_bs;
-
-
-/* Comment buffering data
-
-	Comments are kept in a list until the statement before them has
-   been parsed.  This list is implemented with the above comment_buf
-   structure and the pointers cbnext and cblast.
-
-	The comments are stored with terminating NULL, and no other
-   intervening space.  The last few bytes of each block are likely to
-   remain unused.
-*/
-
-/* struct Inclfile   holds the state information for each include file */
-struct Inclfile
-{
-	struct Inclfile *inclnext;
-	FILEP inclfp;
-	char *inclname;
-	int incllno;
-	char *incllinp;
-	int incllen;
-	int inclcode;
-	ftnint inclstno;
-};
-
-LOCAL struct Inclfile *inclp	=  NULL;
-struct Keylist {
-	char *keyname;
-	int keyval;
-	char notinf66;
-};
-struct Punctlist {
-	char punchar;
-	int punval;
-};
-struct Fmtlist {
-	char fmtchar;
-	int fmtval;
-};
-struct Dotlist {
-	char *dotname;
-	int dotval;
-	};
-LOCAL struct Keylist *keystart[26], *keyend[26];
-
-/* KEYWORD AND SPECIAL CHARACTER TABLES
-*/
-
-static struct Punctlist puncts[ ] =
-{
-	'(', SLPAR,
-	')', SRPAR,
-	'=', SEQUALS,
-	',', SCOMMA,
-	'+', SPLUS,
-	'-', SMINUS,
-	'*', SSTAR,
-	'/', SSLASH,
-	'$', SCURRENCY,
-	':', SCOLON,
-	'<', SLT,
-	'>', SGT,
-	0, 0 };
-
-LOCAL struct Dotlist  dots[ ] =
-{
-	"and.", SAND,
-	    "or.", SOR,
-	    "not.", SNOT,
-	    "true.", STRUE,
-	    "false.", SFALSE,
-	    "eq.", SEQ,
-	    "ne.", SNE,
-	    "lt.", SLT,
-	    "le.", SLE,
-	    "gt.", SGT,
-	    "ge.", SGE,
-	    "neqv.", SNEQV,
-	    "eqv.", SEQV,
-	    0, 0 };
-
-LOCAL struct Keylist  keys[ ] =
-{
-	{ "assign",  SASSIGN  },
-	{ "automatic",  SAUTOMATIC, YES  },
-	{ "backspace",  SBACKSPACE  },
-	{ "blockdata",  SBLOCK  },
-	{ "call",  SCALL  },
-	{ "character",  SCHARACTER, YES  },
-	{ "close",  SCLOSE, YES  },
-	{ "common",  SCOMMON  },
-	{ "complex",  SCOMPLEX  },
-	{ "continue",  SCONTINUE  },
-	{ "data",  SDATA  },
-	{ "dimension",  SDIMENSION  },
-	{ "doubleprecision",  SDOUBLE  },
-	{ "doublecomplex", SDCOMPLEX, YES  },
-	{ "elseif",  SELSEIF, YES  },
-	{ "else",  SELSE, YES  },
-	{ "endfile",  SENDFILE  },
-	{ "endif",  SENDIF, YES  },
-	{ "enddo", SENDDO, YES },
-	{ "end",  SEND  },
-	{ "entry",  SENTRY, YES  },
-	{ "equivalence",  SEQUIV  },
-	{ "external",  SEXTERNAL  },
-	{ "format",  SFORMAT  },
-	{ "function",  SFUNCTION  },
-	{ "goto",  SGOTO  },
-	{ "implicit",  SIMPLICIT, YES  },
-	{ "include",  SINCLUDE, YES  },
-	{ "inquire",  SINQUIRE, YES  },
-	{ "intrinsic",  SINTRINSIC, YES  },
-	{ "integer",  SINTEGER  },
-	{ "logical",  SLOGICAL  },
-	{ "namelist", SNAMELIST, YES },
-	{ "none", SUNDEFINED, YES },
-	{ "open",  SOPEN, YES  },
-	{ "parameter",  SPARAM, YES  },
-	{ "pause",  SPAUSE  },
-	{ "print",  SPRINT  },
-	{ "program",  SPROGRAM, YES  },
-	{ "punch",  SPUNCH, YES  },
-	{ "read",  SREAD  },
-	{ "real",  SREAL  },
-	{ "return",  SRETURN  },
-	{ "rewind",  SREWIND  },
-	{ "save",  SSAVE, YES  },
-	{ "static",  SSTATIC, YES  },
-	{ "stop",  SSTOP  },
-	{ "subroutine",  SSUBROUTINE  },
-	{ "then",  STHEN, YES  },
-	{ "undefined", SUNDEFINED, YES  },
-	{ "while", SWHILE, YES  },
-	{ "write",  SWRITE  },
-	{ 0, 0 }
-};
-
-LOCAL void analyz(), crunch(), store_comment();
-LOCAL int getcd(), getcds(), getkwd(), gettok();
-LOCAL char *stbuf[3];
-
-inilex(name)
-char *name;
-{
-	stbuf[0] = Alloc(3*P1_STMTBUFSIZE);
-	stbuf[1] = stbuf[0] + P1_STMTBUFSIZE;
-	stbuf[2] = stbuf[1] + P1_STMTBUFSIZE;
-	nincl = 0;
-	inclp = NULL;
-	doinclude(name);
-	lexstate = NEWSTMT;
-	return(NO);
-}
-
-
-
-/* throw away the rest of the current line */
-flline()
-{
-	lexstate = RETEOS;
-}
-
-
-
-char *lexline(n)
-int *n;
-{
-	*n = (lastch - nextch) + 1;
-	return(nextch);
-}
-
-
-
-
-
-doinclude(name)
-char *name;
-{
-	FILEP fp;
-	struct Inclfile *t;
-
-	if(inclp)
-	{
-		inclp->incllno = thislin;
-		inclp->inclcode = code;
-		inclp->inclstno = nxtstno;
-		if(nextcd)
-			inclp->incllinp = copyn(inclp->incllen = endcd-nextcd , nextcd);
-		else
-			inclp->incllinp = 0;
-	}
-	nextcd = NULL;
-
-	if(++nincl >= MAXINCLUDES)
-		Fatal("includes nested too deep");
-	if(name[0] == '\0')
-		fp = stdin;
-	else
-		fp = fopen(name, textread);
-	if (fp)
-	{
-		t = inclp;
-		inclp = ALLOC(Inclfile);
-		inclp->inclnext = t;
-		prevlin = thislin = 0;
-		infname = inclp->inclname = name;
-		infile = inclp->inclfp = fp;
-	}
-	else
-	{
-		fprintf(diagfile, "Cannot open file %s\n", name);
-		done(1);
-	}
-}
-
-
-
-
-LOCAL popinclude()
-{
-	struct Inclfile *t;
-	register char *p;
-	register int k;
-
-	if(infile != stdin)
-		clf(&infile, infname, 1);	/* Close the input file */
-	free(infname);
-
-	--nincl;
-	t = inclp->inclnext;
-	free( (charptr) inclp);
-	inclp = t;
-	if(inclp == NULL) {
-		infname = 0;
-		return(NO);
-		}
-
-	infile = inclp->inclfp;
-	infname = inclp->inclname;
-	prevlin = thislin = inclp->incllno;
-	code = inclp->inclcode;
-	stno = nxtstno = inclp->inclstno;
-	if(inclp->incllinp)
-	{
-		endcd = nextcd = sbuf;
-		k = inclp->incllen;
-		p = inclp->incllinp;
-		while(--k >= 0)
-			*endcd++ = *p++;
-		free( (charptr) (inclp->incllinp) );
-	}
-	else
-		nextcd = NULL;
-	return(YES);
-}
-
- static void
-putlineno()
-{
-	static long lastline;
-	static char *lastfile = "??", *lastfile0 = "?";
-	static char fbuf[P1_FILENAME_MAX];
-	extern int gflag;
-	register char *s0, *s1;
-
-	if (gflag) {
-		if (lastline) {
-			if (lastfile != lastfile0) {
-				p1puts(P1_FILENAME, fbuf);
-				lastfile0 = lastfile;
-				}
-			p1_line_number(lastline);
-			}
-		lastline = firstline;
-		if (lastfile != infname)
-			if (lastfile = infname) {
-				strncpy(fbuf, lastfile, sizeof(fbuf));
-				fbuf[sizeof(fbuf)-1] = 0;
-				}
-			else
-				fbuf[0] = 0;
-		}
-	if (addftnsrc) {
-		if (laststb && *laststb) {
-			for(s1 = laststb; *s1; s1++) {
-				for(s0 = s1; *s1 != '\n'; s1++)
-					if (*s1 == '*' && s1[1] == '/')
-						*s1 = '+';
-				*s1 = 0;
-				p1puts(P1_FORTRAN, s0);
-				}
-			*laststb = 0;	/* prevent trouble after EOF */
-			}
-		laststb = stb0;
-		}
-	}
-
-
-yylex()
-{
-	static int  tokno;
-	int retval;
-
-	switch(lexstate)
-	{
-	case NEWSTMT :	/* need a new statement */
-		retval = getcds();
-		putlineno();
-		if(retval == STEOF) {
-			retval = SEOF;
-			break;
-		} /* if getcds() == STEOF */
-		crunch();
-		tokno = 0;
-		lexstate = FIRSTTOKEN;
-		yystno = stno;
-		stno = nxtstno;
-		toklen = 0;
-		retval = SLABEL;
-		break;
-
-first:
-	case FIRSTTOKEN :	/* first step on a statement */
-		analyz();
-		lexstate = OTHERTOKEN;
-		tokno = 1;
-		retval = stkey;
-		break;
-
-	case OTHERTOKEN :	/* return next token */
-		if(nextch > lastch)
-			goto reteos;
-		++tokno;
-		if( (stkey==SLOGIF || stkey==SELSEIF) && parlev==0 && tokno>3)
-			goto first;
-
-		if(stkey==SASSIGN && tokno==3 && nextch<lastch &&
-		    nextch[0]=='t' && nextch[1]=='o')
-		{
-			nextch+=2;
-			retval = STO;
-			break;
-		}
-		retval = gettok();
-		break;
-
-reteos:
-	case RETEOS:
-		lexstate = NEWSTMT;
-		retval = SEOS;
-		break;
-	default:
-		fatali("impossible lexstate %d", lexstate);
-		break;
-	}
-
-	if (retval == SEOF)
-	    flush_comments ();
-
-	return retval;
-}
-
-/* Get Cards.
-
-   Returns STEOF or STINITIAL, never STCONTINUE.  Any continuation cards get
-merged into one long card (hence the size of the buffer named   sbuf)   */
-
- LOCAL int
-getcds()
-{
-	register char *p, *q;
-
-	flush_comments ();
-top:
-	if(nextcd == NULL)
-	{
-		code = getcd( nextcd = sbuf, 1 );
-		stno = nxtstno;
-		prevlin = thislin;
-	}
-	if(code == STEOF)
-		if( popinclude() )
-			goto top;
-		else
-			return(STEOF);
-
-	if(code == STCONTINUE)
-	{
-		lineno = thislin;
-		nextcd = NULL;
-		goto top;
-	}
-
-/* Get rid of unused space at the head of the buffer */
-
-	if(nextcd > sbuf)
-	{
-		q = nextcd;
-		p = sbuf;
-		while(q < endcd)
-			*p++ = *q++;
-		endcd = p;
-	}
-
-/* Be aware that the input (i.e. the string at the address   nextcd)   is NOT
-   NULL-terminated */
-
-/* This loop merges all continuations into one long statement, AND puts the next
-   card to be read at the end of the buffer (i.e. it stores the look-ahead card
-   when there's room) */
-
-	ncont = 0;
-	do {
-		nextcd = endcd;
-		if (ncont < CONTMAX)
-			linestart[ncont++] = nextcd;
-		}
-		while(nextcd+66<=send && (code = getcd(nextcd,0))==STCONTINUE);
-	nextch = sbuf;
-	lastch = nextcd - 1;
-
-/* Handle buffer overflow by zeroing the 'next' pointer   (nextcd)   so that
-   the top of this function will initialize it next time it is called */
-
-	if(nextcd >= send)
-		nextcd = NULL;
-	lineno = prevlin;
-	prevlin = thislin;
-	return(STINITIAL);
-}
-
- static void
-bang(a,b,c,d,e)		/* save ! comments */
- char *a, *b, *c;
- register char *d, *e;
-{
-	char buf[COMMENT_BUFFER_SIZE + 1];
-	register char *p, *pe;
-
-	p = buf;
-	pe = buf + COMMENT_BUFFER_SIZE;
-	*pe = 0;
-	while(a < b)
-		if (!(*p++ = *a++))
-			p[-1] = 0;
-	if (b < c)
-		*p++ = '\t';
-	while(d < e) {
-		if (!(*p++ = *d++))
-			p[-1] = ' ';
-		if (p == pe) {
-			store_comment(buf);
-			p = buf;
-			}
-		}
-	if (p > buf) {
-		while(--p >= buf && *p == ' ');
-		p[1] = 0;
-		store_comment(buf);
-		}
-	}
-
-
-/* getcd - Get next input card
-
-	This function reads the next input card from global file pointer   infile.
-It assumes that   b   points to currently empty storage somewhere in  sbuf  */
-
- LOCAL int
-getcd(b, nocont)
- register char *b;
-{
-	register int c;
-	register char *p, *bend;
-	int speclin;		/* Special line - true when the line is allowed
-				   to have more than 66 characters (e.g. the
-				   "&" shorthand for continuation, use of a "\t"
-				   to skip part of the label columns) */
-	static char a[6];	/* Statement label buffer */
-	static char *aend	= a+6;
-	static char *stb, *stbend;
-	static int nst;
-	char *atend, *endcd0;
-	extern int warn72;
-	char buf72[24];
-	int amp, i;
-	char storage[COMMENT_BUFFER_SIZE + 1];
-	char *pointer;
-
-top:
-	endcd = b;
-	bend = b+66;
-	amp = speclin = NO;
-	atend = aend;
-
-/* Handle the continuation shorthand of "&" in the first column, which stands
-   for "     x" */
-
-	if( (c = getc(infile)) == '&')
-	{
-		a[0] = c;
-		a[1] = 0;
-		a[5] = 'x';
-		amp = speclin = YES;
-		bend = send;
-		p = aend;
-	}
-
-/* Handle the Comment cards (a 'C', 'c', '*', or '!' in the first column). */
-
-	else if(comstart[c & 0xfff])
-	{
-		if (feof (infile))
-		    return STEOF;
-
-		storage[COMMENT_BUFFER_SIZE] = c = '\0';
-		pointer = storage;
-		while( !feof (infile) && (*pointer++ = c = getc(infile)) != '\n') {
-
-/* Handle obscure end of file conditions on many machines */
-
-			if (feof (infile) && (c == '\377' || c == EOF)) {
-			    pointer--;
-			    break;
-			} /* if (feof (infile)) */
-
-			if (c == '\0')
-				*(pointer - 1) = ' ';
-
-			if (pointer == &storage[COMMENT_BUFFER_SIZE]) {
-				store_comment (storage);
-				pointer = storage;
-			} /* if (pointer == BUFFER_SIZE) */
-		} /* while */
-
-		if (pointer > storage) {
-		    if (c == '\n')
-
-/* Get rid of the newline */
-
-			pointer[-1] = 0;
-		    else
-			*pointer = 0;
-
-		    store_comment (storage);
-		} /* if */
-
-		if (feof (infile))
-		    if (c != '\n')	/* To allow the line index to
-					   increment correctly */
-			return STEOF;
-
-		++thislin;
-		goto top;
-	}
-
-	else if(c != EOF)
-	{
-
-/* Load buffer   a   with the statement label */
-
-		/* a tab in columns 1-6 skips to column 7 */
-		ungetc(c, infile);
-		for(p=a; p<aend && (c=getc(infile)) != '\n' && c!=EOF; )
-			if(c == '\t')
-
-/* The tab character translates into blank characters in the statement label */
-
-			{
-				atend = p;
-				while(p < aend)
-					*p++ = BLANK;
-				speclin = YES;
-				bend = send;
-			}
-			else
-				*p++ = c;
-	}
-
-/* By now we've read either a continuation character or the statement label
-   field */
-
-	if(c == EOF)
-		return(STEOF);
-
-/* The next 'if' block handles lines that have fewer than 7 characters */
-
-	if(c == '\n')
-	{
-		while(p < aend)
-			*p++ = BLANK;
-
-/* Blank out the buffer on lines which are not longer than 66 characters */
-
-		endcd0 = endcd;
-		if( ! speclin )
-			while(endcd < bend)
-				*endcd++ = BLANK;
-	}
-	else	{	/* read body of line */
-		if (warn72 & 2) {
-			speclin = YES;
-			bend = send;
-			}
-		while( endcd<bend && (c=getc(infile)) != '\n' && c!=EOF )
-			*endcd++ = c;
-		if(c == EOF)
-			return(STEOF);
-
-/* Drop any extra characters on the input card; this usually means those after
-   column 72 */
-
-		if(c != '\n')
-		{
-			i = 0;
-			while( (c=getc(infile)) != '\n' && c != EOF)
-				if (i < 23)
-					buf72[i++] = c;
-			if (warn72 && i && !speclin) {
-				buf72[i] = 0;
-				if (i >= 23)
-					strcpy(buf72+20, "...");
-				lineno = thislin + 1;
-				errstr("text after column 72: %s", buf72);
-				}
-			if(c == EOF)
-				return(STEOF);
-		}
-
-		endcd0 = endcd;
-		if( ! speclin )
-			while(endcd < bend)
-				*endcd++ = BLANK;
-	}
-
-/* The flow of control usually gets to this line (unless an earlier RETURN has
-   been taken) */
-
-	++thislin;
-
-	/* Fortran 77 specifies that a 0 in column 6 */
-	/* does not signify continuation */
-
-	if( !isspace(a[5]) && a[5]!='0') {
-		if (!amp)
-			for(p = a; p < aend;)
-				if (*p++ == '!' && p != aend)
-					goto initcheck;
-		if (addftnsrc && stb) {
-			if (stbend > stb + 7) { /* otherwise forget col 1-6 */
-				/* kludge around funny p1gets behavior */
-				*stb++ = '$';
-				if (amp)
-					*stb++ = '&';
-				else
-					for(p = a; p < atend;)
-						*stb++ = *p++;
-				}
-			if (endcd0 - b > stbend - stb) {
-				if (stb > stbend)
-					stb = stbend;
-				endcd0 = b + (stbend - stb);
-				}
-			for(p = b; p < endcd0;)
-				*stb++ = *p++;
-			*stb++ = '\n';
-			*stb = 0;
-			}
-		if (nocont) {
-			lineno = thislin;
-			errstr("illegal continuation card (starts \"%.6s\")",a);
-			}
-		else if (!amp && strncmp(a,"     ",5)) {
-			lineno = thislin;
-			errstr("labeled continuation line (starts \"%.6s\")",a);
-			}
-		return(STCONTINUE);
-		}
-initcheck:
-	for(p=a; p<atend; ++p)
-		if( !isspace(*p) ) {
-			if (*p++ != '!')
-				goto initline;
-			bang(p, atend, aend, b, endcd);
-			goto top;
-			}
-	for(p = b ; p<endcd ; ++p)
-		if( !isspace(*p) ) {
-			if (*p++ != '!')
-				goto initline;
-			bang(a, a, a, p, endcd);
-			goto top;
-			}
-
-/* Skip over blank cards by reading the next one right away */
-
-	goto top;
-
-initline:
-	if (addftnsrc) {
-		nst = (nst+1)%3;
-		if (!laststb && stb0)
-			laststb = stb0;
-		stb0 = stb = stbuf[nst];
-		*stb++ = '$';	/* kludge around funny p1gets behavior */
-		stbend = stb + sizeof(stbuf[0])-2;
-		for(p = a; p < atend;)
-			*stb++ = *p++;
-		if (atend < aend)
-			*stb++ = '\t';
-		for(p = b; p < endcd0;)
-			*stb++ = *p++;
-		*stb++ = '\n';
-		*stb = 0;
-		}
-
-/* Set   nxtstno   equal to the integer value of the statement label */
-
-	nxtstno = 0;
-	bend = a + 5;
-	for(p = a ; p < bend ; ++p)
-		if( !isspace(*p) )
-			if(isdigit(*p))
-				nxtstno = 10*nxtstno + (*p - '0');
-			else if (*p == '!') {
-				if (!addftnsrc)
-					bang(p+1,atend,aend,b,endcd);
-				endcd = b;
-				break;
-				}
-			else	{
-				lineno = thislin;
-				errstr(
-				"nondigit in statement label field \"%.5s\"", a);
-				nxtstno = 0;
-				break;
-			}
-	firstline = thislin;
-	return(STINITIAL);
-}
-
-
-/* crunch -- deletes all space characters, folds the backslash chars and
-   Hollerith strings, quotes the Fortran strings */
-
- LOCAL void
-crunch()
-{
-	register char *i, *j, *j0, *j1, *prvstr;
-	int k, ten, nh, nh0, quote;
-
-	/* i is the next input character to be looked at
-	   j is the next output character */
-
-	new_dcl = needwkey = parlev = parseen = 0;
-	expcom = 0;	/* exposed ','s */
-	expeql = 0;	/* exposed equal signs */
-	j = sbuf;
-	prvstr = sbuf;
-	k = 0;
-	for(i=sbuf ; i<=lastch ; ++i)
-	{
-		if(isspace(*i) )
-			continue;
-		if (*i == '!') {
-			while(i >= linestart[k])
-				if (++k >= CONTMAX)
-					Fatal("too many continuations\n");
-			j0 = linestart[k];
-			if (!addftnsrc)
-				bang(sbuf,sbuf,sbuf,i+1,j0);
-			i = j0-1;
-			continue;
-			}
-
-/* Keep everything in a quoted string */
-
-		if(*i=='\'' ||  *i=='"')
-		{
-			int len = 0;
-
-			quote = *i;
-			*j = MYQUOTE; /* special marker */
-			for(;;)
-			{
-				if(++i > lastch)
-				{
-					err("unbalanced quotes; closing quote supplied");
-					if (j >= lastch)
-						j = lastch - 1;
-					break;
-				}
-				if(*i == quote)
-					if(i<lastch && i[1]==quote) ++i;
-					else break;
-				else if(*i=='\\' && i<lastch && use_bs) {
-					++i;
-					*i = escapes[*(unsigned char *)i];
-					}
-				if (len + 2 < MAXTOKENLEN)
-				    *++j = *i;
-				else if (len + 2 == MAXTOKENLEN)
-				    erri
-	    ("String too long, truncating to %d chars", MAXTOKENLEN - 2);
-				len++;
-			} /* for (;;) */
-
-			j[1] = MYQUOTE;
-			j += 2;
-			prvstr = j;
-		}
-		else if( (*i=='h' || *i=='H')  && j>prvstr)	/* test for Hollerith strings */
-		{
-			j0 = j - 1;
-			if( ! isdigit(*j0)) goto copychar;
-			nh = *j0 - '0';
-			ten = 10;
-			j1 = prvstr;
-			if (j1+4 < j)
-				j1 = j-4;
-			for(;;) {
-				if (j0-- <= j1)
-					goto copychar;
-				if( ! isdigit(*j0 ) ) break;
-				nh += ten * (*j0-'0');
-				ten*=10;
-				}
-			/* a hollerith must be preceded by a punctuation mark.
-   '*' is possible only as repetition factor in a data statement
-   not, in particular, in character*2h
-*/
-
-			if( !(*j0=='*'&&sbuf[0]=='d') && *j0!='/'
-			&& *j0!='(' && *j0!=',' && *j0!='=' && *j0!='.')
-				goto copychar;
-			nh0 = nh;
-			if(i+nh > lastch || nh + 2 > MAXTOKENLEN)
-			{
-				erri("%dH too big", nh);
-				nh = lastch - i;
-				if (nh > MAXTOKENLEN - 2)
-					nh = MAXTOKENLEN - 2;
-				nh0 = -1;
-			}
-			j0[1] = MYQUOTE; /* special marker */
-			j = j0 + 1;
-			while(nh-- > 0)
-			{
-				if (++i > lastch) {
- hol_overflow:
-					if (nh0 >= 0)
-					  erri("escapes make %dH too big",
-						nh0);
-					break;
-					}
-				if(*i == '\\' && use_bs) {
-					if (++i > lastch)
-						goto hol_overflow;
-					*i = escapes[*(unsigned char *)i];
-					}
-				*++j = *i;
-			}
-			j[1] = MYQUOTE;
-			j+=2;
-			prvstr = j;
-		}
-		else	{
-			if(*i == '(') parseen = ++parlev;
-			else if(*i == ')') --parlev;
-			else if(parlev == 0)
-				if(*i == '=') expeql = 1;
-				else if(*i == ',') expcom = 1;
-copychar:		/*not a string or space -- copy, shifting case if necessary */
-			if(shiftcase && isupper(*i))
-				*j++ = tolower(*i);
-			else	*j++ = *i;
-		}
-	}
-	lastch = j - 1;
-	nextch = sbuf;
-}
-
- LOCAL void
-analyz()
-{
-	register char *i;
-
-	if(parlev != 0)
-	{
-		err("unbalanced parentheses, statement skipped");
-		stkey = SUNKNOWN;
-		lastch = sbuf - 1; /* prevent double error msg */
-		return;
-	}
-	if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(')
-	{
-		/* assignment or if statement -- look at character after balancing paren */
-		parlev = 1;
-		for(i=nextch+3 ; i<=lastch; ++i)
-			if(*i == (MYQUOTE))
-			{
-				while(*++i != MYQUOTE)
-					;
-			}
-			else if(*i == '(')
-				++parlev;
-			else if(*i == ')')
-			{
-				if(--parlev == 0)
-					break;
-			}
-		if(i >= lastch)
-			stkey = SLOGIF;
-		else if(i[1] == '=')
-			stkey = SLET;
-		else if( isdigit(i[1]) )
-			stkey = SARITHIF;
-		else	stkey = SLOGIF;
-		if(stkey != SLET)
-			nextch += 2;
-	}
-	else if(expeql) /* may be an assignment */
-	{
-		if(expcom && nextch<lastch &&
-		    nextch[0]=='d' && nextch[1]=='o')
-		{
-			stkey = SDO;
-			nextch += 2;
-		}
-		else	stkey = SLET;
-	}
-	else if (parseen && nextch + 7 < lastch
-			&& nextch[2] != 'u' /* screen out "double..." early */
-			&& nextch[0] == 'd' && nextch[1] == 'o'
-			&& ((nextch[2] >= '0' && nextch[2] <= '9')
-				|| nextch[2] == ','
-				|| nextch[2] == 'w'))
-		{
-		stkey = SDO;
-		nextch += 2;
-		needwkey = 1;
-		}
-	/* otherwise search for keyword */
-	else	{
-		stkey = getkwd();
-		if(stkey==SGOTO && lastch>=nextch)
-			if(nextch[0]=='(')
-				stkey = SCOMPGOTO;
-			else if(isalpha_(* USC nextch))
-				stkey = SASGOTO;
-	}
-	parlev = 0;
-}
-
-
-
- LOCAL int
-getkwd()
-{
-	register char *i, *j;
-	register struct Keylist *pk, *pend;
-	int k;
-
-	if(! isalpha_(* USC nextch) )
-		return(SUNKNOWN);
-	k = letter(nextch[0]);
-	if(pk = keystart[k])
-		for(pend = keyend[k] ; pk<=pend ; ++pk )
-		{
-			i = pk->keyname;
-			j = nextch;
-			while(*++i==*++j && *i!='\0')
-				;
-			if(*i=='\0' && j<=lastch+1)
-			{
-				nextch = j;
-				if(no66flag && pk->notinf66)
-					errstr("Not a Fortran 66 keyword: %s",
-					    pk->keyname);
-				return(pk->keyval);
-			}
-		}
-	return(SUNKNOWN);
-}
-
-initkey()
-{
-	register struct Keylist *p;
-	register int i,j;
-	register char *s;
-
-	for(i = 0 ; i<26 ; ++i)
-		keystart[i] = NULL;
-
-	for(p = keys ; p->keyname ; ++p) {
-		j = letter(p->keyname[0]);
-		if(keystart[j] == NULL)
-			keystart[j] = p;
-		keyend[j] = p;
-		}
-	comstart['c'] = comstart['C'] = comstart['*'] = comstart['!'] = 1;
-	s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_";
-	while(i = *s++)
-		anum_buf[i] = 1;
-	s = "0123456789";
-	while(i = *s++)
-		anum_buf[i] = 2;
-	}
-
- LOCAL int
-hexcheck(key)
- int key;
-{
-	register int radix;
-	register char *p;
-	char *kind;
-
-	switch(key) {
-		case 'z':
-		case 'Z':
-		case 'x':
-		case 'X':
-			radix = 16;
-			key = SHEXCON;
-			kind = "hexadecimal";
-			break;
-		case 'o':
-		case 'O':
-			radix = 8;
-			key = SOCTCON;
-			kind = "octal";
-			break;
-		case 'b':
-		case 'B':
-			radix = 2;
-			key = SBITCON;
-			kind = "binary";
-			break;
-		default:
-			err("bad bit identifier");
-			return(SNAME);
-		}
-	for(p = token; *p; p++)
-		if (hextoi(*p) >= radix) {
-			errstr("invalid %s character", kind);
-			break;
-			}
-	return key;
-	}
-
-/* gettok -- moves the right amount of text from   nextch   into the   token
-   buffer.   token   initially contains garbage (leftovers from the prev token) */
-
- LOCAL int
-gettok()
-{
-int havdot, havexp, havdbl;
-	int radix, val;
-	struct Punctlist *pp;
-	struct Dotlist *pd;
-	register int ch;
-
-	char *i, *j, *n1, *p;
-
-	ch = * USC nextch;
-	if(ch == (MYQUOTE))
-	{
-		++nextch;
-		p = token;
-		while(*nextch != MYQUOTE)
-			*p++ = *nextch++;
-		toklen = p - token;
-		*p = 0;
-		/* allow octal, binary, hex constants of the form 'abc'x (etc.) */
-		if (++nextch <= lastch && isalpha_(val = * USC nextch)) {
-			++nextch;
-			return hexcheck(val);
-			}
-		return (SHOLLERITH);
-	}
-
-	if(needkwd)
-	{
-		needkwd = 0;
-		return( getkwd() );
-	}
-
-	for(pp=puncts; pp->punchar; ++pp)
-		if(ch == pp->punchar) {
-			val = pp->punval;
-			if (++nextch <= lastch)
-			    switch(ch) {
-				case '/':
-					if (*nextch == '/') {
-						nextch++;
-						val = SCONCAT;
-						}
-					else if (new_dcl && parlev == 0)
-						val = SSLASHD;
-					return val;
-				case '*':
-					if (*nextch == '*') {
-						nextch++;
-						return SPOWER;
-						}
-					break;
-				case '<':
-					if (*nextch == '=') {
-						nextch++;
-						val = SLE;
-						}
-					if (*nextch == '>') {
-						nextch++;
-						val = SNE;
-						}
-					goto extchk;
-				case '=':
-					if (*nextch == '=') {
-						nextch++;
-						val = SEQ;
-						goto extchk;
-						}
-					break;
-				case '>':
-					if (*nextch == '=') {
-						nextch++;
-						val = SGE;
-						}
- extchk:
-					NOEXT("Fortran 8x comparison operator");
-					return val;
-				}
-			else if (ch == '/' && new_dcl && parlev == 0)
-				return SSLASHD;
-			switch(val) {
-				case SLPAR:
-					++parlev;
-					break;
-				case SRPAR:
-					--parlev;
-				}
-			return(val);
-			}
-	if(ch == '.')
-		if(nextch >= lastch) goto badchar;
-		else if(isdigit(nextch[1])) goto numconst;
-		else	{
-			for(pd=dots ; (j=pd->dotname) ; ++pd)
-			{
-				for(i=nextch+1 ; i<=lastch ; ++i)
-					if(*i != *j) break;
-					else if(*i != '.') ++j;
-					else	{
-						nextch = i+1;
-						return(pd->dotval);
-					}
-			}
-			goto badchar;
-		}
-	if( isalpha_(ch) )
-	{
-		p = token;
-		*p++ = *nextch++;
-		while(nextch<=lastch)
-			if( isalnum_(* USC nextch) )
-				*p++ = *nextch++;
-			else break;
-		toklen = p - token;
-		*p = 0;
-		if (needwkey) {
-			needwkey = 0;
-			if (toklen == 5
-				&& nextch <= lastch && *nextch == '(' /*)*/
-				&& !strcmp(token,"while"))
-			return(SWHILE);
-			}
-		if(inioctl && nextch<=lastch && *nextch=='=')
-		{
-			++nextch;
-			return(SNAMEEQ);
-		}
-		if(toklen>8 && eqn(8,token,"function")
-		&& isalpha_(* USC (token+8)) &&
-		    nextch<lastch && nextch[0]=='(' &&
-		    (nextch[1]==')' || isalpha_(* USC (nextch+1))) )
-		{
-			nextch -= (toklen - 8);
-			return(SFUNCTION);
-		}
-
-		if(toklen > 50)
-		{
-			char buff[100];
-			sprintf(buff, toklen >= 60
-				? "name %.56s... too long, truncated to %.*s"
-				: "name %s too long, truncated to %.*s",
-			    token, 50, token);
-			err(buff);
-			toklen = 50;
-			token[50] = '\0';
-		}
-		if(toklen==1 && *nextch==MYQUOTE) {
-			val = token[0];
-			++nextch;
-			for(p = token ; *nextch!=MYQUOTE ; )
-				*p++ = *nextch++;
-			++nextch;
-			toklen = p - token;
-			*p = 0;
-			return hexcheck(val);
-		}
-		return(SNAME);
-	}
-
-	if (isdigit(ch)) {
-
-		/* Check for NAG's special hex constant */
-
-		if (nextch[1] == '#'
-		||  nextch[2] == '#' && isdigit(nextch[1])) {
-
-		    radix = atoi (nextch);
-		    if (*++nextch != '#')
-			nextch++;
-		    if (radix != 2 && radix != 8 && radix != 16) {
-		        erri("invalid base %d for constant, defaulting to hex",
-				radix);
-			radix = 16;
-		    } /* if */
-		    if (++nextch > lastch)
-			goto badchar;
-		    for (p = token; hextoi(*nextch) < radix;) {
-			*p++ = *nextch++;
-			if (nextch > lastch)
-				break;
-			}
-		    toklen = p - token;
-		    *p = 0;
-		    return (radix == 16) ? SHEXCON : ((radix == 8) ? SOCTCON :
-			    SBITCON);
-		    }
-		}
-	else
-		goto badchar;
-numconst:
-	havdot = NO;
-	havexp = NO;
-	havdbl = NO;
-	for(n1 = nextch ; nextch<=lastch ; ++nextch)
-	{
-		if(*nextch == '.')
-			if(havdot) break;
-			else if(nextch+2<=lastch && isalpha_(* USC (nextch+1))
-			    && isalpha_(* USC (nextch+2)))
-				break;
-			else	havdot = YES;
-		else if( !intonly && (*nextch=='d' || *nextch=='e') )
-		{
-			p = nextch;
-			havexp = YES;
-			if(*nextch == 'd')
-				havdbl = YES;
-			if(nextch<lastch)
-				if(nextch[1]=='+' || nextch[1]=='-')
-					++nextch;
-			if( ! isdigit(*++nextch) )
-			{
-				nextch = p;
-				havdbl = havexp = NO;
-				break;
-			}
-			for(++nextch ;
-			    nextch<=lastch && isdigit(* USC nextch);
-			    ++nextch);
-			break;
-		}
-		else if( ! isdigit(* USC nextch) )
-			break;
-	}
-	p = token;
-	i = n1;
-	while(i < nextch)
-		*p++ = *i++;
-	toklen = p - token;
-	*p = 0;
-	if(havdbl) return(SDCON);
-	if(havdot || havexp) return(SRCON);
-	return(SICON);
-badchar:
-	sbuf[0] = *nextch++;
-	return(SUNKNOWN);
-}
-
-/* Comment buffering code */
-
- static void
-store_comment(str)
- char *str;
-{
-	int len;
-	comment_buf *ncb;
-
-	if (nextcd == sbuf) {
-		flush_comments();
-		p1_comment(str);
-		return;
-		}
-	len = strlen(str) + 1;
-	if (cbnext + len > cblast) {
-		if (!cbcur || !(ncb = cbcur->next)) {
-			ncb = (comment_buf *) Alloc(sizeof(comment_buf));
-			if (cbcur) {
-				cbcur->last = cbnext;
-				cbcur->next = ncb;
-				}
-			else {
-				cbfirst = ncb;
-				cbinit = ncb->buf;
-				}
-			ncb->next = 0;
-			}
-		cbcur = ncb;
-		cbnext = ncb->buf;
-		cblast = cbnext + COMMENT_BUF_STORE;
-		}
-	strcpy(cbnext, str);
-	cbnext += len;
-	}
-
- static void
-flush_comments()
-{
-	register char *s, *s1;
-	register comment_buf *cb;
-	if (cbnext == cbinit)
-		return;
-	cbcur->last = cbnext;
-	for(cb = cbfirst;; cb = cb->next) {
-		for(s = cb->buf; s < cb->last; s = s1) {
-			/* compute s1 = new s value first, since */
-			/* p1_comment may insert nulls into s */
-			s1 = s + strlen(s) + 1;
-			p1_comment(s);
-			}
-		if (cb == cbcur)
-			break;
-		}
-	cbcur = cbfirst;
-	cbnext = cbinit;
-	cblast = cbnext + COMMENT_BUF_STORE;
-	}
-
- void
-unclassifiable()
-{
-	register char *s, *se;
-
-	s = sbuf;
-	se = lastch;
-	if (se < sbuf)
-		return;
-	lastch = s - 1;
-	if (se - s > 10)
-		se = s + 10;
-	for(; s < se; s++)
-		if (*s == MYQUOTE) {
-			se = s;
-			break;
-			}
-	*se = 0;
-	errstr("unclassifiable statement (starts \"%s\")", sbuf);
-	}
//GO.SYSIN DD lex.c
echo machdefs.h 1>&2
sed >machdefs.h <<'//GO.SYSIN DD machdefs.h' 's/^-//'
-#define TYLENG	TYLONG		/* char string length field */
-
-#define TYINT	TYLONG
-#define SZADDR	4
-#define SZSHORT	2
-#define SZINT	4
-
-#define SZLONG	4
-#define SZLENG	SZLONG
-
-#define SZDREAL 8
-
-/* Alignment restrictions */
-
-#define ALIADDR SZADDR
-#define ALISHORT SZSHORT
-#define ALILONG 4
-#define ALIDOUBLE 8
-#define ALIINT	ALILONG
-#define ALILENG	ALILONG
-
-#define BLANKCOMMON "_BLNK__"		/* Name for the unnamed
-					   common block; this is unique
-					   because of underscores */
-
-#define LABELFMT "%s:\n"
-
-#define MAXREGVAR 4
-#define TYIREG TYLONG
-#define MSKIREG  (M(TYSHORT)|M(TYLONG))	/* allowed types of DO indicies
-					   which can be put in registers */
//GO.SYSIN DD machdefs.h
echo main.c 1>&2
sed >main.c <<'//GO.SYSIN DD main.c' 's/^-//'
-/****************************************************************
-Copyright 1990, 1991, 1992 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.
-****************************************************************/
-
-extern char F2C_version[];
-
-#include "defs.h"
-#include "parse.h"
-
-int complex_seen, dcomplex_seen;
-
-LOCAL int Max_ftn_files;
-
-char **ftn_files;
-int current_ftn_file = 0;
-
-flag ftn66flag = NO;
-flag nowarnflag = NO;
-flag noextflag = NO;
-flag  no66flag = NO;		/* Must also set noextflag to this
-					   same value */
-flag zflag = YES;		/* recognize double complex intrinsics */
-flag debugflag = NO;
-flag onetripflag = NO;
-flag shiftcase = YES;
-flag undeftype = NO;
-flag checksubs = NO;
-flag r8flag = NO;
-flag use_bs = YES;
-int tyreal = TYREAL;
-int tycomplex = TYCOMPLEX;
-extern void r8fix(), read_Pfiles();
-
-int maxregvar = MAXREGVAR;	/* if maxregvar > MAXREGVAR, error */
-int maxequiv = MAXEQUIV;
-int maxext = MAXEXT;
-int maxstno = MAXSTNO;
-int maxctl = MAXCTL;
-int maxhash = MAXHASH;
-int maxliterals = MAXLITERALS;
-int extcomm, ext1comm, useauto;
-int can_include = YES;	/* so we can disable includes for netlib */
-
-static char *def_i2 = "";
-
-static int useshortints = NO;	/* YES => tyint = TYSHORT */
-static int uselongints = NO;	/* YES => tyint = TYLONG */
-int addftnsrc = NO;		/* Include ftn source in output */
-int usedefsforcommon = NO;	/* Use #defines for common reference */
-int forcedouble = YES;		/* force real functions to double */
-int Ansi = NO;
-int def_equivs = YES;
-int tyioint = TYLONG;
-int szleng = SZLENG;
-int inqmask = M(TYLONG)|M(TYLOGICAL);
-int wordalign = NO;
-int forcereal = NO;
-int warn72 = NO;
-static int skipC, skipversion;
-char *file_name, *filename0, *parens;
-int Castargs = 1;
-static int typedefs = 0;
-int chars_per_wd, gflag, protostatus;
-int infertypes = 1;
-char used_rets[TYSUBR+1];
-extern char *tmpdir;
-static int h0align = 0;
-char *halign, *ohalign;
-int krparens = NO;
-int hsize;	/* for padding under -h */
-int htype;	/* for wr_equiv_init under -h */
-
-#define f2c_entry(swit,count,type,store,size) \
-	p_entry ("-", swit, 0, count, type, store, size)
-
-static arg_info table[] = {
-    f2c_entry ("w66", P_NO_ARGS, P_INT, &ftn66flag, YES),
-    f2c_entry ("w", P_NO_ARGS, P_INT, &nowarnflag, YES),
-    f2c_entry ("66", P_NO_ARGS, P_INT, &no66flag, YES),
-    f2c_entry ("d", P_ONE_ARG, P_INT, &debugflag, YES),
-    f2c_entry ("1", P_NO_ARGS, P_INT, &onetripflag, YES),
-    f2c_entry ("onetrip", P_NO_ARGS, P_INT, &onetripflag, YES),
-    f2c_entry ("I2", P_NO_ARGS, P_INT, &useshortints, YES),
-    f2c_entry ("I4", P_NO_ARGS, P_INT, &uselongints, YES),
-    f2c_entry ("U", P_NO_ARGS, P_INT, &shiftcase, NO),
-    f2c_entry ("u", P_NO_ARGS, P_INT, &undeftype, YES),
-    f2c_entry ("O", P_ONE_ARG, P_INT, &maxregvar, 0),
-    f2c_entry ("C", P_NO_ARGS, P_INT, &checksubs, YES),
-    f2c_entry ("Nq", P_ONE_ARG, P_INT, &maxequiv, 0),
-    f2c_entry ("Nx", P_ONE_ARG, P_INT, &maxext, 0),
-    f2c_entry ("Ns", P_ONE_ARG, P_INT, &maxstno, 0),
-    f2c_entry ("Nc", P_ONE_ARG, P_INT, &maxctl, 0),
-    f2c_entry ("Nn", P_ONE_ARG, P_INT, &maxhash, 0),
-    f2c_entry ("NL", P_ONE_ARG, P_INT, &maxliterals, 0),
-    f2c_entry ("c", P_NO_ARGS, P_INT, &addftnsrc, YES),
-    f2c_entry ("p", P_NO_ARGS, P_INT, &usedefsforcommon, YES),
-    f2c_entry ("R", P_NO_ARGS, P_INT, &forcedouble, NO),
-    f2c_entry ("!R", P_NO_ARGS, P_INT, &forcedouble, YES),
-    f2c_entry ("A", P_NO_ARGS, P_INT, &Ansi, YES),
-    f2c_entry ("ext", P_NO_ARGS, P_INT, &noextflag, YES),
-    f2c_entry ("z", P_NO_ARGS, P_INT, &zflag, NO),
-    f2c_entry ("a", P_NO_ARGS, P_INT, &useauto, YES),
-    f2c_entry ("r8", P_NO_ARGS, P_INT, &r8flag, YES),
-    f2c_entry ("i2", P_NO_ARGS, P_INT, &tyioint, NO),
-    f2c_entry ("w8", P_NO_ARGS, P_INT, &wordalign, YES),
-    f2c_entry ("!I", P_NO_ARGS, P_INT, &can_include, NO),
-    f2c_entry ("W", P_ONE_ARG, P_INT, &chars_per_wd, 0),
-    f2c_entry ("g", P_NO_ARGS, P_INT, &gflag, YES),
-    f2c_entry ("T", P_ONE_ARG, P_STRING, &tmpdir, 0),
-    f2c_entry ("E", P_NO_ARGS, P_INT, &extcomm, 1),
-    f2c_entry ("e1c", P_NO_ARGS, P_INT, &ext1comm, 1),
-    f2c_entry ("ec", P_NO_ARGS, P_INT, &ext1comm, 2),
-    f2c_entry ("C++", P_NO_ARGS, P_INT, &Ansi, 2),
-    f2c_entry ("P", P_NO_ARGS, P_INT, &Castargs, 3),
-    f2c_entry ("Ps", P_NO_ARGS, P_INT, &protostatus, 1),
-    f2c_entry ("!P", P_NO_ARGS, P_INT, &Castargs, 0),
-    f2c_entry ("!c", P_NO_ARGS, P_INT, &skipC, 1),
-    f2c_entry ("!it", P_NO_ARGS, P_INT, &infertypes, 0),
-    f2c_entry ("h", P_NO_ARGS, P_INT, &h0align, 1),
-    f2c_entry ("hd", P_NO_ARGS, P_INT, &h0align, 2),
-    f2c_entry ("kr", P_NO_ARGS, P_INT, &krparens, 1),
-    f2c_entry ("krd", P_NO_ARGS, P_INT, &krparens, 2),
-    f2c_entry ("!bs", P_NO_ARGS, P_INT, &use_bs, NO),
-    f2c_entry ("r", P_NO_ARGS, P_INT, &forcereal, YES),
-    f2c_entry ("72", P_NO_ARGS, P_INT, &warn72, 1),
-    f2c_entry ("f", P_NO_ARGS, P_INT, &warn72, 2),
-
-	/* options omitted from man pages */
-
-	/* -ev ==> implement equivalence with initialized pointers */
-    f2c_entry ("ev", P_NO_ARGS, P_INT, &def_equivs, NO),
-
-	/* -!it used to be the default when -it was more agressive */
-
-    f2c_entry ("it", P_NO_ARGS, P_INT, &infertypes, 1),
-
-	/* -Pd is similar to -P, but omits :ref: lines */
-    f2c_entry ("Pd", P_NO_ARGS, P_INT, &Castargs, 2),
-
-	/* -t ==> emit typedefs (under -A or -C++) for procedure
-		argument types used.  This is meant for netlib's
-		f2c service, so -A and -C++ will work with older
-		versions of f2c.h
-		*/
-    f2c_entry ("t", P_NO_ARGS, P_INT, &typedefs, 1),
-
-	/* -!V ==> omit version msg (to facilitate using diff in
-		regression testing)
-		*/
-    f2c_entry ("!V", P_NO_ARGS, P_INT, &skipversion, 1)
-
-}; /* table */
-
-extern char *c_functions;	/* "c_functions"	*/
-extern char *coutput;		/* "c_output"		*/
-extern char *initfname;		/* "raw_data"		*/
-extern char *blkdfname;		/* "block_data"		*/
-extern char *p1_file;		/* "p1_file"		*/
-extern char *p1_bakfile;	/* "p1_file.BAK"	*/
-extern char *sortfname;		/* "init_file"		*/
-extern char *proto_fname;	/* "proto_file"		*/
-FILE *protofile;
-
-extern void list_init_data(), set_tmp_names(), sigcatch(), Un_link_all();
-extern char *c_name();
-
-
-set_externs ()
-{
-    static char *hset[3] = { 0, "integer", "doublereal" };
-
-/* Adjust the global flags according to the command line parameters */
-
-    if (chars_per_wd > 0) {
-	typesize[TYADDR] = typesize[TYLONG] = typesize[TYREAL] =
-		typesize[TYLOGICAL] = chars_per_wd;
-	typesize[TYDREAL] = typesize[TYCOMPLEX] = chars_per_wd << 1;
-	typesize[TYDCOMPLEX] = chars_per_wd << 2;
-	typesize[TYSHORT] = chars_per_wd >> 1;
-	typesize[TYCILIST] = 5*chars_per_wd;
-	typesize[TYICILIST] = 6*chars_per_wd;
-	typesize[TYOLIST] = 9*chars_per_wd;
-	typesize[TYCLLIST] = 3*chars_per_wd;
-	typesize[TYALIST] = 2*chars_per_wd;
-	typesize[TYINLIST] = 26*chars_per_wd;
-	}
-
-    if (wordalign)
-	typealign[TYDREAL] = typealign[TYDCOMPLEX] = typealign[TYREAL];
-    if (!tyioint) {
-	tyioint = TYSHORT;
-	szleng = typesize[TYSHORT];
-	def_i2 = "#define f2c_i2 1\n";
-	inqmask = M(TYSHORT)|M(TYLOGICAL);
-	goto checklong;
-	}
-    else
-	szleng = typesize[TYLONG];
-    if (useshortints) {
-	inqmask = M(TYLONG);
- checklong:
-	protorettypes[TYLOGICAL] = typename[TYLOGICAL] = "shortlogical";
-	typesize[TYLOGICAL] = typesize[TYSHORT];
-	casttypes[TYLOGICAL] = "K_fp";
-	if (uselongints)
-	    err ("Can't use both long and short ints");
-	else
-	    tyint = tylogical = TYSHORT;
-	}
-    else if (uselongints)
-	tyint = TYLONG;
-
-    if (h0align) {
-	if (tyint == TYLONG && wordalign)
-		h0align = 1;
-    	ohalign = halign = hset[h0align];
-	htype = h0align == 1 ? tyint : TYDREAL;
-	hsize = typesize[htype];
-	}
-
-    if (no66flag)
-	noextflag = no66flag;
-    if (noextflag)
-	zflag = 0;
-
-    if (r8flag) {
-	tyreal = TYDREAL;
-	tycomplex = TYDCOMPLEX;
-	r8fix();
-	}
-    if (forcedouble) {
-	protorettypes[TYREAL] = "E_f";
-	casttypes[TYREAL] = "E_fp";
-	}
-
-    if (maxregvar > MAXREGVAR) {
-	warni("-O%d: too many register variables", maxregvar);
-	maxregvar = MAXREGVAR;
-    } /* if maxregvar > MAXREGVAR */
-
-/* Check the list of input files */
-
-    {
-	int bad, i, cur_max = Max_ftn_files;
-
-	for (i = bad = 0; i < cur_max && ftn_files[i]; i++)
-	    if (ftn_files[i][0] == '-') {
-		errstr ("Invalid flag '%s'", ftn_files[i]);
-		bad++;
-		}
-	if (bad)
-		exit(1);
-
-    } /* block */
-} /* set_externs */
-
-
- static int
-comm2dcl()
-{
-	Extsym *ext;
-	if (ext1comm)
-		for(ext = extsymtab; ext < nextext; ext++)
-			if (ext->extstg == STGCOMMON && !ext->extinit)
-				return ext1comm;
-	return 0;
-	}
-
- static void
-write_typedefs(outfile)
- FILE *outfile;
-{
-	register int i;
-	register char *s, *p = 0;
-	static char st[4] = { TYREAL, TYCOMPLEX, TYDCOMPLEX, TYCHAR };
-	static char stl[4] = { 'E', 'C', 'Z', 'H' };
-
-	for(i = 0; i <= TYSUBR; i++)
-		if (s = usedcasts[i]) {
-			if (!p) {
-				p = Ansi == 1 ? "()" : "(...)";
-				nice_printf(outfile,
-				"/* Types for casting procedure arguments: */\
-\n\n#ifndef F2C_proc_par_types\n");
-				if (i == 0) {
-					nice_printf(outfile,
-			"typedef int /* Unknown procedure type */ (*%s)%s;\n",
-						 s, p);
-					continue;
-					}
-				}
-			nice_printf(outfile, "typedef %s (*%s)%s;\n",
-					c_type_decl(i,1), s, p);
-			}
-	for(i = !forcedouble; i < 4; i++)
-		if (used_rets[st[i]])
-			nice_printf(outfile,
-				"typedef %s %c_f; /* %s function */\n",
-				p = i ? "VOID" : "doublereal",
-				stl[i], ftn_types[st[i]]);
-	if (p)
-		nice_printf(outfile, "#endif\n\n");
-	}
-
- static void
-commonprotos(outfile)
- register FILE *outfile;
-{
-	register Extsym *e, *ee;
-	register Argtypes *at;
-	Atype *a, *ae;
-	int k;
-	extern int proc_protochanges;
-
-	if (!outfile)
-		return;
-	for (e = extsymtab, ee = nextext; e < ee; e++)
-		if (e->extstg == STGCOMMON && e->allextp)
-			nice_printf(outfile, "/* comlen %s %ld */\n",
-				e->cextname, e->maxleng);
-	if (Castargs < 3)
-		return;
-
-	/* -Pr: special comments conveying current knowledge
-	    of external references */
-
-	k = proc_protochanges;
-	for (e = extsymtab, ee = nextext; e < ee; e++)
-		if (e->extstg == STGEXT
-		&& e->cextname != e->fextname)	/* not a library function */
-		    if (at = e->arginfo) {
-			if ((!e->extinit || at->changes & 1)
-				/* not defined here or
-					changed since definition */
-			&& at->nargs >= 0) {
-				nice_printf(outfile, "/*:ref: %s %d %d",
-					e->cextname, e->extype, at->nargs);
-				a = at->atypes;
-				for(ae = a + at->nargs; a < ae; a++)
-					nice_printf(outfile, " %d", a->type);
-				nice_printf(outfile, " */\n");
-				if (at->changes & 1)
-					k++;
-				}
-			}
-		    else if (e->extype)
-			/* typed external, never invoked */
-			nice_printf(outfile, "/*:ref: %s %d :*/\n",
-				e->cextname, e->extype);
-	if (k) {
-		nice_printf(outfile,
-	"/* Rerunning f2c -P may change prototypes or declarations. */\n");
-		if (nerr)
-			return;
-		if (protostatus)
-			done(4);
-		if (protofile != stdout) {
-			fprintf(diagfile,
-	"Rerunning \"f2c -P ... %s %s\" may change prototypes or declarations.\n",
-				filename0, proto_fname);
-			fflush(diagfile);
-			}
-		}
-	}
-
- int retcode = 0;
-
-main(argc, argv)
-int argc;
-char **argv;
-{
-	int c2d, k;
-	FILE *c_output;
-	char *cdfilename;
-	static char stderrbuf[BUFSIZ];
-	extern void def_commons();
-	extern char **dfltproc, *dflt1proc[];
-	extern char link_msg[];
-
-	diagfile = stderr;
-	setbuf(stderr, stderrbuf);	/* arrange for fast error msgs */
-
-	Max_ftn_files = argc - 1;
-	ftn_files = (char **)ckalloc((argc+1)*sizeof(char *));
-
-	parse_args (argc, argv, table, sizeof(table)/sizeof(arg_info),
-		ftn_files, Max_ftn_files);
-	if (!can_include && ext1comm == 2)
-		ext1comm = 1;
-	if (ext1comm && !extcomm)
-		extcomm = 2;
-	if (protostatus)
-		Castargs = 3;
-	else if (Castargs == 1 && !Ansi)
-		Castargs = 0;
-	if (Castargs >= 2 && !Ansi)
-		Ansi = 1;
-
-	if (!Ansi)
-		parens = "()";
-	else if (!Castargs)
-		parens = Ansi == 1 ? "()" : "(...)";
-	else
-		dfltproc = dflt1proc;
-
-	set_externs();
-	fileinit();
-	read_Pfiles(ftn_files);
-
-	for(k = 1; ftn_files[k]; k++)
-		if (dofork())
-			break;
-	filename0 = file_name = ftn_files[current_ftn_file = k - 1];
-
-	set_tmp_names();
-	sigcatch();
-
-	c_file   = opf(c_functions, textwrite);
-	pass1_file=opf(p1_file, binwrite);
-	initkey();
-	if (file_name && *file_name) {
-		if (debugflag != 1) {
-			coutput = c_name(file_name,'c');
-			if (Castargs >= 2)
-				proto_fname = c_name(file_name,'P');
-			}
-		cdfilename = coutput;
-		if (skipC)
-			coutput = 0;
-		else if (!(c_output = fopen(coutput, textwrite))) {
-			file_name = coutput;
-			coutput = 0;	/* don't delete read-only .c file */
-			fatalstr("can't open %.86s", file_name);
-			}
-
-		if (Castargs >= 2
-		&& !(protofile = fopen(proto_fname, textwrite)))
-			fatalstr("Can't open %.84s\n", proto_fname);
-		}
-	else {
-		file_name = "";
-		cdfilename = "f2c_out.c";
-		c_output = stdout;
-		coutput = 0;
-		if (Castargs >= 2) {
-			protofile = stdout;
-			if (!skipC)
-				printf("#ifdef P_R_O_T_O_T_Y_P_E_S\n");
-			}
-		}
-
-	if(inilex( copys(file_name) ))
-		done(1);
-	if (filename0) {
-		fprintf(diagfile, "%s:\n", file_name);
-		fflush(diagfile);
-		}
-
-	procinit();
-	if(k = yyparse())
-	{
-		fprintf(diagfile, "Bad parse, return code %d\n", k);
-		done(1);
-	}
-
-	commonprotos(protofile);
-	if (protofile == stdout && !skipC)
-		printf("#endif\n\n");
-
-	if (nerr || skipC)
-		goto C_skipped;
-
-
-/* Write out the declarations which are global to this file */
-
-	if ((c2d = comm2dcl()) == 1)
-		nice_printf(c_output, "/*>>>'/dev/null'<<<*/\n\n\
-/* Split this into several files by piping it through\n\n\
-sed \"s/^\\/\\*>>>'\\(.*\\)'<<<\\*\\/\\$/cat >'\\1' <<'\\/*<<<\\1>>>*\\/'/\" | /bin/sh\n\
- */\n\
-/*<<</dev/null>>>*/\n\
-/*>>>'%s'<<<*/\n", cdfilename);
-	if (gflag)
-		nice_printf (c_output, "#line 1 \"%s\"\n", file_name);
-	if (!skipversion) {
-		nice_printf (c_output, "/* %s -- translated by f2c ", file_name);
-		nice_printf (c_output, "(version of %s).\n", F2C_version);
-		nice_printf (c_output,
-	"   You must link the resulting object file with the libraries:\n\
-	%s   (in that order)\n*/\n\n", link_msg);
-		}
-	if (Ansi == 2)
-		nice_printf(c_output,
-			"#ifdef __cplusplus\nextern \"C\" {\n#endif\n");
-	nice_printf (c_output, "%s#include \"f2c.h\"\n\n", def_i2);
-	if (gflag)
-		nice_printf (c_output, "#line 1 \"%s\"\n", file_name);
-	if (Castargs && typedefs)
-		write_typedefs(c_output);
-	nice_printf (c_file, "\n");
-	fclose (c_file);
-	c_file = c_output;		/* HACK to get the next indenting
-					   to work */
-	wr_common_decls (c_output);
-	if (blkdfile)
-		list_init_data(&blkdfile, blkdfname, c_output);
-	wr_globals (c_output);
-	if ((c_file = fopen (c_functions, textread)) == (FILE *) NULL)
-	    Fatal("main - couldn't reopen c_functions");
-	ffilecopy (c_file, c_output);
-	if (*main_alias) {
-	    nice_printf (c_output, "/* Main program alias */ ");
-	    nice_printf (c_output, "int %s () { MAIN__ ();%s }\n",
-		    main_alias, Ansi ? " return 0;" : "");
-	    }
-	if (Ansi == 2)
-		nice_printf(c_output,
-			"#ifdef __cplusplus\n\t}\n#endif\n");
-	if (c2d) {
-		if (c2d == 1)
-			fprintf(c_output, "/*<<<%s>>>*/\n", cdfilename);
-		else
-			fclose(c_output);
-		def_commons(c_output);
-		}
-	if (c2d != 2)
-		fclose (c_output);
-
- C_skipped:
-	if(parstate != OUTSIDE)
-		{
-		warn("missing final end statement");
-		endproc();
-		}
-	done(nerr ? 1 : 0);
-}
-
-
-FILEP opf(fn, mode)
-char *fn, *mode;
-{
-	FILEP fp;
-	if( fp = fopen(fn, mode) )
-		return(fp);
-
-	fatalstr("cannot open intermediate file %s", fn);
-	/* NOT REACHED */ return 0;
-}
-
-
-clf(p, what, quit)
- FILEP *p;
- char *what;
- int quit;
-{
-	if(p!=NULL && *p!=NULL && *p!=stdout)
-	{
-		if(ferror(*p)) {
-			fprintf(stderr, "I/O error on %s\n", what);
-			if (quit)
-				done(3);
-			retcode = 3;
-			}
-		fclose(*p);
-	}
-	*p = NULL;
-}
-
-
-done(k)
-int k;
-{
-	clf(&initfile, "initfile", 0);
-	clf(&c_file, "c_file", 0);
-	clf(&pass1_file, "pass1_file", 0);
-	Un_link_all(k);
-	exit(k|retcode);
-}
//GO.SYSIN DD main.c
echo makefile 1>&2
sed >makefile <<'//GO.SYSIN DD makefile' 's/^-//'
-#	Makefile for f2c, a Fortran 77 to C converter
-
-g = -g
-CFLAGS = $g
-SHELL = /bin/sh
-
-OBJECTSd = main.o init.o gram.o lex.o proc.o equiv.o data.o format.o \
-	  expr.o exec.o intr.o io.o misc.o error.o mem.o names.o \
-	  output.o p1output.o pread.o put.o putpcc.o vax.o formatdata.o \
-	  parse_args.o niceprintf.o cds.o sysdep.o version.o
-OBJECTS = $(OBJECTSd) malloc.o
-
-all: xsum.out f2c
-
-f2c: $(OBJECTS)
-	$(CC) $(LDFLAGS) $(OBJECTS) -o f2c
-	size f2c
-
-gram.c:	gram.head gram.dcl gram.expr gram.exec gram.io defs.h tokdefs.h
-	( sed <tokdefs.h "s/#define/%token/" ;\
-		cat gram.head gram.dcl gram.expr gram.exec gram.io ) >gram.in
-	$(YACC) $(YFLAGS) gram.in
-	echo "(expect 4 shift/reduce)"
-	sed 's/^# line.*/\/* & *\//' y.tab.c >gram.c
-	rm -f gram.in y.tab.c
-
-$(OBJECTSd): defs.h ftypes.h defines.h machdefs.h sysdep.h
-
-tokdefs.h: tokens
-	grep -n . <tokens | sed "s/\([^:]*\):\(.*\)/#define \2 \1/" >tokdefs.h
-
-cds.o: sysdep.h
-exec.o: p1defs.h names.h
-expr.o: output.h niceprintf.h names.h
-format.o: p1defs.h format.h output.h niceprintf.h names.h iob.h
-formatdata.o: format.h output.h niceprintf.h names.h
-gram.o: p1defs.h
-init.o: output.h niceprintf.h iob.h
-intr.o: names.h
-io.o: names.h iob.h
-lex.o : tokdefs.h p1defs.h
-main.o: parse.h usignal.h
-mem.o: iob.h
-names.o: iob.h names.h output.h niceprintf.h
-niceprintf.o: defs.h names.h output.h niceprintf.h
-output.o: output.h niceprintf.h names.h
-p1output.o: p1defs.h output.h niceprintf.h names.h
-parse_args.o: parse.h
-proc.o: tokdefs.h names.h niceprintf.h output.h p1defs.h
-put.o: names.h pccdefs.h p1defs.h
-putpcc.o: names.h
-vax.o: defs.h output.h pccdefs.h
-output.h: niceprintf.h
-
-put.o putpcc.o: pccdefs.h
-
-f2c.t: f2c.1t
-	troff -man f2c.1t >f2c.t
-
-f2c.1: f2c.1t
-	nroff -man f2c.1t | col -b | uniq >f2c.1
-
-clean:
-	rm -f gram.c *.o f2c tokdefs.h f2c.t
-
-b = Notice README cds.c data.c defines.h defs.h equiv.c error.c \
-	exec.c expr.c f2c.1 f2c.1t f2c.h format.c format.h formatdata.c \
-	ftypes.h gram.dcl gram.exec gram.expr gram.head gram.io \
-	init.c intr.c io.c iob.h lex.c machdefs.h main.c makefile \
-	malloc.c mem.c memset.c misc.c names.c names.h niceprintf.c \
-	niceprintf.h output.c output.h p1defs.h p1output.c \
-	parse.h parse_args.c pccdefs.h pread.c proc.c put.c putpcc.c \
-	sysdep.c sysdep.h tokens usignal.h vax.c version.c xsum.c
-
-bundle:
-	bundle $b xsum0.out >/tmp/f2c.bundle
-
-xsum: xsum.c
-	$(CC) -o xsum xsum.c
-
-#Check validity of transmitted source...
-xsum.out: xsum
-	./xsum $b >xsum1.out
-	cmp xsum0.out xsum1.out && mv xsum1.out xsum.out
//GO.SYSIN DD makefile
echo malloc.c 1>&2
sed >malloc.c <<'//GO.SYSIN DD malloc.c' 's/^-//'
-/****************************************************************
-Copyright 1990 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.
-****************************************************************/
-
-#ifndef CRAY
-#define STACKMIN 512
-#define MINBLK (2*sizeof(struct mem) + 16)
-#define MSTUFF _malloc_stuff_
-#define F MSTUFF.free
-#define B MSTUFF.busy
-#define SBGULP 8192
-char *memcpy();
-
-struct mem {
-	struct mem *next;
-	unsigned len;
-	};
-
-struct {
-	struct mem *free;
-	char *busy;
-	} MSTUFF;
-
-char *
-malloc(size)
-register unsigned size;
-{
-	register struct mem *p, *q, *r, *s;
-	unsigned register k, m;
-	extern char *sbrk();
-	char *top, *top1;
-
-	size = (size+7) & ~7;
-	r = (struct mem *) &F;
-	for (p = F, q = 0; p; r = p, p = p->next) {
-		if ((k = p->len) >= size && (!q || m > k)) { m = k; q = p; s = r; }
-		}
-	if (q) {
-		if (q->len - size >= MINBLK) { /* split block */
-			p = (struct mem *) (((char *) (q+1)) + size);
-			p->next = q->next;
-			p->len = q->len - size - sizeof(struct mem);
-			s->next = p;
-			q->len = size;
-			}
-		else s->next = q->next;
-		}
-	else {
-		top = B ? B : (char *)(((long)sbrk(0) + 7) & ~7);
-		if (F && (char *)(F+1) + F->len == B)
-			{ q = F; F = F->next; }
-		else q = (struct mem *) top;
-		top1 = (char *)(q+1) + size;
-		if (top1 > top) {
-			if (sbrk((int)(top1-top+SBGULP)) == (char *) -1)
-				return 0;
-			r = (struct mem *)top1;
-			r->len = SBGULP - sizeof(struct mem);
-			r->next = F;
-			F = r;
-			top1 += SBGULP;
-			}
-		q->len = size;
-		B = top1;
-		}
-	return (char *) (q+1);
-	}
-
-free(f)
-char *f;
-{
-	struct mem *p, *q, *r;
-	char *pn, *qn;
-
-	if (!f) return;
-	q = (struct mem *) (f - sizeof(struct mem));
-	qn = f + q->len;
-	for (p = F, r = (struct mem *) &F; ; r = p, p = p->next) {
-		if (qn == (char *) p) {
-			q->len += p->len + sizeof(struct mem);
-			p = p->next;
-			}
-		pn = p ? ((char *) (p+1)) + p->len : 0;
-		if (pn == (char *) q) {
-			p->len += sizeof(struct mem) + q->len;
-			q->len = 0;
-			q->next = p;
-			r->next = p;
-			break;
-			}
-		if (pn < (char *) q) {
-			r->next = q;
-			q->next = p;
-			break;
-			}
-		}
-	}
-
-char *
-realloc(f, size)
-char *f;
-unsigned size;
-{
-	struct mem *p;
-	char *q, *f1;
-	unsigned s1;
-
-	if (!f) return malloc(size);
-	p = (struct mem *) (f - sizeof(struct mem));
-	s1 = p->len;
-	free(f);
-	if (s1 > size) s1 = size + 7 & ~7;
-	if (!p->len) {
-		f1 = (char *)(p->next + 1);
-		memcpy(f1, f, s1);
-		f = f1;
-		}
-	q = malloc(size);
-	if (q && q != f)
-		memcpy(q, f, s1);
-	return q;
-	}
-#endif
//GO.SYSIN DD malloc.c
echo mem.c 1>&2
sed >mem.c <<'//GO.SYSIN DD mem.c' 's/^-//'
-/****************************************************************
-Copyright 1990, 1991 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.
-****************************************************************/
-
-#include "defs.h"
-#include "iob.h"
-
-#define MEMBSIZE	32000
-#define GMEMBSIZE	16000
-
- extern void exit();
-
- char *
-gmem(n, round)
- int n, round;
-{
-	static char *last, *next;
-	char *rv;
-	if (round)
-#ifdef CRAY
-		if ((long)next & 0xe000000000000000)
-			next = (char *)(((long)next & 0x1fffffffffffffff) + 1);
-#else
-#ifdef MSDOS
-		if ((int)next & 1)
-			next++;
-#else
-		next = (char *)(((long)next + sizeof(char *)-1)
-				& ~((long)sizeof(char *)-1));
-#endif
-#endif
-	rv = next;
-	if ((next += n) > last) {
-		rv = Alloc(n + GMEMBSIZE);
-
-		next = rv + n;
-		last = next + GMEMBSIZE;
-		}
-	return rv;
-	}
-
- struct memblock {
-	struct memblock *next;
-	char buf[MEMBSIZE];
-	};
- typedef struct memblock memblock;
-
- static memblock *mem0;
- memblock *curmemblock, *firstmemblock;
-
- char *mem_first, *mem_next, *mem_last, *mem0_last;
-
- void
-mem_init()
-{
-	curmemblock = firstmemblock = mem0
-		= (memblock *)Alloc(sizeof(memblock));
-	mem_first = mem0->buf;
-	mem_next  = mem0->buf;
-	mem_last  = mem0->buf + MEMBSIZE;
-	mem0_last = mem0->buf + MEMBSIZE;
-	mem0->next = 0;
-	}
-
- char *
-mem(n, round)
- int n, round;
-{
-	memblock *b;
-	register char *rv, *s;
-
-	if (round)
-#ifdef CRAY
-		if ((long)mem_next & 0xe000000000000000)
-			mem_next = (char *)(((long)mem_next & 0x1fffffffffffffff) + 1);
-#else
-#ifdef MSDOS
-		if ((int)mem_next & 1)
-			mem_next++;
-#else
-		mem_next = (char *)(((long)mem_next + sizeof(char *)-1)
-				& ~((long)sizeof(char *)-1));
-#endif
-#endif
-	rv = mem_next;
-	s = rv + n;
-	if (s >= mem_last) {
-		if (n > MEMBSIZE)  {
-			fprintf(stderr, "mem(%d) failure!\n", n);
-			exit(1);
-			}
-		if (!(b = curmemblock->next)) {
-			b = (memblock *)Alloc(sizeof(memblock));
-			curmemblock->next = b;
-			b->next = 0;
-			}
-		curmemblock = b;
-		rv = b->buf;
-		mem_last = rv + sizeof(b->buf);
-		s = rv + n;
-		}
-	mem_next = s;
-	return rv;
-	}
-
- char *
-tostring(s,n)
- register char *s;
- int n;
-{
-	register char *s1, *se, **sf;
-	char *rv, *s0;
-	register int k = n + 2, t;
-
-	sf = str_fmt;
-	sf['%'] = "%";
-	s0 = s;
-	se = s + n;
-	for(; s < se; s++) {
-		t = *(unsigned char *)s;
-		s1 = sf[t];
-		while(*++s1)
-			k++;
-		}
-	sf['%'] = "%%";
-	rv = s1 = mem(k,0);
-	*s1++ = '"';
-	for(s = s0; s < se; s++) {
-		t = *(unsigned char *)s;
-		sprintf(s1, sf[t], t);
-		s1 += strlen(s1);
-		}
-	*s1 = 0;
-	return rv;
-	}
-
- char *
-cpstring(s)
- register char *s;
-{
-	return strcpy(mem(strlen(s)+1,0), s);
-	}
-
- void
-new_iob_data(ios, name)
- register io_setup *ios;
- char *name;
-{
-	register iob_data *iod;
-	register char **s, **se;
-
-	iod = (iob_data *)
-		mem(sizeof(iob_data) + ios->nelt*sizeof(char *), 1);
-	iod->next = iob_list;
-	iob_list = iod;
-	iod->type = ios->fields[0];
-	iod->name = cpstring(name);
-	s = iod->fields;
-	se = s + ios->nelt;
-	while(s < se)
-		*s++ = "0";
-	*s = 0;
-	}
-
- char *
-string_num(pfx, n)
- char *pfx;
- long n;
-{
-	char buf[32];
-	sprintf(buf, "%s%ld", pfx, n);
-	/* can't trust return type of sprintf -- BSD gets it wrong */
-	return strcpy(mem(strlen(buf)+1,0), buf);
-	}
-
-static defines *define_list;
-
- void
-def_start(outfile, s1, s2, post)
- FILE *outfile;
- char *s1, *s2, *post;
-{
-	defines *d;
-	int n, n1;
-
-	n = n1 = strlen(s1);
-	if (s2)
-		n += strlen(s2);
-	d = (defines *)mem(sizeof(defines)+n, 1);
-	d->next = define_list;
-	define_list = d;
-	strcpy(d->defname, s1);
-	if (s2)
-		strcpy(d->defname + n1, s2);
-	nice_printf(outfile, "#define %s %s", d->defname, post);
-	}
-
- void
-other_undefs(outfile)
- FILE *outfile;
-{
-	defines *d;
-	if (d = define_list) {
-		define_list = 0;
-		nice_printf(outfile, "\n");
-		do
-			nice_printf(outfile, "#undef %s\n", d->defname);
-			while(d = d->next);
-		nice_printf(outfile, "\n");
-		}
-	}
//GO.SYSIN DD mem.c
echo memset.c 1>&2
sed >memset.c <<'//GO.SYSIN DD memset.c' 's/^-//'
-/****************************************************************
-Copyright 1990 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.
-****************************************************************/
-
-/* This is for the benefit of people whose systems don't provide
- * memset, memcpy, and memcmp.  If yours is such a system, adjust
- * the makefile by adding memset.o to the "OBJECTS =" assignment.
- * WARNING: the memcpy below is adequate for f2c, but is not a
- * general memcpy routine (which must correctly handle overlapping
- * fields).
- */
-
- int
-memcmp(s1, s2, n)
- register char *s1, *s2;
- int n;
-{
-	register char *se;
-
-	for(se = s1 + n; s1 < se; s1++, s2++)
-		if (*s1 != *s2)
-			return *s1 - *s2;
-	return 0;
-	}
-
- char *
-memcpy(s1, s2, n)
- register char *s1, *s2;
- int n;
-{
-	register char *s0 = s1, *se = s1 + n;
-
-	while(s1 < se)
-		*s1++ = *s2++;
-	return s0;
-	}
-
-memset(s, c, n)
- register char *s;
- register int c;
- int n;
-{
-	register char *se = s + n;
-
-	while(s < se)
-		*s++ = c;
-	}
//GO.SYSIN DD memset.c
echo misc.c 1>&2
sed >misc.c <<'//GO.SYSIN DD misc.c' 's/^-//'
-/****************************************************************
-Copyright 1990, 1992 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.
-****************************************************************/
-
-#include "defs.h"
-
-int oneof_stg (name, stg, mask)
- Namep name;
- int stg, mask;
-{
-	if (stg == STGCOMMON && name) {
-		if ((mask & M(STGEQUIV)))
-			return name->vcommequiv;
-		if ((mask & M(STGCOMMON)))
-			return !name->vcommequiv;
-		}
-	return ONEOF(stg, mask);
-	}
-
-
-/* op_assign -- given a binary opcode, return the associated assignment
-   operator */
-
-int op_assign (opcode)
-int opcode;
-{
-    int retval = -1;
-
-    switch (opcode) {
-        case OPPLUS: retval = OPPLUSEQ; break;
-	case OPMINUS: retval = OPMINUSEQ; break;
-	case OPSTAR: retval = OPSTAREQ; break;
-	case OPSLASH: retval = OPSLASHEQ; break;
-	case OPMOD: retval = OPMODEQ; break;
-	case OPLSHIFT: retval = OPLSHIFTEQ; break;
-	case OPRSHIFT: retval = OPRSHIFTEQ; break;
-	case OPBITAND: retval = OPBITANDEQ; break;
-	case OPBITXOR: retval = OPBITXOREQ; break;
-	case OPBITOR: retval = OPBITOREQ; break;
-	default:
-	    erri ("op_assign:  bad opcode '%d'", opcode);
-	    break;
-    } /* switch */
-
-    return retval;
-} /* op_assign */
-
-
- char *
-Alloc(n)	/* error-checking version of malloc */
-		/* ckalloc initializes memory to 0; Alloc does not */
- int n;
-{
-	char errbuf[32];
-	register char *rv;
-
-	rv = malloc(n);
-	if (!rv) {
-		sprintf(errbuf, "malloc(%d) failure!", n);
-		Fatal(errbuf);
-		}
-	return rv;
-	}
-
-
-cpn(n, a, b)
-register int n;
-register char *a, *b;
-{
-	while(--n >= 0)
-		*b++ = *a++;
-}
-
-
-
-eqn(n, a, b)
-register int n;
-register char *a, *b;
-{
-	while(--n >= 0)
-		if(*a++ != *b++)
-			return(NO);
-	return(YES);
-}
-
-
-
-
-
-
-
-cmpstr(a, b, la, lb)	/* compare two strings */
-register char *a, *b;
-ftnint la, lb;
-{
-	register char *aend, *bend;
-	aend = a + la;
-	bend = b + lb;
-
-
-	if(la <= lb)
-	{
-		while(a < aend)
-			if(*a != *b)
-				return( *a - *b );
-			else
-			{
-				++a;
-				++b;
-			}
-
-		while(b < bend)
-			if(*b != ' ')
-				return(' ' - *b);
-			else
-				++b;
-	}
-
-	else
-	{
-		while(b < bend)
-			if(*a != *b)
-				return( *a - *b );
-			else
-			{
-				++a;
-				++b;
-			}
-		while(a < aend)
-			if(*a != ' ')
-				return(*a - ' ');
-			else
-				++a;
-	}
-	return(0);
-}
-
-
-/* hookup -- Same as LISP NCONC, that is a destructive append of two lists */
-
-chainp hookup(x,y)
-register chainp x, y;
-{
-	register chainp p;
-
-	if(x == NULL)
-		return(y);
-
-	for(p = x ; p->nextp ; p = p->nextp)
-		;
-	p->nextp = y;
-	return(x);
-}
-
-
-
-struct Listblock *mklist(p)
-chainp p;
-{
-	register struct Listblock *q;
-
-	q = ALLOC(Listblock);
-	q->tag = TLIST;
-	q->listp = p;
-	return(q);
-}
-
-
-chainp mkchain(p,q)
-register char * p;
-register chainp q;
-{
-	register chainp r;
-
-	if(chains)
-	{
-		r = chains;
-		chains = chains->nextp;
-	}
-	else
-		r = ALLOC(Chain);
-
-	r->datap = p;
-	r->nextp = q;
-	return(r);
-}
-
- chainp
-revchain(next)
- register chainp next;
-{
-	register chainp p, prev = 0;
-
-	while(p = next) {
-		next = p->nextp;
-		p->nextp = prev;
-		prev = p;
-		}
-	return prev;
-	}
-
-
-/* addunder -- turn a cvarname into an external name */
-/* The cvarname may already end in _ (to avoid C keywords); */
-/* if not, it has room for appending an _. */
-
- char *
-addunder(s)
- register char *s;
-{
-	register int c, i;
-	char *s0 = s;
-
-	i = 0;
-	while(c = *s++)
-		if (c == '_')
-			i++;
-		else
-			i = 0;
-	if (!i) {
-		*s-- = 0;
-		*s = '_';
-		}
-	return( s0 );
-	}
-
-
-/* copyn -- return a new copy of the input Fortran-string */
-
-char *copyn(n, s)
-register int n;
-register char *s;
-{
-	register char *p, *q;
-
-	p = q = (char *) Alloc(n);
-	while(--n >= 0)
-		*q++ = *s++;
-	return(p);
-}
-
-
-
-/* copys -- return a new copy of the input C-string */
-
-char *copys(s)
-char *s;
-{
-	return( copyn( strlen(s)+1 , s) );
-}
-
-
-
-/* convci -- Convert Fortran-string to integer; assumes that input is a
-   legal number, with no trailing blanks */
-
-ftnint convci(n, s)
-register int n;
-register char *s;
-{
-	ftnint sum;
-	sum = 0;
-	while(n-- > 0)
-		sum = 10*sum + (*s++ - '0');
-	return(sum);
-}
-
-/* convic - Convert Integer constant to string */
-
-char *convic(n)
-ftnint n;
-{
-	static char s[20];
-	register char *t;
-
-	s[19] = '\0';
-	t = s+19;
-
-	do	{
-		*--t = '0' + n%10;
-		n /= 10;
-	} while(n > 0);
-
-	return(t);
-}
-
-
-
-/* mkname -- add a new identifier to the environment, including the closed
-   hash table. */
-
-Namep mkname(s)
-register char *s;
-{
-	struct Hashentry *hp;
-	register Namep q;
-	register int c, hash, i;
-	register char *t;
-	char *s0;
-	char errbuf[64];
-
-	hash = i = 0;
-	s0 = s;
-	while(c = *s++) {
-		hash += c;
-		if (c == '_')
-			i = 1;
-		}
-	if (!i && in_vector(s0) >= 0)
-		i = 1;
-	hash %= maxhash;
-
-/* Add the name to the closed hash table */
-
-	hp = hashtab + hash;
-
-	while(q = hp->varp)
-		if( hash == hp->hashval && !strcmp(s0,q->fvarname) )
-			return(q);
-		else if(++hp >= lasthash)
-			hp = hashtab;
-
-	if(++nintnames >= maxhash-1)
-		many("names", 'n', maxhash);	/* Fatal error */
-	hp->varp = q = ALLOC(Nameblock);
-	hp->hashval = hash;
-	q->tag = TNAME;	/* TNAME means the tag type is NAME */
-	c = s - s0;
-	if (c > 7 && noextflag) {
-		sprintf(errbuf, "\"%.35s%s\" over 6 characters long", s0,
-			c > 36 ? "..." : "");
-		errext(errbuf);
-		}
-	q->fvarname = strcpy(mem(c,0), s0);
-	t = q->cvarname = mem(c + i + 1, 0);
-	s = s0;
-	/* add __ to the end of any name containing _ and to any C keyword */
-	while(*t = *s++)
-		t++;
-	if (i) {
-		t[0] = t[1] = '_';
-		t[2] = 0;
-		}
-	return(q);
-}
-
-
-struct Labelblock *mklabel(l)
-ftnint l;
-{
-	register struct Labelblock *lp;
-
-	if(l <= 0)
-		return(NULL);
-
-	for(lp = labeltab ; lp < highlabtab ; ++lp)
-		if(lp->stateno == l)
-			return(lp);
-
-	if(++highlabtab > labtabend)
-		many("statement labels", 's', maxstno);
-
-	lp->stateno = l;
-	lp->labelno = newlabel();
-	lp->blklevel = 0;
-	lp->labused = NO;
-	lp->fmtlabused = NO;
-	lp->labdefined = NO;
-	lp->labinacc = NO;
-	lp->labtype = LABUNKNOWN;
-	lp->fmtstring = 0;
-	return(lp);
-}
-
-
-newlabel()
-{
-	return( ++lastlabno );
-}
-
-
-/* this label appears in a branch context */
-
-struct Labelblock *execlab(stateno)
-ftnint stateno;
-{
-	register struct Labelblock *lp;
-
-	if(lp = mklabel(stateno))
-	{
-		if(lp->labinacc)
-			warn1("illegal branch to inner block, statement label %s",
-			    convic(stateno) );
-		else if(lp->labdefined == NO)
-			lp->blklevel = blklevel;
-		if(lp->labtype == LABFORMAT)
-			err("may not branch to a format");
-		else
-			lp->labtype = LABEXEC;
-	}
-	else
-		execerr("illegal label %s", convic(stateno));
-
-	return(lp);
-}
-
-
-/* find or put a name in the external symbol table */
-
-Extsym *mkext(f,s)
-char *f, *s;
-{
-	Extsym *p;
-
-	for(p = extsymtab ; p<nextext ; ++p)
-		if(!strcmp(s,p->cextname))
-			return( p );
-
-	if(nextext >= lastext)
-		many("external symbols", 'x', maxext);
-
-	nextext->fextname = strcpy(gmem(strlen(f)+1,0), f);
-	nextext->cextname = f == s
-				? nextext->fextname
-				: strcpy(gmem(strlen(s)+1,0), s);
-	nextext->extstg = STGUNKNOWN;
-	nextext->extp = 0;
-	nextext->allextp = 0;
-	nextext->extleng = 0;
-	nextext->maxleng = 0;
-	nextext->extinit = 0;
-	nextext->curno = nextext->maxno = 0;
-	return( nextext++ );
-}
-
-
-Addrp builtin(t, s, dbi)
-int t, dbi;
-char *s;
-{
-	register Extsym *p;
-	register Addrp q;
-	extern chainp used_builtins;
-
-	p = mkext(s,s);
-	if(p->extstg == STGUNKNOWN)
-		p->extstg = STGEXT;
-	else if(p->extstg != STGEXT)
-	{
-		errstr("improper use of builtin %s", s);
-		return(0);
-	}
-
-	q = ALLOC(Addrblock);
-	q->tag = TADDR;
-	q->vtype = t;
-	q->vclass = CLPROC;
-	q->vstg = STGEXT;
-	q->memno = p - extsymtab;
-	q->dbl_builtin = dbi;
-
-/* A NULL pointer here tells you to use   memno   to check the external
-   symbol table */
-
-	q -> uname_tag = UNAM_EXTERN;
-
-/* Add to the list of used builtins */
-
-	if (dbi >= 0)
-		add_extern_to_list (q, &used_builtins);
-	return(q);
-}
-
-
-
-add_extern_to_list (addr, list_store)
-Addrp addr;
-chainp *list_store;
-{
-    chainp last = CHNULL;
-    chainp list;
-    int memno;
-
-    if (list_store == (chainp *) NULL || addr == (Addrp) NULL)
-	return;
-
-    list = *list_store;
-    memno = addr -> memno;
-
-    for (;list; last = list, list = list -> nextp) {
-	Addrp this = (Addrp) (list -> datap);
-
-	if (this -> tag == TADDR && this -> uname_tag == UNAM_EXTERN &&
-		this -> memno == memno)
-	    return;
-    } /* for */
-
-    if (*list_store == CHNULL)
-	*list_store = mkchain((char *)cpexpr((expptr)addr), CHNULL);
-    else
-	last->nextp = mkchain((char *)cpexpr((expptr)addr), CHNULL);
-
-} /* add_extern_to_list */
-
-
-frchain(p)
-register chainp *p;
-{
-	register chainp q;
-
-	if(p==0 || *p==0)
-		return;
-
-	for(q = *p; q->nextp ; q = q->nextp)
-		;
-	q->nextp = chains;
-	chains = *p;
-	*p = 0;
-}
-
- void
-frexchain(p)
- register chainp *p;
-{
-	register chainp q, r;
-
-	if (q = *p) {
-		for(;;q = r) {
-			frexpr((expptr)q->datap);
-			if (!(r = q->nextp))
-				break;
-			}
-		q->nextp = chains;
-		chains = *p;
-		*p = 0;
-		}
-	}
-
-
-tagptr cpblock(n,p)
-register int n;
-register char * p;
-{
-	register ptr q;
-
-	memcpy((char *)(q = ckalloc(n)), (char *)p, n);
-	return( (tagptr) q);
-}
-
-
-
-ftnint lmax(a, b)
-ftnint a, b;
-{
-	return( a>b ? a : b);
-}
-
-ftnint lmin(a, b)
-ftnint a, b;
-{
-	return(a < b ? a : b);
-}
-
-
-
-
-maxtype(t1, t2)
-int t1, t2;
-{
-	int t;
-
-	t = t1 >= t2 ? t1 : t2;
-	if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) )
-		t = TYDCOMPLEX;
-	return(t);
-}
-
-
-
-/* return log base 2 of n if n a power of 2; otherwise -1 */
-log_2(n)
-ftnint n;
-{
-	int k;
-
-	/* trick based on binary representation */
-
-	if(n<=0 || (n & (n-1))!=0)
-		return(-1);
-
-	for(k = 0 ;  n >>= 1  ; ++k)
-		;
-	return(k);
-}
-
-
-
-frrpl()
-{
-	struct Rplblock *rp;
-
-	while(rpllist)
-	{
-		rp = rpllist->rplnextp;
-		free( (charptr) rpllist);
-		rpllist = rp;
-	}
-}
-
-
-
-/* Call a Fortran function with an arbitrary list of arguments */
-
-int callk_kludge;
-
-expptr callk(type, name, args)
-int type;
-char *name;
-chainp args;
-{
-	register expptr p;
-
-	p = mkexpr(OPCALL,
-		(expptr)builtin(callk_kludge ? callk_kludge : type, name, 0),
-		(expptr)args);
-	p->exprblock.vtype = type;
-	return(p);
-}
-
-
-
-expptr call4(type, name, arg1, arg2, arg3, arg4)
-int type;
-char *name;
-expptr arg1, arg2, arg3, arg4;
-{
-	struct Listblock *args;
-	args = mklist( mkchain((char *)arg1,
-			mkchain((char *)arg2,
-				mkchain((char *)arg3,
-	    				mkchain((char *)arg4, CHNULL)) ) ) );
-	return( callk(type, name, (chainp)args) );
-}
-
-
-
-
-expptr call3(type, name, arg1, arg2, arg3)
-int type;
-char *name;
-expptr arg1, arg2, arg3;
-{
-	struct Listblock *args;
-	args = mklist( mkchain((char *)arg1,
-			mkchain((char *)arg2,
-				mkchain((char *)arg3, CHNULL) ) ) );
-	return( callk(type, name, (chainp)args) );
-}
-
-
-
-
-
-expptr call2(type, name, arg1, arg2)
-int type;
-char *name;
-expptr arg1, arg2;
-{
-	struct Listblock *args;
-
-	args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) );
-	return( callk(type,name, (chainp)args) );
-}
-
-
-
-
-expptr call1(type, name, arg)
-int type;
-char *name;
-expptr arg;
-{
-	return( callk(type,name, (chainp)mklist(mkchain((char *)arg,CHNULL)) ));
-}
-
-
-expptr call0(type, name)
-int type;
-char *name;
-{
-	return( callk(type, name, CHNULL) );
-}
-
-
-
-struct Impldoblock *mkiodo(dospec, list)
-chainp dospec, list;
-{
-	register struct Impldoblock *q;
-
-	q = ALLOC(Impldoblock);
-	q->tag = TIMPLDO;
-	q->impdospec = dospec;
-	q->datalist = list;
-	return(q);
-}
-
-
-
-
-/* ckalloc -- Allocate 1 memory unit of size   n,   checking for out of
-   memory error */
-
-ptr ckalloc(n)
-register int n;
-{
-	register ptr p;
-	p = (ptr)calloc(1, (unsigned) n);
-	if (p || !n)
-		return(p);
-	fprintf(stderr, "failing to get %d bytes\n",n);
-	Fatal("out of memory");
-	/* NOT REACHED */ return 0;
-}
-
-
-
-isaddr(p)
-register expptr p;
-{
-	if(p->tag == TADDR)
-		return(YES);
-	if(p->tag == TEXPR)
-		switch(p->exprblock.opcode)
-		{
-		case OPCOMMA:
-			return( isaddr(p->exprblock.rightp) );
-
-		case OPASSIGN:
-		case OPASSIGNI:
-		case OPPLUSEQ:
-		case OPMINUSEQ:
-		case OPSLASHEQ:
-		case OPMODEQ:
-		case OPLSHIFTEQ:
-		case OPRSHIFTEQ:
-		case OPBITANDEQ:
-		case OPBITXOREQ:
-		case OPBITOREQ:
-			return( isaddr(p->exprblock.leftp) );
-		}
-	return(NO);
-}
-
-
-
-
-isstatic(p)
-register expptr p;
-{
-	extern int useauto;
-	if(p->headblock.vleng && !ISCONST(p->headblock.vleng))
-		return(NO);
-
-	switch(p->tag)
-	{
-	case TCONST:
-		return(YES);
-
-	case TADDR:
-		if(ONEOF(p->addrblock.vstg,MSKSTATIC) &&
-		    ISCONST(p->addrblock.memoffset) && !useauto)
-			return(YES);
-
-	default:
-		return(NO);
-	}
-}
-
-
-
-/* addressable -- return True iff it is a constant value, or can be
-   referenced by constant values */
-
-addressable(p)
-register expptr p;
-{
-	switch(p->tag)
-	{
-	case TCONST:
-		return(YES);
-
-	case TADDR:
-		return( addressable(p->addrblock.memoffset) );
-
-	default:
-		return(NO);
-	}
-}
-
-
-/* isnegative_const -- returns true if the constant is negative.  Returns
-   false for imaginary and nonnumeric constants */
-
-int isnegative_const (cp)
-struct Constblock *cp;
-{
-    int retval;
-
-    if (cp == NULL)
-	return 0;
-
-    switch (cp -> vtype) {
-        case TYSHORT:
-	case TYLONG:
-	    retval = cp -> Const.ci < 0;
-	    break;
-	case TYREAL:
-	case TYDREAL:
-		retval = cp->vstg ? *cp->Const.cds[0] == '-'
-				  :  cp->Const.cd[0] < 0.0;
-	    break;
-	default:
-
-	    retval = 0;
-	    break;
-    } /* switch */
-
-    return retval;
-} /* isnegative_const */
-
-negate_const(cp)
- Constp cp;
-{
-    if (cp == (struct Constblock *) NULL)
-	return;
-
-    switch (cp -> vtype) {
-	case TYSHORT:
-	case TYLONG:
-	    cp -> Const.ci = - cp -> Const.ci;
-	    break;
-	case TYCOMPLEX:
-	case TYDCOMPLEX:
-		if (cp->vstg)
-		    switch(*cp->Const.cds[1]) {
-			case '-':
-				++cp->Const.cds[1];
-				break;
-			case '0':
-				break;
-			default:
-				--cp->Const.cds[1];
-			}
-		else
-	    		cp->Const.cd[1] = -cp->Const.cd[1];
-		/* no break */
-	case TYREAL:
-	case TYDREAL:
-		if (cp->vstg)
-		    switch(*cp->Const.cds[0]) {
-			case '-':
-				++cp->Const.cds[0];
-				break;
-			case '0':
-				break;
-			default:
-				--cp->Const.cds[0];
-			}
-		else
-	    		cp->Const.cd[0] = -cp->Const.cd[0];
-	    break;
-	case TYCHAR:
-	case TYLOGICAL:
-	    erri ("negate_const:  can't negate type '%d'", cp -> vtype);
-	    break;
-	default:
-	    erri ("negate_const:  bad type '%d'",
-		    cp -> vtype);
-	    break;
-    } /* switch */
-} /* negate_const */
-
-ffilecopy (infp, outfp)
-FILE *infp, *outfp;
-{
-    while (!feof (infp)) {
-	register c = getc (infp);
-	if (!feof (infp))
-	putc (c, outfp);
-    } /* while */
-} /* ffilecopy */
-
-
-#define NOT_IN_VECTOR -1
-
-/* in_vector -- verifies whether   str   is in c_keywords.
-   If so, the index is returned else   NOT_IN_VECTOR   is returned.
-   c_keywords must be in alphabetical order (as defined by strcmp).
-*/
-
-int in_vector(str)
-char *str;
-{
-	extern int n_keywords;
-	extern char *c_keywords[];
-	register int n = n_keywords;
-	register char **K = c_keywords;
-	register int n1, t;
-
-	do {
-		n1 = n >> 1;
-		if (!(t = strcmp(str, K[n1])))
-			return K - c_keywords + n1;
-		if (t < 0)
-			n = n1;
-		else {
-			n -= ++n1;
-			K += n1;
-			}
-		}
-		while(n > 0);
-
-	return NOT_IN_VECTOR;
-	} /* in_vector */
-
-
-int is_negatable (Const)
-Constp Const;
-{
-    int retval = 0;
-    if (Const != (Constp) NULL)
-	switch (Const -> vtype) {
-	    case TYSHORT:
-	        retval = Const -> Const.ci >= -BIGGEST_SHORT;
-	        break;
-	    case TYLONG:
-	        retval = Const -> Const.ci >= -BIGGEST_LONG;
-	        break;
-	    case TYREAL:
-	    case TYDREAL:
-	    case TYCOMPLEX:
-	    case TYDCOMPLEX:
-	        retval = 1;
-	        break;
-	    case TYLOGICAL:
-	    case TYCHAR:
-	    case TYSUBR:
-	    default:
-	        retval = 0;
-	        break;
-	} /* switch */
-
-    return retval;
-} /* is_negatable */
-
-backup(fname, bname)
- char *fname, *bname;
-{
-	FILE *b, *f;
-	static char couldnt[] = "Couldn't open %.80s";
-
-	if (!(f = fopen(fname, binread))) {
-		warn1(couldnt, fname);
-		return;
-		}
-	if (!(b = fopen(bname, binwrite))) {
-		warn1(couldnt, bname);
-		return;
-		}
-	ffilecopy(f, b);
-	fclose(f);
-	fclose(b);
-	}
-
-
-/* struct_eq -- returns YES if structures have the same field names and
-   types, NO otherwise */
-
-int struct_eq (s1, s2)
-chainp s1, s2;
-{
-    struct Dimblock *d1, *d2;
-    Constp cp1, cp2;
-
-    if (s1 == CHNULL && s2 == CHNULL)
-	return YES;
-    for(; s1 && s2; s1 = s1->nextp, s2 = s2->nextp) {
-	register Namep v1 = (Namep) s1 -> datap;
-	register Namep v2 = (Namep) s2 -> datap;
-
-	if (v1 == (Namep) NULL || v1 -> tag != TNAME ||
-		v2 == (Namep) NULL || v2 -> tag != TNAME)
-	    return NO;
-
-	if (v1->vtype != v2->vtype || v1->vclass != v2->vclass
-		|| strcmp(v1->fvarname, v2->fvarname))
-	    return NO;
-
-	/* compare dimensions (needed for comparing COMMON blocks) */
-
-	if (d1 = v1->vdim) {
-		if (!(cp1 = (Constp)d1->nelt) || cp1->tag != TCONST)
-			return NO;
-		if (!(d2 = v2->vdim))
-			if (cp1->Const.ci == 1)
-				continue;
-			else
-				return NO;
-		if (!(cp2 = (Constp)d2->nelt) || cp2->tag != TCONST
-		||  cp1->Const.ci != cp2->Const.ci)
-			return NO;
-		}
-	else if ((d2 = v2->vdim) && (!(cp2 = (Constp)d2->nelt)
-				|| cp2->tag != TCONST
-				|| cp2->Const.ci != 1))
-		return NO;
-    } /* while s1 != CHNULL && s2 != CHNULL */
-
-    return s1 == CHNULL && s2 == CHNULL;
-} /* struct_eq */
//GO.SYSIN DD misc.c
echo names.c 1>&2
sed >names.c <<'//GO.SYSIN DD names.c' 's/^-//'
-/****************************************************************
-Copyright 1990, 1992 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.
-****************************************************************/
-
-#include "defs.h"
-#include "output.h"
-#include "names.h"
-#include "iob.h"
-
-
-/* Names generated by the translator are guaranteed to be unique from the
-   Fortan names because Fortran does not allow underscores in identifiers,
-   and all of the system generated names do have underscores.  The various
-   naming conventions are outlined below:
-
-	FORMAT		APPLICATION
-   ----------------------------------------------------------------------
-	io_#		temporaries generated by IO calls; these will
-			contain the device number (e.g. 5, 6, 0)
-	ret_val		function return value, required for complex and
-			character functions.
-	ret_val_len	length of the return value in character functions
-
-	ssss_len	length of character argument "ssss"
-
-	c_#		member of the literal pool, where # is an
-			arbitrary label assigned by the system
-	cs_#		short integer constant in the literal pool
-	t_#		expression temporary, # is the depth of arguments
-			on the stack.
-	L#		label "#", given by user in the Fortran program.
-			This is unique because Fortran labels are numeric
-	pad_#		label on an init field required for alignment
-	xxx_init	label on a common block union, if a block data
-			requires a separate declaration
-*/
-
-/* generate variable references */
-
-char *c_type_decl (type, is_extern)
-int type, is_extern;
-{
-    static char buff[100];
-
-    switch (type) {
-	case TYADDR:	strcpy (buff, "address");	break;
-	case TYSHORT:	strcpy (buff, "shortint");	break;
-	case TYLONG:	strcpy (buff, "integer");	break;
-	case TYREAL:	if (!is_extern || !forcedouble)
-				{ strcpy (buff, "real");break; }
-	case TYDREAL:	strcpy (buff, "doublereal");	break;
-	case TYCOMPLEX:	if (is_extern)
-			    strcpy (buff, Ansi	? "/* Complex */ VOID"
-						: "/* Complex */ int");
-			else
-			    strcpy (buff, "complex");
-			break;
-	case TYDCOMPLEX:if (is_extern)
-			    strcpy (buff, Ansi	? "/* Double Complex */ VOID"
-						: "/* Double Complex */ int");
-			else
-			    strcpy (buff, "doublecomplex");
-			break;
-	case TYLOGICAL:	strcpy(buff, typename[TYLOGICAL]);
-			break;
-	case TYCHAR:	if (is_extern)
-			    strcpy (buff, Ansi	? "/* Character */ VOID"
-						: "/* Character */ int");
-			else
-			    strcpy (buff, "char");
-			break;
-
-        case TYUNKNOWN:	strcpy (buff, "UNKNOWN");
-
-/* If a procedure's type is unknown, assume it's a subroutine */
-
-			if (!is_extern)
-			    break;
-
-/* Subroutines must return an INT, because they might return a label
-   value.  Even if one doesn't, the caller will EXPECT it to. */
-
-	case TYSUBR:	strcpy (buff, "/* Subroutine */ int");
-							break;
-	case TYERROR:	strcpy (buff, "ERROR");		break;
-	case TYVOID:	strcpy (buff, "void");		break;
-	case TYCILIST:	strcpy (buff, "cilist");	break;
-	case TYICILIST:	strcpy (buff, "icilist");	break;
-	case TYOLIST:	strcpy (buff, "olist");		break;
-	case TYCLLIST:	strcpy (buff, "cllist");	break;
-	case TYALIST:	strcpy (buff, "alist");		break;
-	case TYINLIST:	strcpy (buff, "inlist");	break;
-	case TYFTNLEN:	strcpy (buff, "ftnlen");	break;
-	default:	sprintf (buff, "BAD DECL '%d'", type);
-							break;
-    } /* switch */
-
-    return buff;
-} /* c_type_decl */
-
-
-char *new_func_length()
-{ return "ret_val_len"; }
-
-char *new_arg_length(arg)
- Namep arg;
-{
-	static char buf[64];
-	sprintf (buf, "%s_len", arg->fvarname);
-
-	return buf;
-} /* new_arg_length */
-
-
-/* declare_new_addr -- Add a new local variable to the function, given a
-   pointer to an Addrblock structure (which must have the uname_tag set)
-   This list of idents will be printed in reverse (i.e., chronological)
-   order */
-
- void
-declare_new_addr (addrp)
-struct Addrblock *addrp;
-{
-    extern chainp new_vars;
-
-    new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars);
-} /* declare_new_addr */
-
-
-wr_nv_ident_help (outfile, addrp)
-FILE *outfile;
-struct Addrblock *addrp;
-{
-    int eltcount = 0;
-
-    if (addrp == (struct Addrblock *) NULL)
-	return;
-
-    if (addrp -> isarray) {
-	frexpr (addrp -> memoffset);
-	addrp -> memoffset = ICON(0);
-	eltcount = addrp -> ntempelt;
-	addrp -> ntempelt = 0;
-	addrp -> isarray = 0;
-    } /* if */
-    out_addr (outfile, addrp);
-    if (eltcount)
-	nice_printf (outfile, "[%d]", eltcount);
-} /* wr_nv_ident_help */
-
-int nv_type_help (addrp)
-struct Addrblock *addrp;
-{
-    if (addrp == (struct Addrblock *) NULL)
-	return -1;
-
-    return addrp -> vtype;
-} /* nv_type_help */
-
-
-/* lit_name -- returns a unique identifier for the given literal.  Make
-   the label useful, when possible.  For example:
-
-	1 -> c_1		(constant 1)
-	2 -> c_2		(constant 2)
-	1000 -> c_1000		(constant 1000)
-	1000000 -> c_b<memno>	(big constant number)
-	1.2 -> c_1_2		(constant 1.2)
-	1.234345 -> c_b<memno>	(big constant number)
-	-1 -> c_n1		(constant -1)
-	-1.0 -> c_n1_0		(constant -1.0)
-	.true. -> c_true	(constant true)
-	.false. -> c_false	(constant false)
-	default -> c_b<memno>	(default label)
-*/
-
-char *lit_name (litp)
-struct Literal *litp;
-{
-    static char buf[CONST_IDENT_MAX];
-
-    if (litp == (struct Literal *) NULL)
-	return NULL;
-
-    switch (litp -> littype) {
-        case TYSHORT:
-	    if (litp -> litval.litival < 32768 &&
-		    litp -> litval.litival > -32769) {
-		ftnint val = litp -> litval.litival;
-
-		if (val < 0)
-		    sprintf (buf, "cs_n%ld", -val);
-		else
-		    sprintf (buf, "cs__%ld", val);
-	    } else
-		sprintf (buf, "c_b%d", litp -> litnum);
-	    break;
-	case TYLONG:
-	    if (litp -> litval.litival < 100000 &&
-		    litp -> litval.litival > -10000) {
-		ftnint val = litp -> litval.litival;
-
-		if (val < 0)
-		    sprintf (buf, "c_n%ld", -val);
-		else
-		    sprintf (buf, "c__%ld", val);
-	    } else
-		sprintf (buf, "c_b%d", litp -> litnum);
-	    break;
-	case TYLOGICAL:
-	    sprintf (buf, "c_%s", (litp -> litval.litival ? "true" : "false"));
-	    break;
-	case TYREAL:
-	case TYDREAL:
-		/* Given a limit of 6 or 8 character on external names,	*/
-		/* few f.p. values can be meaningfully encoded in the	*/
-		/* constant name.  Just going with the default cb_#	*/
-		/* seems to be the best course for floating-point	*/
-		/* constants.	*/
-	case TYCHAR:
-	    /* Shouldn't be any of these */
-	case TYADDR:
-	case TYCOMPLEX:
-	case TYDCOMPLEX:
-	case TYSUBR:
-	default:
-	    sprintf (buf, "c_b%d", litp -> litnum);
-	    break;
-    } /* switch */
-    return buf;
-} /* lit_name */
-
-
-
- char *
-comm_union_name(count)
- int count;
-{
-	static char buf[12];
-
-	sprintf(buf, "%d", count);
-	return buf;
-	}
-
-
-
-
-/* wr_globals -- after every function has been translated, we need to
-   output the global declarations, such as the static table of constant
-   values */
-
-wr_globals (outfile)
-FILE *outfile;
-{
-    struct Literal *litp, *lastlit;
-    extern int hsize;
-    extern char *lit_name();
-    char *litname;
-    int did_one, t;
-    struct Constblock cb;
-    ftnint x, y;
-
-    if (nliterals == 0)
-	return;
-
-    lastlit = litpool + nliterals;
-    did_one = 0;
-    for (litp = litpool; litp < lastlit; litp++) {
-	if (!litp->lituse)
-		continue;
-	litname = lit_name(litp);
-	if (!did_one) {
-		margin_printf(outfile, "/* Table of constant values */\n\n");
-		did_one = 1;
-		}
-	cb.vtype = litp->littype;
-	if (litp->littype == TYCHAR) {
-		x = litp->litval.litival2[0] + litp->litval.litival2[1];
-		y = x + 1;
-		nice_printf(outfile,
-			"static struct { %s fill; char val[%ld+1];", halign, x);
-		if (y %= hsize)
-			nice_printf(outfile, " char fill2[%ld];", hsize - y);
-		nice_printf(outfile, " } %s_st = { 0,", litname);
-		cb.vleng = ICON(litp->litval.litival2[0]);
-		cb.Const.ccp = litp->cds[0];
-		cb.Const.ccp1.blanks = litp->litval.litival2[1];
-		cb.vtype = TYCHAR;
-		out_const(outfile, &cb);
-		frexpr(cb.vleng);
-		nice_printf(outfile, " };\n");
-		nice_printf(outfile, "#define %s %s_st.val\n", litname, litname);
-		continue;
-		}
-	nice_printf(outfile, "static %s %s = ",
-		c_type_decl(litp->littype,0), litname);
-
-	t = litp->littype;
-	if (ONEOF(t, MSKREAL|MSKCOMPLEX)) {
-		cb.vstg = 1;
-		cb.Const.cds[0] = litp->cds[0];
-		cb.Const.cds[1] = litp->cds[1];
-		}
-	else {
-		memcpy((char *)&cb.Const, (char *)&litp->litval,
-			sizeof(cb.Const));
-		cb.vstg = 0;
-		}
-	out_const(outfile, &cb);
-
-	nice_printf (outfile, ";\n");
-    } /* for */
-    if (did_one)
-    	nice_printf (outfile, "\n");
-} /* wr_globals */
-
- ftnint
-commlen(vl)
- register chainp vl;
-{
-	ftnint size;
-	int type;
-	struct Dimblock *t;
-	Namep v;
-
-	while(vl->nextp)
-		vl = vl->nextp;
-	v = (Namep)vl->datap;
-	type = v->vtype;
-	if (type == TYCHAR)
-		size = v->vleng->constblock.Const.ci;
-	else
-		size = typesize[type];
-	if ((t = v->vdim) && ISCONST(t->nelt))
-		size *= t->nelt->constblock.Const.ci;
-	return size + v->voffset;
-	}
-
- static void	/* Pad common block if an EQUIVALENCE extended it. */
-pad_common(c)
- Extsym *c;
-{
-	register chainp cvl;
-	register Namep v;
-	long L = c->maxleng;
-	int type;
-	struct Dimblock *t;
-	int szshort = typesize[TYSHORT];
-
-	for(cvl = c->allextp; cvl; cvl = cvl->nextp)
-		if (commlen((chainp)cvl->datap) >= L)
-			return;
-	v = ALLOC(Nameblock);
-	v->vtype = type = L % szshort ? TYCHAR
-				      : type_choice[L/szshort % 4];
-	v->vstg = STGCOMMON;
-	v->vclass = CLVAR;
-	v->tag = TNAME;
-	v->vdim = t = ALLOC(Dimblock);
-	t->ndim = 1;
-	t->dims[0].dimsize = ICON(L / typesize[type]);
-	v->fvarname = v->cvarname = "eqv_pad";
-	c->allextp = mkchain((char *)mkchain((char *)v, CHNULL), c->allextp);
-	}
-
-
-/* wr_common_decls -- outputs the common declarations in one of three
-   formats.  If all references to a common block look the same (field
-   names and types agree), only one actual declaration will appear.
-   Otherwise, the same block will require many structs.  If there is no
-   block data, these structs will be union'ed together (so the linker
-   knows the size of the largest one).  If there IS a block data, only
-   that version will be associated with the variable, others will only be
-   defined as types, so the pointer can be cast to it.  e.g.
-
-	FORTRAN				C
-----------------------------------------------------------------------
-	common /com1/ a, b, c		struct { real a, b, c; } com1_;
-
-	common /com1/ a, b, c		union {
-	common /com1/ i, j, k		    struct { real a, b, c; } _1;
-					    struct { integer i, j, k; } _2;
-					} com1_;
-
-	common /com1/ a, b, c		struct com1_1_ { real a, b, c; };
-	block data			struct { integer i, j, k; } com1_ =
-	common /com1/ i, j, k		  { 1, 2, 3 };
-	data i/1/, j/2/, k/3/
-
-
-   All of these versions will be followed by #defines, since the code in
-   the function bodies can't know ahead of time which of these options
-   will be taken */
-
-/* Macros for deciding the output type */
-
-#define ONE_STRUCT 1
-#define UNION_STRUCT 2
-#define INIT_STRUCT 3
-
-wr_common_decls(outfile)
- FILE *outfile;
-{
-    Extsym *ext;
-    extern int extcomm;
-    static char *Extern[4] = {"", "Extern ", "extern "};
-    char *E, *E0 = Extern[extcomm];
-    int did_one = 0;
-
-    for (ext = extsymtab; ext < nextext; ext++) {
-	if (ext -> extstg == STGCOMMON && ext->allextp) {
-	    chainp comm;
-	    int count = 1;
-	    int which;			/* which display to use;
-					   ONE_STRUCT, UNION or INIT */
-
-	    if (!did_one)
-		nice_printf (outfile, "/* Common Block Declarations */\n\n");
-
-	    pad_common(ext);
-
-/* Construct the proper, condensed list of structs; eliminate duplicates
-   from the initial list   ext -> allextp   */
-
-	    comm = ext->allextp = revchain(ext->allextp);
-
-	    if (ext -> extinit)
-		which = INIT_STRUCT;
-	    else if (comm->nextp) {
-		which = UNION_STRUCT;
-		nice_printf (outfile, "%sunion {\n", E0);
-		next_tab (outfile);
-		E = "";
-		}
-	    else {
-		which = ONE_STRUCT;
-		E = E0;
-		}
-
-	    for (; comm; comm = comm -> nextp, count++) {
-
-		if (which == INIT_STRUCT)
-		    nice_printf (outfile, "struct %s%d_ {\n",
-			    ext->cextname, count);
-		else
-		    nice_printf (outfile, "%sstruct {\n", E);
-
-		next_tab (c_file);
-
-		wr_struct (outfile, (chainp) comm -> datap);
-
-		prev_tab (c_file);
-		if (which == UNION_STRUCT)
-		    nice_printf (outfile, "} _%d;\n", count);
-		else if (which == ONE_STRUCT)
-		    nice_printf (outfile, "} %s;\n", ext->cextname);
-		else
-		    nice_printf (outfile, "};\n");
-	    } /* for */
-
-	    if (which == UNION_STRUCT) {
-		prev_tab (c_file);
-		nice_printf (outfile, "} %s;\n", ext->cextname);
-	    } /* if */
-	    did_one = 1;
-	    nice_printf (outfile, "\n");
-
-	    for (count = 1, comm = ext -> allextp; comm;
-		    comm = comm -> nextp, count++) {
-		def_start(outfile, ext->cextname,
-			comm_union_name(count), "");
-		switch (which) {
-		    case ONE_STRUCT:
-		        extern_out (outfile, ext);
-		        break;
-		    case UNION_STRUCT:
-		        nice_printf (outfile, "(");
-			extern_out (outfile, ext);
-			nice_printf(outfile, "._%d)", count);
-		        break;
-		    case INIT_STRUCT:
-			nice_printf (outfile, "(*(struct ");
-			extern_out (outfile, ext);
-			nice_printf (outfile, "%d_ *) &", count);
-			extern_out (outfile, ext);
-			nice_printf (outfile, ")");
-		        break;
-		} /* switch */
-		nice_printf (outfile, "\n");
-	    } /* for count = 1, comm = ext -> allextp */
-	    nice_printf (outfile, "\n");
-	} /* if ext -> extstg == STGCOMMON */
-    } /* for ext = extsymtab */
-} /* wr_common_decls */
-
-
-wr_struct (outfile, var_list)
-FILE *outfile;
-chainp var_list;
-{
-    int last_type = -1;
-    int did_one = 0;
-    chainp this_var;
-
-    for (this_var = var_list; this_var; this_var = this_var -> nextp) {
-	Namep var = (Namep) this_var -> datap;
-	int type;
-	char *comment = NULL, *wr_ardecls ();
-
-	if (var == (Namep) NULL)
-	    err ("wr_struct:  null variable");
-	else if (var -> tag != TNAME)
-	    erri ("wr_struct:  bad tag on variable '%d'",
-		    var -> tag);
-
-	type = var -> vtype;
-
-	if (last_type == type && did_one)
-	    nice_printf (outfile, ", ");
-	else {
-	    if (did_one)
-		nice_printf (outfile, ";\n");
-	    nice_printf (outfile, "%s ",
-		    c_type_decl (type, var -> vclass == CLPROC));
-	} /* else */
-
-/* Character type is really a string type.  Put out a '*' for parameters
-   with unknown length and functions returning character */
-
-	if (var -> vtype == TYCHAR && (!ISICON ((var -> vleng))
-		|| var -> vclass == CLPROC))
-	    nice_printf (outfile, "*");
-
-	var -> vstg = STGAUTO;
-	out_name (outfile, var);
-	if (var -> vclass == CLPROC)
-	    nice_printf (outfile, "()");
-	else if (var -> vdim)
-	    comment = wr_ardecls(outfile, var->vdim,
-				var->vtype == TYCHAR && ISICON(var->vleng)
-				? var->vleng->constblock.Const.ci : 1L);
-	else if (var -> vtype == TYCHAR && var -> vclass != CLPROC &&
-	    ISICON ((var -> vleng)))
-	    nice_printf (outfile, "[%ld]",
-		    var -> vleng -> constblock.Const.ci);
-
-	if (comment)
-	    nice_printf (outfile, "%s", comment);
-	did_one = 1;
-	last_type = type;
-    } /* for this_var */
-
-    if (did_one)
-	nice_printf (outfile, ";\n");
-} /* wr_struct */
-
-
-char *user_label(stateno)
-ftnint stateno;
-{
-	static char buf[USER_LABEL_MAX + 1];
-	static char *Lfmt[2] = { "L_%ld", "L%ld" };
-
-	if (stateno >= 0)
-		sprintf(buf, Lfmt[shiftcase], stateno);
-	else
-		sprintf(buf, "L_%s", extsymtab[-1-stateno].fextname);
-	return buf;
-} /* user_label */
-
-
-char *temp_name (starter, num, storage)
-char *starter;
-int num;
-char *storage;
-{
-    static char buf[IDENT_LEN];
-    char *pointer = buf;
-    char *prefix = "t";
-
-    if (storage)
-	pointer = storage;
-
-    if (starter && *starter)
-	prefix = starter;
-
-    sprintf (pointer, "%s__%d", prefix, num);
-    return pointer;
-} /* temp_name */
-
-
-char *equiv_name (memno, store)
-int memno;
-char *store;
-{
-    static char buf[IDENT_LEN];
-    char *pointer = buf;
-
-    if (store)
-	pointer = store;
-
-    sprintf (pointer, "%s_%d", EQUIV_INIT_NAME, memno);
-    return pointer;
-} /* equiv_name */
-
- void
-def_commons(of)
- FILE *of;
-{
-	Extsym *ext;
-	int c, onefile, Union;
-	char buf[64];
-	chainp comm;
-	extern int ext1comm;
-	FILE *c_filesave = c_file;
-
-	if (ext1comm == 1) {
-		onefile = 1;
-		c_file = of;
-		fprintf(of, "/*>>>'/dev/null'<<<*/\n\
-#ifdef Define_COMMONs\n\
-/*<<</dev/null>>>*/\n");
-		}
-	else
-		onefile = 0;
-	for(ext = extsymtab; ext < nextext; ext++)
-		if (ext->extstg == STGCOMMON
-		&& !ext->extinit && (comm = ext->allextp)) {
-			sprintf(buf, "%scom.c", ext->cextname);
-			if (onefile)
-				fprintf(of, "/*>>>'%s'<<<*/\n",
-					buf);
-			else {
-				c_file = of = fopen(buf,textwrite);
-				if (!of)
-					fatalstr("can't open %s", buf);
-				}
-			fprintf(of, "#include \"f2c.h\"\n");
-			if (comm->nextp) {
-				Union = 1;
-				nice_printf(of, "union {\n");
-				next_tab(of);
-				}
-			else
-				Union = 0;
-			for(c = 1; comm; comm = comm->nextp) {
-				nice_printf(of, "struct {\n");
-				next_tab(of);
-				wr_struct(of, (chainp)comm->datap);
-				prev_tab(of);
-				if (Union)
-					nice_printf(of, "} _%d;\n", c++);
-				}
-			if (Union)
-				prev_tab(of);
-			nice_printf(of, "} %s;\n", ext->cextname);
-			if (onefile)
-				fprintf(of, "/*<<<%s>>>*/\n", buf);
-			else
-				fclose(of);
-			}
-	if (onefile)
-		fprintf(of, "/*>>>'/dev/null'<<<*/\n#endif\n\
-/*<<</dev/null>>>*/\n");
-	c_file = c_filesave;
-	}
-
-/* C Language keywords.  Needed to filter unwanted fortran identifiers like
- * "int", etc.  Source:  Kernighan & Ritchie, eds. 1 and 2; Stroustrup.
- * Also includes C++ keywords and types used for I/O in f2c.h .
- * These keywords must be in alphabetical order (as defined by strcmp()).
- */
-
-char *c_keywords[] = {
-	"Long", "Multitype", "Namelist", "Vardesc",
-	"abs", "acos", "address", "alist", "asin", "asm",
-	"atan", "atan2", "auto", "break",
-	"case", "catch", "char", "cilist", "class", "cllist",
-	"complex", "const", "continue", "cos", "cosh",
-	"dabs", "default", "defined", "delete",
-	"dmax", "dmin", "do", "double", "doublecomplex", "doublereal",
-	"else", "entry", "enum", "exp", "extern",
-	"flag", "float", "for", "friend", "ftnint", "ftnlen", "goto",
-	"icilist", "if", "include", "inline", "inlist", "int", "integer",
-	"log", "logical", "long", "max", "min", "new",
-	"olist", "operator", "overload", "private", "protected", "public",
-	"real", "register", "return",
-	"short", "shortint", "shortlogical", "signed", "sin", "sinh",
-	"sizeof", "sqrt", "static", "struct", "switch",
-	"tan", "tanh", "template", "this", "try", "typedef",
-	"union", "unsigned", "virtual", "void", "volatile", "while"
-}; /* c_keywords */
-
-int n_keywords = sizeof(c_keywords)/sizeof(char *);
//GO.SYSIN DD names.c
echo names.h 1>&2
sed >names.h <<'//GO.SYSIN DD names.h' 's/^-//'
-#define CONST_IDENT_MAX 30
-#define IO_IDENT_MAX 30
-#define ARGUMENT_MAX 30
-#define USER_LABEL_MAX 30
-
-#define EQUIV_INIT_NAME "equiv"
-
-#define write_nv_ident(fp,a) wr_nv_ident_help ((fp), (struct Addrblock *) (a))
-#define nv_type(x) nv_type_help ((struct Addrblock *) x)
-
-extern char *c_keywords[];
-
-char *new_io_ident (/* char * */);
-char *new_func_length (/* char * */);
-char *new_arg_length (/* Namep */);
-void declare_new_addr (/* struct Addrblock * */);
-char *nv_ident_help (/* struct Addrblock * */);
-int nv_type_help (/* struct Addrblock */);
-char *user_label (/* int */);
-char *temp_name (/* int, char */);
-char *c_type_decl (/* int, int */);
-char *equiv_name (/* int, char * */);
//GO.SYSIN DD names.h
echo niceprintf.c 1>&2
sed >niceprintf.c <<'//GO.SYSIN DD niceprintf.c' 's/^-//'
-/****************************************************************
-Copyright 1990, 1991 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.
-****************************************************************/
-
-#include "defs.h"
-#include "names.h"
-#include "output.h"
-
-#define TOO_LONG_INDENT (2 * tab_size)
-#define MAX_INDENT 44
-#define MIN_INDENT 22
-static int last_was_newline = 0;
-int indent = 0;
-int in_comment = 0;
- extern int gflag1;
- extern char *file_name;
-
- static int
-write_indent(fp, use_indent, extra_indent, start, end)
- FILE *fp;
- int use_indent, extra_indent;
- char *start, *end;
-{
-    int ind, tab;
-
-    if (gflag1 && last_was_newline)
-	fprintf(fp, "#line %ld \"%s\"\n", lineno, file_name);
-    if (last_was_newline && use_indent) {
-	if (*start == '\n') do {
-		putc('\n', fp);
-		if (++start > end)
-			return;
-		}
-		while(*start == '\n');
-
-	ind = indent <= MAX_INDENT
-		? indent
-		: MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT);
-
-	tab = ind + extra_indent;
-
-	while (tab > 7) {
-	    putc ('\t', fp);
-	    tab -= 8;
-	} /* while */
-
-	while (tab-- > 0)
-	    putc (' ', fp);
-    } /* if last_was_newline */
-
-    while (start <= end)
-	putc (*start++, fp);
-} /* write_indent */
-
-
-/*VARARGS2*/
-int margin_printf (fp, a, b, c, d, e, f, g)
-FILE *fp;
-char *a;
-long b, c, d, e, f, g;
-{
-    ind_printf (0, fp, a, b, c, d, e, f, g);
-} /* margin_printf */
-
-/*VARARGS2*/
-int nice_printf (fp, a, b, c, d, e, f, g)
-FILE *fp;
-char *a;
-long b, c, d, e, f, g;
-{
-    ind_printf (1, fp, a, b, c, d, e, f, g);
-} /* nice_printf */
-
-
-#define  max_line_len c_output_line_length
- 		/* 74Number of characters allowed on an output
-			           line.  This assumes newlines are handled
-			           nicely, i.e. a newline after a full text
-			           line on a terminal is ignored */
-
-/* output_buf   holds the text of the next line to be printed.  It gets
-   flushed when a newline is printed.   next_slot   points to the next
-   available location in the output buffer, i.e. where the next call to
-   nice_printf will have its output stored */
-
-static char *output_buf;
-static char *next_slot;
-static char *string_start;
-
-static char *word_start = NULL;
-static int cursor_pos = 0;
-static int In_string = 0;
-
- void
-np_init()
-{
-	next_slot = output_buf = Alloc(MAX_OUTPUT_SIZE);
-	memset(output_buf, 0, MAX_OUTPUT_SIZE);
-	}
-
- static char *
-adjust_pointer_in_string(pointer)
- register char *pointer;
-{
-	register char *s, *s1, *se, *s0;
-
-	/* arrange not to break \002 */
-	s1 = string_start ? string_start : output_buf;
-	for(s = s1; s < pointer; s++) {
-		s0 = s1;
-		s1 = s;
-		if (*s == '\\') {
-			se = s++ + 4;
-			if (se > pointer)
-				break;
-			if (*s < '0' || *s > '7')
-				continue;
-			while(++s < se)
-				if (*s < '0' || *s > '7')
-					break;
-			--s;
-			}
-		}
-	return s0 - 1;
-	}
-
-/* ANSI says strcpy's behavior is undefined for overlapping args,
- * so we roll our own fwd_strcpy: */
-
- static void
-fwd_strcpy(t, s)
- register char *t, *s;
-{ while(*t++ = *s++); }
-
-/* isident -- true iff character could belong to a unit.  C allows
-   letters, numbers and underscores in identifiers.  This also doubles as
-   a check for numeric constants, since we include the decimal point and
-   minus sign.  The minus has to be here, since the constant "10e-2"
-   cannot be broken up.  The '.' also prevents structure references from
-   being broken, which is a quite acceptable side effect */
-
-#define isident(x) (Tr[x] & 1)
-#define isntident(x) (!Tr[x])
-
-int ind_printf (use_indent, fp, a, b, c, d, e, f, g)
-int use_indent;
-FILE *fp;
-char *a;
-long b, c, d, e, f, g;
-{
-    extern int max_line_len;
-    extern FILEP c_file;
-    extern char tr_tab[];	/* in output.c */
-    register char *Tr = tr_tab;
-    int ch, inc, ind;
-    static int extra_indent, last_indent, set_cursor = 1;
-
-    cursor_pos += indent - last_indent;
-    last_indent = indent;
-    sprintf (next_slot, a, b, c, d, e, f, g);
-
-    if (fp != c_file) {
-	fprintf (fp,"%s", next_slot);
-	return 1;
-    } /* if fp != c_file */
-
-    do {
-	char *pointer;
-
-/* The   for   loop will parse one output line */
-
-	if (set_cursor) {
-		ind = indent <= MAX_INDENT
-			? indent
-			: MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT);
-		cursor_pos = ind + extra_indent;
-		set_cursor = 0;
-		}
-	if (in_comment)
-        	for (pointer = next_slot; *pointer && *pointer != '\n' &&
-				cursor_pos <= max_line_len; pointer++)
-			cursor_pos++;
-	else
-          for (pointer = next_slot; *pointer && *pointer != '\n' &&
-		cursor_pos <= max_line_len; pointer++) {
-
-	    /* Update state variables here */
-
-	    if (In_string) {
-		switch(*pointer) {
-			case '\\':
-				if (++cursor_pos > max_line_len) {
-					cursor_pos -= 2;
-					--pointer;
-					goto overflow;
-					}
-				++pointer;
-				break;
-			case '"':
-				In_string = 0;
-				word_start = 0;
-			}
-		}
-	    else switch (*pointer) {
-	        case '"':
-			if (cursor_pos + 5 > max_line_len) {
-				word_start = 0;
-				--pointer;
-				goto overflow;
-				}
-			In_string = 1;
-			string_start = word_start = pointer;
-		    	break;
-	        case '\'':
-			if (pointer[1] == '\\')
-				if ((ch = pointer[2]) >= '0' && ch <= '7')
-					for(inc = 3; pointer[inc] != '\''
-						&& ++inc < 5;);
-				else
-					inc = 3;
-			else
-				inc = 2;
-			/*debug*/ if (pointer[inc] != '\'')
-			/*debug*/  fatalstr("Bad character constant %.10s",
-					pointer);
-			if ((cursor_pos += inc) > max_line_len) {
-				cursor_pos -= inc;
-				word_start = 0;
-				--pointer;
-				goto overflow;
-				}
-			word_start = pointer;
-			pointer += inc;
-			break;
-		case '\t':
-		    cursor_pos = 8 * ((cursor_pos + 8) / 8) - 1;
-		    break;
-		default: {
-
-/* HACK  Assumes that all characters in an atomic C token will be written
-   at the same time.  Must check for tokens first, since '-' is considered
-   part of an identifier; checking isident first would mean breaking up "->" */
-
-		    if (!word_start && isident(*(unsigned char *)pointer))
-			word_start = pointer;
-		    else if (word_start && isntident(*(unsigned char *)pointer))
-			word_start = NULL;
-		    break;
-		} /* default */
-	    } /* switch */
-	    cursor_pos++;
-	} /* for pointer = next_slot */
- overflow:
-	if (*pointer == '\0') {
-
-/* The output line is not complete, so break out and don't output
-   anything.  The current line fragment will be stored in the buffer */
-
-	    next_slot = pointer;
-	    break;
-	} else {
-	    char last_char;
-	    int in_string0 = In_string;
-
-/* If the line was too long, move   pointer   back to the character before
-   the current word.  This allows line breaking on word boundaries.  Make
-   sure that 80 character comment lines get broken up somehow.  We assume
-   that any non-string 80 character identifier must be in a comment.
-*/
-
-	    if (word_start && *pointer != '\n' && word_start > output_buf)
-		if (In_string)
-			if (string_start && pointer - string_start < 5)
-				pointer = string_start - 1;
-			else {
-				pointer = adjust_pointer_in_string(pointer);
-				string_start = 0;
-				}
-		else if (word_start == string_start
-				&& pointer - string_start >= 5) {
-			pointer = adjust_pointer_in_string(next_slot);
-			In_string = 1;
-			string_start = 0;
-			}
-		else
-			pointer = word_start - 1;
-	    else if (cursor_pos > max_line_len) {
-		extern char *strchr();
-		if (In_string) {
-			pointer = adjust_pointer_in_string(pointer);
-			if (string_start && pointer > string_start)
-				string_start = 0;
-			}
-		else if (strchr("&*+-/<=>|", *pointer)
-			&& strchr("!%&*+-/<=>^|", pointer[-1])) {
-			pointer -= 2;
-			if (strchr("<>", *pointer)) /* <<=, >>= */
-				pointer--;
-			}
-		else
-			pointer--;
-		}
-	    last_char = *pointer;
-	    write_indent(fp, use_indent, extra_indent, output_buf, pointer);
-	    next_slot = output_buf;
-	    if (In_string && !string_start && Ansi == 1 && last_char != '\n')
-		*next_slot++ = '"';
-	    fwd_strcpy(next_slot, pointer + 1);
-
-/* insert a line break */
-
-	    if (last_char == '\n') {
-		if (In_string)
-			last_was_newline = 0;
-		else {
-			last_was_newline = 1;
-			extra_indent = 0;
-			}
-		}
-	    else {
-		extra_indent = TOO_LONG_INDENT;
-		if (In_string && !string_start) {
-			if (Ansi == 1) {
-				fprintf(fp, "\"\n");
-				use_indent = 1;
-				last_was_newline = 1;
-				}
-			else {
-				fprintf(fp, "\\\n");
-				last_was_newline = 0;
-				}
-			In_string = in_string0;
-			}
-		else {
-			putc ('\n', fp);
-			last_was_newline = 1;
-			}
-	    } /* if *pointer != '\n' */
-
-	    if (In_string && Ansi != 1 && !string_start)
-		cursor_pos = 0;
-	    else
-		set_cursor = 1;
-
-	    string_start = word_start = NULL;
-
-	} /* else */
-
-    } while (*next_slot);
-
-    return 0;
-} /* ind_printf */
//GO.SYSIN DD niceprintf.c
echo niceprintf.h 1>&2
sed >niceprintf.h <<'//GO.SYSIN DD niceprintf.h' 's/^-//'
-/* niceprintf.h -- contains constants and macros from the output filter
-   for the generated C code.  We use macros for increased speed, less
-   function overhead.  */
-
-#define MAX_OUTPUT_SIZE 6000	/* Number of chars on one output line PLUS
-				   the length of the longest string
-				   printed using   nice_printf   */
-
-
-
-#define next_tab(fp) (indent += tab_size)
-
-#define prev_tab(fp) (indent -= tab_size)
-
-
-
//GO.SYSIN DD niceprintf.h
echo output.c 1>&2
sed >output.c <<'//GO.SYSIN DD output.c' 's/^-//'
-/****************************************************************
-Copyright 1990, 1991 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.
-****************************************************************/
-
-#include "defs.h"
-#include "names.h"
-#include "output.h"
-
-#ifndef TRUE
-#define TRUE 1
-#endif
-#ifndef FALSE
-#define FALSE 0
-#endif
-
-char _assoc_table[] = { 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 };
-
-/* Opcode table -- This array is indexed by the OP_____ macros defined in
-   defines.h; these macros are expected to be adjacent integers, so that
-   this table is as small as possible. */
-
-table_entry opcode_table[] = {
-				{ 0, 0, NULL },
-	/* OPPLUS 1 */		{ BINARY_OP, 12, "%l + %r" },
-	/* OPMINUS 2 */		{ BINARY_OP, 12, "%l - %r" },
-	/* OPSTAR 3 */		{ BINARY_OP, 13, "%l * %r" },
-	/* OPSLASH 4 */		{ BINARY_OP, 13, "%l / %r" },
-	/* OPPOWER 5 */		{ BINARY_OP,  0, "power (%l, %r)" },
-	/* OPNEG 6 */		{ UNARY_OP,  14, "-%l" },
-	/* OPOR 7 */		{ BINARY_OP,  4, "%l || %r" },
-	/* OPAND 8 */		{ BINARY_OP,  5, "%l && %r" },
-	/* OPEQV 9 */		{ BINARY_OP,  9, "%l == %r" },
-	/* OPNEQV 10 */		{ BINARY_OP,  9, "%l != %r" },
-	/* OPNOT 11 */		{ UNARY_OP,  14, "! %l" },
-	/* OPCONCAT 12 */	{ BINARY_OP,  0, "concat (%l, %r)" },
-	/* OPLT 13 */		{ BINARY_OP, 10, "%l < %r" },
-	/* OPEQ 14 */		{ BINARY_OP,  9, "%l == %r" },
-	/* OPGT 15 */		{ BINARY_OP, 10, "%l > %r" },
-	/* OPLE 16 */		{ BINARY_OP, 10, "%l <= %r" },
-	/* OPNE 17 */		{ BINARY_OP,  9, "%l != %r" },
-	/* OPGE 18 */		{ BINARY_OP, 10, "%l >= %r" },
-	/* OPCALL 19 */		{ BINARY_OP, 15, SPECIAL_FMT },
-	/* OPCCALL 20 */	{ BINARY_OP, 15, SPECIAL_FMT },
-
-/* Left hand side of an assignment cannot have outermost parens */
-
-	/* OPASSIGN 21 */	{ BINARY_OP,  2, "%l = %r" },
-	/* OPPLUSEQ 22 */	{ BINARY_OP,  2, "%l += %r" },
-	/* OPSTAREQ 23 */	{ BINARY_OP,  2, "%l *= %r" },
-	/* OPCONV 24 */		{ BINARY_OP, 14, "%l" },
-	/* OPLSHIFT 25 */	{ BINARY_OP, 11, "%l << %r" },
-	/* OPMOD 26 */		{ BINARY_OP, 13, "%l %% %r" },
-	/* OPCOMMA 27 */	{ BINARY_OP,  1, "%l, %r" },
-
-/* Don't want to nest the colon operator in parens */
-
-	/* OPQUEST 28 */	{ BINARY_OP, 3, "%l ? %r" },
-	/* OPCOLON 29 */	{ BINARY_OP, 3, "%l : %r" },
-	/* OPABS 30 */		{ UNARY_OP,  0, "abs(%l)" },
-	/* OPMIN 31 */		{ BINARY_OP,   0, SPECIAL_FMT },
-	/* OPMAX 32 */		{ BINARY_OP,   0, SPECIAL_FMT },
-	/* OPADDR 33 */		{ UNARY_OP, 14, "&%l" },
-
-	/* OPCOMMA_ARG 34 */	{ BINARY_OP, 15, SPECIAL_FMT },
-	/* OPBITOR 35 */	{ BINARY_OP,  6, "%l | %r" },
-	/* OPBITAND 36 */	{ BINARY_OP,  8, "%l & %r" },
-	/* OPBITXOR 37 */	{ BINARY_OP,  7, "%l ^ %r" },
-	/* OPBITNOT 38 */	{ UNARY_OP,  14, "~ %l" },
-	/* OPRSHIFT 39 */	{ BINARY_OP, 11, "%l >> %r" },
-
-/* This isn't quite right -- it doesn't handle arrays, for instance */
-
-	/* OPWHATSIN 40 */	{ UNARY_OP,  14, "*%l" },
-	/* OPMINUSEQ 41 */	{ BINARY_OP,  2, "%l -= %r" },
-	/* OPSLASHEQ 42 */	{ BINARY_OP,  2, "%l /= %r" },
-	/* OPMODEQ 43 */	{ BINARY_OP,  2, "%l %%= %r" },
-	/* OPLSHIFTEQ 44 */	{ BINARY_OP,  2, "%l <<= %r" },
-	/* OPRSHIFTEQ 45 */	{ BINARY_OP,  2, "%l >>= %r" },
-	/* OPBITANDEQ 46 */	{ BINARY_OP,  2, "%l &= %r" },
-	/* OPBITXOREQ 47 */	{ BINARY_OP,  2, "%l ^= %r" },
-	/* OPBITOREQ 48 */	{ BINARY_OP,  2, "%l |= %r" },
-	/* OPPREINC 49 */	{ UNARY_OP,  14, "++%l" },
-	/* OPPREDEC 50 */	{ UNARY_OP,  14, "--%l" },
-	/* OPDOT 51 */		{ BINARY_OP, 15, "%l.%r" },
-	/* OPARROW 52 */	{ BINARY_OP, 15, "%l -> %r"},
-	/* OPNEG1 53 */		{ UNARY_OP,  14, "-%l" },
-	/* OPDMIN 54 */		{ BINARY_OP, 0, "dmin(%l,%r)" },
-	/* OPDMAX 55 */		{ BINARY_OP, 0, "dmax(%l,%r)" },
-	/* OPASSIGNI 56 */	{ BINARY_OP,  2, "%l = &%r" },
-	/* OPIDENTITY 57 */	{ UNARY_OP, 15, "%l" },
-	/* OPCHARCAST 58 */	{ UNARY_OP, 14, "(char *)&%l" },
-	/* OPDABS 59 */		{ UNARY_OP, 0, "dabs(%l)" },
-	/* OPMIN2 60 */		{ BINARY_OP,   0, "min(%l,%r)" },
-	/* OPMAX2 61 */		{ BINARY_OP,   0, "max(%l,%r)" },
-
-/* kludge to imitate (under forcedouble) f77's bizarre treatement of OPNEG... */
-
-	/* OPNEG KLUDGE */	{ UNARY_OP,  14, "-(doublereal)%l" }
-}; /* opcode_table */
-
-#define OPNEG_KLUDGE (sizeof(opcode_table)/sizeof(table_entry) - 1)
-
-static char opeqable[sizeof(opcode_table)/sizeof(table_entry)];
-
-
-static void output_prim ();
-static void output_unary (), output_binary (), output_arg_list ();
-static void output_list (), output_literal ();
-
-
-void expr_out (fp, e)
-FILE *fp;
-expptr e;
-{
-    if (e == (expptr) NULL)
-	return;
-
-    switch (e -> tag) {
-	case TNAME:	out_name (fp, (struct Nameblock *) e);
-			return;
-
-	case TCONST:	out_const(fp, &e->constblock);
-			goto end_out;
-	case TEXPR:
-	    		break;
-
-	case TADDR:	out_addr (fp, &(e -> addrblock));
-			goto end_out;
-
-	case TPRIM:	warn ("expr_out: got TPRIM");
-			output_prim (fp, &(e -> primblock));
-			return;
-
-	case TLIST:	output_list (fp, &(e -> listblock));
- end_out:		frexpr(e);
-			return;
-
-	case TIMPLDO:	err ("expr_out: got TIMPLDO");
-			return;
-
-	case TERROR:
-	default:
-			erri ("expr_out: bad tag '%d'", e -> tag);
-    } /* switch */
-
-/* Now we know that the tag is TEXPR */
-
-/* Optimize on simple expressions, such as "a = a + b" ==> "a += b" */
-
-    if (e -> exprblock.opcode == OPASSIGN && e -> exprblock.rightp &&
-	e -> exprblock.rightp -> tag == TEXPR) {
-	int opcode;
-
-	opcode = e -> exprblock.rightp -> exprblock.opcode;
-
-	if (opeqable[opcode]) {
-	    expptr leftp, rightp;
-
-	    if ((leftp = e -> exprblock.leftp) &&
-		(rightp = e -> exprblock.rightp -> exprblock.leftp)) {
-
-		if (same_ident (leftp, rightp)) {
-		    expptr temp = e -> exprblock.rightp;
-
-		    e -> exprblock.opcode = op_assign(opcode);
-
-		    e -> exprblock.rightp = temp -> exprblock.rightp;
-		    temp->exprblock.rightp = 0;
-		    frexpr(temp);
-		} /* if same_ident (leftp, rightp) */
-	    } /* if leftp && rightp */
-	} /* if opcode == OPPLUS || */
-    } /* if e -> exprblock.opcode == OPASSIGN */
-
-
-/* Optimize on increment or decrement by 1 */
-
-    {
-	int opcode = e -> exprblock.opcode;
-	expptr leftp = e -> exprblock.leftp;
-	expptr rightp = e -> exprblock.rightp;
-
-	if (leftp && rightp && (leftp -> headblock.vstg == STGARG ||
-		ISINT (leftp -> headblock.vtype)) &&
-		(opcode == OPPLUSEQ || opcode == OPMINUSEQ) &&
-		ISINT (rightp -> headblock.vtype) &&
-		ISICON (e -> exprblock.rightp) &&
-		(ISONE (e -> exprblock.rightp) ||
-		e -> exprblock.rightp -> constblock.Const.ci == -1)) {
-
-/* Allow for the '-1' constant value */
-
-	    if (!ISONE (e -> exprblock.rightp))
-		opcode = (opcode == OPPLUSEQ) ? OPMINUSEQ : OPPLUSEQ;
-
-/* replace the existing opcode */
-
-	    if (opcode == OPPLUSEQ)
-		e -> exprblock.opcode = OPPREINC;
-	    else
-		e -> exprblock.opcode = OPPREDEC;
-
-/* Free up storage used by the right hand side */
-
-	    frexpr (e -> exprblock.rightp);
-	    e->exprblock.rightp = 0;
-	} /* if opcode == OPPLUS */
-    } /* block */
-
-
-    if (is_unary_op (e -> exprblock.opcode))
-	output_unary (fp, &(e -> exprblock));
-    else if (is_binary_op (e -> exprblock.opcode))
-	output_binary (fp, &(e -> exprblock));
-    else
-	erri ("expr_out: bad opcode '%d'", (int) e -> exprblock.opcode);
-
-    free((char *)e);
-
-} /* expr_out */
-
-
-void out_and_free_statement (outfile, expr)
-FILE *outfile;
-expptr expr;
-{
-    if (expr)
-	expr_out (outfile, expr);
-
-    nice_printf (outfile, ";\n");
-} /* out_and_free_statement */
-
-
-
-int same_ident (left, right)
-expptr left, right;
-{
-    if (!left || !right)
-	return 0;
-
-    if (left -> tag == TNAME && right -> tag == TNAME && left == right)
-	return 1;
-
-    if (left -> tag == TADDR && right -> tag == TADDR &&
-	    left -> addrblock.uname_tag == right -> addrblock.uname_tag)
-	switch (left -> addrblock.uname_tag) {
-	    case UNAM_NAME:
-
-/* Check for array subscripts */
-
-		if (left -> addrblock.user.name -> vdim ||
-			right -> addrblock.user.name -> vdim)
-		    if (left -> addrblock.user.name !=
-			    right -> addrblock.user.name ||
-			    !same_expr (left -> addrblock.memoffset,
-			    right -> addrblock.memoffset))
-			return 0;
-
-		return same_ident ((expptr) (left -> addrblock.user.name),
-			(expptr) right -> addrblock.user.name);
-	    case UNAM_IDENT:
-		return strcmp(left->addrblock.user.ident,
-				right->addrblock.user.ident) == 0;
-	    case UNAM_CHARP:
-		return strcmp(left->addrblock.user.Charp,
-				right->addrblock.user.Charp) == 0;
-	    default:
-	        return 0;
-	} /* switch */
-
-    if (left->tag == TEXPR && left->exprblock.opcode == OPWHATSIN
-	&& right->tag == TEXPR && right->exprblock.opcode == OPWHATSIN)
-		return same_ident(left->exprblock.leftp,
-				 right->exprblock.leftp);
-
-    return 0;
-} /* same_ident */
-
- static int
-samefpconst(c1, c2, n)
- register Constp c1, c2;
- register int n;
-{
-	char *s1, *s2;
-	if (!c1->vstg && !c2->vstg)
-		return c1->Const.cd[n] == c2->Const.cd[n];
-	s1 = c1->vstg ? c1->Const.cds[n] : dtos(c1->Const.cd[n]);
-	s2 = c2->vstg ? c2->Const.cds[n] : dtos(c2->Const.cd[n]);
-	return !strcmp(s1, s2);
-	}
-
- static int
-sameconst(c1, c2)
- register Constp c1, c2;
-{
-	switch(c1->vtype) {
-		case TYCOMPLEX:
-		case TYDCOMPLEX:
-			if (!samefpconst(c1,c2,1))
-				return 0;
-		case TYREAL:
-		case TYDREAL:
-			return samefpconst(c1,c2,0);
-		case TYCHAR:
-			return c1->Const.ccp1.blanks == c2->Const.ccp1.blanks
-			    &&	   c1->vleng->constblock.Const.ci
-				== c2->vleng->constblock.Const.ci
-			    && !memcmp(c1->Const.ccp, c2->Const.ccp,
-					(int)c1->vleng->constblock.Const.ci);
-		case TYSHORT:
-		case TYINT:
-		case TYLOGICAL:
-			return c1->Const.ci == c2->Const.ci;
-		}
-	err("unexpected type in sameconst");
-	return 0;
-	}
-
-/* same_expr -- Returns true only if   e1 and e2   match.  This is
-   somewhat pessimistic, but can afford to be because it's just used to
-   optimize on the assignment operators (+=, -=, etc). */
-
-int same_expr (e1, e2)
-expptr e1, e2;
-{
-    if (!e1 || !e2)
-	return !e1 && !e2;
-
-    if (e1 -> tag != e2 -> tag || e1 -> headblock.vtype != e2 -> headblock.vtype)
-	return 0;
-
-    switch (e1 -> tag) {
-        case TEXPR:
-	    if (e1 -> exprblock.opcode != e2 -> exprblock.opcode)
-		return 0;
-
-	    return same_expr (e1 -> exprblock.leftp, e2 -> exprblock.leftp) &&
-		   same_expr (e1 -> exprblock.rightp, e2 -> exprblock.rightp);
-	case TNAME:
-	case TADDR:
-	    return same_ident (e1, e2);
-	case TCONST:
-	    return sameconst(&e1->constblock, &e2->constblock);
-	default:
-	    return 0;
-    } /* switch */
-} /* same_expr */
-
-
-
-void out_name (fp, namep)
- FILE *fp;
- Namep namep;
-{
-    extern int usedefsforcommon;
-    Extsym *comm;
-
-    if (namep == NULL)
-	return;
-
-/* DON'T want to use oneof_stg() here; need to find the right common name
-   */
-
-    if (namep->vstg == STGCOMMON && !namep->vcommequiv && !usedefsforcommon) {
-	comm = &extsymtab[namep->vardesc.varno];
-	extern_out(fp, comm);
-	nice_printf(fp, "%d.", comm->curno);
-    } /* if namep -> vstg == STGCOMMON */
-
-    if (namep->vprocclass == PTHISPROC && namep->vtype != TYSUBR)
-	nice_printf(fp, xretslot[namep->vtype]->user.ident);
-    else
-	nice_printf (fp, "%s", namep->cvarname);
-} /* out_name */
-
-
-static char *Longfmt = "%ld";
-
-#define cpd(n) cp->vstg ? cp->Const.cds[n] : dtos(cp->Const.cd[n])
-
-void out_const(fp, cp)
- FILE *fp;
- register Constp cp;
-{
-    static char real_buf[50], imag_buf[50];
-    unsigned int k;
-    int type = cp->vtype;
-
-    switch (type) {
-        case TYSHORT:
-	    nice_printf (fp, "%ld", cp->Const.ci);	/* don't cast ci! */
-	    break;
-	case TYLONG:
-	    nice_printf (fp, Longfmt, cp->Const.ci);	/* don't cast ci! */
-	    break;
-	case TYREAL:
-	    nice_printf(fp, "%s", flconst(real_buf, cpd(0)));
-	    break;
-	case TYDREAL:
-	    nice_printf(fp, "%s", cpd(0));
-	    break;
-	case TYCOMPLEX:
-	    nice_printf(fp, cm_fmt_string, flconst(real_buf, cpd(0)),
-			flconst(imag_buf, cpd(1)));
-	    break;
-	case TYDCOMPLEX:
-	    nice_printf(fp, dcm_fmt_string, cpd(0), cpd(1));
-	    break;
-	case TYLOGICAL:
-	    nice_printf (fp, "%s", cp->Const.ci ? "TRUE_" : "FALSE_");
-	    break;
-	case TYCHAR: {
-	    char *c = cp->Const.ccp, *ce;
-
-	    if (c == NULL) {
-		nice_printf (fp, "\"\"");
-		break;
-	    } /* if c == NULL */
-
-	    nice_printf (fp, "\"");
-	    ce = c + cp->vleng->constblock.Const.ci;
-	    while(c < ce) {
-		k = *(unsigned char *)c++;
-		nice_printf(fp, str_fmt[k], k);
-		}
-	    for(k = cp->Const.ccp1.blanks; k > 0; k--)
-		nice_printf(fp, " ");
-	    nice_printf (fp, "\"");
-	    break;
-	} /* case TYCHAR */
-	default:
-	    erri ("out_const:  bad type '%d'", (int) type);
-	    break;
-    } /* switch */
-
-} /* out_const */
-#undef cpd
-
-
-/* out_addr -- this routine isn't local because it is called by the
-   system-generated identifier printing routines */
-
-void out_addr (fp, addrp)
-FILE *fp;
-struct Addrblock *addrp;
-{
-	extern Extsym *extsymtab;
-	int was_array = 0;
-	char *s;
-
-
-	if (addrp == NULL)
-		return;
-	if (doin_setbound
-			&& addrp->vstg == STGARG
-			&& addrp->vtype != TYCHAR
-			&& ISICON(addrp->memoffset)
-			&& !addrp->memoffset->constblock.Const.ci)
-		nice_printf(fp, "*");
-
-	switch (addrp -> uname_tag) {
-	    case UNAM_NAME:
-		out_name (fp, addrp -> user.name);
-		break;
-	    case UNAM_IDENT:
-		if (*(s = addrp->user.ident) == ' ') {
-			if (multitype)
-				nice_printf(fp, "%s",
-					xretslot[addrp->vtype]->user.ident);
-			else
-				nice_printf(fp, "%s", s+1);
-			}
-		else {
-			nice_printf(fp, "%s", s);
-			}
-		break;
-	    case UNAM_CHARP:
-		nice_printf(fp, "%s", addrp->user.Charp);
-		break;
-	    case UNAM_EXTERN:
-		extern_out (fp, &extsymtab[addrp -> memno]);
-		break;
-	    case UNAM_CONST:
-		switch(addrp->vstg) {
-			case STGCONST:
-				out_const(fp, (Constp)addrp);
-				break;
-			case STGMEMNO:
-				output_literal (fp, (int)addrp->memno,
-					(Constp)addrp);
-				break;
-			default:
-			Fatal("unexpected vstg in out_addr");
-			}
-		break;
-	    case UNAM_UNKNOWN:
-	    default:
-		nice_printf (fp, "Unknown Addrp");
-		break;
-	} /* switch */
-
-/* It's okay to just throw in the brackets here because they have a
-   precedence level of 15, the highest value.  */
-
-    if ((addrp->uname_tag == UNAM_NAME && addrp->user.name->vdim
-			|| addrp->ntempelt > 1 || addrp->isarray)
-	&& addrp->vtype != TYCHAR) {
-	expptr offset;
-
-	was_array = 1;
-
-	offset = addrp -> memoffset;
-	addrp->memoffset = 0;
-	if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV)) &&
-		addrp -> uname_tag == UNAM_NAME)
-	    offset = mkexpr (OPMINUS, offset, mkintcon (
-		    addrp -> user.name -> voffset));
-
-	nice_printf (fp, "[");
-
-	offset = mkexpr (OPSLASH, offset,
-		ICON (typesize[addrp -> vtype] * (addrp -> Field ? 2 : 1)));
-	expr_out (fp, offset);
-	nice_printf (fp, "]");
-	}
-
-/* Check for structure field reference */
-
-    if (addrp -> Field && addrp -> uname_tag != UNAM_CONST &&
-	    addrp -> uname_tag != UNAM_UNKNOWN) {
-	if (oneof_stg((addrp -> uname_tag == UNAM_NAME ? addrp -> user.name :
-		(Namep) NULL), addrp -> vstg, M(STGARG)|M(STGEQUIV))
-		&& !was_array && (addrp->vclass != CLPROC || !multitype))
-	    nice_printf (fp, "->%s", addrp -> Field);
-	else
-	    nice_printf (fp, ".%s", addrp -> Field);
-    } /* if */
-
-/* Check for character subscripting */
-
-    if (addrp->vtype == TYCHAR &&
-	    (addrp->vclass != CLPROC || addrp->uname_tag == UNAM_NAME
-			&& addrp->user.name->vprocclass == PTHISPROC) &&
-	    addrp -> memoffset &&
-	    (addrp -> uname_tag != UNAM_NAME ||
-	     addrp -> user.name -> vtype == TYCHAR) &&
-	    (!ISICON (addrp -> memoffset) ||
-	     (addrp -> memoffset -> constblock.Const.ci))) {
-
-	int use_paren = 0;
-	expptr e = addrp -> memoffset;
-
-	if (!e)
-		return;
-	addrp->memoffset = 0;
-
-	if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV))
-	 && addrp -> uname_tag == UNAM_NAME) {
-	    e = mkexpr (OPMINUS, e, mkintcon (addrp -> user.name -> voffset));
-
-/* mkexpr will simplify it to zero if possible */
-	    if (e->tag == TCONST && e->constblock.Const.ci == 0)
-		return;
-	} /* if addrp -> vstg == STGCOMMON */
-
-/* In the worst case, parentheses might be needed OUTSIDE the expression,
-   too.  But since I think this subscripting can only appear as a
-   parameter in a procedure call, I don't think outside parens will ever
-   be needed.  INSIDE parens are handled below */
-
-	nice_printf (fp, " + ");
-	if (e -> tag == TEXPR) {
-	    int arg_prec = op_precedence (e -> exprblock.opcode);
-	    int prec = op_precedence (OPPLUS);
-	    use_paren = arg_prec && (arg_prec < prec || (arg_prec == prec &&
-		    is_left_assoc (OPPLUS)));
-	} /* if e -> tag == TEXPR */
-	if (use_paren) nice_printf (fp, "(");
-	expr_out (fp, e);
-	if (use_paren) nice_printf (fp, ")");
-    } /* if */
-} /* out_addr */
-
-
-static void output_literal (fp, memno, cp)
- FILE *fp;
- int memno;
- Constp cp;
-{
-    struct Literal *litp, *lastlit;
-    extern char *lit_name ();
-
-    lastlit = litpool + nliterals;
-
-    for (litp = litpool; litp < lastlit; litp++) {
-	if (litp -> litnum == memno)
-	    break;
-    } /* for litp */
-
-    if (litp >= lastlit)
-	out_const (fp, cp);
-    else {
-	nice_printf (fp, "%s", lit_name (litp));
-	litp->lituse++;
-	}
-} /* output_literal */
-
-
-static void output_prim (fp, primp)
-FILE *fp;
-struct Primblock *primp;
-{
-    if (primp == NULL)
-	return;
-
-    out_name (fp, primp -> namep);
-    if (primp -> argsp)
-	output_arg_list (fp, primp -> argsp);
-
-    if (primp -> fcharp != (expptr) NULL || primp -> lcharp != (expptr) NULL)
-	nice_printf (fp, "Sorry, no substrings yet");
-}
-
-
-
-static void output_arg_list (fp, listp)
-FILE *fp;
-struct Listblock *listp;
-{
-    chainp arg_list;
-
-    if (listp == (struct Listblock *) NULL || listp -> listp == (chainp) NULL)
-	return;
-
-    nice_printf (fp, "(");
-
-    for (arg_list = listp -> listp; arg_list; arg_list = arg_list -> nextp) {
-	expr_out (fp, (expptr) arg_list -> datap);
-	if (arg_list -> nextp != (chainp) NULL)
-
-/* Might want to add a hook in here to accomodate the style setting which
-   wants spaces after commas */
-
-	    nice_printf (fp, ",");
-    } /* for arg_list */
-
-    nice_printf (fp, ")");
-} /* output_arg_list */
-
-
-
-static void output_unary (fp, e)
-FILE *fp;
-struct Exprblock *e;
-{
-    if (e == NULL)
-	return;
-
-    switch (e -> opcode) {
-        case OPNEG:
-		if (e->vtype == TYREAL && forcedouble) {
-			e->opcode = OPNEG_KLUDGE;
-			output_binary(fp,e);
-			e->opcode = OPNEG;
-			break;
-			}
-	case OPNEG1:
-	case OPNOT:
-	case OPABS:
-	case OPBITNOT:
-	case OPWHATSIN:
-	case OPPREINC:
-	case OPPREDEC:
-	case OPADDR:
-	case OPIDENTITY:
-	case OPCHARCAST:
-	case OPDABS:
-	    output_binary (fp, e);
-	    break;
-	case OPCALL:
-	case OPCCALL:
-	    nice_printf (fp, "Sorry, no OPCALL yet");
-	    break;
-	default:
-	    erri ("output_unary: bad opcode", (int) e -> opcode);
-	    break;
-    } /* switch */
-} /* output_unary */
-
-
- static char *
-findconst(m)
- register long m;
-{
-	register struct Literal *litp, *litpe;
-
-	litp = litpool;
-	for(litpe = litp + nliterals; litp < litpe; litp++)
-		if (litp->litnum ==  m)
-			return litp->cds[0];
-	Fatal("findconst failure!");
-	return 0;
-	}
-
- static int
-opconv_fudge(fp,e)
- FILE *fp;
- struct Exprblock *e;
-{
-	/* special handling for ichar and character*1 */
-	register expptr lp;
-	register union Expression *Offset;
-	register char *cp;
-	int lt;
-	char buf[8];
-	unsigned int k;
-	Namep np;
-
-	if (!(lp = e->leftp))	/* possible with erroneous Fortran */
-		return 1;
-	lt = lp->headblock.vtype;
-	if (lp->addrblock.vtype == TYCHAR) {
-		switch(lp->tag) {
-			case TNAME:
-				nice_printf(fp, "*");
-				out_name(fp, (Namep)lp);
-				return 1;
-			case TCONST:
- tconst:
-				cp = lp->constblock.Const.ccp;
- tconst1:
-				k = *(unsigned char *)cp;
-				sprintf(buf, chr_fmt[k], k);
-				nice_printf(fp, "'%s'", buf);
-				return 1;
-			case TADDR:
-				switch(lp->addrblock.vstg) {
-				    case STGMEMNO:
-					cp = findconst(lp->addrblock.memno);
-					goto tconst1;
-				    case STGCONST:
-					goto tconst;
-				    }
-				lt = lp->addrblock.vtype = tyint;
-				Offset = lp->addrblock.memoffset;
-				if (lp->addrblock.uname_tag == UNAM_NAME) {
-					np = lp->addrblock.user.name;
-					if (ONEOF(np->vstg,
-					    M(STGCOMMON)|M(STGEQUIV)))
-						Offset = mkexpr(OPMINUS, Offset,
-							ICON(np->voffset));
-					}
-				lp->addrblock.memoffset = Offset ?
-					mkexpr(OPSTAR, Offset,
-						ICON(typesize[tyint]))
-					: ICON(0);
-				lp->addrblock.isarray = 1;
-				/* STGCOMMON or STGEQUIV would cause */
-				/* voffset to be added in a second time */
-				lp->addrblock.vstg = STGUNKNOWN;
-				break;
-			default:
-				badtag("opconv_fudge", lp->tag);
-			}
-		}
-	if (lt != e->vtype)
-		nice_printf(fp, "(%s) ",
-			c_type_decl(e->vtype, 0));
-	return 0;
-	}
-
-
-static void output_binary (fp, e)
-FILE *fp;
-struct Exprblock *e;
-{
-    char *format;
-    extern table_entry opcode_table[];
-    int prec;
-
-    if (e == NULL || e -> tag != TEXPR)
-	return;
-
-/* Instead of writing a huge switch, I've incorporated the output format
-   into a table.  Things like "%l" and "%r" stand for the left and
-   right subexpressions.  This should allow both prefix and infix
-   functions to be specified (e.g. "(%l * %r", "z_div (%l, %r").  Of
-   course, I should REALLY think out the ramifications of writing out
-   straight text, as opposed to some intermediate format, which could
-   figure out and optimize on the the number of required blanks (we don't
-   want "x - (-y)" to become "x --y", for example).  Special cases (such as
-   incomplete implementations) could still be implemented as part of the
-   switch, they will just have some dummy value instead of the string
-   pattern.  Another difficulty is the fact that the complex functions
-   will differ from the integer and real ones */
-
-/* Handle a special case.  We don't want to output "x + - 4", or "y - - 3"
-*/
-    if ((e -> opcode == OPPLUS || e -> opcode == OPMINUS) &&
-	    e -> rightp && e -> rightp -> tag == TCONST &&
-	    isnegative_const (&(e -> rightp -> constblock)) &&
-	    is_negatable (&(e -> rightp -> constblock))) {
-
-	e -> opcode = (e -> opcode == OPPLUS) ? OPMINUS : OPPLUS;
-	negate_const (&(e -> rightp -> constblock));
-    } /* if e -> opcode == PLUS or MINUS */
-
-    prec = op_precedence (e -> opcode);
-    format = op_format (e -> opcode);
-
-    if (format != SPECIAL_FMT) {
-	while (*format) {
-	    if (*format == '%') {
-		int arg_prec, use_paren = 0;
-		expptr lp, rp;
-
-		switch (*(format + 1)) {
-		    case 'l':
-			lp = e->leftp;
-			if (lp && lp->tag == TEXPR) {
-			    arg_prec = op_precedence(lp->exprblock.opcode);
-
-			    use_paren = arg_prec &&
-			        (arg_prec < prec || (arg_prec == prec &&
-				    is_right_assoc (prec)));
-			} /* if e -> leftp */
-			if (e->opcode == OPCONV && opconv_fudge(fp,e))
-				break;
-			if (use_paren)
-			    nice_printf (fp, "(");
-		        expr_out(fp, lp);
-			if (use_paren)
-			    nice_printf (fp, ")");
-		        break;
-		    case 'r':
-			rp = e->rightp;
-			if (rp && rp->tag == TEXPR) {
-			    arg_prec = op_precedence(rp->exprblock.opcode);
-
-			    use_paren = arg_prec &&
-			        (arg_prec < prec || (arg_prec == prec &&
-				    is_left_assoc (prec)));
-			    use_paren = use_paren ||
-				(rp->exprblock.opcode == OPNEG
-				&& prec >= op_precedence(OPMINUS));
-			} /* if e -> rightp */
-			if (use_paren)
-			    nice_printf (fp, "(");
-		        expr_out(fp, rp);
-			if (use_paren)
-			    nice_printf (fp, ")");
-		        break;
-		    case '\0':
-		    case '%':
-		        nice_printf (fp, "%%");
-		        break;
-		    default:
-		        erri ("output_binary: format err: '%%%c' illegal",
-				(int) *(format + 1));
-		        break;
-		} /* switch */
-		format += 2;
-	    } else
-		nice_printf (fp, "%c", *format++);
-	} /* while *format */
-    } else {
-
-/* Handle Special cases of formatting */
-
-	switch (e -> opcode) {
-		case OPCCALL:
-		case OPCALL:
-			out_call (fp, (int) e -> opcode, e -> vtype,
-					e -> vleng, e -> leftp, e -> rightp);
-			break;
-
-		case OPCOMMA_ARG:
-			doin_setbound = 1;
-			nice_printf(fp, "(");
-			expr_out(fp, e->leftp);
-			nice_printf(fp, ", &");
-			doin_setbound = 0;
-			expr_out(fp, e->rightp);
-			nice_printf(fp, ")");
-			break;
-
-		case OPADDR:
-		default:
-	        	nice_printf (fp, "Sorry, can't format OPCODE '%d'",
-				e -> opcode);
-	        	break;
-		}
-
-    } /* else */
-} /* output_binary */
-
-
-out_call (outfile, op, ftype, len, name, args)
-FILE *outfile;
-int op, ftype;
-expptr len, name, args;
-{
-    chainp arglist;		/* Pointer to any actual arguments */
-    chainp cp;			/* Iterator over argument lists */
-    Addrp ret_val = (Addrp) NULL;
-				/* Function return value buffer, if any is
-				   required */
-    int byvalue;		/* True iff we're calling a C library
-				   routine */
-    int done_once;		/* Used for writing commas to   outfile   */
-    int narg, t;
-    register expptr q;
-    long L;
-    Argtypes *at;
-    Atype *A, *Ac;
-    Namep np;
-    extern int forcereal;
-
-/* Don't use addresses if we're calling a C function */
-
-    byvalue = op == OPCCALL;
-
-    if (args)
-	arglist = args -> listblock.listp;
-    else
-	arglist = CHNULL;
-
-/* If this is a CHARACTER function, the first argument is the result */
-
-    if (ftype == TYCHAR)
-	if (ISICON (len)) {
-	    ret_val = (Addrp) (arglist -> datap);
-	    arglist = arglist -> nextp;
-	} else {
-	    err ("adjustable character function");
-	    return;
-	} /* else */
-
-/* If this is a COMPLEX function, the first argument is the result */
-
-    else if (ISCOMPLEX (ftype)) {
-	ret_val = (Addrp) (arglist -> datap);
-	arglist = arglist -> nextp;
-    } /* if ISCOMPLEX */
-
-/* Now we can actually start to write out the function invocation */
-
-    if (ftype == TYREAL && forcereal)
-	nice_printf(outfile, "(real)");
-    if (name -> tag == TEXPR && name -> exprblock.opcode == OPWHATSIN) {
-	nice_printf (outfile, "(");
-	np = (Namep)name->exprblock.leftp; /*expr_out will free name */
-	expr_out (outfile, name);
-	nice_printf (outfile, ")");
-	}
-    else {
-	np = (Namep)name;
-	expr_out(outfile, name);
-	}
-
-    /* prepare to cast procedure parameters -- set A if we know how */
-
-    A = Ac = 0;
-    if (at = np->arginfo) {
-	if (np->tag == TNAME && at->nargs > 0)
-		A = at->atypes;
-	if (Ansi && (at->defined || at->nargs > 0))
-		Ac = at->atypes;
-    	}
-
-    nice_printf(outfile, "(");
-
-    if (ret_val) {
-	if (ISCOMPLEX (ftype))
-	    nice_printf (outfile, "&");
-	expr_out (outfile, (expptr) ret_val);
-	if (Ac)
-		Ac++;
-
-/* The length of the result of a character function is the second argument */
-/* It should be in place from putcall(), so we won't touch it explicitly */
-
-    } /* if ret_val */
-    done_once = ret_val ? TRUE : FALSE;
-
-/* Now run through the named arguments */
-
-    narg = -1;
-    for (cp = arglist; cp; cp = cp -> nextp, done_once = TRUE) {
-
-	if (done_once)
-	    nice_printf (outfile, ", ");
-	narg++;
-
-	if (!( q = (expptr)cp->datap) )
-		continue;
-
-	if (q->tag == TADDR) {
-		if (q->addrblock.vtype > TYERROR) {
-			/* I/O block */
-			nice_printf(outfile, "&%s", q->addrblock.user.ident);
-			continue;
-			}
-		if (!byvalue && q->addrblock.isarray
-		&& q->addrblock.vtype != TYCHAR
-		&& q->addrblock.memoffset->tag == TCONST) {
-
-			/* check for 0 offset -- after */
-			/* correcting for equivalence. */
-			L = q->addrblock.memoffset->constblock.Const.ci;
-			if (ONEOF(q->addrblock.vstg, M(STGCOMMON)|M(STGEQUIV))
-					&& q->addrblock.uname_tag == UNAM_NAME)
-				L -= q->addrblock.user.name->voffset;
-			if (L)
-				goto skip_deref;
-
-			if (Ac && narg < at->dnargs
-			 && q->headblock.vtype != (t = Ac[narg].type)
-			 && t > TYADDR && t < TYSUBR)
-				nice_printf(outfile, "(%s*)", typename[t]);
-
-			/* &x[0] == x */
-			/* This also prevents &sizeof(doublereal)[0] */
-
-			switch(q->addrblock.uname_tag) {
-			    case UNAM_NAME:
-				out_name(outfile, q->addrblock.user.name);
-				continue;
-			    case UNAM_IDENT:
-				nice_printf(outfile, "%s",
-					q->addrblock.user.ident);
-				continue;
-			    case UNAM_CHARP:
-				nice_printf(outfile, "%s",
-					q->addrblock.user.Charp);
-				continue;
-			    case UNAM_EXTERN:
-				extern_out(outfile,
-					&extsymtab[q->addrblock.memno]);
-				continue;
-			    }
-			}
-		}
-
-/* Skip over the dereferencing operator generated only for the
-   intermediate file */
- skip_deref:
-	if (q -> tag == TEXPR && q -> exprblock.opcode == OPWHATSIN)
-	    q = q -> exprblock.leftp;
-
-	if (q->headblock.vclass == CLPROC) {
-	    if (Castargs && (q->tag != TNAME
-				|| q->nameblock.vprocclass != PTHISPROC))
-		{
-		if (A && (t = A[narg].type) >= 200)
-			t %= 100;
-		else {
-			t = q->headblock.vtype;
-			if (q->tag == TNAME && q->nameblock.vimpltype)
-				t = TYUNKNOWN;
-			}
-		nice_printf(outfile, "(%s)", usedcasts[t] = casttypes[t]);
-		}
-	    }
-	else if (Ac && narg < at->dnargs
-		&& q->headblock.vtype != (t = Ac[narg].type)
-		&& t > TYADDR && t < TYSUBR)
-		nice_printf(outfile, "(%s*)", typename[t]);
-
-	if ((q -> tag == TADDR || q-> tag == TNAME) &&
-		(byvalue || q -> headblock.vstg != STGREG)) {
-	    if (q -> headblock.vtype != TYCHAR)
-	      if (byvalue) {
-
-		if (q -> tag == TADDR &&
-			q -> addrblock.uname_tag == UNAM_NAME &&
-			! q -> addrblock.user.name -> vdim &&
-			oneof_stg(q -> addrblock.user.name, q -> addrblock.vstg,
-					M(STGARG)|M(STGEQUIV)) &&
-			! ISCOMPLEX(q->addrblock.user.name->vtype))
-		    nice_printf (outfile, "*");
-		else if (q -> tag == TNAME
-			&& oneof_stg(&q->nameblock, q -> nameblock.vstg,
-				M(STGARG)|M(STGEQUIV))
-			&& !(q -> nameblock.vdim))
-		    nice_printf (outfile, "*");
-
-	      } else {
-		expptr memoffset;
-
-		if (q->tag == TADDR &&
-			!ONEOF (q -> addrblock.vstg, M(STGEXT)|M(STGLENG))
-			&& (
-			ONEOF(q->addrblock.vstg,
-				M(STGCOMMON)|M(STGEQUIV)|M(STGMEMNO))
-			|| ((memoffset = q->addrblock.memoffset)
-				&& (!ISICON(memoffset)
-				|| memoffset->constblock.Const.ci)))
-			|| ONEOF(q->addrblock.vstg,
-					M(STGINIT)|M(STGAUTO)|M(STGBSS))
-				&& !q->addrblock.isarray)
-		    nice_printf (outfile, "&");
-		else if (q -> tag == TNAME
-			&& !oneof_stg(&q->nameblock, q -> nameblock.vstg,
-				M(STGARG)|M(STGEXT)|M(STGEQUIV)))
-		    nice_printf (outfile, "&");
-	    } /* else */
-
-	    expr_out (outfile, q);
-	} /* if q -> tag == TADDR || q -> tag == TNAME */
-
-/* Might be a Constant expression, e.g. string length, character constants */
-
-	else if (q -> tag == TCONST) {
-	    if (tyioint == TYLONG)
-	   	Longfmt = "%ldL";
-	    out_const(outfile, &q->constblock);
-	    Longfmt = "%ld";
-	    }
-
-/* Must be some other kind of expression, or register var, or constant.
-   In particular, this is likely to be a temporary variable assignment
-   which was generated in p1put_call */
-
-	else if (!ISCOMPLEX (q -> headblock.vtype) && !ISCHAR (q)){
-	    int use_paren = q -> tag == TEXPR &&
-		    op_precedence (q -> exprblock.opcode) <=
-		    op_precedence (OPCOMMA);
-
-	    if (use_paren) nice_printf (outfile, "(");
-	    expr_out (outfile, q);
-	    if (use_paren) nice_printf (outfile, ")");
-	} /* if !ISCOMPLEX */
-	else
-	    err ("out_call:  unknown parameter");
-
-    } /* for (cp = arglist */
-
-    if (arglist)
-	frchain (&arglist);
-
-    nice_printf (outfile, ")");
-
-} /* out_call */
-
-
- char *
-flconst(buf, x)
- char *buf, *x;
-{
-	sprintf(buf, fl_fmt_string, x);
-	return buf;
-	}
-
- char *
-dtos(x)
- double x;
-{
-	static char buf[64];
-	sprintf(buf, db_fmt_string, x);
-	return buf;
-	}
-
-char tr_tab[Table_size];
-
-/* out_init -- Initialize the data structures used by the routines in
-   output.c.  These structures include the output format to be used for
-   Float, Double, Complex, and Double Complex constants. */
-
-void out_init ()
-{
-    extern int tab_size;
-    register char *s;
-
-    s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_+-.";
-    while(*s)
-	tr_tab[*s++] = 3;
-    tr_tab['>'] = 1;
-
-	opeqable[OPPLUS] = 1;
-	opeqable[OPMINUS] = 1;
-	opeqable[OPSTAR] = 1;
-	opeqable[OPSLASH] = 1;
-	opeqable[OPMOD] = 1;
-	opeqable[OPLSHIFT] = 1;
-	opeqable[OPBITAND] = 1;
-	opeqable[OPBITXOR] = 1;
-	opeqable[OPBITOR ] = 1;
-
-
-/* Set the output format for both types of floating point constants */
-
-    if (fl_fmt_string == NULL || *fl_fmt_string == '\0')
-	fl_fmt_string = Ansi == 1 ? "%sf" : "(float)%s";
-
-    if (db_fmt_string == NULL || *db_fmt_string == '\0')
-	db_fmt_string = "%.17g";
-
-/* Set the output format for both types of complex constants.  They will
-   have string parameters rather than float or double so that the decimal
-   point may be added to the strings generated by the {db,fl}_fmt_string
-   formats above */
-
-    if (cm_fmt_string == NULL || *cm_fmt_string == '\0') {
-	cm_fmt_string = "{%s,%s}";
-    } /* if cm_fmt_string == NULL */
-
-    if (dcm_fmt_string == NULL || *dcm_fmt_string == '\0') {
-	dcm_fmt_string = "{%s,%s}";
-    } /* if dcm_fmt_string == NULL */
-
-    tab_size = 4;
-} /* out_init */
-
-
-void extern_out (fp, extsym)
-FILE *fp;
-Extsym *extsym;
-{
-    if (extsym == (Extsym *) NULL)
-	return;
-
-    nice_printf (fp, "%s", extsym->cextname);
-
-} /* extern_out */
-
-
-
-static void output_list (fp, listp)
-FILE *fp;
-struct Listblock *listp;
-{
-    int did_one = 0;
-    chainp elts;
-
-    nice_printf (fp, "(");
-    if (listp)
-	for (elts = listp -> listp; elts; elts = elts -> nextp) {
-	    if (elts -> datap) {
-		if (did_one)
-		    nice_printf (fp, ", ");
-		expr_out (fp, (expptr) elts -> datap);
-		did_one = 1;
-	    } /* if elts -> datap */
-	} /* for elts */
-    nice_printf (fp, ")");
-} /* output_list */
-
-
-void out_asgoto (outfile, expr)
-FILE *outfile;
-expptr expr;
-{
-    char *user_label();
-    chainp value;
-    Namep namep;
-    int k;
-
-    if (expr == (expptr) NULL) {
-	err ("out_asgoto:  NULL variable expr");
-	return;
-    } /* if expr */
-
-    nice_printf (outfile, Ansi ? "switch (" : "switch ((int)"); /*)*/
-    expr_out (outfile, expr);
-    nice_printf (outfile, ") {\n");
-    next_tab (outfile);
-
-/* The initial addrp value will be stored as a namep pointer */
-
-    switch(expr->tag) {
-	case TNAME:
-		/* local variable */
-		namep = &expr->nameblock;
-		break;
-	case TEXPR:
-		if (expr->exprblock.opcode == OPWHATSIN
-		 && expr->exprblock.leftp->tag == TNAME)
-			/* argument */
-			namep = &expr->exprblock.leftp->nameblock;
-		else
-			goto bad;
-		break;
-	case TADDR:
-		if (expr->addrblock.uname_tag == UNAM_NAME) {
-			/* initialized local variable */
-			namep = expr->addrblock.user.name;
-			break;
-			}
-	default:
- bad:
-		err("out_asgoto:  bad expr");
-		return;
-	}
-
-    for(k = 0, value = namep -> varxptr.assigned_values; value;
-	    value = value->nextp, k++) {
-	nice_printf (outfile, "case %d: goto %s;\n", k,
-		user_label((long)value->datap));
-    } /* for value */
-    prev_tab (outfile);
-
-    nice_printf (outfile, "}\n");
-} /* out_asgoto */
-
-void out_if (outfile, expr)
-FILE *outfile;
-expptr expr;
-{
-    nice_printf (outfile, "if (");
-    expr_out (outfile, expr);
-    nice_printf (outfile, ") {\n");
-    next_tab (outfile);
-} /* out_if */
-
- static void
-output_rbrace(outfile, s)
- FILE *outfile;
- char *s;
-{
-	extern int last_was_label;
-	register char *fmt;
-
-	if (last_was_label) {
-		last_was_label = 0;
-		fmt = ";%s";
-		}
-	else
-		fmt = "%s";
-	nice_printf(outfile, fmt, s);
-	}
-
-void out_else (outfile)
-FILE *outfile;
-{
-    prev_tab (outfile);
-    output_rbrace(outfile, "} else {\n");
-    next_tab (outfile);
-} /* out_else */
-
-void elif_out (outfile, expr)
-FILE *outfile;
-expptr expr;
-{
-    prev_tab (outfile);
-    output_rbrace(outfile, "} else ");
-    out_if (outfile, expr);
-} /* elif_out */
-
-void endif_out (outfile)
-FILE *outfile;
-{
-    prev_tab (outfile);
-    output_rbrace(outfile, "}\n");
-} /* endif_out */
-
-void end_else_out (outfile)
-FILE *outfile;
-{
-    prev_tab (outfile);
-    output_rbrace(outfile, "}\n");
-} /* end_else_out */
-
-
-
-void compgoto_out (outfile, index, labels)
-FILE *outfile;
-expptr index, labels;
-{
-    char *s1, *s2;
-
-    if (index == ENULL)
-	err ("compgoto_out:  null index for computed goto");
-    else if (labels && labels -> tag != TLIST)
-	erri ("compgoto_out:  expected label list, got tag '%d'",
-		labels -> tag);
-    else {
-	extern char *user_label ();
-	chainp elts;
-	int i = 1;
-
-	s2 = /*(*/ ") {\n"; /*}*/
-	if (Ansi)
-		s1 = "switch ("; /*)*/
-	else if (index->tag == TNAME || index->tag == TEXPR
-				&& index->exprblock.opcode == OPWHATSIN)
-		s1 = "switch ((int)"; /*)*/
-	else {
-		s1 = "switch ((int)(";
-		s2 = ")) {\n"; /*}*/
-		}
-	nice_printf(outfile, s1);
-	expr_out (outfile, index);
-	nice_printf (outfile, s2);
-	next_tab (outfile);
-
-	for (elts = labels -> listblock.listp; elts; elts = elts -> nextp, i++) {
-	    if (elts -> datap) {
-		if (ISICON(((expptr) (elts -> datap))))
-		    nice_printf (outfile, "case %d:  goto %s;\n", i,
-			user_label(((expptr)(elts->datap))->constblock.Const.ci));
-		else
-		    err ("compgoto_out:  bad label in label list");
-	    } /* if (elts -> datap) */
-	} /* for elts */
-	prev_tab (outfile);
-	nice_printf (outfile, /*{*/ "}\n");
-    } /* else */
-} /* compgoto_out */
-
-
-void out_for (outfile, init, test, inc)
-FILE *outfile;
-expptr init, test, inc;
-{
-    nice_printf (outfile, "for (");
-    expr_out (outfile, init);
-    nice_printf (outfile, "; ");
-    expr_out (outfile, test);
-    nice_printf (outfile, "; ");
-    expr_out (outfile, inc);
-    nice_printf (outfile, ") {\n");
-    next_tab (outfile);
-} /* out_for */
-
-
-void out_end_for (outfile)
-FILE *outfile;
-{
-    prev_tab (outfile);
-    nice_printf (outfile, "}\n");
-} /* out_end_for */
//GO.SYSIN DD output.c
echo output.h 1>&2
sed >output.h <<'//GO.SYSIN DD output.h' 's/^-//'
-/* nice_printf -- same arguments as fprintf.
-
-	All output which is to become C code must be directed through this
-   function.  For now, no buffering is done.  Later on, every line of
-   output will be filtered to accomodate the style definitions (e.g. one
-   statement per line, spaces between function names and argument lists,
-   etc.)
-*/
-#include "niceprintf.h"
-
-extern int nice_printf ();
-
-
-/* Definitions for the opcode table.  The table is indexed by the macros
-   which are #defined in   defines.h   */
-
-#define UNARY_OP 01
-#define BINARY_OP 02
-
-#define SPECIAL_FMT NULL
-
-#define is_unary_op(x) (opcode_table[x].type == UNARY_OP)
-#define is_binary_op(x) (opcode_table[x].type == BINARY_OP)
-#define op_precedence(x) (opcode_table[x].prec)
-#define op_format(x) (opcode_table[x].format)
-
-/* _assoc_table -- encodes left-associativity and right-associativity
-   information; indexed by precedence level.  Only 2, 3, 14 are
-   right-associative.  Source:  Kernighan & Ritchie, p. 49 */
-
-extern char _assoc_table[];
-
-#define is_right_assoc(x) (_assoc_table [x])
-#define is_left_assoc(x) (! _assoc_table [x])
-
-
-typedef struct {
-    int type;			/* UNARY_OP or BINARY_OP */
-    int prec;			/* Precedence level, useful for adjusting
-				   number of parens to insert.  Zero is a
-				   special level, and 2, 3, 14 are
-				   right-associative */
-    char *format;
-} table_entry;
-
-
-extern char *fl_fmt_string;	/* Float constant format string */
-extern char *db_fmt_string;	/* Double constant format string */
-extern char *cm_fmt_string;	/* Complex constant format string */
-extern char *dcm_fmt_string;	/* Double Complex constant format string */
-
-extern int indent;		/* Number of spaces to indent; this is a
-				   temporary fix */
-extern int tab_size;		/* Number of spaces in each tab */
-extern int in_string;
-
-extern table_entry opcode_table[];
-
-
-void expr_out (), out_init (), out_addr (), out_const ();
-void out_name (), extern_out (), out_asgoto ();
-void out_if (), out_else (), elif_out ();
-void endif_out (), end_else_out ();
-void compgoto_out (), out_for ();
-void out_end_for (), out_and_free_statement ();
//GO.SYSIN DD output.h
echo p1defs.h 1>&2
sed >p1defs.h <<'//GO.SYSIN DD p1defs.h' 's/^-//'
-#define P1_UNKNOWN 0
-#define P1_COMMENT 1		/* Fortan comment string */
-#define P1_EOF 2		/* End of file dummy token */
-#define P1_SET_LINE 3		/* Reset the line counter */
-#define P1_FILENAME 4		/* Name of current input file */
-#define P1_NAME_POINTER 5	/* Pointer to hash table entry */
-#define P1_CONST 6		/* Some constant value */
-#define P1_EXPR 7		/* Followed by opcode */
-
-/* The next two tokens could be grouped together, since they always come
-   from an Addr structure */
-
-#define P1_IDENT 8		/* Char string identifier in addrp->user
-				   field */
-#define P1_EXTERN 9		/* Pointer to external symbol entry */
-
-#define P1_HEAD 10		/* Function header info */
-#define P1_LIST 11		/* A list of data (e.g. arguments) will
-				   follow the tag, type, and count */
-#define P1_LITERAL 12		/* Hold the index into the literal pool */
-#define P1_LABEL 13		/* label value */
-#define P1_ASGOTO 14		/* Store the hash table pointer of
-				   variable used in assigned goto */
-#define P1_GOTO 15		/* Store the statement number */
-#define P1_IF 16		/* store the condition as an expression */
-#define P1_ELSE 17		/* No data */
-#define P1_ELIF 18		/* store the condition as an expression */
-#define P1_ENDIF 19		/* Marks the end of a block IF */
-#define P1_ENDELSE 20		/* Marks the end of a block ELSE */
-#define P1_ADDR 21		/* Addr data; used for arrays, common and
-				   equiv addressing, NOT for names, idents
-				   or externs */
-#define P1_SUBR_RET 22		/* Subroutine return; the return expression
-				   follows */
-#define P1_COMP_GOTO 23		/* Computed goto; has expr, label list */
-#define P1_FOR 24		/* C FOR loop; three expressions follow */
-#define P1_ENDFOR 25		/* End of C FOR loop */
-#define P1_FORTRAN 26		/* original Fortran source */
-#define P1_CHARP 27		/* user.Charp field -- for long names */
-#define P1_WHILE1START 28	/* start of DO WHILE */
-#define P1_WHILE2START 29	/* rest of DO WHILE */
-#define P1_PROCODE 30		/* invoke procode() -- to adjust params */
-#define P1_ELSEIFSTART 31	/* handle extra code for abs, min, max
-				   in else if() */
-
-#define P1_FILENAME_MAX	256	/* max filename length to retain (for -g) */
-#define P1_STMTBUFSIZE 1400
-
-
-
-#define COMMENT_BUFFER_SIZE 255	/* max number of chars in each comment */
-#define CONSTANT_STR_MAX 1000	/* max number of chars in string constant */
-
-extern void p1put (/* int */);
-extern void p1_comment (/* char * */);
-extern void p1_label (/* int */);
-extern void p1_line_number (/* int */);
-extern void p1put_filename();
-extern void p1_expr (/* expptr */);
-extern void p1_head (/* int, char * */);
-extern void p1_if (/* expptr */);
-extern void p1_else ();
-extern void p1_elif (/* expptr */);
-extern void p1_endif ();
-extern void p1else_end ();
-extern void p1_subr_ret (/* expptr */);
-extern void p1_goto(/* long */);
-extern void p1comp_goto (/* expptr, int, struct Labelblock *[] */);
-extern void p1_for (/* expptr, expptr, expptr */);
-extern void p1for_end ();
-
-
-extern void p1puts (/* int, char * */);
-
-/* The pass 1 intermediate file has the following format:
-
-	<ascii-integer-rep> [ : [ <sp> [ <data> ]]] \n
-
-   e.g.   1: This is a comment
-
-   This format is destined to change in the future, but for now a readable
-   form is more desirable than a compact form.
-
-   NOTES ABOUT THE P1 FORMAT
-   ----------------------------------------------------------------------
-
-	P1_COMMENT:  The comment string (in   <data>)   may be at most
-		COMMENT_BUFFER_SIZE bytes long.  It must contain no newlines
-		or null characters.  A side effect of the way comments are
-		read in   lex.c   is that no '\377' chars may be in a
-		comment either.
-
-	P1_SET_LINE:  <data>  holds the line number in the current source file.
-
-	P1_INC_LINE:  Increment the source line number;   <data>   is empty.
-
-	P1_NAME_POINTER:  <data>   holds the integer representation of a
-			  pointer into a hash table entry.
-
-	P1_CONST:  the first field in   <data>   is a type tag (one of the
-		   TYxxxx   macros), the next field holds the constant
-		   value
-
-	P1_EXPR:  <data>   holds the opcode number of the expression,
-		  followed by the type of the expression (required for
-		  OPCONV).  Next is the value of   vleng.
-		  The type of operation represented by the
-		  opcode determines how many of the following data items
-		  are part of this expression.
-
-	P1_IDENT:  <data>   holds the type, then storage, then the
-		   char string identifier in the   addrp->user   field.
-
-	P1_EXTERN:  <data>   holds an offset into the external symbol
-		    table entry
-
-	P1_HEAD:  the first field in   <data>  is the procedure class, the
-		  second is the name of the procedure
-
-	P1_LIST:  the first field in   <data>   is the tag, the second the
-		  type of the list, the third the number of elements in
-		  the list
-
-	P1_LITERAL:  <data>   holds the   litnum   of a value in the
-		     literal pool.
-
-	P1_LABEL:  <data>   holds the statement number of the current
-		   line
-
-	P1_ASGOTO:  <data>   holds the hash table pointer of the variable
-
-	P1_GOTO:  <data>   holds the statement number to jump to
-
-	P1_IF:  <data>   is empty, the following expression is the IF
-	        condition.
-
-	P1_ELSE:  <data>   is empty.
-
-	P1_ELIF:  <data>   is empty, the following expression is the IF
-		  condition.
-
-	P1_ENDIF:  <data>   is empty.
-
-	P1_ENDELSE:  <data>   is empty.
-
-	P1_ADDR:   <data>   holds a direct copy of the structure.  The
-		  next expression is a copy of    vleng,   and the next a
-		  copy of    memoffset.
-
-	P1_SUBR_RET:  The next token is an expression for the return value.
-
-	P1_COMP_GOTO:  The next token is an integer expression, the
-		       following one a list of labels.
-
-	P1_FOR:  The next three expressions are the Init, Test, and
-	         Increment expressions of a C FOR loop.
-
-	P1_ENDFOR:  Marks the end of the body of a FOR loop
-
-*/
//GO.SYSIN DD p1defs.h
echo p1output.c 1>&2
sed >p1output.c <<'//GO.SYSIN DD p1output.c' 's/^-//'
-/****************************************************************
-Copyright 1990, 1991 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.
-****************************************************************/
-
-#include "defs.h"
-#include "p1defs.h"
-#include "output.h"
-#include "names.h"
-
-
-static void p1_addr(), p1_big_addr(), p1_binary(), p1_const(), p1_list(),
-	p1_literal(), p1_name(), p1_unary(), p1putn();
-static void p1putd (/* int, int */);
-static void p1putds (/* int, int, char * */);
-static void p1putdds (/* int, int, int, char * */);
-static void p1putdd (/* int, int, int */);
-static void p1putddd (/* int, int, int, int */);
-
-
-/* p1_comment -- save the text of a Fortran comment in the intermediate
-   file.  Make sure that there are no spurious "/ *" or "* /" characters by
-   mapping them onto "/+" and "+/".   str   is assumed to hold no newlines and be
-   null terminated; it may be modified by this function. */
-
-void p1_comment (str)
-char *str;
-{
-    register unsigned char *pointer, *ustr;
-
-    if (!str)
-	return;
-
-/* Get rid of any open or close comment combinations that may be in the
-   Fortran input */
-
-	ustr = (unsigned char *)str;
-	for(pointer = ustr; *pointer; pointer++)
-		if (*pointer == '*' && (pointer[1] == '/'
-					|| pointer > ustr && pointer[-1] == '/'))
-			*pointer = '+';
-	/* trim trailing white space */
-#ifdef isascii
-	while(--pointer >= ustr && (!isascii(*pointer) || isspace(*pointer)));
-#else
-	while(--pointer >= ustr && isspace(*pointer));
-#endif
-	pointer[1] = 0;
-	p1puts (P1_COMMENT, str);
-} /* p1_comment */
-
-void p1_line_number (line_number)
-long line_number;
-{
-
-    p1putd (P1_SET_LINE, line_number);
-} /* p1_line_number */
-
-/* p1_name -- Writes the address of a hash table entry into the
-   intermediate file */
-
-static void p1_name (namep)
-Namep namep;
-{
-	p1putd (P1_NAME_POINTER, (long) namep);
-	namep->visused = 1;
-} /* p1_name */
-
-
-
-void p1_expr (expr)
-expptr expr;
-{
-/* An opcode of 0 means a null entry */
-
-    if (expr == ENULL) {
-	p1putdd (P1_EXPR, 0, TYUNKNOWN);	/* Should this be TYERROR? */
-	return;
-    } /* if (expr == ENULL) */
-
-    switch (expr -> tag) {
-        case TNAME:
-		p1_name ((Namep) expr);
-		return;
-	case TCONST:
-		p1_const(&expr->constblock);
-		return;
-	case TEXPR:
-		/* Fall through the switch */
-		break;
-	case TADDR:
-		p1_addr (&(expr -> addrblock));
-		goto freeup;
-	case TPRIM:
-		warn ("p1_expr:  got TPRIM");
-		return;
-	case TLIST:
-		p1_list (&(expr->listblock));
-		frchain( &(expr->listblock.listp) );
-		return;
-	case TERROR:
-		return;
-	default:
-		erri ("p1_expr: bad tag '%d'", (int) (expr -> tag));
-		return;
-	}
-
-/* Now we know that the tag is TEXPR */
-
-    if (is_unary_op (expr -> exprblock.opcode))
-	p1_unary (&(expr -> exprblock));
-    else if (is_binary_op (expr -> exprblock.opcode))
-	p1_binary (&(expr -> exprblock));
-    else
-	erri ("p1_expr:  bad opcode '%d'", (int) expr -> exprblock.opcode);
- freeup:
-    free((char *)expr);
-
-} /* p1_expr */
-
-
-
-static void p1_const(cp)
- register Constp cp;
-{
-	int type = cp->vtype;
-	expptr vleng = cp->vleng;
-	union Constant *c = &cp->Const;
-	char cdsbuf0[64], cdsbuf1[64];
-	char *cds0, *cds1;
-
-    switch (type) {
-        case TYSHORT:
-	case TYLONG:
-	case TYLOGICAL:
-	    fprintf(pass1_file, "%d: %d %ld\n", P1_CONST, type, c->ci);
-	    break;
-	case TYREAL:
-	case TYDREAL:
-		fprintf(pass1_file, "%d: %d %s\n", P1_CONST, type,
-			cp->vstg ? c->cds[0] : cds(dtos(c->cd[0]), cdsbuf0));
-	    break;
-	case TYCOMPLEX:
-	case TYDCOMPLEX:
-		if (cp->vstg) {
-			cds0 = c->cds[0];
-			cds1 = c->cds[1];
-			}
-		else {
-			cds0 = cds(dtos(c->cd[0]), cdsbuf0);
-			cds1 = cds(dtos(c->cd[1]), cdsbuf1);
-			}
-		fprintf(pass1_file, "%d: %d %s %s\n", P1_CONST, type,
-			cds0, cds1);
-	    break;
-	case TYCHAR:
-	    if (vleng && !ISICON (vleng))
-		erri("p1_const:  bad vleng '%d'\n", (int) vleng);
-	    else
-		fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type,
-			cpexpr((expptr)cp));
-	    break;
-	default:
-	    erri ("p1_const:  bad constant type '%d'", type);
-	    break;
-    } /* switch */
-} /* p1_const */
-
-
-void p1_asgoto (addrp)
-Addrp addrp;
-{
-    p1put (P1_ASGOTO);
-    p1_addr (addrp);
-} /* p1_asgoto */
-
-
-void p1_goto (stateno)
-ftnint stateno;
-{
-    p1putd (P1_GOTO, stateno);
-} /* p1_goto */
-
-
-static void p1_addr (addrp)
- register struct Addrblock *addrp;
-{
-    int stg;
-
-    if (addrp == (struct Addrblock *) NULL)
-	return;
-
-    stg = addrp -> vstg;
-
-    if (ONEOF(stg, M(STGINIT)|M(STGREG))
-	|| ONEOF(stg, M(STGCOMMON)|M(STGEQUIV)) &&
-		(!ISICON(addrp->memoffset)
-		|| (addrp->uname_tag == UNAM_NAME
-			? addrp->memoffset->constblock.Const.ci
-				!= addrp->user.name->voffset
-			: addrp->memoffset->constblock.Const.ci))
-	|| ONEOF(stg, M(STGBSS)|M(STGINIT)|M(STGAUTO)|M(STGARG)) &&
-		(!ISICON(addrp->memoffset)
-			|| addrp->memoffset->constblock.Const.ci)
-	|| addrp->Field || addrp->isarray || addrp->vstg == STGLENG)
-	{
-		p1_big_addr (addrp);
-		return;
-	}
-
-/* Write out a level of indirection for non-array arguments, which have
-   addrp -> memoffset   set and are handled by   p1_big_addr().
-   Lengths are passed by value, so don't check STGLENG
-   28-Jun-89 (dmg)  Added the check for != TYCHAR
- */
-
-    if (oneof_stg ( addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : NULL,
-	    stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) {
-	p1putdd (P1_EXPR, OPWHATSIN, addrp -> vtype);
-	p1_expr (ENULL);	/* Put dummy   vleng   */
-    } /* if stg == STGARG */
-
-    switch (addrp -> uname_tag) {
-        case UNAM_NAME:
-	    p1_name (addrp -> user.name);
-	    break;
-	case UNAM_IDENT:
-	    p1putdds(P1_IDENT, addrp->vtype, addrp->vstg,
-				addrp->user.ident);
-	    break;
-	case UNAM_CHARP:
-		p1putdds(P1_CHARP, addrp->vtype, addrp->vstg,
-				addrp->user.Charp);
-		break;
-	case UNAM_EXTERN:
-	    p1putd (P1_EXTERN, (long) addrp -> memno);
-	    if (addrp->vclass == CLPROC)
-		extsymtab[addrp->memno].extype = addrp->vtype;
-	    break;
-	case UNAM_CONST:
-	    if (addrp -> memno != BAD_MEMNO)
-		p1_literal (addrp -> memno);
-	    else
-		p1_const((struct Constblock *)addrp);
-	    break;
-	case UNAM_UNKNOWN:
-	default:
-	    erri ("p1_addr:  unknown uname_tag '%d'", addrp -> uname_tag);
-	    break;
-    } /* switch */
-} /* p1_addr */
-
-
-static void p1_list (listp)
-struct Listblock *listp;
-{
-    chainp lis;
-    int count = 0;
-
-    if (listp == (struct Listblock *) NULL)
-	return;
-
-/* Count the number of parameters in the list */
-
-    for (lis = listp -> listp; lis; lis = lis -> nextp)
-	count++;
-
-    p1putddd (P1_LIST, listp -> tag, listp -> vtype, count);
-
-    for (lis = listp -> listp; lis; lis = lis -> nextp)
-	p1_expr ((expptr) lis -> datap);
-
-} /* p1_list */
-
-
-void p1_label (lab)
-long lab;
-{
-	if (parstate < INDATA)
-		earlylabs = mkchain((char *)lab, earlylabs);
-	else
-		p1putd (P1_LABEL, lab);
-	}
-
-
-
-static void p1_literal (memno)
-long memno;
-{
-    p1putd (P1_LITERAL, memno);
-} /* p1_literal */
-
-
-void p1_if (expr)
-expptr expr;
-{
-    p1put (P1_IF);
-    p1_expr (expr);
-} /* p1_if */
-
-
-
-
-void p1_elif (expr)
-expptr expr;
-{
-    p1put (P1_ELIF);
-    p1_expr (expr);
-} /* p1_elif */
-
-
-
-
-void p1_else ()
-{
-    p1put (P1_ELSE);
-} /* p1_else */
-
-
-
-
-void p1_endif ()
-{
-    p1put (P1_ENDIF);
-} /* p1_endif */
-
-
-
-
-void p1else_end ()
-{
-    p1put (P1_ENDELSE);
-} /* p1else_end */
-
-
-static void p1_big_addr (addrp)
-Addrp addrp;
-{
-    if (addrp == (Addrp) NULL)
-	return;
-
-    p1putn (P1_ADDR, (int)sizeof(struct Addrblock), (char *) addrp);
-    p1_expr (addrp -> vleng);
-    p1_expr (addrp -> memoffset);
-    if (addrp->uname_tag == UNAM_NAME)
-	addrp->user.name->visused = 1;
-} /* p1_big_addr */
-
-
-
-static void p1_unary (e)
-struct Exprblock *e;
-{
-    if (e == (struct Exprblock *) NULL)
-	return;
-
-    p1putdd (P1_EXPR, (int) e -> opcode, e -> vtype);
-    p1_expr (e -> vleng);
-
-    switch (e -> opcode) {
-        case OPNEG:
-	case OPNEG1:
-	case OPNOT:
-	case OPABS:
-	case OPBITNOT:
-	case OPPREINC:
-	case OPPREDEC:
-	case OPADDR:
-	case OPIDENTITY:
-	case OPCHARCAST:
-	case OPDABS:
-	    p1_expr(e -> leftp);
-	    break;
-	default:
-	    erri ("p1_unary: bad opcode '%d'", (int) e -> opcode);
-	    break;
-    } /* switch */
-
-} /* p1_unary */
-
-
-static void p1_binary (e)
-struct Exprblock *e;
-{
-    if (e == (struct Exprblock *) NULL)
-	return;
-
-    p1putdd (P1_EXPR, e -> opcode, e -> vtype);
-    p1_expr (e -> vleng);
-    p1_expr (e -> leftp);
-    p1_expr (e -> rightp);
-} /* p1_binary */
-
-
-void p1_head (class, name)
-int class;
-char *name;
-{
-    p1putds (P1_HEAD, class, name ? name : "");
-} /* p1_head */
-
-
-void p1_subr_ret (retexp)
-expptr retexp;
-{
-
-    p1put (P1_SUBR_RET);
-    p1_expr (cpexpr(retexp));
-} /* p1_subr_ret */
-
-
-
-void p1comp_goto (index, count, labels)
-expptr index;
-int count;
-struct Labelblock *labels[];
-{
-    struct Constblock c;
-    int i;
-    register struct Labelblock *L;
-
-    p1put (P1_COMP_GOTO);
-    p1_expr (index);
-
-/* Write out a P1_LIST directly, to avoid the overhead of allocating a
-   list before it's needed HACK HACK HACK */
-
-    p1putddd (P1_LIST, TLIST, TYUNKNOWN, count);
-    c.vtype = TYLONG;
-    c.vleng = 0;
-
-    for (i = 0; i < count; i++) {
-	L = labels[i];
-	L->labused = 1;
-	c.Const.ci = L->stateno;
-	p1_const(&c);
-    } /* for i = 0 */
-} /* p1comp_goto */
-
-
-
-void p1_for (init, test, inc)
-expptr init, test, inc;
-{
-    p1put (P1_FOR);
-    p1_expr (init);
-    p1_expr (test);
-    p1_expr (inc);
-} /* p1_for */
-
-
-void p1for_end ()
-{
-    p1put (P1_ENDFOR);
-} /* p1for_end */
-
-
-
-
-/* ----------------------------------------------------------------------
-   The intermediate file actually gets written ONLY by the routines below.
-   To change the format of the file, you need only change these routines.
-   ----------------------------------------------------------------------
-*/
-
-
-/* p1puts -- Put a typed string into the Pass 1 intermediate file.  Assumes that
-   str   contains no newlines and is null-terminated. */
-
-void p1puts (type, str)
-int type;
-char *str;
-{
-    fprintf (pass1_file, "%d: %s\n", type, str);
-} /* p1puts */
-
-
-/* p1putd -- Put a typed integer into the Pass 1 intermediate file. */
-
-static void p1putd (type, value)
-int type;
-long value;
-{
-    fprintf (pass1_file, "%d: %ld\n", type, value);
-} /* p1_putd */
-
-
-/* p1putdd -- Put a typed pair of integers into the intermediate file. */
-
-static void p1putdd (type, v1, v2)
-int type, v1, v2;
-{
-    fprintf (pass1_file, "%d: %d %d\n", type, v1, v2);
-} /* p1putdd */
-
-
-/* p1putddd -- Put a typed triple of integers into the intermediate file. */
-
-static void p1putddd (type, v1, v2, v3)
-int type, v1, v2, v3;
-{
-    fprintf (pass1_file, "%d: %d %d %d\n", type, v1, v2, v3);
-} /* p1putddd */
-
- union dL {
-	double d;
-	long L[2];
-	};
-
-static void p1putn (type, count, str)
-int type, count;
-char *str;
-{
-    int i;
-
-    fprintf (pass1_file, "%d: ", type);
-
-    for (i = 0; i < count; i++)
-	putc (str[i], pass1_file);
-
-    putc ('\n', pass1_file);
-} /* p1putn */
-
-
-
-/* p1put -- Put a type marker into the intermediate file. */
-
-void p1put(type)
-int type;
-{
-    fprintf (pass1_file, "%d:\n", type);
-} /* p1put */
-
-
-
-static void p1putds (type, i, str)
-int type;
-int i;
-char *str;
-{
-    fprintf (pass1_file, "%d: %d %s\n", type, i, str);
-} /* p1putds */
-
-
-static void p1putdds (token, type, stg, str)
-int token, type, stg;
-char *str;
-{
-    fprintf (pass1_file, "%d: %d %d %s\n", token, type, stg, str);
-} /* p1putdds */
//GO.SYSIN DD p1output.c
echo parse.h 1>&2
sed >parse.h <<'//GO.SYSIN DD parse.h' 's/^-//'
-#ifndef PARSE_INCLUDE
-#define PARSE_INCLUDE
-
-/* macros for the   parse_args   routine */
-
-#define P_STRING 1		/* Macros for the result_type attribute */
-#define P_CHAR 2
-#define P_SHORT 3
-#define P_INT 4
-#define P_LONG 5
-#define P_FILE 6
-#define P_OLD_FILE 7
-#define P_NEW_FILE 8
-#define P_FLOAT 9
-#define P_DOUBLE 10
-
-#define P_CASE_INSENSITIVE 01	/* Macros for the   flags   attribute */
-#define P_REQUIRED_PREFIX 02
-
-#define P_NO_ARGS 0		/* Macros for the   arg_count   attribute */
-#define P_ONE_ARG 1
-#define P_INFINITE_ARGS 2
-
-#define p_entry(pref,swit,flag,count,type,store,size) \
-    { (pref), (swit), (flag), (count), (type), (int *) (store), (size) }
-
-typedef struct {
-    char *prefix;
-    char *string;
-    int flags;
-    int count;
-    int result_type;
-    int *result_ptr;
-    int table_size;
-} arg_info;
-
-extern int parse_args ();
-
-#endif
//GO.SYSIN DD parse.h
echo parse_args.c 1>&2
sed >parse_args.c <<'//GO.SYSIN DD parse_args.c' 's/^-//'
-/****************************************************************
-Copyright 1990 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.
-****************************************************************/
-
-/* parse_args
-
-	This function will parse command line input into appropriate data
-   structures, output error messages when appropriate and provide some
-   minimal type conversion.
-
-	Input to the function consists of the standard   argc,argv
-   values, and a table which directs the parser.  Each table entry has the
-   following components:
-
-	prefix -- the (optional) switch character string, e.g. "-" "/" "="
-	switch -- the command string, e.g. "o" "data" "file" "F"
-	flags -- control flags, e.g.   CASE_INSENSITIVE, REQUIRED_PREFIX
-	arg_count -- number of arguments this command requires, e.g. 0 for
-		     booleans, 1 for filenames, INFINITY for input files
-	result_type -- how to interpret the switch arguments, e.g. STRING,
-		       CHAR, FILE, OLD_FILE, NEW_FILE
-	result_ptr -- pointer to storage for the result, be it a table or
-		      a string or whatever
-	table_size -- if the arguments fill a table, the maximum number of
-		      entries; if there are no arguments, the value to
-		      load into the result storage
-
-	Although the table can be used to hold a list of filenames, only
-   scalar values (e.g. pointers) can be stored in the table.  No vector
-   processing will be done, only pointers to string storage will be moved.
-
-	An example entry, which could be used to parse input filenames, is:
-
-	"-", "o", 0, oo, OLD_FILE, infilenames, INFILE_TABLE_SIZE
-
-*/
-
-#include <stdio.h>
-#ifndef NULL
-/* ANSI C */
-#include <stddef.h>
-#endif
-#include "parse.h"
-#include <math.h>	     /* For atof */
-#include <ctype.h>
-
-#define MAX_INPUT_SIZE 1000
-
-#define arg_prefix(x) ((x).prefix)
-#define arg_string(x) ((x).string)
-#define arg_flags(x) ((x).flags)
-#define arg_count(x) ((x).count)
-#define arg_result_type(x) ((x).result_type)
-#define arg_result_ptr(x) ((x).result_ptr)
-#define arg_table_size(x) ((x).table_size)
-
-#ifndef TRUE
-#define TRUE 1
-#endif
-#ifndef FALSE
-#define FALSE 0
-#endif
-typedef int boolean;
-
-
-char *lower_string (/* char [], char * */);
-
-static char *this_program = "";
-
-extern long atol();
-static int arg_parse (/* char *, arg_info * */);
-
-
-boolean parse_args (argc, argv, table, entries, others, other_count)
-int argc;
-char *argv[];
-arg_info table[];
-int entries;
-char *others[];
-int other_count;
-{
-    boolean arg_verify (/* argv, table, entries */);
-    void init_store (/* table, entries */);
-
-    boolean result;
-
-    if (argv)
-	this_program = argv[0];
-
-/* Check the validity of the table and its parameters */
-
-    result = arg_verify (argv, table, entries);
-
-/* Initialize the storage values */
-
-    init_store (table, entries);
-
-    if (result) {
-	boolean use_prefix = TRUE;
-	char *argv0;
-
-	argc--;
-	argv0 = *++argv;
-	while (argc) {
-	    int index, length;
-
-	    index = match_table (*argv, table, entries, use_prefix, &length);
-	    if (index < 0) {
-
-/* The argument doesn't match anything in the table */
-
-		if (others) {
-
-		    if (*argv > argv0)
-			*--*argv = '-';	/* complain at invalid flag */
-
-		    if (other_count > 0) {
-			*others++ = *argv;
-			other_count--;
-		    } else {
-			fprintf (stderr, "%s:  too many parameters: ",
-				this_program);
-			fprintf (stderr, "'%s' ignored\n", *argv);
-		    } /* else */
-		} /* if (others) */
-		argv0 = *++argv;
-		argc--;
-	    } else {
-
-/* A match was found */
-
-		if (length >= strlen (*argv)) {
-		    argc--;
-		    argv0 = *++argv;
-		    use_prefix = TRUE;
-		} else {
-		    (*argv) += length;
-		    use_prefix = FALSE;
-		} /* else */
-
-/* Parse any necessary arguments */
-
-		if (arg_count (table[index]) != P_NO_ARGS) {
-
-/* Now   length   will be used to store the number of parsed characters */
-
-		    length = arg_parse(*argv, &table[index]);
-		    if (*argv == NULL)
-			argc = 0;
-		    else if (length >= strlen (*argv)) {
-			argc--;
-			argv0 = *++argv;
-			use_prefix = TRUE;
-		    } else {
-			(*argv) += length;
-			use_prefix = FALSE;
-		    } /* else */
-		} /* if (argv_count != P_NO_ARGS) */
-		  else
-		    *arg_result_ptr(table[index]) =
-			    arg_table_size(table[index]);
-	    } /* else */
-	} /* while (argc) */
-    } /* if (result) */
-
-    return result;
-} /* parse_args */
-
-
-boolean arg_verify (argv, table, entries)
-char *argv[];
-arg_info table[];
-int entries;
-{
-    int i;
-    char *this_program = "";
-
-    if (argv)
-	this_program = argv[0];
-
-    for (i = 0; i < entries; i++) {
-	arg_info *arg = &table[i];
-
-/* Check the argument flags */
-
-	if (arg_flags (*arg) & ~(P_CASE_INSENSITIVE | P_REQUIRED_PREFIX)) {
-	    fprintf (stderr, "%s [arg_verify]:  too many ", this_program);
-	    fprintf (stderr, "flags in entry %d:  '%x' (hex)\n", i,
-		    arg_flags (*arg));
-	} /* if */
-
-/* Check the argument count */
-
-	{ int count = arg_count (*arg);
-
-	    if (count != P_NO_ARGS && count != P_ONE_ARG && count !=
-		    P_INFINITE_ARGS) {
-		fprintf (stderr, "%s [arg_verify]:  invalid ", this_program);
-		fprintf (stderr, "argument count in entry %d:  '%d'\n", i,
-			count);
-	    } /* if count != P_NO_ARGS ... */
-
-/* Check the result field; want to be able to store results */
-
-	      else
-		if (arg_result_ptr (*arg) == (int *) NULL) {
-		    fprintf (stderr, "%s [arg_verify]:  ", this_program);
-		    fprintf (stderr, "no argument storage given for ");
-		    fprintf (stderr, "entry %d\n", i);
-		} /* if arg_result_ptr */
-	}
-
-/* Check the argument type */
-
-	{ int type = arg_result_type (*arg);
-
-	    if (type < P_STRING || type > P_DOUBLE)
-		    fprintf(stderr,
-			"%s [arg_verify]:  bad arg type in entry %d:  '%d'\n",
-			this_program, i, type);
-	}
-
-/* Check table size */
-
-	{ int size = arg_table_size (*arg);
-
-	    if (arg_count (*arg) == P_INFINITE_ARGS && size < 1) {
-		fprintf (stderr, "%s [arg_verify]:  bad ", this_program);
-		fprintf (stderr, "table size in entry %d:  '%d'\n", i,
-			size);
-	    } /* if (arg_count == P_INFINITE_ARGS && size < 1) */
-	}
-
-    } /* for i = 0 */
-
-    return TRUE;
-} /* arg_verify */
-
-
-/* match_table -- returns the index of the best entry matching the input,
-   -1 if no match.  The best match is the one of longest length which
-   appears lowest in the table.  The length of the match will be returned
-   in   length   ONLY IF a match was found.   */
-
-int match_table (norm_input, table, entries, use_prefix, length)
-register char *norm_input;
-arg_info table[];
-int entries;
-boolean use_prefix;
-int *length;
-{
-    extern int match (/* char *, char *, arg_info *, boolean */);
-
-    char low_input[MAX_INPUT_SIZE];
-    register int i;
-    int best_index = -1, best_length = 0;
-
-/* FUNCTION BODY */
-
-    (void) lower_string (low_input, norm_input);
-
-    for (i = 0; i < entries; i++) {
-	int this_length = match (norm_input, low_input, &table[i], use_prefix);
-
-	if (this_length > best_length) {
-	    best_index = i;
-	    best_length = this_length;
-	} /* if (this_length > best_length) */
-    } /* for (i = 0) */
-
-    if (best_index > -1 && length != (int *) NULL)
-	*length = best_length;
-
-    return best_index;
-} /* match_table */
-
-
-/* match -- takes an input string and table entry, and returns the length
-   of the longer match.
-
-	0 ==> input doesn't match
-
-   For example:
-
-	INPUT	PREFIX	STRING	RESULT
-----------------------------------------------------------------------
-	"abcd"	"-"	"d"	0
-	"-d"	"-"	"d"	2    (i.e. "-d")
-	"dout"	"-"	"d"	1    (i.e. "d")
-	"-d"	""	"-d"	2    (i.e. "-d")
-	"dd"	"d"	"d"	2	<= here's the weird one
-*/
-
-int match (norm_input, low_input, entry, use_prefix)
-char *norm_input, *low_input;
-arg_info *entry;
-boolean use_prefix;
-{
-    char *norm_prefix = arg_prefix (*entry);
-    char *norm_string = arg_string (*entry);
-    boolean prefix_match = FALSE, string_match = FALSE;
-    int result = 0;
-
-/* Buffers for the lowercased versions of the strings being compared.
-   These are used when the switch is to be case insensitive */
-
-    static char low_prefix[MAX_INPUT_SIZE];
-    static char low_string[MAX_INPUT_SIZE];
-    int prefix_length = strlen (norm_prefix);
-    int string_length = strlen (norm_string);
-
-/* Pointers for the required strings (lowered or nonlowered) */
-
-    register char *input, *prefix, *string;
-
-/* FUNCTION BODY */
-
-/* Use the appropriate strings to handle case sensitivity */
-
-    if (arg_flags (*entry) & P_CASE_INSENSITIVE) {
-	input = low_input;
-	prefix = lower_string (low_prefix, norm_prefix);
-	string = lower_string (low_string, norm_string);
-    } else {
-	input = norm_input;
-	prefix = norm_prefix;
-	string = norm_string;
-    } /* else */
-
-/* First, check the string formed by concatenating the prefix onto the
-   switch string, but only when the prefix is not being ignored */
-
-    if (use_prefix && prefix != NULL && *prefix != '\0')
-	 prefix_match = (strncmp (input, prefix, prefix_length) == 0) &&
-		(strncmp (input + prefix_length, string, string_length) == 0);
-
-/* Next, check just the switch string, if that's allowed */
-
-    if (!use_prefix && (arg_flags (*entry) & P_REQUIRED_PREFIX) == 0)
-	string_match = strncmp (input, string, string_length) == 0;
-
-    if (prefix_match)
-	result = prefix_length + string_length;
-    else if (string_match)
-	result = string_length;
-
-    return result;
-} /* match */
-
-
-char *lower_string (dest, src)
-char *dest, *src;
-{
-    char *result = dest;
-    register int c;
-
-    if (dest == NULL || src == NULL)
-	result = NULL;
-    else
-	while (*dest++ = (c = *src++) >= 'A' && c <= 'Z' ? tolower(c) : c);
-
-    return result;
-} /* lower_string */
-
-
-/* arg_parse -- returns the number of characters parsed for this entry */
-
-static int arg_parse (str, entry)
-char *str;
-arg_info *entry;
-{
-    int length = 0;
-
-    if (arg_count (*entry) == P_ONE_ARG) {
-	char **store = (char **) arg_result_ptr (*entry);
-
-	length = put_one_arg (arg_result_type (*entry), str, store,
-		arg_prefix (*entry), arg_string (*entry));
-
-    } /* if (arg_count == P_ONE_ARG) */
-      else { /* Must be a table of arguments */
-	char **store = (char **) arg_result_ptr (*entry);
-
-	if (store) {
-	    while (*store)
-		store++;
-
-	    length = put_one_arg (arg_result_type (*entry), str, store++,
-		    arg_prefix (*entry), arg_string (*entry));
-
-	    *store = (char *) NULL;
-	} /* if (store) */
-    } /* else */
-
-    return length;
-} /* arg_parse */
-
-
-int put_one_arg (type, str, store, prefix, string)
-int type;
-char *str;
-char **store;
-char *prefix, *string;
-{
-    int length = 0;
-    long L;
-
-    if (store) {
-	switch (type) {
-	    case P_STRING:
-	    case P_FILE:
-	    case P_OLD_FILE:
-	    case P_NEW_FILE:
-		*store = str;
-		if (str == NULL)
-		    fprintf (stderr, "%s: Missing argument after '%s%s'\n",
-			    this_program, prefix, string);
-		length = str ? strlen (str) : 0;
-		break;
-	    case P_CHAR:
-		*((char *) store) = *str;
-		length = 1;
-		break;
-	    case P_SHORT:
-		L = atol(str);
-		*(short *)store = (short) L;
-		if (L != *(short *)store)
-		    fprintf(stderr,
-	"%s%s parameter '%ld' is not a SHORT INT (truncating to %d)\n",
-			    prefix, string, L, *(short *)store);
-		length = strlen (str);
-		break;
-	    case P_INT:
-		L = atol(str);
-		*(int *)store = (int)L;
-		if (L != *(int *)store)
-		    fprintf(stderr,
-	"%s%s parameter '%ld' is not an INT (truncating to %d)\n",
-			    prefix, string, L, *(int *)store);
-		length = strlen (str);
-		break;
-	    case P_LONG:
-		*(long *)store = atol(str);
-		length = strlen (str);
-		break;
-	    case P_FLOAT:
-		*((float *) store) = (float) atof (str);
-		length = strlen (str);
-		break;
-	    case P_DOUBLE:
-		*((double *) store) = (double) atof (str);
-		length = strlen (str);
-		break;
-	    default:
-		fprintf (stderr, "put_one_arg:  bad type '%d'\n",
-			type);
-		break;
-	} /* switch */
-    } /* if (store) */
-
-    return length;
-} /* put_one_arg */
-
-
-void init_store (table, entries)
-arg_info *table;
-int entries;
-{
-    int index;
-
-    for (index = 0; index < entries; index++)
-	if (arg_count (table[index]) == P_INFINITE_ARGS) {
-	    char **place = (char **) arg_result_ptr (table[index]);
-
-	    if (place)
-		*place = (char *) NULL;
-	} /* if arg_count == P_INFINITE_ARGS */
-
-} /* init_store */
-
//GO.SYSIN DD parse_args.c
echo pccdefs.h 1>&2
sed >pccdefs.h <<'//GO.SYSIN DD pccdefs.h' 's/^-//'
-/* The following numbers are strange, and implementation-dependent */
-
-#define P2BAD -1
-#define P2NAME 2
-#define P2ICON 4		/* Integer constant */
-#define P2PLUS 6
-#define P2PLUSEQ 7
-#define P2MINUS 8
-#define P2NEG 10
-#define P2STAR 11
-#define P2STAREQ 12
-#define P2INDIRECT 13
-#define P2BITAND 14
-#define P2BITOR 17
-#define P2BITXOR 19
-#define P2QUEST 21
-#define P2COLON 22
-#define P2ANDAND 23
-#define P2OROR 24
-#define P2GOTO 37
-#define P2LISTOP 56
-#define P2ASSIGN 58
-#define P2COMOP 59
-#define P2SLASH 60
-#define P2MOD 62
-#define P2LSHIFT 64
-#define P2RSHIFT 66
-#define P2CALL 70
-#define P2CALL0 72
-
-#define P2NOT 76
-#define P2BITNOT 77
-#define P2EQ 80
-#define P2NE 81
-#define P2LE 82
-#define P2LT 83
-#define P2GE 84
-#define P2GT 85
-#define P2REG 94
-#define P2OREG 95
-#define P2CONV 104
-#define P2FORCE 108
-#define P2CBRANCH 109
-
-/* special operators included only for fortran's use */
-
-#define P2PASS 200
-#define P2STMT 201
-#define P2SWITCH 202
-#define P2LBRACKET 203
-#define P2RBRACKET 204
-#define P2EOF 205
-#define P2ARIF 206
-#define P2LABEL 207
-
-#define P2SHORT 3
-#define P2INT 4
-#define P2LONG 4
-
-#define P2CHAR 2
-#define P2REAL 6
-#define P2DREAL 7
-#define P2PTR 020
-#define P2FUNCT 040
//GO.SYSIN DD pccdefs.h
echo pread.c 1>&2
sed >pread.c <<'//GO.SYSIN DD pread.c' 's/^-//'
-/****************************************************************
-Copyright 1990 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.
-****************************************************************/
-
-#include "defs.h"
-
- static char Ptok[128], Pct[Table_size];
- static char *Pfname;
- static long Plineno;
- static int Pbad;
- static int *tfirst, *tlast, *tnext, tmax;
-
-#define P_space	1
-#define P_anum	2
-#define P_delim	3
-#define P_slash	4
-
-#define TGULP	100
-
- static void
-trealloc()
-{
-	int k = tmax;
-	tfirst = (int *)realloc((char *)tfirst,
-		(tmax += TGULP)*sizeof(int));
-	if (!tfirst) {
-		fprintf(stderr,
-		"Pfile: realloc failure!\n");
-		exit(2);
-		}
-	tlast = tfirst + tmax;
-	tnext = tfirst + k;
-	}
-
- static void
-badchar(c)
- int c;
-{
-	fprintf(stderr,
-		"unexpected character 0x%.2x = '%c' on line %ld of %s\n",
-		c, c, Plineno, Pfname);
-	exit(2);
-	}
-
- static void
-bad_type()
-{
-	fprintf(stderr,
-		"unexpected type \"%s\" on line %ld of %s\n",
-		Ptok, Plineno, Pfname);
-	exit(2);
-	}
-
- static void
-badflag(tname, option)
- char *tname, *option;
-{
-	fprintf(stderr, "%s type from `f2c -%s` on line %ld of %s\n",
-		tname, option, Plineno, Pfname);
-	Pbad++;
-	}
-
- static void
-detected(msg)
- char *msg;
-{
-	fprintf(stderr,
-	"%sdetected on line %ld of %s\n", msg, Plineno, Pfname);
-	Pbad++;
-	}
-
- static void
-checklogical(k)
- int k;
-{
-	static int lastmsg = 0;
-	static int seen[2] = {0,0};
-
-	seen[k] = 1;
-	if (seen[1-k]) {
-		if (lastmsg < 3) {
-			lastmsg = 3;
-			detected(
-	"Illegal combination of LOGICAL types -- mixing -I4 with -I2 or -i2\n\t");
-			}
-		return;
-		}
-	if (k) {
-		if (tylogical == TYLONG || lastmsg >= 2)
-			return;
-		if (!lastmsg) {
-			lastmsg = 2;
-			badflag("LOGICAL", "I4");
-			}
-		}
-	else {
-		if (tylogical == TYSHORT || lastmsg & 1)
-			return;
-		if (!lastmsg) {
-			lastmsg = 1;
-			badflag("LOGICAL", "i2` or `f2c -I2");
-			}
-		}
-	}
-
- static void
-checkreal(k)
-{
-	static int warned = 0;
-	static int seen[2] = {0,0};
-
-	seen[k] = 1;
-	if (seen[1-k]) {
-		if (warned < 2)
-			detected("Illegal mixture of -R and -!R ");
-		warned = 2;
-		return;
-		}
-	if (k == forcedouble || warned)
-		return;
-	warned = 1;
-	badflag("REAL return", k ? "!R" : "R");
-	}
-
- static void
-Pnotboth(e)
- Extsym *e;
-{
-	if (e->curno)
-		return;
-	Pbad++;
-	e->curno = 1;
-	fprintf(stderr,
-	"%s cannot be both a procedure and a common block (line %ld of %s)\n",
-		e->fextname, Plineno, Pfname);
-	}
-
- static int
-numread(pf, n)
- register FILE *pf;
- int *n;
-{
-	register int c, k;
-
-	if ((c = getc(pf)) < '0' || c > '9')
-		return c;
-	k = c - '0';
-	for(;;) {
-		if ((c = getc(pf)) == ' ') {
-			*n = k;
-			return c;
-			}
-		if (c < '0' || c > '9')
-			break;
-		k = 10*k + c - '0';
-		}
-	return c;
-	}
-
- static void argverify(), Pbadret();
-
- static int
-readref(pf, e, ftype)
- register FILE *pf;
- Extsym *e;
- int ftype;
-{
-	register int c, *t;
-	int i, nargs, type;
-	Argtypes *at;
-	Atype *a, *ae;
-
-	if (ftype > TYSUBR)
-		return 0;
-	if ((c = numread(pf, &nargs)) != ' ') {
-		if (c != ':')
-			return c == EOF;
-		/* just a typed external */
-		if (e->extstg == STGUNKNOWN) {
-			at = 0;
-			goto justsym;
-			}
-		if (e->extstg == STGEXT) {
-			if (e->extype != ftype)
-				Pbadret(ftype, e);
-			}
-		else
-			Pnotboth(e);
-		return 0;
-		}
-
-	tnext = tfirst;
-	for(i = 0; i < nargs; i++) {
-		if ((c = numread(pf, &type)) != ' '
-		|| type >= 500
-		|| type != TYFTNLEN + 100 && type % 100 > TYSUBR)
-			return c == EOF;
-		if (tnext >= tlast)
-			trealloc();
-		*tnext++ = type;
-		}
-
-	if (e->extstg == STGUNKNOWN) {
- save_at:
-		at = (Argtypes *)
-			gmem(sizeof(Argtypes) + (nargs-1)*sizeof(Atype), 1);
-		at->dnargs = at->nargs = nargs;
-		at->changes = 0;
-		t = tfirst;
-		a = at->atypes;
-		for(ae = a + nargs; a < ae; a++) {
-			a->type = *t++;
-			a->cp = 0;
-			}
- justsym:
-		e->extstg = STGEXT;
-		e->extype = ftype;
-		e->arginfo = at;
-		}
-	else if (e->extstg != STGEXT) {
-		Pnotboth(e);
-		}
-	else if (!e->arginfo) {
-		if (e->extype != ftype)
-			Pbadret(ftype, e);
-		else
-			goto save_at;
-		}
-	else
-		argverify(ftype, e);
-	return 0;
-	}
-
- static int
-comlen(pf)
- register FILE *pf;
-{
-	register int c;
-	register char *s, *se;
-	char buf[128], cbuf[128];
-	int refread;
-	long L;
-	Extsym *e;
-
-	if ((c = getc(pf)) == EOF)
-		return 1;
-	if (c == ' ') {
-		refread = 0;
-		s = "comlen ";
-		}
-	else if (c == ':') {
-		refread = 1;
-		s = "ref: ";
-		}
-	else {
- ret0:
-		if (c == '*')
-			ungetc(c,pf);
-		return 0;
-		}
-	while(*s) {
-		if ((c = getc(pf)) == EOF)
-			return 1;
-		if (c != *s++)
-			goto ret0;
-		}
-	s = buf;
-	se = buf + sizeof(buf) - 1;
-	for(;;) {
-		if ((c = getc(pf)) == EOF)
-			return 1;
-		if (c == ' ')
-			break;
-		if (s >= se || Pct[c] != P_anum)
-			goto ret0;
-		*s++ = c;
-		}
-	*s-- = 0;
-	if (s <= buf || *s != '_')
-		return 0;
-	strcpy(cbuf,buf);
-	*s-- = 0;
-	if (*s == '_') {
-		*s-- = 0;
-		if (s <= buf)
-			return 0;
-		}
-	for(L = 0;;) {
-		if ((c = getc(pf)) == EOF)
-			return 1;
-		if (c == ' ')
-			break;
-		if (c < '0' && c > '9')
-			goto ret0;
-		L = 10*L + c - '0';
-		}
-	if (!L && !refread)
-		return 0;
-	e = mkext(buf, cbuf);
-	if (refread)
-		return readref(pf, e, (int)L);
-	if (e->extstg == STGUNKNOWN) {
-		e->extstg = STGCOMMON;
-		e->maxleng = L;
-		}
-	else if (e->extstg != STGCOMMON)
-		Pnotboth(e);
-	else if (e->maxleng != L) {
-		fprintf(stderr,
-	"incompatible lengths for common block %s (line %ld of %s)\n",
-				    buf, Plineno, Pfname);
-		if (e->maxleng < L)
-			e->maxleng = L;
-		}
-	return 0;
-	}
-
- static int
-Ptoken(pf, canend)
- FILE *pf;
- int canend;
-{
-	register int c;
-	register char *s, *se;
-
- top:
-	for(;;) {
-		c = getc(pf);
-		if (c == EOF) {
-			if (canend)
-				return 0;
-			goto badeof;
-			}
-		if (Pct[c] != P_space)
-			break;
-		if (c == '\n')
-			Plineno++;
-		}
-	switch(Pct[c]) {
-		case P_anum:
-			if (c == '_')
-				badchar(c);
-			s = Ptok;
-			se = s + sizeof(Ptok) - 1;
-			do {
-				if (s < se)
-					*s++ = c;
-				if ((c = getc(pf)) == EOF) {
- badeof:
-					fprintf(stderr,
-					"unexpected end of file in %s\n",
-						Pfname);
-					exit(2);
-					}
-				}
-				while(Pct[c] == P_anum);
-			ungetc(c,pf);
-			*s = 0;
-			return P_anum;
-
-		case P_delim:
-			return c;
-
-		case P_slash:
-			if ((c = getc(pf)) != '*') {
-				if (c == EOF)
-					goto badeof;
-				badchar('/');
-				}
-			if (canend && comlen(pf))
-				goto badeof;
-			for(;;) {
-				while((c = getc(pf)) != '*') {
-					if (c == EOF)
-						goto badeof;
-					if (c == '\n')
-						Plineno++;
-					}
- slashseek:
-				switch(getc(pf)) {
-					case '/':
-						goto top;
-					case EOF:
-						goto badeof;
-					case '*':
-						goto slashseek;
-					}
-				}
-		default:
-			badchar(c);
-		}
-	/* NOT REACHED */
-	return 0;
-	}
-
- static int
-Pftype()
-{
-	switch(Ptok[0]) {
-		case 'C':
-			if (!strcmp(Ptok+1, "_f"))
-				return TYCOMPLEX;
-			break;
-		case 'E':
-			if (!strcmp(Ptok+1, "_f")) {
-				/* TYREAL under forcedouble */
-				checkreal(1);
-				return TYREAL;
-				}
-			break;
-		case 'H':
-			if (!strcmp(Ptok+1, "_f"))
-				return TYCHAR;
-			break;
-		case 'Z':
-			if (!strcmp(Ptok+1, "_f"))
-				return TYDCOMPLEX;
-			break;
-		case 'd':
-			if (!strcmp(Ptok+1, "oublereal"))
-				return TYDREAL;
-			break;
-		case 'i':
-			if (!strcmp(Ptok+1, "nt"))
-				return TYSUBR;
-			if (!strcmp(Ptok+1, "nteger"))
-				return TYLONG;
-			break;
-		case 'l':
-			if (!strcmp(Ptok+1, "ogical")) {
-				checklogical(1);
-				return TYLOGICAL;
-				}
-			break;
-		case 'r':
-			if (!strcmp(Ptok+1, "eal")) {
-				checkreal(0);
-				return TYREAL;
-				}
-			break;
-		case 's':
-			if (!strcmp(Ptok+1, "hortint"))
-				return TYSHORT;
-			if (!strcmp(Ptok+1, "hortlogical")) {
-				checklogical(0);
-				return TYLOGICAL;
-				}
-			break;
-		}
-	bad_type();
-	/* NOT REACHED */
-	return 0;
-	}
-
- static void
-wanted(i, what)
- int i;
- char *what;
-{
-	if (i != P_anum) {
-		Ptok[0] = i;
-		Ptok[1] = 0;
-		}
-	fprintf(stderr,"Error: expected %s, not \"%s\" (line %ld of %s)\n",
-		what, Ptok, Plineno, Pfname);
-	exit(2);
-	}
-
- static int
-Ptype(pf)
- FILE *pf;
-{
-	int i, rv;
-
-	i = Ptoken(pf,0);
-	if (i == ')')
-		return 0;
-	if (i != P_anum)
-		badchar(i);
-
-	rv = 0;
-	switch(Ptok[0]) {
-		case 'C':
-			if (!strcmp(Ptok+1, "_fp"))
-				rv = TYCOMPLEX+200;
-			break;
-		case 'D':
-			if (!strcmp(Ptok+1, "_fp"))
-				rv = TYDREAL+200;
-			break;
-		case 'E':
-		case 'R':
-			if (!strcmp(Ptok+1, "_fp"))
-				rv = TYREAL+200;
-			break;
-		case 'H':
-			if (!strcmp(Ptok+1, "_fp"))
-				rv = TYCHAR+200;
-			break;
-		case 'I':
-			if (!strcmp(Ptok+1, "_fp"))
-				rv = TYLONG+200;
-			break;
-		case 'J':
-			if (!strcmp(Ptok+1, "_fp"))
-				rv = TYSHORT+200;
-			break;
-		case 'K':
-			checklogical(0);
-			goto Logical;
-		case 'L':
-			checklogical(1);
- Logical:
-			if (!strcmp(Ptok+1, "_fp"))
-				rv = TYLOGICAL+200;
-			break;
-		case 'S':
-			if (!strcmp(Ptok+1, "_fp"))
-				rv = TYSUBR+200;
-			break;
-		case 'U':
-			if (!strcmp(Ptok+1, "_fp"))
-				rv = TYUNKNOWN+300;
-			break;
-		case 'Z':
-			if (!strcmp(Ptok+1, "_fp"))
-				rv = TYDCOMPLEX+200;
-			break;
-		case 'c':
-			if (!strcmp(Ptok+1, "har"))
-				rv = TYCHAR;
-			else if (!strcmp(Ptok+1, "omplex"))
-				rv = TYCOMPLEX;
-			break;
-		case 'd':
-			if (!strcmp(Ptok+1, "oublereal"))
-				rv = TYDREAL;
-			else if (!strcmp(Ptok+1, "oublecomplex"))
-				rv = TYDCOMPLEX;
-			break;
-		case 'f':
-			if (!strcmp(Ptok+1, "tnlen"))
-				rv = TYFTNLEN+100;
-			break;
-		case 'i':
-			if (!strcmp(Ptok+1, "nteger"))
-				rv = TYLONG;
-			break;
-		case 'l':
-			if (!strcmp(Ptok+1, "ogical")) {
-				checklogical(1);
-				rv = TYLOGICAL;
-				}
-			break;
-		case 'r':
-			if (!strcmp(Ptok+1, "eal"))
-				rv = TYREAL;
-			break;
-		case 's':
-			if (!strcmp(Ptok+1, "hortint"))
-				rv = TYSHORT;
-			else if (!strcmp(Ptok+1, "hortlogical")) {
-				checklogical(0);
-				rv = TYLOGICAL;
-				}
-			break;
-		case 'v':
-			if (tnext == tfirst && !strcmp(Ptok+1, "oid")) {
-				if ((i = Ptoken(pf,0)) != /*(*/ ')')
-					wanted(i, /*(*/ "\")\"");
-				return 0;
-				}
-		}
-	if (!rv)
-		bad_type();
-	if (rv < 100 && (i = Ptoken(pf,0)) != '*')
-			wanted(i, "\"*\"");
-	if ((i = Ptoken(pf,0)) == P_anum)
-		i = Ptoken(pf,0);	/* skip variable name */
-	switch(i) {
-		case ')':
-			ungetc(i,pf);
-			break;
-		case ',':
-			break;
-		default:
-			wanted(i, "\",\" or \")\"");
-		}
-	return rv;
-	}
-
- static char *
-trimunder()
-{
-	register char *s;
-	register int n;
-	static char buf[128];
-
-	s = Ptok + strlen(Ptok) - 1;
-	if (*s != '_') {
-		fprintf(stderr,
-			"warning: %s does not end in _ (line %ld of %s)\n",
-			Ptok, Plineno, Pfname);
-		return Ptok;
-		}
-	if (s[-1] == '_')
-		s--;
-	strncpy(buf, Ptok, n = s - Ptok);
-	buf[n] = 0;
-	return buf;
-	}
-
- static void
-Pbadmsg(msg, p)
- char *msg;
- Extsym *p;
-{
-	Pbad++;
-	fprintf(stderr, "%s for %s (line %ld of %s):\n\t", msg,
-		p->fextname, Plineno, Pfname);
-	p->arginfo->nargs = -1;
-	}
-
- char *Argtype();
-
- static void
-Pbadret(ftype, p)
- int ftype;
- Extsym *p;
-{
-	char buf1[32], buf2[32];
-
-	Pbadmsg("inconsistent types",p);
-	fprintf(stderr, "here %s, previously %s\n",
-		Argtype(ftype+200,buf1),
-		Argtype(p->extype+200,buf2));
-	}
-
- static void
-argverify(ftype, p)
- int ftype;
- Extsym *p;
-{
-	Argtypes *at;
-	register Atype *aty;
-	int i, j, k;
-	register int *t, *te;
-	char buf1[32], buf2[32];
-	int type_fixup();
-
-	at = p->arginfo;
-	if (at->nargs < 0)
-		return;
-	if (p->extype != ftype) {
-		Pbadret(ftype, p);
-		return;
-		}
-	t = tfirst;
-	te = tnext;
-	i = te - t;
-	if (at->nargs != i) {
-		j = at->nargs;
-		Pbadmsg("differing numbers of arguments",p);
-		fprintf(stderr, "here %d, previously %d\n",
-			i, j);
-		return;
-		}
-	for(aty = at->atypes; t < te; t++, aty++) {
-		if (*t == aty->type)
-			continue;
-		j = aty->type;
-		k = *t;
-		if (k >= 300 || k == j)
-			continue;
-		if (j >= 300) {
-			if (k >= 200) {
-				if (k == TYUNKNOWN + 200)
-					continue;
-				if (j % 100 != k - 200
-				 && k != TYSUBR + 200
-				 && j != TYUNKNOWN + 300
-				 && !type_fixup(at,aty,k))
-					goto badtypes;
-				}
-			else if (j % 100 % TYSUBR != k % TYSUBR
-					&& !type_fixup(at,aty,k))
-				goto badtypes;
-			}
-		else if (k < 200 || j < 200)
-			goto badtypes;
-		else if (k == TYUNKNOWN+200)
-			continue;
-		else if (j != TYUNKNOWN+200)
-			{
- badtypes:
-			Pbadmsg("differing calling sequences",p);
-			i = t - tfirst + 1;
-			fprintf(stderr,
-				"arg %d: here %s, prevously %s\n",
-				i, Argtype(k,buf1), Argtype(j,buf2));
-			return;
-			}
-		/* We've subsequently learned the right type,
-		   as in the call on zoo below...
-
-			subroutine foo(x, zap)
-			external zap
-			call goo(zap)
-			x = zap(3)
-			call zoo(zap)
-			end
-		 */
-		aty->type = k;
-		at->changes = 1;
-		}
-	}
-
- static void
-newarg(ftype, p)
- int ftype;
- Extsym *p;
-{
-	Argtypes *at;
-	register Atype *aty;
-	register int *t, *te;
-	int i, k;
-
-	if (p->extstg == STGCOMMON) {
-		Pnotboth(p);
-		return;
-		}
-	p->extstg = STGEXT;
-	p->extype = ftype;
-	p->exproto = 1;
-	t = tfirst;
-	te = tnext;
-	i = te - t;
-	k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
-	at = p->arginfo = (Argtypes *)gmem(k,1);
-	at->dnargs = at->nargs = i;
-	at->defined = at->changes = 0;
-	for(aty = at->atypes; t < te; aty++) {
-		aty->type = *t++;
-		aty->cp = 0;
-		}
-	}
-
- static int
-Pfile(fname)
- char *fname;
-{
-	char *s;
-	int ftype, i;
-	FILE *pf;
-	Extsym *p;
-
-	for(s = fname; *s; s++);
-	if (s - fname < 2
-	|| s[-2] != '.'
-	|| (s[-1] != 'P' && s[-1] != 'p'))
-		return 0;
-
-	if (!(pf = fopen(fname, textread))) {
-		fprintf(stderr, "can't open %s\n", fname);
-		exit(2);
-		}
-	Pfname = fname;
-	Plineno = 1;
-	if (!Pct[' ']) {
-		for(s = " \t\n\r\v\f"; *s; s++)
-			Pct[*s] = P_space;
-		for(s = "*,();"; *s; s++)
-			Pct[*s] = P_delim;
-		for(i = '0'; i <= '9'; i++)
-			Pct[i] = P_anum;
-		for(s = "abcdefghijklmnopqrstuvwxyz"; i = *s; s++)
-			Pct[i] = Pct[i+'A'-'a'] = P_anum;
-		Pct['_'] = P_anum;
-		Pct['/'] = P_slash;
-		}
-
-	for(;;) {
-		if (!(i = Ptoken(pf,1)))
-			break;
-		if (i != P_anum
-		|| !strcmp(Ptok, "extern") && (i = Ptoken(pf,0)) != P_anum)
-			badchar(i);
-		ftype = Pftype();
- getname:
-		if ((i = Ptoken(pf,0)) != P_anum)
-			badchar(i);
-		p = mkext(trimunder(), Ptok);
-
-		if ((i = Ptoken(pf,0)) != '(')
-			badchar(i);
-		tnext = tfirst;
-		while(i = Ptype(pf)) {
-			if (tnext >= tlast)
-				trealloc();
-			*tnext++ = i;
-			}
-		if (p->arginfo) {
-			argverify(ftype, p);
-			if (p->arginfo->nargs < 0)
-				newarg(ftype, p);
-			}
-		else
-			newarg(ftype, p);
-		p->arginfo->defined = 1;
-		i = Ptoken(pf,0);
-		switch(i) {
-			case ';':
-				break;
-			case ',':
-				goto getname;
-			default:
-				wanted(i, "\";\" or \",\"");
-			}
-		}
-	fclose(pf);
-	return 1;
-	}
-
- void
-read_Pfiles(ffiles)
- char **ffiles;
-{
-	char **f1files, **f1files0, *s;
-	int k;
-	register Extsym *e, *ee;
-	register Argtypes *at;
-	extern int retcode;
-
-	f1files0 = f1files = ffiles;
-	while(s = *ffiles++)
-		if (!Pfile(s))
-			*f1files++ = s;
-	if (Pbad)
-		retcode = 8;
-	if (tfirst) {
-		free((char *)tfirst);
-		/* following should be unnecessary, as we won't be back here */
-		tfirst = tnext = tlast = 0;
-		tmax = 0;
-		}
-	*f1files = 0;
-	if (f1files == f1files0)
-		f1files[1] = 0;
-
-	k = 0;
-	ee = nextext;
-	for (e = extsymtab; e < ee; e++)
-		if (e->extstg == STGEXT
-		&& (at = e->arginfo)) {
-			if (at->nargs < 0 || at->changes)
-				k++;
-			at->changes = 2;
-			}
-	if (k) {
-		fprintf(diagfile,
-		"%d prototype%s updated while reading prototypes.\n", k,
-			k > 1 ? "s" : "");
-		}
-	fflush(diagfile);
-	}
//GO.SYSIN DD pread.c
echo proc.c 1>&2
sed >proc.c <<'//GO.SYSIN DD proc.c' 's/^-//'
-/****************************************************************
-Copyright 1990, 1991, 1992 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.
-****************************************************************/
-
-#include "defs.h"
-#include "names.h"
-#include "output.h"
-#include "p1defs.h"
-
-#define EXNULL (union Expression *)0
-
-LOCAL dobss(), docomleng(), docommon(), doentry(),
-	epicode(), nextarg(), retval();
-
-static char Blank[] = BLANKCOMMON;
-
- static char *postfix[] = { "h", "i", "r", "d", "c", "z", "i" };
-
- chainp new_procs;
- int prev_proc, proc_argchanges, proc_protochanges;
- long first_lineno;
-
- void
-changedtype(q)
- Namep q;
-{
-	char buf[200];
-	int qtype, type1;
-	register Extsym *e;
-	Argtypes *at;
-
-	if (q->vtypewarned)
-		return;
-	q->vtypewarned = 1;
-	qtype = q->vtype;
-	e = &extsymtab[q->vardesc.varno];
-	if (!(at = e->arginfo)) {
-		if (!e->exused)
-			return;
-		}
-	else if (at->changes & 2 && qtype != TYUNKNOWN && !at->defined)
-		proc_protochanges++;
-	type1 = e->extype;
-	if (type1 == TYUNKNOWN)
-		return;
-	if (qtype == TYUNKNOWN)
-		/* e.g.,
-			subroutine foo
-			end
-			external foo
-			call goo(foo)
-			end
-		*/
-		return;
-	sprintf(buf, "%.90s: inconsistent declarations:\n\
-	here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype],
-		qtype == TYSUBR ? "" : " function",
-		ftn_types[type1], type1 == TYSUBR ? "" : " function");
-	warn(buf);
-	}
-
- void
-unamstring(q, s)
- register Addrp q;
- register char *s;
-{
-	register int k;
-	register char *t;
-
-	k = strlen(s);
-	if (k < IDENT_LEN) {
-		q->uname_tag = UNAM_IDENT;
-		t = q->user.ident;
-		}
-	else {
-		q->uname_tag = UNAM_CHARP;
-		q->user.Charp = t = mem(k+1, 0);
-		}
-	strcpy(t, s);
-	}
-
- static void
-fix_entry_returns()	/* for multiple entry points */
-{
-	Addrp a;
-	int i;
-	struct Entrypoint *e;
-	Namep np;
-
-	e = entries = (struct Entrypoint *)revchain((chainp)entries);
-	allargs = revchain(allargs);
-	if (!multitype)
-		return;
-
-	/* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */
-
-	for(i = TYSHORT; i <= TYLOGICAL; i++)
-		if (a = xretslot[i])
-			sprintf(a->user.ident, "(*ret_val).%s",
-				postfix[i-TYSHORT]);
-
-	do {
-		np = e->enamep;
-		switch(np->vtype) {
-			case TYSHORT:
-			case TYLONG:
-			case TYREAL:
-			case TYDREAL:
-			case TYCOMPLEX:
-			case TYDCOMPLEX:
-			case TYLOGICAL:
-				np->vstg = STGARG;
-			}
-		}
-		while(e = e->entnextp);
-	}
-
- static void
-putentries(outfile)	/* put out wrappers for multiple entries */
- FILE *outfile;
-{
-	char base[IDENT_LEN];
-	struct Entrypoint *e;
-	Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
-	chainp args, lengths, length_comp();
-	void listargs(), list_arg_types();
-	int i, k, mt, nL, type;
-	extern char *dfltarg[], **dfltproc;
-
-	e = entries;
-	if (!e->enamep) /* only possible with erroneous input */
-		return;
-	nL = (nallargs + nallchargs) * sizeof(Namep *);
-	A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **));
-	Ae = A + nallargs;
-	Alp = (Namep **)(Ae1 = Ae + nallchargs);
-	i = k = 0;
-	for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) {
-		np = (Namep)args->datap;
-		if (np->vtype == TYCHAR && np->vclass != CLPROC)
-			*a1 = &Ae[i++];
-		}
-
-	mt = multitype;
-	multitype = 0;
-	sprintf(base, "%s0_", e->enamep->cvarname);
-	do {
-		np = e->enamep;
-		lengths = length_comp(e, 0);
-		proctype = type = np->vtype;
-		if (protofile)
-			protowrite(protofile, type, np->cvarname, e, lengths);
-		nice_printf(outfile, "\n%s ", c_type_decl(type, 1));
-		nice_printf(outfile, "%s", np->cvarname);
-		if (!Ansi) {
-			listargs(outfile, e, 0, lengths);
-			nice_printf(outfile, "\n");
-			}
-	    	list_arg_types(outfile, e, lengths, 0, "\n");
-		nice_printf(outfile, "{\n");
-		frchain(&lengths);
-		next_tab(outfile);
-		if (mt)
-			nice_printf(outfile,
-				"Multitype ret_val;\n%s(%d, &ret_val",
-				base, k); /*)*/
-		else if (ISCOMPLEX(type))
-			nice_printf(outfile, "%s(%d,%s", base, k,
-				xretslot[type]->user.ident); /*)*/
-		else if (type == TYCHAR)
-			nice_printf(outfile,
-				"%s(%d, ret_val, ret_val_len", base, k); /*)*/
-		else
-			nice_printf(outfile, "return %s(%d", base, k); /*)*/
-		k++;
-		memset((char *)A, 0, nL);
-		for(args = e->arglist; args; args = args->nextp) {
-			np = (Namep)args->datap;
-			A[np->argno] = np;
-			if (np->vtype == TYCHAR && np->vclass != CLPROC)
-				*Alp[np->argno] = np;
-			}
-		args = allargs;
-		for(a = A; a < Ae; a++, args = args->nextp)
-			nice_printf(outfile, ", %s", (np = *a)
-				? np->cvarname
-				: ((Namep)args->datap)->vclass == CLPROC
-				? dfltproc[((Namep)args->datap)->vtype]
-				: dfltarg[((Namep)args->datap)->vtype]);
-		for(; a < Ae1; a++)
-			if (np = *a)
-				nice_printf(outfile, ", %s_len", np->fvarname);
-			else
-				nice_printf(outfile, ", (ftnint)0");
-		nice_printf(outfile, /*(*/ ");\n");
-		if (mt) {
-			if (type == TYCOMPLEX)
-				nice_printf(outfile,
-		    "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\nreturn 0;\n");
-			else if (type == TYDCOMPLEX)
-				nice_printf(outfile,
-		    "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\nreturn 0;\n");
-			else nice_printf(outfile, "return ret_val.%s;\n",
-				postfix[type-TYSHORT]);
-			}
-		else if (ONEOF(type, M(TYCHAR)|M(TYCOMPLEX)|M(TYDCOMPLEX)))
-			nice_printf(outfile, "return 0;\n");
-		nice_printf(outfile, "}\n");
-		prev_tab(outfile);
-		}
-		while(e = e->entnextp);
-	free((char *)A);
-	}
-
- static void
-entry_goto(outfile)
- FILEP outfile;
-{
-	struct Entrypoint *e = entries;
-	int k = 0;
-
-	nice_printf(outfile, "switch(n__) {\n");
-	next_tab(outfile);
-	while(e = e->entnextp)
-		nice_printf(outfile, "case %d: goto %s;\n", ++k,
-			user_label((long)(extsymtab - e->entryname - 1)));
-	nice_printf(outfile, "}\n\n");
-	prev_tab(outfile);
-	}
-
-/* start a new procedure */
-
-newproc()
-{
-	if(parstate != OUTSIDE)
-	{
-		execerr("missing end statement", CNULL);
-		endproc();
-	}
-
-	parstate = INSIDE;
-	procclass = CLMAIN;	/* default */
-}
-
- static void
-zap_changes()
-{
-	register chainp cp;
-	register Argtypes *at;
-
-	/* arrange to get correct count of prototypes that would
-	   change by running f2c again */
-
-	if (prev_proc && proc_argchanges)
-		proc_protochanges++;
-	prev_proc = proc_argchanges = 0;
-	for(cp = new_procs; cp; cp = cp->nextp)
-		if (at = ((Namep)cp->datap)->arginfo)
-			at->changes &= ~1;
-	frchain(&new_procs);
-	}
-
-/* end of procedure. generate variables, epilogs, and prologs */
-
-endproc()
-{
-	struct Labelblock *lp;
-	Extsym *ext;
-
-	if(parstate < INDATA)
-		enddcl();
-	if(ctlstack >= ctls)
-		err("DO loop or BLOCK IF not closed");
-	for(lp = labeltab ; lp < labtabend ; ++lp)
-		if(lp->stateno!=0 && lp->labdefined==NO)
-			errstr("missing statement label %s",
-				convic(lp->stateno) );
-
-/* Save copies of the common variables in extptr -> allextp */
-
-	for (ext = extsymtab; ext < nextext; ext++)
-		if (ext -> extstg == STGCOMMON && ext -> extp) {
-			extern int usedefsforcommon;
-
-/* Write out the abbreviations for common block reference */
-
-			copy_data (ext -> extp);
-			if (usedefsforcommon) {
-				wr_abbrevs (c_file, 1, ext -> extp);
-				ext -> used_here = 1;
-				}
-			else
-				ext -> extp = CHNULL;
-
-			}
-
-	if (nentry > 1)
-		fix_entry_returns();
-	epicode();
-	donmlist();
-	dobss();
-	start_formatting ();
-	if (nentry > 1)
-		putentries(c_file);
-
-	zap_changes();
-	procinit();	/* clean up for next procedure */
-}
-
-
-
-/* End of declaration section of procedure.  Allocate storage. */
-
-enddcl()
-{
-	register struct Entrypoint *ep;
-	struct Entrypoint *ep0;
-	extern void freetemps();
-	chainp cp;
-	extern char *err_proc;
-	static char comblks[] = "common blocks";
-
-	err_proc = comblks;
-	docommon();
-
-/* Now the hash table entries for fields of common blocks have STGCOMMON,
-   vdcldone, voffset, and varno.  And the common blocks themselves have
-   their full sizes in extleng. */
-
-	err_proc = "equivalences";
-	doequiv();
-
-	err_proc = comblks;
-	docomleng();
-
-/* This implies that entry points in the declarations are buffered in
-   entries   but not written out */
-
-	err_proc = "entries";
-	if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
-		/* entries could be 0 in case of an error */
-		do doentry(ep);
-			while(ep = ep->entnextp);
-		entries = (struct Entrypoint *)revchain((chainp)ep0);
-		}
-
-	err_proc = 0;
-	parstate = INEXEC;
-	p1put(P1_PROCODE);
-	freetemps();
-	if (earlylabs) {
-		for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
-			p1_label((long)cp->datap);
-		frchain(&earlylabs);
-		}
-}
-
-/* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
-
-/* Main program or Block data */
-
-startproc(progname, class)
-Extsym * progname;
-int class;
-{
-	register struct Entrypoint *p;
-
-	first_lineno = lineno;
-	p = ALLOC(Entrypoint);
-	if(class == CLMAIN) {
-		puthead(CNULL, CLMAIN);
-		if (progname)
-		    strcpy (main_alias, progname->cextname);
-	} else
-		puthead(CNULL, CLBLOCK);
-	if(class == CLMAIN)
-		newentry( mkname(" MAIN"), 0 )->extinit = 1;
-	p->entryname = progname;
-	entries = p;
-
-	procclass = class;
-	fprintf(diagfile, "   %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
-	if(progname) {
-		fprintf(diagfile, " %s", progname->fextname);
-		procname = progname->cextname;
-		}
-	fprintf(diagfile, ":\n");
-	fflush(diagfile);
-}
-
-/* subroutine or function statement */
-
-Extsym *newentry(v, substmsg)
- register Namep v;
- int substmsg;
-{
-	register Extsym *p;
-	char buf[128], badname[64];
-	static int nbad = 0;
-	static char already[] = "external name already used";
-
-	p = mkext(v->fvarname, addunder(v->cvarname));
-
-	if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
-	{
-		sprintf(badname, "%s_bad%d", v->fvarname, ++nbad);
-		if (substmsg) {
-			sprintf(buf,"%s\n\tsubstituting \"%s\"",
-				already, badname);
-			dclerr(buf, v);
-			}
-		else
-			dclerr(already, v);
-		p = mkext(v->fvarname, badname);
-	}
-	v->vstg = STGAUTO;
-	v->vprocclass = PTHISPROC;
-	v->vclass = CLPROC;
-	if (p->extstg == STGEXT)
-		prev_proc = 1;
-	else
-		p->extstg = STGEXT;
-	p->extinit = YES;
-	v->vardesc.varno = p - extsymtab;
-	return(p);
-}
-
-
-entrypt(class, type, length, entry, args)
-int class, type;
-ftnint length;
-Extsym *entry;
-chainp args;
-{
-	register Namep q;
-	register struct Entrypoint *p;
-
-	if(class != CLENTRY)
-		puthead( procname = entry->cextname, class);
-	else
-		fprintf(diagfile, "       entry ");
-	fprintf(diagfile, "   %s:\n", entry->fextname);
-	fflush(diagfile);
-	q = mkname(entry->fextname);
-	if (type == TYSUBR)
-		q->vstg = STGEXT;
-
-	type = lengtype(type, length);
-	if(class == CLPROC)
-	{
-		procclass = CLPROC;
-		proctype = type;
-		procleng = type == TYCHAR ? length : 0;
-	}
-
-	p = ALLOC(Entrypoint);
-
-	p->entnextp = entries;
-	entries = p;
-
-	p->entryname = entry;
-	p->arglist = revchain(args);
-	p->enamep = q;
-
-	if(class == CLENTRY)
-	{
-		class = CLPROC;
-		if(proctype == TYSUBR)
-			type = TYSUBR;
-	}
-
-	q->vclass = class;
-	q->vprocclass = 0;
-	settype(q, type, length);
-	q->vprocclass = PTHISPROC;
-	/* hold all initial entry points till end of declarations */
-	if(parstate >= INDATA)
-		doentry(p);
-}
-
-/* generate epilogs */
-
-/* epicode -- write out the proper function return mechanism at the end of
-   the procedure declaration.  Handles multiple return value types, as
-   well as cooercion into the proper value */
-
-LOCAL epicode()
-{
-	extern int lastwasbranch;
-
-	if(procclass==CLPROC)
-	{
-		if(proctype==TYSUBR)
-		{
-
-/* Return a zero only when the alternate return mechanism has been
-   specified in the function header */
-
-			if ((substars || Ansi) && lastwasbranch != YES)
-			    p1_subr_ret (ICON(0));
-		}
-		else if (!multitype && lastwasbranch != YES)
-			retval(proctype);
-	}
-	else if (procclass == CLMAIN && Ansi && lastwasbranch != YES)
-		p1_subr_ret (ICON(0));
-	lastwasbranch = NO;
-}
-
-
-/* generate code to return value of type  t */
-
-LOCAL retval(t)
-register int t;
-{
-	register Addrp p;
-
-	switch(t)
-	{
-	case TYCHAR:
-	case TYCOMPLEX:
-	case TYDCOMPLEX:
-		break;
-
-	case TYLOGICAL:
-		t = tylogical;
-	case TYADDR:
-	case TYSHORT:
-	case TYLONG:
-	case TYREAL:
-	case TYDREAL:
-		p = (Addrp) cpexpr((expptr)retslot);
-		p->vtype = t;
-		p1_subr_ret (mkconv (t, fixtype((expptr)p)));
-		break;
-
-	default:
-		badtype("retval", t);
-	}
-}
-
-
-/* Do parameter adjustments */
-
-procode(outfile)
-FILE *outfile;
-{
-	prolog(outfile, allargs);
-
-	if (nentry > 1)
-		entry_goto(outfile);
-	}
-
-/* Finish bound computations now that all variables are declared.
- * This used to be in setbound(), but under -u the following incurred
- * an erroneous error message:
- *	subroutine foo(x,n)
- *	real x(n)
- *	integer n
- */
-
- static void
-dim_finish(v)
- Namep v;
-{
-	register struct Dimblock *p;
-	register expptr q;
-	register int i, nd;
-	extern expptr make_int_expr();
-
-	p = v->vdim;
-	v->vdimfinish = 0;
-	nd = p->ndim;
-	doin_setbound = 1;
-	for(i = 0; i < nd; i++)
-		if (q = p->dims[i].dimexpr) {
-			q = p->dims[i].dimexpr = make_int_expr(putx(fixtype(q)));
-			if (!ONEOF(q->headblock.vtype, MSKINT|MSKREAL))
-				errstr("bad dimension type for %.70s",
-					v->fvarname);
-			}
-	if (q = p->basexpr)
-		p->basexpr = make_int_expr(putx(fixtype(q)));
-	doin_setbound = 0;
-	}
-
- static void
-duparg(q)
- Namep q;
-{ errstr("duplicate argument %.80s", q->fvarname); }
-
-/*
-   manipulate argument lists (allocate argument slot positions)
- * keep track of return types and labels
- */
-
-LOCAL doentry(ep)
-struct Entrypoint *ep;
-{
-	register int type;
-	register Namep np;
-	chainp p, p1;
-	register Namep q;
-	Addrp mkarg(), rs;
-	int it, k;
-	extern char dflttype[26];
-	Extsym *entryname = ep->entryname;
-
-	if (++nentry > 1)
-		p1_label((long)(extsymtab - entryname - 1));
-
-/* The main program isn't allowed to have parameters, so any given
-   parameters are ignored */
-
-	if(procclass == CLMAIN || procclass == CLBLOCK)
-		return;
-
-/* So now we're working with something other than CLMAIN or CLBLOCK.
-   Determine the type of its return value. */
-
-	impldcl( np = mkname(entryname->fextname) );
-	type = np->vtype;
-	proc_argchanges = prev_proc && type != entryname->extype;
-	entryname->extseen = 1;
-	if(proctype == TYUNKNOWN)
-		if( (proctype = type) == TYCHAR)
-			procleng = np->vleng ? np->vleng->constblock.Const.ci
-					     : (ftnint) (-1);
-
-	if(proctype == TYCHAR)
-	{
-		if(type != TYCHAR)
-			err("noncharacter entry of character function");
-
-/* Functions returning type   char   can only have multiple entries if all
-   entries return the same length */
-
-		else if( (np->vleng ? np->vleng->constblock.Const.ci :
-		    (ftnint) (-1)) != procleng)
-			err("mismatched character entry lengths");
-	}
-	else if(type == TYCHAR)
-		err("character entry of noncharacter function");
-	else if(type != proctype)
-		multitype = YES;
-	if(rtvlabel[type] == 0)
-		rtvlabel[type] = newlabel();
-	ep->typelabel = rtvlabel[type];
-
-	if(type == TYCHAR)
-	{
-		if(chslot < 0)
-		{
-			chslot = nextarg(TYADDR);
-			chlgslot = nextarg(TYLENG);
-		}
-		np->vstg = STGARG;
-
-/* Put a new argument in the function, one which will hold the result of
-   a character function.  This will have to be named sometime, probably in
-   mkarg(). */
-
-		if(procleng < 0) {
-			np->vleng = (expptr) mkarg(TYLENG, chlgslot);
-			np->vleng->addrblock.uname_tag = UNAM_IDENT;
-			strcpy (np -> vleng -> addrblock.user.ident,
-				new_func_length());
-			}
-		if (!xretslot[TYCHAR]) {
-			xretslot[TYCHAR] = rs =
-				autovar(0, type, ISCONST(np->vleng)
-					? np->vleng : ICON(0), "");
-			strcpy(rs->user.ident, "ret_val");
-			}
-	}
-
-/* Handle a   complex   return type -- declare a new parameter (pointer to
-   a complex value) */
-
-	else if( ISCOMPLEX(type) ) {
-		if (!xretslot[type])
-			xretslot[type] =
-				autovar(0, type, EXNULL, " ret_val");
-				/* the blank is for use in out_addr */
-		np->vstg = STGARG;
-		if(cxslot < 0)
-			cxslot = nextarg(TYADDR);
-		}
-	else if (type != TYSUBR) {
-		if (type == TYUNKNOWN) {
-			dclerr("untyped function", np);
-			proctype = type = np->vtype =
-				dflttype[letter(np->fvarname[0])];
-			}
-		if (!xretslot[type])
-			xretslot[type] = retslot =
-				autovar(1, type, EXNULL, " ret_val");
-				/* the blank is for use in out_addr */
-		np->vstg = STGAUTO;
-		}
-
-	for(p = ep->arglist ; p ; p = p->nextp)
-		if(! (( q = (Namep) (p->datap) )->vknownarg) ) {
-			q->vknownarg = 1;
-			q->vardesc.varno = nextarg(TYADDR);
-			allargs = mkchain((char *)q, allargs);
-			q->argno = nallargs++;
-			}
-		else if (nentry == 1)
-			duparg(q);
-		else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp)
-			if ((Namep)p1->datap == q)
-				duparg(q);
-
-	k = 0;
-	for(p = ep->arglist ; p ; p = p->nextp) {
-		if(! (( q = (Namep) (p->datap) )->vdcldone) )
-			{
-			impldcl(q);
-			q->vdcldone = YES;
-			if(q->vtype == TYCHAR)
-				{
-
-/* If we don't know the length of a char*(*) (i.e. a string), we must add
-   in this additional length argument. */
-
-				++nallchargs;
-				if (q->vclass == CLPROC)
-					nallchargs--;
-				else if (q->vleng == NULL) {
-					/* character*(*) */
-					q->vleng = (expptr)
-					    mkarg(TYLENG, nextarg(TYLENG) );
-					unamstring((Addrp)q->vleng,
-						new_arg_length(q));
-					}
-				}
-			}
-		if (q->vdimfinish)
-			dim_finish(q);
-		if (q->vtype == TYCHAR && q->vclass != CLPROC)
-			k++;
-		}
-
-	if (entryname->extype != type)
-		changedtype(np);
-
-	/* save information for checking consistency of arg lists */
-
-	it = infertypes;
-	if (entryname->exproto)
-		infertypes = 1;
-	save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo,
-			0, np->fvarname, STGEXT, k, np->vtype, 2);
-	infertypes = it;
-}
-
-
-
-LOCAL nextarg(type)
-int type;
-{
-	int k;
-	k = lastargslot;
-	lastargslot += typesize[type];
-	return(k);
-}
-
- LOCAL
-dim_check(q)
- Namep q;
-{
-	register struct Dimblock *vdim = q->vdim;
-
-	if(!vdim->nelt || !ISICON(vdim->nelt))
-		dclerr("adjustable dimension on non-argument", q);
-	else if (vdim->nelt->constblock.Const.ci <= 0)
-		dclerr("nonpositive dimension", q);
-	}
-
-LOCAL dobss()
-{
-	register struct Hashentry *p;
-	register Namep q;
-	int qstg, qclass, qtype;
-	Extsym *e;
-
-	for(p = hashtab ; p<lasthash ; ++p)
-		if(q = p->varp)
-		{
-			qstg = q->vstg;
-			qtype = q->vtype;
-			qclass = q->vclass;
-
-			if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
-			    (qclass==CLVAR && qstg==STGUNKNOWN) ) {
-				if (!(q->vis_assigned | q->vimpldovar))
-					warn1("local variable %s never used",
-						q->fvarname);
-				}
-			else if(qclass==CLVAR && qstg==STGBSS)
-			{ ; }
-
-/* Give external procedures the proper storage class */
-
-			else if(qclass==CLPROC && q->vprocclass==PEXTERNAL
-					&& qstg!=STGARG) {
-				e = mkext(q->fvarname,addunder(q->cvarname));
-				e->extstg = STGEXT;
-				q->vardesc.varno = e - extsymtab;
-				if (e->extype != qtype)
-					changedtype(q);
-				}
-			if(qclass==CLVAR) {
-			    if (qstg != STGARG && q->vdim)
-				dim_check(q);
-			} /* if qclass == CLVAR */
-		}
-
-}
-
-
-
-donmlist()
-{
-	register struct Hashentry *p;
-	register Namep q;
-
-	for(p=hashtab; p<lasthash; ++p)
-		if( (q = p->varp) && q->vclass==CLNAMELIST)
-			namelist(q);
-}
-
-
-/* iarrlen -- Returns the size of the array in bytes, or -1 */
-
-ftnint iarrlen(q)
-register Namep q;
-{
-	ftnint leng;
-
-	leng = typesize[q->vtype];
-	if(leng <= 0)
-		return(-1);
-	if(q->vdim)
-		if( ISICON(q->vdim->nelt) )
-			leng *= q->vdim->nelt->constblock.Const.ci;
-		else	return(-1);
-	if(q->vleng)
-		if( ISICON(q->vleng) )
-			leng *= q->vleng->constblock.Const.ci;
-		else return(-1);
-	return(leng);
-}
-
-namelist(np)
-Namep np;
-{
-	register chainp q;
-	register Namep v;
-	int y;
-
-	if (!np->visused)
-		return;
-	y = 0;
-
-	for(q = np->varxptr.namelist ; q ; q = q->nextp)
-	{
-		vardcl( v = (Namep) (q->datap) );
-		if( !ONEOF(v->vstg, MSKSTATIC) )
-			dclerr("may not appear in namelist", v);
-		else {
-			v->vnamelist = 1;
-			v->visused = 1;
-			v->vsave = 1;
-			y = 1;
-			}
-	np->visused = y;
-	}
-}
-
-/* docommon -- called at the end of procedure declarations, before
-   equivalences and the procedure body */
-
-LOCAL docommon()
-{
-    register Extsym *extptr;
-    register chainp q, q1;
-    struct Dimblock *t;
-    expptr neltp;
-    register Namep comvar;
-    ftnint size;
-    int i, k, pref, type;
-    extern int type_pref[];
-
-    for(extptr = extsymtab ; extptr<nextext ; ++extptr)
-	if (extptr->extstg == STGCOMMON && (q = extptr->extp)) {
-
-/* If a common declaration also had a list of variables ... */
-
-	    q = extptr->extp = revchain(q);
-	    pref = 1;
-	    for(k = TYCHAR; q ; q = q->nextp)
-	    {
-		comvar = (Namep) (q->datap);
-
-		if(comvar->vdcldone == NO)
-		    vardcl(comvar);
-		type = comvar->vtype;
-		if (pref < type_pref[type])
-			pref = type_pref[k = type];
-		if(extptr->extleng % typealign[type] != 0) {
-		    dclerr("common alignment", comvar);
-		    --nerr; /* don't give bad return code for this */
-#if 0
-		    extptr->extleng = roundup(extptr->extleng, typealign[type]);
-#endif
-		} /* if extptr -> extleng % */
-
-/* Set the offset into the common block */
-
-		comvar->voffset = extptr->extleng;
-		comvar->vardesc.varno = extptr - extsymtab;
-		if(type == TYCHAR)
-		    size = comvar->vleng->constblock.Const.ci;
-		else
-		    size = typesize[type];
-		if(t = comvar->vdim)
-		    if( (neltp = t->nelt) && ISCONST(neltp) )
-			size *= neltp->constblock.Const.ci;
-		    else
-			dclerr("adjustable array in common", comvar);
-
-/* Adjust the length of the common block so far */
-
-		extptr->extleng += size;
-	    } /* for */
-
-	    extptr->extype = k;
-
-/* Determine curno and, if new, save this identifier chain */
-
-	    q1 = extptr->extp;
-	    for (q = extptr->allextp, i = 0; q; i++, q = q->nextp)
-		if (struct_eq((chainp)q->datap, q1))
-			break;
-	    if (q)
-		extptr->curno = extptr->maxno - i;
-	    else {
-		extptr->curno = ++extptr->maxno;
-		extptr->allextp = mkchain((char *)extptr->extp,
-						extptr->allextp);
-		}
-	} /* if extptr -> extstg == STGCOMMON */
-
-/* Now the hash table entries have STGCOMMON, vdcldone, voffset, and
-   varno.  And the common block itself has its full size in extleng. */
-
-} /* docommon */
-
-
-/* copy_data -- copy the Namep entries so they are available even after
-   the hash table is empty */
-
-copy_data (list)
-chainp list;
-{
-    for (; list; list = list -> nextp) {
-	Namep namep = ALLOC (Nameblock);
-	int size, nd, i;
-	struct Dimblock *dp;
-
-	cpn(sizeof(struct Nameblock), list->datap, (char *)namep);
-	namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0),
-		namep->fvarname);
-	namep->cvarname = strcmp(namep->fvarname, namep->cvarname)
-		? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname)
-		: namep->fvarname;
-	if (namep -> vleng)
-	    namep -> vleng = (expptr) cpexpr (namep -> vleng);
-	if (namep -> vdim) {
-	    nd = namep -> vdim -> ndim;
-	    size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr);
-	    dp = (struct Dimblock *) ckalloc (size);
-	    cpn(size, (char *)namep->vdim, (char *)dp);
-	    namep -> vdim = dp;
-	    dp->nelt = (expptr)cpexpr(dp->nelt);
-	    for (i = 0; i < nd; i++) {
-		dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize);
-	    } /* for */
-	} /* if */
-	list -> datap = (char *) namep;
-    } /* for */
-} /* copy_data */
-
-
-
-LOCAL docomleng()
-{
-	register Extsym *p;
-
-	for(p = extsymtab ; p < nextext ; ++p)
-		if(p->extstg == STGCOMMON)
-		{
-			if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
-			    && strcmp(Blank, p->cextname) )
-				warn1("incompatible lengths for common block %.60s",
-				    p->fextname);
-			if(p->maxleng < p->extleng)
-				p->maxleng = p->extleng;
-			p->extleng = 0;
-		}
-}
-
-
-/* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
-
-frtemp(p)
-Addrp p;
-{
-	/* put block on chain of temps to be reclaimed */
-	holdtemps = mkchain((char *)p, holdtemps);
-}
-
- void
-freetemps()
-{
-	register chainp p, p1;
-	register Addrp q;
-	register int t;
-
-	p1 = holdtemps;
-	while(p = p1) {
-		q = (Addrp)p->datap;
-		t = q->vtype;
-		if (t == TYCHAR && q->varleng != 0) {
-			/* restore clobbered character string lengths */
-			frexpr(q->vleng);
-			q->vleng = ICON(q->varleng);
-			}
-		p1 = p->nextp;
-		p->nextp = templist[t];
-		templist[t] = p;
-		}
-	holdtemps = 0;
-	}
-
-/* allocate an automatic variable slot for each of   nelt   variables */
-
-Addrp autovar(nelt0, t, lengp, name)
-register int nelt0, t;
-expptr lengp;
-char *name;
-{
-	ftnint leng;
-	register Addrp q;
-	char *temp_name ();
-	register int nelt = nelt0 > 0 ? nelt0 : 1;
-	extern char *av_pfix[];
-
-	if(t == TYCHAR)
-		if( ISICON(lengp) )
-			leng = lengp->constblock.Const.ci;
-		else	{
-			Fatal("automatic variable of nonconstant length");
-		}
-	else
-		leng = typesize[t];
-
-	q = ALLOC(Addrblock);
-	q->tag = TADDR;
-	q->vtype = t;
-	if(t == TYCHAR)
-	{
-		q->vleng = ICON(leng);
-		q->varleng = leng;
-	}
-	q->vstg = STGAUTO;
-	q->ntempelt = nelt;
-	q->isarray = (nelt > 1);
-	q->memoffset = ICON(0);
-
-	/* kludge for nls so we can have ret_val rather than ret_val_4 */
-	if (*name == ' ')
-		unamstring(q, name);
-	else {
-		q->uname_tag = UNAM_IDENT;
-		temp_name(av_pfix[t], ++autonum[t], q->user.ident);
-		}
-	if (nelt0 > 0)
-		declare_new_addr (q);
-	return(q);
-}
-
-
-/* Returns a temporary of the appropriate type.  Will reuse existing
-   temporaries when possible */
-
-Addrp mktmpn(nelt, type, lengp)
-int nelt;
-register int type;
-expptr lengp;
-{
-	ftnint leng;
-	chainp p, oldp;
-	register Addrp q;
-
-	if(type==TYUNKNOWN || type==TYERROR)
-		badtype("mktmpn", type);
-
-	if(type==TYCHAR)
-		if(lengp && ISICON(lengp) )
-			leng = lengp->constblock.Const.ci;
-		else	{
-			err("adjustable length");
-			return( (Addrp) errnode() );
-		}
-	else if (type > TYCHAR || type < TYADDR) {
-		erri("mktmpn: unexpected type %d", type);
-		exit(1);
-		}
-/*
- * if a temporary of appropriate shape is on the templist,
- * remove it from the list and return it
- */
-	for(oldp=CHNULL, p=templist[type];  p  ;  oldp=p, p=p->nextp)
-	{
-		q = (Addrp) (p->datap);
-		if(q->ntempelt==nelt &&
-		    (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) )
-		{
-			if(oldp)
-				oldp->nextp = p->nextp;
-			else
-				templist[type] = p->nextp;
-			free( (charptr) p);
-			return(q);
-		}
-	}
-	q = autovar(nelt, type, lengp, "");
-	return(q);
-}
-
-
-
-
-/* mktmp -- create new local variable; call it something like   name
-   lengp   is taken directly, not copied */
-
-Addrp mktmp(type, lengp)
-int type;
-expptr lengp;
-{
-	Addrp rv;
-	/* arrange for temporaries to be recycled */
-	/* at the end of this statement... */
-	rv = mktmpn(1,type,lengp);
-	frtemp((Addrp)cpexpr((expptr)rv));
-	return rv;
-}
-
-/* mktmp0 omits frtemp() */
-Addrp mktmp0(type, lengp)
-int type;
-expptr lengp;
-{
-	Addrp rv;
-	/* arrange for temporaries to be recycled */
-	/* when this Addrp is freed */
-	rv = mktmpn(1,type,lengp);
-	rv->istemp = YES;
-	return rv;
-}
-
-/* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
-
-/* comblock -- Declare a new common block.  Input parameters name the block;
-   s   will be NULL if the block is unnamed */
-
-Extsym *comblock(s)
- register char *s;
-{
-	Extsym *p;
-	register char *t;
-	register int c, i;
-	char cbuf[256], *s0;
-
-/* Give the unnamed common block a unique name */
-
-	if(*s == 0)
-		p = mkext(Blank,Blank);
-	else {
-		s0 = s;
-		t = cbuf;
-		for(i = 0; c = *t = *s++; t++)
-			if (c == '_')
-				i = 1;
-		if (i)
-			*t++ = '_';
-		t[0] = '_';
-		t[1] = 0;
-		p = mkext(s0,cbuf);
-		}
-	if(p->extstg == STGUNKNOWN)
-		p->extstg = STGCOMMON;
-	else if(p->extstg != STGCOMMON)
-	{
-		errstr("%.68s cannot be a common block name", s);
-		return(0);
-	}
-
-	return( p );
-}
-
-
-/* incomm -- add a new variable to a common declaration */
-
-incomm(c, v)
-Extsym *c;
-Namep v;
-{
-	if (!c)
-		return;
-	if(v->vstg != STGUNKNOWN && !v->vimplstg)
-		dclerr(v->vstg == STGARG
-			? "dummy arguments cannot be in common"
-			: "incompatible common declaration", v);
-	else
-	{
-		v->vstg = STGCOMMON;
-		c->extp = mkchain((char *)v, c->extp);
-	}
-}
-
-
-
-
-/* settype -- set the type or storage class of a Namep object.  If
-   v -> vstg == STGUNKNOWN && type < 0,   attempt to reset vstg to be
-   -type.  This function will not change any earlier definitions in   v,
-   in will only attempt to fill out more information give the other params */
-
-settype(v, type, length)
-register Namep  v;
-register int type;
-register ftnint length;
-{
-	int type1;
-
-	if(type == TYUNKNOWN)
-		return;
-
-	if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
-	{
-		v->vtype = TYSUBR;
-		frexpr(v->vleng);
-		v->vleng = 0;
-		v->vimpltype = 0;
-	}
-	else if(type < 0)	/* storage class set */
-	{
-		if(v->vstg == STGUNKNOWN)
-			v->vstg = - type;
-		else if(v->vstg != -type)
-			dclerr("incompatible storage declarations", v);
-	}
-	else if(v->vtype == TYUNKNOWN || v->vimpltype && v->vtype != type)
-	{
-		if( (v->vtype = lengtype(type, length))==TYCHAR )
-			if (length>=0)
-				v->vleng = ICON(length);
-			else if (parstate >= INDATA)
-				v->vleng = ICON(1);	/* avoid a memory fault */
-		v->vimpltype = 0;
-
-		if (v->vclass == CLPROC) {
-			if (v->vstg == STGEXT
-			 && (type1 = extsymtab[v->vardesc.varno].extype)
-			 &&  type1 != v->vtype)
-				changedtype(v);
-			else if (v->vprocclass == PTHISPROC
-					&& (parstate >= INDATA
-						|| procclass == CLMAIN)
-					&& !xretslot[type]) {
-				xretslot[type] = autovar(ONEOF(type,
-					MSKCOMPLEX|MSKCHAR) ? 0 : 1, type,
-					v->vleng, " ret_val");
-				if (procclass == CLMAIN)
-					errstr(
-				"illegal use of %.60s (main program name)",
-					v->fvarname);
-				/* not completely right, but enough to */
-				/* avoid memory faults; we won't */
-				/* emit any C as we have illegal Fortran */
-				}
-			}
-	}
-	else if(v->vtype!=type) {
- incompat:
-		dclerr("incompatible type declarations", v);
-		}
-	else if (type==TYCHAR)
-		if (v->vleng && v->vleng->constblock.Const.ci != length)
-			goto incompat;
-		else if (parstate >= INDATA)
-			v->vleng = ICON(1);	/* avoid a memory fault */
-}
-
-
-
-
-
-/* lengtype -- returns the proper compiler type, given input of Fortran
-   type and length specifier */
-
-lengtype(type, len)
-register int type;
-ftnint len;
-{
-	register int length = (int)len;
-	switch(type)
-	{
-	case TYREAL:
-		if(length == typesize[TYDREAL])
-			return(TYDREAL);
-		if(length == typesize[TYREAL])
-			goto ret;
-		break;
-
-	case TYCOMPLEX:
-		if(length == typesize[TYDCOMPLEX])
-			return(TYDCOMPLEX);
-		if(length == typesize[TYCOMPLEX])
-			goto ret;
-		break;
-
-	case TYSHORT:
-	case TYDREAL:
-	case TYDCOMPLEX:
-	case TYCHAR:
-	case TYUNKNOWN:
-	case TYSUBR:
-	case TYERROR:
-		goto ret;
-
-	case TYLOGICAL:
-		if(length == typesize[TYLOGICAL])
-			goto ret;
-		if(length == 1 || length == 2) {
-			erri("treating LOGICAL*%d as LOGICAL", length);
-			--nerr;	/* allow generation of .c file */
-			goto ret;
-			}
-		break;
-
-	case TYLONG:
-		if(length == 0)
-			return(tyint);
-		if(length == typesize[TYSHORT])
-			return(TYSHORT);
-		if(length == typesize[TYLONG])
-			goto ret;
-		break;
-	default:
-		badtype("lengtype", type);
-	}
-
-	if(len != 0)
-		err("incompatible type-length combination");
-
-ret:
-	return(type);
-}
-
-
-
-
-
-/* setintr -- Set Intrinsic function */
-
-setintr(v)
-register Namep  v;
-{
-	int k;
-
-	if(v->vstg == STGUNKNOWN)
-		v->vstg = STGINTR;
-	else if(v->vstg!=STGINTR)
-		dclerr("incompatible use of intrinsic function", v);
-	if(v->vclass==CLUNKNOWN)
-		v->vclass = CLPROC;
-	if(v->vprocclass == PUNKNOWN)
-		v->vprocclass = PINTRINSIC;
-	else if(v->vprocclass != PINTRINSIC)
-		dclerr("invalid intrinsic declaration", v);
-	if(k = intrfunct(v->fvarname)) {
-		if ((*(struct Intrpacked *)&k).f4)
-			if (noextflag)
-				goto unknown;
-			else
-				dcomplex_seen++;
-		v->vardesc.varno = k;
-		}
-	else {
- unknown:
-		dclerr("unknown intrinsic function", v);
-		}
-}
-
-
-
-/* setext -- Set External declaration -- assume that unknowns will become
-   procedures */
-
-setext(v)
-register Namep  v;
-{
-	if(v->vclass == CLUNKNOWN)
-		v->vclass = CLPROC;
-	else if(v->vclass != CLPROC)
-		dclerr("invalid external declaration", v);
-
-	if(v->vprocclass == PUNKNOWN)
-		v->vprocclass = PEXTERNAL;
-	else if(v->vprocclass != PEXTERNAL)
-		dclerr("invalid external declaration", v);
-} /* setext */
-
-
-
-
-/* create dimensions block for array variable */
-
-setbound(v, nd, dims)
-register Namep  v;
-int nd;
-struct Dims dims[ ];
-{
-	register expptr q, t;
-	register struct Dimblock *p;
-	int i;
-	extern chainp new_vars;
-	char buf[256];
-
-	if(v->vclass == CLUNKNOWN)
-		v->vclass = CLVAR;
-	else if(v->vclass != CLVAR)
-	{
-		dclerr("only variables may be arrays", v);
-		return;
-	}
-
-	v->vdim = p = (struct Dimblock *)
-	    ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) );
-	p->ndim = nd--;
-	p->nelt = ICON(1);
-	doin_setbound = 1;
-
-	for(i = 0; i <= nd; ++i)
-	{
-		if( (q = dims[i].ub) == NULL)
-		{
-			if(i == nd)
-			{
-				frexpr(p->nelt);
-				p->nelt = NULL;
-			}
-			else
-				err("only last bound may be asterisk");
-			p->dims[i].dimsize = ICON(1);
-			;
-			p->dims[i].dimexpr = NULL;
-		}
-		else
-		{
-
-			if(dims[i].lb)
-			{
-				q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
-				q = mkexpr(OPPLUS, q, ICON(1) );
-			}
-			if( ISCONST(q) )
-			{
-				p->dims[i].dimsize = q;
-				p->dims[i].dimexpr = (expptr) PNULL;
-			}
-			else {
-				sprintf(buf, " %s_dim%d", v->fvarname, i+1);
-				p->dims[i].dimsize = (expptr)
-					autovar(1, tyint, EXNULL, buf);
-				p->dims[i].dimexpr = q;
-				if (i == nd)
-					v->vlastdim = new_vars;
-				v->vdimfinish = 1;
-			}
-			if(p->nelt)
-				p->nelt = mkexpr(OPSTAR, p->nelt,
-				    cpexpr(p->dims[i].dimsize) );
-		}
-	}
-
-	q = dims[nd].lb;
-	if(q == NULL)
-		q = ICON(1);
-
-	for(i = nd-1 ; i>=0 ; --i)
-	{
-		t = dims[i].lb;
-		if(t == NULL)
-			t = ICON(1);
-		if(p->dims[i].dimsize)
-			q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) );
-	}
-
-	if( ISCONST(q) )
-	{
-		p->baseoffset = q;
-		p->basexpr = NULL;
-	}
-	else
-	{
-		sprintf(buf, " %s_offset", v->fvarname);
-		p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf);
-		p->basexpr = q;
-		v->vdimfinish = 1;
-	}
-	doin_setbound = 0;
-}
-
-
-
-wr_abbrevs (outfile, function_head, vars)
-FILE *outfile;
-int function_head;
-chainp vars;
-{
-    for (; vars; vars = vars -> nextp) {
-	Namep name = (Namep) vars -> datap;
-	if (!name->visused)
-		continue;
-
-	if (function_head)
-	    nice_printf (outfile, "#define ");
-	else
-	    nice_printf (outfile, "#undef ");
-	out_name (outfile, name);
-
-	if (function_head) {
-	    Extsym *comm = &extsymtab[name -> vardesc.varno];
-
-	    nice_printf (outfile, " (");
-	    extern_out (outfile, comm);
-	    nice_printf (outfile, "%d.", comm->curno);
-	    nice_printf (outfile, "%s)", name->cvarname);
-	} /* if function_head */
-	nice_printf (outfile, "\n");
-    } /* for */
-} /* wr_abbrevs */
//GO.SYSIN DD proc.c
echo put.c 1>&2
sed >put.c <<'//GO.SYSIN DD put.c' 's/^-//'
-/****************************************************************
-Copyright 1990 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.
-****************************************************************/
-
-/*
- * INTERMEDIATE CODE GENERATION PROCEDURES COMMON TO BOTH
- * JOHNSON (PORTABLE) AND RITCHIE FAMILIES OF SECOND PASSES
-*/
-
-#include "defs.h"
-#include "names.h"		/* For LOCAL_CONST_NAME */
-#include "pccdefs.h"
-#include "p1defs.h"
-
-/* Definitions for   putconst()   */
-
-#define LIT_CHAR 1
-#define LIT_FLOAT 2
-#define LIT_INT 3
-
-
-/*
-char *ops [ ] =
-	{
-	"??", "+", "-", "*", "/", "**", "-",
-	"OR", "AND", "EQV", "NEQV", "NOT",
-	"CONCAT",
-	"<", "==", ">", "<=", "!=", ">=",
-	" of ", " ofC ", " = ", " += ", " *= ", " CONV ", " << ", " % ",
-	" , ", " ? ", " : "
-	" abs ", " min ", " max ", " addr ", " indirect ",
-	" bitor ", " bitand ", " bitxor ", " bitnot ", " >> ",
-	};
-*/
-
-/* Each of these values is defined in   pccdefs   */
-
-int ops2 [ ] =
-{
-	P2BAD, P2PLUS, P2MINUS, P2STAR, P2SLASH, P2BAD, P2NEG,
-	P2OROR, P2ANDAND, P2EQ, P2NE, P2NOT,
-	P2BAD,
-	P2LT, P2EQ, P2GT, P2LE, P2NE, P2GE,
-	P2CALL, P2CALL, P2ASSIGN, P2PLUSEQ, P2STAREQ, P2CONV, P2LSHIFT, P2MOD,
-	P2COMOP, P2QUEST, P2COLON,
-	1, P2BAD, P2BAD, P2BAD, P2BAD,
-	P2BITOR, P2BITAND, P2BITXOR, P2BITNOT, P2RSHIFT,
-	P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD,
-	P2BAD, P2BAD, P2BAD, P2BAD,
-	1,1,1,1,1, /* OPNEG1, OPDMIN, OPDMAX, OPASSIGNI, OPIDENTITY */
-	1,1,1,1	/* OPCHARCAST, OPDABS, OPMIN2, OPMAX2 */
-};
-
-
-int types2 [ ] =
-{
-	P2BAD, P2INT|P2PTR, P2SHORT, P2LONG, P2REAL, P2DREAL,
-	P2REAL, P2DREAL, P2LONG, P2CHAR, P2INT, P2BAD
-};
-
-
-setlog()
-{
-	types2[TYLOGICAL] = types2[tylogical];
-	typesize[TYLOGICAL] = typesize[tylogical];
-	typealign[TYLOGICAL] = typealign[tylogical];
-}
-
-
-putexpr(p)
-expptr p;
-{
-/* Write the expression to the p1 file */
-
-	p = (expptr) putx (fixtype (p));
-	p1_expr (p);
-}
-
-
-
-
-
-expptr putassign(lp, rp)
-expptr lp, rp;
-{
-	return putx(fixexpr((Exprp)mkexpr(OPASSIGN, lp, rp)));
-}
-
-
-
-
-void puteq(lp, rp)
-expptr lp, rp;
-{
-	putexpr(mkexpr(OPASSIGN, lp, rp) );
-}
-
-
-
-
-/* put code for  a *= b */
-
-expptr putsteq(a, b)
-Addrp a, b;
-{
-	return putx( fixexpr((Exprp)
-		mkexpr(OPSTAREQ, cpexpr((expptr)a), cpexpr((expptr)b))));
-}
-
-
-
-
-Addrp mkfield(res, f, ty)
-register Addrp res;
-char *f;
-int ty;
-{
-    res -> vtype = ty;
-    res -> Field = f;
-    return res;
-} /* mkfield */
-
-
-Addrp realpart(p)
-register Addrp p;
-{
-	register Addrp q;
-	expptr mkrealcon();
-
-	if (p -> uname_tag == UNAM_CONST && ISCOMPLEX (p->vtype)) {
-		return (Addrp)mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
-			p->user.kludge.vstg1 ? p->user.Const.cds[0]
-				: cds(dtos(p->user.Const.cd[0]),CNULL));
-	} /* if p -> uname_tag */
-
-	q = (Addrp) cpexpr((expptr) p);
-	if( ISCOMPLEX(p->vtype) )
-		q = mkfield (q, "r", p -> vtype + TYREAL - TYCOMPLEX);
-
-	return(q);
-}
-
-
-
-
-expptr imagpart(p)
-register Addrp p;
-{
-	register Addrp q;
-	expptr mkrealcon();
-
-	if( ISCOMPLEX(p->vtype) )
-	{
-		if (p -> uname_tag == UNAM_CONST)
-			return mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
-				p->user.kludge.vstg1 ? p->user.Const.cds[1]
-				: cds(dtos(p->user.Const.cd[1]),CNULL));
-		q = (Addrp) cpexpr((expptr) p);
-		q = mkfield (q, "i", p -> vtype + TYREAL - TYCOMPLEX);
-		return( (expptr) q );
-	}
-	else
-
-/* Cast an integer type onto a Double Real type */
-
-		return( mkrealcon( ISINT(p->vtype) ? TYDREAL : p->vtype , "0"));
-}
-
-
-
-
-
-/* ncat -- computes the number of adjacent concatenation operations */
-
-ncat(p)
-register expptr p;
-{
-	if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
-		return( ncat(p->exprblock.leftp) + ncat(p->exprblock.rightp) );
-	else	return(1);
-}
-
-
-
-
-/* lencat -- returns the length of the concatenated string.  Each
-   substring must have a static (i.e. compile-time) fixed length */
-
-ftnint lencat(p)
-register expptr p;
-{
-	if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
-		return( lencat(p->exprblock.leftp) + lencat(p->exprblock.rightp) );
-	else if( p->headblock.vleng!=NULL && ISICON(p->headblock.vleng) )
-		return(p->headblock.vleng->constblock.Const.ci);
-	else if(p->tag==TADDR && p->addrblock.varleng!=0)
-		return(p->addrblock.varleng);
-	else
-	{
-		err("impossible element in concatenation");
-		return(0);
-	}
-}
-
-/* putconst -- Creates a new Addrp value which maps onto the input
-   constant value.  The Addrp doesn't retain the value of the constant,
-   instead that value is copied into a table of constants (called
-   litpool,   for pool of literal values).  The only way to retrieve the
-   actual value of the constant is to look at the   memno   field of the
-   Addrp result.  You know that the associated literal is the one referred
-   to by   q   when   (q -> memno == litp -> litnum).
-*/
-
-Addrp putconst(p)
-register Constp p;
-{
-	register Addrp q;
-	struct Literal *litp, *lastlit;
-	int k, len, type;
-	int litflavor;
-	double cd[2];
-	ftnint nblanks;
-	char *strp;
-	char cdsbuf0[64], cdsbuf1[64], *ds[2];
-
-	if (p->tag != TCONST)
-		badtag("putconst", p->tag);
-
-	q = ALLOC(Addrblock);
-	q->tag = TADDR;
-	type = p->vtype;
-	q->vtype = ( type==TYADDR ? tyint : type );
-	q->vleng = (expptr) cpexpr(p->vleng);
-	q->vstg = STGCONST;
-
-/* Create the new label for the constant.  This is wasteful of labels
-   because when the constant value already exists in the literal pool,
-   this label gets thrown away and is never reclaimed.  It might be
-   cleaner to move this down past the first   switch()   statement below */
-
-	q->memno = newlabel();
-	q->memoffset = ICON(0);
-	q -> uname_tag = UNAM_CONST;
-
-/* Copy the constant info into the Addrblock; do this by copying the
-   largest storage elts */
-
-	q -> user.Const = p -> Const;
-	q->user.kludge.vstg1 = p->vstg;	/* distinguish string from binary fp */
-
-	/* check for value in literal pool, and update pool if necessary */
-
-	k = 1;
-	switch(type)
-	{
-	case TYCHAR:
-		if (halign) {
-			strp = p->Const.ccp;
-			nblanks = p->Const.ccp1.blanks;
-			len = p->vleng->constblock.Const.ci;
-			litflavor = LIT_CHAR;
-			goto loop;
-			}
-		else
-			q->memno = BAD_MEMNO;
-		break;
-	case TYCOMPLEX:
-	case TYDCOMPLEX:
-		k = 2;
-		if (p->vstg)
-			cd[1] = atof(ds[1] = p->Const.cds[1]);
-		else
-			ds[1] = cds(dtos(cd[1] = p->Const.cd[1]), cdsbuf1);
-	case TYREAL:
-	case TYDREAL:
-		litflavor = LIT_FLOAT;
-		if (p->vstg)
-			cd[0] = atof(ds[0] = p->Const.cds[0]);
-		else
-			ds[0] = cds(dtos(cd[0] = p->Const.cd[0]), cdsbuf0);
-		goto loop;
-
-	case TYLOGICAL:
-		type = tylogical;
-		goto lit_int_flavor;
-	case TYLONG:
-		type = tyint;
-	case TYSHORT:
- lit_int_flavor:
-		litflavor = LIT_INT;
-
-/* Scan the literal pool for this constant value.  If this same constant
-   has been assigned before, use the same label.  Note that this routine
-   does NOT consider two differently-typed constants with the same bit
-   pattern to be the same constant */
-
- loop:
-		lastlit = litpool + nliterals;
-		for(litp = litpool ; litp<lastlit ; ++litp)
-
-/* Remove this type checking to ensure that all bit patterns are reused */
-
-			if(type == litp->littype) switch(litflavor)
-			{
-			case LIT_CHAR:
-				if (len == (int)litp->litval.litival2[0]
-				&& nblanks == litp->litval.litival2[1]
-				&& !memcmp(strp, litp->cds[0], len)) {
-					q->memno = litp->litnum;
-					frexpr((expptr)p);
-					return(q);
-					}
-				break;
-			case LIT_FLOAT:
-				if(cd[0] == litp->litval.litdval[0]
-				&& !strcmp(ds[0], litp->cds[0])
-				&& (k == 1 ||
-				    cd[1] == litp->litval.litdval[1]
-				    && !strcmp(ds[1], litp->cds[1]))) {
-ret:
-					q->memno = litp->litnum;
-					frexpr((expptr)p);
-					return(q);
-					}
-				break;
-
-			case LIT_INT:
-				if(p->Const.ci == litp->litval.litival)
-					goto ret;
-				break;
-			}
-
-/* If there's room in the literal pool, add this new value to the pool */
-
-		if(nliterals < maxliterals)
-		{
-			++nliterals;
-
-			/* litp   now points to the next free elt */
-
-			litp->littype = type;
-			litp->litnum = q->memno;
-			switch(litflavor)
-			{
-			case LIT_CHAR:
-				litp->litval.litival2[0] = len;
-				litp->litval.litival2[1] = nblanks;
-				q->user.Const.ccp = litp->cds[0] =
-					memcpy(gmem(len,0), strp, len);
-				break;
-
-			case LIT_FLOAT:
-				litp->litval.litdval[0] = cd[0];
-				litp->cds[0] = copys(ds[0]);
-				if (k == 2) {
-					litp->litval.litdval[1] = cd[1];
-					litp->cds[1] = copys(ds[1]);
-					}
-				break;
-
-			case LIT_INT:
-				litp->litval.litival = p->Const.ci;
-				break;
-			} /* switch (litflavor) */
-		}
-		else
-			many("literal constants", 'L', maxliterals);
-
-		break;
-	case TYADDR:
-	    break;
-	default:
-		badtype ("putconst", p -> vtype);
-		break;
-	} /* switch */
-
-	if (type != TYCHAR || halign)
-	    frexpr((expptr)p);
-	return( q );
-}
//GO.SYSIN DD put.c
echo putpcc.c 1>&2
sed >putpcc.c <<'//GO.SYSIN DD putpcc.c' 's/^-//'
-/****************************************************************
-Copyright 1990, 1991 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.
-****************************************************************/
-
-/* INTERMEDIATE CODE GENERATION FOR S. C. JOHNSON C COMPILERS */
-/* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
-
-#include "defs.h"
-#include "pccdefs.h"
-#include "output.h"		/* for nice_printf */
-#include "names.h"
-#include "p1defs.h"
-
-Addrp realpart();
-LOCAL Addrp intdouble(), putcx1(), putcxeq (), putch1 ();
-LOCAL putct1 ();
-
-expptr putcxop();
-LOCAL expptr putcall (), putmnmx (), putcheq(), putcat ();
-LOCAL expptr putaddr(), putchcmp (), putpower(), putop();
-LOCAL expptr putcxcmp ();
-expptr imagpart();
-ftnint lencat();
-
-#define FOUR 4
-extern int ops2[];
-extern int types2[];
-extern int proc_argchanges, proc_protochanges;
-extern int krparens;
-
-#define P2BUFFMAX 128
-
-/* Puthead -- output the header information about subroutines, functions
-   and entry points */
-
-puthead(s, class)
-char *s;
-int class;
-{
-	if (headerdone == NO) {
-		if (class == CLMAIN)
-			s = "MAIN__";
-		p1_head (class, s);
-		headerdone = YES;
-		}
-}
-
-putif(p, else_if_p)
- register expptr p;
- int else_if_p;
-{
-	register int k;
-	int n;
-	long where;
-
-	if (else_if_p) {
-		p1put(P1_ELSEIFSTART);
-		where = ftell(pass1_file);
-		}
-	if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
-	{
-		if(k != TYERROR)
-			err("non-logical expression in IF statement");
-		}
-	else {
-		if (else_if_p) {
-			if (ei_next >= ei_last)
-				{
-				k = ei_last - ei_first;
-				n = k + 100;
-				ei_next = mem(n,0);
-				ei_last = ei_first + n;
-				if (k)
-					memcpy(ei_next, ei_first, k);
-				ei_first =  ei_next;
-				ei_next += k;
-				ei_last = ei_first + n;
-				}
-			p = putx(p);
-			if (*ei_next++ = ftell(pass1_file) > where) {
-				p1_if(p);
-				new_endif();
-				}
-			else
-				p1_elif(p);
-			}
-		else {
-			p = putx(p);
-			p1_if(p);
-			}
-		}
-	}
-
-
-putout(p)
-expptr p;
-{
-	p1_expr (p);
-
-/* Used to make temporaries in holdtemps available here, but they */
-/* may be reused too soon (e.g. when multiple **'s are involved). */
-}
-
-
-
-putcmgo(index, nlab, labs)
-expptr index;
-int nlab;
-struct Labelblock *labs[];
-{
-	if(! ISINT(index->headblock.vtype) )
-	{
-		execerr("computed goto index must be integer", CNULL);
-		return;
-	}
-
-	p1comp_goto (index, nlab, labs);
-}
-
- static expptr
-krput(p)
- register expptr p;
-{
-	register expptr e, e1;
-	register unsigned op;
-	int t = krparens == 2 ? TYDREAL : p->exprblock.vtype;
-
-	op = p->exprblock.opcode;
-	e = p->exprblock.leftp;
-	if (e->tag == TEXPR && e->exprblock.opcode == op) {
-		e1 = (expptr)mktmp(t, ENULL);
-		putout(putassign(cpexpr(e1), e));
-		p->exprblock.leftp = e1;
-		}
-	else
-		p->exprblock.leftp = putx(e);
-
-	e = p->exprblock.rightp;
-	if (e->tag == TEXPR && e->exprblock.opcode == op) {
-		e1 = (expptr)mktmp(t, ENULL);
-		putout(putassign(cpexpr(e1), e));
-		p->exprblock.rightp = e1;
-		}
-	else
-		p->exprblock.rightp = putx(e);
-	return p;
-	}
-
-expptr putx(p)
- register expptr p;
-{
-	int opc;
-	int k;
-
-	if (p)
-	  switch(p->tag)
-	{
-	case TERROR:
-		break;
-
-	case TCONST:
-		switch(p->constblock.vtype)
-		{
-		case TYLOGICAL:
-		case TYLONG:
-		case TYSHORT:
-			break;
-
-		case TYADDR:
-			break;
-		case TYREAL:
-		case TYDREAL:
-
-/* Don't write it out to the p2 file, since you'd need to call putconst,
-   which is just what we need to avoid in the translator */
-
-			break;
-		default:
-			p = putx( (expptr)putconst((Constp)p) );
-			break;
-		}
-		break;
-
-	case TEXPR:
-		switch(opc = p->exprblock.opcode)
-		{
-		case OPCALL:
-		case OPCCALL:
-			if( ISCOMPLEX(p->exprblock.vtype) )
-				p = putcxop(p);
-			else	p = putcall(p, (Addrp *)NULL);
-			break;
-
-		case OPMIN:
-		case OPMAX:
-			p = putmnmx(p);
-			break;
-
-
-		case OPASSIGN:
-			if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype)
-			    || ISCOMPLEX(p->exprblock.rightp->headblock.vtype)) {
-				(void) putcxeq(p);
-				p = ENULL;
-			} else if( ISCHAR(p) )
-				p = putcheq(p);
-			else
-				goto putopp;
-			break;
-
-		case OPEQ:
-		case OPNE:
-			if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ||
-			    ISCOMPLEX(p->exprblock.rightp->headblock.vtype) )
-			{
-				p = putcxcmp(p);
-				break;
-			}
-		case OPLT:
-		case OPLE:
-		case OPGT:
-		case OPGE:
-			if(ISCHAR(p->exprblock.leftp))
-			{
-				p = putchcmp(p);
-				break;
-			}
-			goto putopp;
-
-		case OPPOWER:
-			p = putpower(p);
-			break;
-
-		case OPSTAR:
-			/*   m * (2**k) -> m<<k   */
-			if(INT(p->exprblock.leftp->headblock.vtype) &&
-			    ISICON(p->exprblock.rightp) &&
-			    ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) )
-			{
-				p->exprblock.opcode = OPLSHIFT;
-				frexpr(p->exprblock.rightp);
-				p->exprblock.rightp = ICON(k);
-				goto putopp;
-			}
-			if (krparens && ISREAL(p->exprblock.vtype))
-				return krput(p);
-
-		case OPMOD:
-			goto putopp;
-		case OPPLUS:
-			if (krparens && ISREAL(p->exprblock.vtype))
-				return krput(p);
-		case OPMINUS:
-		case OPSLASH:
-		case OPNEG:
-		case OPNEG1:
-		case OPABS:
-		case OPDABS:
-			if( ISCOMPLEX(p->exprblock.vtype) )
-				p = putcxop(p);
-			else	goto putopp;
-			break;
-
-		case OPCONV:
-			if( ISCOMPLEX(p->exprblock.vtype) )
-				p = putcxop(p);
-			else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) )
-			{
-				p = putx( mkconv(p->exprblock.vtype,
-				    (expptr)realpart(putcx1(p->exprblock.leftp))));
-			}
-			else	goto putopp;
-			break;
-
-		case OPNOT:
-		case OPOR:
-		case OPAND:
-		case OPEQV:
-		case OPNEQV:
-		case OPADDR:
-		case OPPLUSEQ:
-		case OPSTAREQ:
-		case OPCOMMA:
-		case OPQUEST:
-		case OPCOLON:
-		case OPBITOR:
-		case OPBITAND:
-		case OPBITXOR:
-		case OPBITNOT:
-		case OPLSHIFT:
-		case OPRSHIFT:
-		case OPASSIGNI:
-		case OPIDENTITY:
-		case OPCHARCAST:
-		case OPMIN2:
-		case OPMAX2:
-		case OPDMIN:
-		case OPDMAX:
-putopp:
-			p = putop(p);
-			break;
-
-		case OPCONCAT:
-			/* weird things like ichar(a//a) */
-			p = (expptr)putch1(p);
-			break;
-
-		default:
-			badop("putx", opc);
-			p = errnode ();
-		}
-		break;
-
-	case TADDR:
-		p = putaddr(p);
-		break;
-
-	default:
-		badtag("putx", p->tag);
-		p = errnode ();
-	}
-
-	return p;
-}
-
-
-
-LOCAL expptr putop(p)
-expptr p;
-{
-	expptr lp, tp;
-	int pt, lt, lt1;
-	int comma;
-
-	switch(p->exprblock.opcode)	/* check for special cases and rewrite */
-	{
-	case OPCONV:
-		pt = p->exprblock.vtype;
-		lp = p->exprblock.leftp;
-		lt = lp->headblock.vtype;
-
-/* Simplify nested type casts */
-
-		while(p->tag==TEXPR && p->exprblock.opcode==OPCONV &&
-		    ( (ISREAL(pt)&&ONEOF(lt,MSKREAL|MSKCOMPLEX)) ||
-		    (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) ))
-		{
-			if(pt==TYDREAL && lt==TYREAL)
-			{
-				if(lp->tag==TEXPR
-				&& lp->exprblock.opcode == OPCONV) {
-				    lt1 = lp->exprblock.leftp->headblock.vtype;
-				    if (lt1 == TYDREAL) {
-					lp->exprblock.leftp =
-						putx(lp->exprblock.leftp);
-					return p;
-					}
-				    if (lt1 == TYDCOMPLEX) {
-					lp->exprblock.leftp = putx(
-						(expptr)realpart(
-						putcx1(lp->exprblock.leftp)));
-					return p;
-					}
-				    }
-				break;
-			}
-			else if (ISREAL(pt) && ISCOMPLEX(lt)) {
-				p->exprblock.leftp = putx(mkconv(pt,
-					(expptr)realpart(
-						putcx1(p->exprblock.leftp))));
-				break;
-				}
-			if(lt==TYCHAR && lp->tag==TEXPR &&
-			    lp->exprblock.opcode==OPCALL)
-			{
-
-/* May want to make a comma expression here instead.  I had one, but took
-   it out for my convenience, not for the convenience of the end user */
-
-				putout (putcall (lp, (Addrp *) &(p ->
-				    exprblock.leftp)));
-				return putop (p);
-			}
-			if (lt == TYCHAR) {
-				p->exprblock.leftp = putx(p->exprblock.leftp);
-				return p;
-				}
-			frexpr(p->exprblock.vleng);
-			free( (charptr) p );
-			p = lp;
-			if (p->tag != TEXPR)
-				goto retputx;
-			pt = lt;
-			lp = p->exprblock.leftp;
-			lt = lp->headblock.vtype;
-		} /* while */
-		if(p->tag==TEXPR && p->exprblock.opcode==OPCONV)
-			break;
- retputx:
-		return putx(p);
-
-	case OPADDR:
-		comma = NO;
-		lp = p->exprblock.leftp;
-		free( (charptr) p );
-		if(lp->tag != TADDR)
-		{
-			tp = (expptr)
-			    mktmp(lp->headblock.vtype,lp->headblock.vleng);
-			p = putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
-			lp = tp;
-			comma = YES;
-		}
-		if(comma)
-			p = mkexpr(OPCOMMA, p, putaddr(lp));
-		else
-			p = (expptr)putaddr(lp);
-		return p;
-
-	case OPASSIGN:
-	case OPASSIGNI:
-	case OPLT:
-	case OPLE:
-	case OPGT:
-	case OPGE:
-	case OPEQ:
-	case OPNE:
-	    ;
-	}
-
-	if( ops2[p->exprblock.opcode] <= 0)
-		badop("putop", p->exprblock.opcode);
-	p -> exprblock.leftp = putx (p -> exprblock.leftp);
-	if (p -> exprblock.rightp)
-	    p -> exprblock.rightp = putx (p -> exprblock.rightp);
-	return p;
-}
-
-LOCAL expptr putpower(p)
-expptr p;
-{
-	expptr base;
-	Addrp t1, t2;
-	ftnint k;
-	int type;
-	char buf[80];			/* buffer for text of comment */
-
-	if(!ISICON(p->exprblock.rightp) ||
-	    (k = p->exprblock.rightp->constblock.Const.ci)<2)
-		Fatal("putpower: bad call");
-	base = p->exprblock.leftp;
-	type = base->headblock.vtype;
-	t1 = mktmp(type, ENULL);
-	t2 = NULL;
-
-	free ((charptr) p);
-	p = putassign (cpexpr((expptr) t1), base);
-
-	sprintf (buf, "Computing %ld%s power", k,
-		k == 2 ? "nd" : k == 3 ? "rd" : "th");
-	p1_comment (buf);
-
-	for( ; (k&1)==0 && k>2 ; k>>=1 )
-	{
-		p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
-	}
-
-	if(k == 2) {
-
-/* Write the power computation out immediately */
-		putout (p);
-		p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)));
-	} else {
-		t2 = mktmp(type, ENULL);
-		p = mkexpr (OPCOMMA, p, putassign(cpexpr((expptr)t2),
-						cpexpr((expptr)t1)));
-
-		for(k>>=1 ; k>1 ; k>>=1)
-		{
-			p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
-			if(k & 1)
-			{
-				p = mkexpr (OPCOMMA, p, putsteq(t2, t1));
-			}
-		}
-/* Write the power computation out immediately */
-		putout (p);
-		p = putx( mkexpr(OPSTAR, cpexpr((expptr)t2),
-		    mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))));
-	}
-	frexpr((expptr)t1);
-	if(t2)
-		frexpr((expptr)t2);
-	return p;
-}
-
-
-
-
-LOCAL Addrp intdouble(p)
-Addrp p;
-{
-	register Addrp t;
-
-	t = mktmp(TYDREAL, ENULL);
-	putout (putassign(cpexpr((expptr)t), (expptr)p));
-	return(t);
-}
-
-
-
-
-
-/* Complex-type variable assignment */
-
-LOCAL Addrp putcxeq(p)
-register expptr p;
-{
-	register Addrp lp, rp;
-	expptr code;
-
-	if(p->tag != TEXPR)
-		badtag("putcxeq", p->tag);
-
-	lp = putcx1(p->exprblock.leftp);
-	rp = putcx1(p->exprblock.rightp);
-	code = putassign ( (expptr)realpart(lp), (expptr)realpart(rp));
-
-	if( ISCOMPLEX(p->exprblock.vtype) )
-	{
-		code = mkexpr (OPCOMMA, code, putassign
-			(imagpart(lp), imagpart(rp)));
-	}
-	putout (code);
-	frexpr((expptr)rp);
-	free ((charptr) p);
-	return lp;
-}
-
-
-
-/* putcxop -- used to write out embedded calls to complex functions, and
-   complex arguments to procedures */
-
-expptr putcxop(p)
-expptr p;
-{
-	return (expptr)putaddr((expptr)putcx1(p));
-}
-
-#define PAIR(x,y) mkexpr (OPCOMMA, (x), (y))
-
-LOCAL Addrp putcx1(p)
-register expptr p;
-{
-	expptr q;
-	Addrp lp, rp;
-	register Addrp resp;
-	int opcode;
-	int ltype, rtype;
-	long ts;
-	expptr mkrealcon();
-
-	if(p == NULL)
-		return(NULL);
-
-	switch(p->tag)
-	{
-	case TCONST:
-		if( ISCOMPLEX(p->constblock.vtype) )
-			p = (expptr) putconst((Constp)p);
-		return( (Addrp) p );
-
-	case TADDR:
-		resp = &p->addrblock;
-		if (addressable(p))
-			return (Addrp) p;
-		if ((q = resp->memoffset) && resp->isarray
-					  && resp->vtype != TYCHAR) {
-			if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
-					&& resp->uname_tag == UNAM_NAME)
-				q = mkexpr(OPMINUS, q,
-					mkintcon(resp->user.name->voffset));
-			ts = typesize[resp->vtype]
-					* (resp->Field ? 2 : 1);
-			q = resp->memoffset = mkexpr(OPSLASH, q, ICON(ts));
-			}
-		else
-			ts = 0;
-		resp = mktmp(tyint, ENULL);
-		putout(putassign(cpexpr((expptr)resp), q));
-		p->addrblock.memoffset = (expptr)resp;
-		if (ts) {
-			resp = &p->addrblock;
-			q = mkexpr(OPSTAR, resp->memoffset, ICON(ts));
-			if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
-				&& resp->uname_tag == UNAM_NAME)
-				q = mkexpr(OPPLUS, q,
-				    mkintcon(resp->user.name->voffset));
-			resp->memoffset = q;
-			}
-		return (Addrp) p;
-
-	case TEXPR:
-		if( ISCOMPLEX(p->exprblock.vtype) )
-			break;
-		resp = mktmp(TYDREAL, ENULL);
-		putout (putassign( cpexpr((expptr)resp), p));
-		return(resp);
-
-	default:
-		badtag("putcx1", p->tag);
-	}
-
-	opcode = p->exprblock.opcode;
-	if(opcode==OPCALL || opcode==OPCCALL)
-	{
-		Addrp t;
-		p = putcall(p, &t);
-		putout(p);
-		return t;
-	}
-	else if(opcode == OPASSIGN)
-	{
-		return putcxeq (p);
-	}
-
-/* BUG  (inefficient)  Generates too many temporary variables */
-
-	resp = mktmp(p->exprblock.vtype, ENULL);
-	if(lp = putcx1(p->exprblock.leftp) )
-		ltype = lp->vtype;
-	if(rp = putcx1(p->exprblock.rightp) )
-		rtype = rp->vtype;
-
-	switch(opcode)
-	{
-	case OPCOMMA:
-		frexpr((expptr)resp);
-		resp = rp;
-		rp = NULL;
-		break;
-
-	case OPNEG:
-	case OPNEG1:
-		putout (PAIR (
-			putassign( (expptr)realpart(resp),
-				mkexpr(OPNEG, (expptr)realpart(lp), ENULL)),
-			putassign( imagpart(resp),
-				mkexpr(OPNEG, imagpart(lp), ENULL))));
-		break;
-
-	case OPPLUS:
-	case OPMINUS: { expptr r;
-		r = putassign( (expptr)realpart(resp),
-		    mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp) ));
-		if(rtype < TYCOMPLEX)
-			q = putassign( imagpart(resp), imagpart(lp) );
-		else if(ltype < TYCOMPLEX)
-		{
-			if(opcode == OPPLUS)
-				q = putassign( imagpart(resp), imagpart(rp) );
-			else
-				q = putassign( imagpart(resp),
-				    mkexpr(OPNEG, imagpart(rp), ENULL) );
-		}
-		else
-			q = putassign( imagpart(resp),
-			    mkexpr(opcode, imagpart(lp), imagpart(rp) ));
-		r = PAIR (r, q);
-		putout (r);
-		break;
-	    } /* case OPPLUS, OPMINUS: */
-	case OPSTAR:
-		if(ltype < TYCOMPLEX)
-		{
-			if( ISINT(ltype) )
-				lp = intdouble(lp);
-			putout (PAIR (
-				putassign( (expptr)realpart(resp),
-				    mkexpr(OPSTAR, cpexpr((expptr)lp),
-					(expptr)realpart(rp))),
-				putassign( imagpart(resp),
-				    mkexpr(OPSTAR, cpexpr((expptr)lp), imagpart(rp)))));
-		}
-		else if(rtype < TYCOMPLEX)
-		{
-			if( ISINT(rtype) )
-				rp = intdouble(rp);
-			putout (PAIR (
-				putassign( (expptr)realpart(resp),
-				    mkexpr(OPSTAR, cpexpr((expptr)rp),
-					(expptr)realpart(lp))),
-				putassign( imagpart(resp),
-				    mkexpr(OPSTAR, cpexpr((expptr)rp), imagpart(lp)))));
-		}
-		else	{
-			putout (PAIR (
-				putassign( (expptr)realpart(resp), mkexpr(OPMINUS,
-				    mkexpr(OPSTAR, (expptr)realpart(lp),
-					(expptr)realpart(rp)),
-				    mkexpr(OPSTAR, imagpart(lp), imagpart(rp)))),
-				putassign( imagpart(resp), mkexpr(OPPLUS,
-				    mkexpr(OPSTAR, (expptr)realpart(lp), imagpart(rp)),
-				    mkexpr(OPSTAR, imagpart(lp),
-					(expptr)realpart(rp))))));
-		}
-		break;
-
-	case OPSLASH:
-		/* fixexpr has already replaced all divisions
-		 * by a complex by a function call
-		 */
-		if( ISINT(rtype) )
-			rp = intdouble(rp);
-		putout (PAIR (
-			putassign( (expptr)realpart(resp),
-			    mkexpr(OPSLASH, (expptr)realpart(lp), cpexpr((expptr)rp))),
-			putassign( imagpart(resp),
-			    mkexpr(OPSLASH, imagpart(lp), cpexpr((expptr)rp)))));
-		break;
-
-	case OPCONV:
-		if( ISCOMPLEX(lp->vtype) )
-			q = imagpart(lp);
-		else if(rp != NULL)
-			q = (expptr) realpart(rp);
-		else
-			q = mkrealcon(TYDREAL, "0");
-		putout (PAIR (
-			putassign( (expptr)realpart(resp), (expptr)realpart(lp)),
-			putassign( imagpart(resp), q)));
-		break;
-
-	default:
-		badop("putcx1", opcode);
-	}
-
-	frexpr((expptr)lp);
-	frexpr((expptr)rp);
-	free( (charptr) p );
-	return(resp);
-}
-
-
-
-
-/* Only .EQ. and .NE. may be performed on COMPLEX data, other relations
-   are not defined */
-
-LOCAL expptr putcxcmp(p)
-register expptr p;
-{
-	int opcode;
-	register Addrp lp, rp;
-	expptr q;
-
-	if(p->tag != TEXPR)
-		badtag("putcxcmp", p->tag);
-
-	opcode = p->exprblock.opcode;
-	lp = putcx1(p->exprblock.leftp);
-	rp = putcx1(p->exprblock.rightp);
-
-	q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
-	    mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp)),
-	    mkexpr(opcode, imagpart(lp), imagpart(rp)) );
-
-	free( (charptr) lp);
-	free( (charptr) rp);
-	free( (charptr) p );
-	return 	putx( fixexpr((Exprp)q) );
-}
-
-/* putch1 -- Forces constants into the literal pool, among other things */
-
-LOCAL Addrp putch1(p)
-register expptr p;
-{
-	Addrp t;
-	expptr e;
-
-	switch(p->tag)
-	{
-	case TCONST:
-		return( putconst((Constp)p) );
-
-	case TADDR:
-		return( (Addrp) p );
-
-	case TEXPR:
-		switch(p->exprblock.opcode)
-		{
-			expptr q;
-
-		case OPCALL:
-		case OPCCALL:
-
-			p = putcall(p, &t);
-			putout (p);
-			break;
-
-		case OPCONCAT:
-			t = mktmp(TYCHAR, ICON(lencat(p)));
-			q = (expptr) cpexpr(p->headblock.vleng);
-			p = putcat( cpexpr((expptr)t), p );
-			/* put the correct length on the block */
-			frexpr(t->vleng);
-			t->vleng = q;
-			putout (p);
-			break;
-
-		case OPCONV:
-			if(!ISICON(p->exprblock.vleng)
-			    || p->exprblock.vleng->constblock.Const.ci!=1
-			    || ! INT(p->exprblock.leftp->headblock.vtype) )
-				Fatal("putch1: bad character conversion");
-			t = mktmp(TYCHAR, ICON(1));
-			e = mkexpr(OPCONV, (expptr)t, ENULL);
-			e->headblock.vtype = tyint;
-			p = putop( mkexpr(OPASSIGN, cpexpr(e), p));
-			putout (p);
-			break;
-		default:
-			badop("putch1", p->exprblock.opcode);
-		}
-		return(t);
-
-	default:
-		badtag("putch1", p->tag);
-	}
-	/* NOT REACHED */ return 0;
-}
-
-
-/* putchop -- Write out a character actual parameter; that is, this is
-   part of a procedure invocation */
-
-Addrp putchop(p)
-expptr p;
-{
-	p = putaddr((expptr)putch1(p));
-	return (Addrp)p;
-}
-
-
-
-
-LOCAL expptr putcheq(p)
-register expptr p;
-{
-	expptr lp, rp;
-	int nbad;
-
-	if(p->tag != TEXPR)
-		badtag("putcheq", p->tag);
-
-	lp = p->exprblock.leftp;
-	rp = p->exprblock.rightp;
-	frexpr(p->exprblock.vleng);
-	free( (charptr) p );
-
-/* If s = t // u, don't bother copying the result, write it directly into
-   this buffer */
-
-	nbad = badchleng(lp) + badchleng(rp);
-	if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT )
-		p = putcat(lp, rp);
-	else if( !nbad
-		&& ISONE(lp->headblock.vleng)
-		&& ISONE(rp->headblock.vleng) ) {
-		lp = mkexpr(OPCONV, lp, ENULL);
-		rp = mkexpr(OPCONV, rp, ENULL);
-		lp->headblock.vtype = rp->headblock.vtype = tyint;
-		p = putop(mkexpr(OPASSIGN, lp, rp));
-		}
-	else
-		p = putx( call2(TYSUBR, "s_copy", lp, rp) );
-	return p;
-}
-
-
-
-
-LOCAL expptr putchcmp(p)
-register expptr p;
-{
-	expptr lp, rp;
-
-	if(p->tag != TEXPR)
-		badtag("putchcmp", p->tag);
-
-	lp = p->exprblock.leftp;
-	rp = p->exprblock.rightp;
-
-	if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) {
-		lp = mkexpr(OPCONV, lp, ENULL);
-		rp = mkexpr(OPCONV, rp, ENULL);
-		lp->headblock.vtype = rp->headblock.vtype = tyint;
-		}
-	else {
-		lp = call2(TYINT,"s_cmp", lp, rp);
-		rp = ICON(0);
-		}
-	p->exprblock.leftp = lp;
-	p->exprblock.rightp = rp;
-	p = putop(p);
-	return p;
-}
-
-
-
-
-
-/* putcat -- Writes out a concatenation operation.  Two temporary arrays
-   are allocated,   putct1()   is called to initialize them, and then a
-   call to runtime library routine   s_cat()   is inserted.
-
-	This routine generates code which will perform an  (nconc lhs rhs)
-   at runtime.  The runtime funciton does not return a value, the routine
-   that calls this   putcat   must remember the name of   lhs.
-*/
-
-
-LOCAL expptr putcat(lhs0, rhs)
- expptr lhs0;
- register expptr rhs;
-{
-	register Addrp lhs = (Addrp)lhs0;
-	int n, tyi;
-	Addrp length_var, string_var;
-	expptr p;
-	static char Writing_concatenation[] = "Writing concatenation";
-
-/* Create the temporary arrays */
-
-	n = ncat(rhs);
-	length_var = mktmpn(n, tyioint, ENULL);
-	string_var = mktmpn(n, TYADDR, ENULL);
-	frtemp((Addrp)cpexpr((expptr)length_var));
-	frtemp((Addrp)cpexpr((expptr)string_var));
-
-/* Initialize the arrays */
-
-	n = 0;
-	/* p1_comment scribbles on its argument, so we
-	 * cannot safely pass a string literal here. */
-	p1_comment(Writing_concatenation);
-	putct1(rhs, length_var, string_var, &n);
-
-/* Create the invocation */
-
-	tyi = tyint;
-	tyint = tyioint;	/* for -I2 */
-	p = putx (call4 (TYSUBR, "s_cat",
-				(expptr)lhs,
-				(expptr)string_var,
-				(expptr)length_var,
-				(expptr)putconst((Constp)ICON(n))));
-	tyint = tyi;
-
-	return p;
-}
-
-
-
-
-
-LOCAL putct1(q, length_var, string_var, ip)
-register expptr q;
-register Addrp length_var, string_var;
-int *ip;
-{
-	int i;
-	Addrp length_copy, string_copy;
-	expptr e;
-	extern int szleng;
-
-	if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT)
-	{
-		putct1(q->exprblock.leftp, length_var, string_var,
-		    ip);
-		putct1(q->exprblock.rightp, length_var, string_var,
-		    ip);
-		frexpr (q -> exprblock.vleng);
-		free ((charptr) q);
-	}
-	else
-	{
-		i = (*ip)++;
-		e = cpexpr(q->headblock.vleng);
-		if (!e)
-			return; /* error -- character*(*) */
-		length_copy = (Addrp) cpexpr((expptr)length_var);
-		length_copy->memoffset =
-		    mkexpr(OPPLUS,length_copy->memoffset, ICON(i*szleng));
-		string_copy = (Addrp) cpexpr((expptr)string_var);
-		string_copy->memoffset =
-		    mkexpr(OPPLUS, string_copy->memoffset,
-			ICON(i*typesize[TYLONG]));
-		putout (PAIR (putassign((expptr)length_copy, e),
-			putassign((expptr)string_copy, addrof((expptr)putch1(q)))));
-	}
-}
-
-/* putaddr -- seems to write out function invocation actual parameters */
-
-LOCAL expptr putaddr(p0)
- expptr p0;
-{
-	register Addrp p;
-
-	if (!(p = (Addrp)p0))
-		return ENULL;
-
-	if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) )
-	{
-		frexpr((expptr)p);
-		return ENULL;
-	}
-	if (p->isarray && p->memoffset)
-		p->memoffset = putx(p->memoffset);
-	return (expptr) p;
-}
-
- LOCAL expptr
-addrfix(e)		/* fudge character string length if it's a TADDR */
- expptr e;
-{
-	return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e;
-	}
-
- LOCAL int
-typekludge(ccall, q, at, j)
- int ccall;
- register expptr q;
- Atype *at;
- int j;	/* alternate type */
-{
-	register int i, k;
-	extern int iocalladdr;
-	register Namep np;
-
-	/* Return value classes:
-	 *	< 100 ==> Fortran arg (pointer to type)
-	 *	< 200 ==> C arg
-	 *	< 300 ==> procedure arg
-	 *	< 400 ==> external, no explicit type
-	 *	< 500 ==> arg that may turn out to be
-	 *		  either a variable or a procedure
-	 */
-
-	k = q->headblock.vtype;
-	if (ccall) {
-		if (k == TYREAL)
-			k = TYDREAL;	/* force double for library routines */
-		return k + 100;
-		}
-	if (k == TYADDR)
-		return iocalladdr;
-	i = q->tag;
-	if ((i == TEXPR && q->exprblock.opcode != OPCOMMA_ARG)
-	||  (i == TADDR && q->addrblock.charleng)
-	||   i == TCONST)
-		k = TYFTNLEN + 100;
-	else if (i == TADDR)
-	    switch(q->addrblock.vclass) {
-		case CLPROC:
-			if (q->addrblock.uname_tag != UNAM_NAME)
-				k += 200;
-			else if ((np = q->addrblock.user.name)->vprocclass
-					!= PTHISPROC) {
-				if (k && !np->vimpltype)
-					k += 200;
-				else {
-					if (j > 200 && infertypes && j < 300) {
-						k = j;
-						inferdcl(np, j-200);
-						}
-					else k = (np->vstg == STGEXT
-						? extsymtab[np->vardesc.varno].extype
-						: 0) + 200;
-					at->cp = mkchain((char *)np, at->cp);
-					}
-				}
-			else if (k == TYSUBR)
-				k += 200;
-			break;
-
-		case CLUNKNOWN:
-			if (q->addrblock.vstg == STGARG
-			 && q->addrblock.uname_tag == UNAM_NAME) {
-				k += 400;
-				at->cp = mkchain((char *)q->addrblock.user.name,
-						at->cp);
-				}
-		}
-	else if (i == TNAME && q->nameblock.vstg == STGARG) {
-		np = &q->nameblock;
-		switch(np->vclass) {
-		    case CLPROC:
-			if (!np->vimpltype)
-				k += 200;
-			else if (j <= 200 || !infertypes || j >= 300)
-				k += 300;
-			else {
-				k = j;
-				inferdcl(np, j-200);
-				}
-			goto add2chain;
-
-		    case CLUNKNOWN:
-			/* argument may be a scalar variable or a function */
-			if (np->vimpltype && j && infertypes
-			&& j < 300) {
-				inferdcl(np, j % 100);
-				k = j;
-				}
-			else
-				k += 400;
-
-			/* to handle procedure args only so far known to be
-			 * external, save a pointer to the symbol table entry...
-		 	 */
- add2chain:
-			at->cp = mkchain((char *)np, at->cp);
-		    }
-		}
-	return k;
-	}
-
- char *
-Argtype(k, buf)
- int k;
- char *buf;
-{
-	if (k < 100) {
-		sprintf(buf, "%s variable", ftn_types[k]);
-		return buf;
-		}
-	if (k < 200) {
-		k -= 100;
-		return ftn_types[k];
-		}
-	if (k < 300) {
-		k -= 200;
-		if (k == TYSUBR)
-			return ftn_types[TYSUBR];
-		sprintf(buf, "%s function", ftn_types[k]);
-		return buf;
-		}
-	if (k < 400)
-		return "external argument";
-	k -= 400;
-	sprintf(buf, "%s argument", ftn_types[k]);
-	return buf;
-	}
-
- static void
-atype_squawk(at, msg)
- Argtypes *at;
- char *msg;
-{
-	register Atype *a, *ae;
-	warn(msg);
-	for(a = at->atypes, ae = a + at->nargs; a < ae; a++)
-		frchain(&a->cp);
-	at->nargs = -1;
-	if (at->changes & 2 && !at->defined)
-		proc_protochanges++;
-	}
-
- static char inconsist[] = "inconsistent calling sequences for ";
-
- void
-bad_atypes(at, fname, i, j, k, here, prev)
- Argtypes *at;
- char *fname, *here, *prev;
- int i, j, k;
-{
-	char buf[208], buf1[32], buf2[32];
-
-	sprintf(buf, "%s%.90s,\n\targ %d: %s%s%s %s.",
-		inconsist, fname, i, here, Argtype(k, buf1),
-		prev, Argtype(j, buf2));
-	atype_squawk(at, buf);
-	}
-
- int
-type_fixup(at,a,k)
- Argtypes *at;
- Atype *a;
- int k;
-{
-	register struct Entrypoint *ep;
-	if (!infertypes)
-		return 0;
-	for(ep = entries; ep; ep = ep->entnextp)
-		if (at == ep->entryname->arginfo) {
-			a->type = k % 100;
-			return proc_argchanges = 1;
-			}
-	return 0;
-	}
-
-
- void
-save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type, zap)
- chainp arglist;
- Argtypes **at0, **at1;
- int ccall, stg, nchargs, type, zap;
- char *fname;
-{
-	Argtypes *at;
-	chainp cp;
-	int i, i0, j, k, nargs, *t, *te;
-	Atype *atypes;
-	expptr q;
-	char buf[208];
-	static int initargs[4] = {TYCOMPLEX, TYDCOMPLEX, TYCHAR, TYFTNLEN+100};
-	static int *init_ap[TYSUBR+1] = {0,0,0,0,0,0,
-				initargs, initargs+1,0,initargs+2};
-	extern int init_ac[TYSUBR+1];
-
-	i0 = init_ac[type];
-	t = init_ap[type];
-	te = t + i0;
-	if (at = *at0) {
-		*at1 = at;
-		nargs = at->nargs;
-		if (nargs < 0 && type && at->changes & 2 && !at->defined)
-			--proc_protochanges;
-		if (at->dnargs >= 0 && zap != 2)
-			type = 0;
-		if (nargs < 0) { /* inconsistent usage seen */
-			if (type)
-				goto newlist;
-			return;
-			}
-		atypes = at->atypes;
-		i = nchargs;
-		for(; t < te; atypes++) {
-			if (++i > nargs) {
- toomany:
-				i = nchargs + i0;
-				for(cp = arglist; cp; cp = cp->nextp)
-					i++;
- toofew:
-				sprintf(buf,
-		"%s%.90s:\n\there %d, previously %d args and string lengths.",
-					inconsist, fname, i, nargs);
-				atype_squawk(at, buf);
- retn:
-				if (type)
-					goto newlist;
-				return;
-				}
-			j = atypes->type;
-			k = *t++;
-			if (j != k)
-				goto badtypes;
-			}
-		for(cp = arglist; cp; atypes++, cp = cp->nextp) {
-			if (++i > nargs)
-				goto toomany;
-			j = atypes->type;
-			if (!(q = (expptr)cp->datap))
-				continue;
-			k = typekludge(ccall, q, atypes, j);
-			if (k >= 300 || k == j)
-				continue;
-			if (j >= 300) {
-				if (k >= 200) {
-					if (k == TYUNKNOWN + 200)
-						continue;
-					if (j % 100 != k - 200
-					 && k != TYSUBR + 200
-					 && j != TYUNKNOWN + 300
-					 && !type_fixup(at,atypes,k))
-						goto badtypes;
-					}
-				else if (j % 100 % TYSUBR != k % TYSUBR
-						&& !type_fixup(at,atypes,k))
-					goto badtypes;
-				}
-			else if (k < 200 || j < 200)
-				if (j)
-					goto badtypes;
-				else ; /* fall through to update */
-			else if (k == TYUNKNOWN+200)
-				continue;
-			else if (j != TYUNKNOWN+200)
-				{
- badtypes:
-				bad_atypes(at, fname, i, j, k, "here ",
-						", previously");
-				if (type) {
-					/* we're defining the procedure */
-					t = init_ap[type];
-					te = t + i0;
-					proc_argchanges = 1;
-					goto newlist;
-					}
-				goto retn;
-				}
-			/* We've subsequently learned the right type,
-			   as in the call on zoo below...
-
-				subroutine foo(x, zap)
-				external zap
-				call goo(zap)
-				x = zap(3)
-				call zoo(zap)
-				end
-			 */
-			atypes->type = k;
-			at->changes |= 1;
-			}
-		if (i < nargs)
-			goto toofew;
-		if (zap == 1 && (at->changes & 5) != 5)
-			at->changes = 0;
-		return;
-		}
- newlist:
-	i = i0 + nchargs;
-	for(cp = arglist; cp; cp = cp->nextp)
-		i++;
-	k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
-	*at0 = *at1 = at = stg == STGEXT ? (Argtypes *)gmem(k,1)
-					 : (Argtypes *) mem(k,1);
-	at->dnargs = at->nargs = i;
-	at->defined = zap & 2;
-	at->changes = type ? 0 : 4;
-	atypes = at->atypes;
-	for(; t < te; atypes++) {
-		atypes->type = *t++;
-		atypes->cp = 0;
-		}
-	for(cp = arglist; cp; atypes++, cp = cp->nextp) {
-		atypes->cp = 0;
-		atypes->type = (q = (expptr)cp->datap)
-			? typekludge(ccall, q, atypes, 0)
-			: 0;
-		}
-	for(; --nchargs >= 0; atypes++) {
-		atypes->type = TYFTNLEN + 100;
-		atypes->cp = 0;
-		}
-	}
-
- void
-saveargtypes(p)		/* for writing prototypes */
- register Exprp p;
-{
-	Addrp a;
-	Argtypes **at0, **at1;
-	Namep np;
-	chainp arglist;
-	expptr rp;
-	Extsym *e;
-	char *fname;
-
-	a = (Addrp)p->leftp;
-	switch(a->vstg) {
-		case STGEXT:
-			switch(a->uname_tag) {
-				case UNAM_EXTERN:	/* e.g., sqrt() */
-					e = extsymtab + a->memno;
-					at0 = at1 = &e->arginfo;
-					fname = e->fextname;
-					break;
-				case UNAM_NAME:
-					np = a->user.name;
-					at0 = &extsymtab[np->vardesc.varno].arginfo;
-					at1 = &np->arginfo;
-					fname = np->fvarname;
-					break;
-				default:
-					goto bug;
-				}
-			break;
-		case STGARG:
-			if (a->uname_tag != UNAM_NAME)
-				goto bug;
-			np = a->user.name;
-			at0 = at1 = &np->arginfo;
-			fname = np->fvarname;
-			break;
-		default:
-	 bug:
-			Fatal("Confusion in saveargtypes");
-		}
-	rp = p->rightp;
-	arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0;
-	save_argtypes(arglist, at0, at1, p->opcode == OPCCALL,
-		fname, a->vstg, 0, 0, 0);
-	}
-
-/* putcall - fix up the argument list, and write out the invocation.   p
-   is expected to be initialized and point to an OPCALL or OPCCALL
-   expression.  The return value is a pointer to a temporary holding the
-   result of a COMPLEX or CHARACTER operation, or NULL. */
-
-LOCAL expptr putcall(p0, temp)
- expptr p0;
- Addrp *temp;
-{
-    register Exprp p = (Exprp)p0;
-    chainp arglist;		/* Pointer to actual arguments, if any */
-    chainp charsp;		/* List of copies of the variables which
-				   hold the lengths of character
-				   parameters (other than procedure
-				   parameters) */
-    chainp cp;			/* Iterator over argument lists */
-    register expptr q;		/* Pointer to the current argument */
-    Addrp fval;			/* Function return value */
-    int type;			/* type of the call - presumably this was
-				   set elsewhere */
-    int byvalue;		/* True iff we don't want to massage the
-				   parameter list, since we're calling a C
-				   library routine */
-    extern int Castargs;
-    char *s;
-    extern struct Listblock *mklist();
-
-    type = p -> vtype;
-    charsp = NULL;
-    byvalue =  (p->opcode == OPCCALL);
-
-/* Verify the actual parameters */
-
-    if (p == (Exprp) NULL)
-	err ("putcall:  NULL call expression");
-    else if (p -> tag != TEXPR)
-	erri ("putcall:  expected TEXPR, got '%d'", p -> tag);
-
-/* Find the argument list */
-
-    if(p->rightp && p -> rightp -> tag == TLIST)
-	arglist = p->rightp->listblock.listp;
-    else
-	arglist = NULL;
-
-/* Count the number of explicit arguments, including lengths of character
-   variables */
-
-    for(cp = arglist ; cp ; cp = cp->nextp)
-	if(!byvalue) {
-	    q = (expptr) cp->datap;
-	    if( ISCONST(q) )
-	    {
-
-/* Even constants are passed by reference, so we need to put them in the
-   literal table */
-
-		q = (expptr) putconst((Constp)q);
-		cp->datap = (char *) q;
-	    }
-
-/* Save the length expression of character variables (NOT character
-   procedures) for the end of the argument list */
-
-	    if( ISCHAR(q) &&
-		(q->headblock.vclass != CLPROC
-		|| q->headblock.vstg == STGARG
-			&& q->tag == TADDR
-			&& q->addrblock.uname_tag == UNAM_NAME
-			&& q->addrblock.user.name->vprocclass == PTHISPROC))
-	    {
-		p0 = cpexpr(q->headblock.vleng);
-		charsp = mkchain((char *)p0, charsp);
-		if (q->headblock.vclass == CLUNKNOWN
-		 && q->headblock.vstg == STGARG)
-			q->addrblock.user.name->vpassed = 1;
-		else if (q->tag == TADDR
-				&& q->addrblock.uname_tag == UNAM_CONST)
-			p0->constblock.Const.ci
-				+= q->addrblock.user.Const.ccp1.blanks;
-	    }
-	}
-    charsp = revchain(charsp);
-
-/* If the routine is a CHARACTER function ... */
-
-    if(type == TYCHAR)
-    {
-	if( ISICON(p->vleng) )
-	{
-
-/* Allocate a temporary to hold the return value of the function */
-
-	    fval = mktmp(TYCHAR, p->vleng);
-	}
-	else    {
-		err("adjustable character function");
-		if (temp)
-			*temp = 0;
-		return 0;
-		}
-    }
-
-/* If the routine is a COMPLEX function ... */
-
-    else if( ISCOMPLEX(type) )
-	fval = mktmp(type, ENULL);
-    else
-	fval = NULL;
-
-/* Write the function name, without taking its address */
-
-    p -> leftp = putx(fixtype(putaddr(p->leftp)));
-
-    if(fval)
-    {
-	chainp prepend;
-
-/* Prepend a copy of the function return value buffer out as the first
-   argument. */
-
-	prepend = mkchain((char *)putx(putaddr(cpexpr((expptr)fval))), arglist);
-
-/* If it's a character function, also prepend the length of the result */
-
-	if(type==TYCHAR)
-	{
-
-	    prepend->nextp = mkchain((char *)putx(mkconv(TYLENG,
-					p->vleng)), arglist);
-	}
-	if (!(q = p->rightp))
-		p->rightp = q = (expptr)mklist(CHNULL);
-	q->listblock.listp = prepend;
-    }
-
-/* Scan through the fortran argument list */
-
-    for(cp = arglist ; cp ; cp = cp->nextp)
-    {
-	q = (expptr) (cp->datap);
-	if (q == ENULL)
-	    err ("putcall:  NULL argument");
-
-/* call putaddr only when we've got a parameter for a C routine or a
-   memory resident parameter */
-
-	if (q -> tag == TCONST && !byvalue)
-	    q = (expptr) putconst ((Constp)q);
-
-	if(q->tag==TADDR && (byvalue || q->addrblock.vstg!=STGREG) )
-		cp->datap = (char *)putaddr(q);
-	else if( ISCOMPLEX(q->headblock.vtype) )
-	    cp -> datap = (char *) putx (fixtype(putcxop(q)));
-	else if (ISCHAR(q) )
-	    cp -> datap = (char *) putx (fixtype((expptr)putchop(q)));
-	else if( ! ISERROR(q) )
-	{
-	    if(byvalue
-	    || q->tag == TEXPR && q->exprblock.opcode == OPCHARCAST)
-		cp -> datap = (char *) putx(q);
-	    else {
-		expptr t, t1;
-
-/* If we've got a register parameter, or (maybe?) a constant, save it in a
-   temporary first */
-
-		t = (expptr) mktmp(q->headblock.vtype, q->headblock.vleng);
-
-/* Assign to temporary variables before invoking the subroutine or
-   function */
-
-		t1 = putassign( cpexpr(t), q );
-		if (doin_setbound)
-			t = mkexpr(OPCOMMA_ARG, t1, t);
-		else
-			putout(t1);
-		cp -> datap = (char *) t;
-	    } /* else */
-	} /* if !ISERROR(q) */
-    }
-
-/* Now adjust the lengths of the CHARACTER parameters */
-
-    for(cp = charsp ; cp ; cp = cp->nextp)
-	cp->datap = (char *)addrfix(putx(
-			/* in case MAIN has a character*(*)... */
-			(s = cp->datap) ? mkconv(TYLENG,(expptr)s)
-					 : ICON(0)));
-
-/* ... and add them to the end of the argument list */
-
-    hookup (arglist, charsp);
-
-/* Return the name of the temporary used to hold the results, if any was
-   necessary. */
-
-    if (temp) *temp = fval;
-    else frexpr ((expptr)fval);
-
-    saveargtypes(p);
-
-    return (expptr) p;
-}
-
-
-
-/* putmnmx -- Put min or max.   p   must point to an EXPR, not just a
-   CONST */
-
-LOCAL expptr putmnmx(p)
-register expptr p;
-{
-	int op, op2, type;
-	expptr arg, qp, temp;
-	chainp p0, p1;
-	Addrp sp, tp;
-	char comment_buf[80];
-	char *what;
-
-	if(p->tag != TEXPR)
-		badtag("putmnmx", p->tag);
-
-	type = p->exprblock.vtype;
-	op = p->exprblock.opcode;
-	op2 = op == OPMIN ? OPMIN2 : OPMAX2;
-	p0 = p->exprblock.leftp->listblock.listp;
-	free( (charptr) (p->exprblock.leftp) );
-	free( (charptr) p );
-
-	/* special case for two addressable operands */
-
-	if (addressable((expptr)p0->datap)
-	 && (p1 = p0->nextp)
-	 && addressable((expptr)p1->datap)
-	 && !p1->nextp) {
-		if (type == TYREAL && forcedouble)
-			op2 = op == OPMIN ? OPDMIN : OPDMAX;
-		p = mkexpr(op2, mkconv(type, cpexpr((expptr)p0->datap)),
-				mkconv(type, cpexpr((expptr)p1->datap)));
-		frchain(&p0);
-		return p;
-		}
-
-	/* general case */
-
-	sp = mktmp(type, ENULL);
-
-/* We only need a second temporary if the arg list has an unaddressable
-   value */
-
-	tp = (Addrp) NULL;
-	qp = ENULL;
-	for (p1 = p0 -> nextp; p1; p1 = p1 -> nextp)
-		if (!addressable ((expptr) p1 -> datap)) {
-			tp = mktmp(type, ENULL);
-			qp = mkexpr(op2, cpexpr((expptr)sp), cpexpr((expptr)tp));
-			qp = fixexpr((Exprp)qp);
-			break;
-		} /* if */
-
-/* Now output the appropriate number of assignments and comparisons.  Min
-   and max are implemented by the simple O(n) algorithm:
-
-	min (a, b, c, d) ==>
-	{ <type> t1, t2;
-
-	    t1 = a;
-	    t2 = b; t1 = (t1 < t2) ? t1 : t2;
-	    t2 = c; t1 = (t1 < t2) ? t1 : t2;
-	    t2 = d; t1 = (t1 < t2) ? t1 : t2;
-	}
-*/
-
-	if (!doin_setbound) {
-		switch(op) {
-			case OPLT:
-			case OPMIN:
-			case OPDMIN:
-			case OPMIN2:
-				what = "IN";
-				break;
-			default:
-				what = "AX";
-			}
-		sprintf (comment_buf, "Computing M%s", what);
-		p1_comment (comment_buf);
-		}
-
-	p1 = p0->nextp;
-	temp = (expptr)p0->datap;
-	if (addressable(temp) && addressable((expptr)p1->datap)) {
-		p = mkconv(type, cpexpr(temp));
-		arg = mkconv(type, cpexpr((expptr)p1->datap));
-		temp = mkexpr(op2, p, arg);
-		if (!ISCONST(temp))
-			temp = fixexpr((Exprp)temp);
-		p1 = p1->nextp;
-		}
-	p = putassign (cpexpr((expptr)sp), temp);
-
-	for(; p1 ; p1 = p1->nextp)
-	{
-		if (addressable ((expptr) p1 -> datap)) {
-			arg = mkconv(type, cpexpr((expptr)p1->datap));
-			temp = mkexpr(op2, cpexpr((expptr)sp), arg);
-			temp = fixexpr((Exprp)temp);
-		} else {
-			temp = (expptr) cpexpr (qp);
-			p = mkexpr(OPCOMMA, p,
-				putassign(cpexpr((expptr)tp), (expptr)p1->datap));
-		} /* else */
-
-		if(p1->nextp)
-			p = mkexpr(OPCOMMA, p,
-				putassign(cpexpr((expptr)sp), temp));
-		else {
-			if (type == TYREAL && forcedouble)
-				temp->exprblock.opcode =
-					op == OPMIN ? OPDMIN : OPDMAX;
-			if (doin_setbound)
-				p = mkexpr(OPCOMMA, p, temp);
-			else {
-				putout (p);
-				p = putx(temp);
-				}
-			if (qp)
-				frexpr (qp);
-		} /* else */
-	} /* for */
-
-	frchain( &p0 );
-	return p;
-}
-
-
- void
-putwhile(p)
- expptr p;
-{
-	long where;
-	int k, n;
-
-	if (wh_next >= wh_last)
-		{
-		k = wh_last - wh_first;
-		n = k + 100;
-		wh_next = mem(n,0);
-		wh_last = wh_first + n;
-		if (k)
-			memcpy(wh_next, wh_first, k);
-		wh_first =  wh_next;
-		wh_next += k;
-		wh_last = wh_first + n;
-		}
-	if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
-		{
-		if(k != TYERROR)
-			err("non-logical expression in DO WHILE statement");
-		}
-	else	{
-		p1put(P1_WHILE1START);
-		where = ftell(pass1_file);
-		p = putx(p);
-		*wh_next++ = ftell(pass1_file) > where;
-		p1put(P1_WHILE2START);
-		p1_expr(p);
-		}
-	}
//GO.SYSIN DD putpcc.c
echo sysdep.c 1>&2
sed >sysdep.c <<'//GO.SYSIN DD sysdep.c' 's/^-//'
-/****************************************************************
-Copyright 1990, 1991, 1992 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.
-****************************************************************/
-#include "defs.h"
-#include "usignal.h"
-
-char binread[] = "rb", textread[] = "r";
-char binwrite[] = "wb", textwrite[] = "w";
-char *c_functions	= "c_functions";
-char *coutput		= "c_output";
-char *initfname		= "raw_data";
-char *initbname		= "raw_data.b";
-char *blkdfname		= "block_data";
-char *p1_file		= "p1_file";
-char *p1_bakfile	= "p1_file.BAK";
-char *sortfname		= "init_file";
-char *proto_fname	= "proto_file";
-
-char link_msg[]		= "-lF77 -lI77 -lm -lc";
-
-#ifndef TMPDIR
-#ifdef MSDOS
-#define TMPDIR ""
-#else
-#define TMPDIR "/tmp"
-#endif
-#endif
-
-char *tmpdir = TMPDIR;
-
- void
-Un_link_all(cdelete)
-{
-	if (!debugflag) {
-		unlink(c_functions);
-		unlink(initfname);
-		unlink(p1_file);
-		unlink(sortfname);
-		unlink(blkdfname);
-		if (cdelete && coutput)
-			unlink(coutput);
-		}
-	}
-
- void
-set_tmp_names()
-{
-	int k;
-	if (debugflag == 1)
-		return;
-	k = strlen(tmpdir) + 16;
-	c_functions = (char *)ckalloc(7*k);
-	initfname = c_functions + k;
-	initbname = initfname + k;
-	blkdfname = initbname + k;
-	p1_file = blkdfname + k;
-	p1_bakfile = p1_file + k;
-	sortfname = p1_bakfile + k;
-	{
-#ifdef MSDOS
-	char buf[64], *s, *t;
-	if (!*tmpdir || *tmpdir == '.' && !tmpdir[1])
-		t = "";
-	else {
-		/* substitute \ for / to avoid confusion with a
-		 * switch indicator in the system("sort ...")
-		 * call in formatdata.c
-		 */
-		for(s = tmpdir, t = buf; *s; s++, t++)
-			if ((*t = *s) == '/')
-				*t = '\\';
-		if (t[-1] != '\\')
-			*t++ = '\\';
-		*t = 0;
-		t = buf;
-		}
-	sprintf(c_functions, "%sf2c_func", t);
-	sprintf(initfname, "%sf2c_rd", t);
-	sprintf(blkdfname, "%sf2c_blkd", t);
-	sprintf(p1_file, "%sf2c_p1f", t);
-	sprintf(p1_bakfile, "%sf2c_p1fb", t);
-	sprintf(sortfname, "%sf2c_sort", t);
-#else
-	int pid = getpid();
-	sprintf(c_functions, "%s/f2c%d_func", tmpdir, pid);
-	sprintf(initfname, "%s/f2c%d_rd", tmpdir, pid);
-	sprintf(blkdfname, "%s/f2c%d_blkd", tmpdir, pid);
-	sprintf(p1_file, "%s/f2c%d_p1f", tmpdir, pid);
-	sprintf(p1_bakfile, "%s/f2c%d_p1fb", tmpdir, pid);
-	sprintf(sortfname, "%s/f2c%d_sort", tmpdir, pid);
-#endif
-	sprintf(initbname, "%s.b", initfname);
-	}
-	if (debugflag)
-		fprintf(diagfile, "%s %s %s %s %s %s\n", c_functions,
-			initfname, blkdfname, p1_file, p1_bakfile, sortfname);
-	}
-
- char *
-c_name(s,ft)char *s;
-{
-	char *b, *s0;
-	int c;
-
-	b = s0 = s;
-	while(c = *s++)
-		if (c == '/')
-			b = s;
-	if (--s < s0 + 3 || s[-2] != '.'
-			 || ((c = *--s) != 'f' && c != 'F')) {
-		infname = s0;
-		Fatal("file name must end in .f or .F");
-		}
-	*s = ft;
-	b = copys(b);
-	*s = c;
-	return b;
-	}
-
- static void
-killed(sig)
-{
-	signal(SIGINT, SIG_IGN);
-#ifdef SIGQUIT
-	signal(SIGQUIT, SIG_IGN);
-#endif
-#ifdef SIGHUP
-	signal(SIGHUP, SIG_IGN);
-#endif
-	signal(SIGTERM, SIG_IGN);
-	Un_link_all(1);
-	exit(126);
-	}
-
- static void
-sig1catch(sig)
-{
-	if (signal(sig, SIG_IGN) != SIG_IGN)
-		signal(sig, killed);
-	}
-
- static void
-flovflo(sig)
-{
-	Fatal("floating exception during constant evaluation; cannot recover");
-	/* vax returns a reserved operand that generates
-	   an illegal operand fault on next instruction,
-	   which if ignored causes an infinite loop.
-	*/
-	signal(SIGFPE, flovflo);
-}
-
- void
-sigcatch(sig)
-{
-	sig1catch(SIGINT);
-#ifdef SIGQUIT
-	sig1catch(SIGQUIT);
-#endif
-#ifdef SIGHUP
-	sig1catch(SIGHUP);
-#endif
-	sig1catch(SIGTERM);
-	signal(SIGFPE, flovflo);  /* catch overflows */
-	}
-
-
-dofork()
-{
-#ifdef MSDOS
-	Fatal("Only one Fortran input file allowed under MS-DOS");
-#else
-	int pid, status, w;
-	extern int retcode;
-
-	if (!(pid = fork()))
-		return 1;
-	if (pid == -1)
-		Fatal("bad fork");
-	while((w = wait(&status)) != pid)
-		if (w == -1)
-			Fatal("bad wait code");
-	retcode |= status >> 8;
-#endif
-	return 0;
-	}
-
-/* Initialization of tables that change with the character set... */
-
-char escapes[Table_size];
-
-#ifdef non_ASCII
-char *str_fmt[Table_size];
-static char *str0fmt[127] = { /*}*/
-#else
-char *str_fmt[Table_size] = {
-#endif
- "\\000", "\\001", "\\002", "\\003", "\\004", "\\005", "\\006", "\\007",
-   "\\b",   "\\t",   "\\n", "\\013",   "\\f",   "\\r", "\\016", "\\017",
- "\\020", "\\021", "\\022", "\\023", "\\024", "\\025", "\\026", "\\027",
- "\\030", "\\031", "\\032", "\\033", "\\034", "\\035", "\\036", "\\037",
-     " ",     "!",  "\\\"",     "#",     "$",     "%%",    "&",     "'",
-     "(",     ")",     "*",     "+",     ",",     "-",     ".",     "/",
-     "0",     "1",     "2",     "3",     "4",     "5",     "6",     "7",
-     "8",     "9",     ":",     ";",     "<",     "=",     ">",     "?",
-     "@",     "A",     "B",     "C",     "D",     "E",     "F",     "G",
-     "H",     "I",     "J",     "K",     "L",     "M",     "N",     "O",
-     "P",     "Q",     "R",     "S",     "T",     "U",     "V",     "W",
-     "X",     "Y",     "Z",     "[",  "\\\\",     "]",     "^",     "_",
-     "`",     "a",     "b",     "c",     "d",     "e",     "f",     "g",
-     "h",     "i",     "j",     "k",     "l",     "m",     "n",     "o",
-     "p",     "q",     "r",     "s",     "t",     "u",     "v",     "w",
-     "x",     "y",     "z",     "{",     "|",     "}",     "~"
-     };
-
-#ifdef non_ASCII
-char *chr_fmt[Table_size];
-static char *chr0fmt[127] = {	/*}*/
-#else
-char *chr_fmt[Table_size] = {
-#endif
-   "\\0",   "\\1",   "\\2",   "\\3",   "\\4",   "\\5",   "\\6",   "\\7",
-   "\\b",   "\\t",   "\\n",  "\\13",   "\\f",   "\\r",  "\\16",  "\\17",
-  "\\20",  "\\21",  "\\22",  "\\23",  "\\24",  "\\25",  "\\26",  "\\27",
-  "\\30",  "\\31",  "\\32",  "\\33",  "\\34",  "\\35",  "\\36",  "\\37",
-     " ",     "!",    "\"",     "#",     "$",     "%%",    "&",   "\\'",
-     "(",     ")",     "*",     "+",     ",",     "-",     ".",     "/",
-     "0",     "1",     "2",     "3",     "4",     "5",     "6",     "7",
-     "8",     "9",     ":",     ";",     "<",     "=",     ">",     "?",
-     "@",     "A",     "B",     "C",     "D",     "E",     "F",     "G",
-     "H",     "I",     "J",     "K",     "L",     "M",     "N",     "O",
-     "P",     "Q",     "R",     "S",     "T",     "U",     "V",     "W",
-     "X",     "Y",     "Z",     "[",  "\\\\",     "]",     "^",     "_",
-     "`",     "a",     "b",     "c",     "d",     "e",     "f",     "g",
-     "h",     "i",     "j",     "k",     "l",     "m",     "n",     "o",
-     "p",     "q",     "r",     "s",     "t",     "u",     "v",     "w",
-     "x",     "y",     "z",     "{",     "|",     "}",     "~"
-     };
-
- void
-fmt_init()
-{
-	static char *str1fmt[6] =
-		{ "\\b", "\\t", "\\n", "\\f", "\\r", "\\%03o" };
-	register int i, j;
-	register char *s;
-
-	/* str_fmt */
-
-#ifdef non_ASCII
-	i = 0;
-#else
-	i = 127;
-#endif
-	for(; i < Table_size; i++)
-		str_fmt[i] = "\\%03o";
-#ifdef non_ASCII
-	for(i = 32; i < 127; i++) {
-		s = str0fmt[i];
-		str_fmt[*(unsigned char *)s] = s;
-		}
-	str_fmt['"'] = "\\\"";
-#else
-	if (Ansi == 1)
-		str_fmt[7] = chr_fmt[7] = "\\a";
-#endif
-
-	/* chr_fmt */
-
-#ifdef non_ASCII
-	for(i = 0; i < 32; i++)
-		chr_fmt[i] = chr0fmt[i];
-#else
-	i = 127;
-#endif
-	for(; i < Table_size; i++)
-		chr_fmt[i] = "\\%o";
-#ifdef non_ASCII
-	for(i = 32; i < 127; i++) {
-		s = chr0fmt[i];
-		j = *(unsigned char *)s;
-		if (j == '\\')
-			j = *(unsigned char *)(s+1);
-		chr_fmt[j] = s;
-		}
-#endif
-
-	/* escapes (used in lex.c) */
-
-	for(i = 0; i < Table_size; i++)
-		escapes[i] = i;
-	for(s = "btnfr0", i = 0; i < 6; i++)
-		escapes[*(unsigned char *)s++] = "\b\t\n\f\r"[i];
-	/* finish str_fmt and chr_fmt */
-
-	if (Ansi)
-		str1fmt[5] = "\\v";
-	if ('\v' == 'v') { /* ancient C compiler */
-		str1fmt[5] = "v";
-#ifndef non_ASCII
-		escapes['v'] = 11;
-#endif
-		}
-	else
-		escapes['v'] = '\v';
-	for(s = "\b\t\n\f\r\v", i = 0; j = *(unsigned char *)s++;)
-		str_fmt[j] = chr_fmt[j] = str1fmt[i++];
-	/* '\v' = 11 for both EBCDIC and ASCII... */
-	chr_fmt[11] = Ansi ? "\\v" : "\\13";
-	}
-
-
-
-/* Unless SYSTEM_SORT is defined, the following gives a simple
- * in-core version of dsort().  On Fortran source with huge DATA
- * statements, the in-core version may exhaust the available memory,
- * in which case you might either recompile this source file with
- * SYSTEM_SORT defined (if that's reasonable on your system), or
- * replace the dsort below with a more elaborate version that
- * does a merging sort with the help of auxiliary files.
- */
-
-#ifdef SYSTEM_SORT
-
-dsort(from, to)
- char *from, *to;
-{
-	char buf[200];
-	sprintf(buf, "sort <%s >%s", from, to);
-	return system(buf) >> 8;
-	}
-#else
-
- static int
-compare(a,b)
- char *a, *b;
-{ return strcmp(*(char **)a, *(char **)b); }
-
-dsort(from, to)
- char *from, *to;
-{
-	extern char *Alloc();
-
-	struct Memb {
-		struct Memb *next;
-		int n;
-		char buf[32000];
-		};
-	typedef struct Memb memb;
-	memb *mb, *mb1;
-	register char *x, *x0, *xe;
-	register int c, n;
-	FILE *f;
-	char **z, **z0;
-	int nn = 0;
-
-	f = opf(from, textread);
-	mb = (memb *)Alloc(sizeof(memb));
-	mb->next = 0;
-	x0 = x = mb->buf;
-	xe = x + sizeof(mb->buf);
-	n = 0;
-	for(;;) {
-		c = getc(f);
-		if (x >= xe && (c != EOF || x != x0)) {
-			if (!n)
-				return 126;
-			nn += n;
-			mb->n = n;
-			mb1 = (memb *)Alloc(sizeof(memb));
-			mb1->next = mb;
-			mb = mb1;
-			memcpy(mb->buf, x0, n = x-x0);
-			x0 = mb->buf;
-			x = x0 + n;
-			xe = x0 + sizeof(mb->buf);
-			n = 0;
-			}
-		if (c == EOF)
-			break;
-		if (c == '\n') {
-			++n;
-			*x++ = 0;
-			x0 = x;
-			}
-		else
-			*x++ = c;
-		}
-	clf(&f, from, 1);
-	f = opf(to, textwrite);
-	if (x > x0) { /* shouldn't happen */
-		*x = 0;
-		++n;
-		}
-	mb->n = n;
-	nn += n;
-	if (!nn) /* shouldn't happen */
-		goto done;
-	z = z0 = (char **)Alloc(nn*sizeof(char *));
-	for(mb1 = mb; mb1; mb1 = mb1->next) {
-		x = mb1->buf;
-		n = mb1->n;
-		for(;;) {
-			*z++ = x;
-			if (--n <= 0)
-				break;
-			while(*x++);
-			}
-		}
-	qsort((char *)z0, nn, sizeof(char *), compare);
-	for(n = nn, z = z0; n > 0; n--)
-		fprintf(f, "%s\n", *z++);
-	free((char *)z0);
- done:
-	clf(&f, to, 1);
-	do {
-		mb1 = mb->next;
-		free((char *)mb);
-		}
-		while(mb = mb1);
-	return 0;
-	}
-#endif
//GO.SYSIN DD sysdep.c
echo sysdep.h 1>&2
sed >sysdep.h <<'//GO.SYSIN DD sysdep.h' 's/^-//'
-/****************************************************************
-Copyright 1990, 1991 by AT&T Bell Laboratories, 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.
-****************************************************************/
-
-/* This file is included at the start of defs.h; this file
- * is an initial attempt to gather in one place some declarations
- * that may need to be tweaked on some systems.
- */
-
-#ifdef __STDC__
-#ifndef ANSI_Libraries
-#define ANSI_Libraries
-#endif
-#ifndef ANSI_Prototypes
-#define ANSI_Prototypes
-#endif
-#endif
-
-#ifdef __BORLANDC__
-#define MSDOS
-extern int ind_printf(), nice_printf();
-#endif
-
-#ifdef __ZTC__	/* Zortech */
-#define MSDOS
-extern int ind_printf(...), nice_printf(...);
-#endif
-
-#ifdef MSDOS
-#define ANSI_Libraries
-#define ANSI_Prototypes
-#define LONG_CAST (long)
-#else
-#define LONG_CAST
-#endif
-
-#include <stdio.h>
-
-#ifdef ANSI_Libraries
-#include <stddef.h>
-#include <stdlib.h>
-#else
-char *calloc(), *malloc(), *memcpy(), *memset(), *realloc();
-typedef int size_t;
-#ifdef ANSI_Prototypes
-extern double atof(const char *);
-#else
-extern double atof();
-#endif
-#endif
-
-#ifdef ANSI_Prototypes
-extern char *gmem(int, int);
-extern char *mem(int, int);
-extern char *Alloc(int);
-extern int* ckalloc(int);
-#else
-extern char *Alloc(), *gmem(), *mem();
-int *ckalloc();
-#endif
-
-/* On systems like VMS where fopen might otherwise create
- * multiple versions of intermediate files, you may wish to
- * #define scrub(x) unlink(x)
- */
-#ifndef scrub
-#define scrub(x) /* do nothing */
-#endif
-
-/* On systems that severely limit the total size of statically
- * allocated arrays, you may need to change the following to
- *	extern char **chr_fmt, *escapes, **str_fmt;
- * and to modify sysdep.c appropriately
- */
-extern char *chr_fmt[], escapes[], *str_fmt[];
-
-#include <string.h>
-
-#include "ctype.h"
-
-#define Table_size 256
-/* Table_size should be 1 << (bits/byte) */
//GO.SYSIN DD sysdep.h
echo tokens 1>&2
sed >tokens <<'//GO.SYSIN DD tokens' 's/^-//'
-SEOS
-SCOMMENT
-SLABEL
-SUNKNOWN
-SHOLLERITH
-SICON
-SRCON
-SDCON
-SBITCON
-SOCTCON
-SHEXCON
-STRUE
-SFALSE
-SNAME
-SNAMEEQ
-SFIELD
-SSCALE
-SINCLUDE
-SLET
-SASSIGN
-SAUTOMATIC
-SBACKSPACE
-SBLOCK
-SCALL
-SCHARACTER
-SCLOSE
-SCOMMON
-SCOMPLEX
-SCONTINUE
-SDATA
-SDCOMPLEX
-SDIMENSION
-SDO
-SDOUBLE
-SELSE
-SELSEIF
-SEND
-SENDFILE
-SENDIF
-SENTRY
-SEQUIV
-SEXTERNAL
-SFORMAT
-SFUNCTION
-SGOTO
-SASGOTO
-SCOMPGOTO
-SARITHIF
-SLOGIF
-SIMPLICIT
-SINQUIRE
-SINTEGER
-SINTRINSIC
-SLOGICAL
-SNAMELIST
-SOPEN
-SPARAM
-SPAUSE
-SPRINT
-SPROGRAM
-SPUNCH
-SREAD
-SREAL
-SRETURN
-SREWIND
-SSAVE
-SSTATIC
-SSTOP
-SSUBROUTINE
-STHEN
-STO
-SUNDEFINED
-SWRITE
-SLPAR
-SRPAR
-SEQUALS
-SCOLON
-SCOMMA
-SCURRENCY
-SPLUS
-SMINUS
-SSTAR
-SSLASH
-SPOWER
-SCONCAT
-SAND
-SOR
-SNEQV
-SEQV
-SNOT
-SEQ
-SLT
-SGT
-SLE
-SGE
-SNE
-SENDDO
-SWHILE
-SSLASHD
//GO.SYSIN DD tokens
echo usignal.h 1>&2
sed >usignal.h <<'//GO.SYSIN DD usignal.h' 's/^-//'
-#include <signal.h>
-#ifndef SIGHUP
-#define	SIGHUP	1	/* hangup */
-#endif
-#ifndef SIGQUIT
-#define	SIGQUIT	3	/* quit */
-#endif
//GO.SYSIN DD usignal.h
echo vax.c 1>&2
sed >vax.c <<'//GO.SYSIN DD vax.c' 's/^-//'
-/****************************************************************
-Copyright 1990, 1992 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.
-****************************************************************/
-
-#include "defs.h"
-#include "pccdefs.h"
-#include "output.h"
-
-int regnum[] =  {
-	11, 10, 9, 8, 7, 6 };
-
-/* Put out a constant integer */
-
-prconi(fp, n)
-FILEP fp;
-ftnint n;
-{
-	fprintf(fp, "\t%ld\n", n);
-}
-
-
-
-/* Put out a constant address */
-
-prcona(fp, a)
-FILEP fp;
-ftnint a;
-{
-	fprintf(fp, "\tL%ld\n", a);
-}
-
-
-
-prconr(fp, x, k)
- FILEP fp;
- int k;
- Constp x;
-{
-	char *x0, *x1;
-	char cdsbuf0[64], cdsbuf1[64];
-
-	if (k > 1) {
-		if (x->vstg) {
-			x0 = x->Const.cds[0];
-			x1 = x->Const.cds[1];
-			}
-		else {
-			x0 = cds(dtos(x->Const.cd[0]), cdsbuf0);
-			x1 = cds(dtos(x->Const.cd[1]), cdsbuf1);
-			}
-		fprintf(fp, "\t%s %s\n", x0, x1);
-		}
-	else
-		fprintf(fp, "\t%s\n", x->vstg ? x->Const.cds[0]
-				: cds(dtos(x->Const.cd[0]), cdsbuf0));
-}
-
-
-char *memname(stg, mem)
- int stg;
- long mem;
-{
-	static char s[20];
-
-	switch(stg)
-	{
-	case STGCOMMON:
-	case STGEXT:
-		sprintf(s, "_%s", extsymtab[mem].cextname);
-		break;
-
-	case STGBSS:
-	case STGINIT:
-		sprintf(s, "v.%ld", mem);
-		break;
-
-	case STGCONST:
-		sprintf(s, "L%ld", mem);
-		break;
-
-	case STGEQUIV:
-		sprintf(s, "q.%ld", mem+eqvstart);
-		break;
-
-	default:
-		badstg("memname", stg);
-	}
-	return(s);
-}
-
-/* make_int_expr -- takes an arbitrary expression, and replaces all
-   occurrences of arguments with indirection */
-
-expptr make_int_expr (e)
-expptr e;
-{
-    if (e != ENULL)
-	switch (e -> tag) {
-	    case TADDR:
-	        if (e -> addrblock.vstg == STGARG
-		 && !e->addrblock.isarray)
-		    e = mkexpr (OPWHATSIN, e, ENULL);
-	        break;
-	    case TEXPR:
-	        e -> exprblock.leftp = make_int_expr (e -> exprblock.leftp);
-	        e -> exprblock.rightp = make_int_expr (e -> exprblock.rightp);
-	        break;
-	    default:
-	        break;
-	} /* switch */
-
-    return e;
-} /* make_int_expr */
-
-
-
-/* prune_left_conv -- used in prolog() to strip type cast away from
-   left-hand side of parameter adjustments.  This is necessary to avoid
-   error messages from cktype() */
-
-expptr prune_left_conv (e)
-expptr e;
-{
-    struct Exprblock *leftp;
-
-    if (e && e -> tag == TEXPR && e -> exprblock.leftp &&
-	    e -> exprblock.leftp -> tag == TEXPR) {
-	leftp = &(e -> exprblock.leftp -> exprblock);
-	if (leftp -> opcode == OPCONV) {
-	    e -> exprblock.leftp = leftp -> leftp;
-	    free ((charptr) leftp);
-	}
-    }
-
-    return e;
-} /* prune_left_conv */
-
-
- static int wrote_comment;
- static FILE *comment_file;
-
- static void
-write_comment()
-{
-	if (!wrote_comment) {
-		wrote_comment = 1;
-		nice_printf (comment_file, "/* Parameter adjustments */\n");
-		}
-	}
-
- static int *
-count_args()
-{
-	register int *ac;
-	register chainp cp;
-	register struct Entrypoint *ep;
-	register Namep q;
-
-	ac = (int *)ckalloc(nallargs*sizeof(int));
-
-	for(ep = entries; ep; ep = ep->entnextp)
-		for(cp = ep->arglist; cp; cp = cp->nextp)
-			if (q = (Namep)cp->datap)
-				ac[q->argno]++;
-	return ac;
-	}
-
-prolog(outfile, p)
- FILE *outfile;
- register chainp p;
-{
-	int addif, addif0, i, nd, size;
-	int *ac;
-	register Namep q;
-	register struct Dimblock *dp;
-
-	if(procclass == CLBLOCK)
-		return;
-	wrote_comment = 0;
-	comment_file = outfile;
-	ac = 0;
-
-/* Compute the base addresses and offsets for the array parameters, and
-   assign these values to local variables */
-
-	addif = addif0 = nentry > 1;
-	for(; p ; p = p->nextp)
-	{
-	    q = (Namep) p->datap;
-	    if(dp = q->vdim)	/* if this param is an array ... */
-	    {
-		expptr Q, expr;
-
-		/* See whether to protect the following with an if. */
-		/* This only happens when there are multiple entries. */
-
-		nd = dp->ndim - 1;
-		if (addif0) {
-			if (!ac)
-				ac = count_args();
-			if (ac[q->argno] == nentry)
-				addif = 0;
-			else if (dp->basexpr
-				    || dp->baseoffset->constblock.Const.ci)
-				addif = 1;
-			else for(addif = i = 0; i <= nd; i++)
-				if (dp->dims[i].dimexpr
-				&& (i < nd || !q->vlastdim)) {
-					addif = 1;
-					break;
-					}
-			if (addif) {
-				write_comment();
-				nice_printf(outfile, "if (%s) {\n", /*}*/
-						q->cvarname);
-				next_tab(outfile);
-				}
-			}
-		for(i = 0 ; i <= nd; ++i)
-
-/* Store the variable length of each dimension (which is fixed upon
-   runtime procedure entry) into a local variable */
-
-		    if ((Q = dp->dims[i].dimexpr)
-			&& (i < nd || !q->vlastdim)) {
-			expr = (expptr)cpexpr(Q);
-			write_comment();
-			out_and_free_statement (outfile, mkexpr (OPASSIGN,
-				fixtype(cpexpr(dp->dims[i].dimsize)), expr));
-		    } /* if dp -> dims[i].dimexpr */
-
-/* size   will equal the size of a single element, or -1 if the type is
-   variable length character type */
-
-		size = typesize[ q->vtype ];
-		if(q->vtype == TYCHAR)
-		    if( ISICON(q->vleng) )
-			size *= q->vleng->constblock.Const.ci;
-		    else
-			size = -1;
-
-		/* Fudge the argument pointers for arrays so subscripts
-		 * are 0-based. Not done if array bounds are being checked.
-		 */
-		if(dp->basexpr) {
-
-/* Compute the base offset for this procedure */
-
-		    write_comment();
-		    out_and_free_statement (outfile, mkexpr (OPASSIGN,
-			    cpexpr(fixtype(dp->baseoffset)),
-			    cpexpr(fixtype(dp->basexpr))));
-		} /* if dp -> basexpr */
-
-		if(! checksubs) {
-		    if(dp->basexpr) {
-			expptr tp;
-
-/* If the base of this array has a variable adjustment ... */
-
-			tp = (expptr) cpexpr (dp -> baseoffset);
-			if(size < 0 || q -> vtype == TYCHAR)
-			    tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng));
-
-			write_comment();
-			tp = mkexpr (OPMINUSEQ,
-				mkconv (TYADDR, (expptr)p->datap),
-				mkconv(TYINT, fixtype
-				(fixtype (tp))));
-/* Avoid type clash by removing the type conversion */
-			tp = prune_left_conv (tp);
-			out_and_free_statement (outfile, tp);
-		    } else if(dp->baseoffset->constblock.Const.ci != 0) {
-
-/* if the base of this array has a nonzero constant adjustment ... */
-
-			expptr tp;
-
-			write_comment();
-			if(size > 0 && q -> vtype != TYCHAR) {
-			    tp = prune_left_conv (mkexpr (OPMINUSEQ,
-				    mkconv (TYADDR, (expptr)p->datap),
-				    mkconv (TYINT, fixtype
-				    (cpexpr (dp->baseoffset)))));
-			    out_and_free_statement (outfile, tp);
-			} else {
-			    tp = prune_left_conv (mkexpr (OPMINUSEQ,
-				    mkconv (TYADDR, (expptr)p->datap),
-				    mkconv (TYINT, fixtype
-				    (mkexpr (OPSTAR, cpexpr (dp -> baseoffset),
-				    cpexpr (q -> vleng))))));
-			    out_and_free_statement (outfile, tp);
-			} /* else */
-		    } /* if dp -> baseoffset -> const */
-		} /* if !checksubs */
-
-		if (addif) {
-			nice_printf(outfile, /*{*/ "}\n");
-			prev_tab(outfile);
-			}
-	    }
-	}
-	if (wrote_comment)
-	    nice_printf (outfile, "\n/* Function Body */\n");
-	if (ac)
-		free((char *)ac);
-} /* prolog */
//GO.SYSIN DD vax.c
echo version.c 1>&2
sed >version.c <<'//GO.SYSIN DD version.c' 's/^-//'
-char F2C_version[] = "22 July 1992  22:54:52";
-char xxxvers[] = "\n@(#) FORTRAN 77 to C Translator, VERSION 22 July 1992  22:54:52\n";
//GO.SYSIN DD version.c
echo xsum.c 1>&2
sed >xsum.c <<'//GO.SYSIN DD xsum.c' 's/^-//'
-/****************************************************************
-Copyright 1990 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.
-****************************************************************/
-
-#include "stdio.h"
-
- char *progname;
-
- void
-usage(rc)
-{
-	fprintf(stderr, "usage: %s [file [file...]]\n", progname);
-	exit(rc);
-	}
-
-main(argc, argv)
- char **argv;
-{
-	int x;
-	char *s;
-	static int rc;
-
-	progname = *argv;
-	s = *++argv;
-	if (s && *s == '-') {
-		switch(s[1]) {
-			case '?':
-				usage(0);
-			case '-':
-				break;
-			default:
-				fprintf(stderr, "invalid option %s\n", s);
-				usage(1);
-			}
-		s = *++argv;
-		}
-	if (s) do {
-		x = open(s,0);
-		if (x < 0) {
-			fprintf(stderr, "%s: can't open %s\n", progname, s);
-			rc |= 1;
-			}
-		else
-			process(s, x);
-		}
-		while(s = *++argv);
-	else {
-		process("/dev/stdin", fileno(stdin));
-		}
-	exit(rc);
-	}
-
-typedef unsigned char Uchar;
-
- long
-sum32(sum, x, n)
- register long sum;
- register Uchar *x;
- int n;
-{
-	register Uchar *xe;
-	static long crc_table[256] = {
-		0,		151466134,	302932268,	453595578,
-		-9583591,	-160762737,	-312236747,	-463170141,
-		-19167182,	-136529756,	-321525474,	-439166584,
-		28724267,	145849533,	330837255,	448732561,
-		-38334364,	-189783822,	-273059512,	-423738914,
-		47895677,	199091435,	282375505,	433292743,
-		57448534,	174827712,	291699066,	409324012,
-		-67019697,	-184128295,	-300991133,	-418902539,
-		-76668728,	-227995554,	-379567644,	-530091662,
-		67364049,	218420295,	369985021,	520795499,
-		95791354,	213031020,	398182870,	515701056,
-		-86479645,	-203465611,	-388624945,	-506380967,
-		114897068,	266207290,	349655424,	500195606,
-		-105581387,	-256654301,	-340093543,	-490887921,
-		-134039394,	-251295736,	-368256590,	-485758684,
-		124746887,	241716241,	358686123,	476458301,
-		-153337456,	-2395898,	-455991108,	-304803798,
-		162629001,	11973919,	465560741,	314102835,
-		134728098,	16841012,	436840590,	319723544,
-		-144044613,	-26395347,	-446403433,	-329032703,
-		191582708,	40657250,	426062040,	274858062,
-		-200894995,	-50223749,	-435620671,	-284179369,
-		-172959290,	-55056048,	-406931222,	-289830788,
-		182263263,	64630089,	416513267,	299125861,
-		229794136,	78991822,	532414580,	381366498,
-		-220224191,	-69691945,	-523123603,	-371788549,
-		-211162774,	-93398532,	-513308602,	-396314416,
-		201600371,	84090341,	503991391,	386759881,
-		-268078788,	-117292630,	-502591472,	-351526778,
-		258520357,	107972019,	493278217,	341959839,
-		249493774,	131713432,	483432482,	366454964,
-		-239911657,	-122417791,	-474129349,	-356881235,
-		-306674912,	-457198666,	-4791796,	-156118374,
-		315967289,	466778031,	14362133,	165418627,
-		325258002,	442776452,	23947838,	141187752,
-		-334573813,	-452329571,	-33509849,	-150495567,
-		269456196,	419996626,	33682024,	184992510,
-		-278767779,	-429561909,	-43239823,	-194312473,
-		-288089226,	-405591072,	-52790694,	-170046772,
-		297394031,	415166457,	62373443,	179343061,
-		383165416,	533828478,	81314500,	232780370,
-		-373594127,	-524527769,	-72022307,	-223201717,
-		-401789990,	-519431348,	-100447498,	-217810336,
-		392228803,	510123861,	91131631,	208256633,
-		-345918580,	-496598246,	-110112096,	-261561802,
-		336361365,	487278339,	100800185,	251995695,
-		364526526,	482151208,	129260178,	246639108,
-		-354943065,	-472854735,	-119955829,	-237064675,
-		459588272,	308539942,	157983644,	7181066,
-		-469170519,	-317835713,	-167286907,	-16754925,
-		-440448382,	-323454444,	-139383890,	-21619912,
-		450006683,	332774925,	148697015,	31186721,
-		-422325548,	-271261118,	-186797064,	-36011154,
-		431888077,	280569435,	196114401,	45565815,
-		403200742,	286222960,	168180682,	50400092,
-		-412770561,	-295522711,	-177471533,	-59977915,
-		-536157576,	-384970002,	-234585260,	-83643454,
-		526853729,	375396087,	225003341,	74348507,
-		517040714,	399923932,	215944038,	98057200,
-		-507728301,	-390357307,	-206385281,	-88735767,
-		498987548,	347783818,	263426864,	112501670,
-		-489671163,	-338229613,	-253864151,	-103192641,
-		-479823314,	-362722632,	-244835582,	-126932076,
-		470531639,	353144481,	235265819,	117632909
-		};
-
-	xe = x + n;
-	while(x < xe)
-		sum = crc_table[(sum ^ *x++) & 0xff] ^ (sum >> 8 & 0xffffff);
-	return sum;
-	}
-
-process(s, x)
- char *s;
- int x;
-{
-	register int n;
-	Uchar buf[16*1024];
-	long fsize, sum;
-
-	sum = 0;
-	fsize = 0;
-	while((n = read(x, (char *)buf, sizeof(buf))) > 0) {
-		fsize += n;
-		sum = sum32(sum, buf, n);
-		}
-	sum &= 0xffffffff;
-        if (n==0)
-		printf("%s\t%lx\t%ld\n", s, sum & 0xffffffff, fsize);
-        else { perror(s); }
-	close(x);
-	return(0);
-	}
//GO.SYSIN DD xsum.c
echo xsum0.out 1>&2
sed >xsum0.out <<'//GO.SYSIN DD xsum0.out' 's/^-//'
-Notice	80b5a78	1189
-README	19a827eb	3586
-cds.c	e93849b8	3884
-data.c	e552a480	9278
-defines.h	ed221f1	8188
-defs.h	1f961850	23481
-equiv.c	e7eb3399	8552
-error.c	111d9ebf	3653
-exec.c	f181dc16	18074
-expr.c	512577e	58265
-f2c.1	f49d146c	5977
-f2c.1t	edf29d2	5916
-f2c.h	ed0a0173	4138
-format.c	18836b42	50040
-format.h	e861ad39	300
-formatdata.c	15fcba1d	23859
-ftypes.h	e5db6a7c	941
-gram.dcl	fac72441	8102
-gram.exec	e970562d	2996
-gram.expr	1cdcf8c5	3081
-gram.head	e6859fc0	7539
-gram.io	1b7c281c	3294
-init.c	13677eae	10483
-intr.c	f3b2b75d	19682
-io.c	1f716e1d	29006
-iob.h	fe479ed3	459
-lex.c	f6adc993	29714
-machdefs.h	4950e5b	659
-main.c	860d65	16604
-makefile	12f58dbe	2510
-malloc.c	5c2be2a	3422
-mem.c	5b007b2	4761
-memset.c	17404d52	1964
-misc.c	17206d43	17772
-names.c	f3ed7234	19178
-names.h	f25436a3	689
-niceprintf.c	1c24a198	9491
-niceprintf.h	c31f08c	412
-output.c	12d8f78b	37554
-output.h	edfe9e59	2113
-p1defs.h	e4e11c4e	5776
-p1output.c	e5a1f65e	12202
-parse.h	e457df2e	855
-parse_args.c	f3e5da4d	13015
-pccdefs.h	1b4fbbee	1195
-pread.c	f1bada9e	15920
-proc.c	3e50c9d	34550
-put.c	792c6c4	9495
-putpcc.c	e1c889	38771
-sysdep.c	c839766	10910
-sysdep.h	1021aa5e	2834
-tokens	194fccfe	727
-usignal.h	1c4ce909	124
-vax.c	e3dbe107	7683
-version.c	1b5ead98	135
-xsum.c	1452907d	5479
//GO.SYSIN DD xsum0.out
