Added

lang/fortran/.distr

@@ -0,0 +1,7 @@
+changes
+comp
+disclaimer
+fc
+fixes
+index
+lib

lang/fortran/comp/.distr

@@ -0,0 +1,60 @@
+Notice
+README
+cds.c
+data.c
+defines.h
+defs.h
+equiv.c
+error.c
+exec.c
+expr.c
+f2c.1
+f2c.1t
+f2c.6
+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
+proto.make
+put.c
+putpcc.c
+string.h
+sysdep.c
+sysdep.h
+tokens
+usignal.h
+vax.c
+version.c
+xsum.c
+xsum0.out

lang/fortran/comp/Notice

@@ -0,0 +1,23 @@
+/****************************************************************
+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.
+****************************************************************/
+

lang/fortran/comp/README

@@ -0,0 +1,73 @@
+Type "make" to check the validity of the f2c source and compile f2c.
+
+If (in accordance with what follows) you need to modify the makefile
+or any of the source files, first issue a "make xsum.out" to check
+the validity of the f2c source, then make your changes, then type
+"make f2c".
+
+The file usignal.h is for the benefit of strictly ANSI include files
+on a UNIX system -- the ANSI signal.h does not define SIGHUP or SIGQUIT.
+You may need to modify usignal.h if you are not running f2c on a UNIX
+system.
+
+Should you get the message "xsum0.out xsum1.out differ", see what lines
+are different (`diff xsum0.out xsum1.out`) and ask netlib to send you
+the files in question "from f2c/src".  For example, if exec.c and
+expr.c have incorrect check sums, you would send netlib the message
+	send exec.c expr.c from f2c/src
+
+On some systems, the malloc and free in malloc.c let f2c run faster
+than do the standard malloc and free.  Other systems cannot tolerate
+redefinition of malloc and free.  If yours is such a system, you may
+either modify the makefile appropriately, or simply execute
+	cc -c -DCRAY malloc.c
+before typing "make".  Still other systems have a -lmalloc that
+provides performance competitive with that from malloc.c; you may
+wish to compare the two on your system.
+
+On some BSD systems, you may need to create a file named "string.h"
+whose single line is
+#include <strings.h>
+you may need to add " -Dstrchr=index" to the "CFLAGS =" assignment
+in the makefile, and you may need to add " memset.o" to the "OBJECTS ="
+assignment in the makefile -- see the comments in memset.c .
+
+For non-UNIX systems, you may need to change some things in sysdep.c,
+such as the choice of intermediate file names.
+
+On some systems, you may need to modify parts of sysdep.h (which is
+included by defs.h).  In particular, for Sun 4.1 systems and perhaps
+some others, you need to comment out the typedef of size_t.
+
+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 "index from f2c".  If you do this,
+then you should adjust the definition of link_msg in sysdep.c
+appropriately (e.g., replacing "-lF77 -lI77" by "-lf2c").
+
+Some older C compilers object to
+	typedef void (*foo)();
+or to
+	typedef void zap;
+	zap (*foo)();
+If yours is such a compiler, change the definition of VOID in
+f2c.h from void to int.
+
+Please send bug reports to dmg@research.att.com .  The index file
+("send index from f2c") will report recent changes in the recent-change
+log at its end; all changes will be shown in the "fixes" file
+("send fixes from f2c").  To keep current source, you will need to
+request xsum0.out and version.c, in addition to the changed source
+files.

lang/fortran/comp/cds.c

@@ -0,0 +1,178 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* Put strings representing decimal floating-point numbers
+ * into canonical form: always have a decimal point or
+ * exponent field; if using an exponent field, have the
+ * number before it start with a digit and decimal point
+ * (if the number has more than one digit); only have an
+ * exponent field if it saves space.
+ *
+ * Arrange that the return value, rv, satisfies rv[0] == '-' || rv[-1] == '-' .
+ */
+
+#include "sysdep.h"
+
+ char *
+cds(s, z0)
+ char *s, *z0;
+{
+	int ea, esign, et, i, k, nd = 0, sign = 0, tz;
+	char c, *z;
+	char ebuf[24];
+	long ex = 0;
+	static char etype[Table_size], *db;
+	static int dblen = 64;
+
+	if (!db) {
+		etype['E'] = 1;
+		etype['e'] = 1;
+		etype['D'] = 1;
+		etype['d'] = 1;
+		etype['+'] = 2;
+		etype['-'] = 3;
+		db = Alloc(dblen);
+		}
+
+	while((c = *s++) == '0');
+	if (c == '-')
+		{ sign = 1; c = *s++; }
+	else if (c == '+')
+		c = *s++;
+	k = strlen(s) + 2;
+	if (k >= dblen) {
+		do dblen <<= 1;
+			while(k >= dblen);
+		free(db);
+		db = Alloc(dblen);
+		}
+	if (etype[(unsigned char)c] >= 2)
+		while(c == '0') c = *s++;
+	tz = 0;
+	while(c >= '0' && c <= '9') {
+		if (c == '0')
+			tz++;
+		else {
+			if (nd)
+				for(; tz; --tz)
+					db[nd++] = '0';
+			else
+				tz = 0;
+			db[nd++] = c;
+			}
+		c = *s++;
+		}
+	ea = -tz;
+	if (c == '.') {
+		while((c = *s++) >= '0' && c <= '9') {
+			if (c == '0')
+				tz++;
+			else {
+				if (tz) {
+					ea += tz;
+					if (nd)
+						for(; tz; --tz)
+							db[nd++] = '0';
+					else
+						tz = 0;
+					}
+				db[nd++] = c;
+				ea++;
+				}
+			}
+		}
+	if (et = etype[(unsigned char)c]) {
+		esign = et == 3;
+		c = *s++;
+		if (et == 1) {
+			if(etype[(unsigned char)c] > 1) {
+				if (c == '-')
+					esign = 1;
+				c = *s++;
+				}
+			}
+		while(c >= '0' && c <= '9') {
+			ex = 10*ex + (c - '0');
+			c = *s++;
+			}
+		if (esign)
+			ex = -ex;
+		}
+	/* debug */ if (c)
+	/* debug*/	Fatal("unexpected character in cds");
+	ex -= ea;
+	if (!nd) {
+		if (!z0)
+			z0 = mem(4,0);
+		strcpy(z0, "-0.");
+		sign = 0;
+		}
+	else if (ex > 2 || ex + nd < -2) {
+		sprintf(ebuf, "%ld", ex + nd - 1);
+		k = strlen(ebuf) + nd + 3;
+		if (nd > 1)
+			k++;
+		if (!z0)
+			z0 = mem(k,0);
+		z = z0;
+		*z++ = '-';
+		*z++ = *db;
+		if (nd > 1) {
+			*z++ = '.';
+			for(k = 1; k < nd; k++)
+				*z++ = db[k];
+			}
+		*z++ = 'e';
+		strcpy(z, ebuf);
+		}
+	else {
+		k = (int)(ex + nd);
+		i = nd + 3;
+		if (k < 0)
+			i -= k;
+		else if (ex > 0)
+			i += ex;
+		if (!z0)
+			z0 = mem(i,0);
+		z = z0;
+		*z++ = '-';
+		if (ex >= 0) {
+			for(k = 0; k < nd; k++)
+				*z++ = db[k];
+			while(--ex >= 0)
+				*z++ = '0';
+			*z++ = '.';
+			}
+		else {
+			for(i = 0; i < k;)
+				*z++ = db[i++];
+			*z++ = '.';
+			while(++k <= 0)
+				*z++ = '0';
+			while(i < nd)
+				*z++ = db[i++];
+			}
+		*z = 0;
+		}
+	return sign ? z0 : z0+1;
+	}

lang/fortran/comp/data.c

@@ -0,0 +1,436 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+
+/* ROUTINES CALLED DURING DATA AND PARAMETER STATEMENT PROCESSING */
+
+static char datafmt[] = "%s\t%09ld\t%d";
+static char *cur_varname;
+
+/* another initializer, called from parser */
+dataval(repp, valp)
+register expptr repp, valp;
+{
+	int i, nrep;
+	ftnint elen;
+	register Addrp p;
+	Addrp nextdata();
+
+	if (parstate < INDATA) {
+		frexpr(repp);
+		goto ret;
+		}
+	if(repp == NULL)
+		nrep = 1;
+	else if (ISICON(repp) && repp->constblock.Const.ci >= 0)
+		nrep = repp->constblock.Const.ci;
+	else
+	{
+		err("invalid repetition count in DATA statement");
+		frexpr(repp);
+		goto ret;
+	}
+	frexpr(repp);
+
+	if( ! ISCONST(valp) )
+	{
+		err("non-constant initializer");
+		goto ret;
+	}
+
+	if(toomanyinit) goto ret;
+	for(i = 0 ; i < nrep ; ++i)
+	{
+		p = nextdata(&elen);
+		if(p == NULL)
+		{
+			err("too many initializers");
+			toomanyinit = YES;
+			goto ret;
+		}
+		setdata((Addrp)p, (Constp)valp, elen);
+		frexpr((expptr)p);
+	}
+
+ret:
+	frexpr(valp);
+}
+
+
+Addrp nextdata(elenp)
+ftnint *elenp;
+{
+	register struct Impldoblock *ip;
+	struct Primblock *pp;
+	register Namep np;
+	register struct Rplblock *rp;
+	tagptr p;
+	expptr neltp;
+	register expptr q;
+	int skip;
+	ftnint off, vlen;
+
+	while(curdtp)
+	{
+		p = (tagptr)curdtp->datap;
+		if(p->tag == TIMPLDO)
+		{
+			ip = &(p->impldoblock);
+			if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL)
+				fatali("bad impldoblock 0%o", (int) ip);
+			if(ip->isactive)
+				ip->varvp->Const.ci += ip->impdiff;
+			else
+			{
+				q = fixtype(cpexpr(ip->implb));
+				if( ! ISICON(q) )
+					goto doerr;
+				ip->varvp = (Constp) q;
+
+				if(ip->impstep)
+				{
+					q = fixtype(cpexpr(ip->impstep));
+					if( ! ISICON(q) )
+						goto doerr;
+					ip->impdiff = q->constblock.Const.ci;
+					frexpr(q);
+				}
+				else
+					ip->impdiff = 1;
+
+				q = fixtype(cpexpr(ip->impub));
+				if(! ISICON(q))
+					goto doerr;
+				ip->implim = q->constblock.Const.ci;
+				frexpr(q);
+
+				ip->isactive = YES;
+				rp = ALLOC(Rplblock);
+				rp->rplnextp = rpllist;
+				rpllist = rp;
+				rp->rplnp = ip->varnp;
+				rp->rplvp = (expptr) (ip->varvp);
+				rp->rpltag = TCONST;
+			}
+
+			if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim))
+			    || (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) )
+			{ /* start new loop */
+				curdtp = ip->datalist;
+				goto next;
+			}
+
+			/* clean up loop */
+
+			if(rpllist)
+			{
+				rp = rpllist;
+				rpllist = rpllist->rplnextp;
+				free( (charptr) rp);
+			}
+			else
+				Fatal("rpllist empty");
+
+			frexpr((expptr)ip->varvp);
+			ip->isactive = NO;
+			curdtp = curdtp->nextp;
+			goto next;
+		}
+
+		pp = (struct Primblock *) p;
+		np = pp->namep;
+		cur_varname = np->fvarname;
+		skip = YES;
+
+		if(p->primblock.argsp==NULL && np->vdim!=NULL)
+		{   /* array initialization */
+			q = (expptr) mkaddr(np);
+			off = typesize[np->vtype] * curdtelt;
+			if(np->vtype == TYCHAR)
+				off *= np->vleng->constblock.Const.ci;
+			q->addrblock.memoffset =
+			    mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) );
+			if( (neltp = np->vdim->nelt) && ISCONST(neltp))
+			{
+				if(++curdtelt < neltp->constblock.Const.ci)
+					skip = NO;
+			}
+			else
+				err("attempt to initialize adjustable array");
+		}
+		else
+			q = mklhs( (struct Primblock *)cpexpr((expptr)pp) );
+		if(skip)
+		{
+			curdtp = curdtp->nextp;
+			curdtelt = 0;
+		}
+		if(q->headblock.vtype == TYCHAR)
+			if(ISICON(q->headblock.vleng))
+				*elenp = q->headblock.vleng->constblock.Const.ci;
+			else	{
+				err("initialization of string of nonconstant length");
+				continue;
+			}
+		else	*elenp = typesize[q->headblock.vtype];
+
+		if (np->vstg == STGBSS) {
+			vlen = np->vtype==TYCHAR
+				? np->vleng->constblock.Const.ci
+				: typesize[np->vtype];
+			if(vlen > 0)
+				np->vstg = STGINIT;
+			}
+		return( (Addrp) q );
+
+doerr:
+		err("nonconstant implied DO parameter");
+		frexpr(q);
+		curdtp = curdtp->nextp;
+
+next:
+		curdtelt = 0;
+	}
+
+	return(NULL);
+}
+
+
+
+LOCAL FILEP dfile;
+
+
+setdata(varp, valp, elen)
+register Addrp varp;
+ftnint elen;
+register Constp valp;
+{
+	struct Constblock con;
+	register int type;
+	int i, k, valtype;
+	ftnint offset;
+	char *dataname(), *varname;
+	static Addrp badvar;
+	register unsigned char *s;
+	static int last_lineno;
+	static char *last_varname;
+
+	if (varp->vstg == STGCOMMON) {
+		if (!(dfile = blkdfile))
+			dfile = blkdfile = opf(blkdfname, textwrite);
+		}
+	else {
+		if (procclass == CLBLOCK) {
+			if (varp != badvar) {
+				badvar = varp;
+				warn1("%s is not in a COMMON block",
+					varp->uname_tag == UNAM_NAME
+					? varp->user.name->fvarname
+					: "???");
+				}
+			return;
+			}
+		if (!(dfile = initfile))
+			dfile = initfile = opf(initfname, textwrite);
+		}
+	varname = dataname(varp->vstg, varp->memno);
+	offset = varp->memoffset->constblock.Const.ci;
+	type = varp->vtype;
+	valtype = valp->vtype;
+	if(type!=TYCHAR && valtype==TYCHAR)
+	{
+		if(! ftn66flag
+		&& (last_varname != cur_varname || last_lineno != lineno)) {
+			/* prevent multiple warnings */
+			last_lineno = lineno;
+			warn1(
+	"non-character datum %.42s initialized with character string",
+				last_varname = cur_varname);
+			}
+		varp->vleng = ICON(typesize[type]);
+		varp->vtype = type = TYCHAR;
+	}
+	else if( (type==TYCHAR && valtype!=TYCHAR) ||
+	    (cktype(OPASSIGN,type,valtype) == TYERROR) )
+	{
+		err("incompatible types in initialization");
+		return;
+	}
+	if(type == TYADDR)
+		con.Const.ci = valp->Const.ci;
+	else if(type != TYCHAR)
+	{
+		if(valtype == TYUNKNOWN)
+			con.Const.ci = valp->Const.ci;
+		else	consconv(type, &con, valp);
+	}
+
+	k = 1;
+
+	switch(type)
+	{
+	case TYLOGICAL:
+		if (tylogical != TYLONG)
+			type = tylogical;
+	case TYSHORT:
+	case TYLONG:
+		dataline(varname, offset, type);
+		prconi(dfile, con.Const.ci);
+		break;
+
+	case TYADDR:
+		dataline(varname, offset, type);
+		prcona(dfile, con.Const.ci);
+		break;
+
+	case TYCOMPLEX:
+	case TYDCOMPLEX:
+		k = 2;
+	case TYREAL:
+	case TYDREAL:
+		dataline(varname, offset, type);
+		prconr(dfile, &con, k);
+		break;
+
+	case TYCHAR:
+		k = valp -> vleng -> constblock.Const.ci;
+		if (elen < k)
+			k = elen;
+		s = (unsigned char *)valp->Const.ccp;
+		for(i = 0 ; i < k ; ++i) {
+			dataline(varname, offset++, TYCHAR);
+			fprintf(dfile, "\t%d\n", *s++);
+			}
+		k = elen - valp->vleng->constblock.Const.ci;
+		if(k > 0) {
+			dataline(varname, offset, TYBLANK);
+			fprintf(dfile, "\t%d\n", k);
+			}
+		break;
+
+	default:
+		badtype("setdata", type);
+	}
+
+}
+
+
+
+/*
+   output form of name is padded with blanks and preceded
+   with a storage class digit
+*/
+char *dataname(stg,memno)
+ int stg;
+ long memno;
+{
+	static char varname[64];
+	register char *s, *t;
+	char buf[16], *memname();
+
+	if (stg == STGCOMMON) {
+		varname[0] = '2';
+		sprintf(s = buf, "Q.%ld", memno);
+		}
+	else {
+		varname[0] = stg==STGEQUIV ? '1' : '0';
+		s = memname(stg, memno);
+		}
+	t = varname + 1;
+	while(*t++ = *s++);
+	*t = 0;
+	return(varname);
+}
+
+
+
+
+
+frdata(p0)
+chainp p0;
+{
+	register struct Chain *p;
+	register tagptr q;
+
+	for(p = p0 ; p ; p = p->nextp)
+	{
+		q = (tagptr)p->datap;
+		if(q->tag == TIMPLDO)
+		{
+			if(q->impldoblock.isbusy)
+				return;	/* circular chain completed */
+			q->impldoblock.isbusy = YES;
+			frdata(q->impldoblock.datalist);
+			free( (charptr) q);
+		}
+		else
+			frexpr(q);
+	}
+
+	frchain( &p0);
+}
+
+
+
+dataline(varname, offset, type)
+char *varname;
+ftnint offset;
+int type;
+{
+	fprintf(dfile, datafmt, varname, offset, type);
+}
+
+ void
+make_param(p, e)
+ register struct Paramblock *p;
+ expptr e;
+{
+	register expptr q;
+
+	p->vclass = CLPARAM;
+	impldcl((Namep)p);
+	p->paramval = q = mkconv(p->vtype, e);
+	if (p->vtype == TYCHAR) {
+		if (q->tag == TEXPR)
+			p->paramval = q = fixexpr(q);
+		if (!ISCONST(q) || q->constblock.vtype != TYCHAR) {
+			errstr("invalid value for character parameter %s",
+				p->fvarname);
+			return;
+			}
+		if (!(e = p->vleng))
+			p->vleng = ICON(q->constblock.vleng->constblock.Const.ci
+					+ q->constblock.Const.ccp1.blanks);
+		else if (q->constblock.vleng->constblock.Const.ci
+				> e->constblock.Const.ci) {
+			q->constblock.vleng->constblock.Const.ci
+				= e->constblock.Const.ci;
+			q->constblock.Const.ccp1.blanks = 0;
+			}
+		else
+			q->constblock.Const.ccp1.blanks
+				= e->constblock.Const.ci
+				- q->constblock.vleng->constblock.Const.ci;
+		}
+	}

lang/fortran/comp/defines.h

@@ -0,0 +1,289 @@
+#define PDP11 4
+
+#define BIGGEST_SHORT	0x7fff		/* Assumes 32-bit arithmetic */
+#define BIGGEST_LONG	0x7fffffff	/* Assumes 32-bit arithmetic */
+
+#define M(x) (1<<x)	/* Mask (x) returns 2^x */
+
+#define ALLOC(x)	(struct x *) ckalloc(sizeof(struct x))
+#define ALLEXPR		(expptr) ckalloc( sizeof(union Expression) )
+typedef int *ptr;
+typedef char *charptr;
+typedef FILE *FILEP;
+typedef int flag;
+typedef char field;	/* actually need only 4 bits */
+typedef long int ftnint;
+#define LOCAL static
+
+#define NO 0
+#define YES 1
+
+#define CNULL (char *) 0	/* Character string null */
+#define PNULL (ptr) 0
+#define CHNULL (chainp) 0	/* Chain null */
+#define ENULL (expptr) 0
+
+
+/* BAD_MEMNO - used to distinguish between long string constants and other
+   constants in the table */
+
+#define BAD_MEMNO -32768
+
+
+/* block tag values -- syntactic stuff */
+
+#define TNAME 1
+#define TCONST 2
+#define TEXPR 3
+#define TADDR 4
+#define TPRIM 5		/* Primitive datum - should not appear in an
+			   expptr variable, it should have already been
+			   identified */
+#define TLIST 6
+#define TIMPLDO 7
+#define TERROR 8
+
+
+/* parser states - order is important, since there are several tests for
+   state < INDATA   */
+
+#define OUTSIDE 0
+#define INSIDE 1
+#define INDCL 2
+#define INDATA 3
+#define INEXEC 4
+
+/* procedure classes */
+
+#define PROCMAIN 1
+#define PROCBLOCK 2
+#define PROCSUBR 3
+#define PROCFUNCT 4
+
+
+/* storage classes -- vstg values.  BSS and INIT are used in the later
+   merge pass over identifiers; and they are entered differently into the
+   symbol table */
+
+#define STGUNKNOWN 0
+#define STGARG 1	/* adjustable dimensions */
+#define STGAUTO 2	/* for stack references */
+#define STGBSS 3	/* uninitialized storage (normal variables) */
+#define STGINIT 4	/* initialized storage */
+#define STGCONST 5
+#define STGEXT 6	/* external storage */
+#define STGINTR 7	/* intrinsic (late decision) reference.  See
+			   chapter 5 of the Fortran 77 standard */
+#define STGSTFUNCT 8
+#define STGCOMMON 9
+#define STGEQUIV 10
+#define STGREG 11	/* register - the outermost DO loop index will be
+			   in a register (because the compiler is one
+			   pass, it can't know where the innermost loop is
+			   */
+#define STGLENG 12
+#define STGNULL 13
+#define STGMEMNO 14	/* interemediate-file pointer to constant table */
+
+/* name classes -- vclass values, also   procclass   values */
+
+#define CLUNKNOWN 0
+#define CLPARAM 1	/* Parameter - macro definition */
+#define CLVAR 2		/* variable */
+#define CLENTRY 3
+#define CLMAIN 4
+#define CLBLOCK 5
+#define CLPROC 6
+#define CLNAMELIST 7	/* in data with this tag, the   vdcldone   flag should
+			   be ignored (according to vardcl()) */
+
+
+/* vprocclass values -- there is some overlap with the vclass values given
+   above */
+
+#define PUNKNOWN 0
+#define PEXTERNAL 1
+#define PINTRINSIC 2
+#define PSTFUNCT 3
+#define PTHISPROC 4	/* here to allow recursion - further distinction
+			   is given in the CL tag (those just above).
+			   This applies to the presence of the name of a
+			   function used within itself.  The function name
+			   means either call the function again, or assign
+			   some value to the storage allocated to the
+			   function's return value. */
+
+/* control stack codes - these are part of a state machine which handles
+   the nesting of blocks (i.e. what to do about the ELSE statement) */
+
+#define CTLDO 1
+#define CTLIF 2
+#define CTLELSE 3
+#define CTLIFX 4
+
+
+/* operators for both Fortran input and C output.  They are common because
+   so many are shared between the trees */
+
+#define OPPLUS 1
+#define OPMINUS 2
+#define OPSTAR 3
+#define OPSLASH 4
+#define OPPOWER 5
+#define OPNEG 6
+#define OPOR 7
+#define OPAND 8
+#define OPEQV 9
+#define OPNEQV 10
+#define OPNOT 11
+#define OPCONCAT 12
+#define OPLT 13
+#define OPEQ 14
+#define OPGT 15
+#define OPLE 16
+#define OPNE 17
+#define OPGE 18
+#define OPCALL 19
+#define OPCCALL 20
+#define OPASSIGN 21
+#define OPPLUSEQ 22
+#define OPSTAREQ 23
+#define OPCONV 24
+#define OPLSHIFT 25
+#define OPMOD 26
+#define OPCOMMA 27
+#define OPQUEST 28
+#define OPCOLON 29
+#define OPABS 30
+#define OPMIN 31
+#define OPMAX 32
+#define OPADDR 33
+#define OPCOMMA_ARG 34
+#define OPBITOR 35
+#define OPBITAND 36
+#define OPBITXOR 37
+#define OPBITNOT 38
+#define OPRSHIFT 39
+#define OPWHATSIN 40		/* dereferencing operator */
+#define OPMINUSEQ 41		/* assignment operators */
+#define OPSLASHEQ 42
+#define OPMODEQ 43
+#define OPLSHIFTEQ 44
+#define OPRSHIFTEQ 45
+#define OPBITANDEQ 46
+#define OPBITXOREQ 47
+#define OPBITOREQ 48
+#define OPPREINC 49		/* Preincrement (++x) operator */
+#define OPPREDEC 50		/* Predecrement (--x) operator */
+#define OPDOT 51		/* structure field reference */
+#define OPARROW 52		/* structure pointer field reference */
+#define OPNEG1 53		/* simple negation under forcedouble */
+#define OPDMIN 54		/* min(a,b) macro under forcedouble */
+#define OPDMAX 55		/* max(a,b) macro under forcedouble */
+#define OPASSIGNI 56		/* assignment for inquire stmt */
+#define OPIDENTITY 57		/* for turning TADDR into TEXPR */
+#define OPCHARCAST 58		/* for casting to char * (in I/O stmts) */
+#define OPDABS 59		/* abs macro under forcedouble */
+#define OPMIN2 60		/* min(a,b) macro */
+#define OPMAX2 61		/* max(a,b) macro */
+
+/* label type codes -- used with the ASSIGN statement */
+
+#define LABUNKNOWN 0
+#define LABEXEC 1
+#define LABFORMAT 2
+#define LABOTHER 3
+
+
+/* INTRINSIC function codes*/
+
+#define INTREND 0
+#define INTRCONV 1
+#define INTRMIN 2
+#define INTRMAX 3
+#define INTRGEN 4	/* General intrinsic, e.g. cos v. dcos, zcos, ccos */
+#define INTRSPEC 5
+#define INTRBOOL 6
+#define INTRCNST 7	/* constants, e.g. bigint(1.0) v. bigint (1d0) */
+
+
+/* I/O statement codes - these all form Integer Constants, and are always
+   reevaluated */
+
+#define IOSTDIN ICON(5)
+#define IOSTDOUT ICON(6)
+#define IOSTDERR ICON(0)
+
+#define IOSBAD (-1)
+#define IOSPOSITIONAL 0
+#define IOSUNIT 1
+#define IOSFMT 2
+
+#define IOINQUIRE 1
+#define IOOPEN 2
+#define IOCLOSE 3
+#define IOREWIND 4
+#define IOBACKSPACE 5
+#define IOENDFILE 6
+#define IOREAD 7
+#define IOWRITE 8
+
+
+/* User name tags -- these identify the form of the original identifier
+   stored in a   struct Addrblock   structure (in the   user   field). */
+
+#define UNAM_UNKNOWN 0		/* Not specified */
+#define UNAM_NAME 1		/* Local symbol, store in the hash table */
+#define UNAM_IDENT 2		/* Character string not stored elsewhere */
+#define UNAM_EXTERN 3		/* External reference; check symbol table
+				   using   memno   as index */
+#define UNAM_CONST 4		/* Constant value */
+#define UNAM_CHARP 5		/* pointer to string */
+
+
+#define IDENT_LEN 31		/* Maximum length user.ident */
+
+/* type masks - TYLOGICAL defined in   ftypes   */
+
+#define MSKLOGICAL	M(TYLOGICAL)
+#define MSKADDR	M(TYADDR)
+#define MSKCHAR	M(TYCHAR)
+#define MSKINT	M(TYSHORT)|M(TYLONG)
+#define MSKREAL	M(TYREAL)|M(TYDREAL)	/* DREAL means Double Real */
+#define MSKCOMPLEX	M(TYCOMPLEX)|M(TYDCOMPLEX)
+#define MSKSTATIC (M(STGINIT)|M(STGBSS)|M(STGCOMMON)|M(STGEQUIV)|M(STGCONST))
+
+/* miscellaneous macros */
+
+/* ONEOF (x, y) -- x is the number of one of the OR'ed masks in y (i.e., x is
+   the log of one of the OR'ed masks in y) */
+
+#define ONEOF(x,y) (M(x) & (y))
+#define ISCOMPLEX(z) ONEOF(z, MSKCOMPLEX)
+#define ISREAL(z) ONEOF(z, MSKREAL)
+#define ISNUMERIC(z) ONEOF(z, MSKINT|MSKREAL|MSKCOMPLEX)
+#define ISICON(z) (z->tag==TCONST && ISINT(z->constblock.vtype))
+
+/* ISCHAR assumes that   z   has some kind of structure, i.e. is not null */
+
+#define ISCHAR(z) (z->headblock.vtype==TYCHAR)
+#define ISINT(z)   ONEOF(z, MSKINT)	/*   z   is a tag, i.e. a mask number */
+#define ISCONST(z) (z->tag==TCONST)
+#define ISERROR(z) (z->tag==TERROR)
+#define ISPLUSOP(z) (z->tag==TEXPR && z->exprblock.opcode==OPPLUS)
+#define ISSTAROP(z) (z->tag==TEXPR && z->exprblock.opcode==OPSTAR)
+#define ISONE(z) (ISICON(z) && z->constblock.Const.ci==1)
+#define INT(z) ONEOF(z, MSKINT|MSKCHAR)	/* has INT storage in real life */
+#define ICON(z) mkintcon( (ftnint)(z) )
+
+/* NO66 -- F77 feature is being used
+   NOEXT -- F77 extension is being used */
+
+#define NO66(s)	if(no66flag) err66(s)
+#define NOEXT(s)	if(noextflag) errext(s)
+
+/* round a up to the nearest multiple of b:
+
+   a = b * floor ( (a + (b - 1)) / b )*/
+
+#define roundup(a,b)    ( b * ( (a+b-1)/b) )

lang/fortran/comp/defs.h

@@ -0,0 +1,769 @@
+/****************************************************************
+Copyright 1990, 1991 by AT&T Bell Laboratories, Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "sysdep.h"
+
+#include "ftypes.h"
+#include "defines.h"
+#include "machdefs.h"
+
+#define MAXDIM 20
+#define MAXINCLUDES 10
+#define MAXLITERALS 200		/* Max number of constants in the literal
+				   pool */
+#define MAXTOKENLEN 302		/* length of longest token */
+#define MAXCTL 20
+#define MAXHASH 401
+#define MAXSTNO 801
+#define MAXEXT 200
+#define MAXEQUIV 150
+#define MAXLABLIST 125		/* Max number of labels in an alternate
+				   return CALL */
+
+/* These are the primary pointer types used in the compiler */
+
+typedef union Expression *expptr, *tagptr;
+typedef struct Chain *chainp;
+typedef struct Addrblock *Addrp;
+typedef struct Constblock *Constp;
+typedef struct Exprblock *Exprp;
+typedef struct Nameblock *Namep;
+
+extern FILEP opf();
+extern FILEP infile;
+extern FILEP diagfile;
+extern FILEP textfile;
+extern FILEP asmfile;
+extern FILEP c_file;		/* output file for all functions; extern
+				   declarations will have to be prepended */
+extern FILEP pass1_file;	/* Temp file to hold the function bodies
+				   read on pass 1 */
+extern FILEP expr_file;		/* Debugging file */
+extern FILEP initfile;		/* Intermediate data file pointer */
+extern FILEP blkdfile;		/* BLOCK DATA file */
+
+extern int current_ftn_file;
+
+extern char *blkdfname, *initfname, *sortfname;
+extern long int headoffset;	/* Since the header block requires data we
+				   don't know about until AFTER each
+				   function has been processed, we keep a
+				   pointer to the current (dummy) header
+				   block (at the top of the assembly file)
+				   here */
+
+extern char main_alias[];	/* name given to PROGRAM psuedo-op */
+extern char token [ ];
+extern int toklen;
+extern long lineno;
+extern char *infname;
+extern int needkwd;
+extern struct Labelblock *thislabel;
+
+/* Used to allow runtime expansion of internal tables.  In particular,
+   these values can exceed their associated constants */
+
+extern int maxctl;
+extern int maxequiv;
+extern int maxstno;
+extern int maxhash;
+extern int maxext;
+
+extern flag nowarnflag;
+extern flag ftn66flag;		/* Generate warnings when weird f77
+				   features are used (undeclared dummy
+				   procedure, non-char initialized with
+				   string, 1-dim subscript in EQUIV) */
+extern flag no66flag;		/* Generate an error when a generic
+				   function (f77 feature) is used */
+extern flag noextflag;		/* Generate an error when an extension to
+				   Fortran 77 is used (hex/oct/bin
+				   constants, automatic, static, double
+				   complex types) */
+extern flag zflag;		/* enable double complex intrinsics */
+extern flag shiftcase;
+extern flag undeftype;
+extern flag shortsubs;		/* Use short subscripts on arrays? */
+extern flag onetripflag;	/* if true, always execute DO loop body */
+extern flag checksubs;
+extern flag debugflag;
+extern int nerr;
+extern int nwarn;
+
+extern int parstate;
+extern flag headerdone;		/* True iff the current procedure's header
+				   data has been written */
+extern int blklevel;
+extern flag saveall;
+extern flag substars;		/* True iff some formal parameter is an
+				   asterisk */
+extern int impltype[ ];
+extern ftnint implleng[ ];
+extern int implstg[ ];
+
+extern int tycomplex, tyint, tyioint, tyreal;
+extern int tylogical;		/* TY____ of the implementation of   logical.
+				   This will be LONG unless '-2' is given
+				   on the command line */
+extern int type_choice[];
+extern char *typename[];
+
+extern int typesize[];	/* size (in bytes) of an object of each
+				   type.  Indexed by TY___ macros */
+extern int typealign[];
+extern int proctype;	/* Type of return value in this procedure */
+extern char * procname;	/* External name of the procedure, or last ENTRY name */
+extern int rtvlabel[ ];	/* Return value labels, indexed by TY___ macros */
+extern Addrp retslot;
+extern Addrp xretslot[];
+extern int cxslot;	/* Complex return argument slot (frame pointer offset)*/
+extern int chslot;	/* Character return argument slot (fp offset) */
+extern int chlgslot;	/* Argument slot for length of character buffer */
+extern int procclass;	/* Class of the current procedure:  either CLPROC,
+			   CLMAIN, CLBLOCK or CLUNKNOWN */
+extern ftnint procleng;	/* Length of function return value (e.g. char
+			   string length).  If this is -1, then the length is
+			   not known at compile time */
+extern int nentry;	/* Number of entry points (other than the original
+			   function call) into this procedure */
+extern flag multitype;	/* YES iff there is more than one return value
+			   possible */
+extern int blklevel;
+extern long lastiolabno;
+extern int lastlabno;
+extern int lastvarno;
+extern int lastargslot;	/* integer offset pointing to the next free
+			   location for an argument to the current routine */
+extern int argloc;
+extern int autonum[];		/* for numbering
+				   automatic variables, e.g. temporaries */
+extern int retlabel;
+extern int ret0label;
+extern int dorange;		/* Number of the label which terminates
+				   the innermost DO loop */
+extern int regnum[ ];		/* Numbers of DO indicies named in
+				   regnamep   (below) */
+extern Namep regnamep[ ];	/* List of DO indicies in registers */
+extern int maxregvar;		/* number of elts in   regnamep   */
+extern int highregvar;		/* keeps track of the highest register
+				   number used by DO index allocator */
+extern int nregvar;		/* count of DO indicies in registers */
+
+extern chainp templist[];
+extern int maxdim;
+extern chainp earlylabs;
+extern chainp holdtemps;
+extern struct Entrypoint *entries;
+extern struct Rplblock *rpllist;
+extern struct Chain *curdtp;
+extern ftnint curdtelt;
+extern chainp allargs;		/* union of args in entries */
+extern int nallargs;		/* total number of args */
+extern int nallchargs;		/* total number of character args */
+extern flag toomanyinit;	/* True iff too many initializers in a
+				   DATA statement */
+
+extern flag inioctl;
+extern int iostmt;
+extern Addrp ioblkp;
+extern int nioctl;
+extern int nequiv;
+extern int eqvstart;	/* offset to eqv number to guarantee uniqueness
+			   and prevent <something> from going negative */
+extern int nintnames;
+
+/* Chain of tagged blocks */
+
+struct Chain
+	{
+	chainp nextp;
+	char * datap;		/* Tagged block */
+	};
+
+extern chainp chains;
+
+/* Recall that   field   is intended to hold four-bit characters */
+
+/* This structure exists only to defeat the type checking */
+
+struct Headblock
+	{
+	field tag;
+	field vtype;
+	field vclass;
+	field vstg;
+	expptr vleng;		/* Expression for length of char string -
+				   this may be a constant, or an argument
+				   generated by mkarg() */
+	} ;
+
+/* Control construct info (for do loops, else, etc) */
+
+struct Ctlframe
+	{
+	unsigned ctltype:8;
+	unsigned dostepsign:8;	/* 0 - variable, 1 - pos, 2 - neg */
+	unsigned dowhile:1;
+	int ctlabels[4];	/* Control labels, defined below */
+	int dolabel;		/* label marking end of this DO loop */
+	Namep donamep;		/* DO index variable */
+	expptr domax;		/* constant or temp variable holding MAX
+				   loop value; or expr of while(expr) */
+	expptr dostep;		/* expression */
+	Namep loopname;
+	};
+#define endlabel ctlabels[0]
+#define elselabel ctlabels[1]
+#define dobodylabel ctlabels[1]
+#define doposlabel ctlabels[2]
+#define doneglabel ctlabels[3]
+extern struct Ctlframe *ctls;		/* Keeps info on DO and BLOCK IF
+					   structures - this is the stack
+					   bottom */
+extern struct Ctlframe *ctlstack;	/* Pointer to current nesting
+					   level */
+extern struct Ctlframe *lastctl;	/* Point to end of
+					   dynamically-allocated array */
+
+typedef struct {
+	int type;
+	chainp cp;
+	} Atype;
+
+typedef struct {
+	int nargs, changes;
+	Atype atypes[1];
+	} Argtypes;
+
+/* External Symbols */
+
+struct Extsym
+	{
+	char *fextname;		/* Fortran version of external name */
+	char *cextname;		/* C version of external name */
+	field extstg;		/* STG -- should be COMMON, UNKNOWN or EXT
+				   */
+	unsigned extype:4;	/* for transmitting type to output routines */
+	unsigned used_here:1;	/* Boolean - true on the second pass
+				   through a function if the block has
+				   been referenced */
+	unsigned exused:1;	/* Has been used (for help with error msgs
+				   about externals typed differently in
+				   different modules) */
+	unsigned exproto:1;	/* type specified in a .P file */
+	unsigned extinit:1;	/* Procedure has been defined,
+				   or COMMON has DATA */
+	unsigned extseen:1;	/* True if previously referenced */
+	chainp extp;		/* List of identifiers in the common
+				   block for this function, stored as
+				   Namep (hash table pointers) */
+	chainp allextp;		/* List of lists of identifiers; we keep one
+				   list for each layout of this common block */
+	int curno;		/* current number for this common block,
+				   used for constructing appending _nnn
+				   to the common block name */
+	int maxno;		/* highest curno value for this common block */
+	ftnint extleng;
+	ftnint maxleng;
+	Argtypes *arginfo;
+	};
+typedef struct Extsym Extsym;
+
+extern Extsym *extsymtab;	/* External symbol table */
+extern Extsym *nextext;
+extern Extsym *lastext;
+extern int complex_seen, dcomplex_seen;
+
+/* Statement labels */
+
+struct Labelblock
+	{
+	int labelno;		/* Internal label */
+	unsigned blklevel:8;	/* level of nesting , for branch-in-loop
+				   checking */
+	unsigned labused:1;
+	unsigned fmtlabused:1;
+	unsigned labinacc:1;	/* inaccessible? (i.e. has its scope
+				   vanished) */
+	unsigned labdefined:1;	/* YES or NO */
+	unsigned labtype:2;	/* LAB{FORMAT,EXEC,etc} */
+	ftnint stateno;		/* Original label */
+	char *fmtstring;	/* format string */
+	};
+
+extern struct Labelblock *labeltab;	/* Label table - keeps track of
+					   all labels, including undefined */
+extern struct Labelblock *labtabend;
+extern struct Labelblock *highlabtab;
+
+/* Entry point list */
+
+struct Entrypoint
+	{
+	struct Entrypoint *entnextp;
+	Extsym *entryname;	/* Name of this ENTRY */
+	chainp arglist;
+	int typelabel;			/* Label for function exit; this
+					   will return the proper type of
+					   object */
+	Namep enamep;			/* External name */
+	};
+
+/* Primitive block, or Primary block.  This is a general template returned
+   by the parser, which will be interpreted in context.  It is a template
+   for an identifier (variable name, function name), parenthesized
+   arguments (array subscripts, function parameters) and substring
+   specifications. */
+
+struct Primblock
+	{
+	field tag;
+	field vtype;
+	Namep namep;			/* Pointer to structure Nameblock */
+	struct Listblock *argsp;
+	expptr fcharp;			/* first-char-index-pointer (in
+					   substring) */
+	expptr lcharp;			/* last-char-index-pointer (in
+					   substring) */
+	};
+
+
+struct Hashentry
+	{
+	int hashval;
+	Namep varp;
+	};
+extern struct Hashentry *hashtab;	/* Hash table */
+extern struct Hashentry *lasthash;
+
+struct Intrpacked	/* bits for intrinsic function description */
+	{
+	unsigned f1:3;
+	unsigned f2:4;
+	unsigned f3:7;
+	unsigned f4:1;
+	};
+
+struct Nameblock
+	{
+	field tag;
+	field vtype;
+	field vclass;
+	field vstg;
+	expptr vleng;		/* length of character string, if applicable */
+	char *fvarname;		/* name in the Fortran source */
+	char *cvarname;		/* name in the resulting C */
+	chainp vlastdim;	/* datap points to new_vars entry for the */
+				/* system variable, if any, storing the final */
+				/* dimension; we zero the datap if this */
+				/* variable is needed */
+	unsigned vprocclass:3;	/* P____ macros - selects the   varxptr
+				   field below */
+	unsigned vdovar:1;	/* "is it a DO variable?" for register
+				   and multi-level loop	checking */
+	unsigned vdcldone:1;	/* "do I think I'm done?" - set when the
+				   context is sufficient to determine its
+				   status */
+	unsigned vadjdim:1;	/* "adjustable dimension?" - needed for
+				   information about copies */
+	unsigned vsave:1;
+	unsigned vimpldovar:1;	/* used to prevent erroneous error messages
+				   for variables used only in DATA stmt
+				   implicit DOs */
+	unsigned vis_assigned:1;/* True if this variable has had some
+				   label ASSIGNED to it; hence
+				   varxptr.assigned_values is valid */
+	unsigned vimplstg:1;	/* True if storage type is assigned implicitly;
+				   this allows a COMMON variable to participate
+				   in a DIMENSION before the COMMON declaration.
+				   */
+	unsigned vcommequiv:1;	/* True if EQUIVALENCEd onto STGCOMMON */
+	unsigned vfmt_asg:1;	/* True if char *var_fmt needed */
+	unsigned vpassed:1;	/* True if passed as a character-variable arg */
+	unsigned vknownarg:1;	/* True if seen in a previous entry point */
+	unsigned visused:1;	/* True if variable is referenced -- so we */
+				/* can omit variables that only appear in DATA */
+	unsigned vnamelist:1;	/* Appears in a NAMELIST */
+	unsigned vimpltype:1;	/* True if implicitly typed and not
+				   invoked as a function or subroutine
+				   (so we can consistently type procedures
+				   declared external and passed as args
+				   but never invoked).
+				   */
+	unsigned vtypewarned:1;	/* so we complain just once about
+				   changed types of external procedures */
+	unsigned vinftype:1;	/* so we can restore implicit type to a
+				   procedure if it is invoked as a function
+				   after being given a different type by -it */
+	unsigned vinfproc:1;	/* True if -it infers this to be a procedure */
+	unsigned vcalled:1;	/* has been invoked */
+	unsigned vdimfinish:1;	/* need to invoke dim_finish() */
+
+/* The   vardesc   union below is used to store the number of an intrinsic
+   function (when vstg == STGINTR and vprocclass == PINTRINSIC), or to
+   store the index of this external symbol in   extsymtab   (when vstg ==
+   STGEXT and vprocclass == PEXTERNAL) */
+
+	union	{
+		int varno;		/* Return variable for a function.
+					   This is used when a function is
+					   assigned a return value.  Also
+					   used to point to the COMMON
+					   block, when this is a field of
+					   that block.  Also points to
+					   EQUIV block when STGEQUIV */
+		struct Intrpacked intrdesc;	/* bits for intrinsic function*/
+		} vardesc;
+	struct Dimblock *vdim;	/* points to the dimensions if they exist */
+	ftnint voffset;		/* offset in a storage block (the variable
+				   name will be "v.%d", voffset in a
+				   common blck on the vax).  Also holds
+				   pointers for automatic variables.  When
+				   STGEQUIV, this is -(offset from array
+				   base) */
+	union	{
+		chainp namelist;	/* points to names in the NAMELIST,
+					   if this is a NAMELIST name */
+		chainp vstfdesc;	/* points to (formals, expr) pair */
+		chainp assigned_values;	/* list of integers, each being a
+					   statement label assigned to
+					   this variable in the current function */
+		} varxptr;
+	int argno;		/* for multiple entries */
+	Argtypes *arginfo;
+	};
+
+
+/* PARAMETER statements */
+
+struct Paramblock
+	{
+	field tag;
+	field vtype;
+	field vclass;
+	field vstg;
+	expptr vleng;
+	char *fvarname;
+	char *cvarname;
+	expptr paramval;
+	} ;
+
+
+/* Expression block */
+
+struct Exprblock
+	{
+	field tag;
+	field vtype;
+	field vclass;
+	field vstg;
+	expptr vleng;		/* in the case of a character expression, this
+				   value is inherited from the children */
+	unsigned opcode;
+	expptr leftp;
+	expptr rightp;
+	};
+
+
+union Constant
+	{
+	struct {
+		char *ccp0;
+		ftnint blanks;
+		} ccp1;
+	ftnint ci;		/* Constant long integer */
+	double cd[2];
+	char *cds[2];
+	};
+#define ccp ccp1.ccp0
+
+struct Constblock
+	{
+	field tag;
+	field vtype;
+	field vclass;
+	field vstg;		/* vstg = 1 when using Const.cds */
+	expptr vleng;
+	union Constant Const;
+	};
+
+
+struct Listblock
+	{
+	field tag;
+	field vtype;
+	chainp listp;
+	};
+
+
+
+/* Address block - this is the FINAL form of identifiers before being
+   sent to pass 2.  We'll want to add the original identifier here so that it can
+   be preserved in the translation.
+
+   An example identifier is q.7.  The "q" refers to the storage class
+   (field vstg), the 7 to the variable number (int memno). */
+
+struct Addrblock
+	{
+	field tag;
+	field vtype;
+	field vclass;
+	field vstg;
+	expptr vleng;
+	/* put union...user here so the beginning of an Addrblock
+	 * is the same as a Constblock.
+	 */
+	union {
+	    Namep name;		/* contains a pointer into the hash table */
+	    char ident[IDENT_LEN + 1];	/* C string form of identifier */
+	    char *Charp;
+	    union Constant Const;	/* Constant value */
+	    struct {
+		double dfill[2];
+		field vstg1;
+		} kludge;	/* so we can distinguish string vs binary
+				 * floating-point constants */
+	} user;
+	long memno;		/* when vstg == STGCONST, this is the
+				   numeric part of the assembler label
+				   where the constant value is stored */
+	expptr memoffset;	/* used in subscript computations, usually */
+	unsigned istemp:1;	/* used in stack management of temporary
+				   variables */
+	unsigned isarray:1;	/* used to show that memoffset is
+				   meaningful, even if zero */
+	unsigned ntempelt:10;	/* for representing temporary arrays, as
+				   in concatenation */
+	unsigned dbl_builtin:1;	/* builtin to be declared double */
+	unsigned charleng:1;	/* so saveargtypes can get i/o calls right */
+	ftnint varleng;		/* holds a copy of a constant length which
+				   is stored in the   vleng   field (e.g.
+				   a double is 8 bytes) */
+	int uname_tag;		/* Tag describing which of the unions()
+				   below to use */
+	char *Field;		/* field name when dereferencing a struct */
+}; /* struct Addrblock */
+
+
+/* Errorbock - placeholder for errors, to allow the compilation to
+   continue */
+
+struct Errorblock
+	{
+	field tag;
+	field vtype;
+	};
+
+
+/* Implicit DO block, especially related to DATA statements.  This block
+   keeps track of the compiler's location in the implicit DO while it's
+   running.  In particular, the   isactive and isbusy   flags tell where
+   it is */
+
+struct Impldoblock
+	{
+	field tag;
+	unsigned isactive:1;
+	unsigned isbusy:1;
+	Namep varnp;
+	Constp varvp;
+	chainp impdospec;
+	expptr implb;
+	expptr impub;
+	expptr impstep;
+	ftnint impdiff;
+	ftnint implim;
+	struct Chain *datalist;
+	};
+
+
+/* Each of these components has a first field called   tag.   This union
+   exists just for allocation simplicity */
+
+union Expression
+	{
+	field tag;
+	struct Addrblock addrblock;
+	struct Constblock constblock;
+	struct Errorblock errorblock;
+	struct Exprblock exprblock;
+	struct Headblock headblock;
+	struct Impldoblock impldoblock;
+	struct Listblock listblock;
+	struct Nameblock nameblock;
+	struct Paramblock paramblock;
+	struct Primblock primblock;
+	} ;
+
+
+
+struct Dimblock
+	{
+	int ndim;
+	expptr nelt;		/* This is NULL if the array is unbounded */
+	expptr baseoffset;	/* a constant or local variable holding
+				   the offset in this procedure */
+	expptr basexpr;		/* expression for comuting the offset, if
+				   it's not constant.  If this is
+				   non-null, the register named in
+				   baseoffset will get initialized to this
+				   value in the procedure's prolog */
+	struct
+		{
+		expptr dimsize;	/* constant or register holding the size
+				   of this dimension */
+		expptr dimexpr;	/* as above in basexpr, this is an
+				   expression for computing a variable
+				   dimension */
+		} dims[1];	/* Dimblocks are allocated with enough
+				   space for this to become dims[ndim] */
+	};
+
+
+/* Statement function identifier stack - this holds the name and value of
+   the parameters in a statement function invocation.  For example,
+
+	f(x,y,z)=x+y+z
+		.
+		.
+	y = f(1,2,3)
+
+   generates a stack of depth 3, with <x 1>, <y 2>, <z 3> AT THE INVOCATION, NOT
+   at the definition */
+
+struct Rplblock	/* name replacement block */
+	{
+	struct Rplblock *rplnextp;
+	Namep rplnp;		/* Name of the formal parameter */
+	expptr rplvp;		/* Value of the actual parameter */
+	expptr rplxp;		/* Initialization of temporary variable,
+				   if required; else null */
+	int rpltag;		/* Tag on the value of the actual param */
+	};
+
+
+
+/* Equivalence block */
+
+struct Equivblock
+	{
+	struct Eqvchain *equivs;	/* List (Eqvchain) of primblocks
+					   holding variable identifiers */
+	flag eqvinit;
+	long int eqvtop;
+	long int eqvbottom;
+	int eqvtype;
+	} ;
+#define eqvleng eqvtop
+
+extern struct Equivblock *eqvclass;
+
+
+struct Eqvchain
+	{
+	struct Eqvchain *eqvnextp;
+	union
+		{
+		struct Primblock *eqvlhs;
+		Namep eqvname;
+		} eqvitem;
+	long int eqvoffset;
+	} ;
+
+
+
+/* For allocation purposes only, and to keep lint quiet.  In particular,
+   don't count on the tag being able to tell you which structure is used */
+
+
+/* There is a tradition in Fortran that the compiler not generate the same
+   bit pattern more than is necessary.  This structure is used to do just
+   that; if two integer constants have the same bit pattern, just generate
+   it once.  This could be expanded to optimize without regard to type, by
+   removing the type check in   putconst()   */
+
+struct Literal
+	{
+	short littype;
+	short litnum;			/* numeric part of the assembler
+					   label for this constant value */
+	int lituse;		/* usage count */
+	union	{
+		ftnint litival;
+		double litdval[2];
+		ftnint litival2[2];	/* length, nblanks for strings */
+		} litval;
+	char *cds[2];
+	};
+
+extern struct Literal *litpool;
+extern int maxliterals, nliterals;
+extern char Letters[];
+#define letter(x) Letters[x]
+
+struct Dims { expptr lb, ub; };
+
+
+/* popular functions with non integer return values */
+
+
+int *ckalloc();
+char *varstr(), *nounder(), *addunder();
+char *copyn(), *copys();
+chainp hookup(), mkchain(), revchain();
+ftnint convci();
+char *convic();
+char *setdoto();
+double convcd();
+Namep mkname();
+struct Labelblock *mklabel(), *execlab();
+Extsym *mkext(), *newentry();
+expptr addrof(), call1(), call2(), call3(), call4();
+Addrp builtin(), mktmp(), mktmp0(), mktmpn(), autovar();
+Addrp mkplace(), mkaddr(), putconst(), memversion();
+expptr mkprim(), mklhs(), mkexpr(), mkconv(), mkfunct(), fixexpr(), fixtype();
+expptr errnode(), mkaddcon(), mkintcon(), putcxop();
+tagptr cpexpr();
+ftnint lmin(), lmax(), iarrlen();
+char *dbconst(), *flconst();
+
+void puteq (), putex1 ();
+expptr putx (), putsteq (), putassign ();
+
+extern int forcedouble;		/* force real functions to double */
+extern int doin_setbound;	/* special handling for array bounds */
+extern int Ansi;
+extern char *cds(), *cpstring(), *dtos(), *string_num();
+extern char *c_type_decl();
+extern char hextoi_tab[];
+#define hextoi(x) hextoi_tab[(x) & 0xff]
+extern char *casttypes[], *ftn_types[], *protorettypes[], *usedcasts[];
+extern int Castargs, infertypes;
+extern FILE *protofile;
+extern void exit(), inferdcl(), protowrite(), save_argtypes();
+extern char binread[], binwrite[], textread[], textwrite[];
+extern char *ei_first, *ei_last, *ei_next;
+extern char *wh_first, *wh_last, *wh_next;
+extern void putwhile();
+extern char *halign;

lang/fortran/comp/equiv.c

@@ -0,0 +1,372 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+
+LOCAL eqvcommon(), eqveqv(), nsubs();
+
+/* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */
+
+/* called at end of declarations section to process chains
+   created by EQUIVALENCE statements
+ */
+doequiv()
+{
+	register int i;
+	int inequiv;			/* True if one namep occurs in
+					   several EQUIV declarations */
+	int comno;		/* Index into Extsym table of the last
+				   COMMON block seen (implicitly assuming
+				   that only one will be given) */
+	int ovarno;
+	ftnint comoffset;	/* Index into the COMMON block */
+	ftnint offset;		/* Offset from array base */
+	ftnint leng;
+	register struct Equivblock *equivdecl;
+	register struct Eqvchain *q;
+	struct Primblock *primp;
+	register Namep np;
+	int k, k1, ns, pref, t;
+	chainp cp;
+	extern int type_pref[];
+
+	for(i = 0 ; i < nequiv ; ++i)
+	{
+
+/* Handle each equivalence declaration */
+
+		equivdecl = &eqvclass[i];
+		equivdecl->eqvbottom = equivdecl->eqvtop = 0;
+		comno = -1;
+
+
+
+		for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
+		{
+			offset = 0;
+			primp = q->eqvitem.eqvlhs;
+			vardcl(np = primp->namep);
+			if(primp->argsp || primp->fcharp)
+			{
+				expptr offp, suboffset();
+
+/* Pad ones onto the end of an array declaration when needed */
+
+				if(np->vdim!=NULL && np->vdim->ndim>1 &&
+				    nsubs(primp->argsp)==1 )
+				{
+					if(! ftn66flag)
+						warni
+			("1-dim subscript in EQUIVALENCE, %d-dim declared",
+						    np -> vdim -> ndim);
+					cp = NULL;
+					ns = np->vdim->ndim;
+					while(--ns > 0)
+						cp = mkchain((char *)ICON(1), cp);
+					primp->argsp->listp->nextp = cp;
+				}
+
+				offp = suboffset(primp);
+				if(ISICON(offp))
+					offset = offp->constblock.Const.ci;
+				else	{
+					dclerr
+			("nonconstant subscript in equivalence ",
+					    np);
+					np = NULL;
+				}
+				frexpr(offp);
+			}
+
+/* Free up the primblock, since we now have a hash table (Namep) entry */
+
+			frexpr((expptr)primp);
+
+			if(np && (leng = iarrlen(np))<0)
+			{
+				dclerr("adjustable in equivalence", np);
+				np = NULL;
+			}
+
+			if(np) switch(np->vstg)
+			{
+			case STGUNKNOWN:
+			case STGBSS:
+			case STGEQUIV:
+				break;
+
+			case STGCOMMON:
+
+/* The code assumes that all COMMON references in a given EQUIVALENCE will
+   be to the same COMMON block, and will all be consistent */
+
+				comno = np->vardesc.varno;
+				comoffset = np->voffset + offset;
+				break;
+
+			default:
+				dclerr("bad storage class in equivalence", np);
+				np = NULL;
+				break;
+			}
+
+			if(np)
+			{
+				q->eqvoffset = offset;
+
+/* eqvbottom   gets the largest difference between the array base address
+   and the address specified in the EQUIV declaration */
+
+				equivdecl->eqvbottom =
+				    lmin(equivdecl->eqvbottom, -offset);
+
+/* eqvtop   gets the largest difference between the end of the array and
+   the address given in the EQUIVALENCE */
+
+				equivdecl->eqvtop =
+				    lmax(equivdecl->eqvtop, leng-offset);
+			}
+			q->eqvitem.eqvname = np;
+		}
+
+/* Now all equivalenced variables are in the hash table with the proper
+   offset, and   eqvtop and eqvbottom   are set. */
+
+		if(comno >= 0)
+
+/* Get rid of all STGEQUIVS, they will be mapped onto STGCOMMON variables
+   */
+
+			eqvcommon(equivdecl, comno, comoffset);
+		else for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
+		{
+			if(np = q->eqvitem.eqvname)
+			{
+				inequiv = NO;
+				if(np->vstg==STGEQUIV)
+					if( (ovarno = np->vardesc.varno) == i)
+					{
+
+/* Can't EQUIV different elements of the same array */
+
+						if(np->voffset + q->eqvoffset != 0)
+							dclerr
+			("inconsistent equivalence", np);
+					}
+					else	{
+						offset = np->voffset;
+						inequiv = YES;
+					}
+
+				np->vstg = STGEQUIV;
+				np->vardesc.varno = i;
+				np->voffset = - q->eqvoffset;
+
+				if(inequiv)
+
+/* Combine 2 equivalence declarations */
+
+					eqveqv(i, ovarno, q->eqvoffset + offset);
+			}
+		}
+	}
+
+/* Now each equivalence declaration is distinct (all connections have been
+   merged in eqveqv()), and some may be empty. */
+
+	for(i = 0 ; i < nequiv ; ++i)
+	{
+		equivdecl = & eqvclass[i];
+		if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) {
+
+/* a live chain */
+
+			k = TYCHAR;
+			pref = 1;
+			for(q = equivdecl->equivs ; q; q = q->eqvnextp)
+			    if (np = q->eqvitem.eqvname){
+				np->voffset -= equivdecl->eqvbottom;
+				t = typealign[k1 = np->vtype];
+				if (pref < type_pref[k1]) {
+					k = k1;
+					pref = type_pref[k1];
+					}
+				if(np->voffset % t != 0) {
+					dclerr("bad alignment forced by equivalence", np);
+					--nerr; /* don't give bad return code for this */
+					}
+				}
+			equivdecl->eqvtype = k;
+		}
+		freqchain(equivdecl);
+	}
+}
+
+
+
+
+
+/* put equivalence chain p at common block comno + comoffset */
+
+LOCAL eqvcommon(p, comno, comoffset)
+struct Equivblock *p;
+int comno;
+ftnint comoffset;
+{
+	int ovarno;
+	ftnint k, offq;
+	register Namep np;
+	register struct Eqvchain *q;
+
+	if(comoffset + p->eqvbottom < 0)
+	{
+		errstr("attempt to extend common %s backward",
+		    extsymtab[comno].fextname);
+		freqchain(p);
+		return;
+	}
+
+	if( (k = comoffset + p->eqvtop) > extsymtab[comno].extleng)
+		extsymtab[comno].extleng = k;
+
+
+	for(q = p->equivs ; q ; q = q->eqvnextp)
+		if(np = q->eqvitem.eqvname)
+		{
+			switch(np->vstg)
+			{
+			case STGUNKNOWN:
+			case STGBSS:
+				np->vstg = STGCOMMON;
+				np->vcommequiv = 1;
+				np->vardesc.varno = comno;
+
+/* np -> voffset   will point to the base of the array */
+
+				np->voffset = comoffset - q->eqvoffset;
+				break;
+
+			case STGEQUIV:
+				ovarno = np->vardesc.varno;
+
+/* offq   will point to the current element, even if it's in an array */
+
+				offq = comoffset - q->eqvoffset - np->voffset;
+				np->vstg = STGCOMMON;
+				np->vcommequiv = 1;
+				np->vardesc.varno = comno;
+
+/* np -> voffset   will point to the base of the array */
+
+				np->voffset += offq;
+				if(ovarno != (p - eqvclass))
+					eqvcommon(&eqvclass[ovarno], comno, offq);
+				break;
+
+			case STGCOMMON:
+				if(comno != np->vardesc.varno ||
+				    comoffset != np->voffset+q->eqvoffset)
+					dclerr("inconsistent common usage", np);
+				break;
+
+
+			default:
+				badstg("eqvcommon", np->vstg);
+			}
+		}
+
+	freqchain(p);
+	p->eqvbottom = p->eqvtop = 0;
+}
+
+
+/* Move all items on ovarno chain to the front of   nvarno   chain.
+ * adjust offsets of ovarno elements and top and bottom of nvarno chain
+ */
+
+LOCAL eqveqv(nvarno, ovarno, delta)
+int ovarno, nvarno;
+ftnint delta;
+{
+	register struct Equivblock *neweqv, *oldeqv;
+	register Namep np;
+	struct Eqvchain *q, *q1;
+
+	neweqv = eqvclass + nvarno;
+	oldeqv = eqvclass + ovarno;
+	neweqv->eqvbottom = lmin(neweqv->eqvbottom, oldeqv->eqvbottom - delta);
+	neweqv->eqvtop = lmax(neweqv->eqvtop, oldeqv->eqvtop - delta);
+	oldeqv->eqvbottom = oldeqv->eqvtop = 0;
+
+	for(q = oldeqv->equivs ; q ; q = q1)
+	{
+		q1 = q->eqvnextp;
+		if( (np = q->eqvitem.eqvname) && np->vardesc.varno==ovarno)
+		{
+			q->eqvnextp = neweqv->equivs;
+			neweqv->equivs = q;
+			q->eqvoffset += delta;
+			np->vardesc.varno = nvarno;
+			np->voffset -= delta;
+		}
+		else	free( (charptr) q);
+	}
+	oldeqv->equivs = NULL;
+}
+
+
+
+
+freqchain(p)
+register struct Equivblock *p;
+{
+	register struct Eqvchain *q, *oq;
+
+	for(q = p->equivs ; q ; q = oq)
+	{
+		oq = q->eqvnextp;
+		free( (charptr) q);
+	}
+	p->equivs = NULL;
+}
+
+
+
+
+
+/* nsubs -- number of subscripts in this arglist (just the length of the
+   list) */
+
+LOCAL nsubs(p)
+register struct Listblock *p;
+{
+	register int n;
+	register chainp q;
+
+	n = 0;
+	if(p)
+		for(q = p->listp ; q ; q = q->nextp)
+			++n;
+
+	return(n);
+}

lang/fortran/comp/error.c

@@ -0,0 +1,252 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+
+warni(s,t)
+ char *s;
+ int t;
+{
+	char buf[100];
+	sprintf(buf,s,t);
+	warn(buf);
+	}
+
+warn1(s,t)
+char *s, *t;
+{
+	char buff[100];
+	sprintf(buff, s, t);
+	warn(buff);
+}
+
+
+warn(s)
+char *s;
+{
+	if(nowarnflag)
+		return;
+	if (infname && *infname)
+		fprintf(diagfile, "Warning on line %ld of %s: %s\n",
+			lineno, infname, s);
+	else
+		fprintf(diagfile, "Warning on line %ld: %s\n", lineno, s);
+	fflush(diagfile);
+	++nwarn;
+}
+
+
+errstr(s, t)
+char *s, *t;
+{
+	char buff[100];
+	sprintf(buff, s, t);
+	err(buff);
+}
+
+
+
+erri(s,t)
+char *s;
+int t;
+{
+	char buff[100];
+	sprintf(buff, s, t);
+	err(buff);
+}
+
+errl(s,t)
+char *s;
+long t;
+{
+	char buff[100];
+	sprintf(buff, s, t);
+	err(buff);
+}
+
+ char *err_proc = 0;
+
+err(s)
+char *s;
+{
+	if (err_proc)
+		fprintf(diagfile,
+			"Error processing %s before line %ld",
+			err_proc, lineno);
+	else
+		fprintf(diagfile, "Error on line %ld", lineno);
+	if (infname && *infname)
+		fprintf(diagfile, " of %s", infname);
+	fprintf(diagfile, ": %s\n", s);
+	fflush(diagfile);
+	++nerr;
+}
+
+
+yyerror(s)
+char *s;
+{
+	err(s);
+}
+
+
+
+dclerr(s, v)
+char *s;
+Namep v;
+{
+	char buff[100];
+
+	if(v)
+	{
+		sprintf(buff, "Declaration error for %s: %s", v->fvarname, s);
+		err(buff);
+	}
+	else
+		errstr("Declaration error %s", s);
+}
+
+
+
+execerr(s, n)
+char *s, *n;
+{
+	char buf1[100], buf2[100];
+
+	sprintf(buf1, "Execution error %s", s);
+	sprintf(buf2, buf1, n);
+	err(buf2);
+}
+
+
+Fatal(t)
+char *t;
+{
+	fprintf(diagfile, "Compiler error line %ld", lineno);
+	if (infname)
+		fprintf(diagfile, " of %s", infname);
+	fprintf(diagfile, ": %s\n", t);
+	done(3);
+}
+
+
+
+
+fatalstr(t,s)
+char *t, *s;
+{
+	char buff[100];
+	sprintf(buff, t, s);
+	Fatal(buff);
+}
+
+
+
+fatali(t,d)
+char *t;
+int d;
+{
+	char buff[100];
+	sprintf(buff, t, d);
+	Fatal(buff);
+}
+
+
+
+badthing(thing, r, t)
+char *thing, *r;
+int t;
+{
+	char buff[50];
+	sprintf(buff, "Impossible %s %d in routine %s", thing, t, r);
+	Fatal(buff);
+}
+
+
+
+badop(r, t)
+char *r;
+int t;
+{
+	badthing("opcode", r, t);
+}
+
+
+
+badtag(r, t)
+char *r;
+int t;
+{
+	badthing("tag", r, t);
+}
+
+
+
+
+
+badstg(r, t)
+char *r;
+int t;
+{
+	badthing("storage class", r, t);
+}
+
+
+
+
+badtype(r, t)
+char *r;
+int t;
+{
+	badthing("type", r, t);
+}
+
+
+many(s, c, n)
+char *s, c;
+int n;
+{
+	char buff[250];
+
+	sprintf(buff,
+	    "Too many %s.\nTable limit now %d.\nTry recompiling using the -N%c%d option\n",
+	    s, n, c, 2*n);
+	Fatal(buff);
+}
+
+
+err66(s)
+char *s;
+{
+	errstr("Fortran 77 feature used: %s", s);
+	--nerr;
+}
+
+
+
+errext(s)
+char *s;
+{
+	errstr("F77 compiler extension used: %s", s);
+	--nerr;
+}

lang/fortran/comp/exec.c

@@ -0,0 +1,831 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "p1defs.h"
+#include "names.h"
+
+LOCAL void exar2(), popctl(), pushctl();
+
+/*   Logical IF codes
+*/
+
+
+exif(p)
+expptr p;
+{
+    pushctl(CTLIF);
+    putif(p, 0);	/* 0 => if, not elseif */
+}
+
+
+
+exelif(p)
+expptr p;
+{
+    if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
+	putif(p, 1);	/* 1 ==> elseif */
+    else
+	execerr("elseif out of place", CNULL);
+}
+
+
+
+
+
+exelse()
+{
+	register struct Ctlframe *c;
+
+	for(c = ctlstack; c->ctltype == CTLIFX; --c);
+	if(c->ctltype == CTLIF) {
+		p1_else ();
+		c->ctltype = CTLELSE;
+		}
+	else
+		execerr("else out of place", CNULL);
+	}
+
+
+exendif()
+{
+	while(ctlstack->ctltype == CTLIFX) {
+		popctl();
+		p1else_end();
+		}
+	if(ctlstack->ctltype == CTLIF) {
+		popctl();
+		p1_endif ();
+		}
+	else if(ctlstack->ctltype == CTLELSE) {
+		popctl();
+		p1else_end ();
+		}
+	else
+		execerr("endif out of place", CNULL);
+	}
+
+
+new_endif()
+{
+	if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
+		pushctl(CTLIFX);
+	else
+		err("new_endif bug");
+	}
+
+/* pushctl -- Start a new control construct, initialize the labels (to
+   zero) */
+
+ LOCAL void
+pushctl(code)
+ int code;
+{
+	register int i;
+
+	if(++ctlstack >= lastctl)
+		many("loops or if-then-elses", 'c', maxctl);
+	ctlstack->ctltype = code;
+	for(i = 0 ; i < 4 ; ++i)
+		ctlstack->ctlabels[i] = 0;
+	ctlstack->dowhile = 0;
+	++blklevel;
+}
+
+
+ LOCAL void
+popctl()
+{
+	if( ctlstack-- < ctls )
+		Fatal("control stack empty");
+	--blklevel;
+}
+
+
+
+/* poplab -- update the flags in   labeltab   */
+
+LOCAL poplab()
+{
+	register struct Labelblock  *lp;
+
+	for(lp = labeltab ; lp < highlabtab ; ++lp)
+		if(lp->labdefined)
+		{
+			/* mark all labels in inner blocks unreachable */
+			if(lp->blklevel > blklevel)
+				lp->labinacc = YES;
+		}
+		else if(lp->blklevel > blklevel)
+		{
+			/* move all labels referred to in inner blocks out a level */
+			lp->blklevel = blklevel;
+		}
+}
+
+
+/*  BRANCHING CODE
+*/
+
+exgoto(lab)
+struct Labelblock *lab;
+{
+	lab->labused = 1;
+	p1_goto (lab -> stateno);
+}
+
+
+
+
+
+
+
+exequals(lp, rp)
+register struct Primblock *lp;
+register expptr rp;
+{
+	if(lp->tag != TPRIM)
+	{
+		err("assignment to a non-variable");
+		frexpr((expptr)lp);
+		frexpr(rp);
+	}
+	else if(lp->namep->vclass!=CLVAR && lp->argsp)
+	{
+		if(parstate >= INEXEC)
+			err("statement function amid executables");
+		mkstfunct(lp, rp);
+	}
+	else
+	{
+		expptr new_lp, new_rp;
+
+		if(parstate < INDATA)
+			enddcl();
+		new_lp = mklhs (lp);
+		new_rp = fixtype (rp);
+		puteq(new_lp, new_rp);
+	}
+}
+
+
+
+/* Make Statement Function */
+
+long laststfcn = -1, thisstno;
+int doing_stmtfcn;
+
+mkstfunct(lp, rp)
+struct Primblock *lp;
+expptr rp;
+{
+	register struct Primblock *p;
+	register Namep np;
+	chainp args;
+
+	laststfcn = thisstno;
+	np = lp->namep;
+	if(np->vclass == CLUNKNOWN)
+		np->vclass = CLPROC;
+	else
+	{
+		dclerr("redeclaration of statement function", np);
+		return;
+	}
+	np->vprocclass = PSTFUNCT;
+	np->vstg = STGSTFUNCT;
+
+/* Set the type of the function */
+
+	impldcl(np);
+	if (np->vtype == TYCHAR && !np->vleng)
+		err("character statement function with length (*)");
+	args = (lp->argsp ? lp->argsp->listp : CHNULL);
+	np->varxptr.vstfdesc = mkchain((char *)args, (chainp)rp);
+
+	for(doing_stmtfcn = 1 ; args ; args = args->nextp)
+
+/* It is an error for the formal parameters to have arguments or
+   subscripts */
+
+		if( ((tagptr)(args->datap))->tag!=TPRIM ||
+		    (p = (struct Primblock *)(args->datap) )->argsp ||
+		    p->fcharp || p->lcharp )
+			err("non-variable argument in statement function definition");
+		else
+		{
+
+/* Replace the name on the left-hand side */
+
+			args->datap = (char *)p->namep;
+			vardcl(p -> namep);
+			free((char *)p);
+		}
+	doing_stmtfcn = 0;
+}
+
+ static void
+mixed_type(np)
+ Namep np;
+{
+	char buf[128];
+	sprintf(buf, "%s function %.90s invoked as subroutine",
+		ftn_types[np->vtype], np->fvarname);
+	warn(buf);
+	}
+
+
+excall(name, args, nstars, labels)
+Namep name;
+struct Listblock *args;
+int nstars;
+struct Labelblock *labels[ ];
+{
+	register expptr p;
+
+	if (name->vtype != TYSUBR) {
+		if (name->vinfproc && !name->vcalled) {
+			name->vtype = TYSUBR;
+			frexpr(name->vleng);
+			name->vleng = 0;
+			}
+		else if (!name->vimpltype && name->vtype != TYUNKNOWN)
+			mixed_type(name);
+		else
+			settype(name, TYSUBR, (ftnint)0);
+		}
+	p = mkfunct( mkprim(name, args, CHNULL) );
+
+/* Subroutines and their identifiers acquire the type INT */
+
+	p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
+
+/* Handle the alternate return mechanism */
+
+	if(nstars > 0)
+		putcmgo(putx(fixtype(p)), nstars, labels);
+	else
+		putexpr(p);
+}
+
+
+
+exstop(stop, p)
+int stop;
+register expptr p;
+{
+	char *str;
+	int n;
+	expptr mkstrcon();
+
+	if(p)
+	{
+		if( ! ISCONST(p) )
+		{
+			execerr("pause/stop argument must be constant", CNULL);
+			frexpr(p);
+			p = mkstrcon(0, CNULL);
+		}
+		else if( ISINT(p->constblock.vtype) )
+		{
+			str = convic(p->constblock.Const.ci);
+			n = strlen(str);
+			if(n > 0)
+			{
+				p->constblock.Const.ccp = copyn(n, str);
+				p->constblock.Const.ccp1.blanks = 0;
+				p->constblock.vtype = TYCHAR;
+				p->constblock.vleng = (expptr) ICON(n);
+			}
+			else
+				p = (expptr) mkstrcon(0, CNULL);
+		}
+		else if(p->constblock.vtype != TYCHAR)
+		{
+			execerr("pause/stop argument must be integer or string", CNULL);
+			p = (expptr) mkstrcon(0, CNULL);
+		}
+	}
+	else	p = (expptr) mkstrcon(0, CNULL);
+
+    {
+	expptr subr_call;
+
+	subr_call = call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p);
+	putexpr( subr_call );
+    }
+}
+
+/* DO LOOP CODE */
+
+#define DOINIT	par[0]
+#define DOLIMIT	par[1]
+#define DOINCR	par[2]
+
+
+/* Macros for   ctlstack -> dostepsign   */
+
+#define VARSTEP	0
+#define POSSTEP	1
+#define NEGSTEP	2
+
+
+/* exdo -- generate DO loop code.  In the case of a variable increment,
+   positive increment tests are placed above the body, negative increment
+   tests are placed below (see   enddo()   ) */
+
+exdo(range, loopname, spec)
+int range;			/* end label */
+Namep loopname;
+chainp spec;			/* input spec must have at least 2 exprs */
+{
+	register expptr p;
+	register Namep np;
+	chainp cp;		/* loops over the fields in   spec */
+	register int i;
+	int dotype;		/* type of the index variable */
+	int incsign;		/* sign of the increment, if it's constant
+				   */
+	Addrp dovarp;		/* loop index variable */
+	expptr doinit;		/* constant or register for init param */
+	expptr par[3];		/* local specification parameters */
+
+	expptr init, test, inc;	/* Expressions in the resulting FOR loop */
+
+
+	test = ENULL;
+
+	pushctl(CTLDO);
+	dorange = ctlstack->dolabel = range;
+	ctlstack->loopname = loopname;
+
+/* Declare the loop index */
+
+	np = (Namep)spec->datap;
+	ctlstack->donamep = NULL;
+	if (!np) { /* do while */
+		ctlstack->dowhile = 1;
+#if 0
+		if (loopname) {
+			if (loopname->vtype == TYUNKNOWN) {
+				loopname->vdcldone = 1;
+				loopname->vclass = CLLABEL;
+				loopname->vprocclass = PLABEL;
+				loopname->vtype = TYLABEL;
+				}
+			if (loopname->vtype == TYLABEL)
+				if (loopname->vdovar)
+					dclerr("already in use as a loop name",
+						loopname);
+				else
+					loopname->vdovar = 1;
+			else
+				dclerr("already declared; cannot be a loop name",
+					loopname);
+			}
+#endif
+		putwhile((expptr)spec->nextp);
+		NOEXT("do while");
+		spec->nextp = 0;
+		frchain(&spec);
+		return;
+		}
+	if(np->vdovar)
+	{
+		errstr("nested loops with variable %s", np->fvarname);
+		ctlstack->donamep = NULL;
+		return;
+	}
+
+/* Create a memory-resident version of the index variable */
+
+	dovarp = mkplace(np);
+	if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) )
+	{
+		err("bad type on do variable");
+		return;
+	}
+	ctlstack->donamep = np;
+
+	np->vdovar = YES;
+
+/* Now   dovarp   points to the index to be used within the loop,   dostgp
+   points to the one which may need to be stored */
+
+	dotype = dovarp->vtype;
+
+/* Count the input specifications and type-check each one independently;
+   this just eliminates non-numeric values from the specification */
+
+	for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
+	{
+		p = par[i++] = fixtype((tagptr)cp->datap);
+		if( ! ONEOF(p->headblock.vtype, MSKINT|MSKREAL) )
+		{
+			err("bad type on DO parameter");
+			return;
+		}
+	}
+
+	frchain(&spec);
+	switch(i)
+	{
+	case 0:
+	case 1:
+		err("too few DO parameters");
+		return;
+
+	default:
+		err("too many DO parameters");
+		return;
+
+	case 2:
+		DOINCR = (expptr) ICON(1);
+
+	case 3:
+		break;
+	}
+
+
+/* Now all of the local specification fields are set, but their types are
+   not yet consistent */
+
+/* Declare the loop initialization value, casting it properly and declaring a
+   register if need be */
+
+	if (ISCONST (DOINIT) || !onetripflag)
+/* putx added 6-29-89 (mwm), not sure if fixtype is required, but I doubt it
+   since mkconv is called just before */
+		doinit = putx (mkconv (dotype, DOINIT));
+	else {
+	    doinit = (expptr) mktmp(dotype, ENULL);
+	    puteq (cpexpr (doinit), DOINIT);
+	} /* else */
+
+/* Declare the loop ending value, casting it to the type of the index
+   variable */
+
+	if( ISCONST(DOLIMIT) )
+		ctlstack->domax = mkconv(dotype, DOLIMIT);
+	else {
+		ctlstack->domax = (expptr) mktmp0(dotype, ENULL);
+		puteq (cpexpr (ctlstack -> domax), DOLIMIT);
+	} /* else */
+
+/* Declare the loop increment value, casting it to the type of the index
+   variable */
+
+	if( ISCONST(DOINCR) )
+	{
+		ctlstack->dostep = mkconv(dotype, DOINCR);
+		if( (incsign = conssgn(ctlstack->dostep)) == 0)
+			err("zero DO increment");
+		ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
+	}
+	else
+	{
+		ctlstack->dostep = (expptr) mktmp0(dotype, ENULL);
+		ctlstack->dostepsign = VARSTEP;
+		puteq (cpexpr (ctlstack -> dostep), DOINCR);
+	}
+
+/* All data is now properly typed and in the   ctlstack,   except for the
+   initial value.  Assignments of temps have been generated already */
+
+	switch (ctlstack -> dostepsign) {
+	    case VARSTEP:
+		test = mkexpr (OPQUEST, mkexpr (OPLT,
+			cpexpr (ctlstack -> dostep), ICON(0)),
+			mkexpr (OPCOLON,
+			    mkexpr (OPGE, cpexpr((expptr)dovarp),
+				    cpexpr (ctlstack -> domax)),
+			    mkexpr (OPLE, cpexpr((expptr)dovarp),
+				    cpexpr (ctlstack -> domax))));
+		break;
+	    case POSSTEP:
+	        test = mkexpr (OPLE, cpexpr((expptr)dovarp),
+			cpexpr (ctlstack -> domax));
+	        break;
+	    case NEGSTEP:
+	        test = mkexpr (OPGE, cpexpr((expptr)dovarp),
+			cpexpr (ctlstack -> domax));
+	        break;
+	    default:
+	        erri ("exdo:  bad dostepsign '%d'", ctlstack -> dostepsign);
+	        break;
+	} /* switch (ctlstack -> dostepsign) */
+
+	if (onetripflag)
+	    test = mkexpr (OPOR, test,
+		    mkexpr (OPEQ, cpexpr((expptr)dovarp), cpexpr (doinit)));
+	init = mkexpr (OPASSIGN, cpexpr((expptr)dovarp), doinit);
+	inc = mkexpr (OPPLUSEQ, (expptr)dovarp, cpexpr (ctlstack -> dostep));
+
+	if (!onetripflag && ISCONST (ctlstack -> domax) && ISCONST (doinit)
+		&& ctlstack -> dostepsign != VARSTEP) {
+	    expptr tester;
+
+	    tester = mkexpr (OPMINUS, cpexpr (doinit),
+		    cpexpr (ctlstack -> domax));
+	    if (incsign == conssgn (tester))
+		warn ("DO range never executed");
+	    frexpr (tester);
+	} /* if !onetripflag && */
+
+	p1_for (init, test, inc);
+}
+
+exenddo(np)
+ Namep np;
+{
+	Namep np1;
+	int here;
+	struct Ctlframe *cf;
+
+	if( ctlstack < ctls )
+		Fatal("control stack empty");
+	here = ctlstack->dolabel;
+	if (ctlstack->ctltype != CTLDO || here >= 0) {
+		err("misplaced ENDDO");
+		return;
+		}
+	if (np != ctlstack->loopname) {
+		if (np1 = ctlstack->loopname)
+			errstr("expected \"enddo %s\"", np1->fvarname);
+		else
+			err("expected unnamed ENDDO");
+		for(cf = ctls; cf < ctlstack; cf++)
+			if (cf->ctltype == CTLDO && cf->loopname == np) {
+				here = cf->dolabel;
+				break;
+				}
+		}
+	enddo(here);
+	}
+
+
+enddo(here)
+int here;
+{
+	register struct Ctlframe *q;
+	Namep np;			/* name of the current DO index */
+	Addrp ap;
+	register int i;
+	register expptr e;
+
+/* Many DO's can end at the same statement, so keep looping over all
+   nested indicies */
+
+	while(here == dorange)
+	{
+		if(np = ctlstack->donamep)
+			{
+			p1for_end ();
+
+/* Now we're done with all of the tests, and the loop has terminated.
+   Store the index value back in long-term memory */
+
+			if(ap = memversion(np))
+				puteq((expptr)ap, (expptr)mkplace(np));
+			for(i = 0 ; i < 4 ; ++i)
+				ctlstack->ctlabels[i] = 0;
+			deregister(ctlstack->donamep);
+			ctlstack->donamep->vdovar = NO;
+			e = ctlstack->dostep;
+			if (e->tag == TADDR && e->addrblock.istemp)
+				frtemp((Addrp)e);
+			else
+				frexpr(e);
+			e = ctlstack->domax;
+			if (e->tag == TADDR && e->addrblock.istemp)
+				frtemp((Addrp)e);
+			else
+				frexpr(e);
+			}
+		else if (ctlstack->dowhile)
+			p1for_end ();
+
+/* Set   dorange   to the closing label of the next most enclosing DO loop
+   */
+
+		popctl();
+		poplab();
+		dorange = 0;
+		for(q = ctlstack ; q>=ctls ; --q)
+			if(q->ctltype == CTLDO)
+			{
+				dorange = q->dolabel;
+				break;
+			}
+	}
+}
+
+exassign(vname, labelval)
+ register Namep vname;
+struct Labelblock *labelval;
+{
+	Addrp p;
+	expptr mkaddcon();
+	register Addrp q;
+	static char nullstr[] = "";
+	char *fs;
+	register chainp cp, cpprev;
+	register ftnint k, stno;
+
+	p = mkplace(vname);
+	if( ! ONEOF(p->vtype, MSKINT|MSKADDR) ) {
+		err("noninteger assign variable");
+		return;
+		}
+
+	/* If the label hasn't been defined, then we do things twice:
+	 * once for an executable stmt label, once for a format
+	 */
+
+	/* code for executable label... */
+
+/* Now store the assigned value in a list associated with this variable.
+   This will be used later to generate a switch() statement in the C output */
+
+	if (!labelval->labdefined || !labelval->fmtstring) {
+
+		if (vname -> vis_assigned == 0) {
+			vname -> varxptr.assigned_values = CHNULL;
+			vname -> vis_assigned = 1;
+			}
+
+		/* don't duplicate labels... */
+
+		stno = labelval->stateno;
+		cpprev = 0;
+		for(k = 0, cp = vname->varxptr.assigned_values;
+				cp; cpprev = cp, cp = cp->nextp, k++)
+			if ((ftnint)cp->datap == stno)
+				break;
+		if (!cp) {
+			cp = mkchain((char *)stno, CHNULL);
+			if (cpprev)
+				cpprev->nextp = cp;
+			else
+				vname->varxptr.assigned_values = cp;
+			labelval->labused = 1;
+			}
+		putout(mkexpr(OPASSIGN, (expptr)p, mkintcon(k)));
+		}
+
+	/* Code for FORMAT label... */
+
+	fs = labelval->fmtstring;
+	if (!labelval->labdefined || fs && fs != nullstr) {
+		extern void fmtname();
+
+		if (!fs)
+			labelval->fmtstring = nullstr;
+		labelval->fmtlabused = 1;
+		p = ALLOC(Addrblock);
+		p->tag = TADDR;
+		p->vtype = TYCHAR;
+		p->vstg = STGAUTO;
+		p->memoffset = ICON(0);
+		fmtname(vname, p);
+		q = ALLOC(Addrblock);
+		q->tag = TADDR;
+		q->vtype = TYCHAR;
+		q->vstg = STGAUTO;
+		q->ntempelt = 1;
+		q->memoffset = ICON(0);
+		q->uname_tag = UNAM_IDENT;
+		sprintf(q->user.ident, "fmt_%ld", labelval->stateno);
+		putout(mkexpr(OPASSIGN, (expptr)p, (expptr)q));
+		}
+
+} /* exassign */
+
+
+
+exarif(expr, neglab, zerlab, poslab)
+expptr expr;
+struct Labelblock *neglab, *zerlab, *poslab;
+{
+    register int lm, lz, lp;
+
+    lm = neglab->stateno;
+    lz = zerlab->stateno;
+    lp = poslab->stateno;
+    expr = fixtype(expr);
+
+    if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) )
+    {
+        err("invalid type of arithmetic if expression");
+        frexpr(expr);
+    }
+    else
+    {
+        if (lm == lz && lz == lp)
+            exgoto (neglab);
+        else if(lm == lz)
+            exar2(OPLE, expr, neglab, poslab);
+        else if(lm == lp)
+            exar2(OPNE, expr, neglab, zerlab);
+        else if(lz == lp)
+            exar2(OPGE, expr, zerlab, neglab);
+        else {
+            expptr t;
+
+	    if (!addressable (expr)) {
+		t = (expptr) mktmp(expr -> headblock.vtype, ENULL);
+		expr = mkexpr (OPASSIGN, cpexpr (t), expr);
+	    } else
+		t = (expptr) cpexpr (expr);
+
+	    p1_if(putx(fixtype(mkexpr (OPLT, expr, ICON (0)))));
+	    exgoto(neglab);
+	    p1_elif (mkexpr (OPEQ, t, ICON (0)));
+	    exgoto(zerlab);
+	    p1_else ();
+	    exgoto(poslab);
+	    p1else_end ();
+        } /* else */
+    }
+}
+
+
+
+/* exar2 -- Do arithmetic IF for only 2 distinct labels;   if !(e.op.0)
+   goto l2 else goto l1.  If this seems backwards, that's because it is,
+   in order to make the 1 pass algorithm work. */
+
+ LOCAL void
+exar2(op, e, l1, l2)
+ int op;
+ expptr e;
+ struct Labelblock *l1, *l2;
+{
+	expptr comp;
+
+	comp = mkexpr (op, e, ICON (0));
+	p1_if(putx(fixtype(comp)));
+	exgoto(l1);
+	p1_else ();
+	exgoto(l2);
+	p1else_end ();
+}
+
+
+/* exreturn -- return the value in   p  from a SUBROUTINE call -- used to
+   implement the alternate return mechanism */
+
+exreturn(p)
+register expptr p;
+{
+	if(procclass != CLPROC)
+		warn("RETURN statement in main or block data");
+	if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
+	{
+		err("alternate return in nonsubroutine");
+		p = 0;
+	}
+
+	if (p || proctype == TYSUBR) {
+		if (p == ENULL) p = ICON (0);
+		p = mkconv (TYLONG, fixtype (p));
+		p1_subr_ret (p);
+	} /* if p || proctype == TYSUBR */
+	else
+	    p1_subr_ret((expptr)retslot);
+}
+
+
+exasgoto(labvar)
+Namep labvar;
+{
+	register Addrp p;
+	void p1_asgoto();
+
+	p = mkplace(labvar);
+	if( ! ISINT(p->vtype) )
+		err("assigned goto variable must be integer");
+	else {
+		p1_asgoto (p);
+	} /* else */
+}

lang/fortran/comp/f2c.1

@@ -0,0 +1,182 @@
+
+     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
+	  current 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
+	       suppressed.
+
+	  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		       Tenth Edition	     (printed 4/25/91)
+
+     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.
+
+	  -g   Include original	Fortran	line numbers as	comments.
+
+	  -h   Try to align character strings on word (or, if the
+	       option is `-hd',	on double-word)	boundaries.
+
+	  -i2  Similar to -I2, but assume a modified libF77 and	libI77
+	       (compiled with -Df2c_i2), so INTEGER and	LOGICAL	vari-
+	       ables may be assigned by	INQUIRE	and array lengths are
+	       stored in short ints.
+
+	  -kr  Use temporary values to enforce Fortran expression
+	       evaluation where	K&R (first edition) parenthesization
+	       rules allow rearrangement.  If the option is `-krd',
+	       use double precision temporaries	even for single-
+	       precision operands.
+
+	  -P   Write a file.P of ANSI (or C++) prototypes for pro-
+	       cedures defined in each input file.f or file.F.	When
+	       reading Fortran from standard input, write prototypes
+	       at the beginning	of standard output.  Implies -A	unless
+	       option `-C++' is	present.  Option -Ps implies -P	, and
+	       gives exit status 4 if rerunning	f2c may	change proto-
+	       types or	declarations.
+
+	  -p   Supply preprocessor definitions to make common-block
+	       members look like local variables.
+
+	  -R   Do not promote REAL functions and operations to DOUBLE
+	       PRECISION.  Option `-!R'	confirms the default, which
+	       imitates	f77.
+
+	  -r   Cast values of REAL functions (including	intrinsics) to
+	       REAL.
+
+	  -r8  Promote REAL to DOUBLE PRECISION, COMPLEX to DOUBLE
+	       COMPLEX.
+
+	  -Tdir
+	       Put temporary files in directory	dir.
+
+	  -w8  Suppress	warnings when COMMON or	EQUIVALENCE forces
+	       odd-word	alignment of doubles.
+
+     Page 2		       Tenth Edition	     (printed 4/25/91)
+
+     F2C(1)							F2C(1)
+
+	  -Wn  Assume n	characters/word	(default 4) when initializing
+	       numeric variables with character	data.
+
+	  -z   Do not implicitly recognize DOUBLE COMPLEX.
+
+	  -!bs Do not recognize	backslash escapes (\", \', \0, \\, \b,
+	       \f, \n, \r, \t, \v) in character	strings.
+
+	  -!c  Inhibit C output, but produce -P	output.
+
+	  -!I  Reject include statements.
+
+	  -!it Don't infer types of untyped EXTERNAL procedures	from
+	       use as parameters to previously defined or prototyped
+	       procedures.
+
+	  -!P  Do not attempt to infer ANSI or C++ prototypes from
+	       usage.
+
+	  The resulting	C invokes the support routines of f77; object
+	  code should be loaded	by f77 or with ld(1) or	cc(1) options
+	  -lF77	-lI77 -lm.  Calling conventions	are those of f77: see
+	  the reference	below.
+
+     FILES
+	  file.[fF]
+	       input file
+
+	  *.c  output file
+
+	  /usr/include/f2c.h
+	       header file
+
+	  /usr/lib/libF77.a
+	       intrinsic function library
+
+	  /usr/lib/libI77.a
+	       Fortran I/O library
+
+	  /lib/libc.a
+	       C library, see section 3
+
+     SEE ALSO
+	  S. I.	Feldman	and P. J. Weinberger, `A Portable Fortran 77
+	  Compiler', UNIX Time Sharing System Programmer's Manual,
+	  Tenth	Edition, Volume	2, AT&T	Bell Laboratories, 1990.
+
+     DIAGNOSTICS
+	  The diagnostics produced by f2c are intended to be self-
+	  explanatory.
+
+     BUGS
+
+     Page 3		       Tenth Edition	     (printed 4/25/91)
+
+     F2C(1)							F2C(1)
+
+	  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		       Tenth Edition	     (printed 4/25/91)
+

lang/fortran/comp/f2c.1t

@@ -0,0 +1,326 @@
+. \" 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 -g
+Include original Fortran line numbers as comments.
+.TP
+.B -h
+Try to align character strings on word (or, if the option is
+.LR -hd ,
+on double-word) boundaries.
+.TP
+.B -i2
+Similar to
+.BR -I2 ,
+but assume a modified
+.I libF77
+and
+.I libI77
+(compiled with
+.BR -Df\^2c_i2 ),
+so
+.SM INTEGER
+and
+.SM LOGICAL
+variables may be assigned by
+.SM INQUIRE
+and array lengths are stored in short ints.
+.TP
+.B -kr
+Use temporary values to enforce Fortran expression evaluation
+where K&R (first edition) parenthesization rules allow rearrangement.
+If the option is
+.LR -krd ,
+use double precision temporaries even for single-precision operands.
+.TP
+.B -P
+Write a
+.IB file .P
+of ANSI (or C++) prototypes
+for procedures defined in each input
+.IB file .f
+or
+.IB file .F .
+When reading Fortran from standard input, write prototypes
+at the beginning of standard output.
+Implies
+.B -A
+unless option
+.L -C++
+is present.  Option
+.B -Ps
+implies
+.B -P ,
+and gives exit status 4 if rerunning
+.I f\^2c
+may change prototypes or declarations.
+.TP
+.B -p
+Supply preprocessor definitions to make common-block members
+look like local variables.
+.TP
+.B -R
+Do not promote
+.SM REAL
+functions and operations to
+.SM DOUBLE PRECISION.
+Option
+.L -!R
+confirms the default, which imitates
+.IR f\^77 .
+.TP
+.B -r
+Cast values of REAL functions (including intrinsics) to REAL.
+.TP
+.B -r8
+Promote
+.SM REAL
+to
+.SM DOUBLE PRECISION, COMPLEX
+to
+.SM DOUBLE COMPLEX.
+.TP
+.BI -T dir
+Put temporary files in directory
+.I dir.
+.TP
+.B -w8
+Suppress warnings when
+.SM COMMON
+or
+.SM EQUIVALENCE
+forces odd-word alignment of doubles.
+.TP
+.BI -W n
+Assume
+.I n
+characters/word (default 4)
+when initializing numeric variables with character data.
+.TP
+.B -z
+Do not implicitly recognize
+.SM DOUBLE COMPLEX.
+.TP
+.B -!bs
+Do not recognize \fIb\fRack\fIs\fRlash escapes
+(\e", \e', \e0, \e\e, \eb, \ef, \en, \er, \et, \ev) in character strings.
+.TP
+.B -!c
+Inhibit C output, but produce
+.B -P
+output.
+.TP
+.B -!I
+Reject
+.B include
+statements.
+.TP
+.B -!it
+Don't infer types of untyped
+.SM EXTERNAL
+procedures from use as parameters to previously defined or prototyped
+procedures.
+.TP
+.B -!P
+Do not attempt to infer
+.SM ANSI
+or C++
+prototypes from usage.
+.PP
+The resulting C invokes the support routines of
+.IR f\^77 ;
+object code should be loaded by
+.I f\^77
+or with
+.IR ld (1)
+or
+.IR cc (1)
+options
+.BR "-lF77 -lI77 -lm" .
+Calling conventions
+are those of
+.IR f\&77 :
+see the reference below.
+.br
+.SH FILES
+.TP
+.IB file .[fF]
+input file
+.TP
+.B *.c
+output file
+.TP
+.F /usr/include/f2c.h
+header file
+.TP
+.F /usr/lib/libF77.a
+intrinsic function library
+.TP
+.F /usr/lib/libI77.a
+Fortran I/O library
+.TP
+.F /lib/libc.a
+C library, see section 3
+.SH "SEE ALSO"
+S. I. Feldman and
+P. J. Weinberger,
+`A Portable Fortran 77 Compiler',
+\fIUNIX Time Sharing System Programmer's Manual\fR,
+Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990.
+.SH DIAGNOSTICS
+The diagnostics produced by
+.I f\^2c
+are intended to be
+self-explanatory.
+.SH BUGS
+Floating-point constant expressions are simplified in
+the floating-point arithmetic of the machine running
+.IR f\^2c ,
+so they are typically accurate to at most 16 or 17 decimal places.
+.br
+Untypable
+.SM EXTERNAL
+functions are declared
+.BR int .

lang/fortran/comp/f2c.6

@@ -0,0 +1,317 @@
+. \" 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 6
+.CT 1 prog_other
+.SH NAME
+f\^2c \(mi Convert Fortran 77 to C or C++
+.SH SYNOPSIS
+.B ~em/lib.bin/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 -g
+Include original Fortran line numbers as comments.
+.TP
+.B -h
+Try to align character strings on word (or, if the option is
+.LR -hd ,
+on double-word) boundaries.
+.TP
+.B -i2
+Similar to
+.BR -I2 ,
+but assume a modified
+.I libF77
+and
+.I libI77
+(compiled with
+.BR -Df\^2c_i2 ),
+so
+.SM INTEGER
+and
+.SM LOGICAL
+variables may be assigned by
+.SM INQUIRE
+and array lengths are stored in short ints.
+.TP
+.B -kr
+Use temporary values to enforce Fortran expression evaluation
+where K&R (first edition) parenthesization rules allow rearrangement.
+If the option is
+.LR -krd ,
+use double precision temporaries even for single-precision operands.
+.TP
+.B -P
+Write a
+.IB file .P
+of ANSI (or C++) prototypes
+for procedures defined in each input
+.IB file .f
+or
+.IB file .F .
+When reading Fortran from standard input, write prototypes
+at the beginning of standard output.
+Implies
+.B -A
+unless option
+.L -C++
+is present.  Option
+.B -Ps
+implies
+.B -P ,
+and gives exit status 4 if rerunning
+.I f\^2c
+may change prototypes or declarations.
+.TP
+.B -p
+Supply preprocessor definitions to make common-block members
+look like local variables.
+.TP
+.B -R
+Do not promote
+.SM REAL
+functions and operations to
+.SM DOUBLE PRECISION.
+Option
+.L -!R
+confirms the default, which imitates
+.IR f\^77 .
+.TP
+.B -r
+Cast values of REAL functions (including intrinsics) to REAL.
+.TP
+.B -r8
+Promote
+.SM REAL
+to
+.SM DOUBLE PRECISION, COMPLEX
+to
+.SM DOUBLE COMPLEX.
+.TP
+.BI -T dir
+Put temporary files in directory
+.I dir.
+.TP
+.B -w8
+Suppress warnings when
+.SM COMMON
+or
+.SM EQUIVALENCE
+forces odd-word alignment of doubles.
+.TP
+.BI -W n
+Assume
+.I n
+characters/word (default 4)
+when initializing numeric variables with character data.
+.TP
+.B -z
+Do not implicitly recognize
+.SM DOUBLE COMPLEX.
+.TP
+.B -!bs
+Do not recognize \fIb\fRack\fIs\fRlash escapes
+(\e", \e', \e0, \e\e, \eb, \ef, \en, \er, \et, \ev) in character strings.
+.TP
+.B -!c
+Inhibit C output, but produce
+.B -P
+output.
+.TP
+.B -!I
+Reject
+.B include
+statements.
+.TP
+.B -!it
+Don't infer types of untyped
+.SM EXTERNAL
+procedures from use as parameters to previously defined or prototyped
+procedures.
+.TP
+.B -!P
+Do not attempt to infer
+.SM ANSI
+or C++
+prototypes from usage.
+.PP
+The resulting C invokes the support routines of
+.IR f\^77 ;
+object code should be loaded by
+.I f\^77
+or with
+.IR ld (1)
+or
+.IR cc (1)
+options
+.BR "-lF77 -lI77 -lm" .
+Calling conventions
+are those of
+.IR f\&77 :
+see the reference below.
+.br
+.SH FILES
+.TP
+.IB file .[fF]
+input file
+.TP
+.B *.c
+output file
+.TP
+.F ~em/include/fortran/f2c.h
+header file
+.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 .

lang/fortran/comp/f2c.h

@@ -0,0 +1,209 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+typedef long int integer;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+typedef long int logical;
+typedef short int shortlogical;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+#ifdef f2c_i2
+/* for -i2 */
+typedef short flag;
+typedef short ftnlen;
+typedef short ftnint;
+#else
+typedef long flag;
+typedef long ftnlen;
+typedef long ftnint;
+#endif
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	shortint h;
+	integer i;
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+typedef long Long;	/* No longer used; formerly in Namelist */
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (doublereal)abs(x)
+#define min(a,b) ((a) <= (b) ? (a) : (b))
+#define max(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (doublereal)min(a,b)
+#define dmax(a,b) (doublereal)max(a,b)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef int /* Unknown procedure type */ (*U_fp)(...);
+typedef shortint (*J_fp)(...);
+typedef integer (*I_fp)(...);
+typedef real (*R_fp)(...);
+typedef doublereal (*D_fp)(...), (*E_fp)(...);
+typedef /* Complex */ VOID (*C_fp)(...);
+typedef /* Double Complex */ VOID (*Z_fp)(...);
+typedef logical (*L_fp)(...);
+typedef shortlogical (*K_fp)(...);
+typedef /* Character */ VOID (*H_fp)(...);
+typedef /* Subroutine */ int (*S_fp)(...);
+#else
+typedef int /* Unknown procedure type */ (*U_fp)();
+typedef shortint (*J_fp)();
+typedef integer (*I_fp)();
+typedef real (*R_fp)();
+typedef doublereal (*D_fp)(), (*E_fp)();
+typedef /* Complex */ VOID (*C_fp)();
+typedef /* Double Complex */ VOID (*Z_fp)();
+typedef logical (*L_fp)();
+typedef shortlogical (*K_fp)();
+typedef /* Character */ VOID (*H_fp)();
+typedef /* Subroutine */ int (*S_fp)();
+#endif
+/* E_fp is for real functions when -R is not specified */
+typedef VOID C_f;	/* complex function */
+typedef VOID H_f;	/* character function */
+typedef VOID Z_f;	/* double complex function */
+typedef doublereal E_f;	/* real function with -R not specified */
+
+/* undef any lower-case symbols that your C compiler predefines, e.g.: */
+
+#ifndef Skip_f2c_Undefs
+#undef cray
+#undef gcos
+#undef mc68010
+#undef mc68020
+#undef mips
+#undef pdp11
+#undef sgi
+#undef sparc
+#undef sun
+#undef sun2
+#undef sun3
+#undef sun4
+#undef u370
+#undef u3b
+#undef u3b2
+#undef u3b5
+#undef unix
+#undef vax
+#endif
+#endif

lang/fortran/comp/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 ();

lang/fortran/comp/ftypes.h

@@ -0,0 +1,39 @@
+
+/* variable types (stored in the   vtype  field of   expptr)
+ * numeric assumptions:
+ *	int < reals < complexes
+ *	TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX
+ */
+
+#define TYUNKNOWN 0
+#define TYADDR 1
+#define TYSHORT 2
+#define TYLONG 3
+#define TYREAL 4
+#define TYDREAL 5
+#define TYCOMPLEX 6
+#define TYDCOMPLEX 7
+#define TYLOGICAL 8
+#define TYCHAR 9
+#define TYSUBR 10
+#define TYERROR 11
+#define TYCILIST 12
+#define TYICILIST 13
+#define TYOLIST 14
+#define TYCLLIST 15
+#define TYALIST 16
+#define TYINLIST 17
+#define TYVOID 18
+#define TYLABEL 19
+#define TYFTNLEN 20
+/* TYVOID is not in any tables. */
+
+/* NTYPES, NTYPES0 -- Total number of types, used to allocate tables indexed by
+   type.  Such tables can include the size (in bytes) of objects of a given
+   type, or labels for returning objects of different types from procedures
+   (see array   rtvlabels)   */
+
+#define NTYPES TYVOID
+#define NTYPES0 TYCILIST
+#define TYBLANK TYSUBR		/* Huh? */
+

lang/fortran/comp/gram.dcl

@@ -0,0 +1,399 @@
+spec:	  dcl
+	| common
+	| external
+	| intrinsic
+	| equivalence
+	| data
+	| implicit
+	| namelist
+	| SSAVE
+		{ NO66("SAVE statement");
+		  saveall = YES; }
+	| SSAVE savelist
+		{ NO66("SAVE statement"); }
+	| SFORMAT
+		{ fmtstmt(thislabel); setfmt(thislabel); }
+	| SPARAM in_dcl SLPAR paramlist SRPAR
+		{ NO66("PARAMETER statement"); }
+	;
+
+dcl:	  type opt_comma name in_dcl new_dcl dims lengspec
+		{ settype($3, $1, $7);
+		  if(ndim>0) setbound($3,ndim,dims);
+		}
+	| dcl SCOMMA name dims lengspec
+		{ settype($3, $1, $5);
+		  if(ndim>0) setbound($3,ndim,dims);
+		}
+	| dcl SSLASHD datainit vallist SSLASHD
+		{ if (new_dcl == 2) {
+			err("attempt to give DATA in type-declaration");
+			new_dcl = 1;
+			}
+		}
+	;
+
+new_dcl:	{ new_dcl = 2; }
+
+type:	  typespec lengspec
+		{ varleng = $2;
+		  if (vartype == TYLOGICAL && varleng == 1) {
+			varleng = 0;
+			err("treating LOGICAL*1 as LOGICAL");
+			--nerr;	/* allow generation of .c file */
+			}
+		}
+	;
+
+typespec:  typename
+		{ varleng = ($1<0 || $1==TYLONG ? 0 : typesize[$1]);
+		  vartype = $1; }
+	;
+
+typename:    SINTEGER	{ $$ = TYLONG; }
+	| SREAL		{ $$ = tyreal; }
+	| SCOMPLEX	{ ++complex_seen; $$ = tycomplex; }
+	| SDOUBLE	{ $$ = TYDREAL; }
+	| SDCOMPLEX	{ ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); $$ = TYDCOMPLEX; }
+	| SLOGICAL	{ $$ = TYLOGICAL; }
+	| SCHARACTER	{ NO66("CHARACTER statement"); $$ = TYCHAR; }
+	| SUNDEFINED	{ $$ = TYUNKNOWN; }
+	| SDIMENSION	{ $$ = TYUNKNOWN; }
+	| SAUTOMATIC	{ NOEXT("AUTOMATIC statement"); $$ = - STGAUTO; }
+	| SSTATIC	{ NOEXT("STATIC statement"); $$ = - STGBSS; }
+	;
+
+lengspec:
+		{ $$ = varleng; }
+	| SSTAR intonlyon expr intonlyoff
+		{
+		expptr p;
+		p = $3;
+		NO66("length specification *n");
+		if( ! ISICON(p) || p->constblock.Const.ci <= 0 )
+			{
+			$$ = 0;
+			dclerr("length must be a positive integer constant",
+				NPNULL);
+			}
+		else {
+			if (vartype == TYCHAR)
+				$$ = p->constblock.Const.ci;
+			else switch((int)p->constblock.Const.ci) {
+				case 1:	$$ = 1; break;
+				case 2: $$ = typesize[TYSHORT];	break;
+				case 4: $$ = typesize[TYLONG];	break;
+				case 8: $$ = typesize[TYDREAL];	break;
+				case 16: $$ = typesize[TYDCOMPLEX]; break;
+				default:
+					dclerr("invalid length",NPNULL);
+					$$ = varleng;
+				}
+			}
+		}
+	| SSTAR intonlyon SLPAR SSTAR SRPAR intonlyoff
+		{ NO66("length specification *(*)"); $$ = -1; }
+	;
+
+common:	  SCOMMON in_dcl var
+		{ incomm( $$ = comblock("") , $3 ); }
+	| SCOMMON in_dcl comblock var
+		{ $$ = $3;  incomm($3, $4); }
+	| common opt_comma comblock opt_comma var
+		{ $$ = $3;  incomm($3, $5); }
+	| common SCOMMA var
+		{ incomm($1, $3); }
+	;
+
+comblock:  SCONCAT
+		{ $$ = comblock(""); }
+	| SSLASH SNAME SSLASH
+		{ $$ = comblock(token); }
+	;
+
+external: SEXTERNAL in_dcl name
+		{ setext($3); }
+	| external SCOMMA name
+		{ setext($3); }
+	;
+
+intrinsic:  SINTRINSIC in_dcl name
+		{ NO66("INTRINSIC statement"); setintr($3); }
+	| intrinsic SCOMMA name
+		{ setintr($3); }
+	;
+
+equivalence:  SEQUIV in_dcl equivset
+	| equivalence SCOMMA equivset
+	;
+
+equivset:  SLPAR equivlist SRPAR
+		{
+		struct Equivblock *p;
+		if(nequiv >= maxequiv)
+			many("equivalences", 'q', maxequiv);
+		p  =  & eqvclass[nequiv++];
+		p->eqvinit = NO;
+		p->eqvbottom = 0;
+		p->eqvtop = 0;
+		p->equivs = $2;
+		}
+	;
+
+equivlist:  lhs
+		{ $$=ALLOC(Eqvchain);
+		  $$->eqvitem.eqvlhs = (struct Primblock *)$1;
+		}
+	| equivlist SCOMMA lhs
+		{ $$=ALLOC(Eqvchain);
+		  $$->eqvitem.eqvlhs = (struct Primblock *) $3;
+		  $$->eqvnextp = $1;
+		}
+	;
+
+data:	  SDATA in_data datalist
+	| data opt_comma datalist
+	;
+
+in_data:
+		{ if(parstate == OUTSIDE)
+			{
+			newproc();
+			startproc(ESNULL, CLMAIN);
+			}
+		  if(parstate < INDATA)
+			{
+			enddcl();
+			parstate = INDATA;
+			datagripe = 1;
+			}
+		}
+	;
+
+datalist:  datainit datavarlist SSLASH datapop vallist SSLASH
+		{ ftnint junk;
+		  if(nextdata(&junk) != NULL)
+			err("too few initializers");
+		  frdata($2);
+		  frrpl();
+		}
+	;
+
+datainit: /* nothing */ { frchain(&datastack); curdtp = 0; }
+
+datapop: /* nothing */ { pop_datastack(); }
+
+vallist:  { toomanyinit = NO; }  val
+	| vallist SCOMMA val
+	;
+
+val:	  value
+		{ dataval(ENULL, $1); }
+	| simple SSTAR value
+		{ dataval($1, $3); }
+	;
+
+value:	  simple
+	| addop simple
+		{ if( $1==OPMINUS && ISCONST($2) )
+			consnegop((Constp)$2);
+		  $$ = $2;
+		}
+	| complex_const
+	;
+
+savelist: saveitem
+	| savelist SCOMMA saveitem
+	;
+
+saveitem: name
+		{ int k;
+		  $1->vsave = YES;
+		  k = $1->vstg;
+		if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) )
+			dclerr("can only save static variables", $1);
+		}
+	| comblock
+	;
+
+paramlist:  paramitem
+	| paramlist SCOMMA paramitem
+	;
+
+paramitem:  name SEQUALS expr
+		{ if($1->vclass == CLUNKNOWN)
+			make_param((struct Paramblock *)$1, $3);
+		  else dclerr("cannot make into parameter", $1);
+		}
+	;
+
+var:	  name dims
+		{ if(ndim>0) setbound($1, ndim, dims); }
+	;
+
+datavar:	  lhs
+		{ Namep np;
+		  np = ( (struct Primblock *) $1) -> namep;
+		  vardcl(np);
+		  if(np->vstg == STGCOMMON)
+			extsymtab[np->vardesc.varno].extinit = YES;
+		  else if(np->vstg==STGEQUIV)
+			eqvclass[np->vardesc.varno].eqvinit = YES;
+		  else if(np->vstg!=STGINIT && np->vstg!=STGBSS)
+			dclerr("inconsistent storage classes", np);
+		  $$ = mkchain((char *)$1, CHNULL);
+		}
+	| SLPAR datavarlist SCOMMA dospec SRPAR
+		{ chainp p; struct Impldoblock *q;
+		pop_datastack();
+		q = ALLOC(Impldoblock);
+		q->tag = TIMPLDO;
+		(q->varnp = (Namep) ($4->datap))->vimpldovar = 1;
+		p = $4->nextp;
+		if(p)  { q->implb = (expptr)(p->datap); p = p->nextp; }
+		if(p)  { q->impub = (expptr)(p->datap); p = p->nextp; }
+		if(p)  { q->impstep = (expptr)(p->datap); }
+		frchain( & ($4) );
+		$$ = mkchain((char *)q, CHNULL);
+		q->datalist = hookup($2, $$);
+		}
+	;
+
+datavarlist: datavar
+		{ if (!datastack)
+			curdtp = 0;
+		  datastack = mkchain((char *)curdtp, datastack);
+		  curdtp = $1; curdtelt = 0;
+		  }
+	| datavarlist SCOMMA datavar
+		{ $$ = hookup($1, $3); }
+	;
+
+dims:
+		{ ndim = 0; }
+	| SLPAR dimlist SRPAR
+	;
+
+dimlist:   { ndim = 0; }   dim
+	| dimlist SCOMMA dim
+	;
+
+dim:	  ubound
+		{
+		  if(ndim == maxdim)
+			err("too many dimensions");
+		  else if(ndim < maxdim)
+			{ dims[ndim].lb = 0;
+			  dims[ndim].ub = $1;
+			}
+		  ++ndim;
+		}
+	| expr SCOLON ubound
+		{
+		  if(ndim == maxdim)
+			err("too many dimensions");
+		  else if(ndim < maxdim)
+			{ dims[ndim].lb = $1;
+			  dims[ndim].ub = $3;
+			}
+		  ++ndim;
+		}
+	;
+
+ubound:	  SSTAR
+		{ $$ = 0; }
+	| expr
+	;
+
+labellist: label
+		{ nstars = 1; labarray[0] = $1; }
+	| labellist SCOMMA label
+		{ if(nstars < MAXLABLIST)  labarray[nstars++] = $3; }
+	;
+
+label:	  SICON
+		{ $$ = execlab( convci(toklen, token) ); }
+	;
+
+implicit:  SIMPLICIT in_dcl implist
+		{ NO66("IMPLICIT statement"); }
+	| implicit SCOMMA implist
+	;
+
+implist:  imptype SLPAR letgroups SRPAR
+	| imptype
+		{ if (vartype != TYUNKNOWN)
+			dclerr("-- expected letter range",NPNULL);
+		  setimpl(vartype, varleng, 'a', 'z'); }
+	;
+
+imptype:   { needkwd = 1; } type
+		/* { vartype = $2; } */
+	;
+
+letgroups: letgroup
+	| letgroups SCOMMA letgroup
+	;
+
+letgroup:  letter
+		{ setimpl(vartype, varleng, $1, $1); }
+	| letter SMINUS letter
+		{ setimpl(vartype, varleng, $1, $3); }
+	;
+
+letter:  SNAME
+		{ if(toklen!=1 || token[0]<'a' || token[0]>'z')
+			{
+			dclerr("implicit item must be single letter", NPNULL);
+			$$ = 0;
+			}
+		  else $$ = token[0];
+		}
+	;
+
+namelist:	SNAMELIST
+	| namelist namelistentry
+	;
+
+namelistentry:  SSLASH name SSLASH namelistlist
+		{
+		if($2->vclass == CLUNKNOWN)
+			{
+			$2->vclass = CLNAMELIST;
+			$2->vtype = TYINT;
+			$2->vstg = STGBSS;
+			$2->varxptr.namelist = $4;
+			$2->vardesc.varno = ++lastvarno;
+			}
+		else dclerr("cannot be a namelist name", $2);
+		}
+	;
+
+namelistlist:  name
+		{ $$ = mkchain((char *)$1, CHNULL); }
+	| namelistlist SCOMMA name
+		{ $$ = hookup($1, mkchain((char *)$3, CHNULL)); }
+	;
+
+in_dcl:
+		{ switch(parstate)
+			{
+			case OUTSIDE:	newproc();
+					startproc(ESNULL, CLMAIN);
+			case INSIDE:	parstate = INDCL;
+			case INDCL:	break;
+
+			case INDATA:
+				if (datagripe) {
+					errstr(
+				"Statement order error: declaration after DATA",
+						CNULL);
+					datagripe = 0;
+					}
+				break;
+
+			default:
+				dclerr("declaration among executables", NPNULL);
+			}
+		}
+	;

lang/fortran/comp/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
+			err("too many alternate returns");
+		}
+	| SRETURN end_spec opt_expr
+		{ exreturn($3);  thiswasbranch = YES; }
+	| stop end_spec opt_expr
+		{ exstop($1, $3);  thiswasbranch = $1; }
+	;
+
+assignlabel:   SICON
+		{ $$ = mklabel( convci(toklen, token) ); }
+	;
+
+let:	  SLET
+		{ if(parstate == OUTSIDE)
+			{
+			newproc();
+			startproc(ESNULL, CLMAIN);
+			}
+		}
+	;
+
+goto:	  SGOTO end_spec label
+		{ exgoto($3);  thiswasbranch = YES; }
+	| SASGOTO end_spec name
+		{ exasgoto($3);  thiswasbranch = YES; }
+	| SASGOTO end_spec name opt_comma SLPAR labellist SRPAR
+		{ exasgoto($3);  thiswasbranch = YES; }
+	| SCOMPGOTO end_spec SLPAR labellist SRPAR opt_comma expr
+		{ if(nstars < MAXLABLIST)
+			putcmgo(putx(fixtype($7)), nstars, labarray);
+		  else
+			err("computed GOTO list too long");
+		}
+	;
+
+opt_comma:
+	| SCOMMA
+	;
+
+call:	  SCALL end_spec name
+		{ nstars = 0; $$ = $3; }
+	;
+
+callarglist:  callarg
+		{ $$ = $1 ? mkchain((char *)$1,CHNULL) : CHNULL; }
+	| callarglist SCOMMA callarg
+		{ $$ = $3 ? mkchain((char *)$3, $1) : $1; }
+	;
+
+callarg:  expr
+	| SSTAR label
+		{ if(nstars<MAXLABLIST) labarray[nstars++] = $2; $$ = 0; }
+	;
+
+stop:	  SPAUSE
+		{ $$ = 0; }
+	| SSTOP
+		{ $$ = 1; }
+	;
+
+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; }
+	;

lang/fortran/comp/gram.expr

@@ -0,0 +1,141 @@
+funarglist:
+		{ $$ = 0; }
+	| funargs
+		{ $$ = revchain($1); }
+	;
+
+funargs:  expr
+		{ $$ = mkchain((char *)$1, CHNULL); }
+	| funargs SCOMMA expr
+		{ $$ = mkchain((char *)$3, $1); }
+	;
+
+
+expr:	  uexpr
+	| SLPAR expr SRPAR	{ $$ = $2; }
+	| complex_const
+	;
+
+uexpr:	  lhs
+	| simple_const
+	| expr addop expr   %prec SPLUS
+		{ $$ = mkexpr($2, $1, $3); }
+	| expr SSTAR expr
+		{ $$ = mkexpr(OPSTAR, $1, $3); }
+	| expr SSLASH expr
+		{ $$ = mkexpr(OPSLASH, $1, $3); }
+	| expr SPOWER expr
+		{ $$ = mkexpr(OPPOWER, $1, $3); }
+	| addop expr  %prec SSTAR
+		{ if($1 == OPMINUS)
+			$$ = mkexpr(OPNEG, $2, ENULL);
+		  else 	$$ = $2;
+		}
+	| expr relop expr  %prec SEQ
+		{ $$ = mkexpr($2, $1, $3); }
+	| expr SEQV expr
+		{ NO66(".EQV. operator");
+		  $$ = mkexpr(OPEQV, $1,$3); }
+	| expr SNEQV expr
+		{ NO66(".NEQV. operator");
+		  $$ = mkexpr(OPNEQV, $1, $3); }
+	| expr SOR expr
+		{ $$ = mkexpr(OPOR, $1, $3); }
+	| expr SAND expr
+		{ $$ = mkexpr(OPAND, $1, $3); }
+	| SNOT expr
+		{ $$ = mkexpr(OPNOT, $2, ENULL); }
+	| expr SCONCAT expr
+		{ NO66("concatenation operator //");
+		  $$ = mkexpr(OPCONCAT, $1, $3); }
+	;
+
+addop:	  SPLUS		{ $$ = OPPLUS; }
+	| SMINUS	{ $$ = OPMINUS; }
+	;
+
+relop:	  SEQ	{ $$ = OPEQ; }
+	| SGT	{ $$ = OPGT; }
+	| SLT	{ $$ = OPLT; }
+	| SGE	{ $$ = OPGE; }
+	| SLE	{ $$ = OPLE; }
+	| SNE	{ $$ = OPNE; }
+	;
+
+lhs:	 name
+		{ $$ = mkprim($1, LBNULL, CHNULL); }
+	| name substring
+		{ NO66("substring operator :");
+		  $$ = mkprim($1, LBNULL, $2); }
+	| name SLPAR funarglist SRPAR
+		{ $$ = mkprim($1, mklist($3), CHNULL); }
+	| name SLPAR funarglist SRPAR substring
+		{ NO66("substring operator :");
+		  $$ = mkprim($1, mklist($3), $5); }
+	;
+
+substring:  SLPAR opt_expr SCOLON opt_expr SRPAR
+		{ $$ = mkchain((char *)$2, mkchain((char *)$4,CHNULL)); }
+	;
+
+opt_expr:
+		{ $$ = 0; }
+	| expr
+	;
+
+simple:	  name
+		{ if($1->vclass == CLPARAM)
+			$$ = (expptr) cpexpr(
+				( (struct Paramblock *) ($1) ) -> paramval);
+		}
+	| simple_const
+	;
+
+simple_const:   STRUE	{ $$ = mklogcon(1); }
+	| SFALSE	{ $$ = mklogcon(0); }
+	| SHOLLERITH  { $$ = mkstrcon(toklen, token); }
+	| SICON	= { $$ = mkintcon( convci(toklen, token) ); }
+	| SRCON	= { $$ = mkrealcon(tyreal, token); }
+	| SDCON	= { $$ = mkrealcon(TYDREAL, token); }
+	| bit_const
+	;
+
+complex_const:  SLPAR uexpr SCOMMA uexpr SRPAR
+		{ $$ = mkcxcon($2,$4); }
+	;
+
+bit_const:  SHEXCON
+		{ NOEXT("hex constant");
+		  $$ = mkbitcon(4, toklen, token); }
+	| SOCTCON
+		{ NOEXT("octal constant");
+		  $$ = mkbitcon(3, toklen, token); }
+	| SBITCON
+		{ NOEXT("binary constant");
+		  $$ = mkbitcon(1, toklen, token); }
+	;
+
+fexpr:	  unpar_fexpr
+	| SLPAR fexpr SRPAR
+		{ $$ = $2; }
+	;
+
+unpar_fexpr:	  lhs
+	| simple_const
+	| fexpr addop fexpr   %prec SPLUS
+		{ $$ = mkexpr($2, $1, $3); }
+	| fexpr SSTAR fexpr
+		{ $$ = mkexpr(OPSTAR, $1, $3); }
+	| fexpr SSLASH fexpr
+		{ $$ = mkexpr(OPSLASH, $1, $3); }
+	| fexpr SPOWER fexpr
+		{ $$ = mkexpr(OPPOWER, $1, $3); }
+	| addop fexpr  %prec SSTAR
+		{ if($1 == OPMINUS)
+			$$ = mkexpr(OPNEG, $2, ENULL);
+		  else	$$ = $2;
+		}
+	| fexpr SCONCAT fexpr
+		{ NO66("concatenation operator //");
+		  $$ = mkexpr(OPCONCAT, $1, $3); }
+	;

lang/fortran/comp/gram.head

@@ -0,0 +1,299 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories, Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+%{
+#	include "defs.h"
+#	include "p1defs.h"
+
+static int nstars;			/* Number of labels in an
+					   alternate return CALL */
+static int datagripe;
+static int ndim;
+static int vartype;
+int new_dcl;
+static ftnint varleng;
+static struct Dims dims[MAXDIM+1];
+static struct Labelblock *labarray[MAXLABLIST];	/* Labels in an alternate
+						   return CALL */
+
+/* The next two variables are used to verify that each statement might be reached
+   during runtime.   lastwasbranch   is tested only in the defintion of the
+   stat:   nonterminal. */
+
+int lastwasbranch = NO;
+static int thiswasbranch = NO;
+extern ftnint yystno;
+extern flag intonly;
+static chainp datastack;
+extern long laststfcn, thisstno;
+extern int can_include;	/* for netlib */
+
+ftnint convci();
+Addrp nextdata();
+expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon();
+expptr mkcxcon();
+struct Listblock *mklist();
+struct Listblock *mklist();
+struct Impldoblock *mkiodo();
+Extsym *comblock();
+#define ESNULL (Extsym *)0
+#define NPNULL (Namep)0
+#define LBNULL (struct Listblock *)0
+extern void freetemps(), make_param();
+
+ static void
+pop_datastack() {
+	chainp d0 = datastack;
+	if (d0->datap)
+		curdtp = (chainp)d0->datap;
+	datastack = d0->nextp;
+	d0->nextp = 0;
+	frchain(&d0);
+	}
+
+%}
+
+/* Specify precedences and associativities. */
+
+%union	{
+	int ival;
+	ftnint lval;
+	char *charpval;
+	chainp chval;
+	tagptr tagval;
+	expptr expval;
+	struct Labelblock *labval;
+	struct Nameblock *namval;
+	struct Eqvchain *eqvval;
+	Extsym *extval;
+	}
+
+%left SCOMMA
+%nonassoc SCOLON
+%right SEQUALS
+%left SEQV SNEQV
+%left SOR
+%left SAND
+%left SNOT
+%nonassoc SLT SGT SLE SGE SEQ SNE
+%left SCONCAT
+%left SPLUS SMINUS
+%left SSTAR SSLASH
+%right SPOWER
+
+%start program
+%type <labval> thislabel label assignlabel
+%type <tagval> other inelt
+%type <ival> type typespec typename dcl letter addop relop stop nameeq
+%type <lval> lengspec
+%type <charpval> filename
+%type <chval> datavar datavarlist namelistlist funarglist funargs
+%type <chval> dospec dospecw
+%type <chval> callarglist arglist args exprlist inlist outlist out2 substring
+%type <namval> name arg call var
+%type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr
+%type <expval> ubound simple value callarg complex_const simple_const bit_const
+%type <extval> common comblock entryname progname
+%type <eqvval> equivlist
+
+%%
+
+program:
+	| program stat SEOS
+	;
+
+stat:	  thislabel  entry
+		{
+/* stat:   is the nonterminal for Fortran statements */
+
+		  lastwasbranch = NO; }
+	| thislabel  spec
+	| thislabel  exec
+		{ /* forbid further statement function definitions... */
+		  if (parstate == INDATA && laststfcn != thisstno)
+			parstate = INEXEC;
+		  thisstno++;
+		  if($1 && ($1->labelno==dorange))
+			enddo($1->labelno);
+		  if(lastwasbranch && thislabel==NULL)
+			warn("statement cannot be reached");
+		  lastwasbranch = thiswasbranch;
+		  thiswasbranch = NO;
+		  if($1)
+			{
+			if($1->labtype == LABFORMAT)
+				err("label already that of a format");
+			else
+				$1->labtype = LABEXEC;
+			}
+		  freetemps();
+		}
+	| thislabel SINCLUDE filename
+		{ if (can_include)
+			doinclude( $3 );
+		  else {
+			fprintf(diagfile, "Cannot open file %s\n", $3);
+			done(1);
+			}
+		}
+	| thislabel  SEND  end_spec
+		{ if ($1)
+			lastwasbranch = NO;
+		  endproc(); /* lastwasbranch = NO; -- set in endproc() */
+		}
+	| thislabel SUNKNOWN
+		{ extern void unclassifiable();
+		  unclassifiable();
+
+/* flline flushes the current line, ignoring the rest of the text there */
+
+		  flline(); };
+	| error
+		{ flline();  needkwd = NO;  inioctl = NO;
+		  yyerrok; yyclearin; }
+	;
+
+thislabel:  SLABEL
+		{
+		if(yystno != 0)
+			{
+			$$ = thislabel =  mklabel(yystno);
+			if( ! headerdone ) {
+				if (procclass == CLUNKNOWN)
+					procclass = CLMAIN;
+				puthead(CNULL, procclass);
+				}
+			if(thislabel->labdefined)
+				execerr("label %s already defined",
+					convic(thislabel->stateno) );
+			else	{
+				if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel
+				    && thislabel->labtype!=LABFORMAT)
+					warn1("there is a branch to label %s from outside block",
+					      convic( (ftnint) (thislabel->stateno) ) );
+				thislabel->blklevel = blklevel;
+				thislabel->labdefined = YES;
+				if(thislabel->labtype != LABFORMAT)
+					p1_label((long)(thislabel - labeltab));
+				}
+			}
+		else    $$ = thislabel = NULL;
+		}
+	;
+
+entry:	  SPROGRAM new_proc progname
+		   {startproc($3, CLMAIN); }
+	| SPROGRAM new_proc progname progarglist
+		   {	warn("ignoring arguments to main program");
+			/* hashclear(); */
+			startproc($3, CLMAIN); }
+	| SBLOCK new_proc progname
+		{ if($3) NO66("named BLOCKDATA");
+		  startproc($3, CLBLOCK); }
+	| SSUBROUTINE new_proc entryname arglist
+		{ entrypt(CLPROC, TYSUBR, (ftnint) 0,  $3, $4); }
+	| SFUNCTION new_proc entryname arglist
+		{ entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); }
+	| type SFUNCTION new_proc entryname arglist
+		{ entrypt(CLPROC, $1, varleng, $4, $5); }
+	| SENTRY entryname arglist
+		 { if(parstate==OUTSIDE || procclass==CLMAIN
+			|| procclass==CLBLOCK)
+				execerr("misplaced entry statement", CNULL);
+		  entrypt(CLENTRY, 0, (ftnint) 0, $2, $3);
+		}
+	;
+
+new_proc:
+		{ newproc(); }
+	;
+
+entryname:  name
+		{ $$ = newentry($1, 1); }
+	;
+
+name:	  SNAME
+		{ $$ = mkname(token); }
+	;
+
+progname:		{ $$ = NULL; }
+	| entryname
+	;
+
+progarglist:
+	  SLPAR SRPAR
+	| SLPAR progargs SRPAR
+	;
+
+progargs: progarg
+	| progargs SCOMMA progarg
+	;
+
+progarg:  SNAME
+	| SNAME SEQUALS SNAME
+	;
+
+arglist:
+		{ $$ = 0; }
+	| SLPAR SRPAR
+		{ NO66(" () argument list");
+		  $$ = 0; }
+	| SLPAR args SRPAR
+		{$$ = $2; }
+	;
+
+args:	  arg
+		{ $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL ); }
+	| args SCOMMA arg
+		{ if($3) $1 = $$ = mkchain((char *)$3, $1); }
+	;
+
+arg:	  name
+		{ if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG)
+			dclerr("name declared as argument after use", $1);
+		  $1->vstg = STGARG;
+		}
+	| SSTAR
+		{ NO66("altenate return argument");
+
+/* substars   means that '*'ed formal parameters should be replaced.
+   This is used to specify alternate return labels; in theory, only
+   parameter slots which have '*' should accept the statement labels.
+   This compiler chooses to ignore the '*'s in the formal declaration, and
+   always return the proper value anyway.
+
+   This variable is only referred to in   proc.c   */
+
+		  $$ = 0;  substars = YES; }
+	;
+
+
+
+filename:   SHOLLERITH
+		{
+		char *s;
+		s = copyn(toklen+1, token);
+		s[toklen] = '\0';
+		$$ = s;
+		}
+	;

lang/fortran/comp/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(); }
+	;

lang/fortran/comp/init.c

@@ -0,0 +1,446 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "output.h"
+#include "iob.h"
+
+/* State required for the C output */
+char *fl_fmt_string;		/* Float format string */
+char *db_fmt_string;	    	/* Double format string */
+char *cm_fmt_string;		/* Complex format string */
+char *dcm_fmt_string;		/* Double complex format string */
+
+chainp new_vars = CHNULL;	/* List of newly created locals in this
+				   function.  These may have identifiers
+				   which have underscores and more than VL
+				   characters */
+chainp used_builtins = CHNULL;	/* List of builtins used by this function.
+				   These are all Addrps with UNAM_EXTERN
+				   */
+chainp assigned_fmts = CHNULL;	/* assigned formats */
+chainp allargs;			/* union of args in all entry points */
+chainp earlylabs;		/* labels seen before enddcl() */
+char main_alias[52];		/* PROGRAM name, if any is given */
+int tab_size = 4;
+
+
+FILEP infile;
+FILEP diagfile;
+
+FILEP c_file;
+FILEP pass1_file;
+FILEP initfile;
+FILEP blkdfile;
+
+
+char token[MAXTOKENLEN];
+int toklen;
+long lineno;			/* Current line in the input file, NOT the
+				   Fortran statement label number */
+char *infname;
+int needkwd;
+struct Labelblock *thislabel	= NULL;
+int nerr;
+int nwarn;
+
+flag saveall;
+flag substars;
+int parstate	= OUTSIDE;
+flag headerdone	= NO;
+int blklevel;
+int doin_setbound;
+int impltype[26];
+ftnint implleng[26];
+int implstg[26];
+
+int tyint	= TYLONG ;
+int tylogical	= TYLONG;
+int typesize[NTYPES] = {
+	1, SZADDR, SZSHORT, SZLONG, SZLONG, 2*SZLONG,
+	    2*SZLONG, 4*SZLONG, SZLONG, 1, 1, 0,
+		4*SZLONG + SZADDR,	/* sizeof(cilist) */
+		4*SZLONG + 2*SZADDR,	/* sizeof(icilist) */
+		4*SZLONG + 5*SZADDR,	/* sizeof(olist) */
+		2*SZLONG + SZADDR,	/* sizeof(cllist) */
+		2*SZLONG,		/* sizeof(alist) */
+		11*SZLONG + 15*SZADDR	/* sizeof(inlist) */
+		};
+
+int typealign[NTYPES] = {
+	1, ALIADDR, ALISHORT, ALILONG, ALILONG, ALIDOUBLE,
+	ALILONG, ALIDOUBLE, ALILONG, 1, 1, 1,
+	ALILONG, ALILONG, ALILONG, ALILONG, ALILONG, ALILONG};
+
+int type_choice[4] = { TYDREAL, TYSHORT, TYLONG,  TYSHORT };
+
+char *typename[] = {
+	"<<unknown>>",
+	"address",
+	"shortint",
+	"integer",
+	"real",
+	"doublereal",
+	"complex",
+	"doublecomplex",
+	"logical",
+	"char"	/* character */
+	};
+
+int type_pref[NTYPES] = { 0, 0, 2, 4, 5, 7, 6, 8, 3, 1 };
+
+char *protorettypes[] = {
+	"?", "??", "shortint", "integer", "real", "doublereal",
+	"C_f", "Z_f", "logical", "H_f", "int"
+	};
+
+char *casttypes[TYSUBR+1] = {
+	"U_fp", "??bug??",
+	"J_fp", "I_fp", "R_fp",
+	"D_fp", "C_fp", "Z_fp",
+	"L_fp", "H_fp", "S_fp"
+	};
+char *usedcasts[TYSUBR+1];
+
+char *dfltarg[] = {
+	0, 0,
+	"(shortint *)0", "(integer *)0", "(real *)0",
+	"(doublereal *)0", "(complex *)0", "(doublecomplex *)0",
+	"(logical *)0", "(char *)0"
+	};
+
+static char *dflt0proc[] = {
+	0, 0,
+	"(shortint (*)())0", "(integer (*)())0", "(real (*)())0",
+	"(doublereal (*)())0", "(complex (*)())0", "(doublecomplex (*)())0",
+	"(logical (*)())0", "(char (*)())0", "(int (*)())0"
+	};
+
+char *dflt1proc[] = { "(U_fp)0", "(??bug??)0",
+	"(J_fp)0", "(I_fp)0", "(R_fp)0",
+	"(D_fp)0", "(C_fp)0", "(Z_fp)0",
+	"(L_fp)0", "(H_fp)0", "(S_fp)0"
+	};
+
+char **dfltproc = dflt0proc;
+
+static char Bug[] = "bug";
+
+char *ftn_types[] = { "external", "??",
+	"integer*2", "integer", "real",
+	"double precision", "complex", "double complex",
+	"logical", "character", "subroutine",
+	Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug,Bug, "ftnlen"
+	};
+
+int init_ac[TYSUBR+1] = { 0,0,0,0,0,0, 1, 1, 0, 2};
+
+int proctype	= TYUNKNOWN;
+char *procname;
+int rtvlabel[NTYPES0];
+Addrp retslot;			/* Holds automatic variable which was
+				   allocated the function return value
+				   */
+Addrp xretslot[NTYPES0];	/* for multiple entry points */
+int cxslot	= -1;
+int chslot	= -1;
+int chlgslot	= -1;
+int procclass	= CLUNKNOWN;
+int nentry;
+int nallargs;
+int nallchargs;
+flag multitype;
+ftnint procleng;
+long lastiolabno;
+int lastlabno;
+int lastvarno;
+int lastargslot;
+int autonum[TYVOID];
+char *av_pfix[TYVOID] = {"??TYUNKNOWN??", "a","s","i","r","d","q","z","L","ch",
+			 "??TYSUBR??", "??TYERROR??","ci", "ici",
+			 "o", "cl", "al", "ioin" };
+
+extern int maxctl;
+struct Ctlframe *ctls;
+struct Ctlframe *ctlstack;
+struct Ctlframe *lastctl;
+
+Namep regnamep[MAXREGVAR];
+int highregvar;
+int nregvar;
+
+extern int maxext;
+Extsym *extsymtab;
+Extsym *nextext;
+Extsym *lastext;
+
+extern int maxequiv;
+struct Equivblock *eqvclass;
+
+extern int maxhash;
+struct Hashentry *hashtab;
+struct Hashentry *lasthash;
+
+extern int maxstno;		/* Maximum number of statement labels */
+struct Labelblock *labeltab;
+struct Labelblock *labtabend;
+struct Labelblock *highlabtab;
+
+int maxdim	= MAXDIM;
+struct Rplblock *rpllist	= NULL;
+struct Chain *curdtp	= NULL;
+flag toomanyinit;
+ftnint curdtelt;
+chainp templist[TYVOID];
+chainp holdtemps;
+int dorange	= 0;
+struct Entrypoint *entries	= NULL;
+
+chainp chains	= NULL;
+
+flag inioctl;
+int iostmt;
+int nioctl;
+int nequiv	= 0;
+int eqvstart	= 0;
+int nintnames	= 0;
+
+struct Literal *litpool;
+int nliterals;
+
+char dflttype[26];
+char hextoi_tab[Table_size], Letters[Table_size];
+char *ei_first, *ei_next, *ei_last;
+char *wh_first, *wh_next, *wh_last;
+
+#define ALLOCN(n,x)	(struct x *) ckalloc((n)*sizeof(struct x))
+
+fileinit()
+{
+	register char *s;
+	register int i, j;
+	extern void fmt_init(), mem_init(), np_init();
+
+	lastiolabno = 100000;
+	lastlabno = 0;
+	lastvarno = 0;
+	nliterals = 0;
+	nerr = 0;
+
+	infile = stdin;
+
+	memset(dflttype, tyreal, 26);
+	memset(dflttype + 'i' - 'a', tyint, 6);
+	memset(hextoi_tab, 16, sizeof(hextoi_tab));
+	for(i = 0, s = "0123456789abcdef"; *s; i++, s++)
+		hextoi(*s) = i;
+	for(i = 10, s = "ABCDEF"; *s; i++, s++)
+		hextoi(*s) = i;
+	for(j = 0, s = "abcdefghijklmnopqrstuvwxyz"; i = *s++; j++)
+		Letters[i] = Letters[i+'A'-'a'] = j;
+
+	ctls = ALLOCN(maxctl+1, Ctlframe);
+	extsymtab = ALLOCN(maxext, Extsym);
+	eqvclass = ALLOCN(maxequiv, Equivblock);
+	hashtab = ALLOCN(maxhash, Hashentry);
+	labeltab = ALLOCN(maxstno, Labelblock);
+	litpool = ALLOCN(maxliterals, Literal);
+	fmt_init();
+	mem_init();
+	np_init();
+
+	ctlstack = ctls++;
+	lastctl = ctls + maxctl;
+	nextext = extsymtab;
+	lastext = extsymtab + maxext;
+	lasthash = hashtab + maxhash;
+	labtabend = labeltab + maxstno;
+	highlabtab = labeltab;
+	main_alias[0] = '\0';
+	if (forcedouble)
+		dfltproc[TYREAL] = dfltproc[TYDREAL];
+
+/* Initialize the routines for providing C output */
+
+	out_init ();
+}
+
+hashclear()	/* clear hash table */
+{
+	register struct Hashentry *hp;
+	register Namep p;
+	register struct Dimblock *q;
+	register int i;
+
+	for(hp = hashtab ; hp < lasthash ; ++hp)
+		if(p = hp->varp)
+		{
+			frexpr(p->vleng);
+			if(q = p->vdim)
+			{
+				for(i = 0 ; i < q->ndim ; ++i)
+				{
+					frexpr(q->dims[i].dimsize);
+					frexpr(q->dims[i].dimexpr);
+				}
+				frexpr(q->nelt);
+				frexpr(q->baseoffset);
+				frexpr(q->basexpr);
+				free( (charptr) q);
+			}
+			if(p->vclass == CLNAMELIST)
+				frchain( &(p->varxptr.namelist) );
+			free( (charptr) p);
+			hp->varp = NULL;
+		}
+	}
+
+procinit()
+{
+	register struct Labelblock *lp;
+	struct Chain *cp;
+	int i;
+	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)
+				length = 0;
+			for(i = c1 ; i<=c2 ; ++i) {
+				impltype[i] = type;
+				implleng[i] = length;
+				}
+			}
+		}
+	}

lang/fortran/comp/intr.c

@@ -0,0 +1,846 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "names.h"
+
+void cast_args ();
+
+union
+	{
+	int ijunk;
+	struct Intrpacked bits;
+	} packed;
+
+struct Intrbits
+	{
+	char intrgroup /* :3 */;
+	char intrstuff /* result type or number of generics */;
+	char intrno /* :7 */;
+	char dblcmplx;
+	char dblintrno;	/* for -r8 */
+	};
+
+/* List of all intrinsic functions.  */
+
+LOCAL struct Intrblock
+	{
+	char intrfname[8];
+	struct Intrbits intrval;
+	} intrtab[ ] =
+{
+"int", 		{ INTRCONV, TYLONG },
+"real", 	{ INTRCONV, TYREAL, 1 },
+		/* 1 ==> real(TYDCOMPLEX) yields TYDREAL */
+"dble", 	{ INTRCONV, TYDREAL },
+"cmplx", 	{ INTRCONV, TYCOMPLEX },
+"dcmplx", 	{ INTRCONV, TYDCOMPLEX, 0, 1 },
+"ifix", 	{ INTRCONV, TYLONG },
+"idint", 	{ INTRCONV, TYLONG },
+"float", 	{ INTRCONV, TYREAL },
+"dfloat",	{ INTRCONV, TYDREAL },
+"sngl", 	{ INTRCONV, TYREAL },
+"ichar", 	{ INTRCONV, TYLONG },
+"iachar", 	{ INTRCONV, TYLONG },
+"char", 	{ INTRCONV, TYCHAR },
+"achar", 	{ INTRCONV, TYCHAR },
+
+/* any MAX or MIN can be used with any types; the compiler will cast them
+   correctly.  So rules against bad syntax in these expressions are not
+   enforced */
+
+"max", 		{ INTRMAX, TYUNKNOWN },
+"max0", 	{ INTRMAX, TYLONG },
+"amax0", 	{ INTRMAX, TYREAL },
+"max1", 	{ INTRMAX, TYLONG },
+"amax1", 	{ INTRMAX, TYREAL },
+"dmax1", 	{ INTRMAX, TYDREAL },
+
+"and",		{ INTRBOOL, TYUNKNOWN, OPBITAND },
+"or",		{ INTRBOOL, TYUNKNOWN, OPBITOR },
+"xor",		{ INTRBOOL, TYUNKNOWN, OPBITXOR },
+"not",		{ INTRBOOL, TYUNKNOWN, OPBITNOT },
+"lshift",	{ INTRBOOL, TYUNKNOWN, OPLSHIFT },
+"rshift",	{ INTRBOOL, TYUNKNOWN, OPRSHIFT },
+
+"min", 		{ INTRMIN, TYUNKNOWN },
+"min0", 	{ INTRMIN, TYLONG },
+"amin0", 	{ INTRMIN, TYREAL },
+"min1", 	{ INTRMIN, TYLONG },
+"amin1", 	{ INTRMIN, TYREAL },
+"dmin1", 	{ INTRMIN, TYDREAL },
+
+"aint", 	{ INTRGEN, 2, 0 },
+"dint", 	{ INTRSPEC, TYDREAL, 1 },
+
+"anint", 	{ INTRGEN, 2, 2 },
+"dnint", 	{ INTRSPEC, TYDREAL, 3 },
+
+"nint", 	{ INTRGEN, 4, 4 },
+"idnint", 	{ INTRGEN, 2, 6 },
+
+"abs", 		{ INTRGEN, 6, 8 },
+"iabs", 	{ INTRGEN, 2, 9 },
+"dabs", 	{ INTRSPEC, TYDREAL, 11 },
+"cabs", 	{ INTRSPEC, TYREAL, 12, 0, 13 },
+"zabs", 	{ INTRSPEC, TYDREAL, 13, 1 },
+
+"mod", 		{ INTRGEN, 4, 14 },
+"amod", 	{ INTRSPEC, TYREAL, 16, 0, 17 },
+"dmod", 	{ INTRSPEC, TYDREAL, 17 },
+
+"sign", 	{ INTRGEN, 4, 18 },
+"isign", 	{ INTRGEN, 2, 19 },
+"dsign", 	{ INTRSPEC, TYDREAL, 21 },
+
+"dim", 		{ INTRGEN, 4, 22 },
+"idim", 	{ INTRGEN, 2, 23 },
+"ddim", 	{ INTRSPEC, TYDREAL, 25 },
+
+"dprod", 	{ INTRSPEC, TYDREAL, 26 },
+
+"len", 		{ INTRSPEC, TYLONG, 27 },
+"index", 	{ INTRSPEC, TYLONG, 29 },
+
+"imag", 	{ INTRGEN, 2, 31 },
+"aimag", 	{ INTRSPEC, TYREAL, 31, 0, 32 },
+"dimag", 	{ INTRSPEC, TYDREAL, 32 },
+
+"conjg", 	{ INTRGEN, 2, 33 },
+"dconjg", 	{ INTRSPEC, TYDCOMPLEX, 34, 1 },
+
+"sqrt", 	{ INTRGEN, 4, 35 },
+"dsqrt", 	{ INTRSPEC, TYDREAL, 36 },
+"csqrt", 	{ INTRSPEC, TYCOMPLEX, 37, 0, 38 },
+"zsqrt", 	{ INTRSPEC, TYDCOMPLEX, 38, 1 },
+
+"exp", 		{ INTRGEN, 4, 39 },
+"dexp", 	{ INTRSPEC, TYDREAL, 40 },
+"cexp", 	{ INTRSPEC, TYCOMPLEX, 41, 0, 42 },
+"zexp", 	{ INTRSPEC, TYDCOMPLEX, 42, 1 },
+
+"log", 		{ INTRGEN, 4, 43 },
+"alog", 	{ INTRSPEC, TYREAL, 43, 0, 44 },
+"dlog", 	{ INTRSPEC, TYDREAL, 44 },
+"clog", 	{ INTRSPEC, TYCOMPLEX, 45, 0, 46 },
+"zlog", 	{ INTRSPEC, TYDCOMPLEX, 46, 1 },
+
+"log10", 	{ INTRGEN, 2, 47 },
+"alog10", 	{ INTRSPEC, TYREAL, 47, 0, 48 },
+"dlog10", 	{ INTRSPEC, TYDREAL, 48 },
+
+"sin", 		{ INTRGEN, 4, 49 },
+"dsin", 	{ INTRSPEC, TYDREAL, 50 },
+"csin", 	{ INTRSPEC, TYCOMPLEX, 51, 0, 52 },
+"zsin", 	{ INTRSPEC, TYDCOMPLEX, 52, 1 },
+
+"cos", 		{ INTRGEN, 4, 53 },
+"dcos", 	{ INTRSPEC, TYDREAL, 54 },
+"ccos", 	{ INTRSPEC, TYCOMPLEX, 55, 0, 56 },
+"zcos", 	{ INTRSPEC, TYDCOMPLEX, 56, 1 },
+
+"tan", 		{ INTRGEN, 2, 57 },
+"dtan", 	{ INTRSPEC, TYDREAL, 58 },
+
+"asin", 	{ INTRGEN, 2, 59 },
+"dasin", 	{ INTRSPEC, TYDREAL, 60 },
+
+"acos", 	{ INTRGEN, 2, 61 },
+"dacos", 	{ INTRSPEC, TYDREAL, 62 },
+
+"atan", 	{ INTRGEN, 2, 63 },
+"datan", 	{ INTRSPEC, TYDREAL, 64 },
+
+"atan2", 	{ INTRGEN, 2, 65 },
+"datan2", 	{ INTRSPEC, TYDREAL, 66 },
+
+"sinh", 	{ INTRGEN, 2, 67 },
+"dsinh", 	{ INTRSPEC, TYDREAL, 68 },
+
+"cosh", 	{ INTRGEN, 2, 69 },
+"dcosh", 	{ INTRSPEC, TYDREAL, 70 },
+
+"tanh", 	{ INTRGEN, 2, 71 },
+"dtanh", 	{ INTRSPEC, TYDREAL, 72 },
+
+"lge",		{ INTRSPEC, TYLOGICAL, 73},
+"lgt",		{ INTRSPEC, TYLOGICAL, 75},
+"lle",		{ INTRSPEC, TYLOGICAL, 77},
+"llt",		{ INTRSPEC, TYLOGICAL, 79},
+
+#if 0
+"epbase",	{ INTRCNST, 4, 0 },
+"epprec",	{ INTRCNST, 4, 4 },
+"epemin",	{ INTRCNST, 2, 8 },
+"epemax",	{ INTRCNST, 2, 10 },
+"eptiny",	{ INTRCNST, 2, 12 },
+"ephuge",	{ INTRCNST, 4, 14 },
+"epmrsp",	{ INTRCNST, 2, 18 },
+#endif
+
+"fpexpn",	{ INTRGEN, 4, 81 },
+"fpabsp",	{ INTRGEN, 2, 85 },
+"fprrsp",	{ INTRGEN, 2, 87 },
+"fpfrac",	{ INTRGEN, 2, 89 },
+"fpmake",	{ INTRGEN, 2, 91 },
+"fpscal",	{ INTRGEN, 2, 93 },
+
+"" };
+
+
+LOCAL struct Specblock
+	{
+	char atype;		/* Argument type; every arg must have
+				   this type */
+	char rtype;		/* Result type */
+	char nargs;		/* Number of arguments */
+	char spxname[8];	/* Name of the function in Fortran */
+	char othername;		/* index into callbyvalue table */
+	} spectab[ ] =
+{
+	{ TYREAL,TYREAL,1,"r_int" },
+	{ TYDREAL,TYDREAL,1,"d_int" },
+
+	{ TYREAL,TYREAL,1,"r_nint" },
+	{ TYDREAL,TYDREAL,1,"d_nint" },
+
+	{ TYREAL,TYSHORT,1,"h_nint" },
+	{ TYREAL,TYLONG,1,"i_nint" },
+
+	{ TYDREAL,TYSHORT,1,"h_dnnt" },
+	{ TYDREAL,TYLONG,1,"i_dnnt" },
+
+	{ TYREAL,TYREAL,1,"r_abs" },
+	{ TYSHORT,TYSHORT,1,"h_abs" },
+	{ TYLONG,TYLONG,1,"i_abs" },
+	{ TYDREAL,TYDREAL,1,"d_abs" },
+	{ TYCOMPLEX,TYREAL,1,"c_abs" },
+	{ TYDCOMPLEX,TYDREAL,1,"z_abs" },
+
+	{ TYSHORT,TYSHORT,2,"h_mod" },
+	{ TYLONG,TYLONG,2,"i_mod" },
+	{ TYREAL,TYREAL,2,"r_mod" },
+	{ TYDREAL,TYDREAL,2,"d_mod" },
+
+	{ TYREAL,TYREAL,2,"r_sign" },
+	{ TYSHORT,TYSHORT,2,"h_sign" },
+	{ TYLONG,TYLONG,2,"i_sign" },
+	{ TYDREAL,TYDREAL,2,"d_sign" },
+
+	{ TYREAL,TYREAL,2,"r_dim" },
+	{ TYSHORT,TYSHORT,2,"h_dim" },
+	{ TYLONG,TYLONG,2,"i_dim" },
+	{ TYDREAL,TYDREAL,2,"d_dim" },
+
+	{ TYREAL,TYDREAL,2,"d_prod" },
+
+	{ TYCHAR,TYSHORT,1,"h_len" },
+	{ TYCHAR,TYLONG,1,"i_len" },
+
+	{ TYCHAR,TYSHORT,2,"h_indx" },
+	{ TYCHAR,TYLONG,2,"i_indx" },
+
+	{ TYCOMPLEX,TYREAL,1,"r_imag" },
+	{ TYDCOMPLEX,TYDREAL,1,"d_imag" },
+	{ TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" },
+	{ TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" },
+
+	{ TYREAL,TYREAL,1,"r_sqrt", 1 },
+	{ TYDREAL,TYDREAL,1,"d_sqrt", 1 },
+	{ TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" },
+	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" },
+
+	{ TYREAL,TYREAL,1,"r_exp", 2 },
+	{ TYDREAL,TYDREAL,1,"d_exp", 2 },
+	{ TYCOMPLEX,TYCOMPLEX,1,"c_exp" },
+	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" },
+
+	{ TYREAL,TYREAL,1,"r_log", 3 },
+	{ TYDREAL,TYDREAL,1,"d_log", 3 },
+	{ TYCOMPLEX,TYCOMPLEX,1,"c_log" },
+	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_log" },
+
+	{ TYREAL,TYREAL,1,"r_lg10" },
+	{ TYDREAL,TYDREAL,1,"d_lg10" },
+
+	{ TYREAL,TYREAL,1,"r_sin", 4 },
+	{ TYDREAL,TYDREAL,1,"d_sin", 4 },
+	{ TYCOMPLEX,TYCOMPLEX,1,"c_sin" },
+	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" },
+
+	{ TYREAL,TYREAL,1,"r_cos", 5 },
+	{ TYDREAL,TYDREAL,1,"d_cos", 5 },
+	{ TYCOMPLEX,TYCOMPLEX,1,"c_cos" },
+	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" },
+
+	{ TYREAL,TYREAL,1,"r_tan", 6 },
+	{ TYDREAL,TYDREAL,1,"d_tan", 6 },
+
+	{ TYREAL,TYREAL,1,"r_asin", 7 },
+	{ TYDREAL,TYDREAL,1,"d_asin", 7 },
+
+	{ TYREAL,TYREAL,1,"r_acos", 8 },
+	{ TYDREAL,TYDREAL,1,"d_acos", 8 },
+
+	{ TYREAL,TYREAL,1,"r_atan", 9 },
+	{ TYDREAL,TYDREAL,1,"d_atan", 9 },
+
+	{ TYREAL,TYREAL,2,"r_atn2", 10 },
+	{ TYDREAL,TYDREAL,2,"d_atn2", 10 },
+
+	{ TYREAL,TYREAL,1,"r_sinh", 11 },
+	{ TYDREAL,TYDREAL,1,"d_sinh", 11 },
+
+	{ TYREAL,TYREAL,1,"r_cosh", 12 },
+	{ TYDREAL,TYDREAL,1,"d_cosh", 12 },
+
+	{ TYREAL,TYREAL,1,"r_tanh", 13 },
+	{ TYDREAL,TYDREAL,1,"d_tanh", 13 },
+
+	{ TYCHAR,TYLOGICAL,2,"hl_ge" },
+	{ TYCHAR,TYLOGICAL,2,"l_ge" },
+
+	{ TYCHAR,TYLOGICAL,2,"hl_gt" },
+	{ TYCHAR,TYLOGICAL,2,"l_gt" },
+
+	{ TYCHAR,TYLOGICAL,2,"hl_le" },
+	{ TYCHAR,TYLOGICAL,2,"l_le" },
+
+	{ TYCHAR,TYLOGICAL,2,"hl_lt" },
+	{ TYCHAR,TYLOGICAL,2,"l_lt" },
+
+	{ TYREAL,TYSHORT,1,"hr_expn" },
+	{ TYREAL,TYLONG,1,"ir_expn" },
+	{ TYDREAL,TYSHORT,1,"hd_expn" },
+	{ TYDREAL,TYLONG,1,"id_expn" },
+
+	{ TYREAL,TYREAL,1,"r_absp" },
+	{ TYDREAL,TYDREAL,1,"d_absp" },
+
+	{ TYREAL,TYDREAL,1,"r_rrsp" },
+	{ TYDREAL,TYDREAL,1,"d_rrsp" },
+
+	{ TYREAL,TYREAL,1,"r_frac" },
+	{ TYDREAL,TYDREAL,1,"d_frac" },
+
+	{ TYREAL,TYREAL,2,"r_make" },
+	{ TYDREAL,TYDREAL,2,"d_make" },
+
+	{ TYREAL,TYREAL,2,"r_scal" },
+	{ TYDREAL,TYDREAL,2,"d_scal" },
+	{ 0 }
+} ;
+
+#if 0
+LOCAL struct Incstblock
+	{
+	char atype;
+	char rtype;
+	char constno;
+	} consttab[ ] =
+{
+	{ TYSHORT, TYLONG, 0 },
+	{ TYLONG, TYLONG, 1 },
+	{ TYREAL, TYLONG, 2 },
+	{ TYDREAL, TYLONG, 3 },
+
+	{ TYSHORT, TYLONG, 4 },
+	{ TYLONG, TYLONG, 5 },
+	{ TYREAL, TYLONG, 6 },
+	{ TYDREAL, TYLONG, 7 },
+
+	{ TYREAL, TYLONG, 8 },
+	{ TYDREAL, TYLONG, 9 },
+
+	{ TYREAL, TYLONG, 10 },
+	{ TYDREAL, TYLONG, 11 },
+
+	{ TYREAL, TYREAL, 0 },
+	{ TYDREAL, TYDREAL, 1 },
+
+	{ TYSHORT, TYLONG, 12 },
+	{ TYLONG, TYLONG, 13 },
+	{ TYREAL, TYREAL, 2 },
+	{ TYDREAL, TYDREAL, 3 },
+
+	{ TYREAL, TYREAL, 4 },
+	{ TYDREAL, TYDREAL, 5 }
+};
+#endif
+
+char *callbyvalue[ ] =
+	{0,
+	"sqrt",
+	"exp",
+	"log",
+	"sin",
+	"cos",
+	"tan",
+	"asin",
+	"acos",
+	"atan",
+	"atan2",
+	"sinh",
+	"cosh",
+	"tanh"
+	};
+
+ void
+r8fix()	/* adjust tables for -r8 */
+{
+	register struct Intrblock *I;
+	register struct Specblock *S;
+
+	for(I = intrtab; I->intrfname[0]; I++)
+		if (I->intrval.intrgroup != INTRGEN)
+		    switch(I->intrval.intrstuff) {
+			case TYREAL:
+				I->intrval.intrstuff = TYDREAL;
+				I->intrval.intrno = I->intrval.dblintrno;
+				break;
+			case TYCOMPLEX:
+				I->intrval.intrstuff = TYDCOMPLEX;
+				I->intrval.intrno = I->intrval.dblintrno;
+				I->intrval.dblcmplx = 1;
+			}
+
+	for(S = spectab; S->atype; S++)
+	    switch(S->atype) {
+		case TYCOMPLEX:
+			S->atype = TYDCOMPLEX;
+			if (S->rtype == TYREAL)
+				S->rtype = TYDREAL;
+			else if (S->rtype == TYCOMPLEX)
+				S->rtype = TYDCOMPLEX;
+			switch(S->spxname[0]) {
+				case 'r':
+					S->spxname[0] = 'd';
+					break;
+				case 'c':
+					S->spxname[0] = 'z';
+					break;
+				default:
+					Fatal("r8fix bug");
+				}
+			break;
+		case TYREAL:
+			S->atype = TYDREAL;
+			switch(S->rtype) {
+			    case TYREAL:
+				S->rtype = TYDREAL;
+				if (S->spxname[0] != 'r')
+					Fatal("r8fix bug");
+				S->spxname[0] = 'd';
+			    case TYDREAL:	/* d_prod */
+				break;
+
+			    case TYSHORT:
+				if (!strcmp(S->spxname, "hr_expn"))
+					S->spxname[1] = 'd';
+				else if (!strcmp(S->spxname, "h_nint"))
+					strcpy(S->spxname, "h_dnnt");
+				else Fatal("r8fix bug");
+				break;
+
+			    case TYLONG:
+				if (!strcmp(S->spxname, "ir_expn"))
+					S->spxname[1] = 'd';
+				else if (!strcmp(S->spxname, "i_nint"))
+					strcpy(S->spxname, "i_dnnt");
+				else Fatal("r8fix bug");
+				break;
+
+			    default:
+				Fatal("r8fix bug");
+			    }
+		}
+	}
+
+expptr intrcall(np, argsp, nargs)
+Namep np;
+struct Listblock *argsp;
+int nargs;
+{
+	int i, rettype;
+	Addrp ap;
+	register struct Specblock *sp;
+	register struct Chain *cp;
+	expptr Inline(), mkcxcon(), mkrealcon();
+	expptr q, ep;
+	int mtype;
+	int op;
+	int f1field, f2field, f3field;
+
+	packed.ijunk = np->vardesc.varno;
+	f1field = packed.bits.f1;
+	f2field = packed.bits.f2;
+	f3field = packed.bits.f3;
+	if(nargs == 0)
+		goto badnargs;
+
+	mtype = 0;
+	for(cp = argsp->listp ; cp ; cp = cp->nextp)
+	{
+		ep = (expptr)cp->datap;
+		if( ISCONST(ep) && ep->headblock.vtype==TYSHORT )
+			cp->datap = (char *) mkconv(tyint, ep);
+		mtype = maxtype(mtype, ep->headblock.vtype);
+	}
+
+	switch(f1field)
+	{
+	case INTRBOOL:
+		op = f3field;
+		if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
+			goto badtype;
+		if(op == OPBITNOT)
+		{
+			if(nargs != 1)
+				goto badnargs;
+			q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL);
+		}
+		else
+		{
+			if(nargs != 2)
+				goto badnargs;
+			q = mkexpr(op, (expptr)argsp->listp->datap,
+			    		(expptr)argsp->listp->nextp->datap);
+		}
+		frchain( &(argsp->listp) );
+		free( (charptr) argsp);
+		return(q);
+
+	case INTRCONV:
+		rettype = f2field;
+		if(rettype == TYLONG)
+			rettype = tyint;
+		if( ISCOMPLEX(rettype) && nargs==2)
+		{
+			expptr qr, qi;
+			qr = (expptr) argsp->listp->datap;
+			qi = (expptr) argsp->listp->nextp->datap;
+			if(ISCONST(qr) && ISCONST(qi))
+				q = mkcxcon(qr,qi);
+			else	q = mkexpr(OPCONV,mkconv(rettype-2,qr),
+			    mkconv(rettype-2,qi));
+		}
+		else if(nargs == 1) {
+			if (f3field && ((Exprp)argsp->listp->datap)->vtype
+					== TYDCOMPLEX)
+				rettype = TYDREAL;
+			q = mkconv(rettype+100, (expptr)argsp->listp->datap);
+			}
+		else goto badnargs;
+
+		q->headblock.vtype = rettype;
+		frchain(&(argsp->listp));
+		free( (charptr) argsp);
+		return(q);
+
+
+#if 0
+	case INTRCNST:
+
+/* Machine-dependent f77 stuff that f2c omits:
+
+intcon contains
+	radix for short int
+	radix for long int
+	radix for single precision
+	radix for double precision
+	precision for short int
+	precision for long int
+	precision for single precision
+	precision for double precision
+	emin for single precision
+	emin for double precision
+	emax for single precision
+	emax for double prcision
+	largest short int
+	largest long int
+
+realcon contains
+	tiny for single precision
+	tiny for double precision
+	huge for single precision
+	huge for double precision
+	mrsp (epsilon) for single precision
+	mrsp (epsilon) for double precision
+*/
+	{	register struct Incstblock *cstp;
+		extern ftnint intcon[14];
+		extern double realcon[6];
+
+		cstp = consttab + f3field;
+		for(i=0 ; i<f2field ; ++i)
+			if(cstp->atype == mtype)
+				goto foundconst;
+			else
+				++cstp;
+		goto badtype;
+
+foundconst:
+		switch(cstp->rtype)
+		{
+		case TYLONG:
+			return(mkintcon(intcon[cstp->constno]));
+
+		case TYREAL:
+		case TYDREAL:
+			return(mkrealcon(cstp->rtype,
+			    realcon[cstp->constno]) );
+
+		default:
+			Fatal("impossible intrinsic constant");
+		}
+	}
+#endif
+
+	case INTRGEN:
+		sp = spectab + f3field;
+		if(no66flag)
+			if(sp->atype == mtype)
+				goto specfunct;
+			else err66("generic function");
+
+		for(i=0; i<f2field ; ++i)
+			if(sp->atype == mtype)
+				goto specfunct;
+			else
+				++sp;
+		warn1 ("bad argument type to intrinsic %s", np->fvarname);
+
+/* Made this a warning rather than an error so things like "log (5) ==>
+   log (5.0)" can be accommodated.  When none of these cases matches, the
+   argument is cast up to the first type in the spectab list; this first
+   type is assumed to be the "smallest" type, e.g. REAL before DREAL
+   before COMPLEX, before DCOMPLEX */
+
+		sp = spectab + f3field;
+		mtype = sp -> atype;
+		goto specfunct;
+
+	case INTRSPEC:
+		sp = spectab + f3field;
+specfunct:
+		if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL))
+		    && (sp+1)->atype==sp->atype)
+			++sp;
+
+		if(nargs != sp->nargs)
+			goto badnargs;
+		if(mtype != sp->atype)
+			goto badtype;
+
+/* NOTE!!  I moved fixargs (YES) into the ELSE branch so that constants in
+   the inline expression wouldn't get put into the constant table */
+
+		fixargs (NO, argsp);
+		cast_args (mtype, argsp -> listp);
+
+		if(q = Inline((int)(sp-spectab), mtype, argsp->listp))
+		{
+			frchain( &(argsp->listp) );
+			free( (charptr) argsp);
+		} else {
+
+		    if(sp->othername) {
+			/* C library routines that return double... */
+			/* sp->rtype might be TYREAL */
+			ap = builtin(sp->rtype,
+				callbyvalue[sp->othername], 1);
+			q = fixexpr((Exprp)
+				mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );
+		    } else {
+			fixargs(YES, argsp);
+			ap = builtin(sp->rtype, sp->spxname, 0);
+			q = fixexpr((Exprp)
+				mkexpr(OPCALL, (expptr)ap, (expptr)argsp) );
+		    } /* else */
+		} /* else */
+		return(q);
+
+	case INTRMIN:
+	case INTRMAX:
+		if(nargs < 2)
+			goto badnargs;
+		if( ! ONEOF(mtype, MSKINT|MSKREAL) )
+			goto badtype;
+		argsp->vtype = mtype;
+		q = mkexpr( (f1field==INTRMIN ? OPMIN : OPMAX), (expptr)argsp, ENULL);
+
+		q->headblock.vtype = mtype;
+		rettype = f2field;
+		if(rettype == TYLONG)
+			rettype = tyint;
+		else if(rettype == TYUNKNOWN)
+			rettype = mtype;
+		return( mkconv(rettype, q) );
+
+	default:
+		fatali("intrcall: bad intrgroup %d", f1field);
+	}
+badnargs:
+	errstr("bad number of arguments to intrinsic %s", np->fvarname);
+	goto bad;
+
+badtype:
+	errstr("bad argument type to intrinsic %s", np->fvarname);
+
+bad:
+	return( errnode() );
+}
+
+
+
+
+intrfunct(s)
+char *s;
+{
+	register struct Intrblock *p;
+
+	for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p)
+	{
+		if( !strcmp(s, p->intrfname) )
+		{
+			packed.bits.f1 = p->intrval.intrgroup;
+			packed.bits.f2 = p->intrval.intrstuff;
+			packed.bits.f3 = p->intrval.intrno;
+			packed.bits.f4 = p->intrval.dblcmplx;
+			return(packed.ijunk);
+		}
+	}
+
+	return(0);
+}
+
+
+
+
+
+Addrp intraddr(np)
+Namep np;
+{
+	Addrp q;
+	register struct Specblock *sp;
+	int f3field;
+
+	if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC)
+		fatalstr("intraddr: %s is not intrinsic", np->fvarname);
+	packed.ijunk = np->vardesc.varno;
+	f3field = packed.bits.f3;
+
+	switch(packed.bits.f1)
+	{
+	case INTRGEN:
+		/* imag, log, and log10 arent specific functions */
+		if(f3field==31 || f3field==43 || f3field==47)
+			goto bad;
+
+	case INTRSPEC:
+		sp = spectab + f3field;
+		if(tyint==TYLONG && sp->rtype==TYSHORT)
+			++sp;
+		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);
+}

lang/fortran/comp/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();

lang/fortran/comp/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 */

lang/fortran/comp/main.c

@@ -0,0 +1,590 @@
+/****************************************************************
+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.
+****************************************************************/
+
+extern char F2C_version[];
+
+#include "defs.h"
+#include "parse.h"
+
+int complex_seen, dcomplex_seen;
+
+LOCAL int Max_ftn_files;
+
+char **ftn_files;
+int current_ftn_file = 0;
+
+flag ftn66flag = NO;
+flag nowarnflag = NO;
+flag noextflag = NO;
+flag  no66flag = NO;		/* Must also set noextflag to this
+					   same value */
+flag zflag = YES;		/* recognize double complex intrinsics */
+flag debugflag = NO;
+flag onetripflag = NO;
+flag shiftcase = YES;
+flag undeftype = NO;
+flag checksubs = NO;
+flag r8flag = NO;
+flag use_bs = YES;
+int tyreal = TYREAL;
+int tycomplex = TYCOMPLEX;
+extern void r8fix(), read_Pfiles();
+
+int maxregvar = MAXREGVAR;	/* if maxregvar > MAXREGVAR, error */
+int maxequiv = MAXEQUIV;
+int maxext = MAXEXT;
+int maxstno = MAXSTNO;
+int maxctl = MAXCTL;
+int maxhash = MAXHASH;
+int maxliterals = MAXLITERALS;
+int extcomm, ext1comm, useauto;
+int can_include = YES;	/* so we can disable includes for netlib */
+
+static char *def_i2 = "";
+
+static int useshortints = NO;	/* YES => tyint = TYSHORT */
+static int uselongints = NO;	/* YES => tyint = TYLONG */
+int addftnsrc = NO;		/* Include ftn source in output */
+int usedefsforcommon = NO;	/* Use #defines for common reference */
+int forcedouble = YES;		/* force real functions to double */
+int Ansi = NO;
+int def_equivs = YES;
+int tyioint = TYLONG;
+int szleng = SZLENG;
+int inqmask = M(TYLONG)|M(TYLOGICAL);
+int wordalign = NO;
+int forcereal = NO;
+static int skipC, skipversion;
+char *filename0, *parens;
+int Castargs = 1;
+static int typedefs = 0;
+int chars_per_wd, gflag, protostatus;
+int infertypes = 1;
+char used_rets[TYSUBR+1];
+extern char *tmpdir;
+static int h0align = 0;
+char *halign, *ohalign;
+int krparens = NO;
+int hsize;	/* for padding under -h */
+int htype;	/* for wr_equiv_init under -h */
+
+#define f2c_entry(swit,count,type,store,size) \
+	p_entry ("-", swit, 0, count, type, store, size)
+
+static arg_info table[] = {
+    f2c_entry ("w66", P_NO_ARGS, P_INT, &ftn66flag, YES),
+    f2c_entry ("w", P_NO_ARGS, P_INT, &nowarnflag, YES),
+    f2c_entry ("66", P_NO_ARGS, P_INT, &no66flag, YES),
+    f2c_entry ("d", P_ONE_ARG, P_INT, &debugflag, YES),
+    f2c_entry ("1", P_NO_ARGS, P_INT, &onetripflag, YES),
+    f2c_entry ("onetrip", P_NO_ARGS, P_INT, &onetripflag, YES),
+    f2c_entry ("I2", P_NO_ARGS, P_INT, &useshortints, YES),
+    f2c_entry ("I4", P_NO_ARGS, P_INT, &uselongints, YES),
+    f2c_entry ("U", P_NO_ARGS, P_INT, &shiftcase, NO),
+    f2c_entry ("u", P_NO_ARGS, P_INT, &undeftype, YES),
+    f2c_entry ("O", P_ONE_ARG, P_INT, &maxregvar, 0),
+    f2c_entry ("C", P_NO_ARGS, P_INT, &checksubs, YES),
+    f2c_entry ("Nq", P_ONE_ARG, P_INT, &maxequiv, 0),
+    f2c_entry ("Nx", P_ONE_ARG, P_INT, &maxext, 0),
+    f2c_entry ("Ns", P_ONE_ARG, P_INT, &maxstno, 0),
+    f2c_entry ("Nc", P_ONE_ARG, P_INT, &maxctl, 0),
+    f2c_entry ("Nn", P_ONE_ARG, P_INT, &maxhash, 0),
+    f2c_entry ("NL", P_ONE_ARG, P_INT, &maxliterals, 0),
+    f2c_entry ("c", P_NO_ARGS, P_INT, &addftnsrc, YES),
+    f2c_entry ("p", P_NO_ARGS, P_INT, &usedefsforcommon, YES),
+    f2c_entry ("R", P_NO_ARGS, P_INT, &forcedouble, NO),
+    f2c_entry ("!R", P_NO_ARGS, P_INT, &forcedouble, YES),
+    f2c_entry ("A", P_NO_ARGS, P_INT, &Ansi, YES),
+    f2c_entry ("ext", P_NO_ARGS, P_INT, &noextflag, YES),
+    f2c_entry ("z", P_NO_ARGS, P_INT, &zflag, NO),
+    f2c_entry ("a", P_NO_ARGS, P_INT, &useauto, YES),
+    f2c_entry ("r8", P_NO_ARGS, P_INT, &r8flag, YES),
+    f2c_entry ("i2", P_NO_ARGS, P_INT, &tyioint, NO),
+    f2c_entry ("w8", P_NO_ARGS, P_INT, &wordalign, YES),
+    f2c_entry ("!I", P_NO_ARGS, P_INT, &can_include, NO),
+    f2c_entry ("W", P_ONE_ARG, P_INT, &chars_per_wd, 0),
+    f2c_entry ("g", P_NO_ARGS, P_INT, &gflag, YES),
+    f2c_entry ("T", P_ONE_ARG, P_STRING, &tmpdir, 0),
+    f2c_entry ("E", P_NO_ARGS, P_INT, &extcomm, 1),
+    f2c_entry ("e1c", P_NO_ARGS, P_INT, &ext1comm, 1),
+    f2c_entry ("ec", P_NO_ARGS, P_INT, &ext1comm, 2),
+    f2c_entry ("C++", P_NO_ARGS, P_INT, &Ansi, 2),
+    f2c_entry ("P", P_NO_ARGS, P_INT, &Castargs, 3),
+    f2c_entry ("Ps", P_NO_ARGS, P_INT, &protostatus, 1),
+    f2c_entry ("!P", P_NO_ARGS, P_INT, &Castargs, 0),
+    f2c_entry ("!c", P_NO_ARGS, P_INT, &skipC, 1),
+    f2c_entry ("!it", P_NO_ARGS, P_INT, &infertypes, 0),
+    f2c_entry ("h", P_NO_ARGS, P_INT, &h0align, 1),
+    f2c_entry ("hd", P_NO_ARGS, P_INT, &h0align, 2),
+    f2c_entry ("kr", P_NO_ARGS, P_INT, &krparens, 1),
+    f2c_entry ("krd", P_NO_ARGS, P_INT, &krparens, 2),
+    f2c_entry ("!bs", P_NO_ARGS, P_INT, &use_bs, NO),
+    f2c_entry ("r", P_NO_ARGS, P_INT, &forcereal, YES),
+
+	/* 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"		*/
+static char *proto_fname;	/* "proto_file"		*/
+FILE *protofile;
+
+extern void list_init_data(), set_tmp_names(), sigcatch(), Un_link_all();
+extern char *c_name();
+
+
+set_externs ()
+{
+    static char *hset[3] = { 0, "integer", "doublereal" };
+
+/* Adjust the global flags according to the command line parameters */
+
+    if (chars_per_wd > 0) {
+	typesize[TYADDR] = typesize[TYLONG] = typesize[TYREAL] =
+		typesize[TYLOGICAL] = chars_per_wd;
+	typesize[TYDREAL] = typesize[TYCOMPLEX] = chars_per_wd << 1;
+	typesize[TYDCOMPLEX] = chars_per_wd << 2;
+	typesize[TYSHORT] = chars_per_wd >> 1;
+	typesize[TYCILIST] = 5*chars_per_wd;
+	typesize[TYICILIST] = 6*chars_per_wd;
+	typesize[TYOLIST] = 9*chars_per_wd;
+	typesize[TYCLLIST] = 3*chars_per_wd;
+	typesize[TYALIST] = 2*chars_per_wd;
+	typesize[TYINLIST] = 26*chars_per_wd;
+	}
+
+    if (wordalign)
+	typealign[TYDREAL] = typealign[TYDCOMPLEX] = typealign[TYREAL];
+    if (!tyioint) {
+	tyioint = TYSHORT;
+	szleng = typesize[TYSHORT];
+	def_i2 = "#define f2c_i2 1\n";
+	inqmask = M(TYSHORT)|M(TYLOGICAL);
+	goto checklong;
+	}
+    else
+	szleng = typesize[TYLONG];
+    if (useshortints) {
+	inqmask = M(TYLONG);
+ checklong:
+	protorettypes[TYLOGICAL] = typename[TYLOGICAL] = "shortlogical";
+	typesize[TYLOGICAL] = typesize[TYSHORT];
+	casttypes[TYLOGICAL] = "K_fp";
+	if (uselongints)
+	    err ("Can't use both long and short ints");
+	else
+	    tyint = tylogical = TYSHORT;
+	}
+    else if (uselongints)
+	tyint = TYLONG;
+
+    if (h0align) {
+	if (tyint == TYLONG && wordalign)
+		h0align = 1;
+    	ohalign = halign = hset[h0align];
+	htype = h0align == 1 ? tyint : TYDREAL;
+	hsize = typesize[htype];
+	}
+
+    if (no66flag)
+	noextflag = no66flag;
+    if (noextflag)
+	zflag = 0;
+
+    if (r8flag) {
+	tyreal = TYDREAL;
+	tycomplex = TYDCOMPLEX;
+	r8fix();
+	}
+    if (forcedouble) {
+	protorettypes[TYREAL] = "E_f";
+	casttypes[TYREAL] = "E_fp";
+	}
+
+    if (maxregvar > MAXREGVAR) {
+	warni("-O%d: too many register variables", maxregvar);
+	maxregvar = MAXREGVAR;
+    } /* if maxregvar > MAXREGVAR */
+
+/* Check the list of input files */
+
+    {
+	int bad, i, cur_max = Max_ftn_files;
+
+	for (i = bad = 0; i < cur_max && ftn_files[i]; i++)
+	    if (ftn_files[i][0] == '-') {
+		errstr ("Invalid flag '%s'", ftn_files[i]);
+		bad++;
+		}
+	if (bad)
+		exit(1);
+
+    } /* block */
+} /* set_externs */
+
+
+ static int
+comm2dcl()
+{
+	Extsym *ext;
+	if (ext1comm)
+		for(ext = extsymtab; ext < nextext; ext++)
+			if (ext->extstg == STGCOMMON && !ext->extinit)
+				return ext1comm;
+	return 0;
+	}
+
+ static void
+write_typedefs(outfile)
+ FILE *outfile;
+{
+	register int i;
+	register char *s, *p = 0;
+	static char st[4] = { TYREAL, TYCOMPLEX, TYDCOMPLEX, TYCHAR };
+	static char stl[4] = { 'E', 'C', 'Z', 'H' };
+
+	for(i = 0; i <= TYSUBR; i++)
+		if (s = usedcasts[i]) {
+			if (!p) {
+				p = Ansi == 1 ? "()" : "(...)";
+				nice_printf(outfile,
+				"/* Types for casting procedure arguments: */\
+\n\n#ifndef F2C_proc_par_types\n");
+				if (i == 0) {
+					nice_printf(outfile,
+			"typedef int /* Unknown procedure type */ (*%s)%s;\n",
+						 s, p);
+					continue;
+					}
+				}
+			nice_printf(outfile, "typedef %s (*%s)%s;\n",
+					c_type_decl(i,1), s, p);
+			}
+	for(i = !forcedouble; i < 4; i++)
+		if (used_rets[st[i]])
+			nice_printf(outfile,
+				"typedef %s %c_f; /* %s function */\n",
+				p = i ? "VOID" : "doublereal",
+				stl[i], ftn_types[st[i]]);
+	if (p)
+		nice_printf(outfile, "#endif\n\n");
+	}
+
+ static void
+commonprotos(outfile)
+ register FILE *outfile;
+{
+	register Extsym *e, *ee;
+	register Argtypes *at;
+	Atype *a, *ae;
+	int k;
+	extern int proc_protochanges;
+
+	if (!outfile)
+		return;
+	for (e = extsymtab, ee = nextext; e < ee; e++)
+		if (e->extstg == STGCOMMON && e->allextp)
+			nice_printf(outfile, "/* comlen %s %ld */\n",
+				e->cextname, e->maxleng);
+	if (Castargs < 3)
+		return;
+
+	/* -Pr: special comments conveying current knowledge
+	    of external references */
+
+	k = proc_protochanges;
+	for (e = extsymtab, ee = nextext; e < ee; e++)
+		if (e->extstg == STGEXT
+		&& e->cextname != e->fextname)	/* not a library function */
+		    if (at = e->arginfo) {
+			if ((!e->extinit || at->changes & 1)
+				/* not defined here or
+					changed since definition */
+			&& at->nargs >= 0) {
+				nice_printf(outfile, "/*:ref: %s %d %d",
+					e->cextname, e->extype, at->nargs);
+				a = at->atypes;
+				for(ae = a + at->nargs; a < ae; a++)
+					nice_printf(outfile, " %d", a->type);
+				nice_printf(outfile, " */\n");
+				if (at->changes & 1)
+					k++;
+				}
+			}
+		    else if (e->extype)
+			/* typed external, never invoked */
+			nice_printf(outfile, "/*:ref: %s %d :*/\n",
+				e->cextname, e->extype);
+	if (k) {
+		nice_printf(outfile,
+	"/* Rerunning f2c -P may change prototypes or declarations. */\n");
+		if (nerr)
+			return;
+		if (protostatus)
+			done(4);
+		if (protofile != stdout) {
+			fprintf(diagfile,
+	"Rerunning \"f2c -P ... %s %s\" may change prototypes or declarations.\n",
+				filename0, proto_fname);
+			fflush(diagfile);
+			}
+		}
+	}
+
+ int retcode = 0;
+
+main(argc, argv)
+int argc;
+char **argv;
+{
+	int c2d, k;
+	FILE *c_output;
+	char *filename, *cdfilename;
+	static char stderrbuf[BUFSIZ];
+	extern void def_commons();
+	extern char **dfltproc, *dflt1proc[];
+	extern char link_msg[];
+
+	diagfile = stderr;
+	setbuf(stderr, stderrbuf);	/* arrange for fast error msgs */
+
+	Max_ftn_files = argc - 1;
+	ftn_files = (char **)ckalloc((argc+1)*sizeof(char *));
+
+	parse_args (argc, argv, table, sizeof(table)/sizeof(arg_info),
+		ftn_files, Max_ftn_files);
+	if (!can_include && ext1comm == 2)
+		ext1comm = 1;
+	if (ext1comm && !extcomm)
+		extcomm = 2;
+	if (protostatus)
+		Castargs = 3;
+	else if (Castargs == 1 && !Ansi)
+		Castargs = 0;
+	if (Castargs >= 2 && !Ansi)
+		Ansi = 1;
+
+	if (!Ansi)
+		parens = "()";
+	else if (!Castargs)
+		parens = Ansi == 1 ? "()" : "(...)";
+	else
+		dfltproc = dflt1proc;
+
+	set_externs();
+	fileinit();
+	read_Pfiles(ftn_files);
+
+	for(k = 1; ftn_files[k]; k++)
+		if (dofork())
+			break;
+	filename0 = filename = 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 (filename && *filename) {
+		if (debugflag != 1) {
+			coutput = c_name(filename,'c');
+			if (Castargs >= 2)
+				proto_fname = c_name(filename,'P');
+			}
+		cdfilename = coutput;
+		if (skipC)
+			coutput = 0;
+		else if (!(c_output = fopen(coutput, textwrite))) {
+			filename = coutput;
+			coutput = 0;	/* don't delete read-only .c file */
+			fatalstr("can't open %.86s", filename);
+			}
+
+		if (Castargs >= 2
+		&& !(protofile = fopen(proto_fname, textwrite)))
+			fatalstr("Can't open %.84s\n", proto_fname);
+		}
+	else {
+		filename = "";
+		cdfilename = "f2c_out.c";
+		c_output = stdout;
+		coutput = 0;
+		if (Castargs >= 2) {
+			protofile = stdout;
+			if (!skipC)
+				printf("#ifdef P_R_O_T_O_T_Y_P_E_S\n");
+			}
+		}
+
+	if(inilex( copys(filename) ))
+		done(1);
+	if (filename0) {
+		fprintf(diagfile, "%s:\n", filename);
+		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 (!skipversion) {
+		nice_printf (c_output, "/* %s -- translated by f2c ", filename);
+		nice_printf (c_output, "(version of %s).\n", F2C_version);
+		nice_printf (c_output,
+	"   You must link the resulting object file with the libraries:\n\
+	%s   (in that order)\n*/\n\n", link_msg);
+		}
+	if (Ansi == 2)
+		nice_printf(c_output,
+			"#ifdef __cplusplus\nextern \"C\" {\n#endif\n");
+	nice_printf (c_output, "%s#include \"f2c.h\"\n\n", def_i2);
+	if (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__ (); }\n",
+		    main_alias);
+	    }
+	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);
+}

lang/fortran/comp/makefile

@@ -0,0 +1,84 @@
+#	Makefile for f2c, a Fortran 77 to C converter
+
+g = -g
+CFLAGS = $g
+SHELL = /bin/sh
+
+OBJECTSd = main.o init.o gram.o lex.o proc.o equiv.o data.o format.o \
+	  expr.o exec.o intr.o io.o misc.o error.o mem.o names.o \
+	  output.o p1output.o pread.o put.o putpcc.o vax.o formatdata.o \
+	  parse_args.o niceprintf.o cds.o sysdep.o version.o
+OBJECTS = $(OBJECTSd) malloc.o
+
+all: xsum.out f2c
+
+f2c: $(OBJECTS)
+	$(CC) $(LDFLAGS) $(OBJECTS) -o f2c
+	size f2c
+
+gram.c:	gram.head gram.dcl gram.expr gram.exec gram.io defs.h tokdefs.h
+	( sed <tokdefs.h "s/#define/%token/" ;\
+		cat gram.head gram.dcl gram.expr gram.exec gram.io ) >gram.in
+	$(YACC) $(YFLAGS) gram.in
+	echo "(expect 4 shift/reduce)"
+	sed 's/^# line.*/\/* & *\//' y.tab.c >gram.c
+	rm -f gram.in y.tab.c
+
+$(OBJECTSd): defs.h ftypes.h defines.h machdefs.h sysdep.h
+
+tokdefs.h: tokens
+	grep -n . <tokens | sed "s/\([^:]*\):\(.*\)/#define \2 \1/" >tokdefs.h
+
+cds.o: sysdep.h
+exec.o: p1defs.h names.h
+expr.o: output.h niceprintf.h names.h
+format.o: p1defs.h format.h output.h niceprintf.h names.h iob.h
+formatdata.o: format.h output.h niceprintf.h names.h
+gram.o: p1defs.h
+init.o: output.h niceprintf.h iob.h
+intr.o: names.h
+io.o: names.h iob.h
+lex.o : tokdefs.h p1defs.h
+main.o: parse.h usignal.h
+mem.o: iob.h
+names.o: iob.h names.h output.h niceprintf.h
+niceprintf.o: defs.h names.h output.h niceprintf.h
+output.o: output.h niceprintf.h names.h
+p1output.o: p1defs.h output.h niceprintf.h names.h
+parse_args.o: parse.h
+proc.o: tokdefs.h names.h niceprintf.h output.h p1defs.h
+put.o: names.h pccdefs.h p1defs.h
+putpcc.o: names.h
+vax.o: defs.h output.h pccdefs.h
+output.h: niceprintf.h
+
+put.o putpcc.o: pccdefs.h
+
+f2c.t: f2c.1t
+	troff -man f2c.1t >f2c.t
+
+f2c.1: f2c.1t
+	nroff -man f2c.1t | col -b | uniq >f2c.1
+
+clean:
+	rm -f gram.c *.o f2c tokdefs.h f2c.t
+
+b = Notice README cds.c data.c defines.h defs.h equiv.c error.c \
+	exec.c expr.c f2c.1 f2c.1t f2c.h format.c format.h formatdata.c \
+	ftypes.h gram.dcl gram.exec gram.expr gram.head gram.io \
+	init.c intr.c io.c iob.h lex.c machdefs.h main.c makefile \
+	malloc.c mem.c memset.c misc.c names.c names.h niceprintf.c \
+	niceprintf.h output.c output.h p1defs.h p1output.c \
+	parse.h parse_args.c pccdefs.h pread.c proc.c put.c putpcc.c \
+	sysdep.c sysdep.h tokens usignal.h vax.c version.c xsum.c
+
+bundle:
+	bundle $b xsum0.out >/tmp/f2c.bundle
+
+xsum: xsum.c
+	$(CC) -o xsum xsum.c
+
+#Check validity of transmitted source...
+xsum.out: xsum
+	./xsum $b >xsum1.out
+	cmp xsum0.out xsum1.out && mv xsum1.out xsum.out

lang/fortran/comp/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

lang/fortran/comp/mem.c

@@ -0,0 +1,230 @@
+/****************************************************************
+Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "iob.h"
+
+#define MEMBSIZE	32000
+#define GMEMBSIZE	16000
+
+ extern void exit();
+
+ char *
+gmem(n, round)
+ int n, round;
+{
+	static char *last, *next;
+	char *rv;
+	if (round)
+#ifdef CRAY
+		if ((long)next & 0xe000000000000000)
+			next = (char *)(((long)next & 0x1fffffffffffffff) + 1);
+#else
+#ifdef MSDOS
+		if ((int)next & 1)
+			next++;
+#else
+		next = (char *)(((long)next + sizeof(char *)-1)
+				& ~((long)sizeof(char *)-1));
+#endif
+#endif
+	rv = next;
+	if ((next += n) > last) {
+		rv = Alloc(n + GMEMBSIZE);
+
+		next = rv + n;
+		last = next + GMEMBSIZE;
+		}
+	return rv;
+	}
+
+ struct memblock {
+	struct memblock *next;
+	char buf[MEMBSIZE];
+	};
+ typedef struct memblock memblock;
+
+ static memblock *mem0;
+ memblock *curmemblock, *firstmemblock;
+
+ char *mem_first, *mem_next, *mem_last, *mem0_last;
+
+ void
+mem_init()
+{
+	curmemblock = firstmemblock = mem0
+		= (memblock *)Alloc(sizeof(memblock));
+	mem_first = mem0->buf;
+	mem_next  = mem0->buf;
+	mem_last  = mem0->buf + MEMBSIZE;
+	mem0_last = mem0->buf + MEMBSIZE;
+	mem0->next = 0;
+	}
+
+ char *
+mem(n, round)
+ int n, round;
+{
+	memblock *b;
+	register char *rv, *s;
+
+	if (round)
+#ifdef CRAY
+		if ((long)mem_next & 0xe000000000000000)
+			mem_next = (char *)(((long)mem_next & 0x1fffffffffffffff) + 1);
+#else
+#ifdef MSDOS
+		if ((int)mem_next & 1)
+			mem_next++;
+#else
+		mem_next = (char *)(((long)mem_next + sizeof(char *)-1)
+				& ~((long)sizeof(char *)-1));
+#endif
+#endif
+	rv = mem_next;
+	s = rv + n;
+	if (s >= mem_last) {
+		if (n > MEMBSIZE)  {
+			fprintf(stderr, "mem(%d) failure!\n", n);
+			exit(1);
+			}
+		if (!(b = curmemblock->next)) {
+			b = (memblock *)Alloc(sizeof(memblock));
+			curmemblock->next = b;
+			b->next = 0;
+			}
+		curmemblock = b;
+		rv = b->buf;
+		mem_last = rv + sizeof(b->buf);
+		s = rv + n;
+		}
+	mem_next = s;
+	return rv;
+	}
+
+ char *
+tostring(s,n)
+ register char *s;
+ int n;
+{
+	register char *s1, *se, **sf;
+	char *rv, *s0;
+	register int k = n + 2, t;
+
+	sf = str_fmt;
+	sf['%'] = "%";
+	s0 = s;
+	se = s + n;
+	for(; s < se; s++) {
+		t = *(unsigned char *)s;
+		s1 = sf[t];
+		while(*++s1)
+			k++;
+		}
+	sf['%'] = "%%";
+	rv = s1 = mem(k,0);
+	*s1++ = '"';
+	for(s = s0; s < se; s++) {
+		t = *(unsigned char *)s;
+		sprintf(s1, sf[t], t);
+		s1 += strlen(s1);
+		}
+	*s1 = 0;
+	return rv;
+	}
+
+ char *
+cpstring(s)
+ register char *s;
+{
+	return strcpy(mem(strlen(s)+1,0), s);
+	}
+
+ void
+new_iob_data(ios, name)
+ register io_setup *ios;
+ char *name;
+{
+	register iob_data *iod;
+	register char **s, **se;
+
+	iod = (iob_data *)
+		mem(sizeof(iob_data) + ios->nelt*sizeof(char *), 1);
+	iod->next = iob_list;
+	iob_list = iod;
+	iod->type = ios->fields[0];
+	iod->name = cpstring(name);
+	s = iod->fields;
+	se = s + ios->nelt;
+	while(s < se)
+		*s++ = "0";
+	*s = 0;
+	}
+
+ char *
+string_num(pfx, n)
+ char *pfx;
+ long n;
+{
+	char buf[32];
+	sprintf(buf, "%s%ld", pfx, n);
+	/* can't trust return type of sprintf -- BSD gets it wrong */
+	return strcpy(mem(strlen(buf)+1,0), buf);
+	}
+
+static defines *define_list;
+
+ void
+def_start(outfile, s1, s2, post)
+ FILE *outfile;
+ char *s1, *s2, *post;
+{
+	defines *d;
+	int n, n1;
+
+	n = n1 = strlen(s1);
+	if (s2)
+		n += strlen(s2);
+	d = (defines *)mem(sizeof(defines)+n, 1);
+	d->next = define_list;
+	define_list = d;
+	strcpy(d->defname, s1);
+	if (s2)
+		strcpy(d->defname + n1, s2);
+	nice_printf(outfile, "#define %s %s", d->defname, post);
+	}
+
+ void
+other_undefs(outfile)
+ FILE *outfile;
+{
+	defines *d;
+	if (d = define_list) {
+		define_list = 0;
+		nice_printf(outfile, "\n");
+		do
+			nice_printf(outfile, "#undef %s\n", d->defname);
+			while(d = d->next);
+		nice_printf(outfile, "\n");
+		}
+	}

lang/fortran/comp/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;
+	}

lang/fortran/comp/names.c

@@ -0,0 +1,711 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "output.h"
+#include "names.h"
+#include "iob.h"
+
+
+/* Names generated by the translator are guaranteed to be unique from the
+   Fortan names because Fortran does not allow underscores in identifiers,
+   and all of the system generated names do have underscores.  The various
+   naming conventions are outlined below:
+
+	FORMAT		APPLICATION
+   ----------------------------------------------------------------------
+	io_#		temporaries generated by IO calls; these will
+			contain the device number (e.g. 5, 6, 0)
+	ret_val		function return value, required for complex and
+			character functions.
+	ret_val_len	length of the return value in character functions
+
+	ssss_len	length of character argument "ssss"
+
+	c_#		member of the literal pool, where # is an
+			arbitrary label assigned by the system
+	cs_#		short integer constant in the literal pool
+	t_#		expression temporary, # is the depth of arguments
+			on the stack.
+	L#		label "#", given by user in the Fortran program.
+			This is unique because Fortran labels are numeric
+	pad_#		label on an init field required for alignment
+	xxx_init	label on a common block union, if a block data
+			requires a separate declaration
+*/
+
+/* generate variable references */
+
+char *c_type_decl (type, is_extern)
+int type, is_extern;
+{
+    static char buff[100];
+
+    switch (type) {
+	case TYADDR:	strcpy (buff, "address");	break;
+	case TYSHORT:	strcpy (buff, "shortint");	break;
+	case TYLONG:	strcpy (buff, "integer");	break;
+	case TYREAL:	if (!is_extern || !forcedouble)
+				{ strcpy (buff, "real");break; }
+	case TYDREAL:	strcpy (buff, "doublereal");	break;
+	case TYCOMPLEX:	if (is_extern)
+			    strcpy (buff, Ansi	? "/* Complex */ VOID"
+						: "/* Complex */ int");
+			else
+			    strcpy (buff, "complex");
+			break;
+	case TYDCOMPLEX:if (is_extern)
+			    strcpy (buff, Ansi	? "/* Double Complex */ VOID"
+						: "/* Double Complex */ int");
+			else
+			    strcpy (buff, "doublecomplex");
+			break;
+	case TYLOGICAL:	strcpy(buff, typename[TYLOGICAL]);
+			break;
+	case TYCHAR:	if (is_extern)
+			    strcpy (buff, Ansi	? "/* Character */ VOID"
+						: "/* Character */ int");
+			else
+			    strcpy (buff, "char");
+			break;
+
+        case TYUNKNOWN:	strcpy (buff, "UNKNOWN");
+
+/* If a procedure's type is unknown, assume it's a subroutine */
+
+			if (!is_extern)
+			    break;
+
+/* Subroutines must return an INT, because they might return a label
+   value.  Even if one doesn't, the caller will EXPECT it to. */
+
+	case TYSUBR:	strcpy (buff, "/* Subroutine */ int");
+							break;
+	case TYERROR:	strcpy (buff, "ERROR");		break;
+	case TYVOID:	strcpy (buff, "void");		break;
+	case TYCILIST:	strcpy (buff, "cilist");	break;
+	case TYICILIST:	strcpy (buff, "icilist");	break;
+	case TYOLIST:	strcpy (buff, "olist");		break;
+	case TYCLLIST:	strcpy (buff, "cllist");	break;
+	case TYALIST:	strcpy (buff, "alist");		break;
+	case TYINLIST:	strcpy (buff, "inlist");	break;
+	case TYFTNLEN:	strcpy (buff, "ftnlen");	break;
+	default:	sprintf (buff, "BAD DECL '%d'", type);
+							break;
+    } /* switch */
+
+    return buff;
+} /* c_type_decl */
+
+
+char *new_func_length()
+{ return "ret_val_len"; }
+
+char *new_arg_length(arg)
+ Namep arg;
+{
+	static char buf[64];
+	sprintf (buf, "%s_len", arg->fvarname);
+
+	return buf;
+} /* new_arg_length */
+
+
+/* declare_new_addr -- Add a new local variable to the function, given a
+   pointer to an Addrblock structure (which must have the uname_tag set)
+   This list of idents will be printed in reverse (i.e., chronological)
+   order */
+
+ void
+declare_new_addr (addrp)
+struct Addrblock *addrp;
+{
+    extern chainp new_vars;
+
+    new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars);
+} /* declare_new_addr */
+
+
+wr_nv_ident_help (outfile, addrp)
+FILE *outfile;
+struct Addrblock *addrp;
+{
+    int eltcount = 0;
+
+    if (addrp == (struct Addrblock *) NULL)
+	return;
+
+    if (addrp -> isarray) {
+	frexpr (addrp -> memoffset);
+	addrp -> memoffset = ICON(0);
+	eltcount = addrp -> ntempelt;
+	addrp -> ntempelt = 0;
+	addrp -> isarray = 0;
+    } /* if */
+    out_addr (outfile, addrp);
+    if (eltcount)
+	nice_printf (outfile, "[%d]", eltcount);
+} /* wr_nv_ident_help */
+
+int nv_type_help (addrp)
+struct Addrblock *addrp;
+{
+    if (addrp == (struct Addrblock *) NULL)
+	return -1;
+
+    return addrp -> vtype;
+} /* nv_type_help */
+
+
+/* lit_name -- returns a unique identifier for the given literal.  Make
+   the label useful, when possible.  For example:
+
+	1 -> c_1		(constant 1)
+	2 -> c_2		(constant 2)
+	1000 -> c_1000		(constant 1000)
+	1000000 -> c_b<memno>	(big constant number)
+	1.2 -> c_1_2		(constant 1.2)
+	1.234345 -> c_b<memno>	(big constant number)
+	-1 -> c_n1		(constant -1)
+	-1.0 -> c_n1_0		(constant -1.0)
+	.true. -> c_true	(constant true)
+	.false. -> c_false	(constant false)
+	default -> c_b<memno>	(default label)
+*/
+
+char *lit_name (litp)
+struct Literal *litp;
+{
+    static char buf[CONST_IDENT_MAX];
+
+    if (litp == (struct Literal *) NULL)
+	return NULL;
+
+    switch (litp -> littype) {
+        case TYSHORT:
+	    if (litp -> litval.litival < 32768 &&
+		    litp -> litval.litival > -32769) {
+		ftnint val = litp -> litval.litival;
+
+		if (val < 0)
+		    sprintf (buf, "cs_n%ld", -val);
+		else
+		    sprintf (buf, "cs__%ld", val);
+	    } else
+		sprintf (buf, "c_b%d", litp -> litnum);
+	    break;
+	case TYLONG:
+	    if (litp -> litval.litival < 100000 &&
+		    litp -> litval.litival > -10000) {
+		ftnint val = litp -> litval.litival;
+
+		if (val < 0)
+		    sprintf (buf, "c_n%ld", -val);
+		else
+		    sprintf (buf, "c__%ld", val);
+	    } else
+		sprintf (buf, "c_b%d", litp -> litnum);
+	    break;
+	case TYLOGICAL:
+	    sprintf (buf, "c_%s", (litp -> litval.litival ? "true" : "false"));
+	    break;
+	case TYREAL:
+	case TYDREAL:
+		/* Given a limit of 6 or 8 character on external names,	*/
+		/* few f.p. values can be meaningfully encoded in the	*/
+		/* constant name.  Just going with the default cb_#	*/
+		/* seems to be the best course for floating-point	*/
+		/* constants.	*/
+	case TYCHAR:
+	    /* Shouldn't be any of these */
+	case TYADDR:
+	case TYCOMPLEX:
+	case TYDCOMPLEX:
+	case TYSUBR:
+	default:
+	    sprintf (buf, "c_b%d", litp -> litnum);
+	    break;
+    } /* switch */
+    return buf;
+} /* lit_name */
+
+
+
+ char *
+comm_union_name(count)
+ int count;
+{
+	static char buf[12];
+
+	sprintf(buf, "%d", count);
+	return buf;
+	}
+
+
+
+
+/* wr_globals -- after every function has been translated, we need to
+   output the global declarations, such as the static table of constant
+   values */
+
+wr_globals (outfile)
+FILE *outfile;
+{
+    struct Literal *litp, *lastlit;
+    extern int hsize;
+    extern char *lit_name();
+    char *litname;
+    int did_one, t;
+    struct Constblock cb;
+    ftnint x, y;
+
+    if (nliterals == 0)
+	return;
+
+    lastlit = litpool + nliterals;
+    did_one = 0;
+    for (litp = litpool; litp < lastlit; litp++) {
+	if (!litp->lituse)
+		continue;
+	litname = lit_name(litp);
+	if (!did_one) {
+		margin_printf(outfile, "/* Table of constant values */\n\n");
+		did_one = 1;
+		}
+	cb.vtype = litp->littype;
+	if (litp->littype == TYCHAR) {
+		x = litp->litval.litival2[0] + litp->litval.litival2[1];
+		y = x + 1;
+		nice_printf(outfile,
+			"static struct { %s fill; char val[%ld+1];", halign, x);
+		if (y %= hsize)
+			nice_printf(outfile, " char fill2[%ld];", hsize - y);
+		nice_printf(outfile, " } %s_st = { 0,", litname);
+		cb.vleng = ICON(litp->litval.litival2[0]);
+		cb.Const.ccp = litp->cds[0];
+		cb.Const.ccp1.blanks = litp->litval.litival2[1];
+		cb.vtype = TYCHAR;
+		out_const(outfile, &cb);
+		frexpr(cb.vleng);
+		nice_printf(outfile, " };\n");
+		nice_printf(outfile, "#define %s %s_st.val\n", litname, litname);
+		continue;
+		}
+	nice_printf(outfile, "static %s %s = ",
+		c_type_decl(litp->littype,0), litname);
+
+	t = litp->littype;
+	if (ONEOF(t, MSKREAL|MSKCOMPLEX)) {
+		cb.vstg = 1;
+		cb.Const.cds[0] = litp->cds[0];
+		cb.Const.cds[1] = litp->cds[1];
+		}
+	else {
+		memcpy((char *)&cb.Const, (char *)&litp->litval,
+			sizeof(cb.Const));
+		cb.vstg = 0;
+		}
+	out_const(outfile, &cb);
+
+	nice_printf (outfile, ";\n");
+    } /* for */
+    if (did_one)
+    	nice_printf (outfile, "\n");
+} /* wr_globals */
+
+ ftnint
+commlen(vl)
+ register chainp vl;
+{
+	ftnint size;
+	int type;
+	struct Dimblock *t;
+	Namep v;
+
+	while(vl->nextp)
+		vl = vl->nextp;
+	v = (Namep)vl->datap;
+	type = v->vtype;
+	if (type == TYCHAR)
+		size = v->vleng->constblock.Const.ci;
+	else
+		size = typesize[type];
+	if ((t = v->vdim) && ISCONST(t->nelt))
+		size *= t->nelt->constblock.Const.ci;
+	return size + v->voffset;
+	}
+
+ static void	/* Pad common block if an EQUIVALENCE extended it. */
+pad_common(c)
+ Extsym *c;
+{
+	register chainp cvl;
+	register Namep v;
+	long L = c->maxleng;
+	int type;
+	struct Dimblock *t;
+	int szshort = typesize[TYSHORT];
+
+	for(cvl = c->allextp; cvl; cvl = cvl->nextp)
+		if (commlen((chainp)cvl->datap) >= L)
+			return;
+	v = ALLOC(Nameblock);
+	v->vtype = type = L % szshort ? TYCHAR
+				      : type_choice[L/szshort % 4];
+	v->vstg = STGCOMMON;
+	v->vclass = CLVAR;
+	v->tag = TNAME;
+	v->vdim = t = ALLOC(Dimblock);
+	t->ndim = 1;
+	t->dims[0].dimsize = ICON(L / typesize[type]);
+	v->fvarname = v->cvarname = "eqv_pad";
+	c->allextp = mkchain((char *)mkchain((char *)v, CHNULL), c->allextp);
+	}
+
+
+/* wr_common_decls -- outputs the common declarations in one of three
+   formats.  If all references to a common block look the same (field
+   names and types agree), only one actual declaration will appear.
+   Otherwise, the same block will require many structs.  If there is no
+   block data, these structs will be union'ed together (so the linker
+   knows the size of the largest one).  If there IS a block data, only
+   that version will be associated with the variable, others will only be
+   defined as types, so the pointer can be cast to it.  e.g.
+
+	FORTRAN				C
+----------------------------------------------------------------------
+	common /com1/ a, b, c		struct { real a, b, c; } com1_;
+
+	common /com1/ a, b, c		union {
+	common /com1/ i, j, k		    struct { real a, b, c; } _1;
+					    struct { integer i, j, k; } _2;
+					} com1_;
+
+	common /com1/ a, b, c		struct com1_1_ { real a, b, c; };
+	block data			struct { integer i, j, k; } com1_ =
+	common /com1/ i, j, k		  { 1, 2, 3 };
+	data i/1/, j/2/, k/3/
+
+
+   All of these versions will be followed by #defines, since the code in
+   the function bodies can't know ahead of time which of these options
+   will be taken */
+
+/* Macros for deciding the output type */
+
+#define ONE_STRUCT 1
+#define UNION_STRUCT 2
+#define INIT_STRUCT 3
+
+wr_common_decls(outfile)
+ FILE *outfile;
+{
+    Extsym *ext;
+    extern int extcomm;
+    static char *Extern[4] = {"", "Extern ", "extern "};
+    char *E, *E0 = Extern[extcomm];
+    int did_one = 0;
+
+    for (ext = extsymtab; ext < nextext; ext++) {
+	if (ext -> extstg == STGCOMMON && ext->allextp) {
+	    chainp comm;
+	    int count = 1;
+	    int which;			/* which display to use;
+					   ONE_STRUCT, UNION or INIT */
+
+	    if (!did_one)
+		nice_printf (outfile, "/* Common Block Declarations */\n\n");
+
+	    pad_common(ext);
+
+/* Construct the proper, condensed list of structs; eliminate duplicates
+   from the initial list   ext -> allextp   */
+
+	    comm = ext->allextp = revchain(ext->allextp);
+
+	    if (ext -> extinit)
+		which = INIT_STRUCT;
+	    else if (comm->nextp) {
+		which = UNION_STRUCT;
+		nice_printf (outfile, "%sunion {\n", E0);
+		next_tab (outfile);
+		E = "";
+		}
+	    else {
+		which = ONE_STRUCT;
+		E = E0;
+		}
+
+	    for (; comm; comm = comm -> nextp, count++) {
+
+		if (which == INIT_STRUCT)
+		    nice_printf (outfile, "struct %s%d_ {\n",
+			    ext->cextname, count);
+		else
+		    nice_printf (outfile, "%sstruct {\n", E);
+
+		next_tab (c_file);
+
+		wr_struct (outfile, (chainp) comm -> datap);
+
+		prev_tab (c_file);
+		if (which == UNION_STRUCT)
+		    nice_printf (outfile, "} _%d;\n", count);
+		else if (which == ONE_STRUCT)
+		    nice_printf (outfile, "} %s;\n", ext->cextname);
+		else
+		    nice_printf (outfile, "};\n");
+	    } /* for */
+
+	    if (which == UNION_STRUCT) {
+		prev_tab (c_file);
+		nice_printf (outfile, "} %s;\n", ext->cextname);
+	    } /* if */
+	    did_one = 1;
+	    nice_printf (outfile, "\n");
+
+	    for (count = 1, comm = ext -> allextp; comm;
+		    comm = comm -> nextp, count++) {
+		def_start(outfile, ext->cextname,
+			comm_union_name(count), "");
+		switch (which) {
+		    case ONE_STRUCT:
+		        extern_out (outfile, ext);
+		        break;
+		    case UNION_STRUCT:
+		        nice_printf (outfile, "(");
+			extern_out (outfile, ext);
+			nice_printf(outfile, "._%d)", count);
+		        break;
+		    case INIT_STRUCT:
+			nice_printf (outfile, "(*(struct ");
+			extern_out (outfile, ext);
+			nice_printf (outfile, "%d_ *) &", count);
+			extern_out (outfile, ext);
+			nice_printf (outfile, ")");
+		        break;
+		} /* switch */
+		nice_printf (outfile, "\n");
+	    } /* for count = 1, comm = ext -> allextp */
+	    nice_printf (outfile, "\n");
+	} /* if ext -> extstg == STGCOMMON */
+    } /* for ext = extsymtab */
+} /* wr_common_decls */
+
+
+wr_struct (outfile, var_list)
+FILE *outfile;
+chainp var_list;
+{
+    int last_type = -1;
+    int did_one = 0;
+    chainp this_var;
+
+    for (this_var = var_list; this_var; this_var = this_var -> nextp) {
+	Namep var = (Namep) this_var -> datap;
+	int type;
+	char *comment = NULL, *wr_ardecls ();
+
+	if (var == (Namep) NULL)
+	    err ("wr_struct:  null variable");
+	else if (var -> tag != TNAME)
+	    erri ("wr_struct:  bad tag on variable '%d'",
+		    var -> tag);
+
+	type = var -> vtype;
+
+	if (last_type == type && did_one)
+	    nice_printf (outfile, ", ");
+	else {
+	    if (did_one)
+		nice_printf (outfile, ";\n");
+	    nice_printf (outfile, "%s ",
+		    c_type_decl (type, var -> vclass == CLPROC));
+	} /* else */
+
+/* Character type is really a string type.  Put out a '*' for parameters
+   with unknown length and functions returning character */
+
+	if (var -> vtype == TYCHAR && (!ISICON ((var -> vleng))
+		|| var -> vclass == CLPROC))
+	    nice_printf (outfile, "*");
+
+	var -> vstg = STGAUTO;
+	out_name (outfile, var);
+	if (var -> vclass == CLPROC)
+	    nice_printf (outfile, "()");
+	else if (var -> vdim)
+	    comment = wr_ardecls(outfile, var->vdim,
+				var->vtype == TYCHAR && ISICON(var->vleng)
+				? var->vleng->constblock.Const.ci : 1L);
+	else if (var -> vtype == TYCHAR && var -> vclass != CLPROC &&
+	    ISICON ((var -> vleng)))
+	    nice_printf (outfile, "[%ld]",
+		    var -> vleng -> constblock.Const.ci);
+
+	if (comment)
+	    nice_printf (outfile, "%s", comment);
+	did_one = 1;
+	last_type = type;
+    } /* for this_var */
+
+    if (did_one)
+	nice_printf (outfile, ";\n");
+} /* wr_struct */
+
+
+char *user_label(stateno)
+ftnint stateno;
+{
+	static char buf[USER_LABEL_MAX + 1];
+	static char *Lfmt[2] = { "L_%ld", "L%ld" };
+
+	if (stateno >= 0)
+		sprintf(buf, Lfmt[shiftcase], stateno);
+	else
+		sprintf(buf, "L_%s", extsymtab[-1-stateno].fextname);
+	return buf;
+} /* user_label */
+
+
+char *temp_name (starter, num, storage)
+char *starter;
+int num;
+char *storage;
+{
+    static char buf[IDENT_LEN];
+    char *pointer = buf;
+    char *prefix = "t";
+
+    if (storage)
+	pointer = storage;
+
+    if (starter && *starter)
+	prefix = starter;
+
+    sprintf (pointer, "%s__%d", prefix, num);
+    return pointer;
+} /* temp_name */
+
+
+char *equiv_name (memno, store)
+int memno;
+char *store;
+{
+    static char buf[IDENT_LEN];
+    char *pointer = buf;
+
+    if (store)
+	pointer = store;
+
+    sprintf (pointer, "%s_%d", EQUIV_INIT_NAME, memno);
+    return pointer;
+} /* equiv_name */
+
+ void
+def_commons(of)
+ FILE *of;
+{
+	Extsym *ext;
+	int c, onefile, Union;
+	char buf[64];
+	chainp comm;
+	extern int ext1comm;
+
+	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 Language keywords.  Needed to filter unwanted fortran identifiers like
+ * "int", etc.  Source:  Kernighan & Ritchie, eds. 1 and 2; Stroustrup.
+ * Also includes C++ keywords and types used for I/O in f2c.h .
+ * These keywords must be in alphabetical order (as defined by strcmp()).
+ */
+
+char *c_keywords[] = {
+	"Long", "Multitype", "Namelist", "Vardesc",
+	"abs", "acos", "address", "alist", "asin", "asm",
+	"atan", "atan2", "auto", "break",
+	"case", "catch", "char", "cilist", "class", "cllist",
+	"complex", "const", "continue", "cos", "cosh",
+	"dabs", "default", "defined", "delete",
+	"dmax", "dmin", "do", "double", "doublecomplex", "doublereal",
+	"else", "entry", "enum", "exp", "extern",
+	"flag", "float", "for", "friend", "ftnint", "ftnlen", "goto",
+	"icilist", "if", "include", "inline", "inlist", "int", "integer",
+	"log", "logical", "long", "max", "min", "new",
+	"olist", "operator", "overload", "private", "protected", "public",
+	"real", "register", "return",
+	"short", "shortint", "shortlogical", "signed", "sin", "sinh",
+	"sizeof", "sqrt", "static", "struct", "switch",
+	"tan", "tanh", "template", "this", "try", "typedef",
+	"union", "unsigned", "virtual", "void", "volatile", "while"
+}; /* c_keywords */
+
+int n_keywords = sizeof(c_keywords)/sizeof(char *);

lang/fortran/comp/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 * */);

lang/fortran/comp/niceprintf.c

@@ -0,0 +1,367 @@
+/****************************************************************
+Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "names.h"
+#include "output.h"
+
+#define TOO_LONG_INDENT (2 * tab_size)
+#define MAX_INDENT 44
+#define MIN_INDENT 22
+static int last_was_newline = 0;
+int indent = 0;
+int in_comment = 0;
+
+ 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 (last_was_newline && use_indent) {
+	if (*start == '\n') do {
+		putc('\n', fp);
+		if (++start > end)
+			return;
+		}
+		while(*start == '\n');
+
+	ind = indent <= MAX_INDENT
+		? indent
+		: MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT);
+
+	tab = ind + extra_indent;
+
+	while (tab > 7) {
+	    putc ('\t', fp);
+	    tab -= 8;
+	} /* while */
+
+	while (tab-- > 0)
+	    putc (' ', fp);
+    } /* if last_was_newline */
+
+    while (start <= end)
+	putc (*start++, fp);
+} /* write_indent */
+
+
+/*VARARGS2*/
+int margin_printf (fp, a, b, c, d, e, f, g)
+FILE *fp;
+char *a;
+long b, c, d, e, f, g;
+{
+    ind_printf (0, fp, a, b, c, d, e, f, g);
+} /* margin_printf */
+
+/*VARARGS2*/
+int nice_printf (fp, a, b, c, d, e, f, g)
+FILE *fp;
+char *a;
+long b, c, d, e, f, g;
+{
+    ind_printf (1, fp, a, b, c, d, e, f, g);
+} /* nice_printf */
+
+
+#define  max_line_len c_output_line_length
+ 		/* 74Number of characters allowed on an output
+			           line.  This assumes newlines are handled
+			           nicely, i.e. a newline after a full text
+			           line on a terminal is ignored */
+
+/* output_buf   holds the text of the next line to be printed.  It gets
+   flushed when a newline is printed.   next_slot   points to the next
+   available location in the output buffer, i.e. where the next call to
+   nice_printf will have its output stored */
+
+static char *output_buf;
+static char *next_slot;
+static char *string_start;
+
+static char *word_start = NULL;
+static int cursor_pos = 0;
+static int In_string = 0;
+
+ void
+np_init()
+{
+	next_slot = output_buf = Alloc(MAX_OUTPUT_SIZE);
+	memset(output_buf, 0, MAX_OUTPUT_SIZE);
+	}
+
+ static char *
+adjust_pointer_in_string(pointer)
+ register char *pointer;
+{
+	register char *s, *s1, *se, *s0;
+
+	/* arrange not to break \002 */
+	s1 = string_start ? string_start : output_buf;
+	for(s = s1; s < pointer; s++) {
+		s0 = s1;
+		s1 = s;
+		if (*s == '\\') {
+			se = s++ + 4;
+			if (se > pointer)
+				break;
+			if (*s < '0' || *s > '7')
+				continue;
+			while(++s < se)
+				if (*s < '0' || *s > '7')
+					break;
+			--s;
+			}
+		}
+	return s0 - 1;
+	}
+
+/* ANSI says strcpy's behavior is undefined for overlapping args,
+ * so we roll our own fwd_strcpy: */
+
+ static void
+fwd_strcpy(t, s)
+ register char *t, *s;
+{ while(*t++ = *s++); }
+
+/* isident -- true iff character could belong to a unit.  C allows
+   letters, numbers and underscores in identifiers.  This also doubles as
+   a check for numeric constants, since we include the decimal point and
+   minus sign.  The minus has to be here, since the constant "10e-2"
+   cannot be broken up.  The '.' also prevents structure references from
+   being broken, which is a quite acceptable side effect */
+
+#define isident(x) (Tr[x] & 1)
+#define isntident(x) (!Tr[x])
+
+int ind_printf (use_indent, fp, a, b, c, d, e, f, g)
+int use_indent;
+FILE *fp;
+char *a;
+long b, c, d, e, f, g;
+{
+    extern int max_line_len;
+    extern FILEP c_file;
+    extern char tr_tab[];	/* in output.c */
+    register char *Tr = tr_tab;
+    int ch, inc, ind;
+    static int extra_indent, last_indent, set_cursor = 1;
+
+    cursor_pos += indent - last_indent;
+    last_indent = indent;
+    sprintf (next_slot, a, b, c, d, e, f, g);
+
+    if (fp != c_file) {
+	fprintf (fp,"%s", next_slot);
+	return 1;
+    } /* if fp != c_file */
+
+    do {
+	char *pointer;
+
+/* The   for   loop will parse one output line */
+
+	if (set_cursor) {
+		ind = indent <= MAX_INDENT
+			? indent
+			: MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT);
+		cursor_pos = ind + extra_indent;
+		set_cursor = 0;
+		}
+	if (in_comment)
+        	for (pointer = next_slot; *pointer && *pointer != '\n' &&
+				cursor_pos <= max_line_len; pointer++)
+			cursor_pos++;
+	else
+          for (pointer = next_slot; *pointer && *pointer != '\n' &&
+		cursor_pos <= max_line_len; pointer++) {
+
+	    /* Update state variables here */
+
+	    if (In_string) {
+		switch(*pointer) {
+			case '\\':
+				if (++cursor_pos > max_line_len) {
+					cursor_pos -= 2;
+					--pointer;
+					goto overflow;
+					}
+				++pointer;
+				break;
+			case '"':
+				In_string = 0;
+				word_start = 0;
+			}
+		}
+	    else switch (*pointer) {
+	        case '"':
+			if (cursor_pos + 5 > max_line_len) {
+				word_start = 0;
+				--pointer;
+				goto overflow;
+				}
+			In_string = 1;
+			string_start = word_start = pointer;
+		    	break;
+	        case '\'':
+			if (pointer[1] == '\\')
+				if ((ch = pointer[2]) >= '0' && ch <= '7')
+					for(inc = 3; pointer[inc] != '\''
+						&& ++inc < 5;);
+				else
+					inc = 3;
+			else
+				inc = 2;
+			/*debug*/ if (pointer[inc] != '\'')
+			/*debug*/  fatalstr("Bad character constant %.10s",
+					pointer);
+			if ((cursor_pos += inc) > max_line_len) {
+				cursor_pos -= inc;
+				word_start = 0;
+				--pointer;
+				goto overflow;
+				}
+			word_start = pointer;
+			pointer += inc;
+			break;
+		case '\t':
+		    cursor_pos = 8 * ((cursor_pos + 8) / 8) - 1;
+		    break;
+		default: {
+
+/* HACK  Assumes that all characters in an atomic C token will be written
+   at the same time.  Must check for tokens first, since '-' is considered
+   part of an identifier; checking isident first would mean breaking up "->" */
+
+		    if (!word_start && isident(*(unsigned char *)pointer))
+			word_start = pointer;
+		    else if (word_start && isntident(*(unsigned char *)pointer))
+			word_start = NULL;
+		    break;
+		} /* default */
+	    } /* switch */
+	    cursor_pos++;
+	} /* for pointer = next_slot */
+ overflow:
+	if (*pointer == '\0') {
+
+/* The output line is not complete, so break out and don't output
+   anything.  The current line fragment will be stored in the buffer */
+
+	    next_slot = pointer;
+	    break;
+	} else {
+	    char last_char;
+	    int in_string0 = In_string;
+
+/* If the line was too long, move   pointer   back to the character before
+   the current word.  This allows line breaking on word boundaries.  Make
+   sure that 80 character comment lines get broken up somehow.  We assume
+   that any non-string 80 character identifier must be in a comment.
+*/
+
+	    if (word_start && *pointer != '\n' && word_start > output_buf)
+		if (In_string)
+			if (string_start && pointer - string_start < 5)
+				pointer = string_start - 1;
+			else {
+				pointer = adjust_pointer_in_string(pointer);
+				string_start = 0;
+				}
+		else if (word_start == string_start
+				&& pointer - string_start >= 5) {
+			pointer = adjust_pointer_in_string(next_slot);
+			In_string = 1;
+			string_start = 0;
+			}
+		else
+			pointer = word_start - 1;
+	    else if (cursor_pos > max_line_len) {
+		extern char *strchr();
+		if (In_string) {
+			pointer = adjust_pointer_in_string(pointer);
+			if (string_start && pointer > string_start)
+				string_start = 0;
+			}
+		else if (strchr("&*+-/<=>|", *pointer)
+			&& strchr("!%&*+-/<=>^|", pointer[-1])) {
+			pointer -= 2;
+			if (strchr("<>", *pointer)) /* <<=, >>= */
+				pointer--;
+			}
+		else
+			pointer--;
+		}
+	    last_char = *pointer;
+	    write_indent(fp, use_indent, extra_indent, output_buf, pointer);
+	    next_slot = output_buf;
+	    if (In_string && !string_start && Ansi == 1 && last_char != '\n')
+		*next_slot++ = '"';
+	    fwd_strcpy(next_slot, pointer + 1);
+
+/* insert a line break */
+
+	    if (last_char == '\n') {
+		if (In_string)
+			last_was_newline = 0;
+		else {
+			last_was_newline = 1;
+			extra_indent = 0;
+			}
+		}
+	    else {
+		extra_indent = TOO_LONG_INDENT;
+		if (In_string && !string_start) {
+			if (Ansi == 1) {
+				fprintf(fp, "\"\n");
+				use_indent = 1;
+				last_was_newline = 1;
+				}
+			else {
+				fprintf(fp, "\\\n");
+				last_was_newline = 0;
+				}
+			In_string = in_string0;
+			}
+		else {
+			putc ('\n', fp);
+			last_was_newline = 1;
+			}
+	    } /* if *pointer != '\n' */
+
+	    if (In_string && Ansi != 1 && !string_start)
+		cursor_pos = 0;
+	    else
+		set_cursor = 1;
+
+	    string_start = word_start = NULL;
+
+	} /* else */
+
+    } while (*next_slot);
+
+    return 0;
+} /* ind_printf */

lang/fortran/comp/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)
+
+
+

lang/fortran/comp/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 ();

lang/fortran/comp/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
+
+*/

lang/fortran/comp/p1output.c

@@ -0,0 +1,568 @@
+/****************************************************************
+Copyright 1990, 1991 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "p1defs.h"
+#include "output.h"
+#include "names.h"
+
+
+static void p1_addr(), p1_big_addr(), p1_binary(), p1_const(), p1_list(),
+	p1_literal(), p1_name(), p1_unary(), p1putn();
+static void p1putd (/* int, int */);
+static void p1putds (/* int, int, char * */);
+static void p1putdds (/* int, int, int, char * */);
+static void p1putdd (/* int, int, int */);
+static void p1putddd (/* int, int, int, int */);
+
+
+/* p1_comment -- save the text of a Fortran comment in the intermediate
+   file.  Make sure that there are no spurious "/ *" or "* /" characters by
+   mapping them onto "/+" and "+/".   str   is assumed to hold no newlines and be
+   null terminated; it may be modified by this function. */
+
+void p1_comment (str)
+char *str;
+{
+    register unsigned char *pointer, *ustr;
+
+    if (!str)
+	return;
+
+/* Get rid of any open or close comment combinations that may be in the
+   Fortran input */
+
+	ustr = (unsigned char *)str;
+	for(pointer = ustr; *pointer; pointer++)
+		if (*pointer == '*' && (pointer[1] == '/'
+					|| pointer > ustr && pointer[-1] == '/'))
+			*pointer = '+';
+	/* trim trailing white space */
+#ifdef isascii
+	while(--pointer >= ustr && (!isascii(*pointer) || isspace(*pointer)));
+#else
+	while(--pointer >= ustr && isspace(*pointer));
+#endif
+	pointer[1] = 0;
+	p1puts (P1_COMMENT, str);
+} /* p1_comment */
+
+void p1_line_number (line_number)
+long line_number;
+{
+
+    p1putd (P1_SET_LINE, line_number);
+} /* p1_line_number */
+
+/* p1_name -- Writes the address of a hash table entry into the
+   intermediate file */
+
+static void p1_name (namep)
+Namep namep;
+{
+	p1putd (P1_NAME_POINTER, (long) namep);
+	namep->visused = 1;
+} /* p1_name */
+
+
+
+void p1_expr (expr)
+expptr expr;
+{
+/* An opcode of 0 means a null entry */
+
+    if (expr == ENULL) {
+	p1putdd (P1_EXPR, 0, TYUNKNOWN);	/* Should this be TYERROR? */
+	return;
+    } /* if (expr == ENULL) */
+
+    switch (expr -> tag) {
+        case TNAME:
+		p1_name ((Namep) expr);
+		return;
+	case TCONST:
+		p1_const(&expr->constblock);
+		return;
+	case TEXPR:
+		/* Fall through the switch */
+		break;
+	case TADDR:
+		p1_addr (&(expr -> addrblock));
+		goto freeup;
+	case TPRIM:
+		warn ("p1_expr:  got TPRIM");
+		return;
+	case TLIST:
+		p1_list (&(expr->listblock));
+		frchain( &(expr->listblock.listp) );
+		return;
+	case TERROR:
+		return;
+	default:
+		erri ("p1_expr: bad tag '%d'", (int) (expr -> tag));
+		return;
+	}
+
+/* Now we know that the tag is TEXPR */
+
+    if (is_unary_op (expr -> exprblock.opcode))
+	p1_unary (&(expr -> exprblock));
+    else if (is_binary_op (expr -> exprblock.opcode))
+	p1_binary (&(expr -> exprblock));
+    else
+	erri ("p1_expr:  bad opcode '%d'", (int) expr -> exprblock.opcode);
+ freeup:
+    free((char *)expr);
+
+} /* p1_expr */
+
+
+
+static void p1_const(cp)
+ register Constp cp;
+{
+	int type = cp->vtype;
+	expptr vleng = cp->vleng;
+	union Constant *c = &cp->Const;
+	char cdsbuf0[64], cdsbuf1[64];
+	char *cds0, *cds1;
+
+    switch (type) {
+        case TYSHORT:
+	case TYLONG:
+	case TYLOGICAL:
+	    fprintf(pass1_file, "%d: %d %ld\n", P1_CONST, type, c->ci);
+	    break;
+	case TYREAL:
+	case TYDREAL:
+		fprintf(pass1_file, "%d: %d %s\n", P1_CONST, type,
+			cp->vstg ? c->cds[0] : cds(dtos(c->cd[0]), cdsbuf0));
+	    break;
+	case TYCOMPLEX:
+	case TYDCOMPLEX:
+		if (cp->vstg) {
+			cds0 = c->cds[0];
+			cds1 = c->cds[1];
+			}
+		else {
+			cds0 = cds(dtos(c->cd[0]), cdsbuf0);
+			cds1 = cds(dtos(c->cd[1]), cdsbuf1);
+			}
+		fprintf(pass1_file, "%d: %d %s %s\n", P1_CONST, type,
+			cds0, cds1);
+	    break;
+	case TYCHAR:
+	    if (vleng && !ISICON (vleng))
+		erri("p1_const:  bad vleng '%d'\n", (int) vleng);
+	    else
+		fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type,
+			cpexpr((expptr)cp));
+	    break;
+	default:
+	    erri ("p1_const:  bad constant type '%d'", type);
+	    break;
+    } /* switch */
+} /* p1_const */
+
+
+void p1_asgoto (addrp)
+Addrp addrp;
+{
+    p1put (P1_ASGOTO);
+    p1_addr (addrp);
+} /* p1_asgoto */
+
+
+void p1_goto (stateno)
+ftnint stateno;
+{
+    p1putd (P1_GOTO, stateno);
+} /* p1_goto */
+
+
+static void p1_addr (addrp)
+ register struct Addrblock *addrp;
+{
+    int stg;
+
+    if (addrp == (struct Addrblock *) NULL)
+	return;
+
+    stg = addrp -> vstg;
+
+    if (ONEOF(stg, M(STGINIT)|M(STGREG))
+	|| ONEOF(stg, M(STGCOMMON)|M(STGEQUIV)) &&
+		(!ISICON(addrp->memoffset)
+		|| (addrp->uname_tag == UNAM_NAME
+			? addrp->memoffset->constblock.Const.ci
+				!= addrp->user.name->voffset
+			: addrp->memoffset->constblock.Const.ci))
+	|| ONEOF(stg, M(STGBSS)|M(STGINIT)|M(STGAUTO)|M(STGARG)) &&
+		(!ISICON(addrp->memoffset)
+			|| addrp->memoffset->constblock.Const.ci)
+	|| addrp->Field || addrp->isarray || addrp->vstg == STGLENG)
+	{
+		p1_big_addr (addrp);
+		return;
+	}
+
+/* Write out a level of indirection for non-array arguments, which have
+   addrp -> memoffset   set and are handled by   p1_big_addr().
+   Lengths are passed by value, so don't check STGLENG
+   28-Jun-89 (dmg)  Added the check for != TYCHAR
+ */
+
+    if (oneof_stg ( addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : NULL,
+	    stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) {
+	p1putdd (P1_EXPR, OPWHATSIN, addrp -> vtype);
+	p1_expr (ENULL);	/* Put dummy   vleng   */
+    } /* if stg == STGARG */
+
+    switch (addrp -> uname_tag) {
+        case UNAM_NAME:
+	    p1_name (addrp -> user.name);
+	    break;
+	case UNAM_IDENT:
+	    p1putdds(P1_IDENT, addrp->vtype, addrp->vstg,
+				addrp->user.ident);
+	    break;
+	case UNAM_CHARP:
+		p1putdds(P1_CHARP, addrp->vtype, addrp->vstg,
+				addrp->user.Charp);
+		break;
+	case UNAM_EXTERN:
+	    p1putd (P1_EXTERN, (long) addrp -> memno);
+	    if (addrp->vclass == CLPROC)
+		extsymtab[addrp->memno].extype = addrp->vtype;
+	    break;
+	case UNAM_CONST:
+	    if (addrp -> memno != BAD_MEMNO)
+		p1_literal (addrp -> memno);
+	    else
+		p1_const((struct Constblock *)addrp);
+	    break;
+	case UNAM_UNKNOWN:
+	default:
+	    erri ("p1_addr:  unknown uname_tag '%d'", addrp -> uname_tag);
+	    break;
+    } /* switch */
+} /* p1_addr */
+
+
+static void p1_list (listp)
+struct Listblock *listp;
+{
+    chainp lis;
+    int count = 0;
+
+    if (listp == (struct Listblock *) NULL)
+	return;
+
+/* Count the number of parameters in the list */
+
+    for (lis = listp -> listp; lis; lis = lis -> nextp)
+	count++;
+
+    p1putddd (P1_LIST, listp -> tag, listp -> vtype, count);
+
+    for (lis = listp -> listp; lis; lis = lis -> nextp)
+	p1_expr ((expptr) lis -> datap);
+
+} /* p1_list */
+
+
+void p1_label (lab)
+long lab;
+{
+	if (parstate < INDATA)
+		earlylabs = mkchain((char *)lab, earlylabs);
+	else
+		p1putd (P1_LABEL, lab);
+	}
+
+
+
+static void p1_literal (memno)
+long memno;
+{
+    p1putd (P1_LITERAL, memno);
+} /* p1_literal */
+
+
+void p1_if (expr)
+expptr expr;
+{
+    p1put (P1_IF);
+    p1_expr (expr);
+} /* p1_if */
+
+
+
+
+void p1_elif (expr)
+expptr expr;
+{
+    p1put (P1_ELIF);
+    p1_expr (expr);
+} /* p1_elif */
+
+
+
+
+void p1_else ()
+{
+    p1put (P1_ELSE);
+} /* p1_else */
+
+
+
+
+void p1_endif ()
+{
+    p1put (P1_ENDIF);
+} /* p1_endif */
+
+
+
+
+void p1else_end ()
+{
+    p1put (P1_ENDELSE);
+} /* p1else_end */
+
+
+static void p1_big_addr (addrp)
+Addrp addrp;
+{
+    if (addrp == (Addrp) NULL)
+	return;
+
+    p1putn (P1_ADDR, 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 */

lang/fortran/comp/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

lang/fortran/comp/parse_args.c

@@ -0,0 +1,499 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* parse_args
+
+	This function will parse command line input into appropriate data
+   structures, output error messages when appropriate and provide some
+   minimal type conversion.
+
+	Input to the function consists of the standard   argc,argv
+   values, and a table which directs the parser.  Each table entry has the
+   following components:
+
+	prefix -- the (optional) switch character string, e.g. "-" "/" "="
+	switch -- the command string, e.g. "o" "data" "file" "F"
+	flags -- control flags, e.g.   CASE_INSENSITIVE, REQUIRED_PREFIX
+	arg_count -- number of arguments this command requires, e.g. 0 for
+		     booleans, 1 for filenames, INFINITY for input files
+	result_type -- how to interpret the switch arguments, e.g. STRING,
+		       CHAR, FILE, OLD_FILE, NEW_FILE
+	result_ptr -- pointer to storage for the result, be it a table or
+		      a string or whatever
+	table_size -- if the arguments fill a table, the maximum number of
+		      entries; if there are no arguments, the value to
+		      load into the result storage
+
+	Although the table can be used to hold a list of filenames, only
+   scalar values (e.g. pointers) can be stored in the table.  No vector
+   processing will be done, only pointers to string storage will be moved.
+
+	An example entry, which could be used to parse input filenames, is:
+
+	"-", "o", 0, oo, OLD_FILE, infilenames, INFILE_TABLE_SIZE
+
+*/
+
+#include <stdio.h>
+#ifndef NULL
+/* ANSI C */
+#include <stddef.h>
+#endif
+#include "parse.h"
+#include <math.h>	     /* For atof */
+#include <ctype.h>
+
+#define MAX_INPUT_SIZE 1000
+
+#define arg_prefix(x) ((x).prefix)
+#define arg_string(x) ((x).string)
+#define arg_flags(x) ((x).flags)
+#define arg_count(x) ((x).count)
+#define arg_result_type(x) ((x).result_type)
+#define arg_result_ptr(x) ((x).result_ptr)
+#define arg_table_size(x) ((x).table_size)
+
+#ifndef TRUE
+#define TRUE 1
+#endif
+#ifndef FALSE
+#define FALSE 0
+#endif
+typedef int boolean;
+
+
+char *lower_string (/* char [], char * */);
+
+static char *this_program = "";
+
+extern long atol();
+static int arg_parse (/* char *, arg_info * */);
+
+
+boolean parse_args (argc, argv, table, entries, others, other_count)
+int argc;
+char *argv[];
+arg_info table[];
+int entries;
+char *others[];
+int other_count;
+{
+    boolean arg_verify (/* argv, table, entries */);
+    void init_store (/* table, entries */);
+
+    boolean result;
+
+    if (argv)
+	this_program = argv[0];
+
+/* Check the validity of the table and its parameters */
+
+    result = arg_verify (argv, table, entries);
+
+/* Initialize the storage values */
+
+    init_store (table, entries);
+
+    if (result) {
+	boolean use_prefix = TRUE;
+	char *argv0;
+
+	argc--;
+	argv0 = *++argv;
+	while (argc) {
+	    int index, length;
+
+	    index = match_table (*argv, table, entries, use_prefix, &length);
+	    if (index < 0) {
+
+/* The argument doesn't match anything in the table */
+
+		if (others) {
+
+		    if (*argv > argv0)
+			*--*argv = '-';	/* complain at invalid flag */
+
+		    if (other_count > 0) {
+			*others++ = *argv;
+			other_count--;
+		    } else {
+			fprintf (stderr, "%s:  too many parameters: ",
+				this_program);
+			fprintf (stderr, "'%s' ignored\n", *argv);
+		    } /* else */
+		} /* if (others) */
+		argv0 = *++argv;
+		argc--;
+	    } else {
+
+/* A match was found */
+
+		if (length >= strlen (*argv)) {
+		    argc--;
+		    argv0 = *++argv;
+		    use_prefix = TRUE;
+		} else {
+		    (*argv) += length;
+		    use_prefix = FALSE;
+		} /* else */
+
+/* Parse any necessary arguments */
+
+		if (arg_count (table[index]) != P_NO_ARGS) {
+
+/* Now   length   will be used to store the number of parsed characters */
+
+		    length = arg_parse(*argv, &table[index]);
+		    if (*argv == NULL)
+			argc = 0;
+		    else if (length >= strlen (*argv)) {
+			argc--;
+			argv0 = *++argv;
+			use_prefix = TRUE;
+		    } else {
+			(*argv) += length;
+			use_prefix = FALSE;
+		    } /* else */
+		} /* if (argv_count != P_NO_ARGS) */
+		  else
+		    *arg_result_ptr(table[index]) =
+			    arg_table_size(table[index]);
+	    } /* else */
+	} /* while (argc) */
+    } /* if (result) */
+
+    return result;
+} /* parse_args */
+
+
+boolean arg_verify (argv, table, entries)
+char *argv[];
+arg_info table[];
+int entries;
+{
+    int i;
+    char *this_program = "";
+
+    if (argv)
+	this_program = argv[0];
+
+    for (i = 0; i < entries; i++) {
+	arg_info *arg = &table[i];
+
+/* Check the argument flags */
+
+	if (arg_flags (*arg) & ~(P_CASE_INSENSITIVE | P_REQUIRED_PREFIX)) {
+	    fprintf (stderr, "%s [arg_verify]:  too many ", this_program);
+	    fprintf (stderr, "flags in entry %d:  '%x' (hex)\n", i,
+		    arg_flags (*arg));
+	} /* if */
+
+/* Check the argument count */
+
+	{ int count = arg_count (*arg);
+
+	    if (count != P_NO_ARGS && count != P_ONE_ARG && count !=
+		    P_INFINITE_ARGS) {
+		fprintf (stderr, "%s [arg_verify]:  invalid ", this_program);
+		fprintf (stderr, "argument count in entry %d:  '%d'\n", i,
+			count);
+	    } /* if count != P_NO_ARGS ... */
+
+/* Check the result field; want to be able to store results */
+
+	      else
+		if (arg_result_ptr (*arg) == (int *) NULL) {
+		    fprintf (stderr, "%s [arg_verify]:  ", this_program);
+		    fprintf (stderr, "no argument storage given for ");
+		    fprintf (stderr, "entry %d\n", i);
+		} /* if arg_result_ptr */
+	}
+
+/* Check the argument type */
+
+	{ int type = arg_result_type (*arg);
+
+	    if (type < P_STRING || type > P_DOUBLE)
+		    fprintf(stderr,
+			"%s [arg_verify]:  bad arg type in entry %d:  '%d'\n",
+			this_program, i, type);
+	}
+
+/* Check table size */
+
+	{ int size = arg_table_size (*arg);
+
+	    if (arg_count (*arg) == P_INFINITE_ARGS && size < 1) {
+		fprintf (stderr, "%s [arg_verify]:  bad ", this_program);
+		fprintf (stderr, "table size in entry %d:  '%d'\n", i,
+			size);
+	    } /* if (arg_count == P_INFINITE_ARGS && size < 1) */
+	}
+
+    } /* for i = 0 */
+
+    return TRUE;
+} /* arg_verify */
+
+
+/* match_table -- returns the index of the best entry matching the input,
+   -1 if no match.  The best match is the one of longest length which
+   appears lowest in the table.  The length of the match will be returned
+   in   length   ONLY IF a match was found.   */
+
+int match_table (norm_input, table, entries, use_prefix, length)
+register char *norm_input;
+arg_info table[];
+int entries;
+boolean use_prefix;
+int *length;
+{
+    extern int match (/* char *, char *, arg_info *, boolean */);
+
+    char low_input[MAX_INPUT_SIZE];
+    register int i;
+    int best_index = -1, best_length = 0;
+
+/* FUNCTION BODY */
+
+    (void) lower_string (low_input, norm_input);
+
+    for (i = 0; i < entries; i++) {
+	int this_length = match (norm_input, low_input, &table[i], use_prefix);
+
+	if (this_length > best_length) {
+	    best_index = i;
+	    best_length = this_length;
+	} /* if (this_length > best_length) */
+    } /* for (i = 0) */
+
+    if (best_index > -1 && length != (int *) NULL)
+	*length = best_length;
+
+    return best_index;
+} /* match_table */
+
+
+/* match -- takes an input string and table entry, and returns the length
+   of the longer match.
+
+	0 ==> input doesn't match
+
+   For example:
+
+	INPUT	PREFIX	STRING	RESULT
+----------------------------------------------------------------------
+	"abcd"	"-"	"d"	0
+	"-d"	"-"	"d"	2    (i.e. "-d")
+	"dout"	"-"	"d"	1    (i.e. "d")
+	"-d"	""	"-d"	2    (i.e. "-d")
+	"dd"	"d"	"d"	2	<= here's the weird one
+*/
+
+int match (norm_input, low_input, entry, use_prefix)
+char *norm_input, *low_input;
+arg_info *entry;
+boolean use_prefix;
+{
+    char *norm_prefix = arg_prefix (*entry);
+    char *norm_string = arg_string (*entry);
+    boolean prefix_match = FALSE, string_match = FALSE;
+    int result = 0;
+
+/* Buffers for the lowercased versions of the strings being compared.
+   These are used when the switch is to be case insensitive */
+
+    static char low_prefix[MAX_INPUT_SIZE];
+    static char low_string[MAX_INPUT_SIZE];
+    int prefix_length = strlen (norm_prefix);
+    int string_length = strlen (norm_string);
+
+/* Pointers for the required strings (lowered or nonlowered) */
+
+    register char *input, *prefix, *string;
+
+/* FUNCTION BODY */
+
+/* Use the appropriate strings to handle case sensitivity */
+
+    if (arg_flags (*entry) & P_CASE_INSENSITIVE) {
+	input = low_input;
+	prefix = lower_string (low_prefix, norm_prefix);
+	string = lower_string (low_string, norm_string);
+    } else {
+	input = norm_input;
+	prefix = norm_prefix;
+	string = norm_string;
+    } /* else */
+
+/* First, check the string formed by concatenating the prefix onto the
+   switch string, but only when the prefix is not being ignored */
+
+    if (use_prefix && prefix != NULL && *prefix != '\0')
+	 prefix_match = (strncmp (input, prefix, prefix_length) == 0) &&
+		(strncmp (input + prefix_length, string, string_length) == 0);
+
+/* Next, check just the switch string, if that's allowed */
+
+    if (!use_prefix && (arg_flags (*entry) & P_REQUIRED_PREFIX) == 0)
+	string_match = strncmp (input, string, string_length) == 0;
+
+    if (prefix_match)
+	result = prefix_length + string_length;
+    else if (string_match)
+	result = string_length;
+
+    return result;
+} /* match */
+
+
+char *lower_string (dest, src)
+char *dest, *src;
+{
+    char *result = dest;
+    register int c;
+
+    if (dest == NULL || src == NULL)
+	result = NULL;
+    else
+	while (*dest++ = (c = *src++) >= 'A' && c <= 'Z' ? tolower(c) : c);
+
+    return result;
+} /* lower_string */
+
+
+/* arg_parse -- returns the number of characters parsed for this entry */
+
+static int arg_parse (str, entry)
+char *str;
+arg_info *entry;
+{
+    int length = 0;
+
+    if (arg_count (*entry) == P_ONE_ARG) {
+	char **store = (char **) arg_result_ptr (*entry);
+
+	length = put_one_arg (arg_result_type (*entry), str, store,
+		arg_prefix (*entry), arg_string (*entry));
+
+    } /* if (arg_count == P_ONE_ARG) */
+      else { /* Must be a table of arguments */
+	char **store = (char **) arg_result_ptr (*entry);
+
+	if (store) {
+	    while (*store)
+		store++;
+
+	    length = put_one_arg (arg_result_type (*entry), str, store++,
+		    arg_prefix (*entry), arg_string (*entry));
+
+	    *store = (char *) NULL;
+	} /* if (store) */
+    } /* else */
+
+    return length;
+} /* arg_parse */
+
+
+int put_one_arg (type, str, store, prefix, string)
+int type;
+char *str;
+char **store;
+char *prefix, *string;
+{
+    int length = 0;
+    long L;
+
+    if (store) {
+	switch (type) {
+	    case P_STRING:
+	    case P_FILE:
+	    case P_OLD_FILE:
+	    case P_NEW_FILE:
+		*store = str;
+		if (str == NULL)
+		    fprintf (stderr, "%s: Missing argument after '%s%s'\n",
+			    this_program, prefix, string);
+		length = str ? strlen (str) : 0;
+		break;
+	    case P_CHAR:
+		*((char *) store) = *str;
+		length = 1;
+		break;
+	    case P_SHORT:
+		L = atol(str);
+		*(short *)store = (short) L;
+		if (L != *(short *)store)
+		    fprintf(stderr,
+	"%s%s parameter '%ld' is not a SHORT INT (truncating to %d)\n",
+			    prefix, string, L, *(short *)store);
+		length = strlen (str);
+		break;
+	    case P_INT:
+		L = atol(str);
+		*(int *)store = (int)L;
+		if (L != *(int *)store)
+		    fprintf(stderr,
+	"%s%s parameter '%ld' is not an INT (truncating to %d)\n",
+			    prefix, string, L, *(int *)store);
+		length = strlen (str);
+		break;
+	    case P_LONG:
+		*(long *)store = atol(str);
+		length = strlen (str);
+		break;
+	    case P_FLOAT:
+		*((float *) store) = (float) atof (str);
+		length = strlen (str);
+		break;
+	    case P_DOUBLE:
+		*((double *) store) = (double) atof (str);
+		length = strlen (str);
+		break;
+	    default:
+		fprintf (stderr, "put_one_arg:  bad type '%d'\n",
+			type);
+		break;
+	} /* switch */
+    } /* if (store) */
+
+    return length;
+} /* put_one_arg */
+
+
+void init_store (table, entries)
+arg_info *table;
+int entries;
+{
+    int index;
+
+    for (index = 0; index < entries; index++)
+	if (arg_count (table[index]) == P_INFINITE_ARGS) {
+	    char **place = (char **) arg_result_ptr (table[index]);
+
+	    if (place)
+		*place = (char *) NULL;
+	} /* if arg_count == P_INFINITE_ARGS */
+
+} /* init_store */
+

lang/fortran/comp/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

lang/fortran/comp/pread.c

@@ -0,0 +1,881 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+
+ static char Ptok[128], Pct[Table_size];
+ static char *Pfname;
+ static long Plineno;
+ static int Pbad;
+ static int *tfirst, *tlast, *tnext, tmax;
+
+#define P_space	1
+#define P_anum	2
+#define P_delim	3
+#define P_slash	4
+
+#define TGULP	100
+
+ static void
+trealloc()
+{
+	int k = tmax;
+	tfirst = (int *)realloc((char *)tfirst,
+		(tmax += TGULP)*sizeof(int));
+	if (!tfirst) {
+		fprintf(stderr,
+		"Pfile: realloc failure!\n");
+		exit(2);
+		}
+	tlast = tfirst + tmax;
+	tnext = tfirst + k;
+	}
+
+ static void
+badchar(c)
+ int c;
+{
+	fprintf(stderr,
+		"unexpected character 0x%.2x = '%c' on line %ld of %s\n",
+		c, c, Plineno, Pfname);
+	exit(2);
+	}
+
+ static void
+bad_type()
+{
+	fprintf(stderr,
+		"unexpected type \"%s\" on line %ld of %s\n",
+		Ptok, Plineno, Pfname);
+	exit(2);
+	}
+
+ static void
+badflag(tname, option)
+ char *tname, *option;
+{
+	fprintf(stderr, "%s type from `f2c -%s` on line %ld of %s\n",
+		tname, option, Plineno, Pfname);
+	Pbad++;
+	}
+
+ static void
+detected(msg)
+ char *msg;
+{
+	fprintf(stderr,
+	"%sdetected on line %ld of %s\n", msg, Plineno, Pfname);
+	Pbad++;
+	}
+
+ static void
+checklogical(k)
+ int k;
+{
+	static int lastmsg = 0;
+	static int seen[2] = {0,0};
+
+	seen[k] = 1;
+	if (seen[1-k]) {
+		if (lastmsg < 3) {
+			lastmsg = 3;
+			detected(
+	"Illegal combination of LOGICAL types -- mixing -I4 with -I2 or -i2\n\t");
+			}
+		return;
+		}
+	if (k) {
+		if (tylogical == TYLONG || lastmsg >= 2)
+			return;
+		if (!lastmsg) {
+			lastmsg = 2;
+			badflag("LOGICAL", "I4");
+			}
+		}
+	else {
+		if (tylogical == TYSHORT || lastmsg & 1)
+			return;
+		if (!lastmsg) {
+			lastmsg = 1;
+			badflag("LOGICAL", "i2` or `f2c -I2");
+			}
+		}
+	}
+
+ static void
+checkreal(k)
+{
+	static int warned = 0;
+	static int seen[2] = {0,0};
+
+	seen[k] = 1;
+	if (seen[1-k]) {
+		if (warned < 2)
+			detected("Illegal mixture of -R and -!R ");
+		warned = 2;
+		return;
+		}
+	if (k == forcedouble || warned)
+		return;
+	warned = 1;
+	badflag("REAL return", k ? "!R" : "R");
+	}
+
+ static void
+Pnotboth(e)
+ Extsym *e;
+{
+	if (e->curno)
+		return;
+	Pbad++;
+	e->curno = 1;
+	fprintf(stderr,
+	"%s cannot be both a procedure and a common block (line %ld of %s)\n",
+		e->fextname, Plineno, Pfname);
+	}
+
+ static int
+numread(pf, n)
+ register FILE *pf;
+ int *n;
+{
+	register int c, k;
+
+	if ((c = getc(pf)) < '0' || c > '9')
+		return c;
+	k = c - '0';
+	for(;;) {
+		if ((c = getc(pf)) == ' ') {
+			*n = k;
+			return c;
+			}
+		if (c < '0' || c > '9')
+			break;
+		k = 10*k + c - '0';
+		}
+	return c;
+	}
+
+ static void argverify(), Pbadret();
+
+ static int
+readref(pf, e, ftype)
+ register FILE *pf;
+ Extsym *e;
+ int ftype;
+{
+	register int c, *t;
+	int i, nargs, type;
+	Argtypes *at;
+	Atype *a, *ae;
+
+	if (ftype > TYSUBR)
+		return 0;
+	if ((c = numread(pf, &nargs)) != ' ') {
+		if (c != ':')
+			return c == EOF;
+		/* just a typed external */
+		if (e->extstg == STGUNKNOWN) {
+			at = 0;
+			goto justsym;
+			}
+		if (e->extstg == STGEXT) {
+			if (e->extype != ftype)
+				Pbadret(ftype, e);
+			}
+		else
+			Pnotboth(e);
+		return 0;
+		}
+
+	tnext = tfirst;
+	for(i = 0; i < nargs; i++) {
+		if ((c = numread(pf, &type)) != ' '
+		|| type >= 500
+		|| type != TYFTNLEN + 100 && type % 100 > TYSUBR)
+			return c == EOF;
+		if (tnext >= tlast)
+			trealloc();
+		*tnext++ = type;
+		}
+
+	if (e->extstg == STGUNKNOWN) {
+ save_at:
+		at = (Argtypes *)
+			gmem(sizeof(Argtypes) + (nargs-1)*sizeof(Atype), 1);
+		at->nargs = nargs;
+		at->changes = 0;
+		t = tfirst;
+		a = at->atypes;
+		for(ae = a + nargs; a < ae; a++) {
+			a->type = *t++;
+			a->cp = 0;
+			}
+ justsym:
+		e->extstg = STGEXT;
+		e->extype = ftype;
+		e->arginfo = at;
+		}
+	else if (e->extstg != STGEXT) {
+		Pnotboth(e);
+		}
+	else if (!e->arginfo) {
+		if (e->extype != ftype)
+			Pbadret(ftype, e);
+		else
+			goto save_at;
+		}
+	else
+		argverify(ftype, e);
+	return 0;
+	}
+
+ static int
+comlen(pf)
+ register FILE *pf;
+{
+	register int c;
+	register char *s, *se;
+	char buf[128], cbuf[128];
+	int refread;
+	long L;
+	Extsym *e;
+
+	if ((c = getc(pf)) == EOF)
+		return 1;
+	if (c == ' ') {
+		refread = 0;
+		s = "comlen ";
+		}
+	else if (c == ':') {
+		refread = 1;
+		s = "ref: ";
+		}
+	else {
+ ret0:
+		if (c == '*')
+			ungetc(c,pf);
+		return 0;
+		}
+	while(*s) {
+		if ((c = getc(pf)) == EOF)
+			return 1;
+		if (c != *s++)
+			goto ret0;
+		}
+	s = buf;
+	se = buf + sizeof(buf) - 1;
+	for(;;) {
+		if ((c = getc(pf)) == EOF)
+			return 1;
+		if (c == ' ')
+			break;
+		if (s >= se || Pct[c] != P_anum)
+			goto ret0;
+		*s++ = c;
+		}
+	*s-- = 0;
+	if (s <= buf || *s != '_')
+		return 0;
+	strcpy(cbuf,buf);
+	*s-- = 0;
+	if (*s == '_') {
+		*s-- = 0;
+		if (s <= buf)
+			return 0;
+		}
+	for(L = 0;;) {
+		if ((c = getc(pf)) == EOF)
+			return 1;
+		if (c == ' ')
+			break;
+		if (c < '0' && c > '9')
+			goto ret0;
+		L = 10*L + c - '0';
+		}
+	if (!L && !refread)
+		return 0;
+	e = mkext(buf, cbuf);
+	if (refread)
+		return readref(pf, e, (int)L);
+	if (e->extstg == STGUNKNOWN) {
+		e->extstg = STGCOMMON;
+		e->maxleng = L;
+		}
+	else if (e->extstg != STGCOMMON)
+		Pnotboth(e);
+	else if (e->maxleng != L) {
+		fprintf(stderr,
+	"incompatible lengths for common block %s (line %ld of %s)\n",
+				    buf, Plineno, Pfname);
+		if (e->maxleng < L)
+			e->maxleng = L;
+		}
+	return 0;
+	}
+
+ static int
+Ptoken(pf, canend)
+ FILE *pf;
+ int canend;
+{
+	register int c;
+	register char *s, *se;
+
+ top:
+	for(;;) {
+		c = getc(pf);
+		if (c == EOF) {
+			if (canend)
+				return 0;
+			goto badeof;
+			}
+		if (Pct[c] != P_space)
+			break;
+		if (c == '\n')
+			Plineno++;
+		}
+	switch(Pct[c]) {
+		case P_anum:
+			if (c == '_')
+				badchar(c);
+			s = Ptok;
+			se = s + sizeof(Ptok) - 1;
+			do {
+				if (s < se)
+					*s++ = c;
+				if ((c = getc(pf)) == EOF) {
+ badeof:
+					fprintf(stderr,
+					"unexpected end of file in %s\n",
+						Pfname);
+					exit(2);
+					}
+				}
+				while(Pct[c] == P_anum);
+			ungetc(c,pf);
+			*s = 0;
+			return P_anum;
+
+		case P_delim:
+			return c;
+
+		case P_slash:
+			if ((c = getc(pf)) != '*') {
+				if (c == EOF)
+					goto badeof;
+				badchar('/');
+				}
+			if (canend && comlen(pf))
+				goto badeof;
+			for(;;) {
+				while((c = getc(pf)) != '*') {
+					if (c == EOF)
+						goto badeof;
+					if (c == '\n')
+						Plineno++;
+					}
+ slashseek:
+				switch(getc(pf)) {
+					case '/':
+						goto top;
+					case EOF:
+						goto badeof;
+					case '*':
+						goto slashseek;
+					}
+				}
+		default:
+			badchar(c);
+		}
+	/* NOT REACHED */
+	return 0;
+	}
+
+ static int
+Pftype()
+{
+	switch(Ptok[0]) {
+		case 'C':
+			if (!strcmp(Ptok+1, "_f"))
+				return TYCOMPLEX;
+			break;
+		case 'E':
+			if (!strcmp(Ptok+1, "_f")) {
+				/* TYREAL under forcedouble */
+				checkreal(1);
+				return TYREAL;
+				}
+			break;
+		case 'H':
+			if (!strcmp(Ptok+1, "_f"))
+				return TYCHAR;
+			break;
+		case 'Z':
+			if (!strcmp(Ptok+1, "_f"))
+				return TYDCOMPLEX;
+			break;
+		case 'd':
+			if (!strcmp(Ptok+1, "oublereal"))
+				return TYDREAL;
+			break;
+		case 'i':
+			if (!strcmp(Ptok+1, "nt"))
+				return TYSUBR;
+			if (!strcmp(Ptok+1, "nteger"))
+				return TYLONG;
+			break;
+		case 'l':
+			if (!strcmp(Ptok+1, "ogical")) {
+				checklogical(1);
+				return TYLOGICAL;
+				}
+			break;
+		case 'r':
+			if (!strcmp(Ptok+1, "eal")) {
+				checkreal(0);
+				return TYREAL;
+				}
+			break;
+		case 's':
+			if (!strcmp(Ptok+1, "hortint"))
+				return TYSHORT;
+			if (!strcmp(Ptok+1, "hortlogical")) {
+				checklogical(0);
+				return TYLOGICAL;
+				}
+			break;
+		}
+	bad_type();
+	/* NOT REACHED */
+	return 0;
+	}
+
+ static void
+wanted(i, what)
+ int i;
+ char *what;
+{
+	if (i != P_anum) {
+		Ptok[0] = i;
+		Ptok[1] = 0;
+		}
+	fprintf(stderr,"Error: expected %s, not \"%s\" (line %ld of %s)\n",
+		what, Ptok, Plineno, Pfname);
+	exit(2);
+	}
+
+ static int
+Ptype(pf)
+ FILE *pf;
+{
+	int i, rv;
+
+	i = Ptoken(pf,0);
+	if (i == ')')
+		return 0;
+	if (i != P_anum)
+		badchar(i);
+
+	rv = 0;
+	switch(Ptok[0]) {
+		case 'C':
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYCOMPLEX+200;
+			break;
+		case 'D':
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYDREAL+200;
+			break;
+		case 'E':
+		case 'R':
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYREAL+200;
+			break;
+		case 'H':
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYCHAR+200;
+			break;
+		case 'I':
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYLONG+200;
+			break;
+		case 'J':
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYSHORT+200;
+			break;
+		case 'K':
+			checklogical(0);
+			goto Logical;
+		case 'L':
+			checklogical(1);
+ Logical:
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYLOGICAL+200;
+			break;
+		case 'S':
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYSUBR+200;
+			break;
+		case 'U':
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYUNKNOWN+300;
+			break;
+		case 'Z':
+			if (!strcmp(Ptok+1, "_fp"))
+				rv = TYDCOMPLEX+200;
+			break;
+		case 'c':
+			if (!strcmp(Ptok+1, "har"))
+				rv = TYCHAR;
+			else if (!strcmp(Ptok+1, "omplex"))
+				rv = TYCOMPLEX;
+			break;
+		case 'd':
+			if (!strcmp(Ptok+1, "oublereal"))
+				rv = TYDREAL;
+			else if (!strcmp(Ptok+1, "oublecomplex"))
+				rv = TYDCOMPLEX;
+			break;
+		case 'f':
+			if (!strcmp(Ptok+1, "tnlen"))
+				rv = TYFTNLEN+100;
+			break;
+		case 'i':
+			if (!strcmp(Ptok+1, "nteger"))
+				rv = TYLONG;
+			break;
+		case 'l':
+			if (!strcmp(Ptok+1, "ogical")) {
+				checklogical(1);
+				rv = TYLOGICAL;
+				}
+			break;
+		case 'r':
+			if (!strcmp(Ptok+1, "eal"))
+				rv = TYREAL;
+			break;
+		case 's':
+			if (!strcmp(Ptok+1, "hortint"))
+				rv = TYSHORT;
+			else if (!strcmp(Ptok+1, "hortlogical")) {
+				checklogical(0);
+				rv = TYLOGICAL;
+				}
+			break;
+		case 'v':
+			if (tnext == tfirst && !strcmp(Ptok+1, "oid")) {
+				if ((i = Ptoken(pf,0)) != /*(*/ ')')
+					wanted(i, /*(*/ "\")\"");
+				return 0;
+				}
+		}
+	if (!rv)
+		bad_type();
+	if (rv < 100 && (i = Ptoken(pf,0)) != '*')
+			wanted(i, "\"*\"");
+	if ((i = Ptoken(pf,0)) == P_anum)
+		i = Ptoken(pf,0);	/* skip variable name */
+	switch(i) {
+		case ')':
+			ungetc(i,pf);
+			break;
+		case ',':
+			break;
+		default:
+			wanted(i, "\",\" or \")\"");
+		}
+	return rv;
+	}
+
+ static char *
+trimunder()
+{
+	register char *s;
+	register int n;
+	static char buf[128];
+
+	s = Ptok + strlen(Ptok) - 1;
+	if (*s != '_') {
+		fprintf(stderr,
+			"warning: %s does not end in _ (line %ld of %s)\n",
+			Ptok, Plineno, Pfname);
+		return Ptok;
+		}
+	if (s[-1] == '_')
+		s--;
+	strncpy(buf, Ptok, n = s - Ptok);
+	buf[n] = 0;
+	return buf;
+	}
+
+ static void
+Pbadmsg(msg, p)
+ char *msg;
+ Extsym *p;
+{
+	Pbad++;
+	fprintf(stderr, "%s for %s (line %ld of %s):\n\t", msg,
+		p->fextname, Plineno, Pfname);
+	p->arginfo->nargs = -1;
+	}
+
+ char *Argtype();
+
+ static void
+Pbadret(ftype, p)
+ int ftype;
+ Extsym *p;
+{
+	char buf1[32], buf2[32];
+
+	Pbadmsg("inconsistent types",p);
+	fprintf(stderr, "here %s, previously %s\n",
+		Argtype(ftype+200,buf1),
+		Argtype(p->extype+200,buf2));
+	}
+
+ static void
+argverify(ftype, p)
+ int ftype;
+ Extsym *p;
+{
+	Argtypes *at;
+	register Atype *aty;
+	int i, j, k;
+	register int *t, *te;
+	char buf1[32], buf2[32];
+	int type_fixup();
+
+	at = p->arginfo;
+	if (at->nargs < 0)
+		return;
+	if (p->extype != ftype) {
+		Pbadret(ftype, p);
+		return;
+		}
+	t = tfirst;
+	te = tnext;
+	i = te - t;
+	if (at->nargs != i) {
+		j = at->nargs;
+		Pbadmsg("differing numbers of arguments",p);
+		fprintf(stderr, "here %d, previously %d\n",
+			i, j);
+		return;
+		}
+	for(aty = at->atypes; t < te; t++, aty++) {
+		if (*t == aty->type)
+			continue;
+		j = aty->type;
+		k = *t;
+		if (k >= 300 || k == j)
+			continue;
+		if (j >= 300) {
+			if (k >= 200) {
+				if (k == TYUNKNOWN + 200)
+					continue;
+				if (j % 100 != k - 200
+				 && k != TYSUBR + 200
+				 && j != TYUNKNOWN + 300
+				 && !type_fixup(at,aty,k))
+					goto badtypes;
+				}
+			else if (j % 100 % TYSUBR != k % TYSUBR
+					&& !type_fixup(at,aty,k))
+				goto badtypes;
+			}
+		else if (k < 200 || j < 200)
+			goto badtypes;
+		else if (k == TYUNKNOWN+200)
+			continue;
+		else if (j != TYUNKNOWN+200)
+			{
+ badtypes:
+			Pbadmsg("differing calling sequences",p);
+			i = t - tfirst + 1;
+			fprintf(stderr,
+				"arg %d: here %s, prevously %s\n",
+				i, Argtype(k,buf1), Argtype(j,buf2));
+			return;
+			}
+		/* We've subsequently learned the right type,
+		   as in the call on zoo below...
+
+			subroutine foo(x, zap)
+			external zap
+			call goo(zap)
+			x = zap(3)
+			call zoo(zap)
+			end
+		 */
+		aty->type = k;
+		at->changes = 1;
+		}
+	}
+
+ static void
+newarg(ftype, p)
+ int ftype;
+ Extsym *p;
+{
+	Argtypes *at;
+	register Atype *aty;
+	register int *t, *te;
+	int i, k;
+
+	if (p->extstg == STGCOMMON) {
+		Pnotboth(p);
+		return;
+		}
+	p->extstg = STGEXT;
+	p->extype = ftype;
+	p->exproto = 1;
+	t = tfirst;
+	te = tnext;
+	i = te - t;
+	k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
+	at = p->arginfo = (Argtypes *)gmem(k,1);
+	at->nargs = i;
+	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);
+		else
+			newarg(ftype, p);
+		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);
+	}

lang/fortran/comp/proto.make

@@ -0,0 +1,373 @@
+# $Header$
+
+# Makefile for f2c, a Fortran 77 to C converter
+
+#PARAMS		do not remove this line!
+
+UTIL_BIN = \
+	$(UTIL_HOME)/bin
+SRC_DIR = \
+	$(SRC_HOME)/lang/fortran/comp
+INCLUDES = -I$(SRC_DIR) -I.
+CFLAGS = $(COPTIONS) $(INCLUDES)
+LINTFLAGS = $(LINTOPTIONS) $(INCLUDES)
+LDFLAGS = $(LDOPTIONS)
+
+OBJECTS = main.$(SUF) init.$(SUF) gram.$(SUF) lex.$(SUF) proc.$(SUF) \
+	  equiv.$(SUF) data.$(SUF) format.$(SUF) expr.$(SUF) exec.$(SUF) \
+	  intr.$(SUF) io.$(SUF) misc.$(SUF) error.$(SUF) mem.$(SUF) \
+	  names.$(SUF) output.$(SUF) p1output.$(SUF) pread.$(SUF) put.$(SUF) \
+	  putpcc.$(SUF) vax.$(SUF) formatdata.$(SUF) parse_args.$(SUF) \
+	  niceprintf.$(SUF) cds.$(SUF) sysdep.$(SUF) version.$(SUF)
+
+
+GSRC = \
+	$(SRC_DIR)/gram.head \
+	$(SRC_DIR)/gram.dcl \
+	$(SRC_DIR)/gram.expr \
+	$(SRC_DIR)/gram.exec \
+	$(SRC_DIR)/gram.io
+CSRC = \
+	$(SRC_DIR)/main.c \
+	$(SRC_DIR)/init.c \
+	$(SRC_DIR)/lex.c \
+	$(SRC_DIR)/proc.c \
+	$(SRC_DIR)/equiv.c \
+	$(SRC_DIR)/data.c \
+	$(SRC_DIR)/format.c \
+	$(SRC_DIR)/expr.c \
+	$(SRC_DIR)/exec.c \
+	$(SRC_DIR)/intr.c \
+	$(SRC_DIR)/io.c \
+	$(SRC_DIR)/misc.c \
+	$(SRC_DIR)/error.c \
+	$(SRC_DIR)/mem.c \
+	$(SRC_DIR)/names.c \
+	$(SRC_DIR)/output.c \
+	$(SRC_DIR)/p1output.c \
+	$(SRC_DIR)/pread.c \
+	$(SRC_DIR)/put.c \
+	$(SRC_DIR)/putpcc.c \
+	$(SRC_DIR)/vax.c \
+	$(SRC_DIR)/formatdata.c \
+	$(SRC_DIR)/parse_args.c \
+	$(SRC_DIR)/niceprintf.c \
+	$(SRC_DIR)/cds.c \
+	$(SRC_DIR)/sysdep.c \
+	$(SRC_DIR)/version.c
+HSRC = \
+	$(SRC_DIR)/defines.h \
+	$(SRC_DIR)/defs.h \
+	$(SRC_DIR)/f2c.h \
+	$(SRC_DIR)/format.h \
+	$(SRC_DIR)/ftypes.h \
+	$(SRC_DIR)/iob.h \
+	$(SRC_DIR)/machdefs.h \
+	$(SRC_DIR)/names.h \
+	$(SRC_DIR)/niceprintf.h \
+	$(SRC_DIR)/output.h \
+	$(SRC_DIR)/p1defs.h \
+	$(SRC_DIR)/parse.h \
+	$(SRC_DIR)/pccdefs.h \
+	$(SRC_DIR)/sysdep.h \
+	$(SRC_DIR)/usignal.h
+
+SRC = 	$(SRC_DIR)/tokens $(GSRC) $(HSRC) $(CSRC)
+
+CFILES = gram.c $(CSRC)
+
+all:	f2c
+
+install:	all
+	rm -f $(TARGET_HOME)/lib.bin/f2c
+	cp f2c $(TARGET_HOME)/lib.bin/f2c
+	rm -f $(TARGET_HOME)/man/f2c.6
+	cp $(SRC_DIR)/f2c.6 $(TARGET_HOME)/man/f2c.6
+	rm -f $(TARGET_HOME)/include/_tail_cc/f2c.h
+	cp $(SRC_DIR)/f2c.h $(TARGET_HOME)/include/_tail_cc/f2c.h
+
+cmp:	all
+	-cmp f2c $(TARGET_HOME)/lib.bin/f2c
+	-cmp $(SRC_DIR)/f2c.6 $(TARGET_HOME)/man/f2c.6
+	-cmp $(SRC_DIR)/f2c.h $(TARGET_HOME)/include/_tail_cc/f2c.h
+
+lint:	$(CFILES) tokdefs.h
+	$(LINT) $(LINTFLAGS) $(CFILES)
+
+pr:
+	@pr $(SRC_DIR)/proto.make $(SRC)
+
+pr:
+	make pr | opr
+
+depend:	$(CFILES) tokdefs.h
+	sed '/^#DEPENDENCIES/,$$d' Makefile >Makefile.new
+	echo '#DEPENDENCIES' >>Makefile.new
+	for i in $(CFILES) ; do \
+		echo "`basename $$i .c`.$$(SUF):	$$i" >> Makefile.new ; \
+		echo '	$$(CC) -c $$(CFLAGS)' $$i >> Makefile.new ; \
+		$(UTIL_HOME)/lib.bin/cpp -d $(INCLUDES) $$i | sed "s/^/`basename $$i .c`.$$(SUF):	/" >> Makefile.new ; \
+	done
+	mv Makefile Makefile.old
+	mv Makefile.new Makefile
+
+f2c:	$(OBJECTS)
+	$(CC) $(LDFLAGS) $(OBJECTS) $(TARGET_HOME)/modules/lib/libstring.$(LIBSUF) -o f2c
+
+gram.c:	$(GSRC) $(SRC_DIR)/defs.h tokdefs.h
+	( sed <tokdefs.h "s/#define/%token/" ;\
+		cat $(GSRC) ) >gram.in
+	yacc gram.in
+	echo "(expect 4 shift/reduce)"
+	sed 's/^# line.*/\/* & *\//' y.tab.c >gram.c
+	rm -f gram.in y.tab.c
+
+tokdefs.h: $(SRC_DIR)/tokens
+	grep -n . <$(SRC_DIR)/tokens | \
+	   sed "s/\([^:]*\):\(.*\)/#define \2 \1/" >tokdefs.h
+
+clean:
+	rm -f gram.c *.$(SUF) f2c tokdefs.h Out
+
+#DEPENDENCIES
+gram.$(SUF):	gram.c
+	$(CC) -c $(CFLAGS) gram.c
+gram.$(SUF):	$(SRC_DIR)/p1defs.h
+gram.$(SUF):	$(SRC_DIR)/machdefs.h
+gram.$(SUF):	$(SRC_DIR)/defines.h
+gram.$(SUF):	$(SRC_DIR)/ftypes.h
+gram.$(SUF):	$(SRC_DIR)/sysdep.h
+gram.$(SUF):	$(SRC_DIR)/defs.h
+main.$(SUF):	$(SRC_DIR)/main.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/main.c
+main.$(SUF):	$(SRC_DIR)/parse.h
+main.$(SUF):	$(SRC_DIR)/machdefs.h
+main.$(SUF):	$(SRC_DIR)/defines.h
+main.$(SUF):	$(SRC_DIR)/ftypes.h
+main.$(SUF):	$(SRC_DIR)/sysdep.h
+main.$(SUF):	$(SRC_DIR)/defs.h
+init.$(SUF):	$(SRC_DIR)/init.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/init.c
+init.$(SUF):	$(SRC_DIR)/iob.h
+init.$(SUF):	$(SRC_DIR)/niceprintf.h
+init.$(SUF):	$(SRC_DIR)/output.h
+init.$(SUF):	$(SRC_DIR)/machdefs.h
+init.$(SUF):	$(SRC_DIR)/defines.h
+init.$(SUF):	$(SRC_DIR)/ftypes.h
+init.$(SUF):	$(SRC_DIR)/sysdep.h
+init.$(SUF):	$(SRC_DIR)/defs.h
+lex.$(SUF):	$(SRC_DIR)/lex.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/lex.c
+lex.$(SUF):	$(SRC_DIR)/p1defs.h
+lex.$(SUF):	./tokdefs.h
+lex.$(SUF):	$(SRC_DIR)/machdefs.h
+lex.$(SUF):	$(SRC_DIR)/defines.h
+lex.$(SUF):	$(SRC_DIR)/ftypes.h
+lex.$(SUF):	$(SRC_DIR)/sysdep.h
+lex.$(SUF):	$(SRC_DIR)/defs.h
+proc.$(SUF):	$(SRC_DIR)/proc.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/proc.c
+proc.$(SUF):	$(SRC_DIR)/p1defs.h
+proc.$(SUF):	$(SRC_DIR)/niceprintf.h
+proc.$(SUF):	$(SRC_DIR)/output.h
+proc.$(SUF):	$(SRC_DIR)/names.h
+proc.$(SUF):	$(SRC_DIR)/machdefs.h
+proc.$(SUF):	$(SRC_DIR)/defines.h
+proc.$(SUF):	$(SRC_DIR)/ftypes.h
+proc.$(SUF):	$(SRC_DIR)/sysdep.h
+proc.$(SUF):	$(SRC_DIR)/defs.h
+equiv.$(SUF):	$(SRC_DIR)/equiv.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/equiv.c
+equiv.$(SUF):	$(SRC_DIR)/machdefs.h
+equiv.$(SUF):	$(SRC_DIR)/defines.h
+equiv.$(SUF):	$(SRC_DIR)/ftypes.h
+equiv.$(SUF):	$(SRC_DIR)/sysdep.h
+equiv.$(SUF):	$(SRC_DIR)/defs.h
+data.$(SUF):	$(SRC_DIR)/data.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/data.c
+data.$(SUF):	$(SRC_DIR)/machdefs.h
+data.$(SUF):	$(SRC_DIR)/defines.h
+data.$(SUF):	$(SRC_DIR)/ftypes.h
+data.$(SUF):	$(SRC_DIR)/sysdep.h
+data.$(SUF):	$(SRC_DIR)/defs.h
+format.$(SUF):	$(SRC_DIR)/format.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/format.c
+format.$(SUF):	$(SRC_DIR)/iob.h
+format.$(SUF):	$(SRC_DIR)/names.h
+format.$(SUF):	$(SRC_DIR)/niceprintf.h
+format.$(SUF):	$(SRC_DIR)/output.h
+format.$(SUF):	$(SRC_DIR)/format.h
+format.$(SUF):	$(SRC_DIR)/p1defs.h
+format.$(SUF):	$(SRC_DIR)/machdefs.h
+format.$(SUF):	$(SRC_DIR)/defines.h
+format.$(SUF):	$(SRC_DIR)/ftypes.h
+format.$(SUF):	$(SRC_DIR)/sysdep.h
+format.$(SUF):	$(SRC_DIR)/defs.h
+expr.$(SUF):	$(SRC_DIR)/expr.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/expr.c
+expr.$(SUF):	$(SRC_DIR)/names.h
+expr.$(SUF):	$(SRC_DIR)/niceprintf.h
+expr.$(SUF):	$(SRC_DIR)/output.h
+expr.$(SUF):	$(SRC_DIR)/machdefs.h
+expr.$(SUF):	$(SRC_DIR)/defines.h
+expr.$(SUF):	$(SRC_DIR)/ftypes.h
+expr.$(SUF):	$(SRC_DIR)/sysdep.h
+expr.$(SUF):	$(SRC_DIR)/defs.h
+exec.$(SUF):	$(SRC_DIR)/exec.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/exec.c
+exec.$(SUF):	$(SRC_DIR)/names.h
+exec.$(SUF):	$(SRC_DIR)/p1defs.h
+exec.$(SUF):	$(SRC_DIR)/machdefs.h
+exec.$(SUF):	$(SRC_DIR)/defines.h
+exec.$(SUF):	$(SRC_DIR)/ftypes.h
+exec.$(SUF):	$(SRC_DIR)/sysdep.h
+exec.$(SUF):	$(SRC_DIR)/defs.h
+intr.$(SUF):	$(SRC_DIR)/intr.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/intr.c
+intr.$(SUF):	$(SRC_DIR)/names.h
+intr.$(SUF):	$(SRC_DIR)/machdefs.h
+intr.$(SUF):	$(SRC_DIR)/defines.h
+intr.$(SUF):	$(SRC_DIR)/ftypes.h
+intr.$(SUF):	$(SRC_DIR)/sysdep.h
+intr.$(SUF):	$(SRC_DIR)/defs.h
+io.$(SUF):	$(SRC_DIR)/io.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/io.c
+io.$(SUF):	$(SRC_DIR)/iob.h
+io.$(SUF):	$(SRC_DIR)/names.h
+io.$(SUF):	$(SRC_DIR)/machdefs.h
+io.$(SUF):	$(SRC_DIR)/defines.h
+io.$(SUF):	$(SRC_DIR)/ftypes.h
+io.$(SUF):	$(SRC_DIR)/sysdep.h
+io.$(SUF):	$(SRC_DIR)/defs.h
+misc.$(SUF):	$(SRC_DIR)/misc.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/misc.c
+misc.$(SUF):	$(SRC_DIR)/machdefs.h
+misc.$(SUF):	$(SRC_DIR)/defines.h
+misc.$(SUF):	$(SRC_DIR)/ftypes.h
+misc.$(SUF):	$(SRC_DIR)/sysdep.h
+misc.$(SUF):	$(SRC_DIR)/defs.h
+error.$(SUF):	$(SRC_DIR)/error.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/error.c
+error.$(SUF):	$(SRC_DIR)/machdefs.h
+error.$(SUF):	$(SRC_DIR)/defines.h
+error.$(SUF):	$(SRC_DIR)/ftypes.h
+error.$(SUF):	$(SRC_DIR)/sysdep.h
+error.$(SUF):	$(SRC_DIR)/defs.h
+mem.$(SUF):	$(SRC_DIR)/mem.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/mem.c
+mem.$(SUF):	$(SRC_DIR)/iob.h
+mem.$(SUF):	$(SRC_DIR)/machdefs.h
+mem.$(SUF):	$(SRC_DIR)/defines.h
+mem.$(SUF):	$(SRC_DIR)/ftypes.h
+mem.$(SUF):	$(SRC_DIR)/sysdep.h
+mem.$(SUF):	$(SRC_DIR)/defs.h
+names.$(SUF):	$(SRC_DIR)/names.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/names.c
+names.$(SUF):	$(SRC_DIR)/iob.h
+names.$(SUF):	$(SRC_DIR)/names.h
+names.$(SUF):	$(SRC_DIR)/niceprintf.h
+names.$(SUF):	$(SRC_DIR)/output.h
+names.$(SUF):	$(SRC_DIR)/machdefs.h
+names.$(SUF):	$(SRC_DIR)/defines.h
+names.$(SUF):	$(SRC_DIR)/ftypes.h
+names.$(SUF):	$(SRC_DIR)/sysdep.h
+names.$(SUF):	$(SRC_DIR)/defs.h
+output.$(SUF):	$(SRC_DIR)/output.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/output.c
+output.$(SUF):	$(SRC_DIR)/niceprintf.h
+output.$(SUF):	$(SRC_DIR)/output.h
+output.$(SUF):	$(SRC_DIR)/names.h
+output.$(SUF):	$(SRC_DIR)/machdefs.h
+output.$(SUF):	$(SRC_DIR)/defines.h
+output.$(SUF):	$(SRC_DIR)/ftypes.h
+output.$(SUF):	$(SRC_DIR)/sysdep.h
+output.$(SUF):	$(SRC_DIR)/defs.h
+p1output.$(SUF):	$(SRC_DIR)/p1output.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/p1output.c
+p1output.$(SUF):	$(SRC_DIR)/names.h
+p1output.$(SUF):	$(SRC_DIR)/niceprintf.h
+p1output.$(SUF):	$(SRC_DIR)/output.h
+p1output.$(SUF):	$(SRC_DIR)/p1defs.h
+p1output.$(SUF):	$(SRC_DIR)/machdefs.h
+p1output.$(SUF):	$(SRC_DIR)/defines.h
+p1output.$(SUF):	$(SRC_DIR)/ftypes.h
+p1output.$(SUF):	$(SRC_DIR)/sysdep.h
+p1output.$(SUF):	$(SRC_DIR)/defs.h
+pread.$(SUF):	$(SRC_DIR)/pread.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/pread.c
+pread.$(SUF):	$(SRC_DIR)/machdefs.h
+pread.$(SUF):	$(SRC_DIR)/defines.h
+pread.$(SUF):	$(SRC_DIR)/ftypes.h
+pread.$(SUF):	$(SRC_DIR)/sysdep.h
+pread.$(SUF):	$(SRC_DIR)/defs.h
+put.$(SUF):	$(SRC_DIR)/put.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/put.c
+put.$(SUF):	$(SRC_DIR)/p1defs.h
+put.$(SUF):	$(SRC_DIR)/pccdefs.h
+put.$(SUF):	$(SRC_DIR)/names.h
+put.$(SUF):	$(SRC_DIR)/machdefs.h
+put.$(SUF):	$(SRC_DIR)/defines.h
+put.$(SUF):	$(SRC_DIR)/ftypes.h
+put.$(SUF):	$(SRC_DIR)/sysdep.h
+put.$(SUF):	$(SRC_DIR)/defs.h
+putpcc.$(SUF):	$(SRC_DIR)/putpcc.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/putpcc.c
+putpcc.$(SUF):	$(SRC_DIR)/p1defs.h
+putpcc.$(SUF):	$(SRC_DIR)/names.h
+putpcc.$(SUF):	$(SRC_DIR)/niceprintf.h
+putpcc.$(SUF):	$(SRC_DIR)/output.h
+putpcc.$(SUF):	$(SRC_DIR)/pccdefs.h
+putpcc.$(SUF):	$(SRC_DIR)/machdefs.h
+putpcc.$(SUF):	$(SRC_DIR)/defines.h
+putpcc.$(SUF):	$(SRC_DIR)/ftypes.h
+putpcc.$(SUF):	$(SRC_DIR)/sysdep.h
+putpcc.$(SUF):	$(SRC_DIR)/defs.h
+vax.$(SUF):	$(SRC_DIR)/vax.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/vax.c
+vax.$(SUF):	$(SRC_DIR)/niceprintf.h
+vax.$(SUF):	$(SRC_DIR)/output.h
+vax.$(SUF):	$(SRC_DIR)/pccdefs.h
+vax.$(SUF):	$(SRC_DIR)/machdefs.h
+vax.$(SUF):	$(SRC_DIR)/defines.h
+vax.$(SUF):	$(SRC_DIR)/ftypes.h
+vax.$(SUF):	$(SRC_DIR)/sysdep.h
+vax.$(SUF):	$(SRC_DIR)/defs.h
+formatdata.$(SUF):	$(SRC_DIR)/formatdata.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/formatdata.c
+formatdata.$(SUF):	$(SRC_DIR)/format.h
+formatdata.$(SUF):	$(SRC_DIR)/names.h
+formatdata.$(SUF):	$(SRC_DIR)/niceprintf.h
+formatdata.$(SUF):	$(SRC_DIR)/output.h
+formatdata.$(SUF):	$(SRC_DIR)/machdefs.h
+formatdata.$(SUF):	$(SRC_DIR)/defines.h
+formatdata.$(SUF):	$(SRC_DIR)/ftypes.h
+formatdata.$(SUF):	$(SRC_DIR)/sysdep.h
+formatdata.$(SUF):	$(SRC_DIR)/defs.h
+parse_args.$(SUF):	$(SRC_DIR)/parse_args.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/parse_args.c
+parse_args.$(SUF):	$(SRC_DIR)/parse.h
+niceprintf.$(SUF):	$(SRC_DIR)/niceprintf.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/niceprintf.c
+niceprintf.$(SUF):	$(SRC_DIR)/niceprintf.h
+niceprintf.$(SUF):	$(SRC_DIR)/output.h
+niceprintf.$(SUF):	$(SRC_DIR)/names.h
+niceprintf.$(SUF):	$(SRC_DIR)/machdefs.h
+niceprintf.$(SUF):	$(SRC_DIR)/defines.h
+niceprintf.$(SUF):	$(SRC_DIR)/ftypes.h
+niceprintf.$(SUF):	$(SRC_DIR)/sysdep.h
+niceprintf.$(SUF):	$(SRC_DIR)/defs.h
+cds.$(SUF):	$(SRC_DIR)/cds.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/cds.c
+cds.$(SUF):	$(SRC_DIR)/sysdep.h
+sysdep.$(SUF):	$(SRC_DIR)/sysdep.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/sysdep.c
+sysdep.$(SUF):	$(SRC_DIR)/usignal.h
+sysdep.$(SUF):	$(SRC_DIR)/machdefs.h
+sysdep.$(SUF):	$(SRC_DIR)/defines.h
+sysdep.$(SUF):	$(SRC_DIR)/ftypes.h
+sysdep.$(SUF):	$(SRC_DIR)/sysdep.h
+sysdep.$(SUF):	$(SRC_DIR)/defs.h
+version.$(SUF):	$(SRC_DIR)/version.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/version.c
+memset.$(SUF):	$(SRC_DIR)/memset.c
+	$(CC) -c $(CFLAGS) $(SRC_DIR)/memset.c

lang/fortran/comp/put.c

@@ -0,0 +1,399 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/*
+ * INTERMEDIATE CODE GENERATION PROCEDURES COMMON TO BOTH
+ * JOHNSON (PORTABLE) AND RITCHIE FAMILIES OF SECOND PASSES
+*/
+
+#include "defs.h"
+#include "names.h"		/* For LOCAL_CONST_NAME */
+#include "pccdefs.h"
+#include "p1defs.h"
+
+/* Definitions for   putconst()   */
+
+#define LIT_CHAR 1
+#define LIT_FLOAT 2
+#define LIT_INT 3
+
+
+/*
+char *ops [ ] =
+	{
+	"??", "+", "-", "*", "/", "**", "-",
+	"OR", "AND", "EQV", "NEQV", "NOT",
+	"CONCAT",
+	"<", "==", ">", "<=", "!=", ">=",
+	" of ", " ofC ", " = ", " += ", " *= ", " CONV ", " << ", " % ",
+	" , ", " ? ", " : "
+	" abs ", " min ", " max ", " addr ", " indirect ",
+	" bitor ", " bitand ", " bitxor ", " bitnot ", " >> ",
+	};
+*/
+
+/* Each of these values is defined in   pccdefs   */
+
+int ops2 [ ] =
+{
+	P2BAD, P2PLUS, P2MINUS, P2STAR, P2SLASH, P2BAD, P2NEG,
+	P2OROR, P2ANDAND, P2EQ, P2NE, P2NOT,
+	P2BAD,
+	P2LT, P2EQ, P2GT, P2LE, P2NE, P2GE,
+	P2CALL, P2CALL, P2ASSIGN, P2PLUSEQ, P2STAREQ, P2CONV, P2LSHIFT, P2MOD,
+	P2COMOP, P2QUEST, P2COLON,
+	1, P2BAD, P2BAD, P2BAD, P2BAD,
+	P2BITOR, P2BITAND, P2BITXOR, P2BITNOT, P2RSHIFT,
+	P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD, P2BAD,
+	P2BAD, P2BAD, P2BAD, P2BAD,
+	1,1,1,1,1, /* OPNEG1, OPDMIN, OPDMAX, OPASSIGNI, OPIDENTITY */
+	1,1,1,1	/* OPCHARCAST, OPDABS, OPMIN2, OPMAX2 */
+};
+
+
+int types2 [ ] =
+{
+	P2BAD, P2INT|P2PTR, P2SHORT, P2LONG, P2REAL, P2DREAL,
+	P2REAL, P2DREAL, P2LONG, P2CHAR, P2INT, P2BAD
+};
+
+
+setlog()
+{
+	types2[TYLOGICAL] = types2[tylogical];
+	typesize[TYLOGICAL] = typesize[tylogical];
+	typealign[TYLOGICAL] = typealign[tylogical];
+}
+
+
+void putex1(p)
+expptr p;
+{
+/* Write the expression to the p1 file */
+
+	p = (expptr) putx (fixtype (p));
+	p1_expr (p);
+}
+
+
+
+
+
+expptr putassign(lp, rp)
+expptr lp, rp;
+{
+	return putx(fixexpr((Exprp)mkexpr(OPASSIGN, lp, rp)));
+}
+
+
+
+
+void puteq(lp, rp)
+expptr lp, rp;
+{
+	putexpr(mkexpr(OPASSIGN, lp, rp) );
+}
+
+
+
+
+/* put code for  a *= b */
+
+expptr putsteq(a, b)
+Addrp a, b;
+{
+	return putx( fixexpr((Exprp)
+		mkexpr(OPSTAREQ, cpexpr((expptr)a), cpexpr((expptr)b))));
+}
+
+
+
+
+Addrp mkfield(res, f, ty)
+register Addrp res;
+char *f;
+int ty;
+{
+    res -> vtype = ty;
+    res -> Field = f;
+    return res;
+} /* mkfield */
+
+
+Addrp realpart(p)
+register Addrp p;
+{
+	register Addrp q;
+	expptr mkrealcon();
+
+	if (p -> uname_tag == UNAM_CONST && ISCOMPLEX (p->vtype)) {
+		return (Addrp)mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
+			p->user.kludge.vstg1 ? p->user.Const.cds[0]
+				: cds(dtos(p->user.Const.cd[0]),CNULL));
+	} /* if p -> uname_tag */
+
+	q = (Addrp) cpexpr((expptr) p);
+	if( ISCOMPLEX(p->vtype) )
+		q = mkfield (q, "r", p -> vtype + TYREAL - TYCOMPLEX);
+
+	return(q);
+}
+
+
+
+
+expptr imagpart(p)
+register Addrp p;
+{
+	register Addrp q;
+	expptr mkrealcon();
+
+	if( ISCOMPLEX(p->vtype) )
+	{
+		if (p -> uname_tag == UNAM_CONST)
+			return mkrealcon (p -> vtype + TYREAL - TYCOMPLEX,
+				p->user.kludge.vstg1 ? p->user.Const.cds[1]
+				: cds(dtos(p->user.Const.cd[1]),CNULL));
+		q = (Addrp) cpexpr((expptr) p);
+		q = mkfield (q, "i", p -> vtype + TYREAL - TYCOMPLEX);
+		return( (expptr) q );
+	}
+	else
+
+/* Cast an integer type onto a Double Real type */
+
+		return( mkrealcon( ISINT(p->vtype) ? TYDREAL : p->vtype , "0"));
+}
+
+
+
+
+
+/* ncat -- computes the number of adjacent concatenation operations */
+
+ncat(p)
+register expptr p;
+{
+	if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
+		return( ncat(p->exprblock.leftp) + ncat(p->exprblock.rightp) );
+	else	return(1);
+}
+
+
+
+
+/* lencat -- returns the length of the concatenated string.  Each
+   substring must have a static (i.e. compile-time) fixed length */
+
+ftnint lencat(p)
+register expptr p;
+{
+	if(p->tag==TEXPR && p->exprblock.opcode==OPCONCAT)
+		return( lencat(p->exprblock.leftp) + lencat(p->exprblock.rightp) );
+	else if( p->headblock.vleng!=NULL && ISICON(p->headblock.vleng) )
+		return(p->headblock.vleng->constblock.Const.ci);
+	else if(p->tag==TADDR && p->addrblock.varleng!=0)
+		return(p->addrblock.varleng);
+	else
+	{
+		err("impossible element in concatenation");
+		return(0);
+	}
+}
+
+/* putconst -- Creates a new Addrp value which maps onto the input
+   constant value.  The Addrp doesn't retain the value of the constant,
+   instead that value is copied into a table of constants (called
+   litpool,   for pool of literal values).  The only way to retrieve the
+   actual value of the constant is to look at the   memno   field of the
+   Addrp result.  You know that the associated literal is the one referred
+   to by   q   when   (q -> memno == litp -> litnum).
+*/
+
+Addrp putconst(p)
+register Constp p;
+{
+	register Addrp q;
+	struct Literal *litp, *lastlit;
+	int k, len, type;
+	int litflavor;
+	double cd[2];
+	ftnint nblanks;
+	char *strp;
+	char cdsbuf0[64], cdsbuf1[64], *ds[2];
+
+	if (p->tag != TCONST)
+		badtag("putconst", p->tag);
+
+	q = ALLOC(Addrblock);
+	q->tag = TADDR;
+	type = p->vtype;
+	q->vtype = ( type==TYADDR ? tyint : type );
+	q->vleng = (expptr) cpexpr(p->vleng);
+	q->vstg = STGCONST;
+
+/* Create the new label for the constant.  This is wasteful of labels
+   because when the constant value already exists in the literal pool,
+   this label gets thrown away and is never reclaimed.  It might be
+   cleaner to move this down past the first   switch()   statement below */
+
+	q->memno = newlabel();
+	q->memoffset = ICON(0);
+	q -> uname_tag = UNAM_CONST;
+
+/* Copy the constant info into the Addrblock; do this by copying the
+   largest storage elts */
+
+	q -> user.Const = p -> Const;
+	q->user.kludge.vstg1 = p->vstg;	/* distinguish string from binary fp */
+
+	/* check for value in literal pool, and update pool if necessary */
+
+	k = 1;
+	switch(type)
+	{
+	case TYCHAR:
+		if (halign) {
+			strp = p->Const.ccp;
+			nblanks = p->Const.ccp1.blanks;
+			len = p->vleng->constblock.Const.ci;
+			litflavor = LIT_CHAR;
+			goto loop;
+			}
+		else
+			q->memno = BAD_MEMNO;
+		break;
+	case TYCOMPLEX:
+	case TYDCOMPLEX:
+		k = 2;
+		if (p->vstg)
+			cd[1] = atof(ds[1] = p->Const.cds[1]);
+		else
+			ds[1] = cds(dtos(cd[1] = p->Const.cd[1]), cdsbuf1);
+	case TYREAL:
+	case TYDREAL:
+		litflavor = LIT_FLOAT;
+		if (p->vstg)
+			cd[0] = atof(ds[0] = p->Const.cds[0]);
+		else
+			ds[0] = cds(dtos(cd[0] = p->Const.cd[0]), cdsbuf0);
+		goto loop;
+
+	case TYLOGICAL:
+		type = tylogical;
+		goto lit_int_flavor;
+	case TYLONG:
+		type = tyint;
+	case TYSHORT:
+ lit_int_flavor:
+		litflavor = LIT_INT;
+
+/* Scan the literal pool for this constant value.  If this same constant
+   has been assigned before, use the same label.  Note that this routine
+   does NOT consider two differently-typed constants with the same bit
+   pattern to be the same constant */
+
+ loop:
+		lastlit = litpool + nliterals;
+		for(litp = litpool ; litp<lastlit ; ++litp)
+
+/* Remove this type checking to ensure that all bit patterns are reused */
+
+			if(type == litp->littype) switch(litflavor)
+			{
+			case LIT_CHAR:
+				if (len == (int)litp->litval.litival2[0]
+				&& nblanks == litp->litval.litival2[1]
+				&& !memcmp(strp, litp->cds[0], len)) {
+					q->memno = litp->litnum;
+					frexpr((expptr)p);
+					return(q);
+					}
+				break;
+			case LIT_FLOAT:
+				if(cd[0] == litp->litval.litdval[0]
+				&& !strcmp(ds[0], litp->cds[0])
+				&& (k == 1 ||
+				    cd[1] == litp->litval.litdval[1]
+				    && !strcmp(ds[1], litp->cds[1]))) {
+ret:
+					q->memno = litp->litnum;
+					frexpr((expptr)p);
+					return(q);
+					}
+				break;
+
+			case LIT_INT:
+				if(p->Const.ci == litp->litval.litival)
+					goto ret;
+				break;
+			}
+
+/* If there's room in the literal pool, add this new value to the pool */
+
+		if(nliterals < maxliterals)
+		{
+			++nliterals;
+
+			/* litp   now points to the next free elt */
+
+			litp->littype = type;
+			litp->litnum = q->memno;
+			switch(litflavor)
+			{
+			case LIT_CHAR:
+				litp->litval.litival2[0] = len;
+				litp->litval.litival2[1] = nblanks;
+				q->user.Const.ccp = litp->cds[0] =
+					memcpy(gmem(len,0), strp, len);
+				break;
+
+			case LIT_FLOAT:
+				litp->litval.litdval[0] = cd[0];
+				litp->cds[0] = copys(ds[0]);
+				if (k == 2) {
+					litp->litval.litdval[1] = cd[1];
+					litp->cds[1] = copys(ds[1]);
+					}
+				break;
+
+			case LIT_INT:
+				litp->litval.litival = p->Const.ci;
+				break;
+			} /* switch (litflavor) */
+		}
+		else
+			many("literal constants", 'L', maxliterals);
+
+		break;
+	case TYADDR:
+	    break;
+	default:
+		badtype ("putconst", p -> vtype);
+		break;
+	} /* switch */
+
+	if (type != TYCHAR || halign)
+	    frexpr((expptr)p);
+	return( q );
+}

lang/fortran/comp/string.h

@@ -0,0 +1,16 @@
+#ifndef NULL
+#define	NULL		0
+#endif
+
+#define strchr	strindex
+#define strrchr strrindex
+
+extern char *	strcat();
+extern char *	strchr();
+extern int	strcmp();
+extern char *	strcpy();
+extern int	strlen();
+extern char *	strncat();
+extern int	strncmp();
+extern char *	strncpy();
+extern char *	strrchr();

lang/fortran/comp/sysdep.c

@@ -0,0 +1,441 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+#include "defs.h"
+#include "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 link_msg[]		= "-lF77 -lI77 -lm -lc";
+
+#ifndef TMPDIR
+#ifdef MSDOS
+#define TMPDIR ""
+#else
+#define TMPDIR "/tmp"
+#endif
+#endif
+
+char *tmpdir = TMPDIR;
+
+ void
+Un_link_all(cdelete)
+{
+	if (!debugflag) {
+		unlink(c_functions);
+		unlink(initfname);
+		unlink(p1_file);
+		unlink(sortfname);
+		unlink(blkdfname);
+		if (cdelete && coutput)
+			unlink(coutput);
+		}
+	}
+
+ void
+set_tmp_names()
+{
+	int k;
+	if (debugflag == 1)
+		return;
+	k = strlen(tmpdir) + 16;
+	c_functions = (char *)ckalloc(7*k);
+	initfname = c_functions + k;
+	initbname = initfname + k;
+	blkdfname = initbname + k;
+	p1_file = blkdfname + k;
+	p1_bakfile = p1_file + k;
+	sortfname = p1_bakfile + k;
+	{
+#ifdef MSDOS
+	char buf[64], *s, *t;
+	if (!*tmpdir || *tmpdir == '.' && !tmpdir[1])
+		t = "";
+	else {
+		/* substitute \ for / to avoid confusion with a
+		 * switch indicator in the system("sort ...")
+		 * call in formatdata.c
+		 */
+		for(s = tmpdir, t = buf; *s; s++, t++)
+			if ((*t = *s) == '/')
+				*t = '\\';
+		if (t[-1] != '\\')
+			*t++ = '\\';
+		*t = 0;
+		t = buf;
+		}
+	sprintf(c_functions, "%sf2c_func", t);
+	sprintf(initfname, "%sf2c_rd", t);
+	sprintf(blkdfname, "%sf2c_blkd", t);
+	sprintf(p1_file, "%sf2c_p1f", t);
+	sprintf(p1_bakfile, "%sf2c_p1fb", t);
+	sprintf(sortfname, "%sf2c_sort", t);
+#else
+	int pid = getpid();
+	sprintf(c_functions, "%s/f2c%d_func", tmpdir, pid);
+	sprintf(initfname, "%s/f2c%d_rd", tmpdir, pid);
+	sprintf(blkdfname, "%s/f2c%d_blkd", tmpdir, pid);
+	sprintf(p1_file, "%s/f2c%d_p1f", tmpdir, pid);
+	sprintf(p1_bakfile, "%s/f2c%d_p1fb", tmpdir, pid);
+	sprintf(sortfname, "%s/f2c%d_sort", tmpdir, pid);
+#endif
+	sprintf(initbname, "%s.b", initfname);
+	}
+	if (debugflag)
+		fprintf(diagfile, "%s %s %s %s %s %s\n", c_functions,
+			initfname, blkdfname, p1_file, p1_bakfile, sortfname);
+	}
+
+ char *
+c_name(s,ft)char *s;
+{
+	char *b, *s0;
+	int c;
+
+	b = s0 = s;
+	while(c = *s++)
+		if (c == '/')
+			b = s;
+	if (--s < s0 + 3 || s[-2] != '.'
+			 || ((c = *--s) != 'f' && c != 'F')) {
+		infname = s0;
+		Fatal("file name must end in .f or .F");
+		}
+	*s = ft;
+	b = copys(b);
+	*s = c;
+	return b;
+	}
+
+ static void
+killed()
+{
+	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) int sig;
+{
+	if (signal(sig, SIG_IGN) != SIG_IGN)
+		signal(sig, killed);
+	}
+
+ static void
+flovflo()
+{
+	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()
+{
+	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

lang/fortran/comp/sysdep.h

@@ -0,0 +1,83 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories, Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* 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
+
+#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) */

lang/fortran/comp/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

lang/fortran/comp/usignal.h

@@ -0,0 +1,7 @@
+#include <signal.h>
+#ifndef SIGHUP
+#define	SIGHUP	1	/* hangup */
+#endif
+#ifndef SIGQUIT
+#define	SIGQUIT	3	/* quit */
+#endif

lang/fortran/comp/vax.c

@@ -0,0 +1,325 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "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 = mkexpr (OPWHATSIN, e, ENULL);
+	        break;
+	    case TEXPR:
+	        e -> exprblock.leftp = make_int_expr (e -> exprblock.leftp);
+	        e -> exprblock.rightp = make_int_expr (e -> exprblock.rightp);
+	        break;
+	    default:
+	        break;
+	} /* switch */
+
+    return e;
+} /* make_int_expr */
+
+
+
+/* prune_left_conv -- used in prolog() to strip type cast away from
+   left-hand side of parameter adjustments.  This is necessary to avoid
+   error messages from cktype() */
+
+expptr prune_left_conv (e)
+expptr e;
+{
+    struct Exprblock *leftp;
+
+    if (e && e -> tag == TEXPR && e -> exprblock.leftp &&
+	    e -> exprblock.leftp -> tag == TEXPR) {
+	leftp = &(e -> exprblock.leftp -> exprblock);
+	if (leftp -> opcode == OPCONV) {
+	    e -> exprblock.leftp = leftp -> leftp;
+	    free ((charptr) leftp);
+	}
+    }
+
+    return e;
+} /* prune_left_conv */
+
+
+ static int wrote_comment;
+ static FILE *comment_file;
+
+ static void
+write_comment()
+{
+	if (!wrote_comment) {
+		wrote_comment = 1;
+		nice_printf (comment_file, "/* Parameter adjustments */\n");
+		}
+	}
+
+ static int *
+count_args()
+{
+	register int *ac;
+	register chainp cp;
+	register struct Entrypoint *ep;
+	register Namep q;
+
+	ac = (int *)ckalloc(nallargs*sizeof(int));
+
+	for(ep = entries; ep; ep = ep->entnextp)
+		for(cp = ep->arglist; cp; cp = cp->nextp)
+			if (q = (Namep)cp->datap)
+				ac[q->argno]++;
+	return ac;
+	}
+
+prolog(outfile, p)
+ FILE *outfile;
+ register chainp p;
+{
+	int addif, addif0, i, nd, size;
+	int *ac;
+	register Namep q;
+	register struct Dimblock *dp;
+
+	if(procclass == CLBLOCK)
+		return;
+	wrote_comment = 0;
+	comment_file = outfile;
+	ac = 0;
+
+/* Compute the base addresses and offsets for the array parameters, and
+   assign these values to local variables */
+
+	addif = addif0 = nentry > 1;
+	for(; p ; p = p->nextp)
+	{
+	    q = (Namep) p->datap;
+	    if(dp = q->vdim)	/* if this param is an array ... */
+	    {
+		expptr Q, expr;
+
+		/* See whether to protect the following with an if. */
+		/* This only happens when there are multiple entries. */
+
+		nd = dp->ndim - 1;
+		if (addif0) {
+			if (!ac)
+				ac = count_args();
+			if (ac[q->argno] == nentry)
+				addif = 0;
+			else if (dp->basexpr
+				    || dp->baseoffset->constblock.Const.ci)
+				addif = 1;
+			else for(addif = i = 0; i <= nd; i++)
+				if (dp->dims[i].dimexpr
+				&& (i < nd || !q->vlastdim)) {
+					addif = 1;
+					break;
+					}
+			if (addif) {
+				write_comment();
+				nice_printf(outfile, "if (%s) {\n", /*}*/
+						q->cvarname);
+				next_tab(outfile);
+				}
+			}
+		for(i = 0 ; i <= nd; ++i)
+
+/* Store the variable length of each dimension (which is fixed upon
+   runtime procedure entry) into a local variable */
+
+		    if ((Q = dp->dims[i].dimexpr)
+			&& (i < nd || !q->vlastdim)) {
+			expr = (expptr)cpexpr(Q);
+			write_comment();
+			out_and_free_statement (outfile, mkexpr (OPASSIGN,
+				fixtype(cpexpr(dp->dims[i].dimsize)), expr));
+		    } /* if dp -> dims[i].dimexpr */
+
+/* size   will equal the size of a single element, or -1 if the type is
+   variable length character type */
+
+		size = typesize[ q->vtype ];
+		if(q->vtype == TYCHAR)
+		    if( ISICON(q->vleng) )
+			size *= q->vleng->constblock.Const.ci;
+		    else
+			size = -1;
+
+		/* Fudge the argument pointers for arrays so subscripts
+		 * are 0-based. Not done if array bounds are being checked.
+		 */
+		if(dp->basexpr) {
+
+/* Compute the base offset for this procedure */
+
+		    write_comment();
+		    out_and_free_statement (outfile, mkexpr (OPASSIGN,
+			    cpexpr(fixtype(dp->baseoffset)),
+			    cpexpr(fixtype(dp->basexpr))));
+		} /* if dp -> basexpr */
+
+		if(! checksubs) {
+		    if(dp->basexpr) {
+			expptr tp;
+
+/* If the base of this array has a variable adjustment ... */
+
+			tp = (expptr) cpexpr (dp -> baseoffset);
+			if(size < 0 || q -> vtype == TYCHAR)
+			    tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng));
+
+			write_comment();
+			tp = mkexpr (OPMINUSEQ,
+				mkconv (TYADDR, (expptr)p->datap),
+				mkconv(TYINT, fixtype
+				(fixtype (tp))));
+/* Avoid type clash by removing the type conversion */
+			tp = prune_left_conv (tp);
+			out_and_free_statement (outfile, tp);
+		    } else if(dp->baseoffset->constblock.Const.ci != 0) {
+
+/* if the base of this array has a nonzero constant adjustment ... */
+
+			expptr tp;
+
+			write_comment();
+			if(size > 0 && q -> vtype != TYCHAR) {
+			    tp = prune_left_conv (mkexpr (OPMINUSEQ,
+				    mkconv (TYADDR, (expptr)p->datap),
+				    mkconv (TYINT, fixtype
+				    (cpexpr (dp->baseoffset)))));
+			    out_and_free_statement (outfile, tp);
+			} else {
+			    tp = prune_left_conv (mkexpr (OPMINUSEQ,
+				    mkconv (TYADDR, (expptr)p->datap),
+				    mkconv (TYINT, fixtype
+				    (mkexpr (OPSTAR, cpexpr (dp -> baseoffset),
+				    cpexpr (q -> vleng))))));
+			    out_and_free_statement (outfile, tp);
+			} /* else */
+		    } /* if dp -> baseoffset -> const */
+		} /* if !checksubs */
+
+		if (addif) {
+			nice_printf(outfile, /*{*/ "}\n");
+			prev_tab(outfile);
+			}
+	    }
+	}
+	if (wrote_comment)
+	    nice_printf (outfile, "\n/* Function Body */\n");
+	if (ac)
+		free((char *)ac);
+} /* prolog */

lang/fortran/comp/version.c

@@ -0,0 +1,2 @@
+char F2C_version[] = "28 August 1991  0:07:02";
+char xxxvers[] = "\n@(#) FORTRAN 77 to C Translator, VERSION 28 August 1991  0:07:02\n";

lang/fortran/comp/xsum.c

@@ -0,0 +1,174 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "stdio.h"
+
+ char *progname;
+
+ void
+usage(rc)
+{
+	fprintf(stderr, "usage: %s [file [file...]]\n", progname);
+	exit(rc);
+	}
+
+main(argc, argv)
+ char **argv;
+{
+	int x;
+	char *s;
+	static int rc;
+
+	progname = *argv;
+	s = *++argv;
+	if (s && *s == '-') {
+		switch(s[1]) {
+			case '?':
+				usage(0);
+			case '-':
+				break;
+			default:
+				fprintf(stderr, "invalid option %s\n", s);
+				usage(1);
+			}
+		s = *++argv;
+		}
+	if (s) do {
+		x = open(s,0);
+		if (x < 0) {
+			fprintf(stderr, "%s: can't open %s\n", progname, s);
+			rc |= 1;
+			}
+		else
+			process(s, x);
+		}
+		while(s = *++argv);
+	else {
+		process("/dev/stdin", fileno(stdin));
+		}
+	exit(rc);
+	}
+
+typedef unsigned char uchar;
+
+ long
+sum32(sum, x, n)
+ register long sum;
+ register uchar *x;
+ int n;
+{
+	register uchar *xe;
+	static long crc_table[256] = {
+		0,		151466134,	302932268,	453595578,
+		-9583591,	-160762737,	-312236747,	-463170141,
+		-19167182,	-136529756,	-321525474,	-439166584,
+		28724267,	145849533,	330837255,	448732561,
+		-38334364,	-189783822,	-273059512,	-423738914,
+		47895677,	199091435,	282375505,	433292743,
+		57448534,	174827712,	291699066,	409324012,
+		-67019697,	-184128295,	-300991133,	-418902539,
+		-76668728,	-227995554,	-379567644,	-530091662,
+		67364049,	218420295,	369985021,	520795499,
+		95791354,	213031020,	398182870,	515701056,
+		-86479645,	-203465611,	-388624945,	-506380967,
+		114897068,	266207290,	349655424,	500195606,
+		-105581387,	-256654301,	-340093543,	-490887921,
+		-134039394,	-251295736,	-368256590,	-485758684,
+		124746887,	241716241,	358686123,	476458301,
+		-153337456,	-2395898,	-455991108,	-304803798,
+		162629001,	11973919,	465560741,	314102835,
+		134728098,	16841012,	436840590,	319723544,
+		-144044613,	-26395347,	-446403433,	-329032703,
+		191582708,	40657250,	426062040,	274858062,
+		-200894995,	-50223749,	-435620671,	-284179369,
+		-172959290,	-55056048,	-406931222,	-289830788,
+		182263263,	64630089,	416513267,	299125861,
+		229794136,	78991822,	532414580,	381366498,
+		-220224191,	-69691945,	-523123603,	-371788549,
+		-211162774,	-93398532,	-513308602,	-396314416,
+		201600371,	84090341,	503991391,	386759881,
+		-268078788,	-117292630,	-502591472,	-351526778,
+		258520357,	107972019,	493278217,	341959839,
+		249493774,	131713432,	483432482,	366454964,
+		-239911657,	-122417791,	-474129349,	-356881235,
+		-306674912,	-457198666,	-4791796,	-156118374,
+		315967289,	466778031,	14362133,	165418627,
+		325258002,	442776452,	23947838,	141187752,
+		-334573813,	-452329571,	-33509849,	-150495567,
+		269456196,	419996626,	33682024,	184992510,
+		-278767779,	-429561909,	-43239823,	-194312473,
+		-288089226,	-405591072,	-52790694,	-170046772,
+		297394031,	415166457,	62373443,	179343061,
+		383165416,	533828478,	81314500,	232780370,
+		-373594127,	-524527769,	-72022307,	-223201717,
+		-401789990,	-519431348,	-100447498,	-217810336,
+		392228803,	510123861,	91131631,	208256633,
+		-345918580,	-496598246,	-110112096,	-261561802,
+		336361365,	487278339,	100800185,	251995695,
+		364526526,	482151208,	129260178,	246639108,
+		-354943065,	-472854735,	-119955829,	-237064675,
+		459588272,	308539942,	157983644,	7181066,
+		-469170519,	-317835713,	-167286907,	-16754925,
+		-440448382,	-323454444,	-139383890,	-21619912,
+		450006683,	332774925,	148697015,	31186721,
+		-422325548,	-271261118,	-186797064,	-36011154,
+		431888077,	280569435,	196114401,	45565815,
+		403200742,	286222960,	168180682,	50400092,
+		-412770561,	-295522711,	-177471533,	-59977915,
+		-536157576,	-384970002,	-234585260,	-83643454,
+		526853729,	375396087,	225003341,	74348507,
+		517040714,	399923932,	215944038,	98057200,
+		-507728301,	-390357307,	-206385281,	-88735767,
+		498987548,	347783818,	263426864,	112501670,
+		-489671163,	-338229613,	-253864151,	-103192641,
+		-479823314,	-362722632,	-244835582,	-126932076,
+		470531639,	353144481,	235265819,	117632909
+		};
+
+	xe = x + n;
+	while(x < xe)
+		sum = crc_table[(sum ^ *x++) & 0xff] ^ (sum >> 8 & 0xffffff);
+	return sum;
+	}
+
+process(s, x)
+ char *s;
+ int x;
+{
+	register int n;
+	uchar buf[16*1024];
+	long fsize, sum;
+
+	sum = 0;
+	fsize = 0;
+	while((n = read(x, (char *)buf, sizeof(buf))) > 0) {
+		fsize += n;
+		sum = sum32(sum, buf, n);
+		}
+	sum &= 0xffffffff;
+        if (n==0)
+		printf("%s\t%lx\t%ld\n", s, sum & 0xffffffff, fsize);
+        else { perror(s); }
+	close(x);
+	return(0);
+	}

lang/fortran/comp/xsum0.out

@@ -0,0 +1,56 @@
+Notice	fb5a412e	1183
+README	fe10cd03	3340
+cds.c	e93849b8	3884
+data.c	e552a480	9278
+defines.h	ef026e5f	8179
+defs.h	e74a0285	23464
+equiv.c	e7eb3399	8552
+error.c	111d9ebf	3653
+exec.c	18ed4ede	18027
+expr.c	e2bc323c	57458
+f2c.1	e65632a	5799
+f2c.1t	1aad289	5706
+f2c.h	ed0a0173	4138
+format.c	e7b58fa8	49914
+format.h	e861ad39	300
+formatdata.c	eeebb124	23833
+ftypes.h	e5db6a7c	941
+gram.dcl	fac72441	8102
+gram.exec	ff121afb	2996
+gram.expr	1cdcf8c5	3081
+gram.head	e6859fc0	7539
+gram.io	1b7c281c	3294
+init.c	f7ca02f1	10347
+intr.c	e2b8e4ab	19647
+io.c	c474aae	28975
+iob.h	fe479ed3	459
+lex.c	fe1e63b6	29374
+machdefs.h	4950e5b	659
+main.c	1e4ec3a1	16300
+makefile	12f58dbe	2510
+malloc.c	5c2be2a	3422
+mem.c	5b007b2	4761
+memset.c	17404d52	1964
+misc.c	19c4624d	17758
+names.c	e5184875	19122
+names.h	f25436a3	689
+niceprintf.c	f9d80b51	9355
+niceprintf.h	c31f08c	412
+output.c	f97db62	37044
+output.h	edfe9e59	2113
+p1defs.h	e4e11c4e	5776
+p1output.c	e60446f5	12198
+parse.h	e457df2e	855
+parse_args.c	f3e5da4d	13015
+pccdefs.h	1b4fbbee	1195
+pread.c	135e64ca	15796
+proc.c	f5df26ff	34052
+put.c	1f22b2c0	9499
+putpcc.c	1f96161e	38473
+sysdep.c	197e669f	10864
+sysdep.h	e602b6fd	2532
+tokens	194fccfe	727
+usignal.h	1c4ce909	124
+vax.c	b060552	7649
+version.c	f7b72f6f	137
+xsum.c	bd02396	5479

lang/fortran/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.

lang/fortran/fc

@@ -0,0 +1,180 @@
+#!/bin/sh
+PATH=/v/bin:/bin:/usr/bin
+# f77-style shell script to compile and load fortran, C, and assembly codes
+
+#	usage:	f77 [-O] [-o absfile] [-c] files [-l library]
+
+#		-o objfile	Override default executable name a.out.
+
+#		-c		Do not call linker, leave relocatables in *.o.
+
+#		-S		leave assembler output on file.s
+
+#		-l library	(passed to ld).
+
+#		-u		complain about undeclared variables
+
+#		-w		omit all warning messages
+
+#		-w66		omit Fortran 66 compatibility warning messages
+
+#		files		FORTRAN source files ending in .f .
+#				C source files ending in .c .
+#				Assembly language files ending in .s .
+#				efl source files ending in .e .
+
+#		-D def		passed to C compiler (for .c files)
+
+#		-I includepath	passed to C compiler (for .c files)
+
+#		-Ntnnn		allow nnn entries in table t
+
+s=/tmp/stderr_$$
+t=/tmp/f77_$$.o
+CC=${CC_f2c:-'/v/bin/lcc -Wfdouble=8,4,1'}
+EFL=${EFL:-/v/bin/efl}
+EFLFLAGS=${EFLFLAGS:-'system=portable deltastno=10'}
+F2C=${F2C:-/v/bin/f2c}
+F2CFLAGS=${F2CFLAGS:='-ARw8'}
+rc=0
+trap "rm -f $s $t; exit \$rc" 0
+lib=/lib/num/lib.lo
+OUTF=a.out
+cOPT=1
+set -- `getopt cD:gI:N:Oo:Suw6 "$@"`
+case $? in 0);; *) exit 1;; esac
+CCFLAGS=
+while
+	test X"$1" != X--
+do
+	case "$1"
+	in
+	-c)	cOPT=0
+		shift
+		;;
+
+	-D)	CCFLAGS="$CCFLAGS -D$2"
+		shift 2
+		;;
+
+	-g)	CFLAGS="$CFLAGS -g"
+		shift;;
+
+	-I)	CCFLAGS="$CCFLAGS -I$2"
+		shift 2
+		;;
+
+	-o)	OUTF=$2
+		shift 2
+		;;
+
+	-O)	case $2 in -1) O=-O1;; -2) O=-O2;; -3) O=-O3;; *) O=-O;; esac
+		case $O in -O);; *) shift;; esac
+		# lcc ignores -O...
+		shift
+		;;
+
+	-u)	F2CFLAGS="$F2CFLAGS -u"
+		shift
+		;;
+
+	-w)	F2CFLAGS="$F2CFLAGS -w"
+		case $2 in -6) F2CFLAGS="$F2CFLAGS"66; shift
+			case $2 in -6) shift;; esac;; esac
+		shift
+		;;
+
+	-N)	F2CFLAGS="$F2CFLAGS $1""$2"
+		shift 2
+		;;
+
+	-S)	CFLAGS="$CFLAGS -S"
+		cOPT=0
+		shift
+		;;
+
+	*)
+		echo "invalid parameter $1" 1>&2
+		shift
+		;;
+	esac
+done
+shift
+while
+	test -n "$1"
+do
+	case "$1"
+	in
+	*.[fF])
+		case "$1" in *.f) f=".f";; *.F) f=".F";; esac
+		b=`basename $1 $f`
+		$F2C $F2CFLAGS $1
+		case $? in 0);; *) exit;; esac
+                $CC -c $CFLAGS $b.c 2>$s
+		rc=$?
+		sed '/parameter .* is not referenced/d;/warning: too many parameters/d' $s 1>&2
+		case $rc in 0);; *) exit;; esac
+		OFILES="$OFILES $b.o"
+		rm $b.c
+		case $cOPT in 1) cOPT=2;; esac
+		shift
+		;;
+	*.e)
+		b=`basename $1 .e`
+		$EFL $EFLFLAGS $1 >$b.f
+		case $? in 0);; *) exit;; esac
+		$F2C $F2CFLAGS $b.f
+		case $? in 0);; *) exit;; esac
+                $CC -c $CFLAGS $b.c
+		case $? in 0);; *) exit;; esac
+		OFILES="$OFILES $b.o"
+		rm $b.[cf]
+		case $cOPT in 1) cOPT=2;; esac
+		shift
+		;;
+	*.s)
+		echo $1: 1>&2
+		OFILE=`basename $1 .s`.o
+		${AS:-/usr/bin/as} -o $OFILE $AFLAGS $1
+		case $? in 0);; *) exit;; esac
+		OFILES="$OFILES $OFILE"
+		case $cOPT in 1) cOPT=2;; esac
+		shift
+		;;
+	*.c)
+		echo $1: 1>&2
+		OFILE=`basename $1 .c`.o
+                $CC -c $CFLAGS $CCFLAGS $1
+		rc=$?; case $rc in 0);; *) exit;; esac
+		OFILES="$OFILES $OFILE"
+		case $cOPT in 1) cOPT=2;; esac
+		shift
+		;;
+	*.o)
+		OFILES="$OFILES $1"
+		case $cOPT in 1) cOPT=2;; esac
+		shift
+		;;
+	-l)
+		OFILES="$OFILES -l$2"
+		shift 2
+		case $cOPT in 1) cOPT=2;; esac
+		;;
+	-l*)
+		OFILES="$OFILES $1"
+		shift
+		case $cOPT in 1) cOPT=2;; esac
+		;;
+	-o)
+		OUTF=$2; shift 2;;
+	*)
+		OFILES="$OFILES $1"
+		shift
+		case $cOPT in 1) cOPT=2;; esac
+		;;
+	esac
+done
+
+case $cOPT in 2) $CC -o $OUTF -u MAIN__ $OFILES -lf2c -lm;; esac
+rc=$?
+exit $rc

lang/fortran/index

@@ -0,0 +1,392 @@
+
+====== index for f2c ============
+
+FILES:
+
+f2c.h	Include file necessary for compiling output of the converter.
+	See the second NOTE below.
+
+f2c.1	Man page for f2c.
+
+f2c.1t	Source for f2c.1 (to be processed by troff -man or nroff -man).
+
+libf77	Library of non I/O support routines the generated C may need.
+	Fortran main programs result in a C function named MAIN__ that
+	is meant to be invoked by the main() in libf77.
+
+libi77	Library of Fortran I/O routines the generated C may need.
+	Note that some vendors (e.g., BSD, Sun and MIPS) provide a
+	libF77 and libI77 that are incompatible with f2c -- they
+	provide some differently named routines or routines with the
+	names that f2c expects, but with different calling sequences.
+	On such systems, the recommended procedure is to merge
+	libf77 and libi77 into a single library, say libf2c, to install
+	it where you can access it by specifying -lf2c , and to adjust
+	the definition of link_msg in sysdep.c appropriately.
+
+f2c.ps	Postscript for a technical report on f2c.  After you strip the
+	mail header, the first line should be "%!PS".
+
+fixes	The complete change log, reporting bug fixes and other changes.
+	(Some recent change-log entries are given below).
+
+fc	A shell script that uses f2c and imitates much of the behavior
+	of commonly found f77 commands.  You will almost certainly
+	need to adjust some of the shell-variable assignments to make
+	this script work on your system.
+
+
+SUBDIRECTORY:
+
+f2c/src	Source for the converter itself, including a file of checksums
+	and source for a program to compute the checksums (to verify
+	correct transmission of the source), is available: ask netlib to
+		send all from f2c/src
+	If the checksums show damage to just a few source files, or if
+	the change log file (see "fixes" below) reports corrections to
+	some source files, you can request those files individually
+	"from f2c/src".  For example, to get defs.h and xsum0.out, you
+	would ask netlib to
+		send defs.h xsum0.out from f2c/src
+	"all from f2c/src" is 649642 bytes long.
+
+	Tip: if asked to send over 99,000 bytes in one request, netlib
+	breaks the shipment into 1000 line pieces and sends each piece
+	separately (since otherwise some mailers might gag).  To avoid
+	the hassle of reassembling the pieces, try to keep each request
+	under 99,000 bytes long.  The final number in each line of
+	xsum0.out gives the length of each file in f2c/src.  For
+	example,
+		send exec.c expr.c from f2c/src
+		send format.c format_data.c from f2c/src
+	will give you slightly less hassle than
+		send exec.c expr.c format.c format_data.c from f2c/src
+
+	If you have trouble generating gram.c, you can ask netlib to
+		send gram.c from f2c/src
+	Then `xsum gram.c` should report
+		gram.c	efa337b3	57282
+
+NOTE:	For now, you may exercise f2c by sending netlib a message whose
+	first line is "execute f2c" and whose remaining lines are
+	the Fortran 77 source that you wish to have converted.
+	Return mail brings you the resulting C, with f2c's error
+	messages between #ifdef uNdEfInEd and #endif at the end.
+	(To understand line numbers in the error messages, regard
+	the "execute f2c" line as line 0.  It is stripped away by
+	the netlib software before f2c sees your Fortran input.)
+	Options described in the man page may be transmitted to
+	netlib by having the first line of input be a comment
+	whose first 6 characters are "c$f2c " and whose remaining
+	characters are the desired options, e.g., "c$f2c -R -u".
+	This scheme may change -- ask netlib to
+               send index from f2c
+        if you do not get the behavior you expect.
+
+	During the initial experimental period, incoming Fortran
+	will be saved in a file.  Don't send any secrets!
+
+
+BUGS:	Please send bug reports (including the shortest example
+	you can find that illustrates the bug) to research!dmg
+	or dmg@research.att.com .  You might first check whether
+	the bug goes away when you turn optimization off.
+
+
+NOTE:	f2c.h defines several types, e.g., real, integer, doublereal.
+	The definitions in f2c.h are suitable for most machines, but if
+	your machine has sizeof(double) > 2*sizeof(long), you may need
+	to adjust f2c.h appropriately.  f2c assumes
+		sizeof(doublecomplex) = 2*sizeof(doublereal)
+		sizeof(doublereal) = sizeof(complex)
+		sizeof(doublereal) = 2*sizeof(real)
+		sizeof(real) = sizeof(integer)
+		sizeof(real) = sizeof(logical)
+		sizeof(real) = 2*sizeof(shortint)
+	EQUIVALENCEs may not be translated correctly if these
+	assumptions are violated.
+
+	There exists a C compiler that objects to the lines
+		typedef VOID C_f;	/* complex function */
+		typedef VOID H_f;	/* character function */
+		typedef VOID Z_f;	/* double complex function */
+	in f2c.h .  If yours is such a compiler, do two things:
+	1. Complain to your vendor about this compiler bug.
+	2. Find the line
+		#define VOID void
+	   in f2c.h and change it to
+		#define VOID int
+	(For readability, the f2c.h lines shown above have had two
+	tabs inserted before their first character.)
+
+FTP:	All the material described above is now available by ftp from
+	research.att.com (login: netlib; Password: your E-mail address;
+	cd f2c).  You must uncompress the .Z files once you have a
+	copy of them, e.g., by
+		uncompress *.Z
+
+-----------------
+Recent change log (partial)
+-----------------
+
+Tue Jan 15 12:00:24 EST 1991:
+  Fix bug when two equivalence groups are merged, the second with
+nonzero offset, and the result is then merged into a common block.
+Example:
+      INTEGER W(3), X(3), Y(3), Z(3)
+      COMMON /ZOT/ Z
+      EQUIVALENCE (W(1),X(1)), (X(2),Y(1)), (Z(3),X(1))
+***** W WAS GIVEN THE WRONG OFFSET
+  Recognize Fortran 90's optional NML= in NAMELIST READs and WRITEs.
+(Currently NML= and FMT= are treated as synonyms -- there's no
+error message if, e.g., NML= specifies a format.)
+  libi77: minor adjustment to allow internal READs from character
+string constants in read-only memory.
+
+Wed Jan 23 00:38:48 EST 1991:
+  Allow hex, octal, and binary constants to have the qualifying letter
+(z, x, o, or b) either before or after the quoted string containing the
+digits.  For now this change will not be reflected in f2c.ps .
+
+Tue Jan 29 16:23:45 EST 1991:
+  Arrange for character-valued statement functions to give results of
+the right length (that of the statement function's name).
+
+Wed Jan 30 07:05:32 EST 1991:
+  More tweaks for character-valued statement functions: an error
+check and an adjustment so a right-hand side of nonconstant length
+(e.g., a substring) is handled right.
+
+Thu Jan 31 13:53:44 EST 1991:
+  Add a test after the cleanup call generated for I/O statements with
+ERR= or END= clauses to catch the unlikely event that the cleanup
+routine encounters an error.
+
+Tue Feb  5 01:39:36 EST 1991:
+  Change Mktemp to mktmp (for the benefit of systems so brain-damaged
+that they do not distinguish case in external names -- and that for
+some reason want to load mktemp).  Try to get xsum0.out right this
+time (it somehow didn't get updated on 4 Feb. 1991).
+  Add note to libi77/README about adjusting the interpretation of
+RECL= specifiers in OPENs for direct unformatted I/O.
+
+Thu Feb  7 17:24:42 EST 1991:
+  New option -r casts values of REAL functions, including intrinsics,
+to REAL.  This only matters for unportable code like
+	real r
+	r = asin(1.)
+	if (r .eq. asin(1.)) ...
+[The behavior of such code varies with the Fortran compiler used --
+and sometimes is affected by compiler options.]  For now, the man page
+at the end of f2c.ps is the only part of f2c.ps that reflects this new
+option.
+
+Fri Feb  8 18:12:51 EST 1991:
+  Cast pointer differences passed as arguments to the appropriate type.
+This matters, e.g., with MSDOS compilers that yield a long pointer
+difference but have int == short.
+  Disallow nonpositive dimensions.
+
+Fri Feb 15 12:24:15 EST 1991:
+  Change %d to %ld in sprintf call in putpower in putpcc.c.
+  Free more memory (e.g. allowing translation of larger Fortran
+files under MS-DOS).
+  Recognize READ (character expression)
+as formatted I/O with the format given by the character expression.
+  Update year in Notice.
+
+Mon Mar  4 15:19:42 EST 1991:
+  Fix bug in passing the real part of a complex argument to an intrinsic
+function.  Omit unneeded parentheses in nested calls to intrinsics.
+Example:
+	subroutine foo(x, y)
+	complex y
+	x = exp(sin(real(y))) + exp(imag(y))
+	end
+
+Fri Mar  8 15:05:42 EST 1991:
+  Fix a comment in expr.c; omit safstrncpy.c (which had bugs in
+cases not used by f2c).
+
+Wed Mar 13 02:27:23 EST 1991:
+  Initialize firstmemblock->next in mem_init in mem.c .  [On most
+systems it was fortuituously 0, but with System V, -lmalloc could
+trip on this missed initialization.]
+
+Wed Mar 13 11:47:42 EST 1991:
+  Fix a reference to freed memory.
+
+Wed Mar 27 00:42:19 EST 1991:
+  Fix a memory fault caused by such illegal Fortran as
+       function foo
+       x = 3
+       logical foo	! declaration among executables
+       foo=.false.	! used to suffer memory fault
+       end
+
+Fri Apr  5 08:30:31 EST 1991:
+  Fix loss of % in some format expressions, e.g.
+	write(*,'(1h%)')
+  Fix botch introduced 27 March 1991 that caused subroutines with
+multiple entry points to have extraneous declarations of ret_val.
+
+Fri Apr  5 12:44:02 EST 1991
+  Try again to omit extraneous ret_val declarations -- this morning's
+fix was sometimes wrong.
+
+Mon Apr  8 13:47:06 EDT 1991:
+  Arrange for s_rnge to have the right prototype under -A -C .
+
+Wed Apr 17 13:36:03 EDT 1991:
+  New fatal error message for apparent invocation of a recursive
+statement function.
+
+Thu Apr 25 15:13:37 EDT 1991:
+  F2c and libi77 adjusted so NAMELIST works with -i2.  (I forgot
+about -i2 when adding NAMELIST.)  This required a change to f2c.h
+(that only affects NAMELIST I/O under -i2.)  Man-page description of
+-i2 adjusted to reflect that -i2 stores array lengths in short ints.
+
+Fri Apr 26 02:54:41 EDT 1991:
+  Libi77: fix some bugs in NAMELIST reading of multi-dimensional arrays
+(file rsne.c).
+
+Tue May  7 09:04:48 EDT 1991:
+  gram.c added to f2c/src (for folks who have trouble generating it.  It
+is not in "all from f2c", nor in the list of current timestamps below.)
+
+Thu May  9 02:13:51 EDT 1991:
+  Omit a trailing space in expr.c (could cause a false xsum value if
+a mailer drops the trailing blank).
+
+Thu May 16 13:14:59 EDT 1991:
+  libi77: increase LEFBL in lio.h to overcome a NeXT bug.
+  Tweak for compilers that recognize "nested" comments: inside comments,
+turn /* into /+ (as well as */ into +/).
+
+Sat May 25 11:44:25 EDT 1991:
+  libf77: s_rnge: declare line long int rather than int.
+
+Fri May 31 07:51:50 EDT 1991:
+  libf77: system_: officially return status.
+
+Mon Jun 17 16:52:53 EDT 1991:
+  Minor tweaks: omit unnecessary declaration of strcmp (that caused
+trouble on a system where strcmp was a macro) from misc.c; add
+SHELL = /bin/sh to makefiles.
+  Fix a dereference of null when a CHARACTER*(*) declaration appears
+(illegally) after DATA.  Complain only once per subroutine about
+declarations appearing after DATA.
+
+Mon Jul  1 00:28:13 EDT 1991:
+  Add test and error message for illegal use of subroutine names, e.g.
+      SUBROUTINE ZAP(A)
+      ZAP = A
+      END
+
+Mon Jul  8 21:49:20 EDT 1991:
+  Issue a warning about things like
+	integer i
+	i = 'abc'
+(which is treated as i = ichar('a')).  [It might be nice to treat 'abc'
+as an integer initialized (in a DATA statement) with 'abc', but
+other matters have higher priority.]
+  Render
+	i = ichar('A')
+as
+	i = 'A';
+rather than
+	i = 65;
+(which assumes ASCII).
+
+Fri Jul 12 07:41:30 EDT 1991:
+  Note added to README about erroneous definitions of __STDC__ .
+
+Sat Jul 13 13:38:54 EDT 1991:
+  Fix bugs in double type convesions of complex values, e.g.
+sngl(real(...)) or dble(real(...)) (where ... is complex).
+
+Mon Jul 15 13:21:42 EDT 1991:
+  Fix bug introduced 8 July 1991 that caused erroneous warnings
+"ichar([first char. of] char. string) assumed for conversion to numeric"
+when a subroutine had an array of character strings as an argument.
+
+Wed Aug 28 01:12:17 EDT 1991:
+  Omit an unused function in format.c, an unused variable in proc.c .
+  Under -r8, promote complex to double complex (as the man page claims).
+
+Fri Aug 30 17:19:17 EDT 1991:
+  f2c.ps updated: slightly expand description of intrinsics and,or,xor,
+not; add mention of intrinsics lshift, rshift; add note about f2c
+accepting Fortran 90 inline comments (starting with !); update Cobalt
+Blue address.
+
+Tue Sep 17 07:17:33 EDT 1991:
+  libI77: err.c and open.c modified to use modes "rb" and "wb"
+when (f)opening unformatted files; README updated to point out
+that it may be necessary to change these modes to "r" and "w"
+on some non-ANSI systems.
+
+Current timestamps of files in "all from f2c/src", sorted by time,
+appear below (mm/dd/year hh:mm:ss).  To bring your source up to date,
+obtain source files with a timestamp later than the time shown in your
+version.c.  Note that the time shown in the current version.c is the
+timestamp of the source module that immediately follows version.c below:
+
+ 8/28/1991   0:29:01  xsum0.out
+ 8/28/1991   0:23:26  version.c
+ 8/28/1991   0:07:02  main.c
+ 8/28/1991   0:07:01  gram.dcl
+ 8/28/1991   0:07:01  expr.c
+ 8/28/1991   0:07:00  defs.h
+ 8/13/1991   9:06:09  format.c
+ 8/13/1991   9:04:25  proc.c
+ 7/13/1991  12:58:37  putpcc.c
+ 7/12/1991   7:25:33  README
+ 7/05/1991   7:16:57  intr.c
+ 6/17/1991  16:43:01  gram.head
+ 6/06/1991   0:41:56  makefile
+ 6/05/1991   8:34:09  misc.c
+ 5/16/1991  13:06:06  p1output.c
+ 4/25/1991  13:20:26  f2c.1
+ 4/25/1991  12:56:19  f2c.h
+ 4/25/1991  12:51:27  f2c.1t
+ 4/25/1991  12:10:22  io.c
+ 4/05/1991   7:43:45  mem.c
+ 3/13/1991  11:18:09  output.c
+ 3/08/1991  10:14:45  niceprintf.c
+ 2/15/1991  12:08:26  Notice
+ 2/08/1991  11:29:18  gram.exec
+ 2/08/1991  11:29:18  malloc.c
+ 2/05/1991   0:52:39  exec.c
+ 1/22/1991  19:25:10  lex.c
+ 1/15/1991   1:21:00  equiv.c
+12/16/1990  16:46:20  xsum.c
+12/07/1990  17:37:08  names.c
+11/30/1990   9:47:48  data.c
+ 7/26/1990  10:54:47  parse_args.c
+ 7/26/1990  10:44:26  parse.h
+ 6/19/1990   0:18:23  formatdata.c
+ 5/11/1990  14:17:04  error.c
+ 4/23/1990  17:35:47  sysdep.h
+ 4/23/1990  16:37:50  sysdep.c
+ 4/18/1990  12:25:19  init.c
+ 4/18/1990  12:25:19  pread.c
+ 4/18/1990  12:25:18  cds.c
+ 4/10/1990   0:00:38  put.c
+ 4/06/1990   0:00:57  gram.io
+ 4/05/1990  23:40:09  gram.expr
+ 3/27/1990  16:39:18  names.h
+ 3/27/1990  10:05:15  p1defs.h
+ 3/27/1990  10:05:14  defines.h
+ 2/25/1990   9:04:30  vax.c
+ 2/16/1990  10:37:27  tokens
+ 2/14/1990   2:00:20  format.h
+ 2/14/1990   1:38:46  output.h
+ 2/14/1990   0:54:06  iob.h
+ 2/03/1990   0:58:26  niceprintf.h
+ 1/29/1990  13:26:52  memset.c
+ 1/11/1990  18:02:51  ftypes.h
+ 1/07/1990   1:20:01  usignal.h
+11/27/1989   8:27:37  machdefs.h
+ 7/01/1989  11:59:44  pccdefs.h

lang/fortran/lib/.distr

@@ -0,0 +1,3 @@
+LIST
+libF77
+libI77

lang/fortran/lib/LIST

@@ -0,0 +1,3 @@
+LIST
+libF77
+libI77