This commit was generated by cvs2svn to compensate for changes in r943,

which included commits to RCS files with non-trunk default branches.

65 files changed, 30801 insertions, 0 deletions

diff --git a/usr.bin/f2c/Notice b/usr.bin/f2c/Notice
new file mode 100644
index 0000000..64af9f1
--- /dev/null
+++ b/usr.bin/f2c/Notice
@@ -0,0 +1,23 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 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.
+****************************************************************/
+
diff --git a/usr.bin/f2c/README b/usr.bin/f2c/README
new file mode 100644
index 0000000..ed88aaa
--- /dev/null
+++ b/usr.bin/f2c/README
@@ -0,0 +1,94 @@
+Type "make" to check the validity of the f2c source and compile f2c.
+
+On a PC, you may need to compile xsum.c with -DMSDOS (i.e., with
+MSDOS #defined).  If your system does not understand ANSI/ISO C
+syntax (i.e., if you have a K&R C compiler), compile xsum.c with
+-DKR_headers.  (Eventually this will also be required of the f2c
+source proper.)
+
+On non-Unix systems where files have separate binary and text modes,
+you may need to "make xsumr.out" rather than "make xsum.out".
+
+If (in accordance with what follows) you need to modify the makefile
+or any of the source files, first issue a "make xsum.out" (or, if
+appropriate, "make xsumr.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.
+
+For convenience with systems that use control-Z to denote end-of-file,
+f2c treats control-Z characters (ASCII 26, '\x1a') that appear at the
+beginning of a line as an end-of-file indicator.  You can disable this
+test by compiling lex.c with NO_EOF_CHAR_CHECK #defined, or can
+change control-Z to some other character by #defining EOF_CHAR to
+be the desired value.
+
+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.
diff --git a/usr.bin/f2c/cds.c b/usr.bin/f2c/cds.c
new file mode 100644
index 0000000..3a9a9dc
--- /dev/null
+++ b/usr.bin/f2c/cds.c
@@ -0,0 +1,190 @@
+/****************************************************************
+Copyright 1990, 1993 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;
+		}
+	switch(c) {
+		case 0:
+			break;
+#ifndef VAX
+		case 'i':
+		case 'I':
+			Fatal("Overflow evaluating constant expression.");
+		case 'n':
+		case 'N':
+			Fatal("Constant expression yields NaN.");
+#endif
+		default:
+			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;
+	}
diff --git a/usr.bin/f2c/data.c b/usr.bin/f2c/data.c
new file mode 100644
index 0000000..5d11216
--- /dev/null
+++ b/usr.bin/f2c/data.c
@@ -0,0 +1,442 @@
+/****************************************************************
+Copyright 1990, 1993 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), 0);
+		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 TYINT1:
+	case TYLOGICAL1:
+	case TYLOGICAL2:
+	case TYSHORT:
+	case TYLONG:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+		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;
+		}
+	}
diff --git a/usr.bin/f2c/defines.h b/usr.bin/f2c/defines.h
new file mode 100644
index 0000000..fc7eb18
--- /dev/null
+++ b/usr.bin/f2c/defines.h
@@ -0,0 +1,296 @@
+#define PDP11 4
+
+#define BIGGEST_CHAR	0x7f		/* Assumes 32-bit arithmetic */
+#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 UNAM_REF 6		/* subscript reference with -s */
+
+
+#define IDENT_LEN 31		/* Maximum length user.ident */
+
+/* type masks - TYLOGICAL defined in   ftypes   */
+
+#define MSKLOGICAL	M(TYLOGICAL)|M(TYLOGICAL1)|M(TYLOGICAL2)
+#define MSKADDR	M(TYADDR)
+#define MSKCHAR	M(TYCHAR)
+#ifdef TYQUAD
+#define MSKINT	M(TYINT1)|M(TYSHORT)|M(TYLONG)|M(TYQUAD)
+#else
+#define MSKINT	M(TYINT1)|M(TYSHORT)|M(TYLONG)
+#endif
+#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))
+#define ISLOGICAL(z) ONEOF(z, MSKLOGICAL)
+
+/* 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) )
diff --git a/usr.bin/f2c/defs.h b/usr.bin/f2c/defs.h
new file mode 100644
index 0000000..6bb2ca2
--- /dev/null
+++ b/usr.bin/f2c/defs.h
@@ -0,0 +1,784 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 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 502		/* length of longest token */
+#define MAXCTL 20
+#define MAXHASH 401
+#define MAXSTNO 801
+#define MAXEXT 200
+#define MAXEQUIV 150
+#define MAXLABLIST 258		/* Max number of labels in an alternate
+				   return CALL or computed GOTO */
+#define MAXCONTIN 99		/* Max continuation lines */
+
+/* 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 int maxcontin;
+
+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 tylog, 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;
+	unsigned parenused:1;		/* distinguish (a) from a */
+	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() */
+	unsigned vrefused:1;	/* Need to #define name_ref (for -s) */
+	unsigned vsubscrused:1;	/* Need to #define name_subscr (for -2) */
+	unsigned veqvadjust:1;	/* voffset has been adjusted for equivalence */
+
+/* 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 */
+	unsigned cmplx_sub:1;	/* used in complex arithmetic under -s */
+	unsigned skip_offset:1;	/* used in complex arithmetic under -s */
+	unsigned parenused:1;	/* distinguish (a) from a */
+	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;
+extern flag keepsubs;
+#ifdef TYQUAD
+extern flag use_tyquad;
+#endif
+extern int n_keywords, n_st_fields;
+extern char *c_keywords[], *st_fields[];
diff --git a/usr.bin/f2c/dependencies b/usr.bin/f2c/dependencies
new file mode 100644
index 0000000..9937e0b
--- /dev/null
+++ b/usr.bin/f2c/dependencies
@@ -0,0 +1,60 @@
+f2c/src*
+Notice=
+notice
+README=
+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=
+xsum0.out=
diff --git a/usr.bin/f2c/disclaimer b/usr.bin/f2c/disclaimer
new file mode 100644
index 0000000..59db1ec
--- /dev/null
+++ b/usr.bin/f2c/disclaimer
@@ -0,0 +1,15 @@
+f2c is a Fortran to C converter under development by
+	David Gay (AT&T Bell Labs)
+	Stu Feldman (Bellcore)
+	Mark Maimone (Carnegie-Mellon University)
+	Norm Schryer (AT&T Bell Labs)
+Please send bug reports to dmg@research.att.com or uunet!research!dmg.
+
+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.
diff --git a/usr.bin/f2c/equiv.c b/usr.bin/f2c/equiv.c
new file mode 100644
index 0000000..019e206
--- /dev/null
+++ b/usr.bin/f2c/equiv.c
@@ -0,0 +1,383 @@
+/****************************************************************
+Copyright 1990, 1993 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[];
+	char *s;
+
+	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:
+				if (in_vector(np->cvarname, st_fields,
+						n_st_fields) >= 0) {
+					k = strlen(np->cvarname);
+					strcpy(s = mem(k+2,0), np->cvarname);
+					s[k] = '_';
+					s[k+1] = 0;
+					np->cvarname = s;
+					}
+				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->veqvadjust) {
+				np->veqvadjust = 1;
+				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);
+}
diff --git a/usr.bin/f2c/error.c b/usr.bin/f2c/error.c
new file mode 100644
index 0000000..fd68d14
--- /dev/null
+++ b/usr.bin/f2c/error.c
@@ -0,0 +1,252 @@
+/****************************************************************
+Copyright 1990, 1993 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 rerunning with 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("f2c extension used: %s", s);
+	--nerr;
+}
diff --git a/usr.bin/f2c/exec.c b/usr.bin/f2c/exec.c
new file mode 100644
index 0000000..b986492
--- /dev/null
+++ b/usr.bin/f2c/exec.c
@@ -0,0 +1,830 @@
+/****************************************************************
+Copyright 1990, 1993 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, keepsubs);
+		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 )
+		goto misplaced;
+	here = ctlstack->dolabel;
+	if (ctlstack->ctltype != CTLDO
+	|| here >= 0 && (!thislabel || thislabel->labelno != here)) {
+ misplaced:
+		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;
+	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 */
+
+	fs = labelval->fmtstring;
+	if (!labelval->labdefined || !fs) {
+
+		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... */
+
+	if (!labelval->labdefined || fs) {
+		extern void fmtname();
+
+		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 */
+}
diff --git a/usr.bin/f2c/expr.c b/usr.bin/f2c/expr.c
new file mode 100644
index 0000000..eeccf42
--- /dev/null
+++ b/usr.bin/f2c/expr.c
@@ -0,0 +1,3042 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 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];
+extern int htype;
+
+/* 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(tylog);
+	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
+				&& (!halign || p->tag != TADDR
+				|| p->addrblock.uname_tag != UNAM_CONST))
+			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, keepsubs);
+	}
+}
+
+
+ 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 || ISLOGICAL(ptype))
+			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 < TYINT1 || ptype > TYDREAL))
+			p->leftp = fixtype(mkconv(ptype,lp));
+		if(rtype != ptype && (rtype < TYINT1 || 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;
+		if (htype) {
+			if (ltype == TYCHAR) {
+				p->leftp = fixtype(mkconv(rtype,lp));
+				break;
+				}
+			if (rtype == TYCHAR) {
+				p->rightp = fixtype(mkconv(ltype,rp));
+				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 expptr
+subskept(p,a)
+struct Primblock *p;
+Addrp a;
+{
+	expptr ep;
+	struct Listblock *Lb;
+	chainp cp;
+
+	if (a->uname_tag != UNAM_NAME)
+		erri("subskept: uname_tag %d", a->uname_tag);
+	a->user.name->vrefused = 1;
+	a->user.name->visused = 1;
+	a->uname_tag = UNAM_REF;
+	Lb = (struct Listblock *)cpexpr((tagptr)p->argsp);
+	for(cp = Lb->listp; cp; cp = cp->nextp)
+		cp->datap = (char *)putx(fixtype((tagptr)cp->datap));
+	if (a->vtype == TYCHAR) {
+		ep = p->fcharp	? mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1))
+				: ICON(0);
+		Lb->listp = mkchain((char *)ep, Lb->listp);
+		}
+	return (expptr)Lb;
+	}
+
+ 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, subkeep)
+register struct Primblock *p; int subkeep;
+{
+	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 );
+	}
+	s->parenused = p->parenused;
+
+	/* compute the address modified by subscripts */
+
+	if (!replaced)
+		s->memoffset = (subkeep && np->vdim
+				&& (np->vdim->ndim > 1 || np->vtype == TYCHAR
+				&& (!ISCONST(np->vleng)
+				  || np->vleng->constblock.Const.ci != 1)))
+				? subskept(p,s)
+				: 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);
+	if (lp->tag == TPRIM)
+		lp->primblock.parenused = 1;
+	return(lp);
+
+retright:
+	frexpr(lp);
+	if (rp->tag == TPRIM)
+		rp->primblock.parenused = 1;
+	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(ISLOGICAL(lt))
+			return(lt);
+		ERR("NOT of nonlogical")
+
+	case OPAND:
+	case OPOR:
+	case OPEQV:
+	case OPNEQV:
+		if(ISLOGICAL(lt) && ISLOGICAL(rt))
+			return( maxtype(lt, rt) );
+		ERR("nonlogical operand of logical operator")
+
+	case OPLT:
+	case OPGT:
+	case OPLE:
+	case OPGE:
+	case OPEQ:
+	case OPNE:
+		if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt))
+		{
+			if(lt != rt){
+				if (htype
+					&& (lt == TYCHAR && ISNUMERIC(rt)
+					 || rt == TYCHAR && ISNUMERIC(lt)))
+						return TYLOGICAL;
+				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);
+		if (ISLOGICAL(lt) && ISLOGICAL(rt))
+			return lt;
+	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 (ISLOGICAL(lt) && ISLOGICAL(rt) && op == OPASSIGN)
+			return lt;
+		if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt))
+			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 TYINT1:
+			    case TYSHORT:
+			    case TYLONG:
+#ifdef TYQUAD
+			    case TYQUAD:
+#endif
+				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 TYINT1:
+	case TYSHORT:
+	case TYLONG:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+		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:
+	case TYLOGICAL1:
+	case TYLOGICAL2:
+		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 TYINT1:
+	case TYSHORT:
+	case TYLONG:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+		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 TYINT1:
+	case TYSHORT:
+	case TYLONG:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+		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 TYINT1:
+	case TYSHORT:
+	case TYLONG:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+		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 TYINT1:
+		case TYSHORT:
+		case TYLONG:
+#ifdef TYQUAD
+		case TYQUAD:
+#endif
+			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 TYINT1:
+		case TYSHORT:
+		case TYLONG:
+#ifdef TYQUAD
+		case TYQUAD:
+#endif
+			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 TYINT1:
+		case TYSHORT:
+		case TYLONG:
+#ifdef TYQUAD
+		case TYQUAD:
+#endif
+			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 TYINT1:
+		case TYSHORT:
+		case TYLONG:
+#ifdef TYQUAD
+		case TYQUAD:
+#endif
+			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 TYINT1:
+		case TYSHORT:
+		case TYLONG:
+#ifdef TYQUAD
+		case TYQUAD:
+#endif
+			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 TYINT1:
+		case TYSHORT:
+		case TYLONG:
+#ifdef TYQUAD
+		case TYQUAD:
+#endif
+			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 TYINT1:
+		case TYSHORT:
+		case TYLONG:
+#ifdef TYQUAD
+		case TYQUAD:
+#endif
+			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 TYINT1:
+	case TYSHORT:
+	case TYLONG:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+		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",
+#ifdef TYQUAD
+		  "pow_qi",
+#endif
+		  "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 (lp->tag == TADDR)
+		lp->addrblock.parenused = 0;
+
+	if (rp->tag == TADDR)
+		rp->addrblock.parenused = 0;
+
+	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(ONEOF(ltype,M(TYINT1)|M(TYSHORT)))
+			{
+				ltype = TYLONG;
+				lp = mkconv(TYLONG,lp);
+			}
+#ifdef TYQUAD
+			if (ltype == TYQUAD)
+				rp = mkconv(TYQUAD,rp);
+			else
+#endif
+			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;
+	}
+}
diff --git a/usr.bin/f2c/f2c.1 b/usr.bin/f2c/f2c.1
new file mode 100644
index 0000000..419ba03
--- /dev/null
+++ b/usr.bin/f2c/f2c.1
@@ -0,0 +1,191 @@
+
+     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 2/2/93)
+
+     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   Emulate Fortran 66's treatment of Hollerith: 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 defini-
+	       tions in	each input file.f or file.F.  When reading
+	       Fortran from standard input, write prototypes at	the
+	       beginning of standard output.  Option -Ps implies -P
+	       and gives exit status 4 if rerunning f2c	may change
+	       prototypes 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 2/2/93)
+
+     F2C(1)							F2C(1)
+
+	  -s   Preserve	multidimensional subscripts.
+
+	  -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.
+
+	  -!i8 Disallow	INTEGER*8.
+
+	  -!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
+
+     Page 3			   Local	      (printed 2/2/93)
+
+     F2C(1)							F2C(1)
+
+     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.
+
+     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 2/2/93)
+
diff --git a/usr.bin/f2c/f2c.1t b/usr.bin/f2c/f2c.1t
new file mode 100644
index 0000000..2a59dff
--- /dev/null
+++ b/usr.bin/f2c/f2c.1t
@@ -0,0 +1,336 @@
+. \" 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
+Emulate Fortran 66's treatment of Hollerith: 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 definitions in each input
+.IB file .f
+or
+.IB file .F .
+When reading Fortran from standard input, write prototypes
+at the beginning of standard output.  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
+.B -s
+Preserve multidimensional subscripts.
+.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 -!i8
+Disallow
+.SM INTEGER*8.
+.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 .
diff --git a/usr.bin/f2c/f2c.h b/usr.bin/f2c/f2c.h
new file mode 100644
index 0000000..fc1e979
--- /dev/null
+++ b/usr.bin/f2c/f2c.h
@@ -0,0 +1,214 @@
+/* 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;
+typedef char logical1;
+typedef char integer1;
+/* typedef long long longint; */ /* system-dependent */
+
+#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 */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	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
diff --git a/usr.bin/f2c/format.c b/usr.bin/f2c/format.c
new file mode 100644
index 0000000..80faacc
--- /dev/null
+++ b/usr.bin/f2c/format.c
@@ -0,0 +1,2225 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 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;
+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;
+	    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];
+
+	if (!e)
+		return 0;	/* possible only with errors */
+	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 {
+		if (!entryp)
+			return;	/* possible only with errors */
+		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;
+	extern int typeconv[];
+
+	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 || oneof_stg(v,v->vstg,
+					M(STGEQUIV)|M(STGCOMMON)))
+				? "(char *)" : "(char *)&");
+		out_name(outfile, v);
+		nice_printf(outfile, dimp ? ", %s_dims" : ", (ftnlen *)0", name);
+		nice_printf(outfile, ", %ld };\n",
+			type != TYCHAR  ? (long)typeconv[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;
+	}
+
+ static void
+ref_defs(outfile, refdefs) FILE *outfile; chainp refdefs;
+{
+	chainp cp;
+	int eb, i, j, n;
+	struct Dimblock *dimp;
+	long L;
+	expptr b, vl;
+	Namep var;
+	char *amp, *comma;
+
+	ind_printf(0, outfile, "\n");
+	for(cp = refdefs = revchain(refdefs); cp; cp = cp->nextp) {
+		var = (Namep)cp->datap;
+		cp->datap = 0;
+		amp = "_subscr";
+		if (!(eb = var->vsubscrused)) {
+			var->vrefused = 0;
+			if (!ISCOMPLEX(var->vtype))
+				amp = "_ref";
+			}
+		def_start(outfile, var->cvarname, amp, CNULL);
+		dimp = var->vdim;
+		vl = 0;
+		comma = "(";
+		amp = "";
+		if (var->vtype == TYCHAR) {
+			amp = "&";
+			vl = var->vleng;
+			if (ISCONST(vl) && vl->constblock.Const.ci == 1)
+				vl = 0;
+			nice_printf(outfile, "%sa_0", comma);
+			comma = ",";
+			}
+		n = dimp->ndim;
+		for(i = 1; i <= n; i++, comma = ",")
+			nice_printf(outfile, "%sa_%d", comma, i);
+		nice_printf(outfile, ") %s", amp);
+		if (var->vsubscrused)
+			var->vsubscrused = 0;
+		else if (!ISCOMPLEX(var->vtype)) {
+			out_name(outfile, var);
+			nice_printf(outfile, "[%s", vl ? "(" : "");
+			}
+		for(j = 2; j < n; j++)
+			nice_printf(outfile, "(");
+		while(--i > 1) {
+			nice_printf(outfile, "(a_%d)%s*", i, i == n ? "" : ")");
+			expr_out(outfile, cpexpr(dimp->dims[i-2].dimsize));
+			nice_printf(outfile, " + ");
+			}
+		nice_printf(outfile, "a_1");
+		if (var->vtype == TYCHAR) {
+			if (vl) {
+				nice_printf(outfile, ")*");
+				expr_out(outfile, cpexpr(vl));
+				}
+			nice_printf(outfile, " + a_0");
+			}
+		if (var->vstg != STGARG && (b = dimp->baseoffset)) {
+			b = cpexpr(b);
+			if (var->vtype == TYCHAR)
+				b = mkexpr(OPSTAR, cpexpr(var->vleng), b);
+			nice_printf(outfile, " - ");
+			expr_out(outfile, b);
+			}
+		if (ISCOMPLEX(var->vtype)) {
+			ind_printf(0, outfile, "\n");
+			def_start(outfile, var->cvarname, "_ref", CNULL);
+			comma = "(";
+			for(i = 1; i <= n; i++, comma = ",")
+				nice_printf(outfile, "%sa_%d", comma, i);
+			nice_printf(outfile, ") %s[%s_subscr",
+				var->cvarname, var->cvarname);
+			comma = "(";
+			for(i = 1; i <= n; i++, comma = ",")
+				nice_printf(outfile, "%sa_%d", comma, i);
+			nice_printf(outfile, ")");
+			}
+		ind_printf(0, outfile, "]\n" + eb);
+		}
+	nice_printf(outfile, "\n");
+	frchain(&refdefs);
+	}
+
+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, refdefs = 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 (var->vrefused)
+		refdefs = mkchain((char *)var, refdefs);
+	    if (var->vsubscrused)
+		if (ISCOMPLEX(var->vtype))
+			var->vsubscrused = 0;
+		else
+			refdefs = mkchain((char *)var, refdefs);
+	    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);
+
+    if (refdefs)
+	ref_defs(outfile, refdefs);
+
+} /* 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 TYINT1:
+        case TYSHORT:
+	case TYLONG:
+	case TYLOGICAL:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+	case TYLOGICAL1:
+	case TYLOGICAL2:
+	    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[];
+	int asave;
+
+	if (!(asave = Ansi))
+		Castargs = Ansi = 1;
+	nice_printf(protofile, "extern %s %s", protorettypes[type], name);
+	list_arg_types(protofile, e, lengths, 0, ";\n");
+	used_rets[type] = 1;
+	if (!(Ansi = asave))
+		Castargs = 0;
+	}
+
+ 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);
+		}
+	}
diff --git a/usr.bin/f2c/format.h b/usr.bin/f2c/format.h
new file mode 100644
index 0000000..a88c038
--- /dev/null
+++ b/usr.bin/f2c/format.h
@@ -0,0 +1,10 @@
+#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 ();
diff --git a/usr.bin/f2c/formatdata.c b/usr.bin/f2c/formatdata.c
new file mode 100644
index 0000000..541472a
--- /dev/null
+++ b/usr.bin/f2c/formatdata.c
@@ -0,0 +1,1081 @@
+/****************************************************************
+Copyright 1990, 1991, 1993 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;
+#ifndef atol
+    long atol();
+#endif
+    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) != 0;
+		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 TYINT1:
+	    case TYSHORT:
+	    case TYLONG:
+#ifdef TYQUAD
+	    case TYQUAD:
+#endif
+	    case TYREAL:
+	    case TYDREAL:
+	    case TYLOGICAL:
+	    case TYLOGICAL1:
+	    case TYLOGICAL2:
+	    case TYCOMPLEX:
+	    case TYDCOMPLEX:
+		make_one_const(type, &Const.Const, values);
+		Const.vtype = type;
+		Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0;
+		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 btype, curtype, dtype, filltype, filltype1, j, k, wasblank, xtype;
+	static char Blank[] = "";
+	register char *comma = Blank;
+	register chainp cp, v;
+	chainp sentinel, values, v1, vlast;
+	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, TYINT1, TYSHORT, TYLONG,
+#ifdef TYQUAD
+				  TYQUAD,
+#endif
+				  TYREAL, TYDREAL, TYREAL, TYDREAL,
+				  TYLOGICAL1, TYLOGICAL2,
+				  TYLOGICAL, TYCHAR};
+	static char basetype[] = {0, 0, TYCHAR, TYSHORT, TYLONG,
+#ifdef TYQUAD
+				  TYDREAL,
+#endif
+				  TYLONG, TYDREAL, TYLONG, TYDREAL,
+				  TYCHAR, TYSHORT,
+				  TYLONG, 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;
+	*Values = values = revchain(vlast = *Values);
+
+	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 */
+
+		btype = basetype[xtype];
+		loc = 0;
+		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)));
+				vlast = vlast->nextp =
+					mkchain((char *)v, CHNULL);
+				L += k;
+				break;
+				}
+			cp = (chainp)v->datap;
+			if (basetype[(int)cp->nextp->datap] == btype)
+				break;
+			dloc = (ftnint)cp->datap;
+			L1 = dloc - loc;
+			if (L1 > 0
+			 && !(L1 % szshort)
+			 && !(loc % szshort)
+			 && btype <= type_choice[L1/szshort % 4]
+			 && btype <= type_choice[loc/szshort % 4])
+				break;
+			dtype = (int)cp->nextp->datap;
+			loc = dloc + dtype == TYBLANK
+					? (ftnint)cp->nextp->nextp->datap
+					: typesize[dtype];
+			}
+		}
+	sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL));
+	vlast->nextp = mkchain((char *)sentinel, CHNULL);
+
+	/* 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();
+			if ((int)cp->nextp->datap != TYERROR) {
+				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:
+			case TYLOGICAL2:
+			case TYLOGICAL1:
+				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 TYINT1:
+			case TYSHORT:
+			case TYLONG:
+#ifdef TYQUAD
+			case TYQUAD:
+#endif
+				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);
+	}
diff --git a/usr.bin/f2c/ftypes.h b/usr.bin/f2c/ftypes.h
new file mode 100644
index 0000000..80d2deb
--- /dev/null
+++ b/usr.bin/f2c/ftypes.h
@@ -0,0 +1,51 @@
+
+/* variable types (stored in the   vtype  field of   expptr)
+ * numeric assumptions:
+ *	int < reals < complexes
+ *	TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX
+ */
+
+#ifdef NO_TYQUAD
+#undef TYQUAD
+#define TYQUAD_inc 0
+#else
+#define TYQUAD 5
+#define TYQUAD_inc 1
+#endif
+
+#define TYUNKNOWN 0
+#define TYADDR 1
+#define TYINT1 2
+#define TYSHORT 3
+#define TYLONG 4
+/* #define TYQUAD 5 */
+#define TYREAL (5+TYQUAD_inc)
+#define TYDREAL (6+TYQUAD_inc)
+#define TYCOMPLEX (7+TYQUAD_inc)
+#define TYDCOMPLEX (8+TYQUAD_inc)
+#define TYLOGICAL1 (9+TYQUAD_inc)
+#define TYLOGICAL2 (10+TYQUAD_inc)
+#define TYLOGICAL (11+TYQUAD_inc)
+#define TYCHAR (12+TYQUAD_inc)
+#define TYSUBR (13+TYQUAD_inc)
+#define TYERROR (14+TYQUAD_inc)
+#define TYCILIST (15+TYQUAD_inc)
+#define TYICILIST (16+TYQUAD_inc)
+#define TYOLIST (17+TYQUAD_inc)
+#define TYCLLIST (18+TYQUAD_inc)
+#define TYALIST (19+TYQUAD_inc)
+#define TYINLIST (20+TYQUAD_inc)
+#define TYVOID (21+TYQUAD_inc)
+#define TYLABEL (22+TYQUAD_inc)
+#define TYFTNLEN (23+TYQUAD_inc)
+/* 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? */
+
diff --git a/usr.bin/f2c/gram.c b/usr.bin/f2c/gram.c
new file mode 100644
index 0000000..99ac190e
--- /dev/null
+++ b/usr.bin/f2c/gram.c
@@ -0,0 +1,1829 @@
+# define SEOS 1
+# define SCOMMENT 2
+# define SLABEL 3
+# define SUNKNOWN 4
+# define SHOLLERITH 5
+# define SICON 6
+# define SRCON 7
+# define SDCON 8
+# define SBITCON 9
+# define SOCTCON 10
+# define SHEXCON 11
+# define STRUE 12
+# define SFALSE 13
+# define SNAME 14
+# define SNAMEEQ 15
+# define SFIELD 16
+# define SSCALE 17
+# define SINCLUDE 18
+# define SLET 19
+# define SASSIGN 20
+# define SAUTOMATIC 21
+# define SBACKSPACE 22
+# define SBLOCK 23
+# define SCALL 24
+# define SCHARACTER 25
+# define SCLOSE 26
+# define SCOMMON 27
+# define SCOMPLEX 28
+# define SCONTINUE 29
+# define SDATA 30
+# define SDCOMPLEX 31
+# define SDIMENSION 32
+# define SDO 33
+# define SDOUBLE 34
+# define SELSE 35
+# define SELSEIF 36
+# define SEND 37
+# define SENDFILE 38
+# define SENDIF 39
+# define SENTRY 40
+# define SEQUIV 41
+# define SEXTERNAL 42
+# define SFORMAT 43
+# define SFUNCTION 44
+# define SGOTO 45
+# define SASGOTO 46
+# define SCOMPGOTO 47
+# define SARITHIF 48
+# define SLOGIF 49
+# define SIMPLICIT 50
+# define SINQUIRE 51
+# define SINTEGER 52
+# define SINTRINSIC 53
+# define SLOGICAL 54
+# define SNAMELIST 55
+# define SOPEN 56
+# define SPARAM 57
+# define SPAUSE 58
+# define SPRINT 59
+# define SPROGRAM 60
+# define SPUNCH 61
+# define SREAD 62
+# define SREAL 63
+# define SRETURN 64
+# define SREWIND 65
+# define SSAVE 66
+# define SSTATIC 67
+# define SSTOP 68
+# define SSUBROUTINE 69
+# define STHEN 70
+# define STO 71
+# define SUNDEFINED 72
+# define SWRITE 73
+# define SLPAR 74
+# define SRPAR 75
+# define SEQUALS 76
+# define SCOLON 77
+# define SCOMMA 78
+# define SCURRENCY 79
+# define SPLUS 80
+# define SMINUS 81
+# define SSTAR 82
+# define SSLASH 83
+# define SPOWER 84
+# define SCONCAT 85
+# define SAND 86
+# define SOR 87
+# define SNEQV 88
+# define SEQV 89
+# define SNOT 90
+# define SEQ 91
+# define SLT 92
+# define SGT 93
+# define SLE 94
+# define SGE 95
+# define SNE 96
+# define SENDDO 97
+# define SWHILE 98
+# define SSLASHD 99
+
+/* # line 124 "gram.in" */
+#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];
+extern struct Labelblock **labarray;	/* Labels in an alternate
+						   return CALL */
+extern int maxlablist;
+
+/* 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);
+	}
+
+
+/* # line 178 "gram.in" */
+typedef union 	{
+	int ival;
+	ftnint lval;
+	char *charpval;
+	chainp chval;
+	tagptr tagval;
+	expptr expval;
+	struct Labelblock *labval;
+	struct Nameblock *namval;
+	struct Eqvchain *eqvval;
+	Extsym *extval;
+	} YYSTYPE;
+#define yyclearin yychar = -1
+#define yyerrok yyerrflag = 0
+extern int yychar;
+typedef int yytabelem;
+extern yytabelem yyerrflag;
+#ifndef YYMAXDEPTH
+#define YYMAXDEPTH 150
+#endif
+YYSTYPE yylval, yyval;
+# define YYERRCODE 256
+yytabelem yyexca[] ={
+-1, 1,
+	0, -1,
+	-2, 0,
+-1, 20,
+	1, 38,
+	-2, 228,
+-1, 24,
+	1, 42,
+	-2, 228,
+-1, 122,
+	6, 240,
+	-2, 228,
+-1, 150,
+	1, 244,
+	-2, 188,
+-1, 174,
+	1, 265,
+	78, 265,
+	-2, 188,
+-1, 223,
+	77, 173,
+	-2, 139,
+-1, 245,
+	74, 228,
+	-2, 225,
+-1, 271,
+	1, 286,
+	-2, 143,
+-1, 275,
+	1, 295,
+	78, 295,
+	-2, 145,
+-1, 328,
+	77, 174,
+	-2, 141,
+-1, 358,
+	1, 267,
+	14, 267,
+	74, 267,
+	78, 267,
+	-2, 189,
+-1, 436,
+	91, 0,
+	92, 0,
+	93, 0,
+	94, 0,
+	95, 0,
+	96, 0,
+	-2, 153,
+-1, 453,
+	1, 289,
+	78, 289,
+	-2, 143,
+-1, 455,
+	1, 291,
+	78, 291,
+	-2, 143,
+-1, 457,
+	1, 293,
+	78, 293,
+	-2, 143,
+-1, 459,
+	1, 296,
+	78, 296,
+	-2, 144,
+-1, 504,
+	78, 289,
+	-2, 143,
+	};
+# define YYNPROD 301
+# define YYLAST 1346
+yytabelem yyact[]={
+
+ 237, 274, 471, 317, 316, 412, 420, 297, 470, 399,
+ 413, 397, 386, 357, 398, 266, 128, 356, 273, 252,
+ 292,   5, 116, 295, 326, 303, 222,  99, 184, 121,
+ 195, 229,  17, 203, 270, 304, 313, 199, 201, 118,
+  94, 202, 396, 104, 210, 183, 236, 101, 106, 234,
+ 264, 103, 111, 336, 260,  95,  96,  97, 165, 166,
+ 334, 335, 336, 395, 105, 311, 309, 190, 130, 131,
+ 132, 133, 120, 135, 119, 114, 157, 129, 157, 475,
+ 103, 272, 334, 335, 336, 396, 521, 103, 278, 483,
+ 535, 165, 166, 334, 335, 336, 342, 341, 340, 339,
+ 338, 137, 343, 345, 344, 347, 346, 348, 450, 258,
+ 259, 260, 539, 165, 166, 258, 259, 260, 261, 525,
+ 102, 522, 155, 409, 155, 186, 187, 103, 408, 117,
+ 165, 166, 258, 259, 260, 318, 100, 527, 484, 188,
+ 446, 185, 480, 230, 240, 240, 194, 193, 290, 120,
+ 211, 119, 462, 481, 157, 294, 482, 257, 157, 243,
+ 468, 214, 463, 469, 461, 464, 460, 239, 241, 220,
+ 215, 218, 157, 219, 213, 165, 166, 334, 335, 336,
+ 342, 341, 340, 157, 371, 452, 343, 345, 344, 347,
+ 346, 348, 443, 428, 377, 294, 102, 102, 102, 102,
+ 155, 189, 447, 149, 155, 446, 192, 103,  98, 196,
+ 197, 198, 277, 376, 320, 321, 206, 288, 155, 289,
+ 300, 375, 299, 324, 315, 328, 275, 275, 330, 155,
+ 310, 333, 196, 216, 217, 350, 269, 207, 308, 352,
+ 353, 333, 100, 177, 354, 349, 323, 112, 245, 257,
+ 247, 110, 157, 417, 286, 287, 418, 362, 157, 157,
+ 157, 157, 157, 257, 257, 109, 108, 268, 279, 280,
+ 281, 265, 107, 355,   4, 333, 427, 465, 378, 370,
+ 170, 172, 176, 257, 165, 166, 258, 259, 260, 261,
+ 102, 406, 232, 293, 407, 381, 422, 390, 155, 400,
+ 391, 223, 419, 422, 155, 155, 155, 155, 155, 117,
+ 221, 314, 392, 319, 387, 359, 372, 196, 360, 373,
+ 374, 333, 333, 536, 350, 333, 275, 250, 424, 333,
+ 405, 333, 410, 532, 230, 432, 433, 434, 435, 436,
+ 437, 438, 439, 440, 441, 403, 331, 156, 401, 332,
+ 531, 333, 530, 333, 333, 333, 388, 526, 380, 529,
+ 524, 157, 257, 333, 431, 492, 257, 257, 257, 257,
+ 257, 382, 383, 235, 426, 384, 358, 494, 296, 333,
+ 448, 165, 166, 258, 259, 260, 261, 451, 165, 166,
+ 258, 259, 260, 261, 103, 445, 472, 400, 421, 191,
+ 402, 196, 103, 150, 307, 174, 285, 155, 474, 246,
+ 476, 416, 467, 466, 242, 226, 223, 200, 212, 136,
+ 209, 486, 171, 488, 490, 275, 275, 275, 141, 240,
+ 496, 429, 329, 333, 333, 333, 333, 333, 333, 333,
+ 333, 333, 333, 403, 497, 479, 401, 403, 487, 154,
+ 257, 154, 495, 493, 306, 485, 502, 454, 456, 458,
+ 500, 491, 268, 499, 505, 506, 507, 103, 451, 271,
+ 271, 472,  30, 333, 414, 501, 400, 508, 511, 509,
+ 387, 244, 208, 510, 516, 514, 515, 333, 517, 333,
+ 513, 333, 520, 293, 518, 225, 240, 333, 402, 523,
+  92, 248, 402, 528,   6, 262, 123, 249,  81,  80,
+ 275, 275, 275,  79, 534, 533, 479,  78, 173, 263,
+ 314,  77, 403,  76, 537, 401, 351, 154,  75, 333,
+ 282, 154,  60,  49,  48, 333,  45,  33, 333, 538,
+ 113, 205, 454, 456, 458, 154, 267, 165, 166, 334,
+ 335, 336, 342, 540, 503, 411, 154, 204, 394, 393,
+ 298, 478, 503, 503, 503, 134, 389, 312, 115, 379,
+  26,  25,  24,  23, 302,  22, 305, 402,  21, 385,
+ 284,   9, 503,   8,   7,   2, 519, 301,  20, 319,
+ 164,  51, 489, 291, 228, 327, 325, 415,  91, 361,
+ 255,  53, 337,  19,  55, 365, 366, 367, 368, 369,
+  37, 224,   3,   1,   0, 351,   0,   0,   0,   0,
+   0,   0,   0,   0,   0, 154,   0,   0,   0,   0,
+   0, 154, 154, 154, 154, 154,   0,   0,   0, 267,
+   0, 512, 267, 267, 165, 166, 334, 335, 336, 342,
+ 341, 340, 339, 338,   0, 343, 345, 344, 347, 346,
+ 348, 165, 166, 334, 335, 336, 342, 341, 453, 455,
+ 457,   0, 343, 345, 344, 347, 346, 348,   0,   0,
+ 305,   0, 459,   0,   0,   0,   0, 165, 166, 334,
+ 335, 336, 342, 341, 340, 339, 338, 351, 343, 345,
+ 344, 347, 346, 348, 444,   0,   0,   0, 449, 165,
+ 166, 334, 335, 336, 342, 341, 340, 339, 338,   0,
+ 343, 345, 344, 347, 346, 348, 165, 166, 334, 335,
+ 336, 342,   0,   0, 154,   0, 498, 343, 345, 344,
+ 347, 346, 348,   0,   0, 267,   0,   0,   0,   0,
+   0, 442,   0, 504, 455, 457, 165, 166, 334, 335,
+ 336, 342, 341, 340, 339, 338,   0, 343, 345, 344,
+ 347, 346, 348,   0,   0,   0,   0,   0,   0, 430,
+   0, 477,   0, 305, 165, 166, 334, 335, 336, 342,
+ 341, 340, 339, 338,   0, 343, 345, 344, 347, 346,
+ 348, 423,   0,   0,   0,   0, 165, 166, 334, 335,
+ 336, 342, 341, 340, 339, 338,   0, 343, 345, 344,
+ 347, 346, 348,   0,   0,   0, 267,   0,   0,   0,
+   0, 165, 166, 334, 335, 336, 342, 341, 340, 339,
+ 338,  12, 343, 345, 344, 347, 346, 348,   0,   0,
+   0,   0,   0,   0, 305,  10,  56,  46,  73,  85,
+  14,  61,  70,  90,  38,  66,  47,  42,  68,  72,
+  31,  67,  35,  34,  11,  87,  36,  18,  41,  39,
+  28,  16,  57,  58,  59,  50,  54,  43,  88,  64,
+  40,  69,  44,  89,  29,  62,  84,  13,   0,  82,
+  65,  52,  86,  27,  74,  63,  15,   0,   0,  71,
+  83, 160, 161, 162, 163, 169, 168, 167, 158, 159,
+ 103,   0, 160, 161, 162, 163, 169, 168, 167, 158,
+ 159, 103,   0,   0,  32, 160, 161, 162, 163, 169,
+ 168, 167, 158, 159, 103,   0, 160, 161, 162, 163,
+ 169, 168, 167, 158, 159, 103,   0, 160, 161, 162,
+ 163, 169, 168, 167, 158, 159, 103,   0, 160, 161,
+ 162, 163, 169, 168, 167, 158, 159, 103,   0,   0,
+ 233,   0,   0,   0,   0,   0, 165, 166, 363,   0,
+ 364, 233, 227,   0,   0,   0, 238, 165, 166, 231,
+   0,   0,   0,   0, 233,   0,   0, 238,   0,   0,
+ 165, 166, 473,   0,   0, 233,   0,   0,   0,   0,
+ 238, 165, 166, 231,   0,   0, 233,   0,   0,   0,
+   0, 238, 165, 166, 425,   0,   0, 233,   0,   0,
+   0,   0, 238, 165, 166,   0,   0,   0,   0,   0,
+   0,   0,   0, 238, 160, 161, 162, 163, 169, 168,
+ 167, 158, 159, 103,   0, 160, 161, 162, 163, 169,
+ 168, 167, 158, 159, 103, 160, 161, 162, 163, 169,
+ 168, 167, 158, 159, 103,   0,   0,   0, 160, 161,
+ 162, 163, 169, 168, 167, 158, 159, 103, 256,   0,
+  93, 160, 161, 162, 163, 169, 168, 167, 158, 159,
+ 103,   0,   0,   0,   0,   0,   0,   0,   0,   0,
+   0,   0,   0, 276,   0,   0,   0,   0,   0, 165,
+ 166,   0, 122,   0, 322, 125, 126, 127,   0, 238,
+ 165, 166,   0,   0,   0,   0,   0, 138, 139,   0,
+ 238, 140,   0, 142, 143, 144,   0, 251, 145, 146,
+ 147,   0, 148, 165, 166, 253,   0, 254,   0,   0,
+ 153,   0,   0,   0,   0,   0, 165, 166, 151,   0,
+ 152, 178, 179, 180, 181, 182, 160, 161, 162, 163,
+ 169, 168, 167, 158, 159, 103, 160, 161, 162, 163,
+ 169, 168, 167, 158, 159, 103, 160, 161, 162, 163,
+ 169, 168, 167, 158, 159, 103, 160, 161, 162, 163,
+ 169, 168, 167, 158, 159, 103,   0,   0,   0,   0,
+   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
+   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
+   0,   0,   0,   0,   0, 251,   0,   0,   0,   0,
+   0, 165, 166, 283,   0, 153,   0,   0,   0,   0,
+   0, 165, 166, 175,   0, 404,   0,   0,   0,   0,
+   0, 165, 166,  56,  46, 251,  85,   0,  61,   0,
+  90, 165, 166,  47,  73,   0,   0,   0,  70,   0,
+   0,  66,  87,   0,  68,  72,   0,  67,   0,  57,
+  58,  59,  50,   0,   0,  88,   0,   0,   0,   0,
+  89,   0,  62,  84,   0,  64,  82,  69,  52,  86,
+   0,   0,  63,   0, 124,   0,  65,  83,   0,   0,
+  74,   0,   0,   0,   0,  71 };
+yytabelem yypact[]={
+
+-1000,  18, 503, 837,-1000,-1000,-1000,-1000,-1000,-1000,
+ 495,-1000,-1000,-1000,-1000,-1000,-1000, 164, 453, -35,
+ 194, 188, 187, 173,  58, 169,  -8,  66,-1000,-1000,
+-1000,-1000,-1000,1264,-1000,-1000,-1000,  -5,-1000,-1000,
+-1000,-1000,-1000,-1000,-1000, 453,-1000,-1000,-1000,-1000,
+-1000, 354,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,
+-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,
+-1000,-1000,-1000,-1000,-1000,1096, 348,1191, 348, 165,
+-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,
+-1000,-1000,-1000,-1000, 453, 453, 453, 453,-1000, 453,
+-1000, 325,-1000,-1000, 453,-1000, -11, 453, 453, 453,
+ 343,-1000,-1000,-1000, 453, 159,-1000,-1000,-1000,-1000,
+ 468, 346,  58,-1000,-1000, 344,-1000,-1000,-1000,-1000,
+  66, 453, 453, 343,-1000,-1000, 234, 342, 489,-1000,
+ 341, 917, 963, 963, 340, 475, 453, 335, 453,-1000,
+-1000,-1000,-1000,1083,-1000,-1000, 308,1211,-1000,-1000,
+-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,
+-1000,1083, 193, 158,-1000,-1000,1049,1049,-1000,-1000,
+-1000,-1000,1181, 332,-1000,-1000, 325, 325, 453,-1000,
+-1000,  73, 304,-1000,  58,-1000, 304,-1000,-1000,-1000,
+ 453,-1000, 380,-1000, 330,1273, -17,  66, -18, 453,
+ 475,  37, 963,1060,-1000, 453,-1000,-1000,-1000,-1000,
+-1000, 963,-1000, 963, 361,-1000, 963,-1000, 271,-1000,
+ 751, 475,-1000, 963,-1000,-1000,-1000, 963, 963,-1000,
+ 751,-1000, 963,-1000,-1000,  58, 475,-1000, 301, 240,
+-1000,1211,-1000,-1000,-1000, 906,-1000,1211,1211,1211,
+1211,1211, -30, 204, 106, 388,-1000,-1000, 388, 388,
+-1000, 143, 135, 116, 751,-1000,1049,-1000,-1000,-1000,
+-1000,-1000, 308,-1000,-1000, 300,-1000,-1000, 325,-1000,
+-1000, 222,-1000,-1000,-1000,  -5,-1000, -36,1201, 453,
+-1000, 216,-1000,  45,-1000,-1000, 380, 460,-1000, 453,
+-1000,-1000, 178,-1000, 226,-1000,-1000,-1000, 324, 220,
+ 726, 751, 952,-1000, 751, 299, 199, 115, 751, 453,
+ 704,-1000, 941, 963, 963, 963, 963, 963, 963, 963,
+ 963, 963, 963,-1000,-1000,-1000,-1000,-1000,-1000,-1000,
+ 676, 114, -31, 646, 629, 321, 127,-1000,-1000,-1000,
+1083,  33, 751,-1000,-1000,  27, -30, -30, -30,  50,
+-1000, 388, 106, 107, 106,1049,1049,1049, 607,  88,
+  86,  74,-1000,-1000,-1000,  87,-1000, 201,-1000, 304,
+-1000, 113,-1000,  85, 930,-1000,1201,-1000,-1000,  -3,
+1070,-1000,-1000,-1000, 963,-1000,-1000, 453,-1000, 380,
+  64,  78,-1000,   8,-1000,  60,-1000,-1000, 453, 963,
+  58, 963, 963, 391,-1000, 290, 303, 963, 963,-1000,
+ 475,-1000,   0, -31, -31, -31, 467,  95,  95, 581,
+ 646, -22,-1000, 963,-1000, 475, 475,  58,-1000, 308,
+-1000,-1000, 388,-1000,-1000,-1000,-1000,-1000,-1000,-1000,
+1049,1049,1049,-1000, 466, 465,  -5,-1000,-1000, 930,
+-1000,-1000, 564,-1000,-1000,1201,-1000,-1000,-1000,-1000,
+ 380,-1000, 460, 460, 453,-1000, 751,  37,  11,  43,
+ 751,-1000,-1000,-1000, 963, 285, 751,  41, 282,  62,
+-1000, 963, 284, 227, 282, 277, 275, 258,-1000,-1000,
+-1000,-1000, 930,-1000,-1000,   7, 248,-1000,-1000,-1000,
+-1000,-1000, 963,-1000,-1000, 475,-1000,-1000, 751,-1000,
+-1000,-1000,-1000,-1000, 751,-1000,-1000, 751,  34, 475,
+-1000 };
+yytabelem yypgo[]={
+
+   0, 613, 612,  13, 611,  81,  15,  32, 610, 604,
+ 603,  10,   0, 602, 601, 600,  16, 598,  35,  25,
+ 597, 596, 595,   3,   4, 594,  67, 593, 592,  50,
+  34,  18,  26, 101,  20, 591,  30, 373,   1, 292,
+  24, 347, 327,   2,   9,  14,  31,  49,  46, 590,
+ 588,  39,  28,  45, 587, 585, 584, 583, 581,1100,
+  40, 580, 579,  12, 578, 575, 573, 572, 571, 570,
+ 568,  29, 567,  27, 566,  23,  41,   7,  44,   6,
+  37, 565,  38, 561, 560,  11,  22,  36, 559, 558,
+   8,  17,  33, 557, 555, 541,   5, 540, 472, 537,
+ 536, 534, 533, 532, 528, 203, 523, 521, 518, 517,
+ 513, 509,  88, 508, 507,  19 };
+yytabelem yyr1[]={
+
+   0,   1,   1,  55,  55,  55,  55,  55,  55,  55,
+   2,  56,  56,  56,  56,  56,  56,  56,  60,  52,
+  33,  53,  53,  61,  61,  62,  62,  63,  63,  26,
+  26,  26,  27,  27,  34,  34,  17,  57,  57,  57,
+  57,  57,  57,  57,  57,  57,  57,  57,  57,  10,
+  10,  10,  74,   7,   8,   9,   9,   9,   9,   9,
+   9,   9,   9,   9,   9,   9,  16,  16,  16,  50,
+  50,  50,  50,  51,  51,  64,  64,  65,  65,  66,
+  66,  80,  54,  54,  67,  67,  81,  82,  76,  83,
+  84,  77,  77,  85,  85,  45,  45,  45,  70,  70,
+  86,  86,  72,  72,  87,  36,  18,  18,  19,  19,
+  75,  75,  89,  88,  88,  90,  90,  43,  43,  91,
+  91,   3,  68,  68,  92,  92,  95,  93,  94,  94,
+  96,  96,  11,  69,  69,  97,  20,  20,  71,  21,
+  21,  22,  22,  38,  38,  38,  39,  39,  39,  39,
+  39,  39,  39,  39,  39,  39,  39,  39,  39,  39,
+  12,  12,  13,  13,  13,  13,  13,  13,  37,  37,
+  37,  37,  32,  40,  40,  44,  44,  48,  48,  48,
+  48,  48,  48,  48,  47,  49,  49,  49,  41,  41,
+  42,  42,  42,  42,  42,  42,  42,  42,  58,  58,
+  58,  58,  58,  58,  58,  58,  58,  99,  23,  24,
+  24,  98,  98,  98,  98,  98,  98,  98,  98,  98,
+  98,  98,   4, 100, 101, 101, 101, 101,  73,  73,
+  35,  25,  25,  46,  46,  14,  14,  28,  28,  59,
+  78,  79, 102, 103, 103, 103, 103, 103, 103, 103,
+ 103, 103, 103, 103, 103, 103, 103, 104, 111, 111,
+ 111, 106, 113, 113, 113, 108, 108, 105, 105, 114,
+ 114, 115, 115, 115, 115, 115, 115,  15, 107, 109,
+ 110, 110,  29,  29,   6,   6,  30,  30,  30,  31,
+  31,  31,  31,  31,  31,   5,   5,   5,   5,   5,
+ 112 };
+yytabelem yyr2[]={
+
+   0,   0,   3,   2,   2,   2,   3,   3,   2,   1,
+   1,   3,   4,   3,   4,   4,   5,   3,   0,   1,
+   1,   0,   1,   2,   3,   1,   3,   1,   3,   0,
+   2,   3,   1,   3,   1,   1,   1,   1,   1,   1,
+   1,   1,   1,   1,   1,   1,   2,   1,   5,   7,
+   5,   5,   0,   2,   1,   1,   1,   1,   1,   1,
+   1,   1,   1,   1,   1,   1,   0,   4,   6,   3,
+   4,   5,   3,   1,   3,   3,   3,   3,   3,   3,
+   3,   3,   1,   3,   3,   3,   0,   6,   0,   0,
+   0,   2,   3,   1,   3,   1,   2,   1,   1,   3,
+   1,   1,   1,   3,   3,   2,   1,   5,   1,   3,
+   0,   3,   0,   2,   3,   1,   3,   1,   1,   1,
+   3,   1,   3,   3,   4,   1,   0,   2,   1,   3,
+   1,   3,   1,   1,   2,   4,   1,   3,   0,   0,
+   1,   1,   3,   1,   3,   1,   1,   1,   3,   3,
+   3,   3,   2,   3,   3,   3,   3,   3,   2,   3,
+   1,   1,   1,   1,   1,   1,   1,   1,   1,   2,
+   4,   5,   5,   0,   1,   1,   1,   1,   1,   1,
+   1,   1,   1,   1,   5,   1,   1,   1,   1,   3,
+   1,   1,   3,   3,   3,   3,   2,   3,   1,   7,
+   4,   1,   2,   2,   6,   2,   2,   5,   3,   1,
+   4,   4,   5,   2,   1,   1,  10,   1,   3,   4,
+   3,   3,   1,   1,   3,   3,   7,   7,   0,   1,
+   3,   1,   3,   1,   2,   1,   1,   1,   3,   0,
+   0,   0,   1,   2,   2,   2,   2,   2,   2,   2,
+   3,   4,   4,   2,   3,   1,   3,   3,   1,   1,
+   1,   3,   1,   1,   1,   1,   1,   3,   3,   1,
+   3,   1,   1,   1,   2,   2,   2,   1,   3,   3,
+   4,   4,   1,   3,   1,   5,   1,   1,   1,   3,
+   3,   3,   3,   3,   3,   1,   3,   5,   5,   5,
+   0 };
+yytabelem yychk[]={
+
+-1000,  -1, -55,  -2, 256,   3,   1, -56, -57, -58,
+  18,  37,   4,  60,  23,  69,  44,  -7,  40, -10,
+ -50, -64, -65, -66, -67, -68, -69,  66,  43,  57,
+ -98,  33,  97, -99,  36,  35,  39,  -8,  27,  42,
+  53,  41,  30,  50,  55,-100,  20,  29,-101,-102,
+  48, -35,  64, -14,  49,  -9,  19,  45,  46,  47,
+-103,  24,  58,  68,  52,  63,  28,  34,  31,  54,
+  25,  72,  32,  21,  67,-104,-106,-107,-109,-110,
+-111,-113,  62,  73,  59,  22,  65,  38,  51,  56,
+  26, -17,   5, -59, -60, -60, -60, -60,  44, -73,
+  78, -52, -33,  14,  78,  99, -73,  78,  78,  78,
+  78, -73,  78, -97,  83, -70, -86, -33, -51,  85,
+  83, -71, -59, -98,  70, -59, -59, -59, -16,  82,
+ -71, -71, -71, -71, -81, -71, -37, -33, -59, -59,
+ -59,  74, -59, -59, -59, -59, -59, -59, -59,-105,
+ -42,  82,  84,  74, -37, -48, -41, -12,  12,  13,
+   5,   6,   7,   8, -49,  80,  81,  11,  10,   9,
+-105,  74,-105,-108, -42,  82,-105,  78, -59, -59,
+ -59, -59, -59, -53, -52, -53, -52, -52, -60, -33,
+ -26,  74, -33, -76, -51, -36, -33, -33, -33, -80,
+  74, -82, -76, -92, -93, -95, -33,  78,  14,  74,
+ -78, -73,  74, -78, -36, -51, -33, -33, -80, -82,
+ -92,  76, -32,  74,  -4,   6,  74,  75, -25, -46,
+ -38,  82, -39,  74, -47, -37, -48, -12,  90, -40,
+ -38, -40,  74,  -3,   6, -33,  74, -33, -41,-114,
+ -42,  74,-115,  82,  84, -15,  15, -12,  82,  83,
+  84,  85, -41, -41, -29,  78,  -6, -37,  74,  78,
+ -30, -39,  -5, -31, -38, -47,  74, -30,-112,-112,
+-112,-112, -41,  82, -61,  74, -26, -26, -52, -71,
+  75, -27, -34, -33,  82, -75,  74, -77, -84, -73,
+ -75, -54, -37, -19, -18, -37,  74,  74,  -7,  83,
+ -86,  83, -72, -87, -33,  -3, -24, -23,  98, -33,
+ -38, -38,  74, -36, -38, -21, -40, -22, -38,  71,
+ -38,  75,  78, -12,  82,  83,  84, -13,  89,  88,
+  87,  86,  85,  91,  93,  92,  95,  94,  96,  -3,
+ -38, -39, -38, -38, -38, -73, -91,  -3,  75,  75,
+  78, -41, -38,  82,  84, -41, -41, -41, -41, -41,
+  75,  78, -29, -29, -29,  78,  78,  78, -38, -39,
+  -5, -31,-112,-112,  75, -62, -63,  14, -26, -74,
+  75,  78, -16, -88, -89,  99,  78, -85, -45, -44,
+ -12, -47, -33, -48,  74, -36,  75,  78,  83,  78,
+ -19, -94, -96, -11,  14, -20, -33,  75,  78,  76,
+ -79,  74,  76,  75, -79,  82,  75,  77,  78, -33,
+  75, -46, -38, -38, -38, -38, -38, -38, -38, -38,
+ -38, -38,  75,  78,  75,  74,  78,  75,-115, -41,
+  75,  -6,  78, -39,  -5, -39,  -5, -39,  -5,  75,
+  78,  78,  78,  75,  78,  76, -75, -34,  75,  78,
+ -90, -43, -38,  82, -85,  82, -44, -37, -83, -18,
+  78,  75,  78,  81,  78, -87, -38, -73, -38, -28,
+ -38,  70,  75, -32,  74, -40, -38,  -3, -39, -91,
+  -3, -73, -23, -33, -39, -23, -23, -23, -63,  14,
+ -16, -90,  77, -45, -44, -77, -23, -96, -11, -33,
+ -24,  75,  78, -79,  75,  78,  75,  75, -38,  75,
+  75,  75,  75, -43, -38,  83,  75, -38,  -3,  78,
+  -3 };
+yytabelem yydef[]={
+
+   1,  -2,   0,   0,   9,  10,   2,   3,   4,   5,
+   0, 239,   8,  18,  18,  18,  18, 228,   0,  37,
+  -2,  39,  40,  41,  -2,  43,  44,  45,  47, 138,
+ 198, 239, 201,   0, 239, 239, 239,  66, 138, 138,
+ 138, 138,  86, 138, 133,   0, 239, 239, 214, 215,
+ 239, 217, 239, 239, 239,  54, 223, 239, 239, 239,
+ 242, 239, 235, 236,  55,  56,  57,  58,  59,  60,
+  61,  62,  63,  64,  65,   0,   0,   0,   0, 255,
+ 239, 239, 239, 239, 239, 258, 259, 260, 262, 263,
+ 264,   6,  36,   7,  21,  21,   0,   0,  18,   0,
+ 229,  29,  19,  20,   0,  88,   0, 229,   0,   0,
+   0,  88, 126, 134,   0,  46,  98, 100, 101,  73,
+   0,   0,  -2, 202, 203,   0, 205, 206,  53, 240,
+   0,   0,   0,   0,  88, 126,   0, 168,   0, 213,
+   0,   0, 173, 173,   0,   0,   0,   0,   0, 243,
+  -2, 245, 246,   0, 190, 191,   0,   0, 177, 178,
+ 179, 180, 181, 182, 183, 160, 161, 185, 186, 187,
+ 247,   0, 248, 249,  -2, 266, 253,   0, 300, 300,
+ 300, 300,   0,  11,  22,  13,  29,  29,   0, 138,
+  17,   0, 110,  90, 228,  72, 110,  76,  78,  80,
+   0,  85,   0, 123, 125,   0,   0,   0,   0,   0,
+   0,   0,   0,   0,  69,   0,  75,  77,  79,  84,
+ 122,   0, 169,  -2,   0, 222,   0, 218,   0, 231,
+ 233,   0, 143,   0, 145, 146, 147,   0,   0, 220,
+ 174, 221,   0, 224, 121,  -2,   0, 230, 271,   0,
+ 188,   0, 269, 272, 273,   0, 277,   0,   0,   0,
+   0,   0, 196, 271, 250,   0, 282, 284,   0,   0,
+ 254,  -2, 287, 288,   0,  -2,   0, 256, 257, 261,
+ 278, 279, 300, 300,  12,   0,  14,  15,  29,  52,
+  30,   0,  32,  34,  35,  66, 112,   0,   0,   0,
+ 105,   0,  82,   0, 108, 106,   0,   0, 127,   0,
+  99,  74,   0, 102,   0, 241, 200, 209,   0,   0,
+   0, 241,   0,  70, 211,   0,   0, 140,  -2,   0,
+   0, 219,   0,   0,   0,   0,   0,   0,   0,   0,
+   0,   0,   0, 162, 163, 164, 165, 166, 167, 234,
+   0, 143, 152, 158,   0,   0,   0, 119,  -2, 268,
+   0,   0, 274, 275, 276, 192, 193, 194, 195, 197,
+ 267,   0, 252,   0, 251,   0,   0,   0,   0, 143,
+   0,   0, 280, 281,  23,   0,  25,  27,  16, 110,
+  31,   0,  50,   0,   0,  51,   0,  91,  93,  95,
+   0,  97, 175, 176,   0,  71,  81,   0,  89,   0,
+   0,   0, 128, 130, 132, 135, 136,  48,   0,   0,
+ 228,   0,   0,   0,  67,   0, 170, 173,   0, 212,
+   0, 232, 148, 149, 150, 151,  -2, 154, 155, 156,
+ 157, 159, 144,   0, 207,   0,   0, 228, 270, 271,
+ 189, 283,   0,  -2, 290,  -2, 292,  -2, 294,  -2,
+   0,   0,   0,  24,   0,   0,  66,  33, 111,   0,
+ 113, 115, 118, 117,  92,   0,  96,  83,  90, 109,
+   0, 124,   0,   0,   0, 103, 104,   0,   0, 208,
+ 237, 204, 241, 171, 173,   0, 142,   0, 143,   0,
+ 120,   0,   0, 168,  -2,   0,   0,   0,  26,  28,
+  49, 114,   0,  94,  95,   0,   0, 129, 131, 137,
+ 199, 210,   0,  68, 172,   0, 184, 226, 227, 285,
+ 297, 298, 299, 116, 118,  87, 107, 238,   0,   0,
+ 216 };
+# ifdef YYDEBUG
+# include "y.debug"
+# endif
+
+# define YYFLAG -1000
+# define YYERROR goto yyerrlab
+# define YYACCEPT return(0)
+# define YYABORT return(1)
+
+/*	parser for yacc output	*/
+
+#ifdef YYDEBUG
+int yydebug = 0; /* 1 for debugging */
+#endif
+YYSTYPE yyv[YYMAXDEPTH]; /* where the values are stored */
+int yychar = -1; /* current input token number */
+int yynerrs = 0;  /* number of errors */
+yytabelem yyerrflag = 0;  /* error recovery flag */
+
+yyparse()
+{	yytabelem yys[YYMAXDEPTH];
+	int yyj, yym;
+	register YYSTYPE *yypvt;
+	register int yystate, yyn;
+	register yytabelem *yyps;
+	register YYSTYPE *yypv;
+	register yytabelem *yyxi;
+
+	yystate = 0;
+	yychar = -1;
+	yynerrs = 0;
+	yyerrflag = 0;
+	yyps= &yys[-1];
+	yypv= &yyv[-1];
+
+yystack:    /* put a state and value onto the stack */
+#ifdef YYDEBUG
+	if(yydebug >= 3)
+		if(yychar < 0 || yytoknames[yychar] == 0)
+			printf("char %d in %s", yychar, yystates[yystate]);
+		else
+			printf("%s in %s", yytoknames[yychar], yystates[yystate]);
+#endif
+	if( ++yyps >= &yys[YYMAXDEPTH] ) {
+		yyerror( "yacc stack overflow" );
+		return(1);
+	}
+	*yyps = yystate;
+	++yypv;
+	*yypv = yyval;
+yynewstate:
+	yyn = yypact[yystate];
+	if(yyn <= YYFLAG) goto yydefault; /* simple state */
+	if(yychar<0) {
+		yychar = yylex();
+#ifdef YYDEBUG
+		if(yydebug >= 2) {
+			if(yychar <= 0)
+				printf("lex EOF\n");
+			else if(yytoknames[yychar])
+				printf("lex %s\n", yytoknames[yychar]);
+			else
+				printf("lex (%c)\n", yychar);
+		}
+#endif
+		if(yychar < 0)
+			yychar = 0;
+	}
+	if((yyn += yychar) < 0 || yyn >= YYLAST)
+		goto yydefault;
+	if( yychk[ yyn=yyact[ yyn ] ] == yychar ){ /* valid shift */
+		yychar = -1;
+		yyval = yylval;
+		yystate = yyn;
+		if( yyerrflag > 0 ) --yyerrflag;
+		goto yystack;
+	}
+yydefault:
+	/* default state action */
+	if( (yyn=yydef[yystate]) == -2 ) {
+		if(yychar < 0) {
+			yychar = yylex();
+#ifdef YYDEBUG
+			if(yydebug >= 2)
+				if(yychar < 0)
+					printf("lex EOF\n");
+				else
+					printf("lex %s\n", yytoknames[yychar]);
+#endif
+			if(yychar < 0)
+				yychar = 0;
+		}
+		/* look through exception table */
+		for(yyxi=yyexca; (*yyxi!= (-1)) || (yyxi[1]!=yystate);
+			yyxi += 2 ) ; /* VOID */
+		while( *(yyxi+=2) >= 0 ){
+			if( *yyxi == yychar ) break;
+		}
+		if( (yyn = yyxi[1]) < 0 ) return(0);   /* accept */
+	}
+	if( yyn == 0 ){ /* error */
+		/* error ... attempt to resume parsing */
+		switch( yyerrflag ){
+		case 0:   /* brand new error */
+#ifdef YYDEBUG
+			yyerror("syntax error\n%s", yystates[yystate]);
+			if(yytoknames[yychar])
+				yyerror("saw %s\n", yytoknames[yychar]);
+			else if(yychar >= ' ' && yychar < '\177')
+				yyerror("saw `%c'\n", yychar);
+			else if(yychar == 0)
+				yyerror("saw EOF\n");
+			else
+				yyerror("saw char 0%o\n", yychar);
+#else
+			yyerror( "syntax error" );
+#endif
+yyerrlab:
+			++yynerrs;
+		case 1:
+		case 2: /* incompletely recovered error ... try again */
+			yyerrflag = 3;
+			/* find a state where "error" is a legal shift action */
+			while ( yyps >= yys ) {
+				yyn = yypact[*yyps] + YYERRCODE;
+				if( yyn>= 0 && yyn < YYLAST && yychk[yyact[yyn]] == YYERRCODE ){
+					yystate = yyact[yyn];  /* simulate a shift of "error" */
+					goto yystack;
+				}
+				yyn = yypact[*yyps];
+				/* the current yyps has no shift onn "error", pop stack */
+#ifdef YYDEBUG
+				if( yydebug ) printf( "error recovery pops state %d, uncovers %d\n", *yyps, yyps[-1] );
+#endif
+				--yyps;
+				--yypv;
+			}
+			/* there is no state on the stack with an error shift ... abort */
+yyabort:
+			return(1);
+		case 3:  /* no shift yet; clobber input char */
+#ifdef YYDEBUG
+			if( yydebug ) {
+				printf("error recovery discards ");
+				if(yytoknames[yychar])
+					printf("%s\n", yytoknames[yychar]);
+				else if(yychar >= ' ' && yychar < '\177')
+					printf("`%c'\n", yychar);
+				else if(yychar == 0)
+					printf("EOF\n");
+				else
+					printf("char 0%o\n", yychar);
+			}
+#endif
+			if( yychar == 0 ) goto yyabort; /* don't discard EOF, quit */
+			yychar = -1;
+			goto yynewstate;   /* try again in the same state */
+		}
+	}
+	/* reduction by production yyn */
+#ifdef YYDEBUG
+	if(yydebug) {	char *s;
+		printf("reduce %d in:\n\t", yyn);
+		for(s = yystates[yystate]; *s; s++) {
+			putchar(*s);
+			if(*s == '\n' && *(s+1))
+				putchar('\t');
+		}
+	}
+#endif
+	yyps -= yyr2[yyn];
+	yypvt = yypv;
+	yypv -= yyr2[yyn];
+	yyval = yypv[1];
+	yym=yyn;
+	/* consult goto table to find next state */
+	yyn = yyr1[yyn];
+	yyj = yypgo[yyn] + *yyps + 1;
+	if( yyj>=YYLAST || yychk[ yystate = yyact[yyj] ] != -yyn ) yystate = yyact[yypgo[yyn]];
+	switch(yym){
+
+case 3:
+/* # line 226 "gram.in" */
+{
+/* stat:   is the nonterminal for Fortran statements */
+
+		  lastwasbranch = NO; } break;
+case 5:
+/* # line 232 "gram.in" */
+{ /* forbid further statement function definitions... */
+		  if (parstate == INDATA && laststfcn != thisstno)
+			parstate = INEXEC;
+		  thisstno++;
+		  if(yypvt[-1].labval && (yypvt[-1].labval->labelno==dorange))
+			enddo(yypvt[-1].labval->labelno);
+		  if(lastwasbranch && thislabel==NULL)
+			warn("statement cannot be reached");
+		  lastwasbranch = thiswasbranch;
+		  thiswasbranch = NO;
+		  if(yypvt[-1].labval)
+			{
+			if(yypvt[-1].labval->labtype == LABFORMAT)
+				err("label already that of a format");
+			else
+				yypvt[-1].labval->labtype = LABEXEC;
+			}
+		  freetemps();
+		} break;
+case 6:
+/* # line 252 "gram.in" */
+{ if (can_include)
+			doinclude( yypvt[-0].charpval );
+		  else {
+			fprintf(diagfile, "Cannot open file %s\n", yypvt[-0].charpval);
+			done(1);
+			}
+		} break;
+case 7:
+/* # line 260 "gram.in" */
+{ if (yypvt[-2].labval)
+			lastwasbranch = NO;
+		  endproc(); /* lastwasbranch = NO; -- set in endproc() */
+		} break;
+case 8:
+/* # line 265 "gram.in" */
+{ extern void unclassifiable();
+		  unclassifiable();
+
+/* flline flushes the current line, ignoring the rest of the text there */
+
+		  flline(); } break;
+case 9:
+/* # line 272 "gram.in" */
+{ flline();  needkwd = NO;  inioctl = NO;
+		  yyerrok; yyclearin; } break;
+case 10:
+/* # line 277 "gram.in" */
+{
+		if(yystno != 0)
+			{
+			yyval.labval = 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    yyval.labval = thislabel = NULL;
+		} break;
+case 11:
+/* # line 305 "gram.in" */
+{startproc(yypvt[-0].extval, CLMAIN); } break;
+case 12:
+/* # line 307 "gram.in" */
+{	warn("ignoring arguments to main program");
+			/* hashclear(); */
+			startproc(yypvt[-1].extval, CLMAIN); } break;
+case 13:
+/* # line 311 "gram.in" */
+{ if(yypvt[-0].extval) NO66("named BLOCKDATA");
+		  startproc(yypvt[-0].extval, CLBLOCK); } break;
+case 14:
+/* # line 314 "gram.in" */
+{ entrypt(CLPROC, TYSUBR, (ftnint) 0,  yypvt[-1].extval, yypvt[-0].chval); } break;
+case 15:
+/* # line 316 "gram.in" */
+{ entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, yypvt[-1].extval, yypvt[-0].chval); } break;
+case 16:
+/* # line 318 "gram.in" */
+{ entrypt(CLPROC, yypvt[-4].ival, varleng, yypvt[-1].extval, yypvt[-0].chval); } break;
+case 17:
+/* # line 320 "gram.in" */
+{ if(parstate==OUTSIDE || procclass==CLMAIN
+			|| procclass==CLBLOCK)
+				execerr("misplaced entry statement", CNULL);
+		  entrypt(CLENTRY, 0, (ftnint) 0, yypvt[-1].extval, yypvt[-0].chval);
+		} break;
+case 18:
+/* # line 328 "gram.in" */
+{ newproc(); } break;
+case 19:
+/* # line 332 "gram.in" */
+{ yyval.extval = newentry(yypvt[-0].namval, 1); } break;
+case 20:
+/* # line 336 "gram.in" */
+{ yyval.namval = mkname(token); } break;
+case 21:
+/* # line 339 "gram.in" */
+{ yyval.extval = NULL; } break;
+case 29:
+/* # line 357 "gram.in" */
+{ yyval.chval = 0; } break;
+case 30:
+/* # line 359 "gram.in" */
+{ NO66(" () argument list");
+		  yyval.chval = 0; } break;
+case 31:
+/* # line 362 "gram.in" */
+{yyval.chval = yypvt[-1].chval; } break;
+case 32:
+/* # line 366 "gram.in" */
+{ yyval.chval = (yypvt[-0].namval ? mkchain((char *)yypvt[-0].namval,CHNULL) : CHNULL ); } break;
+case 33:
+/* # line 368 "gram.in" */
+{ if(yypvt[-0].namval) yypvt[-2].chval = yyval.chval = mkchain((char *)yypvt[-0].namval, yypvt[-2].chval); } break;
+case 34:
+/* # line 372 "gram.in" */
+{ if(yypvt[-0].namval->vstg!=STGUNKNOWN && yypvt[-0].namval->vstg!=STGARG)
+			dclerr("name declared as argument after use", yypvt[-0].namval);
+		  yypvt[-0].namval->vstg = STGARG;
+		} break;
+case 35:
+/* # line 377 "gram.in" */
+{ 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   */
+
+		  yyval.namval = 0;  substars = YES; } break;
+case 36:
+/* # line 393 "gram.in" */
+{
+		char *s;
+		s = copyn(toklen+1, token);
+		s[toklen] = '\0';
+		yyval.charpval = s;
+		} break;
+case 45:
+/* # line 409 "gram.in" */
+{ NO66("SAVE statement");
+		  saveall = YES; } break;
+case 46:
+/* # line 412 "gram.in" */
+{ NO66("SAVE statement"); } break;
+case 47:
+/* # line 414 "gram.in" */
+{ fmtstmt(thislabel); setfmt(thislabel); } break;
+case 48:
+/* # line 416 "gram.in" */
+{ NO66("PARAMETER statement"); } break;
+case 49:
+/* # line 420 "gram.in" */
+{ settype(yypvt[-4].namval, yypvt[-6].ival, yypvt[-0].lval);
+		  if(ndim>0) setbound(yypvt[-4].namval,ndim,dims);
+		} break;
+case 50:
+/* # line 424 "gram.in" */
+{ settype(yypvt[-2].namval, yypvt[-4].ival, yypvt[-0].lval);
+		  if(ndim>0) setbound(yypvt[-2].namval,ndim,dims);
+		} break;
+case 51:
+/* # line 428 "gram.in" */
+{ if (new_dcl == 2) {
+			err("attempt to give DATA in type-declaration");
+			new_dcl = 1;
+			}
+		} break;
+case 52:
+/* # line 435 "gram.in" */
+{ new_dcl = 2; } break;
+case 53:
+/* # line 438 "gram.in" */
+{ varleng = yypvt[-0].lval; } break;
+case 54:
+/* # line 442 "gram.in" */
+{ varleng = (yypvt[-0].ival<0 || ONEOF(yypvt[-0].ival,M(TYLOGICAL)|M(TYLONG))
+				? 0 : typesize[yypvt[-0].ival]);
+		  vartype = yypvt[-0].ival; } break;
+case 55:
+/* # line 447 "gram.in" */
+{ yyval.ival = TYLONG; } break;
+case 56:
+/* # line 448 "gram.in" */
+{ yyval.ival = tyreal; } break;
+case 57:
+/* # line 449 "gram.in" */
+{ ++complex_seen; yyval.ival = tycomplex; } break;
+case 58:
+/* # line 450 "gram.in" */
+{ yyval.ival = TYDREAL; } break;
+case 59:
+/* # line 451 "gram.in" */
+{ ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); yyval.ival = TYDCOMPLEX; } break;
+case 60:
+/* # line 452 "gram.in" */
+{ yyval.ival = TYLOGICAL; } break;
+case 61:
+/* # line 453 "gram.in" */
+{ NO66("CHARACTER statement"); yyval.ival = TYCHAR; } break;
+case 62:
+/* # line 454 "gram.in" */
+{ yyval.ival = TYUNKNOWN; } break;
+case 63:
+/* # line 455 "gram.in" */
+{ yyval.ival = TYUNKNOWN; } break;
+case 64:
+/* # line 456 "gram.in" */
+{ NOEXT("AUTOMATIC statement"); yyval.ival = - STGAUTO; } break;
+case 65:
+/* # line 457 "gram.in" */
+{ NOEXT("STATIC statement"); yyval.ival = - STGBSS; } break;
+case 66:
+/* # line 461 "gram.in" */
+{ yyval.lval = varleng; } break;
+case 67:
+/* # line 463 "gram.in" */
+{
+		expptr p;
+		p = yypvt[-1].expval;
+		NO66("length specification *n");
+		if( ! ISICON(p) || p->constblock.Const.ci <= 0 )
+			{
+			yyval.lval = 0;
+			dclerr("length must be a positive integer constant",
+				NPNULL);
+			}
+		else {
+			if (vartype == TYCHAR)
+				yyval.lval = p->constblock.Const.ci;
+			else switch((int)p->constblock.Const.ci) {
+				case 1:	yyval.lval = 1; break;
+				case 2: yyval.lval = typesize[TYSHORT];	break;
+				case 4: yyval.lval = typesize[TYLONG];	break;
+				case 8: yyval.lval = typesize[TYDREAL];	break;
+				case 16: yyval.lval = typesize[TYDCOMPLEX]; break;
+				default:
+					dclerr("invalid length",NPNULL);
+					yyval.lval = varleng;
+				}
+			}
+		} break;
+case 68:
+/* # line 489 "gram.in" */
+{ NO66("length specification *(*)"); yyval.lval = -1; } break;
+case 69:
+/* # line 493 "gram.in" */
+{ incomm( yyval.extval = comblock("") , yypvt[-0].namval ); } break;
+case 70:
+/* # line 495 "gram.in" */
+{ yyval.extval = yypvt[-1].extval;  incomm(yypvt[-1].extval, yypvt[-0].namval); } break;
+case 71:
+/* # line 497 "gram.in" */
+{ yyval.extval = yypvt[-2].extval;  incomm(yypvt[-2].extval, yypvt[-0].namval); } break;
+case 72:
+/* # line 499 "gram.in" */
+{ incomm(yypvt[-2].extval, yypvt[-0].namval); } break;
+case 73:
+/* # line 503 "gram.in" */
+{ yyval.extval = comblock(""); } break;
+case 74:
+/* # line 505 "gram.in" */
+{ yyval.extval = comblock(token); } break;
+case 75:
+/* # line 509 "gram.in" */
+{ setext(yypvt[-0].namval); } break;
+case 76:
+/* # line 511 "gram.in" */
+{ setext(yypvt[-0].namval); } break;
+case 77:
+/* # line 515 "gram.in" */
+{ NO66("INTRINSIC statement"); setintr(yypvt[-0].namval); } break;
+case 78:
+/* # line 517 "gram.in" */
+{ setintr(yypvt[-0].namval); } break;
+case 81:
+/* # line 525 "gram.in" */
+{
+		struct Equivblock *p;
+		if(nequiv >= maxequiv)
+			many("equivalences", 'q', maxequiv);
+		p  =  & eqvclass[nequiv++];
+		p->eqvinit = NO;
+		p->eqvbottom = 0;
+		p->eqvtop = 0;
+		p->equivs = yypvt[-1].eqvval;
+		} break;
+case 82:
+/* # line 538 "gram.in" */
+{ yyval.eqvval=ALLOC(Eqvchain);
+		  yyval.eqvval->eqvitem.eqvlhs = (struct Primblock *)yypvt[-0].expval;
+		} break;
+case 83:
+/* # line 542 "gram.in" */
+{ yyval.eqvval=ALLOC(Eqvchain);
+		  yyval.eqvval->eqvitem.eqvlhs = (struct Primblock *) yypvt[-0].expval;
+		  yyval.eqvval->eqvnextp = yypvt[-2].eqvval;
+		} break;
+case 86:
+/* # line 553 "gram.in" */
+{ if(parstate == OUTSIDE)
+			{
+			newproc();
+			startproc(ESNULL, CLMAIN);
+			}
+		  if(parstate < INDATA)
+			{
+			enddcl();
+			parstate = INDATA;
+			datagripe = 1;
+			}
+		} break;
+case 87:
+/* # line 568 "gram.in" */
+{ ftnint junk;
+		  if(nextdata(&junk) != NULL)
+			err("too few initializers");
+		  frdata(yypvt[-4].chval);
+		  frrpl();
+		} break;
+case 88:
+/* # line 576 "gram.in" */
+{ frchain(&datastack); curdtp = 0; } break;
+case 89:
+/* # line 578 "gram.in" */
+{ pop_datastack(); } break;
+case 90:
+/* # line 580 "gram.in" */
+{ toomanyinit = NO; } break;
+case 93:
+/* # line 585 "gram.in" */
+{ dataval(ENULL, yypvt[-0].expval); } break;
+case 94:
+/* # line 587 "gram.in" */
+{ dataval(yypvt[-2].expval, yypvt[-0].expval); } break;
+case 96:
+/* # line 592 "gram.in" */
+{ if( yypvt[-1].ival==OPMINUS && ISCONST(yypvt[-0].expval) )
+			consnegop((Constp)yypvt[-0].expval);
+		  yyval.expval = yypvt[-0].expval;
+		} break;
+case 100:
+/* # line 604 "gram.in" */
+{ int k;
+		  yypvt[-0].namval->vsave = YES;
+		  k = yypvt[-0].namval->vstg;
+		if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) )
+			dclerr("can only save static variables", yypvt[-0].namval);
+		} break;
+case 104:
+/* # line 618 "gram.in" */
+{ if(yypvt[-2].namval->vclass == CLUNKNOWN)
+			make_param((struct Paramblock *)yypvt[-2].namval, yypvt[-0].expval);
+		  else dclerr("cannot make into parameter", yypvt[-2].namval);
+		} break;
+case 105:
+/* # line 625 "gram.in" */
+{ if(ndim>0) setbound(yypvt[-1].namval, ndim, dims); } break;
+case 106:
+/* # line 629 "gram.in" */
+{ Namep np;
+		  np = ( (struct Primblock *) yypvt[-0].expval) -> 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);
+		  yyval.chval = mkchain((char *)yypvt[-0].expval, CHNULL);
+		} break;
+case 107:
+/* # line 641 "gram.in" */
+{ chainp p; struct Impldoblock *q;
+		pop_datastack();
+		q = ALLOC(Impldoblock);
+		q->tag = TIMPLDO;
+		(q->varnp = (Namep) (yypvt[-1].chval->datap))->vimpldovar = 1;
+		p = yypvt[-1].chval->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( & (yypvt[-1].chval) );
+		yyval.chval = mkchain((char *)q, CHNULL);
+		q->datalist = hookup(yypvt[-3].chval, yyval.chval);
+		} break;
+case 108:
+/* # line 657 "gram.in" */
+{ if (!datastack)
+			curdtp = 0;
+		  datastack = mkchain((char *)curdtp, datastack);
+		  curdtp = yypvt[-0].chval; curdtelt = 0;
+		  } break;
+case 109:
+/* # line 663 "gram.in" */
+{ yyval.chval = hookup(yypvt[-2].chval, yypvt[-0].chval); } break;
+case 110:
+/* # line 667 "gram.in" */
+{ ndim = 0; } break;
+case 112:
+/* # line 671 "gram.in" */
+{ ndim = 0; } break;
+case 115:
+/* # line 676 "gram.in" */
+{
+		  if(ndim == maxdim)
+			err("too many dimensions");
+		  else if(ndim < maxdim)
+			{ dims[ndim].lb = 0;
+			  dims[ndim].ub = yypvt[-0].expval;
+			}
+		  ++ndim;
+		} break;
+case 116:
+/* # line 686 "gram.in" */
+{
+		  if(ndim == maxdim)
+			err("too many dimensions");
+		  else if(ndim < maxdim)
+			{ dims[ndim].lb = yypvt[-2].expval;
+			  dims[ndim].ub = yypvt[-0].expval;
+			}
+		  ++ndim;
+		} break;
+case 117:
+/* # line 698 "gram.in" */
+{ yyval.expval = 0; } break;
+case 119:
+/* # line 703 "gram.in" */
+{ nstars = 1; labarray[0] = yypvt[-0].labval; } break;
+case 120:
+/* # line 705 "gram.in" */
+{ if(nstars < maxlablist)  labarray[nstars++] = yypvt[-0].labval; } break;
+case 121:
+/* # line 709 "gram.in" */
+{ yyval.labval = execlab( convci(toklen, token) ); } break;
+case 122:
+/* # line 713 "gram.in" */
+{ NO66("IMPLICIT statement"); } break;
+case 125:
+/* # line 719 "gram.in" */
+{ if (vartype != TYUNKNOWN)
+			dclerr("-- expected letter range",NPNULL);
+		  setimpl(vartype, varleng, 'a', 'z'); } break;
+case 126:
+/* # line 724 "gram.in" */
+{ needkwd = 1; } break;
+case 130:
+/* # line 733 "gram.in" */
+{ setimpl(vartype, varleng, yypvt[-0].ival, yypvt[-0].ival); } break;
+case 131:
+/* # line 735 "gram.in" */
+{ setimpl(vartype, varleng, yypvt[-2].ival, yypvt[-0].ival); } break;
+case 132:
+/* # line 739 "gram.in" */
+{ if(toklen!=1 || token[0]<'a' || token[0]>'z')
+			{
+			dclerr("implicit item must be single letter", NPNULL);
+			yyval.ival = 0;
+			}
+		  else yyval.ival = token[0];
+		} break;
+case 135:
+/* # line 753 "gram.in" */
+{
+		if(yypvt[-2].namval->vclass == CLUNKNOWN)
+			{
+			yypvt[-2].namval->vclass = CLNAMELIST;
+			yypvt[-2].namval->vtype = TYINT;
+			yypvt[-2].namval->vstg = STGBSS;
+			yypvt[-2].namval->varxptr.namelist = yypvt[-0].chval;
+			yypvt[-2].namval->vardesc.varno = ++lastvarno;
+			}
+		else dclerr("cannot be a namelist name", yypvt[-2].namval);
+		} break;
+case 136:
+/* # line 767 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].namval, CHNULL); } break;
+case 137:
+/* # line 769 "gram.in" */
+{ yyval.chval = hookup(yypvt[-2].chval, mkchain((char *)yypvt[-0].namval, CHNULL)); } break;
+case 138:
+/* # line 773 "gram.in" */
+{ 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);
+			}
+		} break;
+case 139:
+/* # line 795 "gram.in" */
+{ yyval.chval = 0; } break;
+case 140:
+/* # line 797 "gram.in" */
+{ yyval.chval = revchain(yypvt[-0].chval); } break;
+case 141:
+/* # line 801 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].expval, CHNULL); } break;
+case 142:
+/* # line 803 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].expval, yypvt[-2].chval); } break;
+case 144:
+/* # line 808 "gram.in" */
+{ yyval.expval = yypvt[-1].expval; if (yyval.expval->tag == TPRIM)
+					yyval.expval->primblock.parenused = 1; } break;
+case 148:
+/* # line 816 "gram.in" */
+{ yyval.expval = mkexpr(yypvt[-1].ival, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 149:
+/* # line 818 "gram.in" */
+{ yyval.expval = mkexpr(OPSTAR, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 150:
+/* # line 820 "gram.in" */
+{ yyval.expval = mkexpr(OPSLASH, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 151:
+/* # line 822 "gram.in" */
+{ yyval.expval = mkexpr(OPPOWER, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 152:
+/* # line 824 "gram.in" */
+{ if(yypvt[-1].ival == OPMINUS)
+			yyval.expval = mkexpr(OPNEG, yypvt[-0].expval, ENULL);
+		  else 	yyval.expval = yypvt[-0].expval;
+		} break;
+case 153:
+/* # line 829 "gram.in" */
+{ yyval.expval = mkexpr(yypvt[-1].ival, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 154:
+/* # line 831 "gram.in" */
+{ NO66(".EQV. operator");
+		  yyval.expval = mkexpr(OPEQV, yypvt[-2].expval,yypvt[-0].expval); } break;
+case 155:
+/* # line 834 "gram.in" */
+{ NO66(".NEQV. operator");
+		  yyval.expval = mkexpr(OPNEQV, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 156:
+/* # line 837 "gram.in" */
+{ yyval.expval = mkexpr(OPOR, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 157:
+/* # line 839 "gram.in" */
+{ yyval.expval = mkexpr(OPAND, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 158:
+/* # line 841 "gram.in" */
+{ yyval.expval = mkexpr(OPNOT, yypvt[-0].expval, ENULL); } break;
+case 159:
+/* # line 843 "gram.in" */
+{ NO66("concatenation operator //");
+		  yyval.expval = mkexpr(OPCONCAT, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 160:
+/* # line 847 "gram.in" */
+{ yyval.ival = OPPLUS; } break;
+case 161:
+/* # line 848 "gram.in" */
+{ yyval.ival = OPMINUS; } break;
+case 162:
+/* # line 851 "gram.in" */
+{ yyval.ival = OPEQ; } break;
+case 163:
+/* # line 852 "gram.in" */
+{ yyval.ival = OPGT; } break;
+case 164:
+/* # line 853 "gram.in" */
+{ yyval.ival = OPLT; } break;
+case 165:
+/* # line 854 "gram.in" */
+{ yyval.ival = OPGE; } break;
+case 166:
+/* # line 855 "gram.in" */
+{ yyval.ival = OPLE; } break;
+case 167:
+/* # line 856 "gram.in" */
+{ yyval.ival = OPNE; } break;
+case 168:
+/* # line 860 "gram.in" */
+{ yyval.expval = mkprim(yypvt[-0].namval, LBNULL, CHNULL); } break;
+case 169:
+/* # line 862 "gram.in" */
+{ NO66("substring operator :");
+		  yyval.expval = mkprim(yypvt[-1].namval, LBNULL, yypvt[-0].chval); } break;
+case 170:
+/* # line 865 "gram.in" */
+{ yyval.expval = mkprim(yypvt[-3].namval, mklist(yypvt[-1].chval), CHNULL); } break;
+case 171:
+/* # line 867 "gram.in" */
+{ NO66("substring operator :");
+		  yyval.expval = mkprim(yypvt[-4].namval, mklist(yypvt[-2].chval), yypvt[-0].chval); } break;
+case 172:
+/* # line 872 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-3].expval, mkchain((char *)yypvt[-1].expval,CHNULL)); } break;
+case 173:
+/* # line 876 "gram.in" */
+{ yyval.expval = 0; } break;
+case 175:
+/* # line 881 "gram.in" */
+{ if(yypvt[-0].namval->vclass == CLPARAM)
+			yyval.expval = (expptr) cpexpr(
+				( (struct Paramblock *) (yypvt[-0].namval) ) -> paramval);
+		} break;
+case 177:
+/* # line 888 "gram.in" */
+{ yyval.expval = mklogcon(1); } break;
+case 178:
+/* # line 889 "gram.in" */
+{ yyval.expval = mklogcon(0); } break;
+case 179:
+/* # line 890 "gram.in" */
+{ yyval.expval = mkstrcon(toklen, token); } break;
+case 180:
+/* # line 891 "gram.in" */
+ { yyval.expval = mkintcon( convci(toklen, token) ); } break;
+case 181:
+/* # line 892 "gram.in" */
+ { yyval.expval = mkrealcon(tyreal, token); } break;
+case 182:
+/* # line 893 "gram.in" */
+ { yyval.expval = mkrealcon(TYDREAL, token); } break;
+case 184:
+/* # line 898 "gram.in" */
+{ yyval.expval = mkcxcon(yypvt[-3].expval,yypvt[-1].expval); } break;
+case 185:
+/* # line 902 "gram.in" */
+{ NOEXT("hex constant");
+		  yyval.expval = mkbitcon(4, toklen, token); } break;
+case 186:
+/* # line 905 "gram.in" */
+{ NOEXT("octal constant");
+		  yyval.expval = mkbitcon(3, toklen, token); } break;
+case 187:
+/* # line 908 "gram.in" */
+{ NOEXT("binary constant");
+		  yyval.expval = mkbitcon(1, toklen, token); } break;
+case 189:
+/* # line 914 "gram.in" */
+{ yyval.expval = yypvt[-1].expval; } break;
+case 192:
+/* # line 920 "gram.in" */
+{ yyval.expval = mkexpr(yypvt[-1].ival, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 193:
+/* # line 922 "gram.in" */
+{ yyval.expval = mkexpr(OPSTAR, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 194:
+/* # line 924 "gram.in" */
+{ yyval.expval = mkexpr(OPSLASH, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 195:
+/* # line 926 "gram.in" */
+{ yyval.expval = mkexpr(OPPOWER, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 196:
+/* # line 928 "gram.in" */
+{ if(yypvt[-1].ival == OPMINUS)
+			yyval.expval = mkexpr(OPNEG, yypvt[-0].expval, ENULL);
+		  else	yyval.expval = yypvt[-0].expval;
+		} break;
+case 197:
+/* # line 933 "gram.in" */
+{ NO66("concatenation operator //");
+		  yyval.expval = mkexpr(OPCONCAT, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 199:
+/* # line 938 "gram.in" */
+{
+		if(yypvt[-3].labval->labdefined)
+			execerr("no backward DO loops", CNULL);
+		yypvt[-3].labval->blklevel = blklevel+1;
+		exdo(yypvt[-3].labval->labelno, NPNULL, yypvt[-0].chval);
+		} break;
+case 200:
+/* # line 945 "gram.in" */
+{
+		exdo((int)(ctls - ctlstack - 2), NPNULL, yypvt[-0].chval);
+		NOEXT("DO without label");
+		} break;
+case 201:
+/* # line 950 "gram.in" */
+{ exenddo(NPNULL); } break;
+case 202:
+/* # line 952 "gram.in" */
+{ exendif();  thiswasbranch = NO; } break;
+case 204:
+/* # line 955 "gram.in" */
+{ exelif(yypvt[-2].expval); lastwasbranch = NO; } break;
+case 205:
+/* # line 957 "gram.in" */
+{ exelse(); lastwasbranch = NO; } break;
+case 206:
+/* # line 959 "gram.in" */
+{ exendif(); lastwasbranch = NO; } break;
+case 207:
+/* # line 963 "gram.in" */
+{ exif(yypvt[-1].expval); } break;
+case 208:
+/* # line 967 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-2].namval, yypvt[-0].chval); } break;
+case 210:
+/* # line 972 "gram.in" */
+{ yyval.chval = mkchain(CNULL, (chainp)yypvt[-1].expval); } break;
+case 211:
+/* # line 976 "gram.in" */
+{ exequals((struct Primblock *)yypvt[-2].expval, yypvt[-0].expval); } break;
+case 212:
+/* # line 978 "gram.in" */
+{ exassign(yypvt[-0].namval, yypvt[-2].labval); } break;
+case 215:
+/* # line 982 "gram.in" */
+{ inioctl = NO; } break;
+case 216:
+/* # line 984 "gram.in" */
+{ exarif(yypvt[-6].expval, yypvt[-4].labval, yypvt[-2].labval, yypvt[-0].labval);  thiswasbranch = YES; } break;
+case 217:
+/* # line 986 "gram.in" */
+{ excall(yypvt[-0].namval, LBNULL, 0, labarray); } break;
+case 218:
+/* # line 988 "gram.in" */
+{ excall(yypvt[-2].namval, LBNULL, 0, labarray); } break;
+case 219:
+/* # line 990 "gram.in" */
+{ if(nstars < maxlablist)
+			excall(yypvt[-3].namval, mklist(revchain(yypvt[-1].chval)), nstars, labarray);
+		  else
+			many("alternate returns", 'l', maxlablist);
+		} break;
+case 220:
+/* # line 996 "gram.in" */
+{ exreturn(yypvt[-0].expval);  thiswasbranch = YES; } break;
+case 221:
+/* # line 998 "gram.in" */
+{ exstop(yypvt[-2].ival, yypvt[-0].expval);  thiswasbranch = yypvt[-2].ival; } break;
+case 222:
+/* # line 1002 "gram.in" */
+{ yyval.labval = mklabel( convci(toklen, token) ); } break;
+case 223:
+/* # line 1006 "gram.in" */
+{ if(parstate == OUTSIDE)
+			{
+			newproc();
+			startproc(ESNULL, CLMAIN);
+			}
+		} break;
+case 224:
+/* # line 1015 "gram.in" */
+{ exgoto(yypvt[-0].labval);  thiswasbranch = YES; } break;
+case 225:
+/* # line 1017 "gram.in" */
+{ exasgoto(yypvt[-0].namval);  thiswasbranch = YES; } break;
+case 226:
+/* # line 1019 "gram.in" */
+{ exasgoto(yypvt[-4].namval);  thiswasbranch = YES; } break;
+case 227:
+/* # line 1021 "gram.in" */
+{ if(nstars < maxlablist)
+			putcmgo(putx(fixtype(yypvt[-0].expval)), nstars, labarray);
+		  else
+			many("labels in computed GOTO list", 'l', maxlablist);
+		} break;
+case 230:
+/* # line 1033 "gram.in" */
+{ nstars = 0; yyval.namval = yypvt[-0].namval; } break;
+case 231:
+/* # line 1037 "gram.in" */
+{ yyval.chval = yypvt[-0].expval ? mkchain((char *)yypvt[-0].expval,CHNULL) : CHNULL; } break;
+case 232:
+/* # line 1039 "gram.in" */
+{ yyval.chval = yypvt[-0].expval ? mkchain((char *)yypvt[-0].expval, yypvt[-2].chval) : yypvt[-2].chval; } break;
+case 234:
+/* # line 1044 "gram.in" */
+{ if(nstars < maxlablist) labarray[nstars++] = yypvt[-0].labval; yyval.expval = 0; } break;
+case 235:
+/* # line 1048 "gram.in" */
+{ yyval.ival = 0; } break;
+case 236:
+/* # line 1050 "gram.in" */
+{ yyval.ival = 2; } break;
+case 237:
+/* # line 1054 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].expval, CHNULL); } break;
+case 238:
+/* # line 1056 "gram.in" */
+{ yyval.chval = hookup(yypvt[-2].chval, mkchain((char *)yypvt[-0].expval,CHNULL) ); } break;
+case 239:
+/* # line 1060 "gram.in" */
+{ if(parstate == OUTSIDE)
+			{
+			newproc();
+			startproc(ESNULL, CLMAIN);
+			}
+
+/* This next statement depends on the ordering of the state table encoding */
+
+		  if(parstate < INDATA) enddcl();
+		} break;
+case 240:
+/* # line 1073 "gram.in" */
+{ intonly = YES; } break;
+case 241:
+/* # line 1077 "gram.in" */
+{ intonly = NO; } break;
+case 242:
+/* # line 1082 "gram.in" */
+{ endio(); } break;
+case 244:
+/* # line 1087 "gram.in" */
+{ ioclause(IOSUNIT, yypvt[-0].expval); endioctl(); } break;
+case 245:
+/* # line 1089 "gram.in" */
+{ ioclause(IOSUNIT, ENULL); endioctl(); } break;
+case 246:
+/* # line 1091 "gram.in" */
+{ ioclause(IOSUNIT, IOSTDERR); endioctl(); } break;
+case 248:
+/* # line 1094 "gram.in" */
+{ doio(CHNULL); } break;
+case 249:
+/* # line 1096 "gram.in" */
+{ doio(CHNULL); } break;
+case 250:
+/* # line 1098 "gram.in" */
+{ doio(revchain(yypvt[-0].chval)); } break;
+case 251:
+/* # line 1100 "gram.in" */
+{ doio(revchain(yypvt[-0].chval)); } break;
+case 252:
+/* # line 1102 "gram.in" */
+{ doio(revchain(yypvt[-0].chval)); } break;
+case 253:
+/* # line 1104 "gram.in" */
+{ doio(CHNULL); } break;
+case 254:
+/* # line 1106 "gram.in" */
+{ doio(revchain(yypvt[-0].chval)); } break;
+case 255:
+/* # line 1108 "gram.in" */
+{ doio(CHNULL); } break;
+case 256:
+/* # line 1110 "gram.in" */
+{ doio(revchain(yypvt[-0].chval)); } break;
+case 258:
+/* # line 1117 "gram.in" */
+{ iostmt = IOBACKSPACE; } break;
+case 259:
+/* # line 1119 "gram.in" */
+{ iostmt = IOREWIND; } break;
+case 260:
+/* # line 1121 "gram.in" */
+{ iostmt = IOENDFILE; } break;
+case 262:
+/* # line 1128 "gram.in" */
+{ iostmt = IOINQUIRE; } break;
+case 263:
+/* # line 1130 "gram.in" */
+{ iostmt = IOOPEN; } break;
+case 264:
+/* # line 1132 "gram.in" */
+{ iostmt = IOCLOSE; } break;
+case 265:
+/* # line 1136 "gram.in" */
+{
+		ioclause(IOSUNIT, ENULL);
+		ioclause(IOSFMT, yypvt[-0].expval);
+		endioctl();
+		} break;
+case 266:
+/* # line 1142 "gram.in" */
+{
+		ioclause(IOSUNIT, ENULL);
+		ioclause(IOSFMT, ENULL);
+		endioctl();
+		} break;
+case 267:
+/* # line 1150 "gram.in" */
+{
+		  ioclause(IOSUNIT, yypvt[-1].expval);
+		  endioctl();
+		} break;
+case 268:
+/* # line 1155 "gram.in" */
+{ endioctl(); } break;
+case 271:
+/* # line 1163 "gram.in" */
+{ ioclause(IOSPOSITIONAL, yypvt[-0].expval); } break;
+case 272:
+/* # line 1165 "gram.in" */
+{ ioclause(IOSPOSITIONAL, ENULL); } break;
+case 273:
+/* # line 1167 "gram.in" */
+{ ioclause(IOSPOSITIONAL, IOSTDERR); } break;
+case 274:
+/* # line 1169 "gram.in" */
+{ ioclause(yypvt[-1].ival, yypvt[-0].expval); } break;
+case 275:
+/* # line 1171 "gram.in" */
+{ ioclause(yypvt[-1].ival, ENULL); } break;
+case 276:
+/* # line 1173 "gram.in" */
+{ ioclause(yypvt[-1].ival, IOSTDERR); } break;
+case 277:
+/* # line 1177 "gram.in" */
+{ yyval.ival = iocname(); } break;
+case 278:
+/* # line 1181 "gram.in" */
+{ iostmt = IOREAD; } break;
+case 279:
+/* # line 1185 "gram.in" */
+{ iostmt = IOWRITE; } break;
+case 280:
+/* # line 1189 "gram.in" */
+{
+		iostmt = IOWRITE;
+		ioclause(IOSUNIT, ENULL);
+		ioclause(IOSFMT, yypvt[-1].expval);
+		endioctl();
+		} break;
+case 281:
+/* # line 1196 "gram.in" */
+{
+		iostmt = IOWRITE;
+		ioclause(IOSUNIT, ENULL);
+		ioclause(IOSFMT, ENULL);
+		endioctl();
+		} break;
+case 282:
+/* # line 1205 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].tagval, CHNULL); } break;
+case 283:
+/* # line 1207 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].tagval, yypvt[-2].chval); } break;
+case 284:
+/* # line 1211 "gram.in" */
+{ yyval.tagval = (tagptr) yypvt[-0].expval; } break;
+case 285:
+/* # line 1213 "gram.in" */
+{ yyval.tagval = (tagptr) mkiodo(yypvt[-1].chval,revchain(yypvt[-3].chval)); } break;
+case 286:
+/* # line 1217 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].expval, CHNULL); } break;
+case 287:
+/* # line 1219 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].tagval, CHNULL); } break;
+case 289:
+/* # line 1224 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].expval, mkchain((char *)yypvt[-2].expval, CHNULL) ); } break;
+case 290:
+/* # line 1226 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].tagval, mkchain((char *)yypvt[-2].expval, CHNULL) ); } break;
+case 291:
+/* # line 1228 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].expval, mkchain((char *)yypvt[-2].tagval, CHNULL) ); } break;
+case 292:
+/* # line 1230 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].tagval, mkchain((char *)yypvt[-2].tagval, CHNULL) ); } break;
+case 293:
+/* # line 1232 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].expval, yypvt[-2].chval); } break;
+case 294:
+/* # line 1234 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].tagval, yypvt[-2].chval); } break;
+case 295:
+/* # line 1238 "gram.in" */
+{ yyval.tagval = (tagptr) yypvt[-0].expval; } break;
+case 296:
+/* # line 1240 "gram.in" */
+{ yyval.tagval = (tagptr) yypvt[-1].expval; } break;
+case 297:
+/* # line 1242 "gram.in" */
+{ yyval.tagval = (tagptr) mkiodo(yypvt[-1].chval, mkchain((char *)yypvt[-3].expval, CHNULL) ); } break;
+case 298:
+/* # line 1244 "gram.in" */
+{ yyval.tagval = (tagptr) mkiodo(yypvt[-1].chval, mkchain((char *)yypvt[-3].tagval, CHNULL) ); } break;
+case 299:
+/* # line 1246 "gram.in" */
+{ yyval.tagval = (tagptr) mkiodo(yypvt[-1].chval, revchain(yypvt[-3].chval)); } break;
+case 300:
+/* # line 1250 "gram.in" */
+{ startioctl(); } break;
+	}
+	goto yystack;  /* stack new state and value */
+}
diff --git a/usr.bin/f2c/gram.dcl b/usr.bin/f2c/gram.dcl
new file mode 100644
index 0000000..9a25c25
--- /dev/null
+++ b/usr.bin/f2c/gram.dcl
@@ -0,0 +1,394 @@
+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; }
+	;
+
+typespec:  typename
+		{ varleng = ($1<0 || ONEOF($1,M(TYLOGICAL)|M(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);
+			}
+		}
+	;
diff --git a/usr.bin/f2c/gram.exec b/usr.bin/f2c/gram.exec
new file mode 100644
index 0000000..0dc6010
--- /dev/null
+++ b/usr.bin/f2c/gram.exec
@@ -0,0 +1,143 @@
+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
+			many("alternate returns", 'l', maxlablist);
+		}
+	| 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
+			many("labels in computed GOTO list", 'l', maxlablist);
+		}
+	;
+
+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; }
+	;
diff --git a/usr.bin/f2c/gram.expr b/usr.bin/f2c/gram.expr
new file mode 100644
index 0000000..1ef18e5
--- /dev/null
+++ b/usr.bin/f2c/gram.expr
@@ -0,0 +1,142 @@
+funarglist:
+		{ $$ = 0; }
+	| funargs
+		{ $$ = revchain($1); }
+	;
+
+funargs:  expr
+		{ $$ = mkchain((char *)$1, CHNULL); }
+	| funargs SCOMMA expr
+		{ $$ = mkchain((char *)$3, $1); }
+	;
+
+
+expr:	  uexpr
+	| SLPAR expr SRPAR	{ $$ = $2; if ($$->tag == TPRIM)
+					$$->primblock.parenused = 1; }
+	| 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); }
+	;
diff --git a/usr.bin/f2c/gram.head b/usr.bin/f2c/gram.head
new file mode 100644
index 0000000..4af7dc7
--- /dev/null
+++ b/usr.bin/f2c/gram.head
@@ -0,0 +1,300 @@
+/****************************************************************
+Copyright 1990, 1993 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];
+extern struct Labelblock **labarray;	/* Labels in an alternate
+						   return CALL */
+extern int maxlablist;
+
+/* 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;
+		}
+	;
diff --git a/usr.bin/f2c/gram.io b/usr.bin/f2c/gram.io
new file mode 100644
index 0000000..f1a6649
--- /dev/null
+++ b/usr.bin/f2c/gram.io
@@ -0,0 +1,173 @@
+  /*  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(); }
+	;
diff --git a/usr.bin/f2c/index b/usr.bin/f2c/index
new file mode 100644
index 0000000..09422b3
--- /dev/null
+++ b/usr.bin/f2c/index
@@ -0,0 +1,135 @@
+# ======  index for f2c/src ======
+
+file	f2c/src/all
+for	bundle of complete f2c source
+
+# NOTE:	"all from f2c/src" is the complete f2c source (sans libraries).
+#	The remaining files in this directory are the component modules
+#	of "all from f2c/src", so you can request just the modules that
+#	have changed since last you updated your f2c source.  You can
+#	tell what has changed by looking at the timestamps at the end
+#	of "readme from f2c".
+
+file	f2c/src/notice
+
+file	f2c/src/readme
+
+file	f2c/src/cds.c
+
+file	f2c/src/changes
+
+file	f2c/src/data.c
+
+file	f2c/src/defines.h
+
+file	f2c/src/defs.h
+
+file	f2c/src/equiv.c
+
+file	f2c/src/error.c
+
+file	f2c/src/exec.c
+
+file	f2c/src/expr.c
+
+file	f2c/src/f2c.1
+
+file	f2c/src/f2c.1t
+
+file	f2c/src/f2c.h
+
+file	f2c/src/fc
+
+file	f2c/src/format.c
+
+file	f2c/src/format.h
+
+file	f2c/src/formatdata.c
+
+file	f2c/src/ftypes.h
+
+file	f2c/src/gram.c
+
+file	f2c/src/gram.dcl
+
+file	f2c/src/gram.exec
+
+file	f2c/src/gram.expr
+
+file	f2c/src/gram.head
+
+file	f2c/src/gram.io
+
+file	f2c/src/init.c
+
+file	f2c/src/intr.c
+
+file	f2c/src/io.c
+
+file	f2c/src/iob.h
+
+file	f2c/src/lex.c
+
+file	f2c/src/machdefs.h
+
+file	f2c/src/main.c
+
+file	f2c/src/makefile
+
+file	f2c/src/malloc.c
+
+file	f2c/src/mem.c
+
+file	f2c/src/memset.c
+
+file	f2c/src/misc.c
+
+file	f2c/src/names.c
+
+file	f2c/src/names.h
+
+file	f2c/src/niceprintf.c
+
+file	f2c/src/niceprintf.h
+
+file	f2c/src/notice
+
+file	f2c/src/output.c
+
+file	f2c/src/output.h
+
+file	f2c/src/p1defs.h
+
+file	f2c/src/p1output.c
+
+file	f2c/src/parse.h
+
+file	f2c/src/parse_args.c
+
+file	f2c/src/pccdefs.h
+
+file	f2c/src/pread.c
+
+file	f2c/src/proc.c
+
+file	f2c/src/put.c
+
+file	f2c/src/putpcc.c
+
+file	f2c/src/readme
+
+file	f2c/src/sysdep.c
+
+file	f2c/src/sysdep.h
+
+file	f2c/src/tokens
+
+file	f2c/src/usignal.h
+
+file	f2c/src/vax.c
+
+file	f2c/src/version.c
+
+file	f2c/src/xsum.c
+
+file	f2c/src/xsum0.out
diff --git a/usr.bin/f2c/index.html b/usr.bin/f2c/index.html
new file mode 100644
index 0000000..f93c66c
--- /dev/null
+++ b/usr.bin/f2c/index.html
@@ -0,0 +1,142 @@
+<TITLE>f2c/src/index</TITLE><UL>
+<PRE>
+======  index for f2c/src ======
+</PRE>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/all.Z">f2c/src/all</A><MENU>
+<LI><EM>for: </EM>bundle of complete f2c source
+</MENU>
+<PRE>
+NOTE:	"all from f2c/src" is the complete f2c source (sans libraries).
+The remaining files in this directory are the component modules
+of "all from f2c/src", so you can request just the modules that
+have changed since last you updated your f2c source.  You can
+tell what has changed by looking at the timestamps at the end
+of "readme from f2c".
+</PRE>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/notice.Z">f2c/src/notice</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/readme.Z">f2c/src/readme</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/cds.c.Z">f2c/src/cds.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/changes.Z">f2c/src/changes</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/data.c.Z">f2c/src/data.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/defines.h.Z">f2c/src/defines.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/defs.h.Z">f2c/src/defs.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/equiv.c.Z">f2c/src/equiv.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/error.c.Z">f2c/src/error.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/exec.c.Z">f2c/src/exec.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/expr.c.Z">f2c/src/expr.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/f2c.1.Z">f2c/src/f2c.1</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/f2c.1t.Z">f2c/src/f2c.1t</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/f2c.h.Z">f2c/src/f2c.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/fc.Z">f2c/src/fc</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/format.c.Z">f2c/src/format.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/format.h.Z">f2c/src/format.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/formatdata.c.Z">f2c/src/formatdata.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/ftypes.h.Z">f2c/src/ftypes.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/gram.c.Z">f2c/src/gram.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/gram.dcl.Z">f2c/src/gram.dcl</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/gram.exec.Z">f2c/src/gram.exec</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/gram.expr.Z">f2c/src/gram.expr</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/gram.head.Z">f2c/src/gram.head</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/gram.io.Z">f2c/src/gram.io</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/init.c.Z">f2c/src/init.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/intr.c.Z">f2c/src/intr.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/io.c.Z">f2c/src/io.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/iob.h.Z">f2c/src/iob.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/lex.c.Z">f2c/src/lex.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/machdefs.h.Z">f2c/src/machdefs.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/main.c.Z">f2c/src/main.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/makefile.Z">f2c/src/makefile</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/malloc.c.Z">f2c/src/malloc.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/mem.c.Z">f2c/src/mem.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/memset.c.Z">f2c/src/memset.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/misc.c.Z">f2c/src/misc.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/names.c.Z">f2c/src/names.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/names.h.Z">f2c/src/names.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/niceprintf.c.Z">f2c/src/niceprintf.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/niceprintf.h.Z">f2c/src/niceprintf.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/notice.Z">f2c/src/notice</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/output.c.Z">f2c/src/output.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/output.h.Z">f2c/src/output.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/p1defs.h.Z">f2c/src/p1defs.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/p1output.c.Z">f2c/src/p1output.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/parse.h.Z">f2c/src/parse.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/parse_args.c.Z">f2c/src/parse_args.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/pccdefs.h.Z">f2c/src/pccdefs.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/pread.c.Z">f2c/src/pread.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/proc.c.Z">f2c/src/proc.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/put.c.Z">f2c/src/put.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/putpcc.c.Z">f2c/src/putpcc.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/readme.Z">f2c/src/readme</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/sysdep.c.Z">f2c/src/sysdep.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/sysdep.h.Z">f2c/src/sysdep.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/tokens.Z">f2c/src/tokens</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/usignal.h.Z">f2c/src/usignal.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/vax.c.Z">f2c/src/vax.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/version.c.Z">f2c/src/version.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/xsum.c.Z">f2c/src/xsum.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/xsum0.out.Z">f2c/src/xsum0.out</A><MENU>
+</MENU>
+<P><LI><A HREF="ftp://netlib.att.com/netlib/bib/thesaurus.Z">glossary/thesaurus of terms used in this index</A>
+</UL>
+<P><A HREF="ftp://netlib.att.com/netlib/bib/ericjack.Z">Eric and Jack</EM>
diff --git a/usr.bin/f2c/init.c b/usr.bin/f2c/init.c
new file mode 100644
index 0000000..67bcd1e
--- /dev/null
+++ b/usr.bin/f2c/init.c
@@ -0,0 +1,509 @@
+/****************************************************************
+Copyright 1990, 1992, 1993 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+2];
+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 tylog	= TYLOGICAL;
+int typesize[NTYPES] = {
+	1, SZADDR, 1, SZSHORT, SZLONG,
+#ifdef TYQUAD
+		2*SZLONG,
+#endif
+		SZLONG, 2*SZLONG,
+		2*SZLONG, 4*SZLONG, 1, SZSHORT, 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, 1, ALISHORT, ALILONG,
+#ifdef TYQUAD
+	ALIDOUBLE,
+#endif
+	ALILONG, ALIDOUBLE,
+	ALILONG, ALIDOUBLE, 1, ALISHORT, ALILONG, 1, 1, 1,
+	ALILONG, ALILONG, ALILONG, ALILONG, ALILONG, ALILONG};
+
+int type_choice[4] = { TYDREAL, TYSHORT, TYLONG,  TYSHORT };
+
+char *typename[] = {
+	"<<unknown>>",
+	"address",
+	"integer1",
+	"shortint",
+	"integer",
+#ifdef TYQUAD
+	"longint",
+#endif
+	"real",
+	"doublereal",
+	"complex",
+	"doublecomplex",
+	"logical1",
+	"shortlogical",
+	"logical",
+	"char"	/* character */
+	};
+
+int type_pref[NTYPES] = { 0, 0, 3, 5, 7,
+#ifdef TYQUAD
+			 10,
+#endif
+				8, 11, 9, 12, 1, 4, 6, 2 };
+
+char *protorettypes[] = {
+	"?", "??", "integer1", "shortint", "integer",
+#ifdef TYQUAD
+	"longint",
+#endif
+	"real", "doublereal",
+	"C_f", "Z_f", "logical1", "shortlogical", "logical", "H_f", "int"
+	};
+
+char *casttypes[TYSUBR+1] = {
+	"U_fp", "??bug??", "I1_fp",
+	"J_fp", "I_fp",
+#ifdef TYQUAD
+	"Q_fp",
+#endif
+	"R_fp", "D_fp", "C_fp", "Z_fp",
+	"L1_fp", "L2_fp", "L_fp", "H_fp", "S_fp"
+	};
+char *usedcasts[TYSUBR+1];
+
+char *dfltarg[] = {
+	0, 0, "(integer1 *)0",
+	"(shortint *)0", "(integer *)0",
+#ifdef TYQUAD
+	"(longint *)0",
+#endif
+	"(real *)0",
+	"(doublereal *)0", "(complex *)0", "(doublecomplex *)0",
+	"(logical1 *)0","(shortlogical *)0)", "(logical *)0", "(char *)0"
+	};
+
+static char *dflt0proc[] = {
+	0, 0, "(integer1 (*)())0",
+	"(shortint (*)())0", "(integer (*)())0",
+#ifdef TYQUAD
+	"(longint (*)())0",
+#endif
+	"(real (*)())0",
+	"(doublereal (*)())0", "(complex (*)())0", "(doublecomplex (*)())0",
+	"(logical1 (*)())0", "(shortlogical (*)())0",
+	"(logical (*)())0", "(char (*)())0", "(int (*)())0"
+	};
+
+char *dflt1proc[] = { "(U_fp)0", "(??bug??)0", "(I1_fp)0",
+	"(J_fp)0", "(I_fp)0",
+#ifdef TYQUAD
+	"(Q_fp)0",
+#endif
+	"(R_fp)0", "(D_fp)0", "(C_fp)0", "(Z_fp)0",
+	"(L1_fp)0","(L2_fp)0",
+	"(L_fp)0", "(H_fp)0", "(S_fp)0"
+	};
+
+char **dfltproc = dflt0proc;
+
+static char Bug[] = "bug";
+
+char *ftn_types[] = { "external", "??", "integer*1",
+	"integer*2", "integer",
+#ifdef TYQUAD
+	"integer*8",
+#endif
+	"real",
+	"double precision", "complex", "double complex",
+	"logical*1", "logical*2",
+	"logical", "character", "subroutine",
+	Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug, "ftnlen"
+	};
+
+int init_ac[TYSUBR+1] = { 0,0,0,0,0,0,0,
+#ifdef TYQUAD
+			  0,
+#endif
+			  1, 1, 0, 0, 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","i1","s","i",
+#ifdef TYQUAD
+			 "i8",
+#endif
+			"r","d","q","z","L1","L2","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;
+extern int maxlablist;
+struct Labelblock **labarray;
+
+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);
+	labarray = (struct Labelblock **)ckalloc(maxlablist*
+					sizeof(struct Labelblock *));
+	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;
+				}
+			}
+		}
+	}
diff --git a/usr.bin/f2c/intr.c b/usr.bin/f2c/intr.c
new file mode 100644
index 0000000..210047f
--- /dev/null
+++ b/usr.bin/f2c/intr.c
@@ -0,0 +1,854 @@
+/****************************************************************
+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 "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;
+		switch(rettype) {
+		  case TYLONG:
+			rettype = tyint;
+			break;
+		  case TYLOGICAL:
+			rettype = tylog;
+		  }
+		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);
+			if (q->tag == TADDR)
+				q->addrblock.parenused = 1;
+			}
+		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);
+}
diff --git a/usr.bin/f2c/io.c b/usr.bin/f2c/io.c
new file mode 100644
index 0000000..761876c
--- /dev/null
+++ b/usr.bin/f2c/io.c
@@ -0,0 +1,1420 @@
+/****************************************************************
+Copyright 1990, 1991, 1993 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 IOSUNIT 1 */
+/* #define IOSFMT 2 */
+#define IOSERR 3
+#define IOSEND 4
+#define IOSIOSTAT 5
+#define IOSREC 6
+#define IOSRECL 7
+#define IOSFILE 8
+#define IOSSTATUS 9
+#define IOSACCESS 10
+#define IOSFORM 11
+#define IOSBLANK 12
+#define IOSEXISTS 13
+#define IOSOPENED 14
+#define IOSNUMBER 15
+#define IOSNAMED 16
+#define IOSNAME 17
+#define IOSSEQUENTIAL 18
+#define IOSDIRECT 19
+#define IOSFORMATTED 20
+#define IOSUNFORMATTED 21
+#define IOSNEXTREC 22
+#define IOSNML 23
+
+#define IOSTP V(IOSIOSTAT)
+
+
+/* offsets in generated structures */
+
+#define SZFLAG SZIOINT
+
+/* offsets for external READ and WRITE statements */
+
+#define XERR 0
+#define XUNIT	SZFLAG
+#define XEND	SZFLAG + SZIOINT
+#define XFMT	2*SZFLAG + SZIOINT
+#define XREC	2*SZFLAG + SZIOINT + SZADDR
+
+/* offsets for internal READ and WRITE statements */
+
+#define XIUNIT	SZFLAG
+#define XIEND	SZFLAG + SZADDR
+#define XIFMT	2*SZFLAG + SZADDR
+#define XIRLEN	2*SZFLAG + 2*SZADDR
+#define XIRNUM	2*SZFLAG + 2*SZADDR + SZIOINT
+#define XIREC	2*SZFLAG + 2*SZADDR + 2*SZIOINT
+
+/* offsets for OPEN statements */
+
+#define XFNAME	SZFLAG + SZIOINT
+#define XFNAMELEN	SZFLAG + SZIOINT + SZADDR
+#define XSTATUS	SZFLAG + 2*SZIOINT + SZADDR
+#define XACCESS	SZFLAG + 2*SZIOINT + 2*SZADDR
+#define XFORMATTED	SZFLAG + 2*SZIOINT + 3*SZADDR
+#define XRECLEN	SZFLAG + 2*SZIOINT + 4*SZADDR
+#define XBLANK	SZFLAG + 3*SZIOINT + 4*SZADDR
+
+/* offset for CLOSE statement */
+
+#define XCLSTATUS	SZFLAG + SZIOINT
+
+/* offsets for INQUIRE statement */
+
+#define XFILE	SZFLAG + SZIOINT
+#define XFILELEN	SZFLAG + SZIOINT + SZADDR
+#define XEXISTS	SZFLAG + 2*SZIOINT + SZADDR
+#define XOPEN	SZFLAG + 2*SZIOINT + 2*SZADDR
+#define XNUMBER	SZFLAG + 2*SZIOINT + 3*SZADDR
+#define XNAMED	SZFLAG + 2*SZIOINT + 4*SZADDR
+#define XNAME	SZFLAG + 2*SZIOINT + 5*SZADDR
+#define XNAMELEN	SZFLAG + 2*SZIOINT + 6*SZADDR
+#define XQACCESS	SZFLAG + 3*SZIOINT + 6*SZADDR
+#define XQACCLEN	SZFLAG + 3*SZIOINT + 7*SZADDR
+#define XSEQ	SZFLAG + 4*SZIOINT + 7*SZADDR
+#define XSEQLEN	SZFLAG + 4*SZIOINT + 8*SZADDR
+#define XDIRECT	SZFLAG + 5*SZIOINT + 8*SZADDR
+#define XDIRLEN	SZFLAG + 5*SZIOINT + 9*SZADDR
+#define XFORM	SZFLAG + 6*SZIOINT + 9*SZADDR
+#define XFORMLEN	SZFLAG + 6*SZIOINT + 10*SZADDR
+#define XFMTED	SZFLAG + 7*SZIOINT + 10*SZADDR
+#define XFMTEDLEN	SZFLAG + 7*SZIOINT + 11*SZADDR
+#define XUNFMT	SZFLAG + 8*SZIOINT + 11*SZADDR
+#define XUNFMTLEN	SZFLAG + 8*SZIOINT + 12*SZADDR
+#define XQRECL	SZFLAG + 9*SZIOINT + 12*SZADDR
+#define XNEXTREC	SZFLAG + 9*SZIOINT + 13*SZADDR
+#define XQBLANK	SZFLAG + 9*SZIOINT + 14*SZADDR
+#define XQBLANKLEN	SZFLAG + 9*SZIOINT + 15*SZADDR
+
+LOCAL char *cilist_names[] = {
+	"cilist",
+	"cierr",
+	"ciunit",
+	"ciend",
+	"cifmt",
+	"cirec"
+	};
+LOCAL char *icilist_names[] = {
+	"icilist",
+	"icierr",
+	"iciunit",
+	"iciend",
+	"icifmt",
+	"icirlen",
+	"icirnum"
+	};
+LOCAL char *olist_names[] = {
+	"olist",
+	"oerr",
+	"ounit",
+	"ofnm",
+	"ofnmlen",
+	"osta",
+	"oacc",
+	"ofm",
+	"orl",
+	"oblnk"
+	};
+LOCAL char *cllist_names[] = {
+	"cllist",
+	"cerr",
+	"cunit",
+	"csta"
+	};
+LOCAL char *alist_names[] = {
+	"alist",
+	"aerr",
+	"aunit"
+	};
+LOCAL char *inlist_names[] = {
+	"inlist",
+	"inerr",
+	"inunit",
+	"infile",
+	"infilen",
+	"inex",
+	"inopen",
+	"innum",
+	"innamed",
+	"inname",
+	"innamlen",
+	"inacc",
+	"inacclen",
+	"inseq",
+	"inseqlen",
+	"indir",
+	"indirlen",
+	"infmt",
+	"infmtlen",
+	"inform",
+	"informlen",
+	"inunf",
+	"inunflen",
+	"inrecl",
+	"innrec",
+	"inblank",
+	"inblanklen"
+	};
+
+LOCAL char **io_fields;
+
+#define zork(n,t) n, sizeof(n)/sizeof(char *) - 1, t
+
+LOCAL io_setup io_stuff[] = {
+	zork(cilist_names, TYCILIST),	/* external read/write */
+	zork(inlist_names, TYINLIST),	/* inquire */
+	zork(olist_names,  TYOLIST),	/* open */
+	zork(cllist_names, TYCLLIST),	/* close */
+	zork(alist_names,  TYALIST),	/* rewind */
+	zork(alist_names,  TYALIST),	/* backspace */
+	zork(alist_names,  TYALIST),	/* endfile */
+	zork(icilist_names,TYICILIST),	/* internal read */
+	zork(icilist_names,TYICILIST)	/* internal write */
+	};
+
+#undef zork
+
+
+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 */
+ int typeconv[TYERROR+1] = {
+#ifdef TYQUAD
+		0, 1, 11, 2, 3, 14, 4, 5, 6, 7, 12, 13, 8, 9, 10, 15
+#else
+		0, 1, 11, 2, 3,     4, 5, 6, 7, 12, 13, 8, 9, 10, 14
+#endif
+		};
+
+ LOCAL void
+putio(nelt, addr)
+ expptr nelt;
+ register expptr addr;
+{
+	int type;
+	register expptr q;
+	register Addrp c = 0;
+
+	type = addr->headblock.vtype;
+	if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) )
+	{
+		nelt = mkexpr(OPSTAR, ICON(2), nelt);
+		type -= (TYCOMPLEX-TYREAL);
+	}
+
+	/* pass a length with every item.  for noncharacter data, fake one */
+	if(type != TYCHAR)
+	{
+
+		if( ISCONST(addr) )
+			addr = (expptr) putconst((Constp)addr);
+		c = ALLOC(Addrblock);
+		c->tag = TADDR;
+		c->vtype = TYLENG;
+		c->vstg = STGAUTO;
+		c->ntempelt = 1;
+		c->isarray = 1;
+		c->memoffset = ICON(0);
+		c->uname_tag = UNAM_IDENT;
+		c->charleng = 1;
+		sprintf(c->user.ident, "(ftnlen)sizeof(%s)", typename[type]);
+		addr = mkexpr(OPCHARCAST, addr, ENULL);
+		}
+
+	nelt = fixtype( mkconv(tyioint,nelt) );
+	if(ioformatted == LISTDIRECTED) {
+		expptr mc = mkconv(tyioint, ICON(typeconv[type]));
+		q = c	? call4(TYINT, "do_lio", mc, nelt, addr, (expptr)c)
+			: call3(TYINT, "do_lio", mc, nelt, addr);
+		}
+	else {
+		char *s = ioformatted==FORMATTED ? "do_fio" : "do_uio";
+		q = c	? call3(TYINT, s, nelt, addr, (expptr)c)
+			: call2(TYINT, s, nelt, addr);
+		}
+	iocalladdr = TYCHAR;
+	putiocall(q);
+	iocalladdr = TYADDR;
+}
+
+
+
+
+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);
+}
diff --git a/usr.bin/f2c/iob.h b/usr.bin/f2c/iob.h
new file mode 100644
index 0000000..9f2269b
--- /dev/null
+++ b/usr.bin/f2c/iob.h
@@ -0,0 +1,24 @@
+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();
diff --git a/usr.bin/f2c/lex.c b/usr.bin/f2c/lex.c
new file mode 100644
index 0000000..a9900be
--- /dev/null
+++ b/usr.bin/f2c/lex.c
@@ -0,0 +1,1577 @@
+/****************************************************************
+Copyright 1990, 1992, 1993 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"
+
+#ifdef NO_EOF_CHAR_CHECK
+#undef EOF_CHAR
+#else
+#ifndef EOF_CHAR
+#define EOF_CHAR 26	/* ASCII control-Z */
+#endif
+#endif
+
+#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;	/* Main buffer for Fortran source input. */
+LOCAL char *send;	/* Was = sbuf+20*66 with sbuf[1390]. */
+LOCAL int maxcont;
+LOCAL int nincl	= 0;	/* Current number of include files */
+LOCAL long firstline;
+LOCAL char *laststb, *stb0;
+extern int addftnsrc;
+static char **linestart;
+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;
+	char *lastslash, *s, *s0, *temp;
+	int k;
+
+	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 if(name[0] == '/' || inclp == NULL
+#ifdef MSDOS
+		|| name[0] == '\\'
+		|| name[1] == ':'
+#endif
+		)
+		fp = fopen(name, textread);
+	else {
+		lastslash = NULL;
+		s = s0 = inclp->inclname;
+#ifdef MSDOS
+		if (s[1] == ':')
+			lastslash = s + 1;
+#endif
+		for(; *s ; ++s)
+			if(*s == '/'
+#ifdef MSDOS
+			|| *s == '\\'
+#endif
+			)
+				lastslash = s;
+		if(lastslash) {
+			k = lastslash - s0 + 1;
+			temp = Alloc(k + strlen(name) + 1);
+			strncpy(temp, s0, k);
+			strcpy(temp+k, name);
+			name = temp;
+			}
+		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 char *lastfile = "??", *lastfile0 = "?";
+static char fbuf[P1_FILENAME_MAX];
+
+void p1_line_number (line_number)
+long line_number;
+{
+	if (lastfile != lastfile0) {
+		p1puts(P1_FILENAME, fbuf);
+		lastfile0 = lastfile;
+		}
+	fprintf(pass1_file, "%d: %ld\n", P1_SET_LINE, line_number);
+	}
+
+ static void
+putlineno()
+{
+	static long lastline;
+	extern int gflag;
+	register char *s0, *s1;
+
+	if (gflag) {
+		if (lastline)
+			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;
+}
+
+ LOCAL void
+contmax()
+{
+	lineno = thislin;
+	many("continuation lines", 'C', maxcontin);
+	}
+
+/* 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;
+	for(;;) {
+		nextcd = endcd;
+		if (ncont >= maxcont || nextcd+66 > send)
+			contmax();
+		linestart[ncont++] = nextcd;
+		if ((code = getcd(nextcd,0)) != STCONTINUE)
+			break;
+		if (ncont == 20 && noextflag) {
+			lineno = thislin;
+			errext("more than 19 continuation lines");
+			}
+		}
+	nextch = sbuf;
+	lastch = nextcd - 1;
+
+	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;
+	long L;
+
+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)
+#ifdef EOF_CHAR
+			 || c == EOF_CHAR
+#endif
+					)
+		    return STEOF;
+
+		if (c == '#') {
+			*endcd++ = c;
+			while((c = getc(infile)) != '\n')
+				if (c == EOF)
+					return STEOF;
+				else if (endcd < bend)
+					*endcd++ = c;
+			++thislin;
+			*endcd = 0;
+			if (b[1] == ' ')
+				p = b + 2;
+			else if (!strncmp(b,"#line ",6))
+				p = b + 6;
+			else {
+ bad_cpp:
+				errstr("Bad # line: \"%s\"", b);
+				goto top;
+				}
+			if (*p < '1' || *p > '9')
+				goto bad_cpp;
+			L = *p - '1';	/* bias down 1 */
+			while((c = *++p) >= '0' && c <= '9')
+				L = 10*L + c - '0';
+			if (c != ' ' || *++p != '"')
+				goto bad_cpp;
+			bend = p;
+			while(*++p != '"')
+				if (!*p)
+					goto bad_cpp;
+			*p = 0;
+			i = p - bend++;
+			thislin = L;
+			if (!infname || strcmp(infname, bend)) {
+				if (infname)
+					free(infname);
+				infname = Alloc(i);
+				strcpy(infname, bend);
+				if (inclp)
+					inclp->inclname = infname;
+				}
+			goto top;
+			}
+
+		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 >= maxcont)
+					contmax();
+			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 < MAXTOKENLEN)
+				    *++j = *i;
+				else if (len == MAXTOKENLEN)
+				    erri
+	    ("String too long, truncating to %d chars", MAXTOKENLEN);
+				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 > MAXTOKENLEN)
+			{
+				erri("%dH too big", nh);
+				nh = lastch - i;
+				if (nh > MAXTOKENLEN)
+					nh = MAXTOKENLEN;
+				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;
+		}
+	i = (maxcontin + 2) * 66;
+	sbuf = (char *)ckalloc(i + 70);
+	send = sbuf + i;
+	maxcont = maxcontin + 1;
+	linestart = (char **)ckalloc(maxcont*sizeof(char*));
+	comstart['c'] = comstart['C'] = comstart['*'] = comstart['!'] =
+	comstart['#'] = 1;
+#ifdef EOF_CHAR
+	comstart[EOF_CHAR] = 1;
+#endif
+	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 < lastch
+		||  nextch[2] == '#' && isdigit(nextch[1]
+				     && lastch - nextch >= 2)) {
+
+		    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);
+	}
diff --git a/usr.bin/f2c/machdefs.h b/usr.bin/f2c/machdefs.h
new file mode 100644
index 0000000..3ab8961
--- /dev/null
+++ b/usr.bin/f2c/machdefs.h
@@ -0,0 +1,31 @@
+#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 */
diff --git a/usr.bin/f2c/main.c b/usr.bin/f2c/main.c
new file mode 100644
index 0000000..a4bb2cd
--- /dev/null
+++ b/usr.bin/f2c/main.c
@@ -0,0 +1,611 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 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;
+flag keepsubs = NO;
+#ifdef TYQUAD
+flag use_tyquad = YES;
+#endif
+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 maxcontin = MAXCONTIN;
+int maxlablist = MAXLABLIST;
+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 Castargs1;
+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 ("NC", P_ONE_ARG, P_INT, &maxcontin, 0),
+    f2c_entry ("Nl", P_ONE_ARG, P_INT, &maxlablist, 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),
+    f2c_entry ("s", P_NO_ARGS, P_INT, &keepsubs, 1),
+#ifdef TYQUAD
+    f2c_entry ("!i8", P_NO_ARGS, P_INT, &use_tyquad, NO),
+#endif
+
+	/* 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[TYINT1] = typesize[TYLOGICAL1] = 1;
+	typesize[TYDREAL] = typesize[TYCOMPLEX] = chars_per_wd << 1;
+	typesize[TYDCOMPLEX] = chars_per_wd << 2;
+	typesize[TYSHORT] = typesize[TYLOGICAL2] = 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;
+		tylog = TYLOGICAL2;
+		}
+	}
+    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 (Castargs1 < 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;
+	Castargs1 = Castargs;
+	if (!Ansi) {
+		Castargs = 0;
+		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 (Castargs1 >= 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 (Castargs1 >= 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 (Castargs1 >= 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 %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);
+}
diff --git a/usr.bin/f2c/makefile b/usr.bin/f2c/makefile
new file mode 100644
index 0000000..d15fe2a
--- /dev/null
+++ b/usr.bin/f2c/makefile
@@ -0,0 +1,90 @@
+#	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
+
+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
+
+#On non-Unix systems that end lines with carriage-return/newline pairs,
+#use "make xsumr.out" rather than "make xsum.out".  The -r flag ignores
+#carriage-return characters.
+xsumr.out: xsum
+	./xsum -r $b >xsum1.out
+	cmp xsum0.out xsum1.out && mv xsum1.out xsumr.out
diff --git a/usr.bin/f2c/malloc.c b/usr.bin/f2c/malloc.c
new file mode 100644
index 0000000..e4414da
--- /dev/null
+++ b/usr.bin/f2c/malloc.c
@@ -0,0 +1,142 @@
+/****************************************************************
+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
diff --git a/usr.bin/f2c/mem.c b/usr.bin/f2c/mem.c
new file mode 100644
index 0000000..940e9c1
--- /dev/null
+++ b/usr.bin/f2c/mem.c
@@ -0,0 +1,234 @@
+/****************************************************************
+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;
+	extern int in_define;
+
+	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);
+	in_define = 1;
+	nice_printf(outfile, "#define %s", d->defname);
+	if (post)
+		nice_printf(outfile, " %s", 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");
+		}
+	}
diff --git a/usr.bin/f2c/memset.c b/usr.bin/f2c/memset.c
new file mode 100644
index 0000000..98a7ce7
--- /dev/null
+++ b/usr.bin/f2c/memset.c
@@ -0,0 +1,66 @@
+/****************************************************************
+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;
+	}
diff --git a/usr.bin/f2c/misc.c b/usr.bin/f2c/misc.c
new file mode 100644
index 0000000..d8ad3cf
--- /dev/null
+++ b/usr.bin/f2c/misc.c
@@ -0,0 +1,1054 @@
+/****************************************************************
+Copyright 1990, 1992, 1993 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 = 2;
+		}
+	if (!i && in_vector(s0,c_keywords,n_keywords) >= 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) {
+		do *t++ = '_';
+			while(--i > 0);
+		*t = 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 TYINT1:
+        case TYSHORT:
+	case TYLONG:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+	    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 TYINT1:
+	case TYSHORT:
+	case TYLONG:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+	    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 TYLOGICAL1:
+	case TYLOGICAL2:
+	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 */
+
+
+/* in_vector -- verifies whether   str   is in c_keywords.
+   If so, the index is returned else  -1  is returned.
+   c_keywords must be in alphabetical order (as defined by strcmp).
+*/
+
+int in_vector(str, keywds, n)
+char *str; char **keywds; register int n;
+{
+	register char **K = keywds;
+	register int n1, t;
+
+	do {
+		n1 = n >> 1;
+		if (!(t = strcmp(str, K[n1])))
+			return K - keywds + n1;
+		if (t < 0)
+			n = n1;
+		else {
+			n -= ++n1;
+			K += n1;
+			}
+		}
+		while(n > 0);
+
+	return -1;
+	} /* in_vector */
+
+
+int is_negatable (Const)
+Constp Const;
+{
+    int retval = 0;
+    if (Const != (Constp) NULL)
+	switch (Const -> vtype) {
+	    case TYINT1:
+		retval = Const -> Const.ci >= -BIGGEST_CHAR;
+		break;
+	    case TYSHORT:
+	        retval = Const -> Const.ci >= -BIGGEST_SHORT;
+	        break;
+	    case TYLONG:
+#ifdef TYQUAD
+	    case TYQUAD:
+#endif
+	        retval = Const -> Const.ci >= -BIGGEST_LONG;
+	        break;
+	    case TYREAL:
+	    case TYDREAL:
+	    case TYCOMPLEX:
+	    case TYDCOMPLEX:
+	        retval = 1;
+	        break;
+	    case TYLOGICAL1:
+	    case TYLOGICAL2:
+	    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 */
diff --git a/usr.bin/f2c/names.c b/usr.bin/f2c/names.c
new file mode 100644
index 0000000..e826f3e
--- /dev/null
+++ b/usr.bin/f2c/names.c
@@ -0,0 +1,742 @@
+/****************************************************************
+Copyright 1990, 1992, 1993 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 TYREAL:	if (!is_extern || !forcedouble)
+				{ strcpy (buff, "real");break; }
+	case TYDREAL:	strcpy (buff, "doublereal");	break;
+	case TYCOMPLEX:	if (is_extern)
+			    strcpy (buff, "/* Complex */ VOID");
+			else
+			    strcpy (buff, "complex");
+			break;
+	case TYDCOMPLEX:if (is_extern)
+			    strcpy (buff, "/* Double Complex */ VOID");
+			else
+			    strcpy (buff, "doublecomplex");
+			break;
+	case TYADDR:
+	case TYINT1:
+	case TYSHORT:
+	case TYLONG:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+	case TYLOGICAL1:
+	case TYLOGICAL2:
+	case TYLOGICAL:	strcpy(buff, typename[type]);
+			break;
+	case TYCHAR:	if (is_extern)
+			    strcpy (buff, "/* Character */ VOID");
+			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];
+	ftnint val;
+
+	if (litp == (struct Literal *) NULL)
+		return NULL;
+
+	switch (litp -> littype) {
+	case TYINT1:
+		val = litp -> litval.litival;
+		if (val >= 256 || val < -255)
+			sprintf (buf, "c_b%d", litp -> litnum);
+		else if (val < 0)
+			sprintf (buf, "ci1_n%ld", -val);
+		else
+			sprintf(buf, "ci1__%ld", val);
+        case TYSHORT:
+		val = litp -> litval.litival;
+		if (val >= 32768 || val <= -32769)
+			sprintf (buf, "c_b%d", litp -> litnum);
+		else if (val < 0)
+			sprintf (buf, "cs_n%ld", -val);
+		else
+			sprintf (buf, "cs__%ld", val);
+		break;
+	case TYLONG:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+		val = litp -> litval.litival;
+		if (val >= 100000 || val <= -10000)
+			sprintf (buf, "c_b%d", litp -> litnum);
+		else if (val < 0)
+			sprintf (buf, "c_n%ld", -val);
+		else
+			sprintf (buf, "c__%ld", val);
+		break;
+	case TYLOGICAL1:
+	case TYLOGICAL2:
+	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);
+    } /* 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];
+		if (y = x % hsize)
+			x += y = hsize - y;
+		nice_printf(outfile,
+			"static struct { %s fill; char val[%ld+1];", halign, x);
+		nice_printf(outfile, " char fill2[%ld];", hsize - 1);
+		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] + y;
+		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";
+	if (type == TYCHAR)
+		v->vleng = ICON(1);
+	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",
+	"integer1", "log", "logical", "logical1", "long", "longint",
+	"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 *);
+
+char *st_fields[] = {
+	"addr", "aerr", "aunit", "c", "cerr", "ciend", "cierr",
+	"cifmt", "cirec", "ciunit", "csta", "cunit", "d", "dims",
+	"h", "i", "iciend", "icierr", "icifmt", "icirlen",
+	"icirnum", "iciunit", "inacc", "inacclen", "inblank",
+	"inblanklen", "indir", "indirlen", "inerr", "inex",
+	"infile", "infilen", "infmt", "infmtlen", "inform",
+	"informlen", "inname", "innamed", "innamlen", "innrec",
+	"innum", "inopen", "inrecl", "inseq", "inseqlen", "inunf",
+	"inunflen", "inunit", "name", "nvars", "oacc", "oblnk",
+	"oerr", "ofm", "ofnm", "ofnmlen", "orl", "osta", "ounit",
+	"r", "type", "vars", "z"
+	};
+int n_st_fields = sizeof(st_fields)/sizeof(char *);
diff --git a/usr.bin/f2c/names.h b/usr.bin/f2c/names.h
new file mode 100644
index 0000000..1ca17d0
--- /dev/null
+++ b/usr.bin/f2c/names.h
@@ -0,0 +1,22 @@
+#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 * */);
diff --git a/usr.bin/f2c/niceprintf.c b/usr.bin/f2c/niceprintf.c
new file mode 100644
index 0000000..3c6cb3a
--- /dev/null
+++ b/usr.bin/f2c/niceprintf.c
@@ -0,0 +1,388 @@
+/****************************************************************
+Copyright 1990, 1991, 1993 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;
+int in_define = 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, infname ? infname : file_name);
+    if (in_define == 1) {
+	in_define = 2;
+	use_indent = 0;
+	}
+    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) {
+			if (isntident(*(unsigned char *)pointer))
+				word_start = NULL;
+			}
+		    else if (isident(*(unsigned char *)pointer))
+			word_start = pointer;
+		    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 (*pointer == '\n')
+		in_define = 0;
+	    else if (word_start && 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) {
+#ifndef ANSI_Libraries
+		extern char *strchr();
+#endif
+		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 {
+			if (word_start)
+				while(isident(*(unsigned char *)pointer))
+					pointer++;
+			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 {
+			if (in_define)
+				putc('\\', fp);
+			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 */
diff --git a/usr.bin/f2c/niceprintf.h b/usr.bin/f2c/niceprintf.h
new file mode 100644
index 0000000..24c65d4
--- /dev/null
+++ b/usr.bin/f2c/niceprintf.h
@@ -0,0 +1,16 @@
+/* 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)
+
+
+
diff --git a/usr.bin/f2c/notice b/usr.bin/f2c/notice
new file mode 100644
index 0000000..64af9f1
--- /dev/null
+++ b/usr.bin/f2c/notice
@@ -0,0 +1,23 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 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.
+****************************************************************/
+
diff --git a/usr.bin/f2c/output.c b/usr.bin/f2c/output.c
new file mode 100644
index 0000000..6d5bdd4
--- /dev/null
+++ b/usr.bin/f2c/output.c
@@ -0,0 +1,1495 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 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_REF:
+	    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 TYINT1:
+        case TYSHORT:
+	    nice_printf (fp, "%ld", cp->Const.ci);	/* don't cast ci! */
+	    break;
+	case TYLONG:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+	    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 TYLOGICAL1:
+	case TYLOGICAL2:
+	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
+
+ static void
+out_args(fp, ep) FILE *fp; expptr ep;
+{
+	chainp arglist;
+
+	if(ep->tag != TLIST)
+		badtag("out_args", ep->tag);
+	for(arglist = ep->listblock.listp;;) {
+		expr_out(fp, (expptr)arglist->datap);
+		arglist->datap = 0;
+		if (!(arglist = arglist->nextp))
+			break;
+		nice_printf(fp, ", ");
+		}
+	}
+
+
+/* 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_REF:
+		nice_printf(fp, "%s_%s(", addrp->user.name->cvarname,
+			addrp->cmplx_sub ? "subscr" : "ref");
+		out_args(fp, addrp->memoffset);
+		nice_printf(fp, ")");
+		return;
+	    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
+		&& !addrp->skip_offset)
+	    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 (lt == 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:
+					if (halign && e->vtype != TYCHAR) {
+						nice_printf(fp, "*(%s *)",
+						    c_type_decl(e->vtype,0));
+						expr_out(fp, lp);
+						return 1;
+						}
+					cp = findconst(lp->addrblock.memno);
+					goto tconst1;
+				    case STGCONST:
+					goto tconst;
+				    }
+				lp->addrblock.vtype = tyint;
+				Offset = lp->addrblock.memoffset;
+				switch(lp->addrblock.uname_tag) {
+				  case UNAM_REF:
+					nice_printf(fp, "*");
+					return 0;
+				  case 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 (np->tag == TNAME && (at = np->arginfo)) {
+	if (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)
+			 && (q->tag != TADDR
+				|| q->addrblock.uname_tag != UNAM_NAME
+				|| q->addrblock.user.name->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 */
diff --git a/usr.bin/f2c/output.h b/usr.bin/f2c/output.h
new file mode 100644
index 0000000..2bc21da
--- /dev/null
+++ b/usr.bin/f2c/output.h
@@ -0,0 +1,65 @@
+/* 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 ();
diff --git a/usr.bin/f2c/p1defs.h b/usr.bin/f2c/p1defs.h
new file mode 100644
index 0000000..16bda0e
--- /dev/null
+++ b/usr.bin/f2c/p1defs.h
@@ -0,0 +1,160 @@
+#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
+
+*/
diff --git a/usr.bin/f2c/p1output.c b/usr.bin/f2c/p1output.c
new file mode 100644
index 0000000..d4419b5
--- /dev/null
+++ b/usr.bin/f2c/p1output.c
@@ -0,0 +1,567 @@
+/****************************************************************
+Copyright 1990, 1991, 1993 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 */
+
+/* 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 TYINT1:
+        case TYSHORT:
+	case TYLONG:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+	case TYLOGICAL:
+	case TYLOGICAL1:
+	case TYLOGICAL2:
+	    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 */
diff --git a/usr.bin/f2c/parse.h b/usr.bin/f2c/parse.h
new file mode 100644
index 0000000..1eb2c54
--- /dev/null
+++ b/usr.bin/f2c/parse.h
@@ -0,0 +1,39 @@
+#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
diff --git a/usr.bin/f2c/parse_args.c b/usr.bin/f2c/parse_args.c
new file mode 100644
index 0000000..8325ae8
--- /dev/null
+++ b/usr.bin/f2c/parse_args.c
@@ -0,0 +1,501 @@
+/****************************************************************
+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 = "";
+
+#ifndef atol
+extern long atol();
+#endif
+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 */
+
diff --git a/usr.bin/f2c/pccdefs.h b/usr.bin/f2c/pccdefs.h
new file mode 100644
index 0000000..bde8117
--- /dev/null
+++ b/usr.bin/f2c/pccdefs.h
@@ -0,0 +1,64 @@
+/* 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
diff --git a/usr.bin/f2c/permission b/usr.bin/f2c/permission
new file mode 100644
index 0000000..20d431e
--- /dev/null
+++ b/usr.bin/f2c/permission
@@ -0,0 +1,41 @@
+From ches Tue Mar  6 09:06:22 EST 1990
+It think it probably is.  I am told the line is 89% utilized.  But the throughpu
+t
+is shared, so I wouldn't worry about it.
+>From ehg Tue Mar  6 08:16 EST 1990
+Received: by coma; Tue Mar  6 08:17:21 1990
+From: pyxis!ehg
+Date: Tue, 6 Mar 90 08:16 EST
+To: coma!ches
+
+Thanks.  Is it reasonable for people to ask for the 600KB f2c source over
+uunet's dedicated line?    I'm just trying to find out if there's a problem
+before there's a disaster.
+>From ches Tue Mar  6 07:16:18 EST 1990
+Inet has no dialers.  All its calls go through the internet.  The mcsun addresse
+s
+were uunet.uu.net!mcsun!..., which will travel to uunet via Internet and
+then across the ocean on uunet's dedicated line.
+/****************************************************************
+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.
+****************************************************************/
+
diff --git a/usr.bin/f2c/pread.c b/usr.bin/f2c/pread.c
new file mode 100644
index 0000000..15d8b30
--- /dev/null
+++ b/usr.bin/f2c/pread.c
@@ -0,0 +1,908 @@
+/****************************************************************
+Copyright 1990, 1992, 1993 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++;
+	}
+
+#if 0
+ 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");
+			}
+		}
+	}
+#else
+#define checklogical(n) /* */
+#endif
+
+ 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;
+			if (!strcmp(Ptok+1, "nteger1"))
+				return TYINT1;
+			break;
+		case 'l':
+			if (!strcmp(Ptok+1, "ogical")) {
+				checklogical(1);
+				return TYLOGICAL;
+				}
+			if (!strcmp(Ptok+1, "ogical1"))
+				return TYLOGICAL1;
+#ifdef TYQUAD
+			if (!strcmp(Ptok+1, "ongint"))
+				return TYQUAD;
+#endif
+			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 TYLOGICAL2;
+				}
+			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;
+			else if (!strcmp(Ptok+1, "1_fp"))
+				rv = TYINT1+200;
+#ifdef TYQUAD
+			else if (!strcmp(Ptok+1, "8_fp"))
+				rv = TYQUAD+200;
+#endif
+			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;
+			else if (!strcmp(Ptok+1, "1_fp"))
+				rv = TYLOGICAL1+200;
+			else if (!strcmp(Ptok+1, "2_fp"))
+				rv = TYLOGICAL2+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;
+				}
+			else if (!strcmp(Ptok+1, "ogical1"))
+				rv = TYLOGICAL1;
+			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);
+	}
diff --git a/usr.bin/f2c/proc.c b/usr.bin/f2c/proc.c
new file mode 100644
index 0000000..ca3043e
--- /dev/null
+++ b/usr.bin/f2c/proc.c
@@ -0,0 +1,1602 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 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[] = { "g", "h", "i",
+#ifdef TYQUAD
+					"j",
+#endif
+					"r", "d", "c", "z", "g", "h", "i" };
+
+ chainp new_procs;
+ int prev_proc, proc_argchanges, proc_protochanges;
+
+ 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 = TYINT1; i <= TYLOGICAL; i++)
+		if (a = xretslot[i])
+			sprintf(a->user.ident, "(*ret_val).%s",
+				postfix[i-TYINT1]);
+
+	do {
+		np = e->enamep;
+		switch(np->vtype) {
+			case TYINT1:
+			case TYSHORT:
+			case TYLONG:
+#ifdef TYQUAD
+			case TYQUAD:
+#endif
+			case TYREAL:
+			case TYDREAL:
+			case TYCOMPLEX:
+			case TYDCOMPLEX:
+			case TYLOGICAL1:
+			case TYLOGICAL2:
+			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;\n");
+			else if (type == TYDCOMPLEX)
+				nice_printf(outfile,
+		    "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\n");
+			else if (type <= TYLOGICAL)
+				nice_printf(outfile, "return ret_val.%s;\n",
+					postfix[type-TYINT1]);
+			}
+		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);
+		}
+	p1_line_number(lineno); /* for files that start with a MAIN program */
+				/* that starts with an executable statement */
+}
+
+/* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
+
+/* Main program or Block data */
+
+startproc(progname, class)
+Extsym * progname;
+int class;
+{
+	register struct Entrypoint *p;
+
+	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 TYINT1:
+	case TYADDR:
+	case TYSHORT:
+	case TYLONG:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+	case TYREAL:
+	case TYDREAL:
+	case TYLOGICAL1:
+	case TYLOGICAL2:
+		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;
+{ return(lastargslot++); }
+
+ 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 TYINT1:
+	case TYSHORT:
+	case TYDREAL:
+	case TYDCOMPLEX:
+	case TYCHAR:
+	case TYLOGICAL1:
+	case TYLOGICAL2:
+	case TYUNKNOWN:
+	case TYSUBR:
+	case TYERROR:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+		goto ret;
+
+	case TYLOGICAL:
+		switch(length) {
+			case 0: return tylog;
+			case 1:	return TYLOGICAL1;
+			case 2: return TYLOGICAL2;
+			case 4: goto ret;
+			}
+#if 0 /*!!??!!*/
+		if(length == typesize[TYLOGICAL])
+			goto ret;
+#endif
+		break;
+
+	case TYLONG:
+		if(length == 0)
+			return(tyint);
+		if (length == 1)
+			return TYINT1;
+		if(length == typesize[TYSHORT])
+			return(TYSHORT);
+#ifdef TYQUAD
+		if(length == typesize[TYQUAD] && use_tyquad)
+			return(TYQUAD);
+#endif
+		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 */
diff --git a/usr.bin/f2c/put.c b/usr.bin/f2c/put.c
new file mode 100644
index 0000000..cbe0b4a
--- /dev/null
+++ b/usr.bin/f2c/put.c
@@ -0,0 +1,399 @@
+/****************************************************************
+Copyright 1990, 1991, 1993 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 */
+};
+
+
+setlog()
+{
+	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->tag == TADDR
+	 && 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));
+
+	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->tag == TADDR && 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 TYLOGICAL1:
+	case TYLOGICAL2:
+	case TYLOGICAL:
+		type = tylogical;
+		goto lit_int_flavor;
+	case TYLONG:
+		type = tyint;
+	case TYSHORT:
+	case TYINT1:
+#ifdef TYQUAD
+	case TYQUAD:
+#endif
+ 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);
+					q->user.Const.ccp1.ccp0 = litp->cds[0];
+					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 );
+}
diff --git a/usr.bin/f2c/putpcc.c b/usr.bin/f2c/putpcc.c
new file mode 100644
index 0000000..d96e5e2
--- /dev/null
+++ b/usr.bin/f2c/putpcc.c
@@ -0,0 +1,1843 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 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 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( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype )) )
+	{
+		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 TYLOGICAL1:
+		case TYLOGICAL2:
+		case TYLOGICAL:
+#ifdef TYQUAD
+		case TYQUAD:
+#endif
+		case TYLONG:
+		case TYSHORT:
+		case TYINT1:
+			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, tskludge;
+	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;
+		ts = tskludge = 0;
+		if (q = resp->memoffset) {
+			if (resp->uname_tag == UNAM_REF) {
+				q = cpexpr((tagptr)resp);
+				q->addrblock.vtype = tyint;
+				q->addrblock.cmplx_sub = 1;
+				p->addrblock.skip_offset = 1;
+				resp->user.name->vsubscrused = 1;
+				resp->uname_tag = UNAM_NAME;
+				tskludge = typesize[resp->vtype]
+					* (resp->Field ? 2 : 1);
+				}
+			else if (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));
+				}
+			}
+		resp = mktmp(tyint, ENULL);
+		putout(putassign(cpexpr((expptr)resp), q));
+		p->addrblock.memoffset = tskludge
+			? mkexpr(OPSTAR, (expptr)resp, ICON(tskludge))
+			: (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 );
+	if (ISCONST(q))
+		return q;
+	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 = TYCHAR;
+			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 = TYCHAR;
+		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 = TYCHAR;
+		}
+	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[TYADDR]));
+		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;
+	chainp cp;
+
+	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)
+		if (p->uname_tag == UNAM_REF) {
+			cp = p->memoffset->listblock.listp;
+			for(; cp; cp = cp->nextp)
+				cp->datap = (char *)fixtype((tagptr)cp->datap);
+			}
+		else
+			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, nbad, *t, *te;
+	Atype *atypes;
+	expptr q;
+	char buf[208], buf1[32], buf2[32];
+	static int initargs[4] = {TYCOMPLEX, TYDCOMPLEX, TYCHAR, TYFTNLEN+100};
+	static int *init_ap[TYSUBR+1] = {0,0,0,0,0,0,0,
+#ifdef TYQUAD
+							0,
+#endif
+				initargs, initargs+1,0,0,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(nbad = 0; t < te; atypes++) {
+			if (++i > nargs) {
+ toomany:
+				i = nchargs + i0;
+				for(cp = arglist; cp; cp = cp->nextp)
+					i++;
+ toofew:
+				switch(zap) {
+					case 2:	zap = 6; break;
+					case 1:	if (at->defined & 4)
+							return;
+					}
+				sprintf(buf,
+		"%s%.90s:\n\there %d, previously %d args and string lengths.",
+					inconsist, fname, i, nargs);
+				atype_squawk(at, buf);
+				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) {
+					if (k == TYUNKNOWN
+					 && q->tag == TNAME
+					 && q->nameblock.vinfproc) {
+						q->nameblock.vdcldone = 0;
+						impldcl((Namep)q);
+						}
+					goto badtypes;
+					}
+				else ; /* fall through to update */
+			else if (k == TYUNKNOWN+200)
+				continue;
+			else if (j != TYUNKNOWN+200)
+				{
+ badtypes:
+				if (++nbad == 1)
+					bad_atypes(at, fname, i, j, k, "here ",
+						", previously");
+				else
+					fprintf(stderr,
+					 "\targ %d: here %s, previously %s.\n",
+						i, Argtype(k,buf1),
+						Argtype(j,buf2));
+				continue;
+				}
+			/* 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
+			 */
+			if (!nbad) {
+				atypes->type = k;
+				at->changes |= 1;
+				}
+			}
+		if (i < nargs)
+			goto toofew;
+		if (nbad) {
+			if (type) {
+				/* we're defining the procedure */
+				t = init_ap[type];
+				te = t + i0;
+				proc_argchanges = 1;
+				goto newlist;
+				}
+			return;
+			}
+		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 & 6;
+	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 */
+    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) ) {
+		if (q->addrblock.parenused
+		 && !byvalue && q->headblock.vtype != TYCHAR)
+			goto make_copy;
+		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 */
+ make_copy:
+		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;
+		}
+	p1put(P1_WHILE1START);
+	where = ftell(pass1_file);
+	if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype)))
+		{
+		if(k != TYERROR)
+			err("non-logical expression in DO WHILE statement");
+		}
+	else	{
+		p = putx(p);
+		*wh_next++ = ftell(pass1_file) > where;
+		p1put(P1_WHILE2START);
+		p1_expr(p);
+		}
+	}
diff --git a/usr.bin/f2c/readme b/usr.bin/f2c/readme
new file mode 100644
index 0000000..ed88aaa
--- /dev/null
+++ b/usr.bin/f2c/readme
@@ -0,0 +1,94 @@
+Type "make" to check the validity of the f2c source and compile f2c.
+
+On a PC, you may need to compile xsum.c with -DMSDOS (i.e., with
+MSDOS #defined).  If your system does not understand ANSI/ISO C
+syntax (i.e., if you have a K&R C compiler), compile xsum.c with
+-DKR_headers.  (Eventually this will also be required of the f2c
+source proper.)
+
+On non-Unix systems where files have separate binary and text modes,
+you may need to "make xsumr.out" rather than "make xsum.out".
+
+If (in accordance with what follows) you need to modify the makefile
+or any of the source files, first issue a "make xsum.out" (or, if
+appropriate, "make xsumr.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.
+
+For convenience with systems that use control-Z to denote end-of-file,
+f2c treats control-Z characters (ASCII 26, '\x1a') that appear at the
+beginning of a line as an end-of-file indicator.  You can disable this
+test by compiling lex.c with NO_EOF_CHAR_CHECK #defined, or can
+change control-Z to some other character by #defining EOF_CHAR to
+be the desired value.
+
+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.
diff --git a/usr.bin/f2c/sysdep.c b/usr.bin/f2c/sysdep.c
new file mode 100644
index 0000000..81bc5af
--- /dev/null
+++ b/usr.bin/f2c/sysdep.c
@@ -0,0 +1,442 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 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[]		= "-lf2c -lm"; /* was "-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
diff --git a/usr.bin/f2c/sysdep.h b/usr.bin/f2c/sysdep.h
new file mode 100644
index 0000000..aef7335
--- /dev/null
+++ b/usr.bin/f2c/sysdep.h
@@ -0,0 +1,101 @@
+/****************************************************************
+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) */
diff --git a/usr.bin/f2c/tokens b/usr.bin/f2c/tokens
new file mode 100644
index 0000000..d97fb52
--- /dev/null
+++ b/usr.bin/f2c/tokens
@@ -0,0 +1,99 @@
+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
diff --git a/usr.bin/f2c/usignal.h b/usr.bin/f2c/usignal.h
new file mode 100644
index 0000000..ba4ee6a
--- /dev/null
+++ b/usr.bin/f2c/usignal.h
@@ -0,0 +1,7 @@
+#include <signal.h>
+#ifndef SIGHUP
+#define	SIGHUP	1	/* hangup */
+#endif
+#ifndef SIGQUIT
+#define	SIGQUIT	3	/* quit */
+#endif
diff --git a/usr.bin/f2c/vax.c b/usr.bin/f2c/vax.c
new file mode 100644
index 0000000..e5a6572
--- /dev/null
+++ b/usr.bin/f2c/vax.c
@@ -0,0 +1,503 @@
+/****************************************************************
+Copyright 1990, 1992, 1993 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;
+	}
+
+ static int nu, *refs, *used;
+ static void awalk();
+
+ static void
+aawalk(P)
+ struct Primblock *P;
+{
+	chainp p;
+	expptr q;
+
+	for(p = P->argsp->listp; p; p = p->nextp) {
+		q = (expptr)p->datap;
+		if (q->tag != TCONST)
+			awalk(q);
+		}
+	if (P->namep->vtype == TYCHAR) {
+		if (q = P->fcharp)
+			awalk(q);
+		if (q = P->lcharp)
+			awalk(q);
+		}
+	}
+
+ static void
+afwalk(P)
+ struct Primblock *P;
+{
+	chainp p;
+	expptr q;
+	Namep np;
+
+	for(p = P->argsp->listp; p; p = p->nextp) {
+		q = (expptr)p->datap;
+		switch(q->tag) {
+		  case TPRIM:
+			np = q->primblock.namep;
+			if (np->vknownarg)
+				if (!refs[np->argno]++)
+					used[nu++] = np->argno;
+			if (q->primblock.argsp == 0) {
+				if (q->primblock.namep->vclass == CLPROC
+				 && q->primblock.namep->vprocclass
+						!= PTHISPROC
+				 || q->primblock.namep->vdim != NULL)
+					continue;
+				}
+		  default:
+			awalk(q);
+			/* no break */
+		  case TCONST:
+			continue;
+		  }
+		}
+	}
+
+ static void
+awalk(e)
+ expptr e;
+{
+	Namep np;
+ top:
+	if (!e)
+		return;
+	switch(e->tag) {
+	  default:
+		badtag("awalk", e);
+	  case TCONST:
+	  case TERROR:
+	  case TLIST:
+		return;
+	  case TADDR:
+		if (e->addrblock.uname_tag == UNAM_NAME) {
+			np = e->addrblock.user.name;
+			if (np->vknownarg && !refs[np->argno]++)
+				used[nu++] = np->argno;
+			}
+		e = e->addrblock.memoffset;
+		goto top;
+	  case TPRIM:
+		np = e->primblock.namep;
+		if (np->vknownarg && !refs[np->argno]++)
+			used[nu++] = np->argno;
+		if (e->primblock.argsp && np->vclass != CLVAR)
+			afwalk((struct Primblock *)e);
+		else
+			aawalk((struct Primblock *)e);
+		return;
+	  case TEXPR:
+		awalk(e->exprblock.rightp);
+		e = e->exprblock.leftp;
+		goto top;
+	  }
+	}
+
+ static chainp
+argsort(p0)
+ chainp p0;
+{
+	Namep *args, q, *stack;
+	int i, nargs, nout, nst;
+	chainp *d, *da, p, rv, *rvp;
+	struct Dimblock *dp;
+
+	if (!p0)
+		return p0;
+	for(nargs = 0, p = p0; p; p = p->nextp)
+		nargs++;
+	args = (Namep *)ckalloc(i = nargs*(sizeof(Namep) + 2*sizeof(chainp)
+			+ 2*sizeof(int)));
+	memset((char *)args, 0, i);
+	stack = args + nargs;
+	d = (chainp *)(stack + nargs);
+	refs = (int *)(d + nargs);
+	used = refs + nargs;
+
+	for(p = p0; p; p = p->nextp) {
+		q = (Namep) p->datap;
+		args[q->argno] = q;
+		}
+	for(p = p0; p; p = p->nextp) {
+		q = (Namep) p->datap;
+		if (!(dp = q->vdim))
+			continue;
+		i = dp->ndim;
+		while(--i >= 0)
+			awalk(dp->dims[i].dimexpr);
+		awalk(dp->basexpr);
+		while(nu > 0) {
+			refs[i = used[--nu]] = 0;
+			d[i] = mkchain((char *)q, d[i]);
+			}
+		}
+	for(i = nst = 0; i < nargs; i++)
+		for(p = d[i]; p; p = p->nextp)
+			refs[((Namep)p->datap)->argno]++;
+	while(--i >= 0)
+		if (!refs[i])
+			stack[nst++] = args[i];
+	if (nst == nargs) {
+		rv = p0;
+		goto done;
+		}
+	nout = 0;
+	rv = 0;
+	rvp = &rv;
+	while(nst > 0) {
+		nout++;
+		q = stack[--nst];
+		*rvp = p = mkchain((char *)q, CHNULL);
+		rvp = &p->nextp;
+		da = d + q->argno;
+		for(p = *da; p; p = p->nextp)
+			if (!--refs[(q = (Namep)p->datap)->argno])
+				stack[nst++] = q;
+		frchain(*da);
+		}
+	if (nout < nargs)
+		for(i = 0; i < nargs; i++)
+			if (refs[i]) {
+				q = args[i];
+				errstr("Can't adjust %.38s correctly\n\
+	due to dependencies among arguments.",
+					q->fvarname);
+				*rvp = p = mkchain((char *)q, CHNULL);
+				rvp = &p->nextp;
+				frchain(d[i]);
+				}
+ done:
+	free((char *)args);
+	return rv;
+	}
+
+prolog(outfile, p)
+ FILE *outfile;
+ register chainp p;
+{
+	int addif, addif0, i, nd, size;
+	int *ac;
+	register Namep q;
+	register struct Dimblock *dp;
+	chainp p0, p1;
+
+	if(procclass == CLBLOCK)
+		return;
+	p0 = p;
+	p1 = p = argsort(p);
+	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);
+	if (p0 != p1)
+		frchain(p1);
+} /* prolog */
diff --git a/usr.bin/f2c/version.c b/usr.bin/f2c/version.c
new file mode 100644
index 0000000..e1fabf5
--- /dev/null
+++ b/usr.bin/f2c/version.c
@@ -0,0 +1,2 @@
+char F2C_version[] = "19931217";
+char xxxvers[] = "\n@(#) FORTRAN 77 to C Translator, VERSION 19931217\n";
diff --git a/usr.bin/f2c/xsum.c b/usr.bin/f2c/xsum.c
new file mode 100644
index 0000000..817da21
--- /dev/null
+++ b/usr.bin/f2c/xsum.c
@@ -0,0 +1,233 @@
+/****************************************************************
+Copyright 1990, 1993 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"
+#ifndef KR_headers
+#include "stdlib.h"
+#include "fcntl.h"	/* for declaration of open, O_RDONLY */
+#endif
+#ifdef MSDOS
+#include "io.h"
+#endif
+#ifndef O_RDONLY
+#define O_RDONLY 0
+#endif
+#ifndef O_BINARY
+#define O_BINARY O_RDONLY
+#endif
+
+ char *progname;
+ static int ignore_cr;
+
+ void
+#ifdef KR_headers
+usage(rc)
+#else
+usage(int rc)
+#endif
+{
+	fprintf(stderr, "usage: %s [-r] [file [file...]]\n\
+	option -r ignores carriage return characters\n", progname);
+	exit(rc);
+	}
+
+typedef unsigned char Uchar;
+
+ long
+#ifdef KR_headers
+sum32(sum, x, n)
+ register long sum;
+ register Uchar *x;
+ int n;
+#else
+sum32(register long sum, register Uchar *x, int n)
+#endif
+{
+	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;
+	}
+
+ int
+#ifdef KR_headers
+cr_purge(buf, n)
+ Uchar *buf;
+ int n;
+#else
+cr_purge(Uchar *buf, int n)
+#endif
+{
+	register Uchar *b, *b1, *be;
+	b = buf;
+	be = b + n;
+	while(b < be)
+		if (*b++ == '\r') {
+			b1 = b - 1;
+			while(b < be)
+				if ((*b1 = *b++) != '\r')
+					b1++;
+			return b1 - buf;
+			}
+	return n;
+	}
+
+static Uchar Buf[16*1024];
+
+ void
+#ifdef KR_headers
+process(s, x)
+ char *s;
+ int x;
+#else
+process(char *s, int x)
+#endif
+{
+	register int n;
+	long fsize, sum;
+
+	sum = 0;
+	fsize = 0;
+	while((n = read(x, (char *)Buf, sizeof(Buf))) > 0) {
+		if (ignore_cr)
+			n = cr_purge(Buf, n);
+		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);
+	}
+
+#ifdef KR_headers
+main(argc, argv)
+ char **argv;
+#else
+main(int argc, char **argv)
+#endif
+{
+	int x;
+	char *s;
+	static int rc;
+
+	progname = *argv;
+	s = *++argv;
+	if (s && *s == '-') {
+		switch(s[1]) {
+			case '?':
+				usage(0);
+			case 'r':
+				ignore_cr = 1;
+			case '-':
+				break;
+			default:
+				fprintf(stderr, "invalid option %s\n", s);
+				usage(1);
+			}
+		s = *++argv;
+		}
+	if (s) do {
+		x = open(s, O_RDONLY|O_BINARY);
+		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));
+		}
+	return rc;
+	}
diff --git a/usr.bin/f2c/xsum0.out b/usr.bin/f2c/xsum0.out
new file mode 100644
index 0000000..0eecb1c
--- /dev/null
+++ b/usr.bin/f2c/xsum0.out
@@ -0,0 +1,56 @@
+Notice	1211689a	1195
+README	110fc3e8	4398
+cds.c	38ec751	4076
+data.c	fa8cecd6	9370
+defines.h	e500bb1a	8464
+defs.h	72515cc	24172
+equiv.c	f6b65bcc	8831
+error.c	7e4ede	3648
+exec.c	e279d99	17980
+expr.c	1d64bc48	60705
+f2c.1	fa354030	6042
+f2c.1t	e571e717	5988
+f2c.h	1be46b90	4271
+format.c	ed4c1a9	52848
+format.h	e861ad39	300
+formatdata.c	eb45f76a	24861
+ftypes.h	18b86a27	1377
+gram.dcl	11121871	7977
+gram.exec	e190cb8e	3026
+gram.expr	e3da3320	3137
+gram.head	ecf8a5e0	7554
+gram.io	1b7c281c	3294
+init.c	ffd3616	11452
+intr.c	e9519537	19813
+io.c	feb30d5a	29027
+iob.h	fe479ed3	459
+lex.c	ffae6a9f	31482
+machdefs.h	4950e5b	659
+main.c	54cb955	17040
+makefile	f3877062	2766
+malloc.c	5c2be2a	3422
+mem.c	133c066	4839
+memset.c	17404d52	1964
+misc.c	fe327633	18006
+names.c	3123927	19947
+names.h	f25436a3	689
+niceprintf.c	f976e7dd	9781
+niceprintf.h	c31f08c	412
+output.c	f0627d49	38529
+output.h	edfe9e59	2113
+p1defs.h	e4e11c4e	5776
+p1output.c	157a2c7e	12175
+parse.h	e457df2e	855
+parse_args.c	e01b1fe9	13035
+pccdefs.h	1b4fbbee	1195
+pread.c	5ac0d2	16490
+proc.c	116a13d2	34930
+put.c	fe8a1281	9480
+putpcc.c	1cebcba8	40081
+sysdep.c	174741bc	10939
+sysdep.h	1021aa5e	2834
+tokens	194fccfe	727
+usignal.h	1c4ce909	124
+vax.c	cf2e339	11030
+version.c	3351b7b	107
+xsum.c	e2d50e0b	6437