f2c from netlib.att.com Jan 4 1994

diff --git a/usr.bin/f2c/Notice b/usr.bin/f2c/Notice
new file mode 100644 (file)
index 0000000..64af9f1
--- /dev/null
+++ b/usr.bin/f2c/Notice
@@ -0,0 +1,23 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+

diff --git a/usr.bin/f2c/README b/usr.bin/f2c/README
new file mode 100644 (file)
index 0000000..ed88aaa
--- /dev/null
+++ b/usr.bin/f2c/README
@@ -0,0 +1,94 @@
+Type "make" to check the validity of the f2c source and compile f2c.
+
+On a PC, you may need to compile xsum.c with -DMSDOS (i.e., with
+MSDOS #defined).  If your system does not understand ANSI/ISO C
+syntax (i.e., if you have a K&R C compiler), compile xsum.c with
+-DKR_headers.  (Eventually this will also be required of the f2c
+source proper.)
+
+On non-Unix systems where files have separate binary and text modes,
+you may need to "make xsumr.out" rather than "make xsum.out".
+
+If (in accordance with what follows) you need to modify the makefile
+or any of the source files, first issue a "make xsum.out" (or, if
+appropriate, "make xsumr.out") to check the validity of the f2c source,
+then make your changes, then type "make f2c".
+
+The file usignal.h is for the benefit of strictly ANSI include files
+on a UNIX system -- the ANSI signal.h does not define SIGHUP or SIGQUIT.
+You may need to modify usignal.h if you are not running f2c on a UNIX
+system.
+
+Should you get the message "xsum0.out xsum1.out differ", see what lines
+are different (`diff xsum0.out xsum1.out`) and ask netlib to send you
+the files in question "from f2c/src".  For example, if exec.c and
+expr.c have incorrect check sums, you would send netlib the message
+       send exec.c expr.c from f2c/src
+
+On some systems, the malloc and free in malloc.c let f2c run faster
+than do the standard malloc and free.  Other systems cannot tolerate
+redefinition of malloc and free.  If yours is such a system, you may
+either modify the makefile appropriately, or simply execute
+       cc -c -DCRAY malloc.c
+before typing "make".  Still other systems have a -lmalloc that
+provides performance competitive with that from malloc.c; you may
+wish to compare the two on your system.
+
+On some BSD systems, you may need to create a file named "string.h"
+whose single line is
+#include <strings.h>
+you may need to add " -Dstrchr=index" to the "CFLAGS =" assignment
+in the makefile, and you may need to add " memset.o" to the "OBJECTS ="
+assignment in the makefile -- see the comments in memset.c .
+
+For non-UNIX systems, you may need to change some things in sysdep.c,
+such as the choice of intermediate file names.
+
+On some systems, you may need to modify parts of sysdep.h (which is
+included by defs.h).  In particular, for Sun 4.1 systems and perhaps
+some others, you need to comment out the typedef of size_t.  For some
+systems (e.g., IRIX 4.0.1 and AIX) it is better to add
+#define ANSI_Libraries
+to the beginning of sysdep.h (or to supply -DANSI_Libraries in the
+makefile).
+
+Alas, some systems #define __STDC__ but do not provide a true standard
+(ANSI or ISO) C environment, e.g. do not provide stdlib.h .  If yours
+is such a system, then (a) you should complain loudly to your vendor
+about __STDC__ being erroneously defined, and (b) you should insert
+#undef __STDC__
+at the beginning of sysdep.h .  You may need to make other adjustments.
+
+For some non-ANSI versions of stdio, you must change the values given
+to binread and binwrite in sysdep.c from "rb" and "wb" to "r" and "w".
+You may need to make this change if you run f2c and get an error
+message of the form
+       Compiler error ... cannot open intermediate file ...
+
+On many systems, it is best to combine libF77 and libI77 into a single
+library, say libf2c, as suggested in "readme from f2c".  If you do this,
+then you should adjust the definition of link_msg in sysdep.c
+appropriately (e.g., replacing "-lF77 -lI77" by "-lf2c").
+
+Some older C compilers object to
+       typedef void (*foo)();
+or to
+       typedef void zap;
+       zap (*foo)();
+If yours is such a compiler, change the definition of VOID in
+f2c.h from void to int.
+
+For convenience with systems that use control-Z to denote end-of-file,
+f2c treats control-Z characters (ASCII 26, '\x1a') that appear at the
+beginning of a line as an end-of-file indicator.  You can disable this
+test by compiling lex.c with NO_EOF_CHAR_CHECK #defined, or can
+change control-Z to some other character by #defining EOF_CHAR to
+be the desired value.
+
+Please send bug reports to dmg@research.att.com .  The old index file
+(now called "readme" due to unfortunate changes in netlib conventions:
+"send readme from f2c") will report recent changes in the recent-change
+log at its end; all changes will be shown in the "changes" file
+("send changes from f2c").  To keep current source, you will need to
+request xsum0.out and version.c, in addition to the changed source
+files.

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

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

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

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

diff --git a/usr.bin/f2c/dependencies b/usr.bin/f2c/dependencies
new file mode 100644 (file)
index 0000000..9937e0b
--- /dev/null
+++ b/usr.bin/f2c/dependencies
@@ -0,0 +1,60 @@
+f2c/src*
+Notice=
+notice
+README=
+readme
+cds.c=
+data.c=
+defines.h=
+defs.h=
+equiv.c=
+error.c=
+exec.c=
+expr.c=
+f2c.1=
+f2c.1t=
+f2c.h=
+format.c=
+format.h=
+formatdata.c=
+ftypes.h=
+gram.dcl=
+gram.exec=
+gram.expr=
+gram.head=
+gram.io=
+init.c=
+intr.c=
+io.c=
+iob.h=
+lex.c=
+machdefs.h=
+main.c=
+makefile=
+malloc.c=
+mem.c=
+memset.c=
+misc.c=
+names.c=
+names.h=
+niceprintf.c=
+niceprintf.h=
+output.c=
+output.h=
+p1defs.h=
+p1output.c=
+parse.h=
+parse_args.c=
+pccdefs.h=
+pread.c=
+proc.c=
+put.c=
+putpcc.c=
+sysdep.c=
+sysdep.h=
+tokens=
+usignal.h=
+vax.c=
+version.c=
+xsum.c=
+xsum0.out=

diff --git a/usr.bin/f2c/disclaimer b/usr.bin/f2c/disclaimer
new file mode 100644 (file)
index 0000000..59db1ec
--- /dev/null
+++ b/usr.bin/f2c/disclaimer
@@ -0,0 +1,15 @@
+f2c is a Fortran to C converter under development by
+       David Gay (AT&T Bell Labs)
+       Stu Feldman (Bellcore)
+       Mark Maimone (Carnegie-Mellon University)
+       Norm Schryer (AT&T Bell Labs)
+Please send bug reports to dmg@research.att.com or uunet!research!dmg.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.

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

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

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

diff --git a/usr.bin/f2c/expr.c b/usr.bin/f2c/expr.c
new file mode 100644 (file)
index 0000000..eeccf42
--- /dev/null
+++ b/usr.bin/f2c/expr.c
@@ -0,0 +1,3042 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "output.h"
+#include "names.h"
+
+LOCAL void conspower(), consbinop(), zdiv();
+LOCAL expptr fold(), mkpower(), stfcall();
+#ifndef stfcall_MAX
+#define stfcall_MAX 144
+#endif
+
+typedef struct { double dreal, dimag; } dcomplex;
+
+extern char dflttype[26];
+extern int htype;
+
+/* little routines to create constant blocks */
+
+Constp mkconst(t)
+register int t;
+{
+       register Constp p;
+
+       p = ALLOC(Constblock);
+       p->tag = TCONST;
+       p->vtype = t;
+       return(p);
+}
+
+
+/* mklogcon -- Make Logical Constant */
+
+expptr mklogcon(l)
+register int l;
+{
+       register Constp  p;
+
+       p = mkconst(tylog);
+       p->Const.ci = l;
+       return( (expptr) p );
+}
+
+
+
+/* mkintcon -- Make Integer Constant */
+
+expptr mkintcon(l)
+ftnint l;
+{
+       register Constp p;
+
+       p = mkconst(tyint);
+       p->Const.ci = l;
+       return( (expptr) p );
+}
+
+
+
+
+/* mkaddcon -- Make Address Constant, given integer value */
+
+expptr mkaddcon(l)
+register long l;
+{
+       register Constp p;
+
+       p = mkconst(TYADDR);
+       p->Const.ci = l;
+       return( (expptr) p );
+}
+
+
+
+/* mkrealcon -- Make Real Constant.  The type t is assumed
+   to be TYREAL or TYDREAL */
+
+expptr mkrealcon(t, d)
+ register int t;
+ char *d;
+{
+       register Constp p;
+
+       p = mkconst(t);
+       p->Const.cds[0] = cds(d,CNULL);
+       p->vstg = 1;
+       return( (expptr) p );
+}
+
+
+/* mkbitcon -- Make bit constant.  Reads the input string, which is
+   assumed to correctly specify a number in base 2^shift (where   shift
+   is the input parameter).   shift   may not exceed 4, i.e. only binary,
+   quad, octal and hex bases may be input.  Constants may not exceed 32
+   bits, or whatever the size of (struct Constblock).ci may be. */
+
+expptr mkbitcon(shift, leng, s)
+int shift;
+int leng;
+char *s;
+{
+       register Constp p;
+       register long x;
+
+       p = mkconst(TYLONG);
+       x = 0;
+       while(--leng >= 0)
+               if(*s != ' ')
+                       x = (x << shift) | hextoi(*s++);
+       /* mwm wanted to change the type to short for short constants,
+        * but this is dangerous -- there is no syntax for long constants
+        * with small values.
+        */
+       p->Const.ci = x;
+       return( (expptr) p );
+}
+
+
+
+
+
+/* mkstrcon -- Make string constant.  Allocates storage and initializes
+   the memory for a copy of the input Fortran-string. */
+
+expptr mkstrcon(l,v)
+int l;
+register char *v;
+{
+       register Constp p;
+       register char *s;
+
+       p = mkconst(TYCHAR);
+       p->vleng = ICON(l);
+       p->Const.ccp = s = (char *) ckalloc(l+1);
+       p->Const.ccp1.blanks = 0;
+       while(--l >= 0)
+               *s++ = *v++;
+       *s = '\0';
+       return( (expptr) p );
+}
+
+
+
+/* mkcxcon -- Make complex contsant.  A complex number is a pair of
+   values, each of which may be integer, real or double. */
+
+expptr mkcxcon(realp,imagp)
+register expptr realp, imagp;
+{
+       int rtype, itype;
+       register Constp p;
+       expptr errnode();
+
+       rtype = realp->headblock.vtype;
+       itype = imagp->headblock.vtype;
+
+       if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
+       {
+               p = mkconst( (rtype==TYDREAL||itype==TYDREAL)
+                               ? TYDCOMPLEX : tycomplex);
+               if (realp->constblock.vstg || imagp->constblock.vstg) {
+                       p->vstg = 1;
+                       p->Const.cds[0] = ISINT(rtype)
+                               ? string_num("", realp->constblock.Const.ci)
+                               : realp->constblock.vstg
+                                       ? realp->constblock.Const.cds[0]
+                                       : dtos(realp->constblock.Const.cd[0]);
+                       p->Const.cds[1] = ISINT(itype)
+                               ? string_num("", imagp->constblock.Const.ci)
+                               : imagp->constblock.vstg
+                                       ? imagp->constblock.Const.cds[0]
+                                       : dtos(imagp->constblock.Const.cd[0]);
+                       }
+               else {
+                       p->Const.cd[0] = ISINT(rtype)
+                               ? realp->constblock.Const.ci
+                               : realp->constblock.Const.cd[0];
+                       p->Const.cd[1] = ISINT(itype)
+                               ? imagp->constblock.Const.ci
+                               : imagp->constblock.Const.cd[0];
+                       }
+       }
+       else
+       {
+               err("invalid complex constant");
+               p = (Constp)errnode();
+       }
+
+       frexpr(realp);
+       frexpr(imagp);
+       return( (expptr) p );
+}
+
+
+/* errnode -- Allocate a new error block */
+
+expptr errnode()
+{
+       struct Errorblock *p;
+       p = ALLOC(Errorblock);
+       p->tag = TERROR;
+       p->vtype = TYERROR;
+       return( (expptr) p );
+}
+
+
+
+
+
+/* mkconv -- Make type conversion.  Cast expression   p   into type   t.
+   Note that casting to a character copies only the first sizeof(char)
+   bytes. */
+
+expptr mkconv(t, p)
+register int t;
+register expptr p;
+{
+       register expptr q;
+       register int pt, charwarn = 1;
+       expptr opconv();
+
+       if (t >= 100) {
+               t -= 100;
+               charwarn = 0;
+               }
+       if(t==TYUNKNOWN || t==TYERROR)
+               badtype("mkconv", t);
+       pt = p->headblock.vtype;
+
+/* Casting to the same type is a no-op */
+
+       if(t == pt)
+               return(p);
+
+/* If we're casting a constant which is not in the literal table ... */
+
+       else if( ISCONST(p) && pt!=TYADDR && pt != TYCHAR)
+       {
+               if (ISINT(t) && ISINT(pt) || ISREAL(t) && ISREAL(pt)) {
+                       /* avoid trouble with -i2 */
+                       p->headblock.vtype = t;
+                       return p;
+                       }
+               q = (expptr) mkconst(t);
+               consconv(t, &q->constblock, &p->constblock );
+               frexpr(p);
+       }
+       else {
+               if (pt == TYCHAR && t != TYADDR && charwarn
+                               && (!halign || p->tag != TADDR
+                               || p->addrblock.uname_tag != UNAM_CONST))
+                       warn(
+                "ichar([first char. of] char. string) assumed for conversion to numeric");
+               q = opconv(p, t);
+               }
+
+       if(t == TYCHAR)
+               q->constblock.vleng = ICON(1);
+       return(q);
+}
+
+
+
+/* opconv -- Convert expression   p   to type   t   using the main
+   expression evaluator; returns an OPCONV expression, I think  14-jun-88 mwm */
+
+expptr opconv(p, t)
+expptr p;
+int t;
+{
+       register expptr q;
+
+       if (t == TYSUBR)
+               err("illegal use of subroutine name");
+       q = mkexpr(OPCONV, p, ENULL);
+       q->headblock.vtype = t;
+       return(q);
+}
+
+
+
+/* addrof -- Create an ADDR expression operation */
+
+expptr addrof(p)
+expptr p;
+{
+       return( mkexpr(OPADDR, p, ENULL) );
+}
+
+
+
+/* cpexpr - Returns a new copy of input expression   p   */
+
+tagptr cpexpr(p)
+register tagptr p;
+{
+       register tagptr e;
+       int tag;
+       register chainp ep, pp;
+       tagptr cpblock();
+
+/* This table depends on the ordering of the T macros, e.g. TNAME */
+
+       static int blksize[ ] =
+       {
+               0,
+               sizeof(struct Nameblock),
+               sizeof(struct Constblock),
+               sizeof(struct Exprblock),
+               sizeof(struct Addrblock),
+               sizeof(struct Primblock),
+               sizeof(struct Listblock),
+               sizeof(struct Impldoblock),
+               sizeof(struct Errorblock)
+       };
+
+       if(p == NULL)
+               return(NULL);
+
+/* TNAMEs are special, and don't get copied.  Each name in the current
+   symbol table has a unique TNAME structure. */
+
+       if( (tag = p->tag) == TNAME)
+               return(p);
+
+       e = cpblock(blksize[p->tag], (char *)p);
+
+       switch(tag)
+       {
+       case TCONST:
+               if(e->constblock.vtype == TYCHAR)
+               {
+                       e->constblock.Const.ccp =
+                           copyn((int)e->constblock.vleng->constblock.Const.ci+1,
+                               e->constblock.Const.ccp);
+                       e->constblock.vleng =
+                           (expptr) cpexpr(e->constblock.vleng);
+               }
+       case TERROR:
+               break;
+
+       case TEXPR:
+               e->exprblock.leftp =  (expptr) cpexpr(p->exprblock.leftp);
+               e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp);
+               break;
+
+       case TLIST:
+               if(pp = p->listblock.listp)
+               {
+                       ep = e->listblock.listp =
+                           mkchain((char *)cpexpr((tagptr)pp->datap), CHNULL);
+                       for(pp = pp->nextp ; pp ; pp = pp->nextp)
+                               ep = ep->nextp =
+                                   mkchain((char *)cpexpr((tagptr)pp->datap),
+                                               CHNULL);
+               }
+               break;
+
+       case TADDR:
+               e->addrblock.vleng = (expptr)  cpexpr(e->addrblock.vleng);
+               e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset);
+               e->addrblock.istemp = NO;
+               break;
+
+       case TPRIM:
+               e->primblock.argsp = (struct Listblock *)
+                   cpexpr((expptr)e->primblock.argsp);
+               e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp);
+               e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp);
+               break;
+
+       default:
+               badtag("cpexpr", tag);
+       }
+
+       return(e);
+}
+
+/* frexpr -- Free expression -- frees up memory used by expression   p   */
+
+frexpr(p)
+register tagptr p;
+{
+       register chainp q;
+
+       if(p == NULL)
+               return;
+
+       switch(p->tag)
+       {
+       case TCONST:
+               if( ISCHAR(p) )
+               {
+                       free( (charptr) (p->constblock.Const.ccp) );
+                       frexpr(p->constblock.vleng);
+               }
+               break;
+
+       case TADDR:
+               if (p->addrblock.vtype > TYERROR)       /* i/o block */
+                       break;
+               frexpr(p->addrblock.vleng);
+               frexpr(p->addrblock.memoffset);
+               break;
+
+       case TERROR:
+               break;
+
+/* TNAME blocks don't get free'd - probably because they're pointed to in
+   the hash table. 14-Jun-88 -- mwm */
+
+       case TNAME:
+               return;
+
+       case TPRIM:
+               frexpr((expptr)p->primblock.argsp);
+               frexpr(p->primblock.fcharp);
+               frexpr(p->primblock.lcharp);
+               break;
+
+       case TEXPR:
+               frexpr(p->exprblock.leftp);
+               if(p->exprblock.rightp)
+                       frexpr(p->exprblock.rightp);
+               break;
+
+       case TLIST:
+               for(q = p->listblock.listp ; q ; q = q->nextp)
+                       frexpr((tagptr)q->datap);
+               frchain( &(p->listblock.listp) );
+               break;
+
+       default:
+               badtag("frexpr", p->tag);
+       }
+
+       free( (charptr) p );
+}
+
+ void
+wronginf(np)
+ Namep np;
+{
+       int c, k;
+       warn1("fixing wrong type inferred for %.65s", np->fvarname);
+       np->vinftype = 0;
+       c = letter(np->fvarname[0]);
+       if ((np->vtype = impltype[c]) == TYCHAR
+       && (k = implleng[c]))
+               np->vleng = ICON(k);
+       }
+
+/* fix up types in expression; replace subtrees and convert
+   names to address blocks */
+
+expptr fixtype(p)
+register tagptr p;
+{
+
+       if(p == 0)
+               return(0);
+
+       switch(p->tag)
+       {
+       case TCONST:
+               if(ONEOF(p->constblock.vtype,MSKINT|MSKLOGICAL|MSKADDR|
+                   MSKREAL) )
+                       return( (expptr) p);
+
+               return( (expptr) putconst((Constp)p) );
+
+       case TADDR:
+               p->addrblock.memoffset = fixtype(p->addrblock.memoffset);
+               return( (expptr) p);
+
+       case TERROR:
+               return( (expptr) p);
+
+       default:
+               badtag("fixtype", p->tag);
+
+/* This case means that   fixexpr   can't call   fixtype   with any expr,
+   only a subexpr of its parameter. */
+
+       case TEXPR:
+               return( fixexpr((Exprp)p) );
+
+       case TLIST:
+               return( (expptr) p );
+
+       case TPRIM:
+               if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR)
+               {
+                       if(p->primblock.namep->vtype == TYSUBR)
+                       {
+                               err("function invocation of subroutine");
+                               return( errnode() );
+                       }
+                       else {
+                               if (p->primblock.namep->vinftype)
+                                       wronginf(p->primblock.namep);
+                               return( mkfunct(p) );
+                               }
+               }
+
+/* The lack of args makes   p   a function name, substring reference
+   or variable name. */
+
+               else    return mklhs((struct Primblock *) p, keepsubs);
+       }
+}
+
+
+ int
+badchleng(p) register expptr p;
+{
+       if (!p->headblock.vleng) {
+               if (p->headblock.tag == TADDR
+               && p->addrblock.uname_tag == UNAM_NAME)
+                       errstr("bad use of character*(*) variable %.60s",
+                               p->addrblock.user.name->fvarname);
+               else
+                       err("Bad use of character*(*)");
+               return 1;
+               }
+       return 0;
+       }
+
+
+ static expptr
+cplenexpr(p)
+ expptr p;
+{
+       expptr rv;
+
+       if (badchleng(p))
+               return ICON(1);
+       rv = cpexpr(p->headblock.vleng);
+       if (ISCONST(p) && p->constblock.vtype == TYCHAR)
+               rv->constblock.Const.ci += p->constblock.Const.ccp1.blanks;
+       return rv;
+       }
+
+
+/* special case tree transformations and cleanups of expression trees.
+   Parameter   p   should have a TEXPR tag at its root, else an error is
+   returned */
+
+expptr fixexpr(p)
+register Exprp p;
+{
+       expptr lp;
+       register expptr rp;
+       register expptr q;
+       int opcode, ltype, rtype, ptype, mtype;
+
+       if( ISERROR(p) )
+               return( (expptr) p );
+       else if(p->tag != TEXPR)
+               badtag("fixexpr", p->tag);
+       opcode = p->opcode;
+
+/* First set the types of the left and right subexpressions */
+
+       lp = p->leftp;
+       if (!ISCONST(lp) || lp->constblock.vtype != TYCHAR)
+               lp = p->leftp = fixtype(lp);
+       ltype = lp->headblock.vtype;
+
+       if(opcode==OPASSIGN && lp->tag!=TADDR)
+       {
+               err("left side of assignment must be variable");
+               frexpr((expptr)p);
+               return( errnode() );
+       }
+
+       if(rp = p->rightp)
+       {
+               if (!ISCONST(rp) || rp->constblock.vtype != TYCHAR)
+                       rp = p->rightp = fixtype(rp);
+               rtype = rp->headblock.vtype;
+       }
+       else
+               rtype = 0;
+
+       if(ltype==TYERROR || rtype==TYERROR)
+       {
+               frexpr((expptr)p);
+               return( errnode() );
+       }
+
+/* Now work on the whole expression */
+
+       /* force folding if possible */
+
+       if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
+       {
+               q = opcode == OPCONV && lp->constblock.vtype == p->vtype
+                       ? lp : mkexpr(opcode, lp, rp);
+
+/* mkexpr is expected to reduce constant expressions */
+
+               if( ISCONST(q) ) {
+                       p->leftp = p->rightp = 0;
+                       frexpr((expptr)p);
+                       return(q);
+                       }
+               free( (charptr) q );    /* constants did not fold */
+       }
+
+       if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
+       {
+               frexpr((expptr)p);
+               return( errnode() );
+       }
+
+       if (ltype == TYCHAR && ISCONST(lp))
+               p->leftp =  lp = (expptr)putconst((Constp)lp);
+       if (rtype == TYCHAR && ISCONST(rp))
+               p->rightp = rp = (expptr)putconst((Constp)rp);
+
+       switch(opcode)
+       {
+       case OPCONCAT:
+               if(p->vleng == NULL)
+                       p->vleng = mkexpr(OPPLUS, cplenexpr(lp),
+                                       cplenexpr(rp) );
+               break;
+
+       case OPASSIGN:
+               if (rtype == TYREAL || ISLOGICAL(ptype))
+                       break;
+       case OPPLUSEQ:
+       case OPSTAREQ:
+               if(ltype == rtype)
+                       break;
+               if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
+                       break;
+               if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
+                       break;
+               if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
+                   && typesize[ltype]>=typesize[rtype] )
+                           break;
+
+/* Cast the right hand side to match the type of the expression */
+
+               p->rightp = fixtype( mkconv(ptype, rp) );
+               break;
+
+       case OPSLASH:
+               if( ISCOMPLEX(rtype) )
+               {
+                       p = (Exprp) call2(ptype,
+
+/* Handle double precision complex variables */
+
+                           ptype == TYCOMPLEX ? "c_div" : "z_div",
+                           mkconv(ptype, lp), mkconv(ptype, rp) );
+                       break;
+               }
+       case OPPLUS:
+       case OPMINUS:
+       case OPSTAR:
+       case OPMOD:
+               if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
+                   (rtype==TYREAL && ! ISCONST(rp) ) ))
+                       break;
+               if( ISCOMPLEX(ptype) )
+                       break;
+
+/* Cast both sides of the expression to match the type of the whole
+   expression.  */
+
+               if(ltype != ptype && (ltype < TYINT1 || ptype > TYDREAL))
+                       p->leftp = fixtype(mkconv(ptype,lp));
+               if(rtype != ptype && (rtype < TYINT1 || ptype > TYDREAL))
+                       p->rightp = fixtype(mkconv(ptype,rp));
+               break;
+
+       case OPPOWER:
+               return( mkpower((expptr)p) );
+
+       case OPLT:
+       case OPLE:
+       case OPGT:
+       case OPGE:
+       case OPEQ:
+       case OPNE:
+               if(ltype == rtype)
+                       break;
+               if (htype) {
+                       if (ltype == TYCHAR) {
+                               p->leftp = fixtype(mkconv(rtype,lp));
+                               break;
+                               }
+                       if (rtype == TYCHAR) {
+                               p->rightp = fixtype(mkconv(ltype,rp));
+                               break;
+                               }
+                       }
+               mtype = cktype(OPMINUS, ltype, rtype);
+               if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) ||
+                   (rtype==TYREAL && ! ISCONST(rp)) ))
+                       break;
+               if( ISCOMPLEX(mtype) )
+                       break;
+               if(ltype != mtype)
+                       p->leftp = fixtype(mkconv(mtype,lp));
+               if(rtype != mtype)
+                       p->rightp = fixtype(mkconv(mtype,rp));
+               break;
+
+       case OPCONV:
+               ptype = cktype(OPCONV, p->vtype, ltype);
+               if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA
+                && !ISCOMPLEX(ptype))
+               {
+                       lp->exprblock.rightp =
+                           fixtype( mkconv(ptype, lp->exprblock.rightp) );
+                       free( (charptr) p );
+                       p = (Exprp) lp;
+               }
+               break;
+
+       case OPADDR:
+               if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR)
+                       Fatal("addr of addr");
+               break;
+
+       case OPCOMMA:
+       case OPQUEST:
+       case OPCOLON:
+               break;
+
+       case OPMIN:
+       case OPMAX:
+       case OPMIN2:
+       case OPMAX2:
+       case OPDMIN:
+       case OPDMAX:
+       case OPABS:
+       case OPDABS:
+               ptype = p->vtype;
+               break;
+
+       default:
+               break;
+       }
+
+       p->vtype = ptype;
+       return((expptr) p);
+}
+
+
+/* fix an argument list, taking due care for special first level cases */
+
+fixargs(doput, p0)
+int doput;     /* doput is true if constants need to be passed by reference */
+struct Listblock *p0;
+{
+       register chainp p;
+       register tagptr q, t;
+       register int qtag;
+       int nargs;
+       Addrp mkscalar();
+
+       nargs = 0;
+       if(p0)
+               for(p = p0->listp ; p ; p = p->nextp)
+               {
+                       ++nargs;
+                       q = (tagptr)p->datap;
+                       qtag = q->tag;
+                       if(qtag == TCONST)
+                       {
+
+/* Call putconst() to store values in a constant table.  Since even
+   constants must be passed by reference, this can optimize on the storage
+   required */
+
+                               p->datap = doput ? (char *)putconst((Constp)q)
+                                                : (char *)q;
+                       }
+
+/* Take a function name and turn it into an Addr.  This only happens when
+   nothing else has figured out the function beforehand */
+
+                       else if(qtag==TPRIM && q->primblock.argsp==0 &&
+                           q->primblock.namep->vclass==CLPROC &&
+                           q->primblock.namep->vprocclass != PTHISPROC)
+                               p->datap = (char *)mkaddr(q->primblock.namep);
+
+                       else if(qtag==TPRIM && q->primblock.argsp==0 &&
+                           q->primblock.namep->vdim!=NULL)
+                               p->datap = (char *)mkscalar(q->primblock.namep);
+
+                       else if(qtag==TPRIM && q->primblock.argsp==0 &&
+                           q->primblock.namep->vdovar &&
+                           (t = (tagptr) memversion(q->primblock.namep)) )
+                               p->datap = (char *)fixtype(t);
+                       else
+                               p->datap = (char *)fixtype(q);
+               }
+       return(nargs);
+}
+
+
+
+/* mkscalar -- only called by   fixargs   above, and by some routines in
+   io.c */
+
+Addrp mkscalar(np)
+register Namep np;
+{
+       register Addrp ap;
+
+       vardcl(np);
+       ap = mkaddr(np);
+
+       /* The prolog causes array arguments to point to the
+        * (0,...,0) element, unless subscript checking is on.
+        */
+       if( !checksubs && np->vstg==STGARG)
+       {
+               register struct Dimblock *dp;
+               dp = np->vdim;
+               frexpr(ap->memoffset);
+               ap->memoffset = mkexpr(OPSTAR,
+                   (np->vtype==TYCHAR ?
+                   cpexpr(np->vleng) :
+                   (tagptr)ICON(typesize[np->vtype]) ),
+                   cpexpr(dp->baseoffset) );
+       }
+       return(ap);
+}
+
+
+ static void
+adjust_arginfo(np)     /* adjust arginfo to omit the length arg for the
+                          arg that we now know to be a character-valued
+                          function */
+ register Namep np;
+{
+       struct Entrypoint *ep;
+       register chainp args;
+       Argtypes *at;
+
+       for(ep = entries; ep; ep = ep->entnextp)
+               for(args = ep->arglist; args; args = args->nextp)
+                       if (np == (Namep)args->datap
+                       && (at = ep->entryname->arginfo))
+                               --at->nargs;
+       }
+
+
+
+expptr mkfunct(p0)
+ expptr p0;
+{
+       register struct Primblock *p = (struct Primblock *)p0;
+       struct Entrypoint *ep;
+       Addrp ap;
+       Extsym *extp;
+       register Namep np;
+       register expptr q;
+       expptr intrcall();
+       extern chainp new_procs;
+       int k, nargs;
+       int class;
+
+       if(p->tag != TPRIM)
+               return( errnode() );
+
+       np = p->namep;
+       class = np->vclass;
+
+
+       if(class == CLUNKNOWN)
+       {
+               np->vclass = class = CLPROC;
+               if(np->vstg == STGUNKNOWN)
+               {
+                       if(np->vtype!=TYSUBR && (k = intrfunct(np->fvarname))
+                               && (zflag || !(*(struct Intrpacked *)&k).f4
+                                       || dcomplex_seen))
+                       {
+                               np->vstg = STGINTR;
+                               np->vardesc.varno = k;
+                               np->vprocclass = PINTRINSIC;
+                       }
+                       else
+                       {
+                               extp = mkext(np->fvarname,
+                                       addunder(np->cvarname));
+                               extp->extstg = STGEXT;
+                               np->vstg = STGEXT;
+                               np->vardesc.varno = extp - extsymtab;
+                               np->vprocclass = PEXTERNAL;
+                       }
+               }
+               else if(np->vstg==STGARG)
+               {
+                   if(np->vtype == TYCHAR) {
+                       adjust_arginfo(np);
+                       if (np->vpassed) {
+                               char wbuf[160], *who;
+                               who = np->fvarname;
+                               sprintf(wbuf, "%s%s%s\n\t%s%s%s",
+                                       "Character-valued dummy procedure ",
+                                       who, " not declared EXTERNAL.",
+                       "Code may be wrong for previous function calls having ",
+                                       who, " as a parameter.");
+                               warn(wbuf);
+                               }
+                       }
+                   np->vprocclass = PEXTERNAL;
+               }
+       }
+
+       if(class != CLPROC) {
+               if (np->vstg == STGCOMMON)
+                       fatalstr(
+                        "Cannot invoke common variable %.50s as a function.",
+                               np->fvarname);
+               fatali("invalid class code %d for function", class);
+               }
+
+/* F77 doesn't allow subscripting of function calls */
+
+       if(p->fcharp || p->lcharp)
+       {
+               err("no substring of function call");
+               goto error;
+       }
+       impldcl(np);
+       np->vimpltype = 0;      /* invoking as function ==> inferred type */
+       np->vcalled = 1;
+       nargs = fixargs( np->vprocclass!=PINTRINSIC,  p->argsp);
+
+       switch(np->vprocclass)
+       {
+       case PEXTERNAL:
+               if(np->vtype == TYUNKNOWN)
+               {
+                       dclerr("attempt to use untyped function", np);
+                       np->vtype = dflttype[letter(np->fvarname[0])];
+               }
+               ap = mkaddr(np);
+               if (!extsymtab[np->vardesc.varno].extseen) {
+                       new_procs = mkchain((char *)np, new_procs);
+                       extsymtab[np->vardesc.varno].extseen = 1;
+                       }
+call:
+               q = mkexpr(OPCALL, (expptr)ap, (expptr)p->argsp);
+               q->exprblock.vtype = np->vtype;
+               if(np->vleng)
+                       q->exprblock.vleng = (expptr) cpexpr(np->vleng);
+               break;
+
+       case PINTRINSIC:
+               q = intrcall(np, p->argsp, nargs);
+               break;
+
+       case PSTFUNCT:
+               q = stfcall(np, p->argsp);
+               break;
+
+       case PTHISPROC:
+               warn("recursive call");
+
+/* entries   is the list of multiple entry points */
+
+               for(ep = entries ; ep ; ep = ep->entnextp)
+                       if(ep->enamep == np)
+                               break;
+               if(ep == NULL)
+                       Fatal("mkfunct: impossible recursion");
+
+               ap = builtin(np->vtype, ep->entryname->cextname, -2);
+               /* the negative last arg prevents adding */
+               /* this name to the list of used builtins */
+               goto call;
+
+       default:
+               fatali("mkfunct: impossible vprocclass %d",
+                   (int) (np->vprocclass) );
+       }
+       free( (charptr) p );
+       return(q);
+
+error:
+       frexpr((expptr)p);
+       return( errnode() );
+}
+
+
+
+LOCAL expptr stfcall(np, actlist)
+Namep np;
+struct Listblock *actlist;
+{
+       register chainp actuals;
+       int nargs;
+       chainp oactp, formals;
+       int type;
+       expptr Ln, Lq, q, q1, rhs, ap;
+       Namep tnp;
+       register struct Rplblock *rp;
+       struct Rplblock *tlist;
+       static int inv_count;
+
+       if (++inv_count > stfcall_MAX)
+               Fatal("Loop invoking recursive statement function?");
+       if(actlist)
+       {
+               actuals = actlist->listp;
+               free( (charptr) actlist);
+       }
+       else
+               actuals = NULL;
+       oactp = actuals;
+
+       nargs = 0;
+       tlist = NULL;
+       if( (type = np->vtype) == TYUNKNOWN)
+       {
+               dclerr("attempt to use untyped statement function", np);
+               type = np->vtype = dflttype[letter(np->fvarname[0])];
+       }
+       formals = (chainp) np->varxptr.vstfdesc->datap;
+       rhs = (expptr) (np->varxptr.vstfdesc->nextp);
+
+       /* copy actual arguments into temporaries */
+       while(actuals!=NULL && formals!=NULL)
+       {
+               rp = ALLOC(Rplblock);
+               rp->rplnp = tnp = (Namep) formals->datap;
+               ap = fixtype((tagptr)actuals->datap);
+               if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR
+                   && (ap->tag==TCONST || ap->tag==TADDR) )
+               {
+
+/* If actuals are constants or variable names, no temporaries are required */
+                       rp->rplvp = (expptr) ap;
+                       rp->rplxp = NULL;
+                       rp->rpltag = ap->tag;
+               }
+               else    {
+                       rp->rplvp = (expptr) mktmp(tnp->vtype, tnp->vleng);
+                       rp -> rplxp = NULL;
+                       putexpr ( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap));
+                       if((rp->rpltag = rp->rplvp->tag) == TERROR)
+                               err("disagreement of argument types in statement function call");
+               }
+               rp->rplnextp = tlist;
+               tlist = rp;
+               actuals = actuals->nextp;
+               formals = formals->nextp;
+               ++nargs;
+       }
+
+       if(actuals!=NULL || formals!=NULL)
+               err("statement function definition and argument list differ");
+
+       /*
+   now push down names involved in formal argument list, then
+   evaluate rhs of statement function definition in this environment
+*/
+
+       if(tlist)       /* put tlist in front of the rpllist */
+       {
+               for(rp = tlist; rp->rplnextp; rp = rp->rplnextp)
+                       ;
+               rp->rplnextp = rpllist;
+               rpllist = tlist;
+       }
+
+/* So when the expression finally gets evaled, that evaluator must read
+   from the globl   rpllist   14-jun-88 mwm */
+
+       q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) );
+
+       /* get length right of character-valued statement functions... */
+       if (type == TYCHAR
+        && (Ln = np->vleng)
+        && q->tag != TERROR
+        && (Lq = q->exprblock.vleng)
+        && (Lq->tag != TCONST
+               || Ln->constblock.Const.ci != Lq->constblock.Const.ci)) {
+               q1 = (expptr) mktmp(type, Ln);
+               putexpr ( mkexpr(OPASSIGN, cpexpr(q1), q));
+               q = q1;
+               }
+
+       /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
+       while(--nargs >= 0)
+       {
+               if(rpllist->rplxp)
+                       q = mkexpr(OPCOMMA, rpllist->rplxp, q);
+               rp = rpllist->rplnextp;
+               frexpr(rpllist->rplvp);
+               free((char *)rpllist);
+               rpllist = rp;
+       }
+       frchain( &oactp );
+       --inv_count;
+       return(q);
+}
+
+
+static int replaced;
+
+/* mkplace -- Figure out the proper storage class for the input name and
+   return an addrp with the appropriate stuff */
+
+Addrp mkplace(np)
+register Namep np;
+{
+       register Addrp s;
+       register struct Rplblock *rp;
+       int regn;
+
+       /* is name on the replace list? */
+
+       for(rp = rpllist ; rp ; rp = rp->rplnextp)
+       {
+               if(np == rp->rplnp)
+               {
+                       replaced = 1;
+                       if(rp->rpltag == TNAME)
+                       {
+                               np = (Namep) (rp->rplvp);
+                               break;
+                       }
+                       else    return( (Addrp) cpexpr(rp->rplvp) );
+               }
+       }
+
+       /* is variable a DO index in a register ? */
+
+       if(np->vdovar && ( (regn = inregister(np)) >= 0) )
+               if(np->vtype == TYERROR)
+                       return((Addrp) errnode() );
+               else
+               {
+                       s = ALLOC(Addrblock);
+                       s->tag = TADDR;
+                       s->vstg = STGREG;
+                       s->vtype = TYIREG;
+                       s->memno = regn;
+                       s->memoffset = ICON(0);
+                       s -> uname_tag = UNAM_NAME;
+                       s -> user.name = np;
+                       return(s);
+               }
+
+       if (np->vclass == CLPROC && np->vprocclass != PTHISPROC)
+               errstr("external %.60s used as a variable", np->fvarname);
+       vardcl(np);
+       return(mkaddr(np));
+}
+
+ static expptr
+subskept(p,a)
+struct Primblock *p;
+Addrp a;
+{
+       expptr ep;
+       struct Listblock *Lb;
+       chainp cp;
+
+       if (a->uname_tag != UNAM_NAME)
+               erri("subskept: uname_tag %d", a->uname_tag);
+       a->user.name->vrefused = 1;
+       a->user.name->visused = 1;
+       a->uname_tag = UNAM_REF;
+       Lb = (struct Listblock *)cpexpr((tagptr)p->argsp);
+       for(cp = Lb->listp; cp; cp = cp->nextp)
+               cp->datap = (char *)putx(fixtype((tagptr)cp->datap));
+       if (a->vtype == TYCHAR) {
+               ep = p->fcharp  ? mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1))
+                               : ICON(0);
+               Lb->listp = mkchain((char *)ep, Lb->listp);
+               }
+       return (expptr)Lb;
+       }
+
+ static int doing_vleng;
+
+/* mklhs -- Compute the actual address of the given expression; account
+   for array subscripts, stack offset, and substring offsets.  The f -> C
+   translator will need this only to worry about the subscript stuff */
+
+expptr mklhs(p, subkeep)
+register struct Primblock *p; int subkeep;
+{
+       expptr suboffset();
+       register Addrp s;
+       Namep np;
+
+       if(p->tag != TPRIM)
+               return( (expptr) p );
+       np = p->namep;
+
+       replaced = 0;
+       s = mkplace(np);
+       if(s->tag!=TADDR || s->vstg==STGREG)
+       {
+               free( (charptr) p );
+               return( (expptr) s );
+       }
+       s->parenused = p->parenused;
+
+       /* compute the address modified by subscripts */
+
+       if (!replaced)
+               s->memoffset = (subkeep && np->vdim
+                               && (np->vdim->ndim > 1 || np->vtype == TYCHAR
+                               && (!ISCONST(np->vleng)
+                                 || np->vleng->constblock.Const.ci != 1)))
+                               ? subskept(p,s)
+                               : mkexpr(OPPLUS, s->memoffset, suboffset(p) );
+       frexpr((expptr)p->argsp);
+       p->argsp = NULL;
+
+       /* now do substring part */
+
+       if(p->fcharp || p->lcharp)
+       {
+               if(np->vtype != TYCHAR)
+                       errstr("substring of noncharacter %s", np->fvarname);
+               else    {
+                       if(p->lcharp == NULL)
+                               p->lcharp = (expptr) cpexpr(s->vleng);
+                       if(p->fcharp) {
+                               doing_vleng = 1;
+                               s->vleng = fixtype(mkexpr(OPMINUS,
+                                               p->lcharp,
+                                       mkexpr(OPMINUS, p->fcharp, ICON(1) )));
+                               doing_vleng = 0;
+                               }
+                       else    {
+                               frexpr(s->vleng);
+                               s->vleng = p->lcharp;
+                       }
+               }
+       }
+
+       s->vleng = fixtype( s->vleng );
+       s->memoffset = fixtype( s->memoffset );
+       free( (charptr) p );
+       return( (expptr) s );
+}
+
+
+
+
+
+/* deregister -- remove a register allocation from the list; assumes that
+   names are deregistered in stack order (LIFO order - Last In First Out) */
+
+deregister(np)
+Namep np;
+{
+       if(nregvar>0 && regnamep[nregvar-1]==np)
+       {
+               --nregvar;
+       }
+}
+
+
+
+
+/* memversion -- moves a DO index REGISTER into a memory location; other
+   objects are passed through untouched */
+
+Addrp memversion(np)
+register Namep np;
+{
+       register Addrp s;
+
+       if(np->vdovar==NO || (inregister(np)<0) )
+               return(NULL);
+       np->vdovar = NO;
+       s = mkplace(np);
+       np->vdovar = YES;
+       return(s);
+}
+
+
+
+/* inregister -- looks for the input name in the global list   regnamep */
+
+inregister(np)
+register Namep np;
+{
+       register int i;
+
+       for(i = 0 ; i < nregvar ; ++i)
+               if(regnamep[i] == np)
+                       return( regnum[i] );
+       return(-1);
+}
+
+
+
+/* suboffset -- Compute the offset from the start of the array, given the
+   subscripts as arguments */
+
+expptr suboffset(p)
+register struct Primblock *p;
+{
+       int n;
+       expptr si, size;
+       chainp cp;
+       expptr e, e1, offp, prod;
+       expptr subcheck();
+       struct Dimblock *dimp;
+       expptr sub[MAXDIM+1];
+       register Namep np;
+
+       np = p->namep;
+       offp = ICON(0);
+       n = 0;
+       if(p->argsp)
+               for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
+               {
+                       si = fixtype(cpexpr((tagptr)cp->datap));
+                       if (!ISINT(si->headblock.vtype)) {
+                               NOEXT("non-integer subscript");
+                               si = mkconv(TYLONG, si);
+                               }
+                       sub[n++] = si;
+                       if(n > maxdim)
+                       {
+                               erri("more than %d subscripts", maxdim);
+                               break;
+                       }
+               }
+
+       dimp = np->vdim;
+       if(n>0 && dimp==NULL)
+               errstr("subscripts on scalar variable %.68s", np->fvarname);
+       else if(dimp && dimp->ndim!=n)
+               errstr("wrong number of subscripts on %.68s", np->fvarname);
+       else if(n > 0)
+       {
+               prod = sub[--n];
+               while( --n >= 0)
+                       prod = mkexpr(OPPLUS, sub[n],
+                           mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
+               if(checksubs || np->vstg!=STGARG)
+                       prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
+
+/* Add in the run-time bounds check */
+
+               if(checksubs)
+                       prod = subcheck(np, prod);
+               size = np->vtype == TYCHAR ?
+                   (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]);
+               prod = mkexpr(OPSTAR, prod, size);
+               offp = mkexpr(OPPLUS, offp, prod);
+       }
+
+/* Check for substring indicator */
+
+       if(p->fcharp && np->vtype==TYCHAR) {
+               e = p->fcharp;
+               e1 = mkexpr(OPMINUS, cpexpr(e), ICON(1));
+               if (!ISCONST(e) && (e->tag != TPRIM || e->primblock.argsp)) {
+                       e = (expptr)mktmp(TYLONG, ENULL);
+                       putout(putassign(cpexpr(e), e1));
+                       p->fcharp = mkexpr(OPPLUS, cpexpr(e), ICON(1));
+                       e1 = e;
+                       }
+               offp = mkexpr(OPPLUS, offp, e1);
+               }
+       return(offp);
+}
+
+
+
+
+expptr subcheck(np, p)
+Namep np;
+register expptr p;
+{
+       struct Dimblock *dimp;
+       expptr t, checkvar, checkcond, badcall;
+
+       dimp = np->vdim;
+       if(dimp->nelt == NULL)
+               return(p);      /* don't check arrays with * bounds */
+       np->vlastdim = 0;
+       if( ISICON(p) )
+       {
+
+/* check for negative (constant) offset */
+
+               if(p->constblock.Const.ci < 0)
+                       goto badsub;
+               if( ISICON(dimp->nelt) )
+
+/* see if constant offset exceeds the array declaration */
+
+                       if(p->constblock.Const.ci < dimp->nelt->constblock.Const.ci)
+                               return(p);
+                       else
+                               goto badsub;
+       }
+
+/* We know that the subscript offset   p   or   dimp -> nelt   is not a constant.
+   Now find a register to use for run-time bounds checking */
+
+       if(p->tag==TADDR && p->addrblock.vstg==STGREG)
+       {
+               checkvar = (expptr) cpexpr(p);
+               t = p;
+       }
+       else    {
+               checkvar = (expptr) mktmp(p->headblock.vtype, ENULL);
+               t = mkexpr(OPASSIGN, cpexpr(checkvar), p);
+       }
+       checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) );
+       if( ! ISICON(p) )
+               checkcond = mkexpr(OPAND, checkcond,
+                   mkexpr(OPLE, ICON(0), cpexpr(checkvar)) );
+
+/* Construct the actual test */
+
+       badcall = call4(p->headblock.vtype, "s_rnge",
+           mkstrcon(strlen(np->fvarname), np->fvarname),
+           mkconv(TYLONG,  cpexpr(checkvar)),
+           mkstrcon(strlen(procname), procname),
+           ICON(lineno) );
+       badcall->exprblock.opcode = OPCCALL;
+       p = mkexpr(OPQUEST, checkcond,
+           mkexpr(OPCOLON, checkvar, badcall));
+
+       return(p);
+
+badsub:
+       frexpr(p);
+       errstr("subscript on variable %s out of range", np->fvarname);
+       return ( ICON(0) );
+}
+
+
+
+
+Addrp mkaddr(p)
+register Namep p;
+{
+       Extsym *extp;
+       register Addrp t;
+       Addrp intraddr();
+       int k;
+
+       switch( p->vstg)
+       {
+       case STGAUTO:
+               if(p->vclass == CLPROC && p->vprocclass == PTHISPROC)
+                       return (Addrp) cpexpr((expptr)xretslot[p->vtype]);
+               goto other;
+
+       case STGUNKNOWN:
+               if(p->vclass != CLPROC)
+                       break;  /* Error */
+               extp = mkext(p->fvarname, addunder(p->cvarname));
+               extp->extstg = STGEXT;
+               p->vstg = STGEXT;
+               p->vardesc.varno = extp - extsymtab;
+               p->vprocclass = PEXTERNAL;
+               if ((extp->exproto || infertypes)
+               && (p->vtype == TYUNKNOWN || p->vimpltype)
+               && (k = extp->extype))
+                       inferdcl(p, k);
+
+
+       case STGCOMMON:
+       case STGEXT:
+       case STGBSS:
+       case STGINIT:
+       case STGEQUIV:
+       case STGARG:
+       case STGLENG:
+ other:
+               t = ALLOC(Addrblock);
+               t->tag = TADDR;
+
+               t->vclass = p->vclass;
+               t->vtype = p->vtype;
+               t->vstg = p->vstg;
+               t->memno = p->vardesc.varno;
+               t->memoffset = ICON(p->voffset);
+               if (p->vdim)
+                   t->isarray = 1;
+               if(p->vleng)
+               {
+                       t->vleng = (expptr) cpexpr(p->vleng);
+                       if( ISICON(t->vleng) )
+                               t->varleng = t->vleng->constblock.Const.ci;
+               }
+
+/* Keep the original name around for the C code generation */
+
+               t -> uname_tag = UNAM_NAME;
+               t -> user.name = p;
+               return(t);
+
+       case STGINTR:
+
+               return ( intraddr (p));
+       }
+       badstg("mkaddr", p->vstg);
+       /* NOT REACHED */ return 0;
+}
+
+
+
+
+/* mkarg -- create storage for a new parameter.  This is called when a
+   function returns a string (for the return value, which is the first
+   parameter), or when a variable-length string is passed to a function. */
+
+Addrp mkarg(type, argno)
+int type, argno;
+{
+       register Addrp p;
+
+       p = ALLOC(Addrblock);
+       p->tag = TADDR;
+       p->vtype = type;
+       p->vclass = CLVAR;
+
+/* TYLENG is the type of the field holding the length of a character string */
+
+       p->vstg = (type==TYLENG ? STGLENG : STGARG);
+       p->memno = argno;
+       return(p);
+}
+
+
+
+
+/* mkprim -- Create a PRIM (primary/primitive) block consisting of a
+   Nameblock (or Paramblock), arguments (actual params or array
+   subscripts) and substring bounds.  Requires that   v   have lots of
+   extra (uninitialized) storage, since it could be a paramblock or
+   nameblock */
+
+expptr mkprim(v0, args, substr)
+ Namep v0;
+ struct Listblock *args;
+ chainp substr;
+{
+       typedef union {
+               struct Paramblock paramblock;
+               struct Nameblock nameblock;
+               struct Headblock headblock;
+               } *Primu;
+       register Primu v = (Primu)v0;
+       register struct Primblock *p;
+
+       if(v->headblock.vclass == CLPARAM)
+       {
+
+/* v   is to be a Paramblock */
+
+               if(args || substr)
+               {
+                       errstr("no qualifiers on parameter name %s",
+                           v->paramblock.fvarname);
+                       frexpr((expptr)args);
+                       if(substr)
+                       {
+                               frexpr((tagptr)substr->datap);
+                               frexpr((tagptr)substr->nextp->datap);
+                               frchain(&substr);
+                       }
+                       frexpr((expptr)v);
+                       return( errnode() );
+               }
+               return( (expptr) cpexpr(v->paramblock.paramval) );
+       }
+
+       p = ALLOC(Primblock);
+       p->tag = TPRIM;
+       p->vtype = v->nameblock.vtype;
+
+/* v   is to be a Nameblock */
+
+       p->namep = (Namep) v;
+       p->argsp = args;
+       if(substr)
+       {
+               p->fcharp = (expptr) substr->datap;
+               p->lcharp = (expptr) substr->nextp->datap;
+               frchain(&substr);
+       }
+       return( (expptr) p);
+}
+
+
+
+/* vardcl -- attempt to fill out the Name template for variable   v.
+   This function is called on identifiers known to be variables or
+   recursive references to the same function */
+
+vardcl(v)
+register Namep v;
+{
+       struct Dimblock *t;
+       expptr neltp;
+       extern int doing_stmtfcn;
+
+       if(v->vclass == CLUNKNOWN) {
+               v->vclass = CLVAR;
+               if (v->vinftype) {
+                       v->vtype = TYUNKNOWN;
+                       if (v->vdcldone) {
+                               v->vdcldone = 0;
+                               impldcl(v);
+                               }
+                       }
+               }
+       if(v->vdcldone)
+               return;
+       if(v->vclass == CLNAMELIST)
+               return;
+
+       if(v->vtype == TYUNKNOWN)
+               impldcl(v);
+       else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC)
+       {
+               dclerr("used as variable", v);
+               return;
+       }
+       if(v->vstg==STGUNKNOWN) {
+               if (doing_stmtfcn) {
+                       /* neither declare this variable if its only use */
+                       /* is in defining a stmt function, nor complain  */
+                       /* that it is never used */
+                       v->vimpldovar = 1;
+                       return;
+                       }
+               v->vstg = implstg[ letter(v->fvarname[0]) ];
+               v->vimplstg = 1;
+               }
+
+/* Compute the actual storage location, i.e. offsets from base addresses,
+   possibly the stack pointer */
+
+       switch(v->vstg)
+       {
+       case STGBSS:
+               v->vardesc.varno = ++lastvarno;
+               break;
+       case STGAUTO:
+               if(v->vclass==CLPROC && v->vprocclass==PTHISPROC)
+                       break;
+               if(t = v->vdim)
+                       if( (neltp = t->nelt) && ISCONST(neltp) ) ;
+                       else
+                               dclerr("adjustable automatic array", v);
+               break;
+
+       default:
+               break;
+       }
+       v->vdcldone = YES;
+}
+
+
+
+/* Set the implicit type declaration of parameter   p   based on its first
+   letter */
+
+impldcl(p)
+register Namep p;
+{
+       register int k;
+       int type;
+       ftnint leng;
+
+       if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) )
+               return;
+       if(p->vtype == TYUNKNOWN)
+       {
+               k = letter(p->fvarname[0]);
+               type = impltype[ k ];
+               leng = implleng[ k ];
+               if(type == TYUNKNOWN)
+               {
+                       if(p->vclass == CLPROC)
+                               return;
+                       dclerr("attempt to use undefined variable", p);
+                       type = dflttype[k];
+                       leng = 0;
+               }
+               settype(p, type, leng);
+               p->vimpltype = 1;
+       }
+}
+
+ void
+inferdcl(np,type)
+ Namep np;
+ int type;
+{
+       int k = impltype[letter(np->fvarname[0])];
+       if (k != type) {
+               np->vinftype = 1;
+               np->vtype = type;
+               frexpr(np->vleng);
+               np->vleng = 0;
+               }
+       np->vimpltype = 0;
+       np->vinfproc = 1;
+       }
+
+
+#define ICONEQ(z, c)  (ISICON(z) && z->constblock.Const.ci==c)
+#define COMMUTE        { e = lp;  lp = rp;  rp = e; }
+
+
+
+/* mkexpr -- Make expression, and simplify constant subcomponents (tree
+   order is not preserved).  Assumes that   lp   is nonempty, and uses
+   fold()   to simplify adjacent constants */
+
+expptr mkexpr(opcode, lp, rp)
+int opcode;
+register expptr lp, rp;
+{
+       register expptr e, e1;
+       int etype;
+       int ltype, rtype;
+       int ltag, rtag;
+       long L;
+
+       ltype = lp->headblock.vtype;
+       ltag = lp->tag;
+       if(rp && opcode!=OPCALL && opcode!=OPCCALL)
+       {
+               rtype = rp->headblock.vtype;
+               rtag = rp->tag;
+       }
+       else rtype = 0;
+
+       etype = cktype(opcode, ltype, rtype);
+       if(etype == TYERROR)
+               goto error;
+
+       switch(opcode)
+       {
+               /* check for multiplication by 0 and 1 and addition to 0 */
+
+       case OPSTAR:
+               if( ISCONST(lp) )
+                       COMMUTE
+
+                           if( ISICON(rp) )
+                       {
+                               if(rp->constblock.Const.ci == 0)
+                                       goto retright;
+                               goto mulop;
+                       }
+               break;
+
+       case OPSLASH:
+       case OPMOD:
+               if( ICONEQ(rp, 0) )
+               {
+                       err("attempted division by zero");
+                       rp = ICON(1);
+                       break;
+               }
+               if(opcode == OPMOD)
+                       break;
+
+/* Handle multiplying or dividing by 1, -1 */
+
+mulop:
+               if( ISICON(rp) )
+               {
+                       if(rp->constblock.Const.ci == 1)
+                               goto retleft;
+
+                       if(rp->constblock.Const.ci == -1)
+                       {
+                               frexpr(rp);
+                               return( mkexpr(OPNEG, lp, ENULL) );
+                       }
+               }
+
+/* Group all constants together.  In particular,
+
+       (x * CONST1) * CONST2 ==> x * (CONST1 * CONST2)
+       (x * CONST1) / CONST2 ==> x * (CONST1 / CONST2)
+*/
+
+               if (lp->tag != TEXPR || !lp->exprblock.rightp
+                               || !ISICON(lp->exprblock.rightp))
+                       break;
+
+               if (lp->exprblock.opcode == OPLSHIFT) {
+                       L = 1 << lp->exprblock.rightp->constblock.Const.ci;
+                       if (opcode == OPSTAR || ISICON(rp) &&
+                                       !(L % rp->constblock.Const.ci)) {
+                               lp->exprblock.opcode = OPSTAR;
+                               lp->exprblock.rightp->constblock.Const.ci = L;
+                               }
+                       }
+
+               if (lp->exprblock.opcode == OPSTAR) {
+                       if(opcode == OPSTAR)
+                               e = mkexpr(OPSTAR, lp->exprblock.rightp, rp);
+                       else if(ISICON(rp) &&
+                           (lp->exprblock.rightp->constblock.Const.ci %
+                           rp->constblock.Const.ci) == 0)
+                               e = mkexpr(OPSLASH, lp->exprblock.rightp, rp);
+                       else    break;
+
+                       e1 = lp->exprblock.leftp;
+                       free( (charptr) lp );
+                       return( mkexpr(OPSTAR, e1, e) );
+                       }
+               break;
+
+
+       case OPPLUS:
+               if( ISCONST(lp) )
+                       COMMUTE
+                           goto addop;
+
+       case OPMINUS:
+               if( ICONEQ(lp, 0) )
+               {
+                       frexpr(lp);
+                       return( mkexpr(OPNEG, rp, ENULL) );
+               }
+
+               if( ISCONST(rp) && is_negatable((Constp)rp))
+               {
+                       opcode = OPPLUS;
+                       consnegop((Constp)rp);
+               }
+
+/* Group constants in an addition expression (also subtraction, since the
+   subtracted value was negated above).  In particular,
+
+       (x + CONST1) + CONST2 ==> x + (CONST1 + CONST2)
+*/
+
+addop:
+               if( ISICON(rp) )
+               {
+                       if(rp->constblock.Const.ci == 0)
+                               goto retleft;
+                       if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) )
+                       {
+                               e = mkexpr(OPPLUS, lp->exprblock.rightp, rp);
+                               e1 = lp->exprblock.leftp;
+                               free( (charptr) lp );
+                               return( mkexpr(OPPLUS, e1, e) );
+                       }
+               }
+               if (opcode == OPMINUS && (ISINT(etype) || doing_vleng)) {
+                       /* check for (i [+const]) - (i [+const]) */
+                       if (lp->tag == TPRIM)
+                               e = lp;
+                       else if (lp->tag == TEXPR && lp->exprblock.opcode == OPPLUS
+                                       && lp->exprblock.rightp->tag == TCONST) {
+                               e = lp->exprblock.leftp;
+                               if (e->tag != TPRIM)
+                                       break;
+                               }
+                       else
+                               break;
+                       if (e->primblock.argsp)
+                               break;
+                       if (rp->tag == TPRIM)
+                               e1 = rp;
+                       else if (rp->tag == TEXPR && rp->exprblock.opcode == OPPLUS
+                                       && rp->exprblock.rightp->tag == TCONST) {
+                               e1 = rp->exprblock.leftp;
+                               if (e1->tag != TPRIM)
+                                       break;
+                               }
+                       else
+                               break;
+                       if (e->primblock.namep != e1->primblock.namep
+                                       || e1->primblock.argsp)
+                               break;
+                       L = e == lp ? 0 : lp->exprblock.rightp->constblock.Const.ci;
+                       if (e1 != rp)
+                               L -= rp->exprblock.rightp->constblock.Const.ci;
+                       frexpr(lp);
+                       frexpr(rp);
+                       return ICON(L);
+                       }
+
+               break;
+
+
+       case OPPOWER:
+               break;
+
+/* Eliminate outermost double negations */
+
+       case OPNEG:
+       case OPNEG1:
+               if(ltag==TEXPR && lp->exprblock.opcode==OPNEG)
+               {
+                       e = lp->exprblock.leftp;
+                       free( (charptr) lp );
+                       return(e);
+               }
+               break;
+
+/* Eliminate outermost double NOTs */
+
+       case OPNOT:
+               if(ltag==TEXPR && lp->exprblock.opcode==OPNOT)
+               {
+                       e = lp->exprblock.leftp;
+                       free( (charptr) lp );
+                       return(e);
+               }
+               break;
+
+       case OPCALL:
+       case OPCCALL:
+               etype = ltype;
+               if(rp!=NULL && rp->listblock.listp==NULL)
+               {
+                       free( (charptr) rp );
+                       rp = NULL;
+               }
+               break;
+
+       case OPAND:
+       case OPOR:
+               if( ISCONST(lp) )
+                       COMMUTE
+
+                           if( ISCONST(rp) )
+                       {
+                               if(rp->constblock.Const.ci == 0)
+                                       if(opcode == OPOR)
+                                               goto retleft;
+                                       else
+                                               goto retright;
+                               else if(opcode == OPOR)
+                                       goto retright;
+                               else
+                                       goto retleft;
+                       }
+       case OPEQV:
+       case OPNEQV:
+
+       case OPBITAND:
+       case OPBITOR:
+       case OPBITXOR:
+       case OPBITNOT:
+       case OPLSHIFT:
+       case OPRSHIFT:
+
+       case OPLT:
+       case OPGT:
+       case OPLE:
+       case OPGE:
+       case OPEQ:
+       case OPNE:
+
+       case OPCONCAT:
+               break;
+       case OPMIN:
+       case OPMAX:
+       case OPMIN2:
+       case OPMAX2:
+       case OPDMIN:
+       case OPDMAX:
+
+       case OPASSIGN:
+       case OPASSIGNI:
+       case OPPLUSEQ:
+       case OPSTAREQ:
+       case OPMINUSEQ:
+       case OPSLASHEQ:
+       case OPMODEQ:
+       case OPLSHIFTEQ:
+       case OPRSHIFTEQ:
+       case OPBITANDEQ:
+       case OPBITXOREQ:
+       case OPBITOREQ:
+
+       case OPCONV:
+       case OPADDR:
+       case OPWHATSIN:
+
+       case OPCOMMA:
+       case OPCOMMA_ARG:
+       case OPQUEST:
+       case OPCOLON:
+       case OPDOT:
+       case OPARROW:
+       case OPIDENTITY:
+       case OPCHARCAST:
+       case OPABS:
+       case OPDABS:
+               break;
+
+       default:
+               badop("mkexpr", opcode);
+       }
+
+       e = (expptr) ALLOC(Exprblock);
+       e->exprblock.tag = TEXPR;
+       e->exprblock.opcode = opcode;
+       e->exprblock.vtype = etype;
+       e->exprblock.leftp = lp;
+       e->exprblock.rightp = rp;
+       if(ltag==TCONST && (rp==0 || rtag==TCONST) )
+               e = fold(e);
+       return(e);
+
+retleft:
+       frexpr(rp);
+       if (lp->tag == TPRIM)
+               lp->primblock.parenused = 1;
+       return(lp);
+
+retright:
+       frexpr(lp);
+       if (rp->tag == TPRIM)
+               rp->primblock.parenused = 1;
+       return(rp);
+
+error:
+       frexpr(lp);
+       if(rp && opcode!=OPCALL && opcode!=OPCCALL)
+               frexpr(rp);
+       return( errnode() );
+}
+
+#define ERR(s)   { errs = s; goto error; }
+
+/* cktype -- Check and return the type of the expression */
+
+cktype(op, lt, rt)
+register int op, lt, rt;
+{
+       char *errs;
+
+       if(lt==TYERROR || rt==TYERROR)
+               goto error1;
+
+       if(lt==TYUNKNOWN)
+               return(TYUNKNOWN);
+       if(rt==TYUNKNOWN)
+
+/* If not unary operation, return UNKNOWN */
+
+               if(!is_unary_op (op) && op != OPCALL && op != OPCCALL)
+                       return(TYUNKNOWN);
+
+       switch(op)
+       {
+       case OPPLUS:
+       case OPMINUS:
+       case OPSTAR:
+       case OPSLASH:
+       case OPPOWER:
+       case OPMOD:
+               if( ISNUMERIC(lt) && ISNUMERIC(rt) )
+                       return( maxtype(lt, rt) );
+               ERR("nonarithmetic operand of arithmetic operator")
+
+       case OPNEG:
+       case OPNEG1:
+               if( ISNUMERIC(lt) )
+                       return(lt);
+               ERR("nonarithmetic operand of negation")
+
+       case OPNOT:
+               if(ISLOGICAL(lt))
+                       return(lt);
+               ERR("NOT of nonlogical")
+
+       case OPAND:
+       case OPOR:
+       case OPEQV:
+       case OPNEQV:
+               if(ISLOGICAL(lt) && ISLOGICAL(rt))
+                       return( maxtype(lt, rt) );
+               ERR("nonlogical operand of logical operator")
+
+       case OPLT:
+       case OPGT:
+       case OPLE:
+       case OPGE:
+       case OPEQ:
+       case OPNE:
+               if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt))
+               {
+                       if(lt != rt){
+                               if (htype
+                                       && (lt == TYCHAR && ISNUMERIC(rt)
+                                        || rt == TYCHAR && ISNUMERIC(lt)))
+                                               return TYLOGICAL;
+                               ERR("illegal comparison")
+                               }
+               }
+
+               else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
+               {
+                       if(op!=OPEQ && op!=OPNE)
+                               ERR("order comparison of complex data")
+               }
+
+               else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
+                       ERR("comparison of nonarithmetic data")
+                           return(TYLOGICAL);
+
+       case OPCONCAT:
+               if(lt==TYCHAR && rt==TYCHAR)
+                       return(TYCHAR);
+               ERR("concatenation of nonchar data")
+
+       case OPCALL:
+       case OPCCALL:
+       case OPIDENTITY:
+               return(lt);
+
+       case OPADDR:
+       case OPCHARCAST:
+               return(TYADDR);
+
+       case OPCONV:
+               if(rt == 0)
+                       return(0);
+               if(lt==TYCHAR && ISINT(rt) )
+                       return(TYCHAR);
+               if (ISLOGICAL(lt) && ISLOGICAL(rt))
+                       return lt;
+       case OPASSIGN:
+       case OPASSIGNI:
+       case OPMINUSEQ:
+       case OPPLUSEQ:
+       case OPSTAREQ:
+       case OPSLASHEQ:
+       case OPMODEQ:
+       case OPLSHIFTEQ:
+       case OPRSHIFTEQ:
+       case OPBITANDEQ:
+       case OPBITXOREQ:
+       case OPBITOREQ:
+               if( ISINT(lt) && rt==TYCHAR)
+                       return(lt);
+               if (ISLOGICAL(lt) && ISLOGICAL(rt) && op == OPASSIGN)
+                       return lt;
+               if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt))
+                       if((op!=OPASSIGN && op != OPPLUSEQ && op != OPMINUSEQ)
+                           || (lt!=rt))
+                       {
+                               ERR("impossible conversion")
+                       }
+               return(lt);
+
+       case OPMIN:
+       case OPMAX:
+       case OPDMIN:
+       case OPDMAX:
+       case OPMIN2:
+       case OPMAX2:
+       case OPBITOR:
+       case OPBITAND:
+       case OPBITXOR:
+       case OPBITNOT:
+       case OPLSHIFT:
+       case OPRSHIFT:
+       case OPWHATSIN:
+       case OPABS:
+       case OPDABS:
+               return(lt);
+
+       case OPCOMMA:
+       case OPCOMMA_ARG:
+       case OPQUEST:
+       case OPCOLON:           /* Only checks the rightmost type because
+                                  of C language definition (rightmost
+                                  comma-expr is the value of the expr) */
+               return(rt);
+
+       case OPDOT:
+       case OPARROW:
+           return (lt);
+           break;
+       default:
+               badop("cktype", op);
+       }
+error:
+       err(errs);
+error1:
+       return(TYERROR);
+}
+
+/* fold -- simplifies constant expressions; it assumes that e -> leftp and
+   e -> rightp are TCONST or NULL */
+
+ LOCAL expptr
+fold(e)
+ register expptr e;
+{
+       Constp p;
+       register expptr lp, rp;
+       int etype, mtype, ltype, rtype, opcode;
+       int i, bl, ll, lr;
+       char *q, *s;
+       struct Constblock lcon, rcon;
+       long L;
+       double d;
+
+       opcode = e->exprblock.opcode;
+       etype = e->exprblock.vtype;
+
+       lp = e->exprblock.leftp;
+       ltype = lp->headblock.vtype;
+       rp = e->exprblock.rightp;
+
+       if(rp == 0)
+               switch(opcode)
+               {
+               case OPNOT:
+                       lp->constblock.Const.ci = ! lp->constblock.Const.ci;
+ retlp:
+                       e->exprblock.leftp = 0;
+                       frexpr(e);
+                       return(lp);
+
+               case OPBITNOT:
+                       lp->constblock.Const.ci = ~ lp->constblock.Const.ci;
+                       goto retlp;
+
+               case OPNEG:
+               case OPNEG1:
+                       consnegop((Constp)lp);
+                       goto retlp;
+
+               case OPCONV:
+               case OPADDR:
+                       return(e);
+
+               case OPABS:
+               case OPDABS:
+                       switch(ltype) {
+                           case TYINT1:
+                           case TYSHORT:
+                           case TYLONG:
+#ifdef TYQUAD
+                           case TYQUAD:
+#endif
+                               if ((L = lp->constblock.Const.ci) < 0)
+                                       lp->constblock.Const.ci = -L;
+                               goto retlp;
+                           case TYREAL:
+                           case TYDREAL:
+                               if (lp->constblock.vstg) {
+                                   s = lp->constblock.Const.cds[0];
+                                   if (*s == '-')
+                                       lp->constblock.Const.cds[0] = s + 1;
+                                   goto retlp;
+                               }
+                               if ((d = lp->constblock.Const.cd[0]) < 0.)
+                                       lp->constblock.Const.cd[0] = -d;
+                           case TYCOMPLEX:
+                           case TYDCOMPLEX:
+                               return e;       /* lazy way out */
+                           }
+               default:
+                       badop("fold", opcode);
+               }
+
+       rtype = rp->headblock.vtype;
+
+       p = ALLOC(Constblock);
+       p->tag = TCONST;
+       p->vtype = etype;
+       p->vleng = e->exprblock.vleng;
+
+       switch(opcode)
+       {
+       case OPCOMMA:
+       case OPCOMMA_ARG:
+       case OPQUEST:
+       case OPCOLON:
+               return(e);
+
+       case OPAND:
+               p->Const.ci = lp->constblock.Const.ci &&
+                   rp->constblock.Const.ci;
+               break;
+
+       case OPOR:
+               p->Const.ci = lp->constblock.Const.ci ||
+                   rp->constblock.Const.ci;
+               break;
+
+       case OPEQV:
+               p->Const.ci = lp->constblock.Const.ci ==
+                   rp->constblock.Const.ci;
+               break;
+
+       case OPNEQV:
+               p->Const.ci = lp->constblock.Const.ci !=
+                   rp->constblock.Const.ci;
+               break;
+
+       case OPBITAND:
+               p->Const.ci = lp->constblock.Const.ci &
+                   rp->constblock.Const.ci;
+               break;
+
+       case OPBITOR:
+               p->Const.ci = lp->constblock.Const.ci |
+                   rp->constblock.Const.ci;
+               break;
+
+       case OPBITXOR:
+               p->Const.ci = lp->constblock.Const.ci ^
+                   rp->constblock.Const.ci;
+               break;
+
+       case OPLSHIFT:
+               p->Const.ci = lp->constblock.Const.ci <<
+                   rp->constblock.Const.ci;
+               break;
+
+       case OPRSHIFT:
+               p->Const.ci = lp->constblock.Const.ci >>
+                   rp->constblock.Const.ci;
+               break;
+
+       case OPCONCAT:
+               ll = lp->constblock.vleng->constblock.Const.ci;
+               lr = rp->constblock.vleng->constblock.Const.ci;
+               bl = lp->constblock.Const.ccp1.blanks;
+               p->Const.ccp = q = (char *) ckalloc(ll+lr+bl);
+               p->Const.ccp1.blanks = rp->constblock.Const.ccp1.blanks;
+               p->vleng = ICON(ll+lr+bl);
+               s = lp->constblock.Const.ccp;
+               for(i = 0 ; i < ll ; ++i)
+                       *q++ = *s++;
+               for(i = 0 ; i < bl ; i++)
+                       *q++ = ' ';
+               s = rp->constblock.Const.ccp;
+               for(i = 0; i < lr; ++i)
+                       *q++ = *s++;
+               break;
+
+
+       case OPPOWER:
+               if( ! ISINT(rtype) )
+                       return(e);
+               conspower(p, (Constp)lp, rp->constblock.Const.ci);
+               break;
+
+
+       default:
+               if(ltype == TYCHAR)
+               {
+                       lcon.Const.ci = cmpstr(lp->constblock.Const.ccp,
+                           rp->constblock.Const.ccp,
+                           lp->constblock.vleng->constblock.Const.ci,
+                           rp->constblock.vleng->constblock.Const.ci);
+                       rcon.Const.ci = 0;
+                       mtype = tyint;
+               }
+               else    {
+                       mtype = maxtype(ltype, rtype);
+                       consconv(mtype, &lcon, &lp->constblock);
+                       consconv(mtype, &rcon, &rp->constblock);
+               }
+               consbinop(opcode, mtype, p, &lcon, &rcon);
+               break;
+       }
+
+       frexpr(e);
+       return( (expptr) p );
+}
+
+
+
+/* assign constant l = r , doing coercion */
+
+consconv(lt, lc, rc)
+ int lt;
+ register Constp lc, rc;
+{
+       int rt = rc->vtype;
+       register union Constant *lv = &lc->Const, *rv = &rc->Const;
+
+       lc->vtype = lt;
+       if (ONEOF(lt, MSKREAL|MSKCOMPLEX) && ONEOF(rt, MSKREAL|MSKCOMPLEX)) {
+               memcpy((char *)lv, (char *)rv, sizeof(union Constant));
+               lc->vstg = rc->vstg;
+               if (ISCOMPLEX(lt) && ISREAL(rt)) {
+                       if (rc->vstg)
+                               lv->cds[1] = cds("0",CNULL);
+                       else
+                               lv->cd[1] = 0.;
+                       }
+               return;
+               }
+       lc->vstg = 0;
+
+       switch(lt)
+       {
+
+/* Casting to character means just copying the first sizeof (character)
+   bytes into a new 1 character string.  This is weird. */
+
+       case TYCHAR:
+               *(lv->ccp = (char *) ckalloc(1)) = rv->ci;
+               lv->ccp1.blanks = 0;
+               break;
+
+       case TYINT1:
+       case TYSHORT:
+       case TYLONG:
+#ifdef TYQUAD
+       case TYQUAD:
+#endif
+               if(rt == TYCHAR)
+                       lv->ci = rv->ccp[0];
+               else if( ISINT(rt) )
+                       lv->ci = rv->ci;
+               else    lv->ci = rc->vstg ? atof(rv->cds[0]) : rv->cd[0];
+
+               break;
+
+       case TYCOMPLEX:
+       case TYDCOMPLEX:
+               lv->cd[1] = 0.;
+               lv->cd[0] = rv->ci;
+               break;
+
+       case TYREAL:
+       case TYDREAL:
+               lv->cd[0] = rv->ci;
+               break;
+
+       case TYLOGICAL:
+       case TYLOGICAL1:
+       case TYLOGICAL2:
+               lv->ci = rv->ci;
+               break;
+       }
+}
+
+
+
+/* Negate constant value -- changes the input node's value */
+
+consnegop(p)
+register Constp p;
+{
+       register char *s;
+
+       if (p->vstg) {
+               if (ISCOMPLEX(p->vtype)) {
+                       s = p->Const.cds[1];
+                       p->Const.cds[1] = *s == '-' ? s+1
+                                       : *s == '0' ? s : s-1;
+                       }
+               s = p->Const.cds[0];
+               p->Const.cds[0] = *s == '-' ? s+1
+                               : *s == '0' ? s : s-1;
+               return;
+               }
+       switch(p->vtype)
+       {
+       case TYINT1:
+       case TYSHORT:
+       case TYLONG:
+#ifdef TYQUAD
+       case TYQUAD:
+#endif
+               p->Const.ci = - p->Const.ci;
+               break;
+
+       case TYCOMPLEX:
+       case TYDCOMPLEX:
+               p->Const.cd[1] = - p->Const.cd[1];
+               /* fall through and do the real parts */
+       case TYREAL:
+       case TYDREAL:
+               p->Const.cd[0] = - p->Const.cd[0];
+               break;
+       default:
+               badtype("consnegop", p->vtype);
+       }
+}
+
+
+
+/* conspower -- Expand out an exponentiation */
+
+ LOCAL void
+conspower(p, ap, n)
+ Constp p, ap;
+ ftnint n;
+{
+       register union Constant *powp = &p->Const;
+       register int type;
+       struct Constblock x, x0;
+
+       if (n == 1) {
+               memcpy((char *)powp, (char *)&ap->Const, sizeof(ap->Const));
+               return;
+               }
+
+       switch(type = ap->vtype)        /* pow = 1 */
+       {
+       case TYINT1:
+       case TYSHORT:
+       case TYLONG:
+#ifdef TYQUAD
+       case TYQUAD:
+#endif
+               powp->ci = 1;
+               break;
+       case TYCOMPLEX:
+       case TYDCOMPLEX:
+               powp->cd[1] = 0;
+       case TYREAL:
+       case TYDREAL:
+               powp->cd[0] = 1;
+               break;
+       default:
+               badtype("conspower", type);
+       }
+
+       if(n == 0)
+               return;
+       switch(type)    /* x0 = ap */
+       {
+       case TYINT1:
+       case TYSHORT:
+       case TYLONG:
+#ifdef TYQUAD
+       case TYQUAD:
+#endif
+               x0.Const.ci = ap->Const.ci;
+               break;
+       case TYCOMPLEX:
+       case TYDCOMPLEX:
+               x0.Const.cd[1] =
+                       ap->vstg ? atof(ap->Const.cds[1]) : ap->Const.cd[1];
+       case TYREAL:
+       case TYDREAL:
+               x0.Const.cd[0] =
+                       ap->vstg ? atof(ap->Const.cds[0]) : ap->Const.cd[0];
+               break;
+       }
+       x0.vtype = type;
+       x0.vstg = 0;
+       if(n < 0)
+       {
+               if( ISINT(type) )
+               {
+                       err("integer ** negative number");
+                       return;
+               }
+               else if (!x0.Const.cd[0]
+                               && (!ISCOMPLEX(type) || !x0.Const.cd[1])) {
+                       err("0.0 ** negative number");
+                       return;
+                       }
+               n = -n;
+               consbinop(OPSLASH, type, &x, p, &x0);
+       }
+       else
+               consbinop(OPSTAR, type, &x, p, &x0);
+
+       for( ; ; )
+       {
+               if(n & 01)
+                       consbinop(OPSTAR, type, p, p, &x);
+               if(n >>= 1)
+                       consbinop(OPSTAR, type, &x, &x, &x);
+               else
+                       break;
+       }
+}
+
+
+
+/* do constant operation cp = a op b -- assumes that   ap and bp   have data
+   matching the input   type */
+
+ LOCAL void
+zerodiv()
+{ Fatal("division by zero during constant evaluation; cannot recover"); }
+
+ LOCAL void
+consbinop(opcode, type, cpp, app, bpp)
+ int opcode, type;
+ Constp cpp, app, bpp;
+{
+       register union Constant *ap = &app->Const,
+                               *bp = &bpp->Const,
+                               *cp = &cpp->Const;
+       int k;
+       double ad[2], bd[2], temp;
+
+       cpp->vstg = 0;
+
+       if (ONEOF(type, MSKREAL|MSKCOMPLEX)) {
+               ad[0] = app->vstg ? atof(ap->cds[0]) : ap->cd[0];
+               bd[0] = bpp->vstg ? atof(bp->cds[0]) : bp->cd[0];
+               if (ISCOMPLEX(type)) {
+                       ad[1] = app->vstg ? atof(ap->cds[1]) : ap->cd[1];
+                       bd[1] = bpp->vstg ? atof(bp->cds[1]) : bp->cd[1];
+                       }
+               }
+       switch(opcode)
+       {
+       case OPPLUS:
+               switch(type)
+               {
+               case TYINT1:
+               case TYSHORT:
+               case TYLONG:
+#ifdef TYQUAD
+               case TYQUAD:
+#endif
+                       cp->ci = ap->ci + bp->ci;
+                       break;
+               case TYCOMPLEX:
+               case TYDCOMPLEX:
+                       cp->cd[1] = ad[1] + bd[1];
+               case TYREAL:
+               case TYDREAL:
+                       cp->cd[0] = ad[0] + bd[0];
+                       break;
+               }
+               break;
+
+       case OPMINUS:
+               switch(type)
+               {
+               case TYINT1:
+               case TYSHORT:
+               case TYLONG:
+#ifdef TYQUAD
+               case TYQUAD:
+#endif
+                       cp->ci = ap->ci - bp->ci;
+                       break;
+               case TYCOMPLEX:
+               case TYDCOMPLEX:
+                       cp->cd[1] = ad[1] - bd[1];
+               case TYREAL:
+               case TYDREAL:
+                       cp->cd[0] = ad[0] - bd[0];
+                       break;
+               }
+               break;
+
+       case OPSTAR:
+               switch(type)
+               {
+               case TYINT1:
+               case TYSHORT:
+               case TYLONG:
+#ifdef TYQUAD
+               case TYQUAD:
+#endif
+                       cp->ci = ap->ci * bp->ci;
+                       break;
+               case TYREAL:
+               case TYDREAL:
+                       cp->cd[0] = ad[0] * bd[0];
+                       break;
+               case TYCOMPLEX:
+               case TYDCOMPLEX:
+                       temp = ad[0] * bd[0]  -  ad[1] * bd[1] ;
+                       cp->cd[1] = ad[0] * bd[1]  +  ad[1] * bd[0] ;
+                       cp->cd[0] = temp;
+                       break;
+               }
+               break;
+       case OPSLASH:
+               switch(type)
+               {
+               case TYINT1:
+               case TYSHORT:
+               case TYLONG:
+#ifdef TYQUAD
+               case TYQUAD:
+#endif
+                       if (!bp->ci)
+                               zerodiv();
+                       cp->ci = ap->ci / bp->ci;
+                       break;
+               case TYREAL:
+               case TYDREAL:
+                       if (!bd[0])
+                               zerodiv();
+                       cp->cd[0] = ad[0] / bd[0];
+                       break;
+               case TYCOMPLEX:
+               case TYDCOMPLEX:
+                       if (!bd[0] && !bd[1])
+                               zerodiv();
+                       zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd);
+                       break;
+               }
+               break;
+
+       case OPMOD:
+               if( ISINT(type) )
+               {
+                       cp->ci = ap->ci % bp->ci;
+                       break;
+               }
+               else
+                       Fatal("inline mod of noninteger");
+
+       case OPMIN2:
+       case OPDMIN:
+               switch(type)
+               {
+               case TYINT1:
+               case TYSHORT:
+               case TYLONG:
+#ifdef TYQUAD
+               case TYQUAD:
+#endif
+                       cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci;
+                       break;
+               case TYREAL:
+               case TYDREAL:
+                       cp->cd[0] = ad[0] <= bd[0] ? ad[0] : bd[0];
+                       break;
+               default:
+                       Fatal("inline min of exected type");
+               }
+               break;
+
+       case OPMAX2:
+       case OPDMAX:
+               switch(type)
+               {
+               case TYINT1:
+               case TYSHORT:
+               case TYLONG:
+#ifdef TYQUAD
+               case TYQUAD:
+#endif
+                       cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci;
+                       break;
+               case TYREAL:
+               case TYDREAL:
+                       cp->cd[0] = ad[0] >= bd[0] ? ad[0] : bd[0];
+                       break;
+               default:
+                       Fatal("inline max of exected type");
+               }
+               break;
+
+       default:          /* relational ops */
+               switch(type)
+               {
+               case TYINT1:
+               case TYSHORT:
+               case TYLONG:
+#ifdef TYQUAD
+               case TYQUAD:
+#endif
+                       if(ap->ci < bp->ci)
+                               k = -1;
+                       else if(ap->ci == bp->ci)
+                               k = 0;
+                       else    k = 1;
+                       break;
+               case TYREAL:
+               case TYDREAL:
+                       if(ad[0] < bd[0])
+                               k = -1;
+                       else if(ad[0] == bd[0])
+                               k = 0;
+                       else    k = 1;
+                       break;
+               case TYCOMPLEX:
+               case TYDCOMPLEX:
+                       if(ad[0] == bd[0] &&
+                           ad[1] == bd[1] )
+                               k = 0;
+                       else    k = 1;
+                       break;
+               }
+
+               switch(opcode)
+               {
+               case OPEQ:
+                       cp->ci = (k == 0);
+                       break;
+               case OPNE:
+                       cp->ci = (k != 0);
+                       break;
+               case OPGT:
+                       cp->ci = (k == 1);
+                       break;
+               case OPLT:
+                       cp->ci = (k == -1);
+                       break;
+               case OPGE:
+                       cp->ci = (k >= 0);
+                       break;
+               case OPLE:
+                       cp->ci = (k <= 0);
+                       break;
+               }
+               break;
+       }
+}
+
+
+
+/* conssgn - returns the sign of a Fortran constant */
+
+conssgn(p)
+register expptr p;
+{
+       register char *s;
+
+       if( ! ISCONST(p) )
+               Fatal( "sgn(nonconstant)" );
+
+       switch(p->headblock.vtype)
+       {
+       case TYINT1:
+       case TYSHORT:
+       case TYLONG:
+#ifdef TYQUAD
+       case TYQUAD:
+#endif
+               if(p->constblock.Const.ci > 0) return(1);
+               if(p->constblock.Const.ci < 0) return(-1);
+               return(0);
+
+       case TYREAL:
+       case TYDREAL:
+               if (p->constblock.vstg) {
+                       s = p->constblock.Const.cds[0];
+                       if (*s == '-')
+                               return -1;
+                       if (*s == '0')
+                               return 0;
+                       return 1;
+                       }
+               if(p->constblock.Const.cd[0] > 0) return(1);
+               if(p->constblock.Const.cd[0] < 0) return(-1);
+               return(0);
+
+
+/* The sign of a complex number is 0 iff the number is 0 + 0i, else it's 1 */
+
+       case TYCOMPLEX:
+       case TYDCOMPLEX:
+               if (p->constblock.vstg)
+                       return *p->constblock.Const.cds[0] != '0'
+                           && *p->constblock.Const.cds[1] != '0';
+               return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0);
+
+       default:
+               badtype( "conssgn", p->constblock.vtype);
+       }
+       /* NOT REACHED */ return 0;
+}
+
+char *powint[ ] = {
+       "pow_ii",
+#ifdef TYQUAD
+                 "pow_qi",
+#endif
+                 "pow_ri", "pow_di", "pow_ci", "pow_zi" };
+
+LOCAL expptr mkpower(p)
+register expptr p;
+{
+       register expptr q, lp, rp;
+       int ltype, rtype, mtype, tyi;
+
+       lp = p->exprblock.leftp;
+       rp = p->exprblock.rightp;
+       ltype = lp->headblock.vtype;
+       rtype = rp->headblock.vtype;
+
+       if (lp->tag == TADDR)
+               lp->addrblock.parenused = 0;
+
+       if (rp->tag == TADDR)
+               rp->addrblock.parenused = 0;
+
+       if(ISICON(rp))
+       {
+               if(rp->constblock.Const.ci == 0)
+               {
+                       frexpr(p);
+                       if( ISINT(ltype) )
+                               return( ICON(1) );
+                       else if (ISREAL (ltype))
+                               return mkconv (ltype, ICON (1));
+                       else
+                               return( (expptr) putconst((Constp)
+                                       mkconv(ltype, ICON(1))) );
+               }
+               if(rp->constblock.Const.ci < 0)
+               {
+                       if( ISINT(ltype) )
+                       {
+                               frexpr(p);
+                               err("integer**negative");
+                               return( errnode() );
+                       }
+                       rp->constblock.Const.ci = - rp->constblock.Const.ci;
+                       p->exprblock.leftp = lp
+                               = fixexpr((Exprp)mkexpr(OPSLASH, ICON(1), lp));
+               }
+               if(rp->constblock.Const.ci == 1)
+               {
+                       frexpr(rp);
+                       free( (charptr) p );
+                       return(lp);
+               }
+
+               if( ONEOF(ltype, MSKINT|MSKREAL) ) {
+                       p->exprblock.vtype = ltype;
+                       return(p);
+               }
+       }
+       if( ISINT(rtype) )
+       {
+               if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
+                       q = call2(TYSHORT, "pow_hh", lp, rp);
+               else    {
+                       if(ONEOF(ltype,M(TYINT1)|M(TYSHORT)))
+                       {
+                               ltype = TYLONG;
+                               lp = mkconv(TYLONG,lp);
+                       }
+#ifdef TYQUAD
+                       if (ltype == TYQUAD)
+                               rp = mkconv(TYQUAD,rp);
+                       else
+#endif
+                       rp = mkconv(TYLONG,rp);
+                       if (ISCONST(rp)) {
+                               tyi = tyint;
+                               tyint = TYLONG;
+                               rp = (expptr)putconst((Constp)rp);
+                               tyint = tyi;
+                               }
+                       q = call2(ltype, powint[ltype-TYLONG], lp, rp);
+               }
+       }
+       else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) {
+               extern int callk_kludge;
+               callk_kludge = TYDREAL;
+               q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
+               callk_kludge = 0;
+               }
+       else    {
+               q  = call2(TYDCOMPLEX, "pow_zz",
+                   mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
+               if(mtype == TYCOMPLEX)
+                       q = mkconv(TYCOMPLEX, q);
+       }
+       free( (charptr) p );
+       return(q);
+}
+
+
+/* Complex Division.  Same code as in Runtime Library
+*/
+
+
+ LOCAL void
+zdiv(c, a, b)
+ register dcomplex *a, *b, *c;
+{
+       double ratio, den;
+       double abr, abi;
+
+       if( (abr = b->dreal) < 0.)
+               abr = - abr;
+       if( (abi = b->dimag) < 0.)
+               abi = - abi;
+       if( abr <= abi )
+       {
+               if(abi == 0)
+                       Fatal("complex division by zero");
+               ratio = b->dreal / b->dimag ;
+               den = b->dimag * (1 + ratio*ratio);
+               c->dreal = (a->dreal*ratio + a->dimag) / den;
+               c->dimag = (a->dimag*ratio - a->dreal) / den;
+       }
+
+       else
+       {
+               ratio = b->dimag / b->dreal ;
+               den = b->dreal * (1 + ratio*ratio);
+               c->dreal = (a->dreal + a->dimag*ratio) / den;
+               c->dimag = (a->dimag - a->dreal*ratio) / den;
+       }
+}

diff --git a/usr.bin/f2c/f2c.1 b/usr.bin/f2c/f2c.1
new file mode 100644 (file)
index 0000000..419ba03
--- /dev/null
+++ b/usr.bin/f2c/f2c.1
@@ -0,0 +1,191 @@
+
+     F2C(1)                                                    F2C(1)
+
+     NAME
+         f2c - Convert Fortran 77 to C or C++
+
+     SYNOPSIS
+         f2c [ option ... ] file ...
+
+     DESCRIPTION
+         F2c converts Fortran 77 source code in files with names end-
+         ing in `.f' or `.F' to C (or C++) source files in the cur-
+         rent directory, with `.c' substituted for the final `.f' or
+         `.F'.  If no Fortran files are named, f2c reads Fortran from
+         standard input and writes C on standard output.  File names
+         that end with `.p' or `.P' are taken to be prototype files,
+         as produced by option `-P', and are read first.
+
+         The following options have the same meaning as in f77(1).
+
+         -C   Compile code to check that subscripts are within
+              declared array bounds.
+
+         -I2  Render INTEGER and LOGICAL as short, INTEGER*4 as long
+              int.  Assume the default libF77 and libI77:  allow only
+              INTEGER*4 (and no LOGICAL) variables in INQUIREs.
+              Option `-I4' confirms the default rendering of INTEGER
+              as long int.
+
+         -onetrip
+              Compile DO loops that are performed at least once if
+              reached.  (Fortran 77 DO loops are not performed at all
+              if the upper limit is smaller than the lower limit.)
+
+         -U   Honor the case of variable and external names.  Fortran
+              keywords must be in lower case.
+
+         -u   Make the default type of a variable `undefined' rather
+              than using the default Fortran rules.
+
+         -w   Suppress all warning messages.  If the option is
+              `-w66', only Fortran 66 compatibility warnings are sup-
+              pressed.
+
+         The following options are peculiar to f2c.
+
+         -A   Produce ANSI C.  Default is old-style C.
+
+         -a   Make local variables automatic rather than static
+              unless they appear in a DATA, EQUIVALENCE, NAMELIST, or
+              SAVE statement.
+
+         -C++ Output C++ code.
+
+         -c   Include original Fortran source as comments.
+
+     Page 1                       Local              (printed 2/2/93)
+
+     F2C(1)                                                    F2C(1)
+
+         -E   Declare uninitialized COMMON to be Extern (overridably
+              defined in f2c.h as extern).
+
+         -ec  Place uninitialized COMMON blocks in separate files:
+              COMMON /ABC/ appears in file abc_com.c.  Option `-e1c'
+              bundles the separate files into the output file, with
+              comments that give an unbundling sed(1) script.
+
+         -ext Complain about f77(1) extensions.
+
+         -f   Assume free-format input: accept text after column 72
+              and do not pad fixed-format lines shorter than 72 char-
+              acters with blanks.
+
+         -72  Treat text appearing after column 72 as an error.
+
+         -g   Include original Fortran line numbers in #line lines.
+
+         -h   Emulate Fortran 66's treatment of Hollerith: try to
+              align character strings on word (or, if the option is
+              `-hd', on double-word) boundaries.
+
+         -i2  Similar to -I2, but assume a modified libF77 and libI77
+              (compiled with -Df2c_i2), so INTEGER and LOGICAL vari-
+              ables may be assigned by INQUIRE and array lengths are
+              stored in short ints.
+
+         -kr  Use temporary values to enforce Fortran expression
+              evaluation where K&R (first edition) parenthesization
+              rules allow rearrangement.  If the option is `-krd',
+              use double precision temporaries even for single-
+              precision operands.
+
+         -P   Write a file.P of ANSI (or C++) prototypes for defini-
+              tions in each input file.f or file.F.  When reading
+              Fortran from standard input, write prototypes at the
+              beginning of standard output.  Option -Ps implies -P
+              and gives exit status 4 if rerunning f2c may change
+              prototypes or declarations.
+
+         -p   Supply preprocessor definitions to make common-block
+              members look like local variables.
+
+         -R   Do not promote REAL functions and operations to DOUBLE
+              PRECISION.  Option `-!R' confirms the default, which
+              imitates f77.
+
+         -r   Cast values of REAL functions (including intrinsics) to
+              REAL.
+
+         -r8  Promote REAL to DOUBLE PRECISION, COMPLEX to DOUBLE
+              COMPLEX.
+
+     Page 2                       Local              (printed 2/2/93)
+
+     F2C(1)                                                    F2C(1)
+
+         -s   Preserve multidimensional subscripts.
+
+         -Tdir
+              Put temporary files in directory dir.
+
+         -w8  Suppress warnings when COMMON or EQUIVALENCE forces
+              odd-word alignment of doubles.
+
+         -Wn  Assume n characters/word (default 4) when initializing
+              numeric variables with character data.
+
+         -z   Do not implicitly recognize DOUBLE COMPLEX.
+
+         -!bs Do not recognize backslash escapes (\", \', \0, \\, \b,
+              \f, \n, \r, \t, \v) in character strings.
+
+         -!c  Inhibit C output, but produce -P output.
+
+         -!I  Reject include statements.
+
+         -!i8 Disallow INTEGER*8.
+
+         -!it Don't infer types of untyped EXTERNAL procedures from
+              use as parameters to previously defined or prototyped
+              procedures.
+
+         -!P  Do not attempt to infer ANSI or C++ prototypes from
+              usage.
+
+         The resulting C invokes the support routines of f77; object
+         code should be loaded by f77 or with ld(1) or cc(1) options
+         -lF77 -lI77 -lm.  Calling conventions are those of f77: see
+         the reference below.
+
+     FILES
+         file.[fF]
+              input file
+
+         *.c  output file
+
+         /usr/include/f2c.h
+              header file
+
+         /usr/lib/libF77.a
+              intrinsic function library
+
+         /usr/lib/libI77.a
+              Fortran I/O library
+
+         /lib/libc.a
+              C library, see section 3
+
+     Page 3                       Local              (printed 2/2/93)
+
+     F2C(1)                                                    F2C(1)
+
+     SEE ALSO
+         S. I. Feldman and P. J. Weinberger, `A Portable Fortran 77
+         Compiler', UNIX Time Sharing System Programmer's Manual,
+         Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990.
+
+     DIAGNOSTICS
+         The diagnostics produced by f2c are intended to be self-
+         explanatory.
+
+     BUGS
+         Floating-point constant expressions are simplified in the
+         floating-point arithmetic of the machine running f2c, so
+         they are typically accurate to at most 16 or 17 decimal
+         places.
+         Untypable EXTERNAL functions are declared int.
+
+     Page 4                       Local              (printed 2/2/93)
+

diff --git a/usr.bin/f2c/f2c.1t b/usr.bin/f2c/f2c.1t
new file mode 100644 (file)
index 0000000..2a59dff
--- /dev/null
+++ b/usr.bin/f2c/f2c.1t
@@ -0,0 +1,336 @@
+. \" Definitions of F, L and LR for the benefit of systems
+. \" whose -man lacks them...
+.de F
+.nh
+.if n \%\&\\$1
+.if t \%\&\f(CW\\$1\fR
+.hy 14
+..
+.de L
+.nh
+.if n \%`\\$1'
+.if t \%\&\f(CW\\$1\fR
+.hy 14
+..
+.de LR
+.nh
+.if n \%`\\$1'\\$2
+.if t \%\&\f(CW\\$1\fR\\$2
+.hy 14
+..
+.TH F2C 1
+.CT 1 prog_other
+.SH NAME
+f\^2c \(mi Convert Fortran 77 to C or C++
+.SH SYNOPSIS
+.B f\^2c
+[
+.I option ...
+]
+.I file ...
+.SH DESCRIPTION
+.I F2c
+converts Fortran 77 source code in
+.I files
+with names ending in
+.L .f
+or
+.L .F
+to C (or C++) source files in the
+current directory, with
+.L .c
+substituted
+for the final
+.L .f
+or
+.LR .F .
+If no Fortran files are named,
+.I f\^2c
+reads Fortran from standard input and
+writes C on standard output.
+.I File
+names that end with
+.L .p
+or
+.L .P
+are taken to be prototype
+files, as produced by option
+.LR -P ,
+and are read first.
+.PP
+The following options have the same meaning as in
+.IR f\^77 (1).
+.TP
+.B -C
+Compile code to check that subscripts are within declared array bounds.
+.TP
+.B -I2
+Render INTEGER and LOGICAL as short,
+INTEGER\(**4 as long int.  Assume the default \fIlibF77\fR
+and \fIlibI77\fR:  allow only INTEGER\(**4 (and no LOGICAL)
+variables in INQUIREs.  Option
+.L -I4
+confirms the default rendering of INTEGER as long int.
+.TP
+.B -onetrip
+Compile DO loops that are performed at least once if reached.
+(Fortran 77 DO loops are not performed at all if the upper limit is smaller than the lower limit.)
+.TP
+.B -U
+Honor the case of variable and external names.  Fortran keywords must be in
+.I
+lower
+case.
+.TP
+.B -u
+Make the default type of a variable `undefined' rather than using the default Fortran rules.
+.TP
+.B -w
+Suppress all warning messages.
+If the option is
+.LR -w66 ,
+only Fortran 66 compatibility warnings are suppressed.
+.PP
+The following options are peculiar to
+.IR f\^2c .
+.TP
+.B -A
+Produce
+.SM ANSI
+C.
+Default is old-style C.
+.TP
+.B -a
+Make local variables automatic rather than static
+unless they appear in a
+.SM "DATA, EQUIVALENCE, NAMELIST,"
+or
+.SM SAVE
+statement.
+.TP
+.B -C++
+Output C++ code.
+.TP
+.B -c
+Include original Fortran source as comments.
+.TP
+.B -E
+Declare uninitialized
+.SM COMMON
+to be
+.B Extern
+(overridably defined in
+.F f2c.h
+as
+.B extern).
+.TP
+.B -ec
+Place uninitialized
+.SM COMMON
+blocks in separate files:
+.B COMMON /ABC/
+appears in file
+.BR abc_com.c .
+Option
+.LR -e1c
+bundles the separate files
+into the output file, with comments that give an unbundling
+.IR sed (1)
+script.
+.TP
+.B -ext
+Complain about
+.IR f\^77 (1)
+extensions.
+.TP
+.B -f
+Assume free-format input: accept text after column 72 and do not
+pad fixed-format lines shorter than 72 characters with blanks.
+.TP
+.B -72
+Treat text appearing after column 72 as an error.
+.TP
+.B -g
+Include original Fortran line numbers in \f(CW#line\fR lines.
+.TP
+.B -h
+Emulate Fortran 66's treatment of Hollerith: try to align character strings on
+word (or, if the option is
+.LR -hd ,
+on double-word) boundaries.
+.TP
+.B -i2
+Similar to
+.BR -I2 ,
+but assume a modified
+.I libF77
+and
+.I libI77
+(compiled with
+.BR -Df\^2c_i2 ),
+so
+.SM INTEGER
+and
+.SM LOGICAL
+variables may be assigned by
+.SM INQUIRE
+and array lengths are stored in short ints.
+.TP
+.B -kr
+Use temporary values to enforce Fortran expression evaluation
+where K&R (first edition) parenthesization rules allow rearrangement.
+If the option is
+.LR -krd ,
+use double precision temporaries even for single-precision operands.
+.TP
+.B -P
+Write a
+.IB file .P
+of ANSI (or C++) prototypes
+for definitions in each input
+.IB file .f
+or
+.IB file .F .
+When reading Fortran from standard input, write prototypes
+at the beginning of standard output.  Option
+.B -Ps
+implies
+.B -P
+and gives exit status 4 if rerunning
+.I f\^2c
+may change prototypes or declarations.
+.TP
+.B -p
+Supply preprocessor definitions to make common-block members
+look like local variables.
+.TP
+.B -R
+Do not promote
+.SM REAL
+functions and operations to
+.SM DOUBLE PRECISION.
+Option
+.L -!R
+confirms the default, which imitates
+.IR f\^77 .
+.TP
+.B -r
+Cast values of REAL functions (including intrinsics) to REAL.
+.TP
+.B -r8
+Promote
+.SM REAL
+to
+.SM DOUBLE PRECISION, COMPLEX
+to
+.SM DOUBLE COMPLEX.
+.TP
+.B -s
+Preserve multidimensional subscripts.
+.TP
+.BI -T dir
+Put temporary files in directory
+.I dir.
+.TP
+.B -w8
+Suppress warnings when
+.SM COMMON
+or
+.SM EQUIVALENCE
+forces odd-word alignment of doubles.
+.TP
+.BI -W n
+Assume
+.I n
+characters/word (default 4)
+when initializing numeric variables with character data.
+.TP
+.B -z
+Do not implicitly recognize
+.SM DOUBLE COMPLEX.
+.TP
+.B -!bs
+Do not recognize \fIb\fRack\fIs\fRlash escapes
+(\e", \e', \e0, \e\e, \eb, \ef, \en, \er, \et, \ev) in character strings.
+.TP
+.B -!c
+Inhibit C output, but produce
+.B -P
+output.
+.TP
+.B -!I
+Reject
+.B include
+statements.
+.TP
+.B -!i8
+Disallow
+.SM INTEGER*8.
+.TP
+.B -!it
+Don't infer types of untyped
+.SM EXTERNAL
+procedures from use as parameters to previously defined or prototyped
+procedures.
+.TP
+.B -!P
+Do not attempt to infer
+.SM ANSI
+or C++
+prototypes from usage.
+.PP
+The resulting C invokes the support routines of
+.IR f\^77 ;
+object code should be loaded by
+.I f\^77
+or with
+.IR ld (1)
+or
+.IR cc (1)
+options
+.BR "-lF77 -lI77 -lm" .
+Calling conventions
+are those of
+.IR f\&77 :
+see the reference below.
+.br
+.SH FILES
+.TP
+.IB file .[fF]
+input file
+.TP
+.B *.c
+output file
+.TP
+.F /usr/include/f2c.h
+header file
+.TP
+.F /usr/lib/libF77.a
+intrinsic function library
+.TP
+.F /usr/lib/libI77.a
+Fortran I/O library
+.TP
+.F /lib/libc.a
+C library, see section 3
+.SH "SEE ALSO"
+S. I. Feldman and
+P. J. Weinberger,
+`A Portable Fortran 77 Compiler',
+\fIUNIX Time Sharing System Programmer's Manual\fR,
+Tenth Edition, Volume 2, AT&T Bell Laboratories, 1990.
+.SH DIAGNOSTICS
+The diagnostics produced by
+.I f\^2c
+are intended to be
+self-explanatory.
+.SH BUGS
+Floating-point constant expressions are simplified in
+the floating-point arithmetic of the machine running
+.IR f\^2c ,
+so they are typically accurate to at most 16 or 17 decimal places.
+.br
+Untypable
+.SM EXTERNAL
+functions are declared
+.BR int .

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

diff --git a/usr.bin/f2c/format.c b/usr.bin/f2c/format.c
new file mode 100644 (file)
index 0000000..80faacc
--- /dev/null
+++ b/usr.bin/f2c/format.c
@@ -0,0 +1,2225 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* Format.c -- this file takes an intermediate file (generated by pass 1
+   of the translator) and some state information about the contents of that
+   file, and generates C program text. */
+
+#include "defs.h"
+#include "p1defs.h"
+#include "format.h"
+#include "output.h"
+#include "names.h"
+#include "iob.h"
+
+int c_output_line_length = DEF_C_LINE_LENGTH;
+
+int last_was_label;    /* Boolean used to generate semicolons
+                                  when a label terminates a block */
+static char this_proc_name[52];        /* Name of the current procedure.  This is
+                                  probably too simplistic to handle
+                                  multiple entry points */
+
+static int p1getd(), p1gets(), p1getf(), get_p1_token();
+static int p1get_const(), p1getn();
+static expptr do_format(), do_p1_name_pointer(), do_p1_const();
+static expptr do_p1_expr(), do_p1_ident(), do_p1_charp(), do_p1_extern();
+static expptr do_p1_head(), do_p1_list(), do_p1_literal();
+static void do_p1_label(), do_p1_asgoto(), do_p1_goto();
+static void do_p1_if(), do_p1_else(), do_p1_elif(), do_p1_endif();
+static void do_p1_endelse(), do_p1_subr_ret(), do_p1_comp_goto();
+static void do_p1_for(), do_p1_end_for(), do_p1_fortran();
+static void do_p1_1while(), do_p1_2while(), do_p1_elseifstart();
+static void do_p1_comment(), do_p1_set_line();
+static expptr do_p1_addr();
+static void proto();
+void list_arg_types();
+chainp length_comp();
+void listargs();
+extern chainp assigned_fmts;
+static char filename[P1_FILENAME_MAX];
+extern int gflag;
+int gflag1;
+extern char *parens;
+
+start_formatting ()
+{
+    FILE *infile;
+    static int wrote_one = 0;
+    extern int usedefsforcommon;
+    extern char *p1_file, *p1_bakfile;
+
+    this_proc_name[0] = '\0';
+    last_was_label = 0;
+    ei_next = ei_first;
+    wh_next = wh_first;
+
+    (void) fclose (pass1_file);
+    if ((infile = fopen (p1_file, binread)) == NULL)
+       Fatal("start_formatting:  couldn't open the intermediate file\n");
+
+    if (wrote_one)
+       nice_printf (c_file, "\n");
+
+    while (!feof (infile)) {
+       expptr this_expr;
+
+       this_expr = do_format (infile, c_file);
+       if (this_expr) {
+           out_and_free_statement (c_file, this_expr);
+       } /* if this_expr */
+    } /* while !feof infile */
+
+    (void) fclose (infile);
+
+    if (last_was_label)
+       nice_printf (c_file, ";\n");
+
+    prev_tab (c_file);
+    gflag1 = 0;
+    if (this_proc_name[0])
+       nice_printf (c_file, "} /* %s */\n", this_proc_name);
+
+
+/* Write the #undefs for common variable reference */
+
+    if (usedefsforcommon) {
+       Extsym *ext;
+       int did_one = 0;
+
+       for (ext = extsymtab; ext < nextext; ext++)
+           if (ext -> extstg == STGCOMMON && ext -> used_here) {
+               ext -> used_here = 0;
+               if (!did_one)
+                   nice_printf (c_file, "\n");
+               wr_abbrevs(c_file, 0, ext->extp);
+               did_one = 1;
+               ext -> extp = CHNULL;
+           } /* if */
+
+       if (did_one)
+           nice_printf (c_file, "\n");
+    } /* if usedefsforcommon */
+
+    other_undefs(c_file);
+
+    wrote_one = 1;
+
+/* For debugging only */
+
+    if (debugflag && (pass1_file = fopen (p1_bakfile, binwrite)))
+       if (infile = fopen (p1_file, binread)) {
+           ffilecopy (infile, pass1_file);
+           fclose (infile);
+           fclose (pass1_file);
+       } /* if infile */
+
+/* End of "debugging only" */
+
+    scrub(p1_file);    /* optionally unlink */
+
+    if ((pass1_file = fopen (p1_file, binwrite)) == NULL)
+       err ("start_formatting:  couldn't reopen the pass1 file");
+
+} /* start_formatting */
+
+
+ static void
+put_semi(outfile)
+ FILE *outfile;
+{
+       nice_printf (outfile, ";\n");
+       last_was_label = 0;
+       }
+
+#define SEM_CHECK(x) if (last_was_label) put_semi(x)
+
+/* do_format -- takes an input stream (a file in pass1 format) and writes
+   the appropriate C code to   outfile   when possible.  When reading an
+   expression, the expression tree is returned instead. */
+
+static expptr do_format (infile, outfile)
+FILE *infile, *outfile;
+{
+    int token_type, was_c_token;
+    expptr retval = ENULL;
+
+    token_type = get_p1_token (infile);
+    was_c_token = 1;
+    switch (token_type) {
+       case P1_COMMENT:
+           do_p1_comment (infile, outfile);
+           was_c_token = 0;
+           break;
+       case P1_SET_LINE:
+           do_p1_set_line (infile);
+           was_c_token = 0;
+           break;
+       case P1_FILENAME:
+           p1gets(infile, filename, P1_FILENAME_MAX);
+           was_c_token = 0;
+           break;
+       case P1_NAME_POINTER:
+           retval = do_p1_name_pointer (infile);
+           break;
+       case P1_CONST:
+           retval = do_p1_const (infile);
+           break;
+       case P1_EXPR:
+           retval = do_p1_expr (infile, outfile);
+           break;
+       case P1_IDENT:
+           retval = do_p1_ident(infile);
+           break;
+       case P1_CHARP:
+               retval = do_p1_charp(infile);
+               break;
+       case P1_EXTERN:
+           retval = do_p1_extern (infile);
+           break;
+       case P1_HEAD:
+           gflag1 = 0;
+           retval = do_p1_head (infile, outfile);
+           gflag1 = gflag;
+           break;
+       case P1_LIST:
+           retval = do_p1_list (infile, outfile);
+           break;
+       case P1_LITERAL:
+           retval = do_p1_literal (infile);
+           break;
+       case P1_LABEL:
+           do_p1_label (infile, outfile);
+           /* last_was_label = 1; -- now set in do_p1_label */
+           was_c_token = 0;
+           break;
+       case P1_ASGOTO:
+           do_p1_asgoto (infile, outfile);
+           break;
+       case P1_GOTO:
+           do_p1_goto (infile, outfile);
+           break;
+       case P1_IF:
+           do_p1_if (infile, outfile);
+           break;
+       case P1_ELSE:
+           SEM_CHECK(outfile);
+           do_p1_else (outfile);
+           break;
+       case P1_ELIF:
+           SEM_CHECK(outfile);
+           do_p1_elif (infile, outfile);
+           break;
+       case P1_ENDIF:
+           SEM_CHECK(outfile);
+           do_p1_endif (outfile);
+           break;
+       case P1_ENDELSE:
+           SEM_CHECK(outfile);
+           do_p1_endelse (outfile);
+           break;
+       case P1_ADDR:
+           retval = do_p1_addr (infile, outfile);
+           break;
+       case P1_SUBR_RET:
+           do_p1_subr_ret (infile, outfile);
+           break;
+       case P1_COMP_GOTO:
+           do_p1_comp_goto (infile, outfile);
+           break;
+       case P1_FOR:
+           do_p1_for (infile, outfile);
+           break;
+       case P1_ENDFOR:
+           SEM_CHECK(outfile);
+           do_p1_end_for (outfile);
+           break;
+       case P1_WHILE1START:
+               do_p1_1while(outfile);
+               break;
+       case P1_WHILE2START:
+               do_p1_2while(infile, outfile);
+               break;
+       case P1_PROCODE:
+               procode(outfile);
+               break;
+       case P1_ELSEIFSTART:
+               SEM_CHECK(outfile);
+               do_p1_elseifstart(outfile);
+               break;
+       case P1_FORTRAN:
+               do_p1_fortran(infile, outfile);
+               /* no break; */
+       case P1_EOF:
+           was_c_token = 0;
+           break;
+       case P1_UNKNOWN:
+           Fatal("do_format:  Unknown token type in intermediate file");
+           break;
+       default:
+           Fatal("do_format:  Bad token type in intermediate file");
+           break;
+   } /* switch */
+
+    if (was_c_token)
+       last_was_label = 0;
+    return retval;
+} /* do_format */
+
+
+ static void
+do_p1_comment (infile, outfile)
+FILE *infile, *outfile;
+{
+    extern int c_output_line_length, in_comment;
+
+    char storage[COMMENT_BUFFER_SIZE + 1];
+    int length;
+
+    if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1))
+       return;
+
+    length = strlen (storage);
+
+    gflag1 = 0;
+    in_comment = 1;
+    if (length > c_output_line_length - 6)
+       margin_printf (outfile, "/*%s*/\n", storage);
+    else
+       margin_printf (outfile, length ? "/* %s */\n" : "\n", storage);
+    in_comment = 0;
+    gflag1 = gflag;
+} /* do_p1_comment */
+
+ static void
+do_p1_set_line (infile)
+FILE *infile;
+{
+    int status;
+    long new_line_number = -1;
+
+    status = p1getd (infile, &new_line_number);
+
+    if (status == EOF)
+       err ("do_p1_set_line:  Missing line number at end of file\n");
+    else if (status == 0 || new_line_number == -1)
+       errl("do_p1_set_line:  Illegal line number in intermediate file: %ld\n",
+               new_line_number);
+    else {
+       lineno = new_line_number;
+       }
+} /* do_p1_set_line */
+
+
+static expptr do_p1_name_pointer (infile)
+FILE *infile;
+{
+    Namep namep = (Namep) NULL;
+    int status;
+
+    status = p1getd (infile, (long *) &namep);
+
+    if (status == EOF)
+       err ("do_p1_name_pointer:  Missing pointer at end of file\n");
+    else if (status == 0 || namep == (Namep) NULL)
+       erri ("do_p1_name_pointer:  Illegal name pointer in p1 file: '%x'\n",
+               (int) namep);
+
+    return (expptr) namep;
+} /* do_p1_name_pointer */
+
+
+
+static expptr do_p1_const (infile)
+FILE *infile;
+{
+    struct Constblock *c = (struct Constblock *) NULL;
+    long type = -1;
+    int status;
+
+    status = p1getd (infile, &type);
+
+    if (status == EOF)
+       err ("do_p1_const:  Missing constant type at end of file\n");
+    else if (status == 0)
+       errl("do_p1_const:  Illegal constant type in p1 file: %ld\n", type);
+    else {
+       status = p1get_const (infile, (int)type, &c);
+
+       if (status == EOF) {
+           err ("do_p1_const:  Missing constant value at end of file\n");
+           c = (struct Constblock *) NULL;
+       } else if (status == 0) {
+           err ("do_p1_const:  Illegal constant value in p1 file\n");
+           c = (struct Constblock *) NULL;
+       } /* else */
+    } /* else */
+    return (expptr) c;
+} /* do_p1_const */
+
+
+static expptr do_p1_literal (infile)
+FILE *infile;
+{
+    int status;
+    long memno;
+    Addrp addrp;
+
+    status = p1getd (infile, &memno);
+
+    if (status == EOF)
+       err ("do_p1_literal:  Missing memno at end of file");
+    else if (status == 0)
+       err ("do_p1_literal:  Missing memno in p1 file");
+    else {
+       struct Literal *litp, *lastlit;
+
+       addrp = ALLOC (Addrblock);
+       addrp -> tag = TADDR;
+       addrp -> vtype = TYUNKNOWN;
+       addrp -> Field = NULL;
+
+       lastlit = litpool + nliterals;
+       for (litp = litpool; litp < lastlit; litp++)
+           if (litp -> litnum == memno) {
+               addrp -> vtype = litp -> littype;
+               *((union Constant *) &(addrp -> user)) =
+                       *((union Constant *) &(litp -> litval));
+               break;
+           } /* if litp -> litnum == memno */
+
+       addrp -> memno = memno;
+       addrp -> vstg = STGMEMNO;
+       addrp -> uname_tag = UNAM_CONST;
+    } /* else */
+
+    return (expptr) addrp;
+} /* do_p1_literal */
+
+
+static void do_p1_label (infile, outfile)
+FILE *infile, *outfile;
+{
+    int status;
+    ftnint stateno;
+    char *user_label ();
+    struct Labelblock *L;
+    char *fmt;
+
+    status = p1getd (infile, &stateno);
+
+    if (status == EOF)
+       err ("do_p1_label:  Missing label at end of file");
+    else if (status == 0)
+       err ("do_p1_label:  Missing label in p1 file ");
+    else if (stateno < 0) {    /* entry */
+       margin_printf(outfile, "\n%s:\n", user_label(stateno));
+       last_was_label = 1;
+       }
+    else {
+       L = labeltab + stateno;
+       if (L->labused) {
+               fmt = "%s:\n";
+               last_was_label = 1;
+               }
+       else
+               fmt = "/* %s: */\n";
+       margin_printf(outfile, fmt, user_label(L->stateno));
+    } /* else */
+} /* do_p1_label */
+
+
+
+static void do_p1_asgoto (infile, outfile)
+FILE *infile, *outfile;
+{
+    expptr expr;
+
+    expr = do_format (infile, outfile);
+    out_asgoto (outfile, expr);
+
+} /* do_p1_asgoto */
+
+
+static void do_p1_goto (infile, outfile)
+FILE *infile, *outfile;
+{
+    int status;
+    long stateno;
+    char *user_label ();
+
+    status = p1getd (infile, &stateno);
+
+    if (status == EOF)
+       err ("do_p1_goto:  Missing goto label at end of file");
+    else if (status == 0)
+       err ("do_p1_goto:  Missing goto label in p1 file");
+    else {
+       nice_printf (outfile, "goto %s;\n", user_label (stateno));
+    } /* else */
+} /* do_p1_goto */
+
+
+static void do_p1_if (infile, outfile)
+FILE *infile, *outfile;
+{
+    expptr cond;
+
+    do {
+        cond = do_format (infile, outfile);
+    } while (cond == ENULL);
+
+    out_if (outfile, cond);
+} /* do_p1_if */
+
+
+static void do_p1_else (outfile)
+FILE *outfile;
+{
+    out_else (outfile);
+} /* do_p1_else */
+
+
+static void do_p1_elif (infile, outfile)
+FILE *infile, *outfile;
+{
+    expptr cond;
+
+    do {
+        cond = do_format (infile, outfile);
+    } while (cond == ENULL);
+
+    elif_out (outfile, cond);
+} /* do_p1_elif */
+
+static void do_p1_endif (outfile)
+FILE *outfile;
+{
+    endif_out (outfile);
+} /* do_p1_endif */
+
+
+static void do_p1_endelse (outfile)
+FILE *outfile;
+{
+    end_else_out (outfile);
+} /* do_p1_endelse */
+
+
+static expptr do_p1_addr (infile, outfile)
+FILE *infile, *outfile;
+{
+    Addrp addrp = (Addrp) NULL;
+    int status;
+
+    status = p1getn (infile, (int)sizeof(struct Addrblock), (char **) &addrp);
+
+    if (status == EOF)
+       err ("do_p1_addr:  Missing Addrp at end of file");
+    else if (status == 0)
+       err ("do_p1_addr:  Missing Addrp in p1 file");
+    else if (addrp == (Addrp) NULL)
+       err ("do_p1_addr:  Null addrp in p1 file");
+    else if (addrp -> tag != TADDR)
+       erri ("do_p1_addr: bad tag in p1 file '%d'", addrp -> tag);
+    else {
+       addrp -> vleng = do_format (infile, outfile);
+       addrp -> memoffset = do_format (infile, outfile);
+    }
+
+    return (expptr) addrp;
+} /* do_p1_addr */
+
+
+
+static void do_p1_subr_ret (infile, outfile)
+FILE *infile, *outfile;
+{
+    expptr retval;
+
+    nice_printf (outfile, "return ");
+    retval = do_format (infile, outfile);
+    if (!multitype)
+       if (retval)
+               expr_out (outfile, retval);
+
+    nice_printf (outfile, ";\n");
+} /* do_p1_subr_ret */
+
+
+
+static void do_p1_comp_goto (infile, outfile)
+FILE *infile, *outfile;
+{
+    expptr index;
+    expptr labels;
+
+    index = do_format (infile, outfile);
+
+    if (index == ENULL) {
+       err ("do_p1_comp_goto:  no expression for computed goto");
+       return;
+    } /* if index == ENULL */
+
+    labels = do_format (infile, outfile);
+
+    if (labels && labels -> tag != TLIST)
+       erri ("do_p1_comp_goto:  expected list, got tag '%d'", labels -> tag);
+    else
+       compgoto_out (outfile, index, labels);
+} /* do_p1_comp_goto */
+
+
+static void do_p1_for (infile, outfile)
+FILE *infile, *outfile;
+{
+    expptr init, test, inc;
+
+    init = do_format (infile, outfile);
+    test = do_format (infile, outfile);
+    inc = do_format (infile, outfile);
+
+    out_for (outfile, init, test, inc);
+} /* do_p1_for */
+
+static void do_p1_end_for (outfile)
+FILE *outfile;
+{
+    out_end_for (outfile);
+} /* do_p1_end_for */
+
+
+ static void
+do_p1_fortran(infile, outfile)
+ FILE *infile, *outfile;
+{
+       char buf[P1_STMTBUFSIZE];
+       if (!p1gets(infile, buf, P1_STMTBUFSIZE))
+               return;
+       /* bypass nice_printf nonsense */
+       fprintf(outfile, "/*< %s >*/\n", buf+1);        /* + 1 to skip by '$' */
+       }
+
+
+static expptr do_p1_expr (infile, outfile)
+FILE *infile, *outfile;
+{
+    int status;
+    long opcode, type;
+    struct Exprblock *result = (struct Exprblock *) NULL;
+
+    status = p1getd (infile, &opcode);
+
+    if (status == EOF)
+       err ("do_p1_expr:  Missing expr opcode at end of file");
+    else if (status == 0)
+       err ("do_p1_expr:  Missing expr opcode in p1 file");
+    else {
+
+       status = p1getd (infile, &type);
+
+       if (status == EOF)
+           err ("do_p1_expr:  Missing expr type at end of file");
+       else if (status == 0)
+           err ("do_p1_expr:  Missing expr type in p1 file");
+       else if (opcode == 0)
+           return ENULL;
+       else {
+           result = ALLOC (Exprblock);
+
+           result -> tag = TEXPR;
+           result -> vtype = type;
+           result -> opcode = opcode;
+           result -> vleng = do_format (infile, outfile);
+
+           if (is_unary_op (opcode))
+               result -> leftp = do_format (infile, outfile);
+           else if (is_binary_op (opcode)) {
+               result -> leftp = do_format (infile, outfile);
+               result -> rightp = do_format (infile, outfile);
+           } else
+               errl("do_p1_expr:  Illegal opcode %ld", opcode);
+       } /* else */
+    } /* else */
+
+    return (expptr) result;
+} /* do_p1_expr */
+
+
+static expptr do_p1_ident(infile)
+FILE *infile;
+{
+       Addrp addrp;
+       int status;
+       long vtype, vstg;
+
+       addrp = ALLOC (Addrblock);
+       addrp -> tag = TADDR;
+
+       status = p1getd (infile, &vtype);
+       if (status == EOF)
+           err ("do_p1_ident:  Missing identifier type at end of file\n");
+       else if (status == 0 || vtype < 0 || vtype >= NTYPES)
+           errl("do_p1_ident:  Bad type in intermediate file: %ld\n", vtype);
+       else
+           addrp -> vtype = vtype;
+
+       status = p1getd (infile, &vstg);
+       if (status == EOF)
+           err ("do_p1_ident:  Missing identifier storage at end of file\n");
+       else if (status == 0 || vstg < 0 || vstg > STGNULL)
+           errl("do_p1_ident:  Bad storage in intermediate file: %ld\n", vtype);
+       else
+           addrp -> vstg = vstg;
+
+       status = p1gets(infile, addrp->user.ident, IDENT_LEN);
+
+       if (status == EOF)
+           err ("do_p1_ident:  Missing ident string at end of file");
+       else if (status == 0)
+           err ("do_p1_ident:  Missing ident string in intermediate file");
+       addrp->uname_tag = UNAM_IDENT;
+       return (expptr) addrp;
+} /* do_p1_ident */
+
+static expptr do_p1_charp(infile)
+FILE *infile;
+{
+       Addrp addrp;
+       int status;
+       long vtype, vstg;
+       char buf[64];
+
+       addrp = ALLOC (Addrblock);
+       addrp -> tag = TADDR;
+
+       status = p1getd (infile, &vtype);
+       if (status == EOF)
+           err ("do_p1_ident:  Missing identifier type at end of file\n");
+       else if (status == 0 || vtype < 0 || vtype >= NTYPES)
+           errl("do_p1_ident:  Bad type in intermediate file: %ld\n", vtype);
+       else
+           addrp -> vtype = vtype;
+
+       status = p1getd (infile, &vstg);
+       if (status == EOF)
+           err ("do_p1_ident:  Missing identifier storage at end of file\n");
+       else if (status == 0 || vstg < 0 || vstg > STGNULL)
+           errl("do_p1_ident:  Bad storage in intermediate file: %ld\n", vtype);
+       else
+           addrp -> vstg = vstg;
+
+       status = p1gets(infile, buf, (int)sizeof(buf));
+
+       if (status == EOF)
+           err ("do_p1_ident:  Missing charp ident string at end of file");
+       else if (status == 0)
+           err ("do_p1_ident:  Missing charp ident string in intermediate file");
+       addrp->uname_tag = UNAM_CHARP;
+       addrp->user.Charp = strcpy(mem(strlen(buf)+1,0), buf);
+       return (expptr) addrp;
+}
+
+
+static expptr do_p1_extern (infile)
+FILE *infile;
+{
+    Addrp addrp;
+
+    addrp = ALLOC (Addrblock);
+    if (addrp) {
+       int status;
+
+       addrp->tag = TADDR;
+       addrp->vstg = STGEXT;
+       addrp->uname_tag = UNAM_EXTERN;
+       status = p1getd (infile, &(addrp -> memno));
+       if (status == EOF)
+           err ("do_p1_extern:  Missing memno at end of file");
+       else if (status == 0)
+           err ("do_p1_extern:  Missing memno in intermediate file");
+       if (addrp->vtype = extsymtab[addrp->memno].extype)
+               addrp->vclass = CLPROC;
+    } /* if addrp */
+
+    return (expptr) addrp;
+} /* do_p1_extern */
+
+
+
+static expptr do_p1_head (infile, outfile)
+FILE *infile, *outfile;
+{
+    int status;
+    int add_n_;
+    long class;
+    char storage[256];
+
+    status = p1getd (infile, &class);
+    if (status == EOF)
+       err ("do_p1_head:  missing header class at end of file");
+    else if (status == 0)
+       err ("do_p1_head:  missing header class in p1 file");
+    else {
+       status = p1gets (infile, storage, (int)sizeof(storage));
+       if (status == EOF || status == 0)
+           storage[0] = '\0';
+    } /* else */
+
+    if (class == CLPROC || class == CLMAIN) {
+       chainp lengths;
+
+       add_n_ = nentry > 1;
+       lengths = length_comp(entries, add_n_);
+
+       if (!add_n_ && protofile && class != CLMAIN)
+               protowrite(protofile, proctype, storage, entries, lengths);
+
+       if (class == CLMAIN)
+           nice_printf (outfile, "/* Main program */ ");
+       else
+           nice_printf(outfile, "%s ", multitype ? "VOID"
+                       : c_type_decl(proctype, 1));
+
+       nice_printf(outfile, add_n_ ? "%s0_" : "%s", storage);
+       if (!Ansi) {
+               listargs(outfile, entries, add_n_, lengths);
+               nice_printf (outfile, "\n");
+               }
+       list_arg_types (outfile, entries, lengths, add_n_, "\n");
+       nice_printf (outfile, "{\n");
+       frchain(&lengths);
+       next_tab (outfile);
+       strcpy(this_proc_name, storage);
+       list_decls (outfile);
+
+    } else if (class == CLBLOCK)
+        next_tab (outfile);
+    else
+       errl("do_p1_head: got class %ld", class);
+
+    return NULL;
+} /* do_p1_head */
+
+
+static expptr do_p1_list (infile, outfile)
+FILE *infile, *outfile;
+{
+    long tag, type, count;
+    int status;
+    expptr result;
+
+    status = p1getd (infile, &tag);
+    if (status == EOF)
+       err ("do_p1_list:  missing list tag at end of file");
+    else if (status == 0)
+       err ("do_p1_list:  missing list tag in p1 file");
+    else {
+       status = p1getd (infile, &type);
+       if (status == EOF)
+           err ("do_p1_list:  missing list type at end of file");
+       else if (status == 0)
+           err ("do_p1_list:  missing list type in p1 file");
+       else {
+           status = p1getd (infile, &count);
+           if (status == EOF)
+               err ("do_p1_list:  missing count at end of file");
+           else if (status == 0)
+               err ("do_p1_list:  missing count in p1 file");
+       } /* else */
+    } /* else */
+
+    result = (expptr) ALLOC (Listblock);
+    if (result) {
+       chainp pointer;
+
+       result -> tag = tag;
+       result -> listblock.vtype = type;
+
+/* Assume there will be enough data */
+
+       if (count--) {
+           pointer = result->listblock.listp =
+               mkchain((char *)do_format(infile, outfile), CHNULL);
+           while (count--) {
+               pointer -> nextp =
+                       mkchain((char *)do_format(infile, outfile), CHNULL);
+               pointer = pointer -> nextp;
+           } /* while (count--) */
+       } /* if (count) */
+    } /* if (result) */
+
+    return result;
+} /* do_p1_list */
+
+
+chainp length_comp(e, add_n)   /* get lengths of characters args */
+ struct Entrypoint *e;
+ int add_n;
+{
+       chainp lengths;
+       chainp args, args1;
+       Namep arg, np;
+       int nchargs;
+       Argtypes *at;
+       Atype *a;
+       extern int init_ac[TYSUBR+1];
+
+       if (!e)
+               return 0;       /* possible only with errors */
+       args = args1 = add_n ? allargs : e->arglist;
+       nchargs = 0;
+       for (lengths = NULL; args; args = args -> nextp)
+               if (arg = (Namep)args->datap) {
+                       if (arg->vclass == CLUNKNOWN)
+                               arg->vclass = CLVAR;
+                       if (arg->vtype == TYCHAR && arg->vclass != CLPROC) {
+                               lengths = mkchain((char *)arg, lengths);
+                               nchargs++;
+                               }
+                       }
+       if (!add_n && (np = e->enamep)) {
+               /* one last check -- by now we know all we ever will
+                * about external args...
+                */
+               save_argtypes(e->arglist, &e->entryname->arginfo,
+                       &np->arginfo, 0, np->fvarname, STGEXT, nchargs,
+                       np->vtype, 1);
+               at = e->entryname->arginfo;
+               a = at->atypes + init_ac[np->vtype];
+               for(; args1; a++, args1 = args1->nextp) {
+                       frchain(&a->cp);
+                       if (arg = (Namep)args1->datap)
+                           switch(arg->vclass) {
+                               case CLPROC:
+                                       if (arg->vimpltype
+                                       && a->type >= 300)
+                                               a->type = TYUNKNOWN + 200;
+                                       break;
+                               case CLUNKNOWN:
+                                       a->type %= 100;
+                               }
+                       }
+               }
+       return revchain(lengths);
+       }
+
+void listargs(outfile, entryp, add_n_, lengths)
+ FILE *outfile;
+ struct Entrypoint *entryp;
+ int add_n_;
+ chainp lengths;
+{
+       chainp args;
+       char *s;
+       Namep arg;
+       int did_one = 0;
+
+       nice_printf (outfile, "(");
+
+       if (add_n_) {
+               nice_printf(outfile, "n__");
+               did_one = 1;
+               args = allargs;
+               }
+       else {
+               if (!entryp)
+                       return; /* possible only with errors */
+               args = entryp->arglist;
+               }
+
+       if (multitype)
+               {
+               nice_printf(outfile, ", ret_val");
+               did_one = 1;
+               args = allargs;
+               }
+       else if (ONEOF(proctype, MSKCOMPLEX|MSKCHAR))
+               {
+               s = xretslot[proctype]->user.ident;
+               nice_printf(outfile, did_one ? ", %s" : "%s",
+                       *s == '(' /*)*/ ? "r_v" : s);
+               did_one = 1;
+               if (proctype == TYCHAR)
+                       nice_printf (outfile, ", ret_val_len");
+               }
+       for (; args; args = args -> nextp)
+               if (arg = (Namep)args->datap) {
+                       nice_printf (outfile, "%s", did_one ? ", " : "");
+                       out_name (outfile, arg);
+                       did_one = 1;
+                       }
+
+       for (args = lengths; args; args = args -> nextp)
+               nice_printf(outfile, ", %s",
+                       new_arg_length((Namep)args->datap));
+       nice_printf (outfile, ")");
+} /* listargs */
+
+
+void list_arg_types(outfile, entryp, lengths, add_n_, finalnl)
+FILE *outfile;
+struct Entrypoint *entryp;
+chainp lengths;
+int add_n_;
+char *finalnl;
+{
+    chainp args;
+    int last_type = -1, last_class = -1;
+    int did_one = 0, done_one, is_ext;
+    char *s, *sep = "", *sep1;
+
+    if (outfile == (FILE *) NULL) {
+       err ("list_arg_types:  null output file");
+       return;
+    } else if (entryp == (struct Entrypoint *) NULL) {
+       err ("list_arg_types:  null procedure entry pointer");
+       return;
+    } /* else */
+
+    if (Ansi) {
+       done_one = 0;
+       sep1 = ", ";
+       nice_printf(outfile, "(" /*)*/);
+       }
+    else {
+       done_one = 1;
+       sep1 = ";\n";
+       }
+    args = entryp->arglist;
+    if (add_n_) {
+       nice_printf(outfile, "int n__");
+       did_one = done_one;
+       sep = sep1;
+       args = allargs;
+       }
+    if (multitype) {
+       nice_printf(outfile, "%sMultitype *ret_val", sep);
+       did_one = done_one;
+       sep = sep1;
+       }
+    else if (ONEOF (proctype, MSKCOMPLEX|MSKCHAR)) {
+       s = xretslot[proctype]->user.ident;
+       nice_printf(outfile, "%s%s *%s", sep, c_type_decl(proctype, 0),
+                       *s == '(' /*)*/ ? "r_v" : s);
+       did_one = done_one;
+       sep = sep1;
+       if (proctype == TYCHAR)
+           nice_printf (outfile, "%sftnlen ret_val_len", sep);
+    } /* if ONEOF proctype */
+    for (; args; args = args -> nextp) {
+       Namep arg = (Namep) args->datap;
+
+/* Scalars are passed by reference, and arrays will have their lower bound
+   adjusted, so nearly everything is printed with a star in front.  The
+   exception is character lengths, which are passed by value. */
+
+       if (arg) {
+           int type = arg -> vtype, class = arg -> vclass;
+
+           if (class == CLPROC)
+               if (arg->vimpltype)
+                       type = Castargs ? TYUNKNOWN : TYSUBR;
+               else if (type == TYREAL && forcedouble && !Castargs)
+                       type = TYDREAL;
+
+           if (type == last_type && class == last_class && did_one)
+               nice_printf (outfile, ", ");
+           else
+               if ((is_ext = class == CLPROC) && Castargs)
+                       nice_printf(outfile, "%s%s ", sep,
+                               usedcasts[type] = casttypes[type]);
+               else
+                       nice_printf(outfile, "%s%s ", sep,
+                               c_type_decl(type, is_ext));
+           if (class == CLPROC)
+               if (Castargs)
+                       out_name(outfile, arg);
+               else {
+                       nice_printf(outfile, "(*");
+                       out_name(outfile, arg);
+                       nice_printf(outfile, ") %s", parens);
+                       }
+           else {
+               nice_printf (outfile, "*");
+               out_name (outfile, arg);
+               }
+
+           last_type = type;
+           last_class = class;
+           did_one = done_one;
+           sep = sep1;
+       } /* if (arg) */
+    } /* for args = entryp -> arglist */
+
+    for (args = lengths; args; args = args -> nextp)
+       nice_printf(outfile, "%sftnlen %s", sep,
+                       new_arg_length((Namep)args->datap));
+    if (did_one)
+       nice_printf (outfile, ";\n");
+    else if (Ansi)
+       nice_printf(outfile,
+               /*((*/ sep != sep1 && Ansi == 1 ? "void)%s" : ")%s",
+               finalnl);
+} /* list_arg_types */
+
+ static void
+write_formats(outfile)
+ FILE *outfile;
+{
+       register struct Labelblock *lp;
+       int first = 1;
+       char *fs;
+
+       for(lp = labeltab ; lp < highlabtab ; ++lp)
+               if (lp->fmtlabused) {
+                       if (first) {
+                               first = 0;
+                               nice_printf(outfile, "/* Format strings */\n");
+                               }
+                       nice_printf(outfile, "static char fmt_%ld[] = \"",
+                               lp->stateno);
+                       if (!(fs = lp->fmtstring))
+                               fs = "";
+                       nice_printf(outfile, "%s\";\n", fs);
+                       }
+       if (!first)
+               nice_printf(outfile, "\n");
+       }
+
+ static void
+write_ioblocks(outfile)
+ FILE *outfile;
+{
+       register iob_data *L;
+       register char *f, **s, *sep;
+
+       nice_printf(outfile, "/* Fortran I/O blocks */\n");
+       L = iob_list = (iob_data *)revchain((chainp)iob_list);
+       do {
+               nice_printf(outfile, "static %s %s = { ",
+                       L->type, L->name);
+               sep = 0;
+               for(s = L->fields; f = *s; s++) {
+                       if (sep)
+                               nice_printf(outfile, sep);
+                       sep = ", ";
+                       if (*f == '"') {        /* kludge */
+                               nice_printf(outfile, "\"");
+                               nice_printf(outfile, "%s\"", f+1);
+                               }
+                       else
+                               nice_printf(outfile, "%s", f);
+                       }
+               nice_printf(outfile, " };\n");
+               }
+               while(L = L->next);
+       nice_printf(outfile, "\n\n");
+       }
+
+ static void
+write_assigned_fmts(outfile)
+ FILE *outfile;
+{
+       register chainp cp;
+       Namep np;
+       int did_one = 0;
+
+       cp = assigned_fmts = revchain(assigned_fmts);
+       nice_printf(outfile, "/* Assigned format variables */\nchar ");
+       do {
+               np = (Namep)cp->datap;
+               if (did_one)
+                       nice_printf(outfile, ", ");
+               did_one = 1;
+               nice_printf(outfile, "*%s_fmt", np->fvarname);
+               }
+               while(cp = cp->nextp);
+       nice_printf(outfile, ";\n\n");
+       }
+
+ static char *
+to_upper(s)
+ register char *s;
+{
+       static char buf[64];
+       register char *t = buf;
+       register int c;
+       while(*t++ = (c = *s++) >= 'a' && c <= 'z' ? c + 'A' - 'a' : c);
+       return buf;
+       }
+
+
+/* This routine creates static structures representing a namelist.
+   Declarations of the namelist and related structures are:
+
+       struct Vardesc {
+               char *name;
+               char *addr;
+               ftnlen *dims;   /* laid out as struct dimensions below *//*
+               int  type;
+               };
+       typedef struct Vardesc Vardesc;
+
+       struct Namelist {
+               char *name;
+               Vardesc **vars;
+               int nvars;
+               };
+
+       struct dimensions
+               {
+               ftnlen numberofdimensions;
+               ftnlen numberofelements
+               ftnlen baseoffset;
+               ftnlen span[numberofdimensions-1];
+               };
+
+   If dims is not null, then the corner element of the array is at
+   addr.  However,  the element with subscripts (i1,...,in) is at
+   addr + sizeoftype * (i1+span[0]*(i2+span[1]*...) - dimp->baseoffset)
+*/
+
+ static void
+write_namelists(nmch, outfile)
+ chainp nmch;
+ FILE *outfile;
+{
+       Namep var;
+       struct Hashentry *entry;
+       struct Dimblock *dimp;
+       int i, nd, type;
+       char *comma, *name;
+       register chainp q;
+       register Namep v;
+       extern int typeconv[];
+
+       nice_printf(outfile, "/* Namelist stuff */\n\n");
+       for (entry = hashtab; entry < lasthash; ++entry) {
+               if (!(v = entry->varp) || !v->vnamelist)
+                       continue;
+               type = v->vtype;
+               name = v->cvarname;
+               if (dimp = v->vdim) {
+                       nd = dimp->ndim;
+                       nice_printf(outfile,
+                               "static ftnlen %s_dims[] = { %d, %ld, %ld",
+                               name, nd,
+                               dimp->nelt->constblock.Const.ci,
+                               dimp->baseoffset->constblock.Const.ci);
+                       for(i = 0, --nd; i < nd; i++)
+                               nice_printf(outfile, ", %ld",
+                                 dimp->dims[i].dimsize->constblock.Const.ci);
+                       nice_printf(outfile, " };\n");
+                       }
+               nice_printf(outfile, "static Vardesc %s_dv = { \"%s\", %s",
+                       name, to_upper(v->fvarname),
+                       type == TYCHAR ? ""
+                               : (dimp || oneof_stg(v,v->vstg,
+                                       M(STGEQUIV)|M(STGCOMMON)))
+                               ? "(char *)" : "(char *)&");
+               out_name(outfile, v);
+               nice_printf(outfile, dimp ? ", %s_dims" : ", (ftnlen *)0", name);
+               nice_printf(outfile, ", %ld };\n",
+                       type != TYCHAR  ? (long)typeconv[type]
+                                       : -v->vleng->constblock.Const.ci);
+               }
+
+       do {
+               var = (Namep)nmch->datap;
+               name = var->cvarname;
+               nice_printf(outfile, "\nstatic Vardesc *%s_vl[] = ", name);
+               comma = "{";
+               i = 0;
+               for(q = var->varxptr.namelist ; q ; q = q->nextp) {
+                       v = (Namep)q->datap;
+                       if (!v->vnamelist)
+                               continue;
+                       i++;
+                       nice_printf(outfile, "%s &%s_dv", comma, v->cvarname);
+                       comma = ",";
+                       }
+               nice_printf(outfile, " };\n");
+               nice_printf(outfile,
+                       "static Namelist %s = { \"%s\", %s_vl, %d };\n",
+                       name, to_upper(var->fvarname), name, i);
+               }
+               while(nmch = nmch->nextp);
+       nice_printf(outfile, "\n");
+       }
+
+/* fixextype tries to infer from usage in previous procedures
+   the type of an external procedure declared
+   external and passed as an argument but never typed or invoked.
+ */
+
+ static int
+fixexttype(var)
+ Namep var;
+{
+       Extsym *e;
+       int type, type1;
+       extern void changedtype();
+
+       type = var->vtype;
+       e = &extsymtab[var->vardesc.varno];
+       if ((type1 = e->extype) && type == TYUNKNOWN)
+               return var->vtype = type1;
+       if (var->visused) {
+               if (e->exused && type != type1)
+                       changedtype(var);
+               e->exused = 1;
+               e->extype = type;
+               }
+       return type;
+       }
+
+ static void
+ref_defs(outfile, refdefs) FILE *outfile; chainp refdefs;
+{
+       chainp cp;
+       int eb, i, j, n;
+       struct Dimblock *dimp;
+       long L;
+       expptr b, vl;
+       Namep var;
+       char *amp, *comma;
+
+       ind_printf(0, outfile, "\n");
+       for(cp = refdefs = revchain(refdefs); cp; cp = cp->nextp) {
+               var = (Namep)cp->datap;
+               cp->datap = 0;
+               amp = "_subscr";
+               if (!(eb = var->vsubscrused)) {
+                       var->vrefused = 0;
+                       if (!ISCOMPLEX(var->vtype))
+                               amp = "_ref";
+                       }
+               def_start(outfile, var->cvarname, amp, CNULL);
+               dimp = var->vdim;
+               vl = 0;
+               comma = "(";
+               amp = "";
+               if (var->vtype == TYCHAR) {
+                       amp = "&";
+                       vl = var->vleng;
+                       if (ISCONST(vl) && vl->constblock.Const.ci == 1)
+                               vl = 0;
+                       nice_printf(outfile, "%sa_0", comma);
+                       comma = ",";
+                       }
+               n = dimp->ndim;
+               for(i = 1; i <= n; i++, comma = ",")
+                       nice_printf(outfile, "%sa_%d", comma, i);
+               nice_printf(outfile, ") %s", amp);
+               if (var->vsubscrused)
+                       var->vsubscrused = 0;
+               else if (!ISCOMPLEX(var->vtype)) {
+                       out_name(outfile, var);
+                       nice_printf(outfile, "[%s", vl ? "(" : "");
+                       }
+               for(j = 2; j < n; j++)
+                       nice_printf(outfile, "(");
+               while(--i > 1) {
+                       nice_printf(outfile, "(a_%d)%s*", i, i == n ? "" : ")");
+                       expr_out(outfile, cpexpr(dimp->dims[i-2].dimsize));
+                       nice_printf(outfile, " + ");
+                       }
+               nice_printf(outfile, "a_1");
+               if (var->vtype == TYCHAR) {
+                       if (vl) {
+                               nice_printf(outfile, ")*");
+                               expr_out(outfile, cpexpr(vl));
+                               }
+                       nice_printf(outfile, " + a_0");
+                       }
+               if (var->vstg != STGARG && (b = dimp->baseoffset)) {
+                       b = cpexpr(b);
+                       if (var->vtype == TYCHAR)
+                               b = mkexpr(OPSTAR, cpexpr(var->vleng), b);
+                       nice_printf(outfile, " - ");
+                       expr_out(outfile, b);
+                       }
+               if (ISCOMPLEX(var->vtype)) {
+                       ind_printf(0, outfile, "\n");
+                       def_start(outfile, var->cvarname, "_ref", CNULL);
+                       comma = "(";
+                       for(i = 1; i <= n; i++, comma = ",")
+                               nice_printf(outfile, "%sa_%d", comma, i);
+                       nice_printf(outfile, ") %s[%s_subscr",
+                               var->cvarname, var->cvarname);
+                       comma = "(";
+                       for(i = 1; i <= n; i++, comma = ",")
+                               nice_printf(outfile, "%sa_%d", comma, i);
+                       nice_printf(outfile, ")");
+                       }
+               ind_printf(0, outfile, "]\n" + eb);
+               }
+       nice_printf(outfile, "\n");
+       frchain(&refdefs);
+       }
+
+list_decls (outfile)
+FILE *outfile;
+{
+    extern chainp used_builtins;
+    extern struct Hashentry *hashtab;
+    extern ftnint wr_char_len();
+    struct Hashentry *entry;
+    int write_header = 1;
+    int last_class = -1, last_stg = -1;
+    Namep var;
+    int Alias, Define, did_one, last_type, type;
+    extern int def_equivs, useauto;
+    extern chainp new_vars;    /* Compiler-generated locals */
+    chainp namelists = 0, refdefs = 0;
+    char *ctype;
+    int useauto1 = useauto && !saveall;
+    long x;
+    extern int hsize;
+
+/* First write out the statically initialized data */
+
+    if (initfile)
+       list_init_data(&initfile, initfname, outfile);
+
+/* Next come formats */
+    write_formats(outfile);
+
+/* Now write out the system-generated identifiers */
+
+    if (new_vars || nequiv) {
+       chainp args, next_var, this_var;
+       chainp nv[TYVOID], nv1[TYVOID];
+       int i, j;
+       Addrp Var;
+       Namep arg;
+
+       /* zap unused dimension variables */
+
+       for(args = allargs; args; args = args->nextp) {
+               arg = (Namep)args->datap;
+               if (this_var = arg->vlastdim) {
+                       frexpr((tagptr)this_var->datap);
+                       this_var->datap = 0;
+                       }
+               }
+
+       /* sort new_vars by type, skipping entries just zapped */
+
+       for(i = TYADDR; i < TYVOID; i++)
+               nv[i] = 0;
+       for(this_var = new_vars; this_var; this_var = next_var) {
+               next_var = this_var->nextp;
+               if (Var = (Addrp)this_var->datap) {
+                       if (!(this_var->nextp = nv[j = Var->vtype]))
+                               nv1[j] = this_var;
+                       nv[j] = this_var;
+                       }
+               else {
+                       this_var->nextp = 0;
+                       frchain(&this_var);
+                       }
+               }
+       new_vars = 0;
+       for(i = TYVOID; --i >= TYADDR;)
+               if (this_var = nv[i]) {
+                       nv1[i]->nextp = new_vars;
+                       new_vars = this_var;
+                       }
+
+       /* write the declarations */
+
+       did_one = 0;
+       last_type = -1;
+
+       for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
+           Var = (Addrp) this_var->datap;
+
+           if (Var == (Addrp) NULL)
+               err ("list_decls:  null variable");
+           else if (Var -> tag != TADDR)
+               erri ("list_decls:  bad tag on new variable '%d'",
+                       Var -> tag);
+
+           type = nv_type (Var);
+           if (Var->vstg == STGINIT
+           ||  Var->uname_tag == UNAM_IDENT
+                       && *Var->user.ident == ' '
+                       && multitype)
+               continue;
+           if (!did_one)
+               nice_printf (outfile, "/* System generated locals */\n");
+
+           if (last_type == type && did_one)
+               nice_printf (outfile, ", ");
+           else {
+               if (did_one)
+                   nice_printf (outfile, ";\n");
+               nice_printf (outfile, "%s ",
+                       c_type_decl (type, Var -> vclass == CLPROC));
+           } /* else */
+
+/* Character type is really a string type.  Put out a '*' for parameters
+   with unknown length and functions returning character */
+
+           if (Var -> vtype == TYCHAR && (!ISICON ((Var -> vleng))
+                   || Var -> vclass == CLPROC))
+               nice_printf (outfile, "*");
+
+           write_nv_ident(outfile, (Addrp)this_var->datap);
+           if (Var -> vtype == TYCHAR && Var->vclass != CLPROC &&
+                   ISICON((Var -> vleng))
+                       && (i = Var->vleng->constblock.Const.ci) > 0)
+               nice_printf (outfile, "[%d]", i);
+
+           did_one = 1;
+           last_type = nv_type (Var);
+       } /* for this_var */
+
+/* Handle the uninitialized equivalences */
+
+       do_uninit_equivs (outfile, &did_one);
+
+       if (did_one)
+           nice_printf (outfile, ";\n\n");
+    } /* if new_vars */
+
+/* Write out builtin declarations */
+
+    if (used_builtins) {
+       chainp cp;
+       Extsym *es;
+
+       last_type = -1;
+       did_one = 0;
+
+       nice_printf (outfile, "/* Builtin functions */");
+
+       for (cp = used_builtins; cp; cp = cp -> nextp) {
+           Addrp e = (Addrp)cp->datap;
+
+           switch(type = e->vtype) {
+               case TYDREAL:
+               case TYREAL:
+                       /* if (forcedouble || e->dbl_builtin) */
+                       /* libF77 currently assumes everything double */
+                       type = TYDREAL;
+                       ctype = "double";
+                       break;
+               case TYCOMPLEX:
+               case TYDCOMPLEX:
+                       type = TYVOID;
+                       /* no break */
+               default:
+                       ctype = c_type_decl(type, 0);
+               }
+
+           if (did_one && last_type == type)
+               nice_printf(outfile, ", ");
+           else
+               nice_printf(outfile, "%s\n%s ", did_one ? ";" : "", ctype);
+
+           extern_out(outfile, es = &extsymtab[e -> memno]);
+           proto(outfile, es->arginfo, es->fextname);
+           last_type = type;
+           did_one = 1;
+       } /* for cp = used_builtins */
+
+       nice_printf (outfile, ";\n\n");
+    } /* if used_builtins */
+
+    last_type = -1;
+    for (entry = hashtab; entry < lasthash; ++entry) {
+       var = entry -> varp;
+
+       if (var) {
+           int procclass = var -> vprocclass;
+           char *comment = NULL;
+           int stg = var -> vstg;
+           int class = var -> vclass;
+           type = var -> vtype;
+
+           if (var->vrefused)
+               refdefs = mkchain((char *)var, refdefs);
+           if (var->vsubscrused)
+               if (ISCOMPLEX(var->vtype))
+                       var->vsubscrused = 0;
+               else
+                       refdefs = mkchain((char *)var, refdefs);
+           if (ONEOF(stg, M(STGARG)|M(STGLENG)|M(STGINIT)))
+               continue;
+
+           if (useauto1 && stg == STGBSS && !var->vsave)
+               stg = STGAUTO;
+
+           switch (class) {
+               case CLVAR:
+                   break;
+               case CLPROC:
+                   switch(procclass) {
+                       case PTHISPROC:
+                               extsymtab[var->vardesc.varno].extype = type;
+                               continue;
+                       case PSTFUNCT:
+                       case PINTRINSIC:
+                               continue;
+                       case PUNKNOWN:
+                               err ("list_decls:  unknown procedure class");
+                               continue;
+                       case PEXTERNAL:
+                               if (stg == STGUNKNOWN) {
+                                       warn1(
+                                       "%.64s declared EXTERNAL but never used.",
+                                               var->fvarname);
+                                       /* to retain names declared EXTERNAL */
+                                       /* but not referenced, change
+                                       /* "continue" to "stg = STGEXT" */
+                                       continue;
+                                       }
+                               else
+                                       type = fixexttype(var);
+                       }
+                   break;
+               case CLUNKNOWN:
+                       /* declared but never used */
+                       continue;
+               case CLPARAM:
+                       continue;
+               case CLNAMELIST:
+                       if (var->visused)
+                               namelists = mkchain((char *)var, namelists);
+                       continue;
+               default:
+                   erri("list_decls:  can't handle class '%d' yet",
+                           class);
+                   Fatal(var->fvarname);
+                   continue;
+           } /* switch */
+
+           /* Might be equivalenced to a common.  If not, don't process */
+           if (stg == STGCOMMON && !var->vcommequiv)
+               continue;
+
+/* Only write the header if system-generated locals, builtins, or
+   uninitialized equivs were already output */
+
+           if (write_header == 1 && (new_vars || nequiv || used_builtins)
+                   && oneof_stg ( var, stg,
+                   M(STGBSS)|M(STGEXT)|M(STGAUTO)|M(STGCOMMON)|M(STGEQUIV))) {
+               nice_printf (outfile, "/* Local variables */\n");
+               write_header = 2;
+               }
+
+
+           Alias = oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON));
+           if (Define = (Alias && def_equivs)) {
+               if (!write_header)
+                       nice_printf(outfile, ";\n");
+               def_start(outfile, var->cvarname, CNULL, "(");
+               goto Alias1;
+               }
+           else if (type == last_type && class == last_class &&
+                   stg == last_stg && !write_header)
+               nice_printf (outfile, ", ");
+           else {
+               if (!write_header && ONEOF(stg, M(STGBSS)|
+                   M(STGEXT)|M(STGAUTO)|M(STGEQUIV)|M(STGCOMMON)))
+                   nice_printf (outfile, ";\n");
+
+               switch (stg) {
+                   case STGARG:
+                   case STGLENG:
+                       /* Part of the argument list, don't write them out
+                          again */
+                       continue;           /* Go back to top of the loop */
+                   case STGBSS:
+                   case STGEQUIV:
+                   case STGCOMMON:
+                       nice_printf (outfile, "static ");
+                       break;
+                   case STGEXT:
+                       nice_printf (outfile, "extern ");
+                       break;
+                   case STGAUTO:
+                       break;
+                   case STGINIT:
+                   case STGUNKNOWN:
+                       /* Don't want to touch the initialized data, that will
+                          be handled elsewhere.  Unknown data have
+                          already been complained about, so skip them */
+                       continue;
+                   default:
+                       erri("list_decls:  can't handle storage class %d",
+                               stg);
+                       continue;
+               } /* switch */
+
+               if (type == TYCHAR && halign && class != CLPROC
+               && ISICON(var->vleng)) {
+                       nice_printf(outfile, "struct { %s fill; char val",
+                               halign);
+                       x = wr_char_len(outfile, var->vdim,
+                               var->vleng->constblock.Const.ci, 1);
+                       if (x %= hsize)
+                               nice_printf(outfile, "; char fill2[%ld]",
+                                       hsize - x);
+                       nice_printf(outfile, "; } %s_st;\n", var->cvarname);
+                       def_start(outfile, var->cvarname, CNULL, var->cvarname);
+                       ind_printf(0, outfile, "_st.val\n");
+                       last_type = -1;
+                       write_header = 2;
+                       continue;
+                       }
+               nice_printf(outfile, "%s ",
+                       c_type_decl(type, class == CLPROC));
+           } /* else */
+
+/* Character type is really a string type.  Put out a '*' for variable
+   length strings, and also for equivalences */
+
+           if (type == TYCHAR && class != CLPROC
+                   && (!var->vleng || !ISICON (var -> vleng))
+           || oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON)))
+               nice_printf (outfile, "*%s", var->cvarname);
+           else {
+               nice_printf (outfile, "%s", var->cvarname);
+               if (class == CLPROC) {
+                       Argtypes *at;
+                       if (!(at = var->arginfo)
+                        && var->vprocclass == PEXTERNAL)
+                               at = extsymtab[var->vardesc.varno].arginfo;
+                       proto(outfile, at, var->fvarname);
+                       }
+               else if (type == TYCHAR && ISICON ((var -> vleng)))
+                       wr_char_len(outfile, var->vdim,
+                               (int)var->vleng->constblock.Const.ci, 0);
+               else if (var -> vdim &&
+                   !oneof_stg (var, stg, M(STGEQUIV)|M(STGCOMMON)))
+                       comment = wr_ardecls(outfile, var->vdim, 1L);
+               }
+
+           if (comment)
+               nice_printf (outfile, "%s", comment);
+ Alias1:
+           if (Alias) {
+               char *amp, *lp, *name, *rp;
+               char *equiv_name ();
+               ftnint voff = var -> voffset;
+               int et0, expr_type, k;
+               Extsym *E;
+               struct Equivblock *eb;
+               char buf[16];
+
+/* We DON'T want to use oneof_stg here, because we need to distinguish
+   between them */
+
+               if (stg == STGEQUIV) {
+                       name = equiv_name(k = var->vardesc.varno, CNULL);
+                       eb = eqvclass + k;
+                       if (eb->eqvinit) {
+                               amp = "&";
+                               et0 = TYERROR;
+                               }
+                       else {
+                               amp = "";
+                               et0 = eb->eqvtype;
+                               }
+                       expr_type = et0;
+                   }
+               else {
+                       E = &extsymtab[var->vardesc.varno];
+                       sprintf(name = buf, "%s%d", E->cextname, E->curno);
+                       expr_type = type;
+                       et0 = -1;
+                       amp = "&";
+               } /* else */
+
+               if (!Define)
+                       nice_printf (outfile, " = ");
+               if (voff) {
+                       k = typesize[type];
+                       switch((int)(voff % k)) {
+                               case 0:
+                                       voff /= k;
+                                       expr_type = type;
+                                       break;
+                               case SZSHORT:
+                               case SZSHORT+SZLONG:
+                                       expr_type = TYSHORT;
+                                       voff /= SZSHORT;
+                                       break;
+                               case SZLONG:
+                                       expr_type = TYLONG;
+                                       voff /= SZLONG;
+                                       break;
+                               default:
+                                       expr_type = TYCHAR;
+                               }
+                       }
+
+               if (expr_type == type) {
+                       lp = rp = "";
+                       if (et0 == -1 && !voff)
+                               goto cast;
+                       }
+               else {
+                       lp = "(";
+                       rp = ")";
+ cast:
+                       nice_printf(outfile, "(%s *)", c_type_decl(type, 0));
+                       }
+
+/* Now worry about computing the offset */
+
+               if (voff) {
+                   if (expr_type == et0)
+                       nice_printf (outfile, "%s%s + %ld%s",
+                               lp, name, voff, rp);
+                   else
+                       nice_printf(outfile, "%s(%s *)%s%s + %ld%s", lp,
+                               c_type_decl (expr_type, 0), amp,
+                               name, voff, rp);
+               } else
+                   nice_printf(outfile, "%s%s", amp, name);
+/* Always put these at the end of the line */
+               last_type = last_class = last_stg = -1;
+               write_header = 0;
+               if (Define) {
+                       ind_printf(0, outfile, ")\n");
+                       write_header = 2;
+                       }
+               continue;
+               }
+           write_header = 0;
+           last_type = type;
+           last_class = class;
+           last_stg = stg;
+       } /* if (var) */
+    } /* for (entry = hashtab */
+
+    if (!write_header)
+       nice_printf (outfile, ";\n\n");
+    else if (write_header == 2)
+       nice_printf(outfile, "\n");
+
+/* Next, namelists, which may reference equivs */
+
+    if (namelists) {
+       write_namelists(namelists = revchain(namelists), outfile);
+       frchain(&namelists);
+       }
+
+/* Finally, ioblocks (which may reference equivs and namelists) */
+    if (iob_list)
+       write_ioblocks(outfile);
+    if (assigned_fmts)
+       write_assigned_fmts(outfile);
+
+    if (refdefs)
+       ref_defs(outfile, refdefs);
+
+} /* list_decls */
+
+do_uninit_equivs (outfile, did_one)
+FILE *outfile;
+int *did_one;
+{
+    extern int nequiv;
+    struct Equivblock *eqv, *lasteqv = eqvclass + nequiv;
+    int k, last_type = -1, t;
+
+    for (eqv = eqvclass; eqv < lasteqv; eqv++)
+       if (!eqv -> eqvinit && eqv -> eqvtop != eqv -> eqvbottom) {
+           if (!*did_one)
+               nice_printf (outfile, "/* System generated locals */\n");
+           t = eqv->eqvtype;
+           if (last_type == t)
+               nice_printf (outfile, ", ");
+           else {
+               if (*did_one)
+                   nice_printf (outfile, ";\n");
+               nice_printf (outfile, "static %s ", c_type_decl(t, 0));
+               k = typesize[t];
+           } /* else */
+           nice_printf(outfile, "%s", equiv_name((int)(eqv - eqvclass), CNULL));
+           nice_printf(outfile, "[%ld]",
+               (eqv->eqvtop - eqv->eqvbottom + k - 1) / k);
+           last_type = t;
+           *did_one = 1;
+       } /* if !eqv -> eqvinit */
+} /* do_uninit_equivs */
+
+
+/* wr_ardecls -- Writes the brackets and size for an array
+   declaration.  Because of the inner workings of the compiler,
+   multi-dimensional arrays get mapped directly into a one-dimensional
+   array, so we have to compute the size of the array here.  When the
+   dimension is greater than 1, a string comment about the original size
+   is returned */
+
+char *wr_ardecls(outfile, dimp, size)
+FILE *outfile;
+struct Dimblock *dimp;
+long size;
+{
+    int i, k;
+    static char buf[1000];
+
+    if (dimp == (struct Dimblock *) NULL)
+       return NULL;
+
+    sprintf(buf, "\t/* was "); /* would like to say  k = sprintf(...), but */
+    k = strlen(buf);           /* BSD doesn't return char transmitted count */
+
+    for (i = 0; i < dimp -> ndim; i++) {
+       expptr this_size = dimp -> dims[i].dimsize;
+
+       if (!ISICON (this_size))
+           err ("wr_ardecls:  nonconstant array size");
+       else {
+           size *= this_size -> constblock.Const.ci;
+           sprintf(buf+k, "[%ld]", this_size -> constblock.Const.ci);
+           k += strlen(buf+k); /* BSD prevents combining this with prev stmt */
+       } /* else */
+    } /* for i = 0 */
+
+    nice_printf (outfile, "[%ld]", size);
+    strcat(buf+k, " */");
+
+    return (i > 1) ? buf : NULL;
+} /* wr_ardecls */
+
+
+
+/* ----------------------------------------------------------------------
+
+       The following routines read from the p1 intermediate file.  If
+   that format changes, only these routines need be changed
+
+   ---------------------------------------------------------------------- */
+
+static int get_p1_token (infile)
+FILE *infile;
+{
+    int token = P1_UNKNOWN;
+
+/* NOT PORTABLE!! */
+
+    if (fscanf (infile, "%d", &token) == EOF)
+       return P1_EOF;
+
+/* Skip over the ": " */
+
+    if (getc (infile) != '\n')
+       getc (infile);
+
+    return token;
+} /* get_p1_token */
+
+
+
+/* Returns a (null terminated) string from the input file */
+
+static int p1gets (fp, str, size)
+FILE *fp;
+char *str;
+int size;
+{
+    char *fgets ();
+    char c;
+
+    if (str == NULL)
+       return 0;
+
+    if ((c = getc (fp)) != ' ')
+       ungetc (c, fp);
+
+    if (fgets (str, size, fp)) {
+       int length;
+
+       str[size - 1] = '\0';
+       length = strlen (str);
+
+/* Get rid of the newline */
+
+       if (str[length - 1] == '\n')
+           str[length - 1] = '\0';
+       return 1;
+
+    } else if (feof (fp))
+       return EOF;
+    else
+       return 0;
+} /* p1gets */
+
+
+static int p1get_const (infile, type, resultp)
+FILE *infile;
+int type;
+struct Constblock **resultp;
+{
+    int status;
+    struct Constblock *result;
+
+       if (type != TYCHAR) {
+               *resultp = result = ALLOC(Constblock);
+               result -> tag = TCONST;
+               result -> vtype = type;
+               }
+
+    switch (type) {
+       case TYINT1:
+        case TYSHORT:
+       case TYLONG:
+       case TYLOGICAL:
+#ifdef TYQUAD
+       case TYQUAD:
+#endif
+       case TYLOGICAL1:
+       case TYLOGICAL2:
+           status = p1getd (infile, &(result -> Const.ci));
+           break;
+       case TYREAL:
+       case TYDREAL:
+           status = p1getf(infile, &result->Const.cds[0]);
+           result->vstg = 1;
+           break;
+       case TYCOMPLEX:
+       case TYDCOMPLEX:
+           status = p1getf(infile, &result->Const.cds[0]);
+           if (status && status != EOF)
+               status = p1getf(infile, &result->Const.cds[1]);
+           result->vstg = 1;
+           break;
+       case TYCHAR:
+           status = fscanf(infile, "%lx", resultp);
+           break;
+       default:
+           erri ("p1get_const:  bad constant type '%d'", type);
+           status = 0;
+           break;
+    } /* switch */
+
+    return status;
+} /* p1get_const */
+
+static int p1getd (infile, result)
+FILE *infile;
+long *result;
+{
+    return fscanf (infile, "%ld", result);
+} /* p1getd */
+
+ static int
+p1getf(infile, result)
+ FILE *infile;
+ char **result;
+{
+
+       char buf[1324];
+       register int k;
+
+       k = fscanf (infile, "%s", buf);
+       if (k < 1)
+               k = EOF;
+       else
+               strcpy(*result = mem(strlen(buf)+1,0), buf);
+       return k;
+}
+
+static int p1getn (infile, count, result)
+FILE *infile;
+int count;
+char **result;
+{
+
+    char *bufptr;
+    extern ptr ckalloc ();
+
+    bufptr = (char *) ckalloc (count);
+
+    if (result)
+       *result = bufptr;
+
+    for (; !feof (infile) && count > 0; count--)
+       *bufptr++ = getc (infile);
+
+    return feof (infile) ? EOF : 1;
+} /* p1getn */
+
+ static void
+proto(outfile, at, fname)
+ FILE *outfile;
+ Argtypes *at;
+ char *fname;
+{
+       int i, j, k, n;
+       char *comma;
+       Atype *atypes;
+       Namep np;
+       chainp cp;
+       extern void bad_atypes();
+
+       if (at) {
+               /* Correct types that we learn on the fly, e.g.
+                       subroutine gotcha(foo)
+                       external foo
+                       call zap(...,foo,...)
+                       call foo(...)
+               */
+               atypes = at->atypes;
+               n = at->defined ? at->dnargs : at->nargs;
+               for(i = 0; i++ < n; atypes++) {
+                       if (!(cp = atypes->cp))
+                               continue;
+                       j = atypes->type;
+                       do {
+                               np = (Namep)cp->datap;
+                               k = np->vtype;
+                               if (np->vclass == CLPROC) {
+                                       if (!np->vimpltype && k)
+                                               k += 200;
+                                       else {
+                                               if (j >= 300)
+                                                       j = TYUNKNOWN + 200;
+                                               continue;
+                                               }
+                                       }
+                               if (j == k)
+                                       continue;
+                               if (j >= 300
+                               ||  j == 200 && k >= 200)
+                                       j = k;
+                               else {
+                                       if (at->nargs >= 0)
+                                          bad_atypes(at,fname,i,j,k,""," and");
+                                       goto break2;
+                                       }
+                               }
+                               while(cp = cp->nextp);
+                       atypes->type = j;
+                       frchain(&atypes->cp);
+                       }
+               }
+ break2:
+       if (parens) {
+               nice_printf(outfile, parens);
+               return;
+               }
+
+       if (!at || (n = at-> defined ? at->dnargs : at->nargs) < 0) {
+               nice_printf(outfile, Ansi == 1 ? "()" : "(...)");
+               return;
+               }
+
+       if (n == 0) {
+               nice_printf(outfile, Ansi == 1 ? "(void)" : "()");
+               return;
+               }
+
+       atypes = at->atypes;
+       nice_printf(outfile, "(");
+       comma = "";
+       for(; --n >= 0; atypes++) {
+               k = atypes->type;
+               if (k == TYADDR)
+                       nice_printf(outfile, "%schar **", comma);
+               else if (k >= 200) {
+                       k -= 200;
+                       nice_printf(outfile, "%s%s", comma,
+                               usedcasts[k] = casttypes[k]);
+                       }
+               else if (k >= 100)
+                       nice_printf(outfile,
+                                       k == TYCHAR + 100 ? "%s%s *" : "%s%s",
+                                       comma, c_type_decl(k-100, 0));
+               else
+                       nice_printf(outfile, "%s%s *", comma,
+                                       c_type_decl(k, 0));
+               comma = ", ";
+               }
+       nice_printf(outfile, ")");
+       }
+
+ void
+protowrite(protofile, type, name, e, lengths)
+ FILE *protofile;
+ char *name;
+ struct Entrypoint *e;
+ chainp lengths;
+{
+       extern char used_rets[];
+       int asave;
+
+       if (!(asave = Ansi))
+               Castargs = Ansi = 1;
+       nice_printf(protofile, "extern %s %s", protorettypes[type], name);
+       list_arg_types(protofile, e, lengths, 0, ";\n");
+       used_rets[type] = 1;
+       if (!(Ansi = asave))
+               Castargs = 0;
+       }
+
+ static void
+do_p1_1while(outfile)
+ FILE *outfile;
+{
+       if (*wh_next) {
+               nice_printf(outfile,
+                       "for(;;) { /* while(complicated condition) */\n" /*}*/ );
+               next_tab(outfile);
+               }
+       else
+               nice_printf(outfile, "while(" /*)*/ );
+       }
+
+ static void
+do_p1_2while(infile, outfile)
+ FILE *infile, *outfile;
+{
+       expptr test;
+
+       test = do_format(infile, outfile);
+       if (*wh_next)
+               nice_printf(outfile, "if (!(");
+       expr_out(outfile, test);
+       if (*wh_next++)
+               nice_printf(outfile, "))\n\tbreak;\n");
+       else {
+               nice_printf(outfile, /*(*/ ") {\n");
+               next_tab(outfile);
+               }
+       }
+
+ static void
+do_p1_elseifstart(outfile)
+ FILE *outfile;
+{
+       if (*ei_next++) {
+               prev_tab(outfile);
+               nice_printf(outfile, /*{*/
+                       "} else /* if(complicated condition) */ {\n" /*}*/ );
+               next_tab(outfile);
+               }
+       }

diff --git a/usr.bin/f2c/format.h b/usr.bin/f2c/format.h
new file mode 100644 (file)
index 0000000..a88c038
--- /dev/null
+++ b/usr.bin/f2c/format.h
@@ -0,0 +1,10 @@
+#define DEF_C_LINE_LENGTH 77
+/* actual max will be 79 */
+
+extern int c_output_line_length;       /* max # chars per line in C source
+                                          code */
+
+char *wr_ardecls (/* FILE *, struct Dimblock * */);
+void list_init_data (), wr_one_init (), wr_output_values ();
+int do_init_data ();
+chainp data_value ();

diff --git a/usr.bin/f2c/formatdata.c b/usr.bin/f2c/formatdata.c
new file mode 100644 (file)
index 0000000..541472a
--- /dev/null
+++ b/usr.bin/f2c/formatdata.c
@@ -0,0 +1,1081 @@
+/****************************************************************
+Copyright 1990, 1991, 1993 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "output.h"
+#include "names.h"
+#include "format.h"
+
+#define MAX_INIT_LINE 100
+#define NAME_MAX 64
+
+static int memno2info();
+
+extern char *initbname;
+extern void def_start();
+
+void list_init_data(Infile, Inname, outfile)
+ FILE **Infile, *outfile;
+ char *Inname;
+{
+    FILE *sortfp;
+    int status;
+
+    fclose(*Infile);
+    *Infile = 0;
+
+    if (status = dsort(Inname, sortfname))
+       fatali ("sort failed, status %d", status);
+
+    scrub(Inname); /* optionally unlink Inname */
+
+    if ((sortfp = fopen(sortfname, textread)) == NULL)
+       Fatal("Couldn't open sorted initialization data");
+
+    do_init_data(outfile, sortfp);
+    fclose(sortfp);
+    scrub(sortfname);
+
+/* Insert a blank line after any initialized data */
+
+       nice_printf (outfile, "\n");
+
+    if (debugflag && infname)
+        /* don't back block data file up -- it won't be overwritten */
+       backup(initfname, initbname);
+} /* list_init_data */
+
+
+
+/* do_init_data -- returns YES when at least one declaration has been
+   written */
+
+int do_init_data(outfile, infile)
+FILE *outfile, *infile;
+{
+    char varname[NAME_MAX], ovarname[NAME_MAX];
+    ftnint offset;
+    ftnint type;
+    int vargroup;      /* 0 --> init, 1 --> equiv, 2 --> common */
+    int did_one = 0;           /* True when one has been output */
+    chainp values = CHNULL;    /* Actual data values */
+    int keepit = 0;
+    Namep np;
+
+    ovarname[0] = '\0';
+
+    while (rdname (infile, &vargroup, varname) && rdlong (infile, &offset)
+           && rdlong (infile, &type)) {
+       if (strcmp (varname, ovarname)) {
+
+       /* If this is a new variable name, the old initialization has been
+          completed */
+
+               wr_one_init(outfile, ovarname, &values, keepit);
+
+               strcpy (ovarname, varname);
+               values = CHNULL;
+               if (vargroup == 0) {
+                       if (memno2info(atoi(varname+2), &np)) {
+                               if (((Addrp)np)->uname_tag != UNAM_NAME) {
+                                       err("do_init_data: expected NAME");
+                                       goto Keep;
+                                       }
+                               np = ((Addrp)np)->user.name;
+                               }
+                       if (!(keepit = np->visused) && !np->vimpldovar)
+                               warn1("local variable %s never used",
+                                       np->fvarname);
+                       }
+               else {
+ Keep:
+                       keepit = 1;
+                       }
+               if (keepit && !did_one) {
+                       nice_printf (outfile, "/* Initialized data */\n\n");
+                       did_one = YES;
+                       }
+       } /* if strcmp */
+
+       values = mkchain((char *)data_value(infile, offset, (int)type), values);
+    } /* while */
+
+/* Write out the last declaration */
+
+    wr_one_init (outfile, ovarname, &values, keepit);
+
+    return did_one;
+} /* do_init_data */
+
+
+ ftnint
+wr_char_len(outfile, dimp, n, extra1)
+ FILE *outfile;
+ int n;
+ struct Dimblock *dimp;
+ int extra1;
+{
+       int i, nd;
+       expptr e;
+       ftnint rv;
+
+       if (!dimp) {
+               nice_printf (outfile, extra1 ? "[%d+1]" : "[%d]", n);
+               return n + extra1;
+               }
+       nice_printf(outfile, "[%d", n);
+       nd = dimp->ndim;
+       rv = n;
+       for(i = 0; i < nd; i++) {
+               e = dimp->dims[i].dimsize;
+               if (!ISICON (e))
+                       err ("wr_char_len:  nonconstant array size");
+               else {
+                       nice_printf(outfile, "*%ld", e->constblock.Const.ci);
+                       rv *= e->constblock.Const.ci;
+                       }
+               }
+       /* extra1 allows for stupid C compilers that complain about
+        * too many initializers in
+        *      char x[2] = "ab";
+        */
+       nice_printf(outfile, extra1 ? "+1]" : "]");
+       return extra1 ? rv+1 : rv;
+       }
+
+ static int ch_ar_dim = -1; /* length of each element of char string array */
+ static int eqvmemno;  /* kludge */
+
+ static void
+write_char_init(outfile, Values, namep)
+ FILE *outfile;
+ chainp *Values;
+ Namep namep;
+{
+       struct Equivblock *eqv;
+       long size;
+       struct Dimblock *dimp;
+       int i, nd, type;
+       expptr ds;
+
+       if (!namep)
+               return;
+       if(nequiv >= maxequiv)
+               many("equivalences", 'q', maxequiv);
+       eqv = &eqvclass[nequiv];
+       eqv->eqvbottom = 0;
+       type = namep->vtype;
+       size = type == TYCHAR
+               ? namep->vleng->constblock.Const.ci
+               : typesize[type];
+       if (dimp = namep->vdim)
+               for(i = 0, nd = dimp->ndim; i < nd; i++) {
+                       ds = dimp->dims[i].dimsize;
+                       if (!ISICON(ds))
+                               err("write_char_values: nonconstant array size");
+                       else
+                               size *= ds->constblock.Const.ci;
+                       }
+       *Values = revchain(*Values);
+       eqv->eqvtop = size;
+       eqvmemno = ++lastvarno;
+       eqv->eqvtype = type;
+       wr_equiv_init(outfile, nequiv, Values, 0);
+       def_start(outfile, namep->cvarname, CNULL, "");
+       if (type == TYCHAR)
+               ind_printf(0, outfile, "((char *)&equiv_%d)\n\n", eqvmemno);
+       else
+               ind_printf(0, outfile, dimp
+                       ? "((%s *)&equiv_%d)\n\n" : "(*(%s *)&equiv_%d)\n\n",
+                       c_type_decl(type,0), eqvmemno);
+       }
+
+/* wr_one_init -- outputs the initialization of the variable pointed to
+   by   info.   When   is_addr   is true,   info   is an Addrp; otherwise,
+   treat it as a Namep */
+
+void wr_one_init (outfile, varname, Values, keepit)
+FILE *outfile;
+char *varname;
+chainp *Values;
+int keepit;
+{
+    static int memno;
+    static union {
+       Namep name;
+       Addrp addr;
+    } info;
+    Namep namep;
+    int is_addr, size, type;
+    ftnint last, loc;
+    int is_scalar = 0;
+    char *array_comment = NULL, *name;
+    chainp cp, values;
+    extern char datachar[];
+    static int e1[3] = {1, 0, 1};
+    ftnint x;
+    extern int hsize;
+
+    if (!keepit)
+       goto done;
+    if (varname == NULL || varname[1] != '.')
+       goto badvar;
+
+/* Get back to a meaningful representation; find the given   memno in one
+   of the appropriate tables (user-generated variables in the hash table,
+   system-generated variables in a separate list */
+
+    memno = atoi(varname + 2);
+    switch(varname[0]) {
+       case 'q':
+               /* Must subtract eqvstart when the source file
+                * contains more than one procedure.
+                */
+               wr_equiv_init(outfile, eqvmemno = memno - eqvstart, Values, 0);
+               goto done;
+       case 'Q':
+               /* COMMON initialization (BLOCK DATA) */
+               wr_equiv_init(outfile, memno, Values, 1);
+               goto done;
+       case 'v':
+               break;
+       default:
+ badvar:
+               errstr("wr_one_init:  unknown variable name '%s'", varname);
+               goto done;
+       }
+
+    is_addr = memno2info (memno, &info.name);
+    if (info.name == (Namep) NULL) {
+       err ("wr_one_init -- unknown variable");
+       return;
+       }
+    if (is_addr) {
+       if (info.addr -> uname_tag != UNAM_NAME) {
+           erri ("wr_one_init -- couldn't get name pointer; tag is %d",
+                   info.addr -> uname_tag);
+           namep = (Namep) NULL;
+           nice_printf (outfile, " /* bad init data */");
+       } else
+           namep = info.addr -> user.name;
+    } else
+       namep = info.name;
+
+       /* check for character initialization */
+
+    *Values = values = revchain(*Values);
+    type = info.name->vtype;
+    if (type == TYCHAR) {
+       for(last = 0; values; values = values->nextp) {
+               cp = (chainp)values->datap;
+               loc = (ftnint)cp->datap;
+               if (loc > last) {
+                       write_char_init(outfile, Values, namep);
+                       goto done;
+                       }
+               last = (int)cp->nextp->datap == TYBLANK
+                       ? loc + (int)cp->nextp->nextp->datap
+                       : loc + 1;
+               }
+       if (halign && info.name->tag == TNAME) {
+               nice_printf(outfile, "static struct { %s fill; char val",
+                       halign);
+               x = wr_char_len(outfile, namep->vdim, ch_ar_dim =
+                       info.name -> vleng -> constblock.Const.ci, 1);
+               if (x %= hsize)
+                       nice_printf(outfile, "; char fill2[%ld]", hsize - x);
+               name = info.name->cvarname;
+               nice_printf(outfile, "; } %s_st = { 0,", name);
+               wr_output_values(outfile, namep, *Values);
+               nice_printf(outfile, " };\n");
+               ch_ar_dim = -1;
+               def_start(outfile, name, CNULL, name);
+               ind_printf(0, outfile, "_st.val\n");
+               goto done;
+               }
+       }
+    else {
+       size = typesize[type];
+       loc = 0;
+       for(; values; values = values->nextp) {
+               if ((int)((chainp)values->datap)->nextp->datap == TYCHAR) {
+                       write_char_init(outfile, Values, namep);
+                       goto done;
+                       }
+               last = ((long) ((chainp) values->datap)->datap) / size;
+               if (last - loc > 4) {
+                       write_char_init(outfile, Values, namep);
+                       goto done;
+                       }
+               loc = last;
+               }
+       }
+    values = *Values;
+
+    nice_printf (outfile, "static %s ", c_type_decl (type, 0));
+
+    if (is_addr)
+       write_nv_ident (outfile, info.addr);
+    else
+       out_name (outfile, info.name);
+
+    if (namep)
+       is_scalar = namep -> vdim == (struct Dimblock *) NULL;
+
+    if (namep && !is_scalar)
+       array_comment = type == TYCHAR
+               ? 0 : wr_ardecls(outfile, namep->vdim, 1L);
+
+    if (type == TYCHAR)
+       if (ISICON (info.name -> vleng))
+
+/* We'll make single strings one character longer, so that we can use the
+   standard C initialization.  All this does is pad an extra zero onto the
+   end of the string */
+               wr_char_len(outfile, namep->vdim, ch_ar_dim =
+                       info.name -> vleng -> constblock.Const.ci, e1[Ansi]);
+       else
+               err ("variable length character initialization");
+
+    if (array_comment)
+       nice_printf (outfile, "%s", array_comment);
+
+    nice_printf (outfile, " = ");
+    wr_output_values (outfile, namep, values);
+    ch_ar_dim = -1;
+    nice_printf (outfile, ";\n");
+ done:
+    frchain(Values);
+} /* wr_one_init */
+
+
+
+
+chainp data_value (infile, offset, type)
+FILE *infile;
+ftnint offset;
+int type;
+{
+    char line[MAX_INIT_LINE + 1], *pointer;
+    chainp vals, prev_val;
+#ifndef atol
+    long atol();
+#endif
+    char *newval;
+
+    if (fgets (line, MAX_INIT_LINE, infile) == NULL) {
+       err ("data_value:  error reading from intermediate file");
+       return CHNULL;
+    } /* if fgets */
+
+/* Get rid of the trailing newline */
+
+    if (line[0])
+       line[strlen (line) - 1] = '\0';
+
+#define iswhite(x) (isspace (x) || (x) == ',')
+
+    pointer = line;
+    prev_val = vals = CHNULL;
+
+    while (*pointer) {
+       register char *end_ptr, old_val;
+
+/* Move   pointer   to the start of the next word */
+
+       while (*pointer && iswhite (*pointer))
+           pointer++;
+       if (*pointer == '\0')
+           break;
+
+/* Move   end_ptr   to the end of the current word */
+
+       for (end_ptr = pointer + 1; *end_ptr && !iswhite (*end_ptr);
+               end_ptr++)
+           ;
+
+       old_val = *end_ptr;
+       *end_ptr = '\0';
+
+/* Add this value to the end of the list */
+
+       if (ONEOF(type, MSKREAL|MSKCOMPLEX))
+               newval = cpstring(pointer);
+       else
+               newval = (char *)atol(pointer);
+       if (vals) {
+           prev_val->nextp = mkchain(newval, CHNULL);
+           prev_val = prev_val -> nextp;
+       } else
+           prev_val = vals = mkchain(newval, CHNULL);
+       *end_ptr = old_val;
+       pointer = end_ptr;
+    } /* while *pointer */
+
+    return mkchain((char *)offset, mkchain((char *)LONG_CAST type, vals));
+} /* data_value */
+
+ static void
+overlapping()
+{
+       extern char *filename0;
+       static int warned = 0;
+
+       if (warned)
+               return;
+       warned = 1;
+
+       fprintf(stderr, "Error");
+       if (filename0)
+               fprintf(stderr, " in file %s", filename0);
+       fprintf(stderr, ": overlapping initializations\n");
+       nerr++;
+       }
+
+ static void make_one_const();
+ static long charlen;
+
+void wr_output_values (outfile, namep, values)
+FILE *outfile;
+Namep namep;
+chainp values;
+{
+       int type = TYUNKNOWN;
+       struct Constblock Const;
+       static expptr Vlen;
+
+       if (namep)
+               type = namep -> vtype;
+
+/* Handle array initializations away from scalars */
+
+       if (namep && namep -> vdim)
+               wr_array_init (outfile, namep -> vtype, values);
+
+       else if (values->nextp && type != TYCHAR)
+               overlapping();
+
+       else {
+               make_one_const(type, &Const.Const, values);
+               Const.vtype = type;
+               Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0;
+               if (type== TYCHAR) {
+                       if (!Vlen)
+                               Vlen = ICON(0);
+                       Const.vleng = Vlen;
+                       Vlen->constblock.Const.ci = charlen;
+                       out_const (outfile, &Const);
+                       free (Const.Const.ccp);
+                       }
+               else
+                       out_const (outfile, &Const);
+               }
+       }
+
+
+wr_array_init (outfile, type, values)
+FILE *outfile;
+int type;
+chainp values;
+{
+    int size = typesize[type];
+    long index, main_index = 0;
+    int k;
+
+    if (type == TYCHAR) {
+       nice_printf(outfile, "\"");
+       k = 0;
+       if (Ansi != 1)
+               ch_ar_dim = -1;
+       }
+    else
+       nice_printf (outfile, "{ ");
+    while (values) {
+       struct Constblock Const;
+
+       index = ((long) ((chainp) values->datap)->datap) / size;
+       while (index > main_index) {
+
+/* Fill with zeros.  The structure shorthand works because the compiler
+   will expand the "0" in braces to fill the size of the entire structure
+   */
+
+           switch (type) {
+               case TYREAL:
+               case TYDREAL:
+                   nice_printf (outfile, "0.0,");
+                   break;
+               case TYCOMPLEX:
+               case TYDCOMPLEX:
+                   nice_printf (outfile, "{0},");
+                   break;
+               case TYCHAR:
+                       nice_printf(outfile, " ");
+                       break;
+               default:
+                   nice_printf (outfile, "0,");
+                   break;
+           } /* switch */
+           main_index++;
+       } /* while index > main_index */
+
+       if (index < main_index)
+               overlapping();
+       else switch (type) {
+           case TYCHAR:
+               { int this_char;
+
+               if (k == ch_ar_dim) {
+                       nice_printf(outfile, "\" \"");
+                       k = 0;
+                       }
+               this_char = (int) ((chainp) values->datap)->
+                               nextp->nextp->datap;
+               if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
+                       main_index += this_char;
+                       k += this_char;
+                       while(--this_char >= 0)
+                               nice_printf(outfile, " ");
+                       values = values -> nextp;
+                       continue;
+                       }
+               nice_printf(outfile, str_fmt[this_char], this_char);
+               k++;
+               } /* case TYCHAR */
+               break;
+
+           case TYINT1:
+           case TYSHORT:
+           case TYLONG:
+#ifdef TYQUAD
+           case TYQUAD:
+#endif
+           case TYREAL:
+           case TYDREAL:
+           case TYLOGICAL:
+           case TYLOGICAL1:
+           case TYLOGICAL2:
+           case TYCOMPLEX:
+           case TYDCOMPLEX:
+               make_one_const(type, &Const.Const, values);
+               Const.vtype = type;
+               Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0;
+               out_const(outfile, &Const);
+               break;
+           default:
+               erri("wr_array_init: bad type '%d'", type);
+               break;
+       } /* switch */
+       values = values->nextp;
+
+       main_index++;
+       if (values && type != TYCHAR)
+           nice_printf (outfile, ",");
+    } /* while values */
+
+    if (type == TYCHAR) {
+       nice_printf(outfile, "\"");
+       }
+    else
+       nice_printf (outfile, " }");
+} /* wr_array_init */
+
+
+ static void
+make_one_const(type, storage, values)
+ int type;
+ union Constant *storage;
+ chainp values;
+{
+    union Constant *Const;
+    register char **L;
+
+    if (type == TYCHAR) {
+       char *str, *str_ptr;
+       chainp v, prev;
+       int b = 0, k, main_index = 0;
+
+/* Find the max length of init string, by finding the highest offset
+   value stored in the list of initial values */
+
+       for(k = 1, prev = CHNULL, v = values; v; prev = v, v = v->nextp)
+           ;
+       if (prev != CHNULL)
+           k = ((int) (((chainp) prev->datap)->datap)) + 2;
+               /* + 2 above for null char at end */
+       str = Alloc (k);
+       for (str_ptr = str; values; str_ptr++) {
+           int index = (int) (((chainp) values->datap)->datap);
+
+           if (index < main_index)
+               overlapping();
+           while (index > main_index++)
+               *str_ptr++ = ' ';
+
+               k = (int) (((chainp) values->datap)->nextp->nextp->datap);
+               if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
+                       b = k;
+                       break;
+                       }
+               *str_ptr = k;
+               values = values -> nextp;
+       } /* for str_ptr */
+       *str_ptr = '\0';
+       Const = storage;
+       Const -> ccp = str;
+       Const -> ccp1.blanks = b;
+       charlen = str_ptr - str;
+    } else {
+       int i = 0;
+       chainp vals;
+
+       vals = ((chainp)values->datap)->nextp->nextp;
+       if (vals) {
+               L = (char **)storage;
+               do L[i++] = vals->datap;
+                       while(vals = vals->nextp);
+               }
+
+    } /* else */
+
+} /* make_one_const */
+
+
+
+rdname (infile, vargroupp, name)
+FILE *infile;
+int *vargroupp;
+char *name;
+{
+    register int i, c;
+
+    c = getc (infile);
+
+    if (feof (infile))
+       return NO;
+
+    *vargroupp = c - '0';
+    for (i = 1;; i++) {
+       if (i >= NAME_MAX)
+               Fatal("rdname: oversize name");
+       c = getc (infile);
+       if (feof (infile))
+           return NO;
+       if (c == '\t')
+               break;
+       *name++ = c;
+    }
+    *name = 0;
+    return YES;
+} /* rdname */
+
+rdlong (infile, n)
+FILE *infile;
+ftnint *n;
+{
+    register int c;
+
+    for (c = getc (infile); !feof (infile) && isspace (c); c = getc (infile))
+       ;
+
+    if (feof (infile))
+       return NO;
+
+    for (*n = 0; isdigit (c); c = getc (infile))
+       *n = 10 * (*n) + c - '0';
+    return YES;
+} /* rdlong */
+
+
+ static int
+memno2info (memno, info)
+ int memno;
+ Namep *info;
+{
+    chainp this_var;
+    extern chainp new_vars;
+    extern struct Hashentry *hashtab, *lasthash;
+    struct Hashentry *entry;
+
+    for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
+       Addrp var = (Addrp) this_var->datap;
+
+       if (var == (Addrp) NULL)
+           Fatal("memno2info:  null variable");
+       else if (var -> tag != TADDR)
+           Fatal("memno2info:  bad tag");
+       if (memno == var -> memno) {
+           *info = (Namep) var;
+           return 1;
+       } /* if memno == var -> memno */
+    } /* for this_var = new_vars */
+
+    for (entry = hashtab; entry < lasthash; ++entry) {
+       Namep var = entry -> varp;
+
+       if (var && var -> vardesc.varno == memno && var -> vstg == STGINIT) {
+           *info = (Namep) var;
+           return 0;
+       } /* if entry -> vardesc.varno == memno */
+    } /* for entry = hashtab */
+
+    Fatal("memno2info:  couldn't find memno");
+    return 0;
+} /* memno2info */
+
+ static chainp
+do_string(outfile, v, nloc)
+ FILEP outfile;
+ register chainp v;
+ ftnint *nloc;
+{
+       register chainp cp, v0;
+       ftnint dloc, k, loc;
+       unsigned long uk;
+       char buf[8], *comma;
+
+       nice_printf(outfile, "{");
+       cp = (chainp)v->datap;
+       loc = (ftnint)cp->datap;
+       comma = "";
+       for(v0 = v;;) {
+               switch((int)cp->nextp->datap) {
+                       case TYBLANK:
+                               k = (ftnint)cp->nextp->nextp->datap;
+                               loc += k;
+                               while(--k >= 0) {
+                                       nice_printf(outfile, "%s' '", comma);
+                                       comma = ", ";
+                                       }
+                               break;
+                       case TYCHAR:
+                               uk = (ftnint)cp->nextp->nextp->datap;
+                               sprintf(buf, chr_fmt[uk], uk);
+                               nice_printf(outfile, "%s'%s'", comma, buf);
+                               comma = ", ";
+                               loc++;
+                               break;
+                       default:
+                               goto done;
+                       }
+               v0 = v;
+               if (!(v = v->nextp))
+                       break;
+               cp = (chainp)v->datap;
+               dloc = (ftnint)cp->datap;
+               if (loc != dloc)
+                       break;
+               }
+ done:
+       nice_printf(outfile, "}");
+       *nloc = loc;
+       return v0;
+       }
+
+ static chainp
+Ado_string(outfile, v, nloc)
+ FILEP outfile;
+ register chainp v;
+ ftnint *nloc;
+{
+       register chainp cp, v0;
+       ftnint dloc, k, loc;
+
+       nice_printf(outfile, "\"");
+       cp = (chainp)v->datap;
+       loc = (ftnint)cp->datap;
+       for(v0 = v;;) {
+               switch((int)cp->nextp->datap) {
+                       case TYBLANK:
+                               k = (ftnint)cp->nextp->nextp->datap;
+                               loc += k;
+                               while(--k >= 0)
+                                       nice_printf(outfile, " ");
+                               break;
+                       case TYCHAR:
+                               k = (ftnint)cp->nextp->nextp->datap;
+                               nice_printf(outfile, str_fmt[k], k);
+                               loc++;
+                               break;
+                       default:
+                               goto done;
+                       }
+               v0 = v;
+               if (!(v = v->nextp))
+                       break;
+               cp = (chainp)v->datap;
+               dloc = (ftnint)cp->datap;
+               if (loc != dloc)
+                       break;
+               }
+ done:
+       nice_printf(outfile, "\"");
+       *nloc = loc;
+       return v0;
+       }
+
+ static char *
+Len(L,type)
+ long L;
+ int type;
+{
+       static char buf[24];
+       if (L == 1 && type != TYCHAR)
+               return "";
+       sprintf(buf, "[%ld]", L);
+       return buf;
+       }
+
+wr_equiv_init(outfile, memno, Values, iscomm)
+ FILE *outfile;
+ int memno;
+ chainp *Values;
+ int iscomm;
+{
+       struct Equivblock *eqv;
+       char *equiv_name ();
+       int btype, curtype, dtype, filltype, filltype1, j, k, wasblank, xtype;
+       static char Blank[] = "";
+       register char *comma = Blank;
+       register chainp cp, v;
+       chainp sentinel, values, v1, vlast;
+       ftnint L, L1, dL, dloc, loc, loc0;
+       union Constant Const;
+       char imag_buf[50], real_buf[50];
+       int szshort = typesize[TYSHORT];
+       static char typepref[] = {0, 0, TYINT1, TYSHORT, TYLONG,
+#ifdef TYQUAD
+                                 TYQUAD,
+#endif
+                                 TYREAL, TYDREAL, TYREAL, TYDREAL,
+                                 TYLOGICAL1, TYLOGICAL2,
+                                 TYLOGICAL, TYCHAR};
+       static char basetype[] = {0, 0, TYCHAR, TYSHORT, TYLONG,
+#ifdef TYQUAD
+                                 TYDREAL,
+#endif
+                                 TYLONG, TYDREAL, TYLONG, TYDREAL,
+                                 TYCHAR, TYSHORT,
+                                 TYLONG, TYCHAR};
+       extern int htype;
+       char *z;
+
+       /* add sentinel */
+       if (iscomm) {
+               L = extsymtab[memno].maxleng;
+               xtype = extsymtab[memno].extype;
+               }
+       else {
+               eqv = &eqvclass[memno];
+               L = eqv->eqvtop - eqv->eqvbottom;
+               xtype = eqv->eqvtype;
+               }
+
+       if (halign && typealign[typepref[xtype]] < typealign[htype])
+               xtype = htype;
+       *Values = values = revchain(vlast = *Values);
+
+       if (xtype != TYCHAR) {
+
+               /* unless the data include a value of the appropriate
+                * type, we add an extra element in an attempt
+                * to force correct alignment */
+
+               btype = basetype[xtype];
+               loc = 0;
+               for(v = *Values;;v = v->nextp) {
+                       if (!v) {
+                               dtype = typepref[xtype];
+                               z = ISREAL(dtype) ? cpstring("0.") : (char *)0;
+                               k = typesize[dtype];
+                               if (j = L % k)
+                                       L += k - j;
+                               v = mkchain((char *)L,
+                                       mkchain((char *)LONG_CAST dtype,
+                                               mkchain(z, CHNULL)));
+                               vlast = vlast->nextp =
+                                       mkchain((char *)v, CHNULL);
+                               L += k;
+                               break;
+                               }
+                       cp = (chainp)v->datap;
+                       if (basetype[(int)cp->nextp->datap] == btype)
+                               break;
+                       dloc = (ftnint)cp->datap;
+                       L1 = dloc - loc;
+                       if (L1 > 0
+                        && !(L1 % szshort)
+                        && !(loc % szshort)
+                        && btype <= type_choice[L1/szshort % 4]
+                        && btype <= type_choice[loc/szshort % 4])
+                               break;
+                       dtype = (int)cp->nextp->datap;
+                       loc = dloc + dtype == TYBLANK
+                                       ? (ftnint)cp->nextp->nextp->datap
+                                       : typesize[dtype];
+                       }
+               }
+       sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL));
+       vlast->nextp = mkchain((char *)sentinel, CHNULL);
+
+       /* use doublereal fillers only if there are doublereal values */
+
+       k = TYLONG;
+       for(v = values; v; v = v->nextp)
+               if (ONEOF((int)((chainp)v->datap)->nextp->datap,
+                               M(TYDREAL)|M(TYDCOMPLEX))) {
+                       k = TYDREAL;
+                       break;
+                       }
+       type_choice[0] = k;
+
+       nice_printf(outfile, "%sstruct {\n", iscomm ? "" : "static ");
+       next_tab(outfile);
+       loc = loc0 = k = 0;
+       curtype = -1;
+       for(v = values; v; v = v->nextp) {
+               cp = (chainp)v->datap;
+               dloc = (ftnint)cp->datap;
+               L = dloc - loc;
+               if (L < 0) {
+                       overlapping();
+                       if ((int)cp->nextp->datap != TYERROR) {
+                               v1 = cp;
+                               frchain(&v1);
+                               v->datap = 0;
+                               }
+                       continue;
+                       }
+               dtype = (int)cp->nextp->datap;
+               if (dtype == TYBLANK) {
+                       dtype = TYCHAR;
+                       wasblank = 1;
+                       }
+               else
+                       wasblank = 0;
+               if (curtype != dtype || L > 0) {
+                       if (curtype != -1) {
+                               L1 = (loc - loc0)/dL;
+                               nice_printf(outfile, "%s e_%d%s;\n",
+                                       typename[curtype], ++k,
+                                       Len(L1,curtype));
+                               }
+                       curtype = dtype;
+                       loc0 = dloc;
+                       }
+               if (L > 0) {
+                       if (xtype == TYCHAR)
+                               filltype = TYCHAR;
+                       else {
+                               filltype = L % szshort ? TYCHAR
+                                               : type_choice[L/szshort % 4];
+                               filltype1 = loc % szshort ? TYCHAR
+                                               : type_choice[loc/szshort % 4];
+                               if (typesize[filltype] > typesize[filltype1])
+                                       filltype = filltype1;
+                               }
+                       L1 = L / typesize[filltype];
+                       nice_printf(outfile, "%s fill_%d[%ld];\n",
+                               typename[filltype], ++k, L1);
+                       loc = dloc;
+                       }
+               if (wasblank) {
+                       loc += (ftnint)cp->nextp->nextp->datap;
+                       dL = 1;
+                       }
+               else {
+                       dL = typesize[dtype];
+                       loc += dL;
+                       }
+               }
+       nice_printf(outfile, "} %s = { ", iscomm
+               ? extsymtab[memno].cextname
+               : equiv_name(eqvmemno, CNULL));
+       loc = 0;
+       for(v = values; ; v = v->nextp) {
+               cp = (chainp)v->datap;
+               if (!cp)
+                       continue;
+               dtype = (int)cp->nextp->datap;
+               if (dtype == TYERROR)
+                       break;
+               dloc = (ftnint)cp->datap;
+               if (dloc > loc) {
+                       nice_printf(outfile, "%s{0}", comma);
+                       comma = ", ";
+                       loc = dloc;
+                       }
+               if (comma != Blank)
+                       nice_printf(outfile, ", ");
+               comma = ", ";
+               if (dtype == TYCHAR || dtype == TYBLANK) {
+                       v =  Ansi == 1  ? Ado_string(outfile, v, &loc)
+                                       :  do_string(outfile, v, &loc);
+                       continue;
+                       }
+               make_one_const(dtype, &Const, v);
+               switch(dtype) {
+                       case TYLOGICAL:
+                       case TYLOGICAL2:
+                       case TYLOGICAL1:
+                               if (Const.ci < 0 || Const.ci > 1)
+                                       errl(
+                         "wr_equiv_init: unexpected logical value %ld",
+                                               Const.ci);
+                               nice_printf(outfile,
+                                       Const.ci ? "TRUE_" : "FALSE_");
+                               break;
+                       case TYINT1:
+                       case TYSHORT:
+                       case TYLONG:
+#ifdef TYQUAD
+                       case TYQUAD:
+#endif
+                               nice_printf(outfile, "%ld", Const.ci);
+                               break;
+                       case TYREAL:
+                               nice_printf(outfile, "%s",
+                                       flconst(real_buf, Const.cds[0]));
+                               break;
+                       case TYDREAL:
+                               nice_printf(outfile, "%s", Const.cds[0]);
+                               break;
+                       case TYCOMPLEX:
+                               nice_printf(outfile, "%s, %s",
+                                       flconst(real_buf, Const.cds[0]),
+                                       flconst(imag_buf, Const.cds[1]));
+                               break;
+                       case TYDCOMPLEX:
+                               nice_printf(outfile, "%s, %s",
+                                       Const.cds[0], Const.cds[1]);
+                               break;
+                       default:
+                               erri("unexpected type %d in wr_equiv_init",
+                                       dtype);
+                       }
+               loc += typesize[dtype];
+               }
+       nice_printf(outfile, " };\n\n");
+       prev_tab(outfile);
+       frchain(&sentinel);
+       }

diff --git a/usr.bin/f2c/ftypes.h b/usr.bin/f2c/ftypes.h
new file mode 100644 (file)
index 0000000..80d2deb
--- /dev/null
+++ b/usr.bin/f2c/ftypes.h
@@ -0,0 +1,51 @@
+
+/* variable types (stored in the   vtype  field of   expptr)
+ * numeric assumptions:
+ *     int < reals < complexes
+ *     TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX
+ */
+
+#ifdef NO_TYQUAD
+#undef TYQUAD
+#define TYQUAD_inc 0
+#else
+#define TYQUAD 5
+#define TYQUAD_inc 1
+#endif
+
+#define TYUNKNOWN 0
+#define TYADDR 1
+#define TYINT1 2
+#define TYSHORT 3
+#define TYLONG 4
+/* #define TYQUAD 5 */
+#define TYREAL (5+TYQUAD_inc)
+#define TYDREAL (6+TYQUAD_inc)
+#define TYCOMPLEX (7+TYQUAD_inc)
+#define TYDCOMPLEX (8+TYQUAD_inc)
+#define TYLOGICAL1 (9+TYQUAD_inc)
+#define TYLOGICAL2 (10+TYQUAD_inc)
+#define TYLOGICAL (11+TYQUAD_inc)
+#define TYCHAR (12+TYQUAD_inc)
+#define TYSUBR (13+TYQUAD_inc)
+#define TYERROR (14+TYQUAD_inc)
+#define TYCILIST (15+TYQUAD_inc)
+#define TYICILIST (16+TYQUAD_inc)
+#define TYOLIST (17+TYQUAD_inc)
+#define TYCLLIST (18+TYQUAD_inc)
+#define TYALIST (19+TYQUAD_inc)
+#define TYINLIST (20+TYQUAD_inc)
+#define TYVOID (21+TYQUAD_inc)
+#define TYLABEL (22+TYQUAD_inc)
+#define TYFTNLEN (23+TYQUAD_inc)
+/* TYVOID is not in any tables. */
+
+/* NTYPES, NTYPES0 -- Total number of types, used to allocate tables indexed by
+   type.  Such tables can include the size (in bytes) of objects of a given
+   type, or labels for returning objects of different types from procedures
+   (see array   rtvlabels)   */
+
+#define NTYPES TYVOID
+#define NTYPES0 TYCILIST
+#define TYBLANK TYSUBR         /* Huh? */
+

diff --git a/usr.bin/f2c/gram.c b/usr.bin/f2c/gram.c
new file mode 100644 (file)
index 0000000..99ac190
--- /dev/null
+++ b/usr.bin/f2c/gram.c
@@ -0,0 +1,1829 @@
+# define SEOS 1
+# define SCOMMENT 2
+# define SLABEL 3
+# define SUNKNOWN 4
+# define SHOLLERITH 5
+# define SICON 6
+# define SRCON 7
+# define SDCON 8
+# define SBITCON 9
+# define SOCTCON 10
+# define SHEXCON 11
+# define STRUE 12
+# define SFALSE 13
+# define SNAME 14
+# define SNAMEEQ 15
+# define SFIELD 16
+# define SSCALE 17
+# define SINCLUDE 18
+# define SLET 19
+# define SASSIGN 20
+# define SAUTOMATIC 21
+# define SBACKSPACE 22
+# define SBLOCK 23
+# define SCALL 24
+# define SCHARACTER 25
+# define SCLOSE 26
+# define SCOMMON 27
+# define SCOMPLEX 28
+# define SCONTINUE 29
+# define SDATA 30
+# define SDCOMPLEX 31
+# define SDIMENSION 32
+# define SDO 33
+# define SDOUBLE 34
+# define SELSE 35
+# define SELSEIF 36
+# define SEND 37
+# define SENDFILE 38
+# define SENDIF 39
+# define SENTRY 40
+# define SEQUIV 41
+# define SEXTERNAL 42
+# define SFORMAT 43
+# define SFUNCTION 44
+# define SGOTO 45
+# define SASGOTO 46
+# define SCOMPGOTO 47
+# define SARITHIF 48
+# define SLOGIF 49
+# define SIMPLICIT 50
+# define SINQUIRE 51
+# define SINTEGER 52
+# define SINTRINSIC 53
+# define SLOGICAL 54
+# define SNAMELIST 55
+# define SOPEN 56
+# define SPARAM 57
+# define SPAUSE 58
+# define SPRINT 59
+# define SPROGRAM 60
+# define SPUNCH 61
+# define SREAD 62
+# define SREAL 63
+# define SRETURN 64
+# define SREWIND 65
+# define SSAVE 66
+# define SSTATIC 67
+# define SSTOP 68
+# define SSUBROUTINE 69
+# define STHEN 70
+# define STO 71
+# define SUNDEFINED 72
+# define SWRITE 73
+# define SLPAR 74
+# define SRPAR 75
+# define SEQUALS 76
+# define SCOLON 77
+# define SCOMMA 78
+# define SCURRENCY 79
+# define SPLUS 80
+# define SMINUS 81
+# define SSTAR 82
+# define SSLASH 83
+# define SPOWER 84
+# define SCONCAT 85
+# define SAND 86
+# define SOR 87
+# define SNEQV 88
+# define SEQV 89
+# define SNOT 90
+# define SEQ 91
+# define SLT 92
+# define SGT 93
+# define SLE 94
+# define SGE 95
+# define SNE 96
+# define SENDDO 97
+# define SWHILE 98
+# define SSLASHD 99
+
+/* # line 124 "gram.in" */
+#include "defs.h"
+#include "p1defs.h"
+
+static int nstars;                     /* Number of labels in an
+                                          alternate return CALL */
+static int datagripe;
+static int ndim;
+static int vartype;
+int new_dcl;
+static ftnint varleng;
+static struct Dims dims[MAXDIM+1];
+extern struct Labelblock **labarray;   /* Labels in an alternate
+                                                  return CALL */
+extern int maxlablist;
+
+/* The next two variables are used to verify that each statement might be reached
+   during runtime.   lastwasbranch   is tested only in the defintion of the
+   stat:   nonterminal. */
+
+int lastwasbranch = NO;
+static int thiswasbranch = NO;
+extern ftnint yystno;
+extern flag intonly;
+static chainp datastack;
+extern long laststfcn, thisstno;
+extern int can_include;        /* for netlib */
+
+ftnint convci();
+Addrp nextdata();
+expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon();
+expptr mkcxcon();
+struct Listblock *mklist();
+struct Listblock *mklist();
+struct Impldoblock *mkiodo();
+Extsym *comblock();
+#define ESNULL (Extsym *)0
+#define NPNULL (Namep)0
+#define LBNULL (struct Listblock *)0
+extern void freetemps(), make_param();
+
+ static void
+pop_datastack() {
+       chainp d0 = datastack;
+       if (d0->datap)
+               curdtp = (chainp)d0->datap;
+       datastack = d0->nextp;
+       d0->nextp = 0;
+       frchain(&d0);
+       }
+
+
+/* # line 178 "gram.in" */
+typedef union  {
+       int ival;
+       ftnint lval;
+       char *charpval;
+       chainp chval;
+       tagptr tagval;
+       expptr expval;
+       struct Labelblock *labval;
+       struct Nameblock *namval;
+       struct Eqvchain *eqvval;
+       Extsym *extval;
+       } YYSTYPE;
+#define yyclearin yychar = -1
+#define yyerrok yyerrflag = 0
+extern int yychar;
+typedef int yytabelem;
+extern yytabelem yyerrflag;
+#ifndef YYMAXDEPTH
+#define YYMAXDEPTH 150
+#endif
+YYSTYPE yylval, yyval;
+# define YYERRCODE 256
+yytabelem yyexca[] ={
+-1, 1,
+       0, -1,
+       -2, 0,
+-1, 20,
+       1, 38,
+       -2, 228,
+-1, 24,
+       1, 42,
+       -2, 228,
+-1, 122,
+       6, 240,
+       -2, 228,
+-1, 150,
+       1, 244,
+       -2, 188,
+-1, 174,
+       1, 265,
+       78, 265,
+       -2, 188,
+-1, 223,
+       77, 173,
+       -2, 139,
+-1, 245,
+       74, 228,
+       -2, 225,
+-1, 271,
+       1, 286,
+       -2, 143,
+-1, 275,
+       1, 295,
+       78, 295,
+       -2, 145,
+-1, 328,
+       77, 174,
+       -2, 141,
+-1, 358,
+       1, 267,
+       14, 267,
+       74, 267,
+       78, 267,
+       -2, 189,
+-1, 436,
+       91, 0,
+       92, 0,
+       93, 0,
+       94, 0,
+       95, 0,
+       96, 0,
+       -2, 153,
+-1, 453,
+       1, 289,
+       78, 289,
+       -2, 143,
+-1, 455,
+       1, 291,
+       78, 291,
+       -2, 143,
+-1, 457,
+       1, 293,
+       78, 293,
+       -2, 143,
+-1, 459,
+       1, 296,
+       78, 296,
+       -2, 144,
+-1, 504,
+       78, 289,
+       -2, 143,
+       };
+# define YYNPROD 301
+# define YYLAST 1346
+yytabelem yyact[]={
+
+ 237, 274, 471, 317, 316, 412, 420, 297, 470, 399,
+ 413, 397, 386, 357, 398, 266, 128, 356, 273, 252,
+ 292,   5, 116, 295, 326, 303, 222,  99, 184, 121,
+ 195, 229,  17, 203, 270, 304, 313, 199, 201, 118,
+  94, 202, 396, 104, 210, 183, 236, 101, 106, 234,
+ 264, 103, 111, 336, 260,  95,  96,  97, 165, 166,
+ 334, 335, 336, 395, 105, 311, 309, 190, 130, 131,
+ 132, 133, 120, 135, 119, 114, 157, 129, 157, 475,
+ 103, 272, 334, 335, 336, 396, 521, 103, 278, 483,
+ 535, 165, 166, 334, 335, 336, 342, 341, 340, 339,
+ 338, 137, 343, 345, 344, 347, 346, 348, 450, 258,
+ 259, 260, 539, 165, 166, 258, 259, 260, 261, 525,
+ 102, 522, 155, 409, 155, 186, 187, 103, 408, 117,
+ 165, 166, 258, 259, 260, 318, 100, 527, 484, 188,
+ 446, 185, 480, 230, 240, 240, 194, 193, 290, 120,
+ 211, 119, 462, 481, 157, 294, 482, 257, 157, 243,
+ 468, 214, 463, 469, 461, 464, 460, 239, 241, 220,
+ 215, 218, 157, 219, 213, 165, 166, 334, 335, 336,
+ 342, 341, 340, 157, 371, 452, 343, 345, 344, 347,
+ 346, 348, 443, 428, 377, 294, 102, 102, 102, 102,
+ 155, 189, 447, 149, 155, 446, 192, 103,  98, 196,
+ 197, 198, 277, 376, 320, 321, 206, 288, 155, 289,
+ 300, 375, 299, 324, 315, 328, 275, 275, 330, 155,
+ 310, 333, 196, 216, 217, 350, 269, 207, 308, 352,
+ 353, 333, 100, 177, 354, 349, 323, 112, 245, 257,
+ 247, 110, 157, 417, 286, 287, 418, 362, 157, 157,
+ 157, 157, 157, 257, 257, 109, 108, 268, 279, 280,
+ 281, 265, 107, 355,   4, 333, 427, 465, 378, 370,
+ 170, 172, 176, 257, 165, 166, 258, 259, 260, 261,
+ 102, 406, 232, 293, 407, 381, 422, 390, 155, 400,
+ 391, 223, 419, 422, 155, 155, 155, 155, 155, 117,
+ 221, 314, 392, 319, 387, 359, 372, 196, 360, 373,
+ 374, 333, 333, 536, 350, 333, 275, 250, 424, 333,
+ 405, 333, 410, 532, 230, 432, 433, 434, 435, 436,
+ 437, 438, 439, 440, 441, 403, 331, 156, 401, 332,
+ 531, 333, 530, 333, 333, 333, 388, 526, 380, 529,
+ 524, 157, 257, 333, 431, 492, 257, 257, 257, 257,
+ 257, 382, 383, 235, 426, 384, 358, 494, 296, 333,
+ 448, 165, 166, 258, 259, 260, 261, 451, 165, 166,
+ 258, 259, 260, 261, 103, 445, 472, 400, 421, 191,
+ 402, 196, 103, 150, 307, 174, 285, 155, 474, 246,
+ 476, 416, 467, 466, 242, 226, 223, 200, 212, 136,
+ 209, 486, 171, 488, 490, 275, 275, 275, 141, 240,
+ 496, 429, 329, 333, 333, 333, 333, 333, 333, 333,
+ 333, 333, 333, 403, 497, 479, 401, 403, 487, 154,
+ 257, 154, 495, 493, 306, 485, 502, 454, 456, 458,
+ 500, 491, 268, 499, 505, 506, 507, 103, 451, 271,
+ 271, 472,  30, 333, 414, 501, 400, 508, 511, 509,
+ 387, 244, 208, 510, 516, 514, 515, 333, 517, 333,
+ 513, 333, 520, 293, 518, 225, 240, 333, 402, 523,
+  92, 248, 402, 528,   6, 262, 123, 249,  81,  80,
+ 275, 275, 275,  79, 534, 533, 479,  78, 173, 263,
+ 314,  77, 403,  76, 537, 401, 351, 154,  75, 333,
+ 282, 154,  60,  49,  48, 333,  45,  33, 333, 538,
+ 113, 205, 454, 456, 458, 154, 267, 165, 166, 334,
+ 335, 336, 342, 540, 503, 411, 154, 204, 394, 393,
+ 298, 478, 503, 503, 503, 134, 389, 312, 115, 379,
+  26,  25,  24,  23, 302,  22, 305, 402,  21, 385,
+ 284,   9, 503,   8,   7,   2, 519, 301,  20, 319,
+ 164,  51, 489, 291, 228, 327, 325, 415,  91, 361,
+ 255,  53, 337,  19,  55, 365, 366, 367, 368, 369,
+  37, 224,   3,   1,   0, 351,   0,   0,   0,   0,
+   0,   0,   0,   0,   0, 154,   0,   0,   0,   0,
+   0, 154, 154, 154, 154, 154,   0,   0,   0, 267,
+   0, 512, 267, 267, 165, 166, 334, 335, 336, 342,
+ 341, 340, 339, 338,   0, 343, 345, 344, 347, 346,
+ 348, 165, 166, 334, 335, 336, 342, 341, 453, 455,
+ 457,   0, 343, 345, 344, 347, 346, 348,   0,   0,
+ 305,   0, 459,   0,   0,   0,   0, 165, 166, 334,
+ 335, 336, 342, 341, 340, 339, 338, 351, 343, 345,
+ 344, 347, 346, 348, 444,   0,   0,   0, 449, 165,
+ 166, 334, 335, 336, 342, 341, 340, 339, 338,   0,
+ 343, 345, 344, 347, 346, 348, 165, 166, 334, 335,
+ 336, 342,   0,   0, 154,   0, 498, 343, 345, 344,
+ 347, 346, 348,   0,   0, 267,   0,   0,   0,   0,
+   0, 442,   0, 504, 455, 457, 165, 166, 334, 335,
+ 336, 342, 341, 340, 339, 338,   0, 343, 345, 344,
+ 347, 346, 348,   0,   0,   0,   0,   0,   0, 430,
+   0, 477,   0, 305, 165, 166, 334, 335, 336, 342,
+ 341, 340, 339, 338,   0, 343, 345, 344, 347, 346,
+ 348, 423,   0,   0,   0,   0, 165, 166, 334, 335,
+ 336, 342, 341, 340, 339, 338,   0, 343, 345, 344,
+ 347, 346, 348,   0,   0,   0, 267,   0,   0,   0,
+   0, 165, 166, 334, 335, 336, 342, 341, 340, 339,
+ 338,  12, 343, 345, 344, 347, 346, 348,   0,   0,
+   0,   0,   0,   0, 305,  10,  56,  46,  73,  85,
+  14,  61,  70,  90,  38,  66,  47,  42,  68,  72,
+  31,  67,  35,  34,  11,  87,  36,  18,  41,  39,
+  28,  16,  57,  58,  59,  50,  54,  43,  88,  64,
+  40,  69,  44,  89,  29,  62,  84,  13,   0,  82,
+  65,  52,  86,  27,  74,  63,  15,   0,   0,  71,
+  83, 160, 161, 162, 163, 169, 168, 167, 158, 159,
+ 103,   0, 160, 161, 162, 163, 169, 168, 167, 158,
+ 159, 103,   0,   0,  32, 160, 161, 162, 163, 169,
+ 168, 167, 158, 159, 103,   0, 160, 161, 162, 163,
+ 169, 168, 167, 158, 159, 103,   0, 160, 161, 162,
+ 163, 169, 168, 167, 158, 159, 103,   0, 160, 161,
+ 162, 163, 169, 168, 167, 158, 159, 103,   0,   0,
+ 233,   0,   0,   0,   0,   0, 165, 166, 363,   0,
+ 364, 233, 227,   0,   0,   0, 238, 165, 166, 231,
+   0,   0,   0,   0, 233,   0,   0, 238,   0,   0,
+ 165, 166, 473,   0,   0, 233,   0,   0,   0,   0,
+ 238, 165, 166, 231,   0,   0, 233,   0,   0,   0,
+   0, 238, 165, 166, 425,   0,   0, 233,   0,   0,
+   0,   0, 238, 165, 166,   0,   0,   0,   0,   0,
+   0,   0,   0, 238, 160, 161, 162, 163, 169, 168,
+ 167, 158, 159, 103,   0, 160, 161, 162, 163, 169,
+ 168, 167, 158, 159, 103, 160, 161, 162, 163, 169,
+ 168, 167, 158, 159, 103,   0,   0,   0, 160, 161,
+ 162, 163, 169, 168, 167, 158, 159, 103, 256,   0,
+  93, 160, 161, 162, 163, 169, 168, 167, 158, 159,
+ 103,   0,   0,   0,   0,   0,   0,   0,   0,   0,
+   0,   0,   0, 276,   0,   0,   0,   0,   0, 165,
+ 166,   0, 122,   0, 322, 125, 126, 127,   0, 238,
+ 165, 166,   0,   0,   0,   0,   0, 138, 139,   0,
+ 238, 140,   0, 142, 143, 144,   0, 251, 145, 146,
+ 147,   0, 148, 165, 166, 253,   0, 254,   0,   0,
+ 153,   0,   0,   0,   0,   0, 165, 166, 151,   0,
+ 152, 178, 179, 180, 181, 182, 160, 161, 162, 163,
+ 169, 168, 167, 158, 159, 103, 160, 161, 162, 163,
+ 169, 168, 167, 158, 159, 103, 160, 161, 162, 163,
+ 169, 168, 167, 158, 159, 103, 160, 161, 162, 163,
+ 169, 168, 167, 158, 159, 103,   0,   0,   0,   0,
+   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
+   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
+   0,   0,   0,   0,   0, 251,   0,   0,   0,   0,
+   0, 165, 166, 283,   0, 153,   0,   0,   0,   0,
+   0, 165, 166, 175,   0, 404,   0,   0,   0,   0,
+   0, 165, 166,  56,  46, 251,  85,   0,  61,   0,
+  90, 165, 166,  47,  73,   0,   0,   0,  70,   0,
+   0,  66,  87,   0,  68,  72,   0,  67,   0,  57,
+  58,  59,  50,   0,   0,  88,   0,   0,   0,   0,
+  89,   0,  62,  84,   0,  64,  82,  69,  52,  86,
+   0,   0,  63,   0, 124,   0,  65,  83,   0,   0,
+  74,   0,   0,   0,   0,  71 };
+yytabelem yypact[]={
+
+-1000,  18, 503, 837,-1000,-1000,-1000,-1000,-1000,-1000,
+ 495,-1000,-1000,-1000,-1000,-1000,-1000, 164, 453, -35,
+ 194, 188, 187, 173,  58, 169,  -8,  66,-1000,-1000,
+-1000,-1000,-1000,1264,-1000,-1000,-1000,  -5,-1000,-1000,
+-1000,-1000,-1000,-1000,-1000, 453,-1000,-1000,-1000,-1000,
+-1000, 354,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,
+-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,
+-1000,-1000,-1000,-1000,-1000,1096, 348,1191, 348, 165,
+-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,
+-1000,-1000,-1000,-1000, 453, 453, 453, 453,-1000, 453,
+-1000, 325,-1000,-1000, 453,-1000, -11, 453, 453, 453,
+ 343,-1000,-1000,-1000, 453, 159,-1000,-1000,-1000,-1000,
+ 468, 346,  58,-1000,-1000, 344,-1000,-1000,-1000,-1000,
+  66, 453, 453, 343,-1000,-1000, 234, 342, 489,-1000,
+ 341, 917, 963, 963, 340, 475, 453, 335, 453,-1000,
+-1000,-1000,-1000,1083,-1000,-1000, 308,1211,-1000,-1000,
+-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,
+-1000,1083, 193, 158,-1000,-1000,1049,1049,-1000,-1000,
+-1000,-1000,1181, 332,-1000,-1000, 325, 325, 453,-1000,
+-1000,  73, 304,-1000,  58,-1000, 304,-1000,-1000,-1000,
+ 453,-1000, 380,-1000, 330,1273, -17,  66, -18, 453,
+ 475,  37, 963,1060,-1000, 453,-1000,-1000,-1000,-1000,
+-1000, 963,-1000, 963, 361,-1000, 963,-1000, 271,-1000,
+ 751, 475,-1000, 963,-1000,-1000,-1000, 963, 963,-1000,
+ 751,-1000, 963,-1000,-1000,  58, 475,-1000, 301, 240,
+-1000,1211,-1000,-1000,-1000, 906,-1000,1211,1211,1211,
+1211,1211, -30, 204, 106, 388,-1000,-1000, 388, 388,
+-1000, 143, 135, 116, 751,-1000,1049,-1000,-1000,-1000,
+-1000,-1000, 308,-1000,-1000, 300,-1000,-1000, 325,-1000,
+-1000, 222,-1000,-1000,-1000,  -5,-1000, -36,1201, 453,
+-1000, 216,-1000,  45,-1000,-1000, 380, 460,-1000, 453,
+-1000,-1000, 178,-1000, 226,-1000,-1000,-1000, 324, 220,
+ 726, 751, 952,-1000, 751, 299, 199, 115, 751, 453,
+ 704,-1000, 941, 963, 963, 963, 963, 963, 963, 963,
+ 963, 963, 963,-1000,-1000,-1000,-1000,-1000,-1000,-1000,
+ 676, 114, -31, 646, 629, 321, 127,-1000,-1000,-1000,
+1083,  33, 751,-1000,-1000,  27, -30, -30, -30,  50,
+-1000, 388, 106, 107, 106,1049,1049,1049, 607,  88,
+  86,  74,-1000,-1000,-1000,  87,-1000, 201,-1000, 304,
+-1000, 113,-1000,  85, 930,-1000,1201,-1000,-1000,  -3,
+1070,-1000,-1000,-1000, 963,-1000,-1000, 453,-1000, 380,
+  64,  78,-1000,   8,-1000,  60,-1000,-1000, 453, 963,
+  58, 963, 963, 391,-1000, 290, 303, 963, 963,-1000,
+ 475,-1000,   0, -31, -31, -31, 467,  95,  95, 581,
+ 646, -22,-1000, 963,-1000, 475, 475,  58,-1000, 308,
+-1000,-1000, 388,-1000,-1000,-1000,-1000,-1000,-1000,-1000,
+1049,1049,1049,-1000, 466, 465,  -5,-1000,-1000, 930,
+-1000,-1000, 564,-1000,-1000,1201,-1000,-1000,-1000,-1000,
+ 380,-1000, 460, 460, 453,-1000, 751,  37,  11,  43,
+ 751,-1000,-1000,-1000, 963, 285, 751,  41, 282,  62,
+-1000, 963, 284, 227, 282, 277, 275, 258,-1000,-1000,
+-1000,-1000, 930,-1000,-1000,   7, 248,-1000,-1000,-1000,
+-1000,-1000, 963,-1000,-1000, 475,-1000,-1000, 751,-1000,
+-1000,-1000,-1000,-1000, 751,-1000,-1000, 751,  34, 475,
+-1000 };
+yytabelem yypgo[]={
+
+   0, 613, 612,  13, 611,  81,  15,  32, 610, 604,
+ 603,  10,   0, 602, 601, 600,  16, 598,  35,  25,
+ 597, 596, 595,   3,   4, 594,  67, 593, 592,  50,
+  34,  18,  26, 101,  20, 591,  30, 373,   1, 292,
+  24, 347, 327,   2,   9,  14,  31,  49,  46, 590,
+ 588,  39,  28,  45, 587, 585, 584, 583, 581,1100,
+  40, 580, 579,  12, 578, 575, 573, 572, 571, 570,
+ 568,  29, 567,  27, 566,  23,  41,   7,  44,   6,
+  37, 565,  38, 561, 560,  11,  22,  36, 559, 558,
+   8,  17,  33, 557, 555, 541,   5, 540, 472, 537,
+ 536, 534, 533, 532, 528, 203, 523, 521, 518, 517,
+ 513, 509,  88, 508, 507,  19 };
+yytabelem yyr1[]={
+
+   0,   1,   1,  55,  55,  55,  55,  55,  55,  55,
+   2,  56,  56,  56,  56,  56,  56,  56,  60,  52,
+  33,  53,  53,  61,  61,  62,  62,  63,  63,  26,
+  26,  26,  27,  27,  34,  34,  17,  57,  57,  57,
+  57,  57,  57,  57,  57,  57,  57,  57,  57,  10,
+  10,  10,  74,   7,   8,   9,   9,   9,   9,   9,
+   9,   9,   9,   9,   9,   9,  16,  16,  16,  50,
+  50,  50,  50,  51,  51,  64,  64,  65,  65,  66,
+  66,  80,  54,  54,  67,  67,  81,  82,  76,  83,
+  84,  77,  77,  85,  85,  45,  45,  45,  70,  70,
+  86,  86,  72,  72,  87,  36,  18,  18,  19,  19,
+  75,  75,  89,  88,  88,  90,  90,  43,  43,  91,
+  91,   3,  68,  68,  92,  92,  95,  93,  94,  94,
+  96,  96,  11,  69,  69,  97,  20,  20,  71,  21,
+  21,  22,  22,  38,  38,  38,  39,  39,  39,  39,
+  39,  39,  39,  39,  39,  39,  39,  39,  39,  39,
+  12,  12,  13,  13,  13,  13,  13,  13,  37,  37,
+  37,  37,  32,  40,  40,  44,  44,  48,  48,  48,
+  48,  48,  48,  48,  47,  49,  49,  49,  41,  41,
+  42,  42,  42,  42,  42,  42,  42,  42,  58,  58,
+  58,  58,  58,  58,  58,  58,  58,  99,  23,  24,
+  24,  98,  98,  98,  98,  98,  98,  98,  98,  98,
+  98,  98,   4, 100, 101, 101, 101, 101,  73,  73,
+  35,  25,  25,  46,  46,  14,  14,  28,  28,  59,
+  78,  79, 102, 103, 103, 103, 103, 103, 103, 103,
+ 103, 103, 103, 103, 103, 103, 103, 104, 111, 111,
+ 111, 106, 113, 113, 113, 108, 108, 105, 105, 114,
+ 114, 115, 115, 115, 115, 115, 115,  15, 107, 109,
+ 110, 110,  29,  29,   6,   6,  30,  30,  30,  31,
+  31,  31,  31,  31,  31,   5,   5,   5,   5,   5,
+ 112 };
+yytabelem yyr2[]={
+
+   0,   0,   3,   2,   2,   2,   3,   3,   2,   1,
+   1,   3,   4,   3,   4,   4,   5,   3,   0,   1,
+   1,   0,   1,   2,   3,   1,   3,   1,   3,   0,
+   2,   3,   1,   3,   1,   1,   1,   1,   1,   1,
+   1,   1,   1,   1,   1,   1,   2,   1,   5,   7,
+   5,   5,   0,   2,   1,   1,   1,   1,   1,   1,
+   1,   1,   1,   1,   1,   1,   0,   4,   6,   3,
+   4,   5,   3,   1,   3,   3,   3,   3,   3,   3,
+   3,   3,   1,   3,   3,   3,   0,   6,   0,   0,
+   0,   2,   3,   1,   3,   1,   2,   1,   1,   3,
+   1,   1,   1,   3,   3,   2,   1,   5,   1,   3,
+   0,   3,   0,   2,   3,   1,   3,   1,   1,   1,
+   3,   1,   3,   3,   4,   1,   0,   2,   1,   3,
+   1,   3,   1,   1,   2,   4,   1,   3,   0,   0,
+   1,   1,   3,   1,   3,   1,   1,   1,   3,   3,
+   3,   3,   2,   3,   3,   3,   3,   3,   2,   3,
+   1,   1,   1,   1,   1,   1,   1,   1,   1,   2,
+   4,   5,   5,   0,   1,   1,   1,   1,   1,   1,
+   1,   1,   1,   1,   5,   1,   1,   1,   1,   3,
+   1,   1,   3,   3,   3,   3,   2,   3,   1,   7,
+   4,   1,   2,   2,   6,   2,   2,   5,   3,   1,
+   4,   4,   5,   2,   1,   1,  10,   1,   3,   4,
+   3,   3,   1,   1,   3,   3,   7,   7,   0,   1,
+   3,   1,   3,   1,   2,   1,   1,   1,   3,   0,
+   0,   0,   1,   2,   2,   2,   2,   2,   2,   2,
+   3,   4,   4,   2,   3,   1,   3,   3,   1,   1,
+   1,   3,   1,   1,   1,   1,   1,   3,   3,   1,
+   3,   1,   1,   1,   2,   2,   2,   1,   3,   3,
+   4,   4,   1,   3,   1,   5,   1,   1,   1,   3,
+   3,   3,   3,   3,   3,   1,   3,   5,   5,   5,
+   0 };
+yytabelem yychk[]={
+
+-1000,  -1, -55,  -2, 256,   3,   1, -56, -57, -58,
+  18,  37,   4,  60,  23,  69,  44,  -7,  40, -10,
+ -50, -64, -65, -66, -67, -68, -69,  66,  43,  57,
+ -98,  33,  97, -99,  36,  35,  39,  -8,  27,  42,
+  53,  41,  30,  50,  55,-100,  20,  29,-101,-102,
+  48, -35,  64, -14,  49,  -9,  19,  45,  46,  47,
+-103,  24,  58,  68,  52,  63,  28,  34,  31,  54,
+  25,  72,  32,  21,  67,-104,-106,-107,-109,-110,
+-111,-113,  62,  73,  59,  22,  65,  38,  51,  56,
+  26, -17,   5, -59, -60, -60, -60, -60,  44, -73,
+  78, -52, -33,  14,  78,  99, -73,  78,  78,  78,
+  78, -73,  78, -97,  83, -70, -86, -33, -51,  85,
+  83, -71, -59, -98,  70, -59, -59, -59, -16,  82,
+ -71, -71, -71, -71, -81, -71, -37, -33, -59, -59,
+ -59,  74, -59, -59, -59, -59, -59, -59, -59,-105,
+ -42,  82,  84,  74, -37, -48, -41, -12,  12,  13,
+   5,   6,   7,   8, -49,  80,  81,  11,  10,   9,
+-105,  74,-105,-108, -42,  82,-105,  78, -59, -59,
+ -59, -59, -59, -53, -52, -53, -52, -52, -60, -33,
+ -26,  74, -33, -76, -51, -36, -33, -33, -33, -80,
+  74, -82, -76, -92, -93, -95, -33,  78,  14,  74,
+ -78, -73,  74, -78, -36, -51, -33, -33, -80, -82,
+ -92,  76, -32,  74,  -4,   6,  74,  75, -25, -46,
+ -38,  82, -39,  74, -47, -37, -48, -12,  90, -40,
+ -38, -40,  74,  -3,   6, -33,  74, -33, -41,-114,
+ -42,  74,-115,  82,  84, -15,  15, -12,  82,  83,
+  84,  85, -41, -41, -29,  78,  -6, -37,  74,  78,
+ -30, -39,  -5, -31, -38, -47,  74, -30,-112,-112,
+-112,-112, -41,  82, -61,  74, -26, -26, -52, -71,
+  75, -27, -34, -33,  82, -75,  74, -77, -84, -73,
+ -75, -54, -37, -19, -18, -37,  74,  74,  -7,  83,
+ -86,  83, -72, -87, -33,  -3, -24, -23,  98, -33,
+ -38, -38,  74, -36, -38, -21, -40, -22, -38,  71,
+ -38,  75,  78, -12,  82,  83,  84, -13,  89,  88,
+  87,  86,  85,  91,  93,  92,  95,  94,  96,  -3,
+ -38, -39, -38, -38, -38, -73, -91,  -3,  75,  75,
+  78, -41, -38,  82,  84, -41, -41, -41, -41, -41,
+  75,  78, -29, -29, -29,  78,  78,  78, -38, -39,
+  -5, -31,-112,-112,  75, -62, -63,  14, -26, -74,
+  75,  78, -16, -88, -89,  99,  78, -85, -45, -44,
+ -12, -47, -33, -48,  74, -36,  75,  78,  83,  78,
+ -19, -94, -96, -11,  14, -20, -33,  75,  78,  76,
+ -79,  74,  76,  75, -79,  82,  75,  77,  78, -33,
+  75, -46, -38, -38, -38, -38, -38, -38, -38, -38,
+ -38, -38,  75,  78,  75,  74,  78,  75,-115, -41,
+  75,  -6,  78, -39,  -5, -39,  -5, -39,  -5,  75,
+  78,  78,  78,  75,  78,  76, -75, -34,  75,  78,
+ -90, -43, -38,  82, -85,  82, -44, -37, -83, -18,
+  78,  75,  78,  81,  78, -87, -38, -73, -38, -28,
+ -38,  70,  75, -32,  74, -40, -38,  -3, -39, -91,
+  -3, -73, -23, -33, -39, -23, -23, -23, -63,  14,
+ -16, -90,  77, -45, -44, -77, -23, -96, -11, -33,
+ -24,  75,  78, -79,  75,  78,  75,  75, -38,  75,
+  75,  75,  75, -43, -38,  83,  75, -38,  -3,  78,
+  -3 };
+yytabelem yydef[]={
+
+   1,  -2,   0,   0,   9,  10,   2,   3,   4,   5,
+   0, 239,   8,  18,  18,  18,  18, 228,   0,  37,
+  -2,  39,  40,  41,  -2,  43,  44,  45,  47, 138,
+ 198, 239, 201,   0, 239, 239, 239,  66, 138, 138,
+ 138, 138,  86, 138, 133,   0, 239, 239, 214, 215,
+ 239, 217, 239, 239, 239,  54, 223, 239, 239, 239,
+ 242, 239, 235, 236,  55,  56,  57,  58,  59,  60,
+  61,  62,  63,  64,  65,   0,   0,   0,   0, 255,
+ 239, 239, 239, 239, 239, 258, 259, 260, 262, 263,
+ 264,   6,  36,   7,  21,  21,   0,   0,  18,   0,
+ 229,  29,  19,  20,   0,  88,   0, 229,   0,   0,
+   0,  88, 126, 134,   0,  46,  98, 100, 101,  73,
+   0,   0,  -2, 202, 203,   0, 205, 206,  53, 240,
+   0,   0,   0,   0,  88, 126,   0, 168,   0, 213,
+   0,   0, 173, 173,   0,   0,   0,   0,   0, 243,
+  -2, 245, 246,   0, 190, 191,   0,   0, 177, 178,
+ 179, 180, 181, 182, 183, 160, 161, 185, 186, 187,
+ 247,   0, 248, 249,  -2, 266, 253,   0, 300, 300,
+ 300, 300,   0,  11,  22,  13,  29,  29,   0, 138,
+  17,   0, 110,  90, 228,  72, 110,  76,  78,  80,
+   0,  85,   0, 123, 125,   0,   0,   0,   0,   0,
+   0,   0,   0,   0,  69,   0,  75,  77,  79,  84,
+ 122,   0, 169,  -2,   0, 222,   0, 218,   0, 231,
+ 233,   0, 143,   0, 145, 146, 147,   0,   0, 220,
+ 174, 221,   0, 224, 121,  -2,   0, 230, 271,   0,
+ 188,   0, 269, 272, 273,   0, 277,   0,   0,   0,
+   0,   0, 196, 271, 250,   0, 282, 284,   0,   0,
+ 254,  -2, 287, 288,   0,  -2,   0, 256, 257, 261,
+ 278, 279, 300, 300,  12,   0,  14,  15,  29,  52,
+  30,   0,  32,  34,  35,  66, 112,   0,   0,   0,
+ 105,   0,  82,   0, 108, 106,   0,   0, 127,   0,
+  99,  74,   0, 102,   0, 241, 200, 209,   0,   0,
+   0, 241,   0,  70, 211,   0,   0, 140,  -2,   0,
+   0, 219,   0,   0,   0,   0,   0,   0,   0,   0,
+   0,   0,   0, 162, 163, 164, 165, 166, 167, 234,
+   0, 143, 152, 158,   0,   0,   0, 119,  -2, 268,
+   0,   0, 274, 275, 276, 192, 193, 194, 195, 197,
+ 267,   0, 252,   0, 251,   0,   0,   0,   0, 143,
+   0,   0, 280, 281,  23,   0,  25,  27,  16, 110,
+  31,   0,  50,   0,   0,  51,   0,  91,  93,  95,
+   0,  97, 175, 176,   0,  71,  81,   0,  89,   0,
+   0,   0, 128, 130, 132, 135, 136,  48,   0,   0,
+ 228,   0,   0,   0,  67,   0, 170, 173,   0, 212,
+   0, 232, 148, 149, 150, 151,  -2, 154, 155, 156,
+ 157, 159, 144,   0, 207,   0,   0, 228, 270, 271,
+ 189, 283,   0,  -2, 290,  -2, 292,  -2, 294,  -2,
+   0,   0,   0,  24,   0,   0,  66,  33, 111,   0,
+ 113, 115, 118, 117,  92,   0,  96,  83,  90, 109,
+   0, 124,   0,   0,   0, 103, 104,   0,   0, 208,
+ 237, 204, 241, 171, 173,   0, 142,   0, 143,   0,
+ 120,   0,   0, 168,  -2,   0,   0,   0,  26,  28,
+  49, 114,   0,  94,  95,   0,   0, 129, 131, 137,
+ 199, 210,   0,  68, 172,   0, 184, 226, 227, 285,
+ 297, 298, 299, 116, 118,  87, 107, 238,   0,   0,
+ 216 };
+# ifdef YYDEBUG
+# include "y.debug"
+# endif
+
+# define YYFLAG -1000
+# define YYERROR goto yyerrlab
+# define YYACCEPT return(0)
+# define YYABORT return(1)
+
+/*     parser for yacc output  */
+
+#ifdef YYDEBUG
+int yydebug = 0; /* 1 for debugging */
+#endif
+YYSTYPE yyv[YYMAXDEPTH]; /* where the values are stored */
+int yychar = -1; /* current input token number */
+int yynerrs = 0;  /* number of errors */
+yytabelem yyerrflag = 0;  /* error recovery flag */
+
+yyparse()
+{      yytabelem yys[YYMAXDEPTH];
+       int yyj, yym;
+       register YYSTYPE *yypvt;
+       register int yystate, yyn;
+       register yytabelem *yyps;
+       register YYSTYPE *yypv;
+       register yytabelem *yyxi;
+
+       yystate = 0;
+       yychar = -1;
+       yynerrs = 0;
+       yyerrflag = 0;
+       yyps= &yys[-1];
+       yypv= &yyv[-1];
+
+yystack:    /* put a state and value onto the stack */
+#ifdef YYDEBUG
+       if(yydebug >= 3)
+               if(yychar < 0 || yytoknames[yychar] == 0)
+                       printf("char %d in %s", yychar, yystates[yystate]);
+               else
+                       printf("%s in %s", yytoknames[yychar], yystates[yystate]);
+#endif
+       if( ++yyps >= &yys[YYMAXDEPTH] ) {
+               yyerror( "yacc stack overflow" );
+               return(1);
+       }
+       *yyps = yystate;
+       ++yypv;
+       *yypv = yyval;
+yynewstate:
+       yyn = yypact[yystate];
+       if(yyn <= YYFLAG) goto yydefault; /* simple state */
+       if(yychar<0) {
+               yychar = yylex();
+#ifdef YYDEBUG
+               if(yydebug >= 2) {
+                       if(yychar <= 0)
+                               printf("lex EOF\n");
+                       else if(yytoknames[yychar])
+                               printf("lex %s\n", yytoknames[yychar]);
+                       else
+                               printf("lex (%c)\n", yychar);
+               }
+#endif
+               if(yychar < 0)
+                       yychar = 0;
+       }
+       if((yyn += yychar) < 0 || yyn >= YYLAST)
+               goto yydefault;
+       if( yychk[ yyn=yyact[ yyn ] ] == yychar ){ /* valid shift */
+               yychar = -1;
+               yyval = yylval;
+               yystate = yyn;
+               if( yyerrflag > 0 ) --yyerrflag;
+               goto yystack;
+       }
+yydefault:
+       /* default state action */
+       if( (yyn=yydef[yystate]) == -2 ) {
+               if(yychar < 0) {
+                       yychar = yylex();
+#ifdef YYDEBUG
+                       if(yydebug >= 2)
+                               if(yychar < 0)
+                                       printf("lex EOF\n");
+                               else
+                                       printf("lex %s\n", yytoknames[yychar]);
+#endif
+                       if(yychar < 0)
+                               yychar = 0;
+               }
+               /* look through exception table */
+               for(yyxi=yyexca; (*yyxi!= (-1)) || (yyxi[1]!=yystate);
+                       yyxi += 2 ) ; /* VOID */
+               while( *(yyxi+=2) >= 0 ){
+                       if( *yyxi == yychar ) break;
+               }
+               if( (yyn = yyxi[1]) < 0 ) return(0);   /* accept */
+       }
+       if( yyn == 0 ){ /* error */
+               /* error ... attempt to resume parsing */
+               switch( yyerrflag ){
+               case 0:   /* brand new error */
+#ifdef YYDEBUG
+                       yyerror("syntax error\n%s", yystates[yystate]);
+                       if(yytoknames[yychar])
+                               yyerror("saw %s\n", yytoknames[yychar]);
+                       else if(yychar >= ' ' && yychar < '\177')
+                               yyerror("saw `%c'\n", yychar);
+                       else if(yychar == 0)
+                               yyerror("saw EOF\n");
+                       else
+                               yyerror("saw char 0%o\n", yychar);
+#else
+                       yyerror( "syntax error" );
+#endif
+yyerrlab:
+                       ++yynerrs;
+               case 1:
+               case 2: /* incompletely recovered error ... try again */
+                       yyerrflag = 3;
+                       /* find a state where "error" is a legal shift action */
+                       while ( yyps >= yys ) {
+                               yyn = yypact[*yyps] + YYERRCODE;
+                               if( yyn>= 0 && yyn < YYLAST && yychk[yyact[yyn]] == YYERRCODE ){
+                                       yystate = yyact[yyn];  /* simulate a shift of "error" */
+                                       goto yystack;
+                               }
+                               yyn = yypact[*yyps];
+                               /* the current yyps has no shift onn "error", pop stack */
+#ifdef YYDEBUG
+                               if( yydebug ) printf( "error recovery pops state %d, uncovers %d\n", *yyps, yyps[-1] );
+#endif
+                               --yyps;
+                               --yypv;
+                       }
+                       /* there is no state on the stack with an error shift ... abort */
+yyabort:
+                       return(1);
+               case 3:  /* no shift yet; clobber input char */
+#ifdef YYDEBUG
+                       if( yydebug ) {
+                               printf("error recovery discards ");
+                               if(yytoknames[yychar])
+                                       printf("%s\n", yytoknames[yychar]);
+                               else if(yychar >= ' ' && yychar < '\177')
+                                       printf("`%c'\n", yychar);
+                               else if(yychar == 0)
+                                       printf("EOF\n");
+                               else
+                                       printf("char 0%o\n", yychar);
+                       }
+#endif
+                       if( yychar == 0 ) goto yyabort; /* don't discard EOF, quit */
+                       yychar = -1;
+                       goto yynewstate;   /* try again in the same state */
+               }
+       }
+       /* reduction by production yyn */
+#ifdef YYDEBUG
+       if(yydebug) {   char *s;
+               printf("reduce %d in:\n\t", yyn);
+               for(s = yystates[yystate]; *s; s++) {
+                       putchar(*s);
+                       if(*s == '\n' && *(s+1))
+                               putchar('\t');
+               }
+       }
+#endif
+       yyps -= yyr2[yyn];
+       yypvt = yypv;
+       yypv -= yyr2[yyn];
+       yyval = yypv[1];
+       yym=yyn;
+       /* consult goto table to find next state */
+       yyn = yyr1[yyn];
+       yyj = yypgo[yyn] + *yyps + 1;
+       if( yyj>=YYLAST || yychk[ yystate = yyact[yyj] ] != -yyn ) yystate = yyact[yypgo[yyn]];
+       switch(yym){
+
+case 3:
+/* # line 226 "gram.in" */
+{
+/* stat:   is the nonterminal for Fortran statements */
+
+                 lastwasbranch = NO; } break;
+case 5:
+/* # line 232 "gram.in" */
+{ /* forbid further statement function definitions... */
+                 if (parstate == INDATA && laststfcn != thisstno)
+                       parstate = INEXEC;
+                 thisstno++;
+                 if(yypvt[-1].labval && (yypvt[-1].labval->labelno==dorange))
+                       enddo(yypvt[-1].labval->labelno);
+                 if(lastwasbranch && thislabel==NULL)
+                       warn("statement cannot be reached");
+                 lastwasbranch = thiswasbranch;
+                 thiswasbranch = NO;
+                 if(yypvt[-1].labval)
+                       {
+                       if(yypvt[-1].labval->labtype == LABFORMAT)
+                               err("label already that of a format");
+                       else
+                               yypvt[-1].labval->labtype = LABEXEC;
+                       }
+                 freetemps();
+               } break;
+case 6:
+/* # line 252 "gram.in" */
+{ if (can_include)
+                       doinclude( yypvt[-0].charpval );
+                 else {
+                       fprintf(diagfile, "Cannot open file %s\n", yypvt[-0].charpval);
+                       done(1);
+                       }
+               } break;
+case 7:
+/* # line 260 "gram.in" */
+{ if (yypvt[-2].labval)
+                       lastwasbranch = NO;
+                 endproc(); /* lastwasbranch = NO; -- set in endproc() */
+               } break;
+case 8:
+/* # line 265 "gram.in" */
+{ extern void unclassifiable();
+                 unclassifiable();
+
+/* flline flushes the current line, ignoring the rest of the text there */
+
+                 flline(); } break;
+case 9:
+/* # line 272 "gram.in" */
+{ flline();  needkwd = NO;  inioctl = NO;
+                 yyerrok; yyclearin; } break;
+case 10:
+/* # line 277 "gram.in" */
+{
+               if(yystno != 0)
+                       {
+                       yyval.labval = thislabel =  mklabel(yystno);
+                       if( ! headerdone ) {
+                               if (procclass == CLUNKNOWN)
+                                       procclass = CLMAIN;
+                               puthead(CNULL, procclass);
+                               }
+                       if(thislabel->labdefined)
+                               execerr("label %s already defined",
+                                       convic(thislabel->stateno) );
+                       else    {
+                               if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel
+                                   && thislabel->labtype!=LABFORMAT)
+                                       warn1("there is a branch to label %s from outside block",
+                                             convic( (ftnint) (thislabel->stateno) ) );
+                               thislabel->blklevel = blklevel;
+                               thislabel->labdefined = YES;
+                               if(thislabel->labtype != LABFORMAT)
+                                       p1_label((long)(thislabel - labeltab));
+                               }
+                       }
+               else    yyval.labval = thislabel = NULL;
+               } break;
+case 11:
+/* # line 305 "gram.in" */
+{startproc(yypvt[-0].extval, CLMAIN); } break;
+case 12:
+/* # line 307 "gram.in" */
+{      warn("ignoring arguments to main program");
+                       /* hashclear(); */
+                       startproc(yypvt[-1].extval, CLMAIN); } break;
+case 13:
+/* # line 311 "gram.in" */
+{ if(yypvt[-0].extval) NO66("named BLOCKDATA");
+                 startproc(yypvt[-0].extval, CLBLOCK); } break;
+case 14:
+/* # line 314 "gram.in" */
+{ entrypt(CLPROC, TYSUBR, (ftnint) 0,  yypvt[-1].extval, yypvt[-0].chval); } break;
+case 15:
+/* # line 316 "gram.in" */
+{ entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, yypvt[-1].extval, yypvt[-0].chval); } break;
+case 16:
+/* # line 318 "gram.in" */
+{ entrypt(CLPROC, yypvt[-4].ival, varleng, yypvt[-1].extval, yypvt[-0].chval); } break;
+case 17:
+/* # line 320 "gram.in" */
+{ if(parstate==OUTSIDE || procclass==CLMAIN
+                       || procclass==CLBLOCK)
+                               execerr("misplaced entry statement", CNULL);
+                 entrypt(CLENTRY, 0, (ftnint) 0, yypvt[-1].extval, yypvt[-0].chval);
+               } break;
+case 18:
+/* # line 328 "gram.in" */
+{ newproc(); } break;
+case 19:
+/* # line 332 "gram.in" */
+{ yyval.extval = newentry(yypvt[-0].namval, 1); } break;
+case 20:
+/* # line 336 "gram.in" */
+{ yyval.namval = mkname(token); } break;
+case 21:
+/* # line 339 "gram.in" */
+{ yyval.extval = NULL; } break;
+case 29:
+/* # line 357 "gram.in" */
+{ yyval.chval = 0; } break;
+case 30:
+/* # line 359 "gram.in" */
+{ NO66(" () argument list");
+                 yyval.chval = 0; } break;
+case 31:
+/* # line 362 "gram.in" */
+{yyval.chval = yypvt[-1].chval; } break;
+case 32:
+/* # line 366 "gram.in" */
+{ yyval.chval = (yypvt[-0].namval ? mkchain((char *)yypvt[-0].namval,CHNULL) : CHNULL ); } break;
+case 33:
+/* # line 368 "gram.in" */
+{ if(yypvt[-0].namval) yypvt[-2].chval = yyval.chval = mkchain((char *)yypvt[-0].namval, yypvt[-2].chval); } break;
+case 34:
+/* # line 372 "gram.in" */
+{ if(yypvt[-0].namval->vstg!=STGUNKNOWN && yypvt[-0].namval->vstg!=STGARG)
+                       dclerr("name declared as argument after use", yypvt[-0].namval);
+                 yypvt[-0].namval->vstg = STGARG;
+               } break;
+case 35:
+/* # line 377 "gram.in" */
+{ NO66("altenate return argument");
+
+/* substars   means that '*'ed formal parameters should be replaced.
+   This is used to specify alternate return labels; in theory, only
+   parameter slots which have '*' should accept the statement labels.
+   This compiler chooses to ignore the '*'s in the formal declaration, and
+   always return the proper value anyway.
+
+   This variable is only referred to in   proc.c   */
+
+                 yyval.namval = 0;  substars = YES; } break;
+case 36:
+/* # line 393 "gram.in" */
+{
+               char *s;
+               s = copyn(toklen+1, token);
+               s[toklen] = '\0';
+               yyval.charpval = s;
+               } break;
+case 45:
+/* # line 409 "gram.in" */
+{ NO66("SAVE statement");
+                 saveall = YES; } break;
+case 46:
+/* # line 412 "gram.in" */
+{ NO66("SAVE statement"); } break;
+case 47:
+/* # line 414 "gram.in" */
+{ fmtstmt(thislabel); setfmt(thislabel); } break;
+case 48:
+/* # line 416 "gram.in" */
+{ NO66("PARAMETER statement"); } break;
+case 49:
+/* # line 420 "gram.in" */
+{ settype(yypvt[-4].namval, yypvt[-6].ival, yypvt[-0].lval);
+                 if(ndim>0) setbound(yypvt[-4].namval,ndim,dims);
+               } break;
+case 50:
+/* # line 424 "gram.in" */
+{ settype(yypvt[-2].namval, yypvt[-4].ival, yypvt[-0].lval);
+                 if(ndim>0) setbound(yypvt[-2].namval,ndim,dims);
+               } break;
+case 51:
+/* # line 428 "gram.in" */
+{ if (new_dcl == 2) {
+                       err("attempt to give DATA in type-declaration");
+                       new_dcl = 1;
+                       }
+               } break;
+case 52:
+/* # line 435 "gram.in" */
+{ new_dcl = 2; } break;
+case 53:
+/* # line 438 "gram.in" */
+{ varleng = yypvt[-0].lval; } break;
+case 54:
+/* # line 442 "gram.in" */
+{ varleng = (yypvt[-0].ival<0 || ONEOF(yypvt[-0].ival,M(TYLOGICAL)|M(TYLONG))
+                               ? 0 : typesize[yypvt[-0].ival]);
+                 vartype = yypvt[-0].ival; } break;
+case 55:
+/* # line 447 "gram.in" */
+{ yyval.ival = TYLONG; } break;
+case 56:
+/* # line 448 "gram.in" */
+{ yyval.ival = tyreal; } break;
+case 57:
+/* # line 449 "gram.in" */
+{ ++complex_seen; yyval.ival = tycomplex; } break;
+case 58:
+/* # line 450 "gram.in" */
+{ yyval.ival = TYDREAL; } break;
+case 59:
+/* # line 451 "gram.in" */
+{ ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); yyval.ival = TYDCOMPLEX; } break;
+case 60:
+/* # line 452 "gram.in" */
+{ yyval.ival = TYLOGICAL; } break;
+case 61:
+/* # line 453 "gram.in" */
+{ NO66("CHARACTER statement"); yyval.ival = TYCHAR; } break;
+case 62:
+/* # line 454 "gram.in" */
+{ yyval.ival = TYUNKNOWN; } break;
+case 63:
+/* # line 455 "gram.in" */
+{ yyval.ival = TYUNKNOWN; } break;
+case 64:
+/* # line 456 "gram.in" */
+{ NOEXT("AUTOMATIC statement"); yyval.ival = - STGAUTO; } break;
+case 65:
+/* # line 457 "gram.in" */
+{ NOEXT("STATIC statement"); yyval.ival = - STGBSS; } break;
+case 66:
+/* # line 461 "gram.in" */
+{ yyval.lval = varleng; } break;
+case 67:
+/* # line 463 "gram.in" */
+{
+               expptr p;
+               p = yypvt[-1].expval;
+               NO66("length specification *n");
+               if( ! ISICON(p) || p->constblock.Const.ci <= 0 )
+                       {
+                       yyval.lval = 0;
+                       dclerr("length must be a positive integer constant",
+                               NPNULL);
+                       }
+               else {
+                       if (vartype == TYCHAR)
+                               yyval.lval = p->constblock.Const.ci;
+                       else switch((int)p->constblock.Const.ci) {
+                               case 1: yyval.lval = 1; break;
+                               case 2: yyval.lval = typesize[TYSHORT]; break;
+                               case 4: yyval.lval = typesize[TYLONG];  break;
+                               case 8: yyval.lval = typesize[TYDREAL]; break;
+                               case 16: yyval.lval = typesize[TYDCOMPLEX]; break;
+                               default:
+                                       dclerr("invalid length",NPNULL);
+                                       yyval.lval = varleng;
+                               }
+                       }
+               } break;
+case 68:
+/* # line 489 "gram.in" */
+{ NO66("length specification *(*)"); yyval.lval = -1; } break;
+case 69:
+/* # line 493 "gram.in" */
+{ incomm( yyval.extval = comblock("") , yypvt[-0].namval ); } break;
+case 70:
+/* # line 495 "gram.in" */
+{ yyval.extval = yypvt[-1].extval;  incomm(yypvt[-1].extval, yypvt[-0].namval); } break;
+case 71:
+/* # line 497 "gram.in" */
+{ yyval.extval = yypvt[-2].extval;  incomm(yypvt[-2].extval, yypvt[-0].namval); } break;
+case 72:
+/* # line 499 "gram.in" */
+{ incomm(yypvt[-2].extval, yypvt[-0].namval); } break;
+case 73:
+/* # line 503 "gram.in" */
+{ yyval.extval = comblock(""); } break;
+case 74:
+/* # line 505 "gram.in" */
+{ yyval.extval = comblock(token); } break;
+case 75:
+/* # line 509 "gram.in" */
+{ setext(yypvt[-0].namval); } break;
+case 76:
+/* # line 511 "gram.in" */
+{ setext(yypvt[-0].namval); } break;
+case 77:
+/* # line 515 "gram.in" */
+{ NO66("INTRINSIC statement"); setintr(yypvt[-0].namval); } break;
+case 78:
+/* # line 517 "gram.in" */
+{ setintr(yypvt[-0].namval); } break;
+case 81:
+/* # line 525 "gram.in" */
+{
+               struct Equivblock *p;
+               if(nequiv >= maxequiv)
+                       many("equivalences", 'q', maxequiv);
+               p  =  & eqvclass[nequiv++];
+               p->eqvinit = NO;
+               p->eqvbottom = 0;
+               p->eqvtop = 0;
+               p->equivs = yypvt[-1].eqvval;
+               } break;
+case 82:
+/* # line 538 "gram.in" */
+{ yyval.eqvval=ALLOC(Eqvchain);
+                 yyval.eqvval->eqvitem.eqvlhs = (struct Primblock *)yypvt[-0].expval;
+               } break;
+case 83:
+/* # line 542 "gram.in" */
+{ yyval.eqvval=ALLOC(Eqvchain);
+                 yyval.eqvval->eqvitem.eqvlhs = (struct Primblock *) yypvt[-0].expval;
+                 yyval.eqvval->eqvnextp = yypvt[-2].eqvval;
+               } break;
+case 86:
+/* # line 553 "gram.in" */
+{ if(parstate == OUTSIDE)
+                       {
+                       newproc();
+                       startproc(ESNULL, CLMAIN);
+                       }
+                 if(parstate < INDATA)
+                       {
+                       enddcl();
+                       parstate = INDATA;
+                       datagripe = 1;
+                       }
+               } break;
+case 87:
+/* # line 568 "gram.in" */
+{ ftnint junk;
+                 if(nextdata(&junk) != NULL)
+                       err("too few initializers");
+                 frdata(yypvt[-4].chval);
+                 frrpl();
+               } break;
+case 88:
+/* # line 576 "gram.in" */
+{ frchain(&datastack); curdtp = 0; } break;
+case 89:
+/* # line 578 "gram.in" */
+{ pop_datastack(); } break;
+case 90:
+/* # line 580 "gram.in" */
+{ toomanyinit = NO; } break;
+case 93:
+/* # line 585 "gram.in" */
+{ dataval(ENULL, yypvt[-0].expval); } break;
+case 94:
+/* # line 587 "gram.in" */
+{ dataval(yypvt[-2].expval, yypvt[-0].expval); } break;
+case 96:
+/* # line 592 "gram.in" */
+{ if( yypvt[-1].ival==OPMINUS && ISCONST(yypvt[-0].expval) )
+                       consnegop((Constp)yypvt[-0].expval);
+                 yyval.expval = yypvt[-0].expval;
+               } break;
+case 100:
+/* # line 604 "gram.in" */
+{ int k;
+                 yypvt[-0].namval->vsave = YES;
+                 k = yypvt[-0].namval->vstg;
+               if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) )
+                       dclerr("can only save static variables", yypvt[-0].namval);
+               } break;
+case 104:
+/* # line 618 "gram.in" */
+{ if(yypvt[-2].namval->vclass == CLUNKNOWN)
+                       make_param((struct Paramblock *)yypvt[-2].namval, yypvt[-0].expval);
+                 else dclerr("cannot make into parameter", yypvt[-2].namval);
+               } break;
+case 105:
+/* # line 625 "gram.in" */
+{ if(ndim>0) setbound(yypvt[-1].namval, ndim, dims); } break;
+case 106:
+/* # line 629 "gram.in" */
+{ Namep np;
+                 np = ( (struct Primblock *) yypvt[-0].expval) -> namep;
+                 vardcl(np);
+                 if(np->vstg == STGCOMMON)
+                       extsymtab[np->vardesc.varno].extinit = YES;
+                 else if(np->vstg==STGEQUIV)
+                       eqvclass[np->vardesc.varno].eqvinit = YES;
+                 else if(np->vstg!=STGINIT && np->vstg!=STGBSS)
+                       dclerr("inconsistent storage classes", np);
+                 yyval.chval = mkchain((char *)yypvt[-0].expval, CHNULL);
+               } break;
+case 107:
+/* # line 641 "gram.in" */
+{ chainp p; struct Impldoblock *q;
+               pop_datastack();
+               q = ALLOC(Impldoblock);
+               q->tag = TIMPLDO;
+               (q->varnp = (Namep) (yypvt[-1].chval->datap))->vimpldovar = 1;
+               p = yypvt[-1].chval->nextp;
+               if(p)  { q->implb = (expptr)(p->datap); p = p->nextp; }
+               if(p)  { q->impub = (expptr)(p->datap); p = p->nextp; }
+               if(p)  { q->impstep = (expptr)(p->datap); }
+               frchain( & (yypvt[-1].chval) );
+               yyval.chval = mkchain((char *)q, CHNULL);
+               q->datalist = hookup(yypvt[-3].chval, yyval.chval);
+               } break;
+case 108:
+/* # line 657 "gram.in" */
+{ if (!datastack)
+                       curdtp = 0;
+                 datastack = mkchain((char *)curdtp, datastack);
+                 curdtp = yypvt[-0].chval; curdtelt = 0;
+                 } break;
+case 109:
+/* # line 663 "gram.in" */
+{ yyval.chval = hookup(yypvt[-2].chval, yypvt[-0].chval); } break;
+case 110:
+/* # line 667 "gram.in" */
+{ ndim = 0; } break;
+case 112:
+/* # line 671 "gram.in" */
+{ ndim = 0; } break;
+case 115:
+/* # line 676 "gram.in" */
+{
+                 if(ndim == maxdim)
+                       err("too many dimensions");
+                 else if(ndim < maxdim)
+                       { dims[ndim].lb = 0;
+                         dims[ndim].ub = yypvt[-0].expval;
+                       }
+                 ++ndim;
+               } break;
+case 116:
+/* # line 686 "gram.in" */
+{
+                 if(ndim == maxdim)
+                       err("too many dimensions");
+                 else if(ndim < maxdim)
+                       { dims[ndim].lb = yypvt[-2].expval;
+                         dims[ndim].ub = yypvt[-0].expval;
+                       }
+                 ++ndim;
+               } break;
+case 117:
+/* # line 698 "gram.in" */
+{ yyval.expval = 0; } break;
+case 119:
+/* # line 703 "gram.in" */
+{ nstars = 1; labarray[0] = yypvt[-0].labval; } break;
+case 120:
+/* # line 705 "gram.in" */
+{ if(nstars < maxlablist)  labarray[nstars++] = yypvt[-0].labval; } break;
+case 121:
+/* # line 709 "gram.in" */
+{ yyval.labval = execlab( convci(toklen, token) ); } break;
+case 122:
+/* # line 713 "gram.in" */
+{ NO66("IMPLICIT statement"); } break;
+case 125:
+/* # line 719 "gram.in" */
+{ if (vartype != TYUNKNOWN)
+                       dclerr("-- expected letter range",NPNULL);
+                 setimpl(vartype, varleng, 'a', 'z'); } break;
+case 126:
+/* # line 724 "gram.in" */
+{ needkwd = 1; } break;
+case 130:
+/* # line 733 "gram.in" */
+{ setimpl(vartype, varleng, yypvt[-0].ival, yypvt[-0].ival); } break;
+case 131:
+/* # line 735 "gram.in" */
+{ setimpl(vartype, varleng, yypvt[-2].ival, yypvt[-0].ival); } break;
+case 132:
+/* # line 739 "gram.in" */
+{ if(toklen!=1 || token[0]<'a' || token[0]>'z')
+                       {
+                       dclerr("implicit item must be single letter", NPNULL);
+                       yyval.ival = 0;
+                       }
+                 else yyval.ival = token[0];
+               } break;
+case 135:
+/* # line 753 "gram.in" */
+{
+               if(yypvt[-2].namval->vclass == CLUNKNOWN)
+                       {
+                       yypvt[-2].namval->vclass = CLNAMELIST;
+                       yypvt[-2].namval->vtype = TYINT;
+                       yypvt[-2].namval->vstg = STGBSS;
+                       yypvt[-2].namval->varxptr.namelist = yypvt[-0].chval;
+                       yypvt[-2].namval->vardesc.varno = ++lastvarno;
+                       }
+               else dclerr("cannot be a namelist name", yypvt[-2].namval);
+               } break;
+case 136:
+/* # line 767 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].namval, CHNULL); } break;
+case 137:
+/* # line 769 "gram.in" */
+{ yyval.chval = hookup(yypvt[-2].chval, mkchain((char *)yypvt[-0].namval, CHNULL)); } break;
+case 138:
+/* # line 773 "gram.in" */
+{ switch(parstate)
+                       {
+                       case OUTSIDE:   newproc();
+                                       startproc(ESNULL, CLMAIN);
+                       case INSIDE:    parstate = INDCL;
+                       case INDCL:     break;
+
+                       case INDATA:
+                               if (datagripe) {
+                                       errstr(
+                               "Statement order error: declaration after DATA",
+                                               CNULL);
+                                       datagripe = 0;
+                                       }
+                               break;
+
+                       default:
+                               dclerr("declaration among executables", NPNULL);
+                       }
+               } break;
+case 139:
+/* # line 795 "gram.in" */
+{ yyval.chval = 0; } break;
+case 140:
+/* # line 797 "gram.in" */
+{ yyval.chval = revchain(yypvt[-0].chval); } break;
+case 141:
+/* # line 801 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].expval, CHNULL); } break;
+case 142:
+/* # line 803 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].expval, yypvt[-2].chval); } break;
+case 144:
+/* # line 808 "gram.in" */
+{ yyval.expval = yypvt[-1].expval; if (yyval.expval->tag == TPRIM)
+                                       yyval.expval->primblock.parenused = 1; } break;
+case 148:
+/* # line 816 "gram.in" */
+{ yyval.expval = mkexpr(yypvt[-1].ival, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 149:
+/* # line 818 "gram.in" */
+{ yyval.expval = mkexpr(OPSTAR, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 150:
+/* # line 820 "gram.in" */
+{ yyval.expval = mkexpr(OPSLASH, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 151:
+/* # line 822 "gram.in" */
+{ yyval.expval = mkexpr(OPPOWER, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 152:
+/* # line 824 "gram.in" */
+{ if(yypvt[-1].ival == OPMINUS)
+                       yyval.expval = mkexpr(OPNEG, yypvt[-0].expval, ENULL);
+                 else  yyval.expval = yypvt[-0].expval;
+               } break;
+case 153:
+/* # line 829 "gram.in" */
+{ yyval.expval = mkexpr(yypvt[-1].ival, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 154:
+/* # line 831 "gram.in" */
+{ NO66(".EQV. operator");
+                 yyval.expval = mkexpr(OPEQV, yypvt[-2].expval,yypvt[-0].expval); } break;
+case 155:
+/* # line 834 "gram.in" */
+{ NO66(".NEQV. operator");
+                 yyval.expval = mkexpr(OPNEQV, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 156:
+/* # line 837 "gram.in" */
+{ yyval.expval = mkexpr(OPOR, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 157:
+/* # line 839 "gram.in" */
+{ yyval.expval = mkexpr(OPAND, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 158:
+/* # line 841 "gram.in" */
+{ yyval.expval = mkexpr(OPNOT, yypvt[-0].expval, ENULL); } break;
+case 159:
+/* # line 843 "gram.in" */
+{ NO66("concatenation operator //");
+                 yyval.expval = mkexpr(OPCONCAT, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 160:
+/* # line 847 "gram.in" */
+{ yyval.ival = OPPLUS; } break;
+case 161:
+/* # line 848 "gram.in" */
+{ yyval.ival = OPMINUS; } break;
+case 162:
+/* # line 851 "gram.in" */
+{ yyval.ival = OPEQ; } break;
+case 163:
+/* # line 852 "gram.in" */
+{ yyval.ival = OPGT; } break;
+case 164:
+/* # line 853 "gram.in" */
+{ yyval.ival = OPLT; } break;
+case 165:
+/* # line 854 "gram.in" */
+{ yyval.ival = OPGE; } break;
+case 166:
+/* # line 855 "gram.in" */
+{ yyval.ival = OPLE; } break;
+case 167:
+/* # line 856 "gram.in" */
+{ yyval.ival = OPNE; } break;
+case 168:
+/* # line 860 "gram.in" */
+{ yyval.expval = mkprim(yypvt[-0].namval, LBNULL, CHNULL); } break;
+case 169:
+/* # line 862 "gram.in" */
+{ NO66("substring operator :");
+                 yyval.expval = mkprim(yypvt[-1].namval, LBNULL, yypvt[-0].chval); } break;
+case 170:
+/* # line 865 "gram.in" */
+{ yyval.expval = mkprim(yypvt[-3].namval, mklist(yypvt[-1].chval), CHNULL); } break;
+case 171:
+/* # line 867 "gram.in" */
+{ NO66("substring operator :");
+                 yyval.expval = mkprim(yypvt[-4].namval, mklist(yypvt[-2].chval), yypvt[-0].chval); } break;
+case 172:
+/* # line 872 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-3].expval, mkchain((char *)yypvt[-1].expval,CHNULL)); } break;
+case 173:
+/* # line 876 "gram.in" */
+{ yyval.expval = 0; } break;
+case 175:
+/* # line 881 "gram.in" */
+{ if(yypvt[-0].namval->vclass == CLPARAM)
+                       yyval.expval = (expptr) cpexpr(
+                               ( (struct Paramblock *) (yypvt[-0].namval) ) -> paramval);
+               } break;
+case 177:
+/* # line 888 "gram.in" */
+{ yyval.expval = mklogcon(1); } break;
+case 178:
+/* # line 889 "gram.in" */
+{ yyval.expval = mklogcon(0); } break;
+case 179:
+/* # line 890 "gram.in" */
+{ yyval.expval = mkstrcon(toklen, token); } break;
+case 180:
+/* # line 891 "gram.in" */
+ { yyval.expval = mkintcon( convci(toklen, token) ); } break;
+case 181:
+/* # line 892 "gram.in" */
+ { yyval.expval = mkrealcon(tyreal, token); } break;
+case 182:
+/* # line 893 "gram.in" */
+ { yyval.expval = mkrealcon(TYDREAL, token); } break;
+case 184:
+/* # line 898 "gram.in" */
+{ yyval.expval = mkcxcon(yypvt[-3].expval,yypvt[-1].expval); } break;
+case 185:
+/* # line 902 "gram.in" */
+{ NOEXT("hex constant");
+                 yyval.expval = mkbitcon(4, toklen, token); } break;
+case 186:
+/* # line 905 "gram.in" */
+{ NOEXT("octal constant");
+                 yyval.expval = mkbitcon(3, toklen, token); } break;
+case 187:
+/* # line 908 "gram.in" */
+{ NOEXT("binary constant");
+                 yyval.expval = mkbitcon(1, toklen, token); } break;
+case 189:
+/* # line 914 "gram.in" */
+{ yyval.expval = yypvt[-1].expval; } break;
+case 192:
+/* # line 920 "gram.in" */
+{ yyval.expval = mkexpr(yypvt[-1].ival, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 193:
+/* # line 922 "gram.in" */
+{ yyval.expval = mkexpr(OPSTAR, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 194:
+/* # line 924 "gram.in" */
+{ yyval.expval = mkexpr(OPSLASH, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 195:
+/* # line 926 "gram.in" */
+{ yyval.expval = mkexpr(OPPOWER, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 196:
+/* # line 928 "gram.in" */
+{ if(yypvt[-1].ival == OPMINUS)
+                       yyval.expval = mkexpr(OPNEG, yypvt[-0].expval, ENULL);
+                 else  yyval.expval = yypvt[-0].expval;
+               } break;
+case 197:
+/* # line 933 "gram.in" */
+{ NO66("concatenation operator //");
+                 yyval.expval = mkexpr(OPCONCAT, yypvt[-2].expval, yypvt[-0].expval); } break;
+case 199:
+/* # line 938 "gram.in" */
+{
+               if(yypvt[-3].labval->labdefined)
+                       execerr("no backward DO loops", CNULL);
+               yypvt[-3].labval->blklevel = blklevel+1;
+               exdo(yypvt[-3].labval->labelno, NPNULL, yypvt[-0].chval);
+               } break;
+case 200:
+/* # line 945 "gram.in" */
+{
+               exdo((int)(ctls - ctlstack - 2), NPNULL, yypvt[-0].chval);
+               NOEXT("DO without label");
+               } break;
+case 201:
+/* # line 950 "gram.in" */
+{ exenddo(NPNULL); } break;
+case 202:
+/* # line 952 "gram.in" */
+{ exendif();  thiswasbranch = NO; } break;
+case 204:
+/* # line 955 "gram.in" */
+{ exelif(yypvt[-2].expval); lastwasbranch = NO; } break;
+case 205:
+/* # line 957 "gram.in" */
+{ exelse(); lastwasbranch = NO; } break;
+case 206:
+/* # line 959 "gram.in" */
+{ exendif(); lastwasbranch = NO; } break;
+case 207:
+/* # line 963 "gram.in" */
+{ exif(yypvt[-1].expval); } break;
+case 208:
+/* # line 967 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-2].namval, yypvt[-0].chval); } break;
+case 210:
+/* # line 972 "gram.in" */
+{ yyval.chval = mkchain(CNULL, (chainp)yypvt[-1].expval); } break;
+case 211:
+/* # line 976 "gram.in" */
+{ exequals((struct Primblock *)yypvt[-2].expval, yypvt[-0].expval); } break;
+case 212:
+/* # line 978 "gram.in" */
+{ exassign(yypvt[-0].namval, yypvt[-2].labval); } break;
+case 215:
+/* # line 982 "gram.in" */
+{ inioctl = NO; } break;
+case 216:
+/* # line 984 "gram.in" */
+{ exarif(yypvt[-6].expval, yypvt[-4].labval, yypvt[-2].labval, yypvt[-0].labval);  thiswasbranch = YES; } break;
+case 217:
+/* # line 986 "gram.in" */
+{ excall(yypvt[-0].namval, LBNULL, 0, labarray); } break;
+case 218:
+/* # line 988 "gram.in" */
+{ excall(yypvt[-2].namval, LBNULL, 0, labarray); } break;
+case 219:
+/* # line 990 "gram.in" */
+{ if(nstars < maxlablist)
+                       excall(yypvt[-3].namval, mklist(revchain(yypvt[-1].chval)), nstars, labarray);
+                 else
+                       many("alternate returns", 'l', maxlablist);
+               } break;
+case 220:
+/* # line 996 "gram.in" */
+{ exreturn(yypvt[-0].expval);  thiswasbranch = YES; } break;
+case 221:
+/* # line 998 "gram.in" */
+{ exstop(yypvt[-2].ival, yypvt[-0].expval);  thiswasbranch = yypvt[-2].ival; } break;
+case 222:
+/* # line 1002 "gram.in" */
+{ yyval.labval = mklabel( convci(toklen, token) ); } break;
+case 223:
+/* # line 1006 "gram.in" */
+{ if(parstate == OUTSIDE)
+                       {
+                       newproc();
+                       startproc(ESNULL, CLMAIN);
+                       }
+               } break;
+case 224:
+/* # line 1015 "gram.in" */
+{ exgoto(yypvt[-0].labval);  thiswasbranch = YES; } break;
+case 225:
+/* # line 1017 "gram.in" */
+{ exasgoto(yypvt[-0].namval);  thiswasbranch = YES; } break;
+case 226:
+/* # line 1019 "gram.in" */
+{ exasgoto(yypvt[-4].namval);  thiswasbranch = YES; } break;
+case 227:
+/* # line 1021 "gram.in" */
+{ if(nstars < maxlablist)
+                       putcmgo(putx(fixtype(yypvt[-0].expval)), nstars, labarray);
+                 else
+                       many("labels in computed GOTO list", 'l', maxlablist);
+               } break;
+case 230:
+/* # line 1033 "gram.in" */
+{ nstars = 0; yyval.namval = yypvt[-0].namval; } break;
+case 231:
+/* # line 1037 "gram.in" */
+{ yyval.chval = yypvt[-0].expval ? mkchain((char *)yypvt[-0].expval,CHNULL) : CHNULL; } break;
+case 232:
+/* # line 1039 "gram.in" */
+{ yyval.chval = yypvt[-0].expval ? mkchain((char *)yypvt[-0].expval, yypvt[-2].chval) : yypvt[-2].chval; } break;
+case 234:
+/* # line 1044 "gram.in" */
+{ if(nstars < maxlablist) labarray[nstars++] = yypvt[-0].labval; yyval.expval = 0; } break;
+case 235:
+/* # line 1048 "gram.in" */
+{ yyval.ival = 0; } break;
+case 236:
+/* # line 1050 "gram.in" */
+{ yyval.ival = 2; } break;
+case 237:
+/* # line 1054 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].expval, CHNULL); } break;
+case 238:
+/* # line 1056 "gram.in" */
+{ yyval.chval = hookup(yypvt[-2].chval, mkchain((char *)yypvt[-0].expval,CHNULL) ); } break;
+case 239:
+/* # line 1060 "gram.in" */
+{ if(parstate == OUTSIDE)
+                       {
+                       newproc();
+                       startproc(ESNULL, CLMAIN);
+                       }
+
+/* This next statement depends on the ordering of the state table encoding */
+
+                 if(parstate < INDATA) enddcl();
+               } break;
+case 240:
+/* # line 1073 "gram.in" */
+{ intonly = YES; } break;
+case 241:
+/* # line 1077 "gram.in" */
+{ intonly = NO; } break;
+case 242:
+/* # line 1082 "gram.in" */
+{ endio(); } break;
+case 244:
+/* # line 1087 "gram.in" */
+{ ioclause(IOSUNIT, yypvt[-0].expval); endioctl(); } break;
+case 245:
+/* # line 1089 "gram.in" */
+{ ioclause(IOSUNIT, ENULL); endioctl(); } break;
+case 246:
+/* # line 1091 "gram.in" */
+{ ioclause(IOSUNIT, IOSTDERR); endioctl(); } break;
+case 248:
+/* # line 1094 "gram.in" */
+{ doio(CHNULL); } break;
+case 249:
+/* # line 1096 "gram.in" */
+{ doio(CHNULL); } break;
+case 250:
+/* # line 1098 "gram.in" */
+{ doio(revchain(yypvt[-0].chval)); } break;
+case 251:
+/* # line 1100 "gram.in" */
+{ doio(revchain(yypvt[-0].chval)); } break;
+case 252:
+/* # line 1102 "gram.in" */
+{ doio(revchain(yypvt[-0].chval)); } break;
+case 253:
+/* # line 1104 "gram.in" */
+{ doio(CHNULL); } break;
+case 254:
+/* # line 1106 "gram.in" */
+{ doio(revchain(yypvt[-0].chval)); } break;
+case 255:
+/* # line 1108 "gram.in" */
+{ doio(CHNULL); } break;
+case 256:
+/* # line 1110 "gram.in" */
+{ doio(revchain(yypvt[-0].chval)); } break;
+case 258:
+/* # line 1117 "gram.in" */
+{ iostmt = IOBACKSPACE; } break;
+case 259:
+/* # line 1119 "gram.in" */
+{ iostmt = IOREWIND; } break;
+case 260:
+/* # line 1121 "gram.in" */
+{ iostmt = IOENDFILE; } break;
+case 262:
+/* # line 1128 "gram.in" */
+{ iostmt = IOINQUIRE; } break;
+case 263:
+/* # line 1130 "gram.in" */
+{ iostmt = IOOPEN; } break;
+case 264:
+/* # line 1132 "gram.in" */
+{ iostmt = IOCLOSE; } break;
+case 265:
+/* # line 1136 "gram.in" */
+{
+               ioclause(IOSUNIT, ENULL);
+               ioclause(IOSFMT, yypvt[-0].expval);
+               endioctl();
+               } break;
+case 266:
+/* # line 1142 "gram.in" */
+{
+               ioclause(IOSUNIT, ENULL);
+               ioclause(IOSFMT, ENULL);
+               endioctl();
+               } break;
+case 267:
+/* # line 1150 "gram.in" */
+{
+                 ioclause(IOSUNIT, yypvt[-1].expval);
+                 endioctl();
+               } break;
+case 268:
+/* # line 1155 "gram.in" */
+{ endioctl(); } break;
+case 271:
+/* # line 1163 "gram.in" */
+{ ioclause(IOSPOSITIONAL, yypvt[-0].expval); } break;
+case 272:
+/* # line 1165 "gram.in" */
+{ ioclause(IOSPOSITIONAL, ENULL); } break;
+case 273:
+/* # line 1167 "gram.in" */
+{ ioclause(IOSPOSITIONAL, IOSTDERR); } break;
+case 274:
+/* # line 1169 "gram.in" */
+{ ioclause(yypvt[-1].ival, yypvt[-0].expval); } break;
+case 275:
+/* # line 1171 "gram.in" */
+{ ioclause(yypvt[-1].ival, ENULL); } break;
+case 276:
+/* # line 1173 "gram.in" */
+{ ioclause(yypvt[-1].ival, IOSTDERR); } break;
+case 277:
+/* # line 1177 "gram.in" */
+{ yyval.ival = iocname(); } break;
+case 278:
+/* # line 1181 "gram.in" */
+{ iostmt = IOREAD; } break;
+case 279:
+/* # line 1185 "gram.in" */
+{ iostmt = IOWRITE; } break;
+case 280:
+/* # line 1189 "gram.in" */
+{
+               iostmt = IOWRITE;
+               ioclause(IOSUNIT, ENULL);
+               ioclause(IOSFMT, yypvt[-1].expval);
+               endioctl();
+               } break;
+case 281:
+/* # line 1196 "gram.in" */
+{
+               iostmt = IOWRITE;
+               ioclause(IOSUNIT, ENULL);
+               ioclause(IOSFMT, ENULL);
+               endioctl();
+               } break;
+case 282:
+/* # line 1205 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].tagval, CHNULL); } break;
+case 283:
+/* # line 1207 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].tagval, yypvt[-2].chval); } break;
+case 284:
+/* # line 1211 "gram.in" */
+{ yyval.tagval = (tagptr) yypvt[-0].expval; } break;
+case 285:
+/* # line 1213 "gram.in" */
+{ yyval.tagval = (tagptr) mkiodo(yypvt[-1].chval,revchain(yypvt[-3].chval)); } break;
+case 286:
+/* # line 1217 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].expval, CHNULL); } break;
+case 287:
+/* # line 1219 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].tagval, CHNULL); } break;
+case 289:
+/* # line 1224 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].expval, mkchain((char *)yypvt[-2].expval, CHNULL) ); } break;
+case 290:
+/* # line 1226 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].tagval, mkchain((char *)yypvt[-2].expval, CHNULL) ); } break;
+case 291:
+/* # line 1228 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].expval, mkchain((char *)yypvt[-2].tagval, CHNULL) ); } break;
+case 292:
+/* # line 1230 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].tagval, mkchain((char *)yypvt[-2].tagval, CHNULL) ); } break;
+case 293:
+/* # line 1232 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].expval, yypvt[-2].chval); } break;
+case 294:
+/* # line 1234 "gram.in" */
+{ yyval.chval = mkchain((char *)yypvt[-0].tagval, yypvt[-2].chval); } break;
+case 295:
+/* # line 1238 "gram.in" */
+{ yyval.tagval = (tagptr) yypvt[-0].expval; } break;
+case 296:
+/* # line 1240 "gram.in" */
+{ yyval.tagval = (tagptr) yypvt[-1].expval; } break;
+case 297:
+/* # line 1242 "gram.in" */
+{ yyval.tagval = (tagptr) mkiodo(yypvt[-1].chval, mkchain((char *)yypvt[-3].expval, CHNULL) ); } break;
+case 298:
+/* # line 1244 "gram.in" */
+{ yyval.tagval = (tagptr) mkiodo(yypvt[-1].chval, mkchain((char *)yypvt[-3].tagval, CHNULL) ); } break;
+case 299:
+/* # line 1246 "gram.in" */
+{ yyval.tagval = (tagptr) mkiodo(yypvt[-1].chval, revchain(yypvt[-3].chval)); } break;
+case 300:
+/* # line 1250 "gram.in" */
+{ startioctl(); } break;
+       }
+       goto yystack;  /* stack new state and value */
+}

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

diff --git a/usr.bin/f2c/gram.exec b/usr.bin/f2c/gram.exec
new file mode 100644 (file)
index 0000000..0dc6010
--- /dev/null
+++ b/usr.bin/f2c/gram.exec
@@ -0,0 +1,143 @@
+exec:    iffable
+       | SDO end_spec intonlyon label intonlyoff opt_comma dospecw
+               {
+               if($4->labdefined)
+                       execerr("no backward DO loops", CNULL);
+               $4->blklevel = blklevel+1;
+               exdo($4->labelno, NPNULL, $7);
+               }
+       | SDO end_spec opt_comma dospecw
+               {
+               exdo((int)(ctls - ctlstack - 2), NPNULL, $4);
+               NOEXT("DO without label");
+               }
+       | SENDDO
+               { exenddo(NPNULL); }
+       | logif iffable
+               { exendif();  thiswasbranch = NO; }
+       | logif STHEN
+       | SELSEIF end_spec SLPAR expr SRPAR STHEN
+               { exelif($4); lastwasbranch = NO; }
+       | SELSE end_spec
+               { exelse(); lastwasbranch = NO; }
+       | SENDIF end_spec
+               { exendif(); lastwasbranch = NO; }
+       ;
+
+logif:   SLOGIF end_spec SLPAR expr SRPAR
+               { exif($4); }
+       ;
+
+dospec:          name SEQUALS exprlist
+               { $$ = mkchain((char *)$1, $3); }
+       ;
+
+dospecw:  dospec
+       | SWHILE SLPAR expr SRPAR
+               { $$ = mkchain(CNULL, (chainp)$3); }
+       ;
+
+iffable:  let lhs SEQUALS expr
+               { exequals((struct Primblock *)$2, $4); }
+       | SASSIGN end_spec assignlabel STO name
+               { exassign($5, $3); }
+       | SCONTINUE end_spec
+       | goto
+       | io
+               { inioctl = NO; }
+       | SARITHIF end_spec SLPAR expr SRPAR label SCOMMA label SCOMMA label
+               { exarif($4, $6, $8, $10);  thiswasbranch = YES; }
+       | call
+               { excall($1, LBNULL, 0, labarray); }
+       | call SLPAR SRPAR
+               { excall($1, LBNULL, 0, labarray); }
+       | call SLPAR callarglist SRPAR
+               { if(nstars < maxlablist)
+                       excall($1, mklist(revchain($3)), nstars, labarray);
+                 else
+                       many("alternate returns", 'l', maxlablist);
+               }
+       | SRETURN end_spec opt_expr
+               { exreturn($3);  thiswasbranch = YES; }
+       | stop end_spec opt_expr
+               { exstop($1, $3);  thiswasbranch = $1; }
+       ;
+
+assignlabel:   SICON
+               { $$ = mklabel( convci(toklen, token) ); }
+       ;
+
+let:     SLET
+               { if(parstate == OUTSIDE)
+                       {
+                       newproc();
+                       startproc(ESNULL, CLMAIN);
+                       }
+               }
+       ;
+
+goto:    SGOTO end_spec label
+               { exgoto($3);  thiswasbranch = YES; }
+       | SASGOTO end_spec name
+               { exasgoto($3);  thiswasbranch = YES; }
+       | SASGOTO end_spec name opt_comma SLPAR labellist SRPAR
+               { exasgoto($3);  thiswasbranch = YES; }
+       | SCOMPGOTO end_spec SLPAR labellist SRPAR opt_comma expr
+               { if(nstars < maxlablist)
+                       putcmgo(putx(fixtype($7)), nstars, labarray);
+                 else
+                       many("labels in computed GOTO list", 'l', maxlablist);
+               }
+       ;
+
+opt_comma:
+       | SCOMMA
+       ;
+
+call:    SCALL end_spec name
+               { nstars = 0; $$ = $3; }
+       ;
+
+callarglist:  callarg
+               { $$ = $1 ? mkchain((char *)$1,CHNULL) : CHNULL; }
+       | callarglist SCOMMA callarg
+               { $$ = $3 ? mkchain((char *)$3, $1) : $1; }
+       ;
+
+callarg:  expr
+       | SSTAR label
+               { if(nstars < maxlablist) labarray[nstars++] = $2; $$ = 0; }
+       ;
+
+stop:    SPAUSE
+               { $$ = 0; }
+       | SSTOP
+               { $$ = 2; }
+       ;
+
+exprlist:  expr
+               { $$ = mkchain((char *)$1, CHNULL); }
+       | exprlist SCOMMA expr
+               { $$ = hookup($1, mkchain((char *)$3,CHNULL) ); }
+       ;
+
+end_spec:
+               { if(parstate == OUTSIDE)
+                       {
+                       newproc();
+                       startproc(ESNULL, CLMAIN);
+                       }
+
+/* This next statement depends on the ordering of the state table encoding */
+
+                 if(parstate < INDATA) enddcl();
+               }
+       ;
+
+intonlyon:
+               { intonly = YES; }
+       ;
+
+intonlyoff:
+               { intonly = NO; }
+       ;

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

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

diff --git a/usr.bin/f2c/gram.io b/usr.bin/f2c/gram.io
new file mode 100644 (file)
index 0000000..f1a6649
--- /dev/null
+++ b/usr.bin/f2c/gram.io
@@ -0,0 +1,173 @@
+  /*  Input/Output Statements */
+
+io:      io1
+               { endio(); }
+       ;
+
+io1:     iofmove ioctl
+       | iofmove unpar_fexpr
+               { ioclause(IOSUNIT, $2); endioctl(); }
+       | iofmove SSTAR
+               { ioclause(IOSUNIT, ENULL); endioctl(); }
+       | iofmove SPOWER
+               { ioclause(IOSUNIT, IOSTDERR); endioctl(); }
+       | iofctl ioctl
+       | read ioctl
+               { doio(CHNULL); }
+       | read infmt
+               { doio(CHNULL); }
+       | read ioctl inlist
+               { doio(revchain($3)); }
+       | read infmt SCOMMA inlist
+               { doio(revchain($4)); }
+       | read ioctl SCOMMA inlist
+               { doio(revchain($4)); }
+       | write ioctl
+               { doio(CHNULL); }
+       | write ioctl outlist
+               { doio(revchain($3)); }
+       | print
+               { doio(CHNULL); }
+       | print SCOMMA outlist
+               { doio(revchain($3)); }
+       ;
+
+iofmove:   fmkwd end_spec in_ioctl
+       ;
+
+fmkwd:   SBACKSPACE
+               { iostmt = IOBACKSPACE; }
+       | SREWIND
+               { iostmt = IOREWIND; }
+       | SENDFILE
+               { iostmt = IOENDFILE; }
+       ;
+
+iofctl:  ctlkwd end_spec in_ioctl
+       ;
+
+ctlkwd:          SINQUIRE
+               { iostmt = IOINQUIRE; }
+       | SOPEN
+               { iostmt = IOOPEN; }
+       | SCLOSE
+               { iostmt = IOCLOSE; }
+       ;
+
+infmt:   unpar_fexpr
+               {
+               ioclause(IOSUNIT, ENULL);
+               ioclause(IOSFMT, $1);
+               endioctl();
+               }
+       | SSTAR
+               {
+               ioclause(IOSUNIT, ENULL);
+               ioclause(IOSFMT, ENULL);
+               endioctl();
+               }
+       ;
+
+ioctl:   SLPAR fexpr SRPAR
+               {
+                 ioclause(IOSUNIT, $2);
+                 endioctl();
+               }
+       | SLPAR ctllist SRPAR
+               { endioctl(); }
+       ;
+
+ctllist:  ioclause
+       | ctllist SCOMMA ioclause
+       ;
+
+ioclause:  fexpr
+               { ioclause(IOSPOSITIONAL, $1); }
+       | SSTAR
+               { ioclause(IOSPOSITIONAL, ENULL); }
+       | SPOWER
+               { ioclause(IOSPOSITIONAL, IOSTDERR); }
+       | nameeq expr
+               { ioclause($1, $2); }
+       | nameeq SSTAR
+               { ioclause($1, ENULL); }
+       | nameeq SPOWER
+               { ioclause($1, IOSTDERR); }
+       ;
+
+nameeq:  SNAMEEQ
+               { $$ = iocname(); }
+       ;
+
+read:    SREAD end_spec in_ioctl
+               { iostmt = IOREAD; }
+       ;
+
+write:   SWRITE end_spec in_ioctl
+               { iostmt = IOWRITE; }
+       ;
+
+print:   SPRINT end_spec fexpr in_ioctl
+               {
+               iostmt = IOWRITE;
+               ioclause(IOSUNIT, ENULL);
+               ioclause(IOSFMT, $3);
+               endioctl();
+               }
+       | SPRINT end_spec SSTAR in_ioctl
+               {
+               iostmt = IOWRITE;
+               ioclause(IOSUNIT, ENULL);
+               ioclause(IOSFMT, ENULL);
+               endioctl();
+               }
+       ;
+
+inlist:          inelt
+               { $$ = mkchain((char *)$1, CHNULL); }
+       | inlist SCOMMA inelt
+               { $$ = mkchain((char *)$3, $1); }
+       ;
+
+inelt:   lhs
+               { $$ = (tagptr) $1; }
+       | SLPAR inlist SCOMMA dospec SRPAR
+               { $$ = (tagptr) mkiodo($4,revchain($2)); }
+       ;
+
+outlist:  uexpr
+               { $$ = mkchain((char *)$1, CHNULL); }
+       | other
+               { $$ = mkchain((char *)$1, CHNULL); }
+       | out2
+       ;
+
+out2:    uexpr SCOMMA uexpr
+               { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); }
+       | uexpr SCOMMA other
+               { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); }
+       | other SCOMMA uexpr
+               { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); }
+       | other SCOMMA other
+               { $$ = mkchain((char *)$3, mkchain((char *)$1, CHNULL) ); }
+       | out2  SCOMMA uexpr
+               { $$ = mkchain((char *)$3, $1); }
+       | out2  SCOMMA other
+               { $$ = mkchain((char *)$3, $1); }
+       ;
+
+other:   complex_const
+               { $$ = (tagptr) $1; }
+       | SLPAR expr SRPAR
+               { $$ = (tagptr) $2; }
+       | SLPAR uexpr SCOMMA dospec SRPAR
+               { $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); }
+       | SLPAR other SCOMMA dospec SRPAR
+               { $$ = (tagptr) mkiodo($4, mkchain((char *)$2, CHNULL) ); }
+       | SLPAR out2  SCOMMA dospec SRPAR
+               { $$ = (tagptr) mkiodo($4, revchain($2)); }
+       ;
+
+in_ioctl:
+               { startioctl(); }
+       ;

diff --git a/usr.bin/f2c/index b/usr.bin/f2c/index
new file mode 100644 (file)
index 0000000..09422b3
--- /dev/null
+++ b/usr.bin/f2c/index
@@ -0,0 +1,135 @@
+# ======  index for f2c/src ======
+
+file   f2c/src/all
+for    bundle of complete f2c source
+
+# NOTE:        "all from f2c/src" is the complete f2c source (sans libraries).
+#      The remaining files in this directory are the component modules
+#      of "all from f2c/src", so you can request just the modules that
+#      have changed since last you updated your f2c source.  You can
+#      tell what has changed by looking at the timestamps at the end
+#      of "readme from f2c".
+
+file   f2c/src/notice
+
+file   f2c/src/readme
+
+file   f2c/src/cds.c
+
+file   f2c/src/changes
+
+file   f2c/src/data.c
+
+file   f2c/src/defines.h
+
+file   f2c/src/defs.h
+
+file   f2c/src/equiv.c
+
+file   f2c/src/error.c
+
+file   f2c/src/exec.c
+
+file   f2c/src/expr.c
+
+file   f2c/src/f2c.1
+
+file   f2c/src/f2c.1t
+
+file   f2c/src/f2c.h
+
+file   f2c/src/fc
+
+file   f2c/src/format.c
+
+file   f2c/src/format.h
+
+file   f2c/src/formatdata.c
+
+file   f2c/src/ftypes.h
+
+file   f2c/src/gram.c
+
+file   f2c/src/gram.dcl
+
+file   f2c/src/gram.exec
+
+file   f2c/src/gram.expr
+
+file   f2c/src/gram.head
+
+file   f2c/src/gram.io
+
+file   f2c/src/init.c
+
+file   f2c/src/intr.c
+
+file   f2c/src/io.c
+
+file   f2c/src/iob.h
+
+file   f2c/src/lex.c
+
+file   f2c/src/machdefs.h
+
+file   f2c/src/main.c
+
+file   f2c/src/makefile
+
+file   f2c/src/malloc.c
+
+file   f2c/src/mem.c
+
+file   f2c/src/memset.c
+
+file   f2c/src/misc.c
+
+file   f2c/src/names.c
+
+file   f2c/src/names.h
+
+file   f2c/src/niceprintf.c
+
+file   f2c/src/niceprintf.h
+
+file   f2c/src/notice
+
+file   f2c/src/output.c
+
+file   f2c/src/output.h
+
+file   f2c/src/p1defs.h
+
+file   f2c/src/p1output.c
+
+file   f2c/src/parse.h
+
+file   f2c/src/parse_args.c
+
+file   f2c/src/pccdefs.h
+
+file   f2c/src/pread.c
+
+file   f2c/src/proc.c
+
+file   f2c/src/put.c
+
+file   f2c/src/putpcc.c
+
+file   f2c/src/readme
+
+file   f2c/src/sysdep.c
+
+file   f2c/src/sysdep.h
+
+file   f2c/src/tokens
+
+file   f2c/src/usignal.h
+
+file   f2c/src/vax.c
+
+file   f2c/src/version.c
+
+file   f2c/src/xsum.c
+
+file   f2c/src/xsum0.out

diff --git a/usr.bin/f2c/index.html b/usr.bin/f2c/index.html
new file mode 100644 (file)
index 0000000..f93c66c
--- /dev/null
+++ b/usr.bin/f2c/index.html
@@ -0,0 +1,142 @@
+<TITLE>f2c/src/index</TITLE><UL>
+<PRE>
+======  index for f2c/src ======
+</PRE>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/all.Z">f2c/src/all</A><MENU>
+<LI><EM>for: </EM>bundle of complete f2c source
+</MENU>
+<PRE>
+NOTE:  "all from f2c/src" is the complete f2c source (sans libraries).
+The remaining files in this directory are the component modules
+of "all from f2c/src", so you can request just the modules that
+have changed since last you updated your f2c source.  You can
+tell what has changed by looking at the timestamps at the end
+of "readme from f2c".
+</PRE>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/notice.Z">f2c/src/notice</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/readme.Z">f2c/src/readme</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/cds.c.Z">f2c/src/cds.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/changes.Z">f2c/src/changes</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/data.c.Z">f2c/src/data.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/defines.h.Z">f2c/src/defines.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/defs.h.Z">f2c/src/defs.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/equiv.c.Z">f2c/src/equiv.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/error.c.Z">f2c/src/error.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/exec.c.Z">f2c/src/exec.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/expr.c.Z">f2c/src/expr.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/f2c.1.Z">f2c/src/f2c.1</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/f2c.1t.Z">f2c/src/f2c.1t</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/f2c.h.Z">f2c/src/f2c.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/fc.Z">f2c/src/fc</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/format.c.Z">f2c/src/format.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/format.h.Z">f2c/src/format.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/formatdata.c.Z">f2c/src/formatdata.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/ftypes.h.Z">f2c/src/ftypes.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/gram.c.Z">f2c/src/gram.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/gram.dcl.Z">f2c/src/gram.dcl</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/gram.exec.Z">f2c/src/gram.exec</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/gram.expr.Z">f2c/src/gram.expr</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/gram.head.Z">f2c/src/gram.head</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/gram.io.Z">f2c/src/gram.io</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/init.c.Z">f2c/src/init.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/intr.c.Z">f2c/src/intr.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/io.c.Z">f2c/src/io.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/iob.h.Z">f2c/src/iob.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/lex.c.Z">f2c/src/lex.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/machdefs.h.Z">f2c/src/machdefs.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/main.c.Z">f2c/src/main.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/makefile.Z">f2c/src/makefile</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/malloc.c.Z">f2c/src/malloc.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/mem.c.Z">f2c/src/mem.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/memset.c.Z">f2c/src/memset.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/misc.c.Z">f2c/src/misc.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/names.c.Z">f2c/src/names.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/names.h.Z">f2c/src/names.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/niceprintf.c.Z">f2c/src/niceprintf.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/niceprintf.h.Z">f2c/src/niceprintf.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/notice.Z">f2c/src/notice</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/output.c.Z">f2c/src/output.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/output.h.Z">f2c/src/output.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/p1defs.h.Z">f2c/src/p1defs.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/p1output.c.Z">f2c/src/p1output.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/parse.h.Z">f2c/src/parse.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/parse_args.c.Z">f2c/src/parse_args.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/pccdefs.h.Z">f2c/src/pccdefs.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/pread.c.Z">f2c/src/pread.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/proc.c.Z">f2c/src/proc.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/put.c.Z">f2c/src/put.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/putpcc.c.Z">f2c/src/putpcc.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/readme.Z">f2c/src/readme</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/sysdep.c.Z">f2c/src/sysdep.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/sysdep.h.Z">f2c/src/sysdep.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/tokens.Z">f2c/src/tokens</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/usignal.h.Z">f2c/src/usignal.h</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/vax.c.Z">f2c/src/vax.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/version.c.Z">f2c/src/version.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/xsum.c.Z">f2c/src/xsum.c</A><MENU>
+</MENU>
+<LI><EM>file: </EM><A HREF="ftp://netlib.att.com/netlib/f2c/src/xsum0.out.Z">f2c/src/xsum0.out</A><MENU>
+</MENU>
+<P><LI><A HREF="ftp://netlib.att.com/netlib/bib/thesaurus.Z">glossary/thesaurus of terms used in this index</A>
+</UL>
+<P><A HREF="ftp://netlib.att.com/netlib/bib/ericjack.Z">Eric and Jack</EM>

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

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

diff --git a/usr.bin/f2c/io.c b/usr.bin/f2c/io.c
new file mode 100644 (file)
index 0000000..761876c
--- /dev/null
+++ b/usr.bin/f2c/io.c
@@ -0,0 +1,1420 @@
+/****************************************************************
+Copyright 1990, 1991, 1993 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* Routines to generate code for I/O statements.
+   Some corrections and improvements due to David Wasley, U. C. Berkeley
+*/
+
+/* TEMPORARY */
+#define TYIOINT TYLONG
+#define SZIOINT SZLONG
+
+#include "defs.h"
+#include "names.h"
+#include "iob.h"
+
+extern int inqmask;
+
+LOCAL void dofclose(), dofinquire(), dofinquire(), dofmove(), dofopen(),
+       doiolist(), ioset(), ioseta(), iosetc(), iosetip(), iosetlc(),
+       putio(), putiocall();
+
+iob_data *iob_list;
+Addrp io_structs[9];
+
+LOCAL char ioroutine[12];
+
+LOCAL long ioendlab;
+LOCAL long ioerrlab;
+LOCAL int endbit;
+LOCAL int errbit;
+LOCAL long jumplab;
+LOCAL long skiplab;
+LOCAL int ioformatted;
+LOCAL int statstruct = NO;
+LOCAL struct Labelblock *skiplabel;
+Addrp ioblkp;
+
+#define UNFORMATTED 0
+#define FORMATTED 1
+#define LISTDIRECTED 2
+#define NAMEDIRECTED 3
+
+#define V(z)   ioc[z].iocval
+
+#define IOALL 07777
+
+LOCAL struct Ioclist
+{
+       char *iocname;
+       int iotype;
+       expptr iocval;
+}
+ioc[ ] =
+{
+       { "", 0 },
+       { "unit", IOALL },
+       { "fmt", M(IOREAD) | M(IOWRITE) },
+       { "err", IOALL },
+       { "end", M(IOREAD) },
+       { "iostat", IOALL },
+       { "rec", M(IOREAD) | M(IOWRITE) },
+       { "recl", M(IOOPEN) | M(IOINQUIRE) },
+       { "file", M(IOOPEN) | M(IOINQUIRE) },
+       { "status", M(IOOPEN) | M(IOCLOSE) },
+       { "access", M(IOOPEN) | M(IOINQUIRE) },
+       { "form", M(IOOPEN) | M(IOINQUIRE) },
+       { "blank", M(IOOPEN) | M(IOINQUIRE) },
+       { "exist", M(IOINQUIRE) },
+       { "opened", M(IOINQUIRE) },
+       { "number", M(IOINQUIRE) },
+       { "named", M(IOINQUIRE) },
+       { "name", M(IOINQUIRE) },
+       { "sequential", M(IOINQUIRE) },
+       { "direct", M(IOINQUIRE) },
+       { "formatted", M(IOINQUIRE) },
+       { "unformatted", M(IOINQUIRE) },
+       { "nextrec", M(IOINQUIRE) },
+       { "nml", M(IOREAD) | M(IOWRITE) }
+};
+
+#define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1)
+
+/* #define IOSUNIT 1 */
+/* #define IOSFMT 2 */
+#define IOSERR 3
+#define IOSEND 4
+#define IOSIOSTAT 5
+#define IOSREC 6
+#define IOSRECL 7
+#define IOSFILE 8
+#define IOSSTATUS 9
+#define IOSACCESS 10
+#define IOSFORM 11
+#define IOSBLANK 12
+#define IOSEXISTS 13
+#define IOSOPENED 14
+#define IOSNUMBER 15
+#define IOSNAMED 16
+#define IOSNAME 17
+#define IOSSEQUENTIAL 18
+#define IOSDIRECT 19
+#define IOSFORMATTED 20
+#define IOSUNFORMATTED 21
+#define IOSNEXTREC 22
+#define IOSNML 23
+
+#define IOSTP V(IOSIOSTAT)
+
+
+/* offsets in generated structures */
+
+#define SZFLAG SZIOINT
+
+/* offsets for external READ and WRITE statements */
+
+#define XERR 0
+#define XUNIT  SZFLAG
+#define XEND   SZFLAG + SZIOINT
+#define XFMT   2*SZFLAG + SZIOINT
+#define XREC   2*SZFLAG + SZIOINT + SZADDR
+
+/* offsets for internal READ and WRITE statements */
+
+#define XIUNIT SZFLAG
+#define XIEND  SZFLAG + SZADDR
+#define XIFMT  2*SZFLAG + SZADDR
+#define XIRLEN 2*SZFLAG + 2*SZADDR
+#define XIRNUM 2*SZFLAG + 2*SZADDR + SZIOINT
+#define XIREC  2*SZFLAG + 2*SZADDR + 2*SZIOINT
+
+/* offsets for OPEN statements */
+
+#define XFNAME SZFLAG + SZIOINT
+#define XFNAMELEN      SZFLAG + SZIOINT + SZADDR
+#define XSTATUS        SZFLAG + 2*SZIOINT + SZADDR
+#define XACCESS        SZFLAG + 2*SZIOINT + 2*SZADDR
+#define XFORMATTED     SZFLAG + 2*SZIOINT + 3*SZADDR
+#define XRECLEN        SZFLAG + 2*SZIOINT + 4*SZADDR
+#define XBLANK SZFLAG + 3*SZIOINT + 4*SZADDR
+
+/* offset for CLOSE statement */
+
+#define XCLSTATUS      SZFLAG + SZIOINT
+
+/* offsets for INQUIRE statement */
+
+#define XFILE  SZFLAG + SZIOINT
+#define XFILELEN       SZFLAG + SZIOINT + SZADDR
+#define XEXISTS        SZFLAG + 2*SZIOINT + SZADDR
+#define XOPEN  SZFLAG + 2*SZIOINT + 2*SZADDR
+#define XNUMBER        SZFLAG + 2*SZIOINT + 3*SZADDR
+#define XNAMED SZFLAG + 2*SZIOINT + 4*SZADDR
+#define XNAME  SZFLAG + 2*SZIOINT + 5*SZADDR
+#define XNAMELEN       SZFLAG + 2*SZIOINT + 6*SZADDR
+#define XQACCESS       SZFLAG + 3*SZIOINT + 6*SZADDR
+#define XQACCLEN       SZFLAG + 3*SZIOINT + 7*SZADDR
+#define XSEQ   SZFLAG + 4*SZIOINT + 7*SZADDR
+#define XSEQLEN        SZFLAG + 4*SZIOINT + 8*SZADDR
+#define XDIRECT        SZFLAG + 5*SZIOINT + 8*SZADDR
+#define XDIRLEN        SZFLAG + 5*SZIOINT + 9*SZADDR
+#define XFORM  SZFLAG + 6*SZIOINT + 9*SZADDR
+#define XFORMLEN       SZFLAG + 6*SZIOINT + 10*SZADDR
+#define XFMTED SZFLAG + 7*SZIOINT + 10*SZADDR
+#define XFMTEDLEN      SZFLAG + 7*SZIOINT + 11*SZADDR
+#define XUNFMT SZFLAG + 8*SZIOINT + 11*SZADDR
+#define XUNFMTLEN      SZFLAG + 8*SZIOINT + 12*SZADDR
+#define XQRECL SZFLAG + 9*SZIOINT + 12*SZADDR
+#define XNEXTREC       SZFLAG + 9*SZIOINT + 13*SZADDR
+#define XQBLANK        SZFLAG + 9*SZIOINT + 14*SZADDR
+#define XQBLANKLEN     SZFLAG + 9*SZIOINT + 15*SZADDR
+
+LOCAL char *cilist_names[] = {
+       "cilist",
+       "cierr",
+       "ciunit",
+       "ciend",
+       "cifmt",
+       "cirec"
+       };
+LOCAL char *icilist_names[] = {
+       "icilist",
+       "icierr",
+       "iciunit",
+       "iciend",
+       "icifmt",
+       "icirlen",
+       "icirnum"
+       };
+LOCAL char *olist_names[] = {
+       "olist",
+       "oerr",
+       "ounit",
+       "ofnm",
+       "ofnmlen",
+       "osta",
+       "oacc",
+       "ofm",
+       "orl",
+       "oblnk"
+       };
+LOCAL char *cllist_names[] = {
+       "cllist",
+       "cerr",
+       "cunit",
+       "csta"
+       };
+LOCAL char *alist_names[] = {
+       "alist",
+       "aerr",
+       "aunit"
+       };
+LOCAL char *inlist_names[] = {
+       "inlist",
+       "inerr",
+       "inunit",
+       "infile",
+       "infilen",
+       "inex",
+       "inopen",
+       "innum",
+       "innamed",
+       "inname",
+       "innamlen",
+       "inacc",
+       "inacclen",
+       "inseq",
+       "inseqlen",
+       "indir",
+       "indirlen",
+       "infmt",
+       "infmtlen",
+       "inform",
+       "informlen",
+       "inunf",
+       "inunflen",
+       "inrecl",
+       "innrec",
+       "inblank",
+       "inblanklen"
+       };
+
+LOCAL char **io_fields;
+
+#define zork(n,t) n, sizeof(n)/sizeof(char *) - 1, t
+
+LOCAL io_setup io_stuff[] = {
+       zork(cilist_names, TYCILIST),   /* external read/write */
+       zork(inlist_names, TYINLIST),   /* inquire */
+       zork(olist_names,  TYOLIST),    /* open */
+       zork(cllist_names, TYCLLIST),   /* close */
+       zork(alist_names,  TYALIST),    /* rewind */
+       zork(alist_names,  TYALIST),    /* backspace */
+       zork(alist_names,  TYALIST),    /* endfile */
+       zork(icilist_names,TYICILIST),  /* internal read */
+       zork(icilist_names,TYICILIST)   /* internal write */
+       };
+
+#undef zork
+
+
+fmtstmt(lp)
+register struct Labelblock *lp;
+{
+       if(lp == NULL)
+       {
+               execerr("unlabeled format statement" , CNULL);
+               return(-1);
+       }
+       if(lp->labtype == LABUNKNOWN)
+       {
+               lp->labtype = LABFORMAT;
+               lp->labelno = newlabel();
+       }
+       else if(lp->labtype != LABFORMAT)
+       {
+               execerr("bad format number", CNULL);
+               return(-1);
+       }
+       return(lp->labelno);
+}
+
+
+setfmt(lp)
+struct Labelblock *lp;
+{
+       int n;
+       char *s0, *lexline();
+       register char *s, *se, *t;
+       register k;
+
+       s0 = s = lexline(&n);
+       se = t = s + n;
+
+       /* warn of trivial errors, e.g. "  11 CONTINUE" (one too few spaces) */
+       /* following FORMAT... */
+
+       if (n <= 0)
+               warn("No (...) after FORMAT");
+       else if (*s != '(')
+               warni("%c rather than ( after FORMAT", *s);
+       else if (se[-1] != ')') {
+               *se = 0;
+               while(--t > s && *t != ')') ;
+               if (t <= s)
+                       warn("No ) at end of FORMAT statement");
+               else if (se - t > 30)
+                       warn1("Extraneous text at end of FORMAT: ...%s", se-12);
+               else
+                       warn1("Extraneous text at end of FORMAT: %s", t+1);
+               t = se;
+               }
+
+       /* fix MYQUOTES (\002's) and \\'s */
+
+       while(s < se)
+               switch(*s++) {
+                       case 2:
+                               t += 3; break;
+                       case '"':
+                       case '\\':
+                               t++; break;
+                       }
+       s = s0;
+       if (lp) {
+               lp->fmtstring = t = mem((int)(t - s + 1), 0);
+               while(s < se)
+                       switch(k = *s++) {
+                               case 2:
+                                       t[0] = '\\';
+                                       t[1] = '0';
+                                       t[2] = '0';
+                                       t[3] = '2';
+                                       t += 4;
+                                       break;
+                               case '"':
+                               case '\\':
+                                       *t++ = '\\';
+                                       /* no break */
+                               default:
+                                       *t++ = k;
+                               }
+               *t = 0;
+               }
+       flline();
+}
+
+
+
+startioctl()
+{
+       register int i;
+
+       inioctl = YES;
+       nioctl = 0;
+       ioformatted = UNFORMATTED;
+       for(i = 1 ; i<=NIOS ; ++i)
+               V(i) = NULL;
+}
+
+ static long
+newiolabel() {
+       long rv;
+       rv = ++lastiolabno;
+       skiplabel = mklabel(rv);
+       skiplabel->labdefined = 1;
+       return rv;
+       }
+
+
+endioctl()
+{
+       int i;
+       expptr p;
+       struct io_setup *ios;
+
+       inioctl = NO;
+
+       /* set up for error recovery */
+
+       ioerrlab = ioendlab = skiplab = jumplab = 0;
+
+       if(p = V(IOSEND))
+               if(ISICON(p))
+                       execlab(ioendlab = p->constblock.Const.ci);
+               else
+                       err("bad end= clause");
+
+       if(p = V(IOSERR))
+               if(ISICON(p))
+                       execlab(ioerrlab = p->constblock.Const.ci);
+               else
+                       err("bad err= clause");
+
+       if(IOSTP)
+               if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) )
+               {
+                       err("iostat must be an integer variable");
+                       frexpr(IOSTP);
+                       IOSTP = NULL;
+               }
+
+       if(iostmt == IOREAD)
+       {
+               if(IOSTP)
+               {
+                       if(ioerrlab && ioendlab && ioerrlab==ioendlab)
+                               jumplab = ioerrlab;
+                       else
+                               skiplab = jumplab = newiolabel();
+               }
+               else    {
+                       if(ioerrlab && ioendlab && ioerrlab!=ioendlab)
+                       {
+                               IOSTP = (expptr) mktmp(TYINT, ENULL);
+                               skiplab = jumplab = newiolabel();
+                       }
+                       else
+                               jumplab = (ioerrlab ? ioerrlab : ioendlab);
+               }
+       }
+       else if(iostmt == IOWRITE)
+       {
+               if(IOSTP && !ioerrlab)
+                       skiplab = jumplab = newiolabel();
+               else
+                       jumplab = ioerrlab;
+       }
+       else
+               jumplab = ioerrlab;
+
+       endbit = IOSTP!=NULL || ioendlab!=0;    /* for use in startrw() */
+       errbit = IOSTP!=NULL || ioerrlab!=0;
+       if (jumplab && !IOSTP)
+               IOSTP = (expptr) mktmp(TYINT, ENULL);
+
+       if(iostmt!=IOREAD && iostmt!=IOWRITE)
+       {
+               ios = io_stuff + iostmt;
+               io_fields = ios->fields;
+               ioblkp = io_structs[iostmt];
+               if(ioblkp == NULL)
+                       io_structs[iostmt] = ioblkp =
+                               autovar(1, ios->type, ENULL, "");
+               ioset(TYIOINT, XERR, ICON(errbit));
+       }
+
+       switch(iostmt)
+       {
+       case IOOPEN:
+               dofopen();
+               break;
+
+       case IOCLOSE:
+               dofclose();
+               break;
+
+       case IOINQUIRE:
+               dofinquire();
+               break;
+
+       case IOBACKSPACE:
+               dofmove("f_back");
+               break;
+
+       case IOREWIND:
+               dofmove("f_rew");
+               break;
+
+       case IOENDFILE:
+               dofmove("f_end");
+               break;
+
+       case IOREAD:
+       case IOWRITE:
+               startrw();
+               break;
+
+       default:
+               fatali("impossible iostmt %d", iostmt);
+       }
+       for(i = 1 ; i<=NIOS ; ++i)
+               if(i!=IOSIOSTAT && V(i)!=NULL)
+                       frexpr(V(i));
+}
+
+
+
+iocname()
+{
+       register int i;
+       int found, mask;
+
+       found = 0;
+       mask = M(iostmt);
+       for(i = 1 ; i <= NIOS ; ++i)
+               if(!strcmp(ioc[i].iocname, token))
+                       if(ioc[i].iotype & mask)
+                               return(i);
+                       else {
+                               found = i;
+                               break;
+                               }
+       if(found) {
+               if (iostmt == IOOPEN && !strcmp(ioc[i].iocname, "name")) {
+                       NOEXT("open with \"name=\" treated as \"file=\"");
+                       for(i = 1; strcmp(ioc[i].iocname, "file"); i++);
+                       return i;
+                       }
+               errstr("invalid control %s for statement", ioc[found].iocname);
+               }
+       else
+               errstr("unknown iocontrol %s", token);
+       return(IOSBAD);
+}
+
+
+ioclause(n, p)
+register int n;
+register expptr p;
+{
+       struct Ioclist *iocp;
+
+       ++nioctl;
+       if(n == IOSBAD)
+               return;
+       if(n == IOSPOSITIONAL)
+               {
+               n = nioctl;
+               if (n == IOSFMT) {
+                       if (iostmt == IOOPEN) {
+                               n = IOSFILE;
+                               NOEXT("file= specifier omitted from open");
+                               }
+                       else if (iostmt < IOREAD)
+                               goto illegal;
+                       }
+               else if(n > IOSFMT)
+                       {
+ illegal:
+                       err("illegal positional iocontrol");
+                       return;
+                       }
+               }
+       else if (n == IOSNML)
+               n = IOSFMT;
+
+       if(p == NULL)
+       {
+               if(n == IOSUNIT)
+                       p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT);
+               else if(n != IOSFMT)
+               {
+                       err("illegal * iocontrol");
+                       return;
+               }
+       }
+       if(n == IOSFMT)
+               ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED);
+
+       iocp = & ioc[n];
+       if(iocp->iocval == NULL)
+       {
+               if(n!=IOSFMT && ( n!=IOSUNIT || (p && p->headblock.vtype!=TYCHAR) ) )
+                       p = fixtype(p);
+               else if (p && p->tag == TPRIM
+                          && p->primblock.namep->vclass == CLUNKNOWN) {
+                       /* kludge made necessary by attempt to infer types
+                        * for untyped external parameters: given an error
+                        * in calling sequences, an integer argument might
+                        * tentatively be assumed TYCHAR; this would otherwise
+                        * be corrected too late in startrw after startrw
+                        * had decided this to be an internal file.
+                        */
+                       vardcl(p->primblock.namep);
+                       p->primblock.vtype = p->primblock.namep->vtype;
+                       }
+               iocp->iocval = p;
+       }
+       else
+               errstr("iocontrol %s repeated", iocp->iocname);
+}
+
+/* io list item */
+
+doio(list)
+chainp list;
+{
+       expptr call0();
+
+       if(ioformatted == NAMEDIRECTED)
+       {
+               if(list)
+                       err("no I/O list allowed in NAMELIST read/write");
+       }
+       else
+       {
+               doiolist(list);
+               ioroutine[0] = 'e';
+               if (skiplab || ioroutine[4] == 'l')
+                       jumplab = 0;
+               putiocall( call0(TYINT, ioroutine) );
+       }
+}
+
+
+
+
+
+ LOCAL void
+doiolist(p0)
+ chainp p0;
+{
+       chainp p;
+       register tagptr q;
+       register expptr qe;
+       register Namep qn;
+       Addrp tp, mkscalar();
+       int range;
+       extern char *ohalign;
+
+       for (p = p0 ; p ; p = p->nextp)
+       {
+               q = (tagptr)p->datap;
+               if(q->tag == TIMPLDO)
+               {
+                       exdo(range=newlabel(), (Namep)0,
+                               q->impldoblock.impdospec);
+                       doiolist(q->impldoblock.datalist);
+                       enddo(range);
+                       free( (charptr) q);
+               }
+               else    {
+                       if(q->tag==TPRIM && q->primblock.argsp==NULL
+                           && q->primblock.namep->vdim!=NULL)
+                       {
+                               vardcl(qn = q->primblock.namep);
+                               if(qn->vdim->nelt) {
+                                       putio( fixtype(cpexpr(qn->vdim->nelt)),
+                                           (expptr)mkscalar(qn) );
+                                       qn->vlastdim = 0;
+                                       }
+                               else
+                                       err("attempt to i/o array of unknown size");
+                       }
+                       else if(q->tag==TPRIM && q->primblock.argsp==NULL &&
+                           (qe = (expptr) memversion(q->primblock.namep)) )
+                               putio(ICON(1),qe);
+                       else if (ISCONST(q) && q->constblock.vtype == TYCHAR) {
+                               halign = 0;
+                               putio(ICON(1), qe = fixtype(cpexpr(q)));
+                               halign = ohalign;
+                               }
+                       else if(((qe = fixtype(cpexpr(q)))->tag==TADDR &&
+                           (qe->addrblock.uname_tag != UNAM_CONST ||
+                           !ISCOMPLEX(qe -> addrblock.vtype))) ||
+                           (qe -> tag == TCONST && !ISCOMPLEX(qe ->
+                           headblock.vtype))) {
+                               if (qe -> tag == TCONST)
+                                       qe = (expptr) putconst((Constp)qe);
+                               putio(ICON(1), qe);
+                       }
+                       else if(qe->headblock.vtype != TYERROR)
+                       {
+                               if(iostmt == IOWRITE)
+                               {
+                                       ftnint lencat();
+                                       expptr qvl;
+                                       qvl = NULL;
+                                       if( ISCHAR(qe) )
+                                       {
+                                               qvl = (expptr)
+                                                   cpexpr(qe->headblock.vleng);
+                                               tp = mktmp(qe->headblock.vtype,
+                                                   ICON(lencat(qe)));
+                                       }
+                                       else
+                                               tp = mktmp(qe->headblock.vtype,
+                                                   qe->headblock.vleng);
+                                       puteq( cpexpr((expptr)tp), qe);
+                                       if(qvl) /* put right length on block */
+                                       {
+                                               frexpr(tp->vleng);
+                                               tp->vleng = qvl;
+                                       }
+                                       putio(ICON(1), (expptr)tp);
+                               }
+                               else
+                                       err("non-left side in READ list");
+                       }
+                       frexpr(q);
+               }
+       }
+       frchain( &p0 );
+}
+
+ int iocalladdr = TYADDR;      /* for fixing TYADDR in saveargtypes */
+ int typeconv[TYERROR+1] = {
+#ifdef TYQUAD
+               0, 1, 11, 2, 3, 14, 4, 5, 6, 7, 12, 13, 8, 9, 10, 15
+#else
+               0, 1, 11, 2, 3,     4, 5, 6, 7, 12, 13, 8, 9, 10, 14
+#endif
+               };
+
+ LOCAL void
+putio(nelt, addr)
+ expptr nelt;
+ register expptr addr;
+{
+       int type;
+       register expptr q;
+       register Addrp c = 0;
+
+       type = addr->headblock.vtype;
+       if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) )
+       {
+               nelt = mkexpr(OPSTAR, ICON(2), nelt);
+               type -= (TYCOMPLEX-TYREAL);
+       }
+
+       /* pass a length with every item.  for noncharacter data, fake one */
+       if(type != TYCHAR)
+       {
+
+               if( ISCONST(addr) )
+                       addr = (expptr) putconst((Constp)addr);
+               c = ALLOC(Addrblock);
+               c->tag = TADDR;
+               c->vtype = TYLENG;
+               c->vstg = STGAUTO;
+               c->ntempelt = 1;
+               c->isarray = 1;
+               c->memoffset = ICON(0);
+               c->uname_tag = UNAM_IDENT;
+               c->charleng = 1;
+               sprintf(c->user.ident, "(ftnlen)sizeof(%s)", typename[type]);
+               addr = mkexpr(OPCHARCAST, addr, ENULL);
+               }
+
+       nelt = fixtype( mkconv(tyioint,nelt) );
+       if(ioformatted == LISTDIRECTED) {
+               expptr mc = mkconv(tyioint, ICON(typeconv[type]));
+               q = c   ? call4(TYINT, "do_lio", mc, nelt, addr, (expptr)c)
+                       : call3(TYINT, "do_lio", mc, nelt, addr);
+               }
+       else {
+               char *s = ioformatted==FORMATTED ? "do_fio" : "do_uio";
+               q = c   ? call3(TYINT, s, nelt, addr, (expptr)c)
+                       : call2(TYINT, s, nelt, addr);
+               }
+       iocalladdr = TYCHAR;
+       putiocall(q);
+       iocalladdr = TYADDR;
+}
+
+
+
+
+endio()
+{
+       extern void p1_label();
+
+       if(skiplab)
+       {
+               if (ioformatted != NAMEDIRECTED)
+                       p1_label((long)(skiplabel - labeltab));
+               if(ioendlab) {
+                       exif( mkexpr(OPLT, cpexpr(IOSTP), ICON(0)));
+                       exgoto(execlab(ioendlab));
+                       exendif();
+                       }
+               if(ioerrlab) {
+                       exif( mkexpr(iostmt==IOREAD||iostmt==IOWRITE
+                                       ? OPGT : OPNE,
+                               cpexpr(IOSTP), ICON(0)));
+                       exgoto(execlab(ioerrlab));
+                       exendif();
+                       }
+       }
+
+       if(IOSTP)
+               frexpr(IOSTP);
+}
+
+
+
+ LOCAL void
+putiocall(q)
+ register expptr q;
+{
+       int tyintsave;
+
+       tyintsave = tyint;
+       tyint = tyioint;        /* for -I2 and -i2 */
+
+       if(IOSTP)
+       {
+               q->headblock.vtype = TYINT;
+               q = fixexpr((Exprp)mkexpr(OPASSIGN, cpexpr(IOSTP), q));
+       }
+       putexpr(q);
+       if(jumplab) {
+               exif(mkexpr(OPNE, cpexpr(IOSTP), ICON(0)));
+               exgoto(execlab(jumplab));
+               exendif();
+               }
+       tyint = tyintsave;
+}
+
+ void
+fmtname(np, q)
+ Namep np;
+ register Addrp q;
+{
+       register int k;
+       register char *s, *t;
+       extern chainp assigned_fmts;
+
+       if (!np->vfmt_asg) {
+               np->vfmt_asg = 1;
+               assigned_fmts = mkchain((char *)np, assigned_fmts);
+               }
+       k = strlen(s = np->fvarname);
+       if (k < IDENT_LEN - 4) {
+               q->uname_tag = UNAM_IDENT;
+               t = q->user.ident;
+               }
+       else {
+               q->uname_tag = UNAM_CHARP;
+               q->user.Charp = t = mem(k + 5,0);
+               }
+       sprintf(t, "%s_fmt", s);
+       }
+
+LOCAL Addrp asg_addr(p)
+ union Expression *p;
+{
+       register Addrp q;
+
+       if (p->tag != TPRIM)
+               badtag("asg_addr", p->tag);
+       q = ALLOC(Addrblock);
+       q->tag = TADDR;
+       q->vtype = TYCHAR;
+       q->vstg = STGAUTO;
+       q->ntempelt = 1;
+       q->isarray = 0;
+       q->memoffset = ICON(0);
+       fmtname(p->primblock.namep, q);
+       return q;
+       }
+
+startrw()
+{
+       register expptr p;
+       register Namep np;
+       register Addrp unitp, fmtp, recp;
+       register expptr nump;
+       Addrp mkscalar();
+       expptr mkaddcon();
+       int iostmt1;
+       flag intfile, sequential, ok, varfmt;
+       struct io_setup *ios;
+
+       /* First look at all the parameters and determine what is to be done */
+
+       ok = YES;
+       statstruct = YES;
+
+       intfile = NO;
+       if(p = V(IOSUNIT))
+       {
+               if( ISINT(p->headblock.vtype) ) {
+ int_unit:
+                       unitp = (Addrp) cpexpr(p);
+                       }
+               else if(p->headblock.vtype == TYCHAR)
+               {
+                       if (nioctl == 1 && iostmt == IOREAD) {
+                               /* kludge to recognize READ(format expr) */
+                               V(IOSFMT) = p;
+                               V(IOSUNIT) = p = (expptr) IOSTDIN;
+                               ioformatted = FORMATTED;
+                               goto int_unit;
+                               }
+                       intfile = YES;
+                       if(p->tag==TPRIM && p->primblock.argsp==NULL &&
+                           (np = p->primblock.namep)->vdim!=NULL)
+                       {
+                               vardcl(np);
+                               if(nump = np->vdim->nelt)
+                               {
+                                       nump = fixtype(cpexpr(nump));
+                                       if( ! ISCONST(nump) ) {
+                                               statstruct = NO;
+                                               np->vlastdim = 0;
+                                               }
+                               }
+                               else
+                               {
+                                       err("attempt to use internal unit array of unknown size");
+                                       ok = NO;
+                                       nump = ICON(1);
+                               }
+                               unitp = mkscalar(np);
+                       }
+                       else    {
+                               nump = ICON(1);
+                               unitp = (Addrp /*pjw */) fixtype(cpexpr(p));
+                       }
+                       if(! isstatic((expptr)unitp) )
+                               statstruct = NO;
+               }
+               else {
+                       err("unit specifier not of type integer or character");
+                       ok = NO;
+                       }
+       }
+       else
+       {
+               err("bad unit specifier");
+               ok = NO;
+       }
+
+       sequential = YES;
+       if(p = V(IOSREC))
+               if( ISINT(p->headblock.vtype) )
+               {
+                       recp = (Addrp) cpexpr(p);
+                       sequential = NO;
+               }
+               else    {
+                       err("bad REC= clause");
+                       ok = NO;
+               }
+       else
+               recp = NULL;
+
+
+       varfmt = YES;
+       fmtp = NULL;
+       if(p = V(IOSFMT))
+       {
+               if(p->tag==TPRIM && p->primblock.argsp==NULL)
+               {
+                       np = p->primblock.namep;
+                       if(np->vclass == CLNAMELIST)
+                       {
+                               ioformatted = NAMEDIRECTED;
+                               fmtp = (Addrp) fixtype(p);
+                               V(IOSFMT) = (expptr)fmtp;
+                               if (skiplab)
+                                       jumplab = 0;
+                               goto endfmt;
+                       }
+                       vardcl(np);
+                       if(np->vdim)
+                       {
+                               if( ! ONEOF(np->vstg, MSKSTATIC) )
+                                       statstruct = NO;
+                               fmtp = mkscalar(np);
+                               goto endfmt;
+                       }
+                       if( ISINT(np->vtype) )  /* ASSIGNed label */
+                       {
+                               statstruct = NO;
+                               varfmt = YES;
+                               fmtp = asg_addr(p);
+                               goto endfmt;
+                       }
+               }
+               p = V(IOSFMT) = fixtype(p);
+               if(p->headblock.vtype == TYCHAR
+                       /* Since we allow write(6,n)            */
+                       /* we may as well allow write(6,n(2))   */
+               || p->tag == TADDR && ISINT(p->addrblock.vtype))
+               {
+                       if( ! isstatic(p) )
+                               statstruct = NO;
+                       fmtp = (Addrp) cpexpr(p);
+               }
+               else if( ISICON(p) )
+               {
+                       struct Labelblock *lp;
+                       lp = mklabel(p->constblock.Const.ci);
+                       if (fmtstmt(lp) > 0)
+                       {
+                               fmtp = (Addrp)mkaddcon(lp->stateno);
+                               /* lp->stateno for names fmt_nnn */
+                               lp->fmtlabused = 1;
+                               varfmt = NO;
+                       }
+                       else
+                               ioformatted = UNFORMATTED;
+               }
+               else    {
+                       err("bad format descriptor");
+                       ioformatted = UNFORMATTED;
+                       ok = NO;
+               }
+       }
+       else
+               fmtp = NULL;
+
+endfmt:
+       if(intfile) {
+               if (ioformatted==UNFORMATTED) {
+                       err("unformatted internal I/O not allowed");
+                       ok = NO;
+                       }
+               if (recp) {
+                       err("direct internal I/O not allowed");
+                       ok = NO;
+                       }
+               }
+       if(!sequential && ioformatted==LISTDIRECTED)
+       {
+               err("direct list-directed I/O not allowed");
+               ok = NO;
+       }
+       if(!sequential && ioformatted==NAMEDIRECTED)
+       {
+               err("direct namelist I/O not allowed");
+               ok = NO;
+       }
+
+       if( ! ok ) {
+               statstruct = NO;
+               return;
+               }
+
+       /*
+   Now put out the I/O structure, statically if all the clauses
+   are constants, dynamically otherwise
+*/
+
+       if (intfile) {
+               ios = io_stuff + iostmt;
+               iostmt1 = IOREAD;
+               }
+       else {
+               ios = io_stuff;
+               iostmt1 = 0;
+               }
+       io_fields = ios->fields;
+       if(statstruct)
+       {
+               ioblkp = ALLOC(Addrblock);
+               ioblkp->tag = TADDR;
+               ioblkp->vtype = ios->type;
+               ioblkp->vclass = CLVAR;
+               ioblkp->vstg = STGINIT;
+               ioblkp->memno = ++lastvarno;
+               ioblkp->memoffset = ICON(0);
+               ioblkp -> uname_tag = UNAM_IDENT;
+               new_iob_data(ios,
+                       temp_name("io_", lastvarno, ioblkp->user.ident));                       }
+       else if(!(ioblkp = io_structs[iostmt1]))
+               io_structs[iostmt1] = ioblkp =
+                       autovar(1, ios->type, ENULL, "");
+
+       ioset(TYIOINT, XERR, ICON(errbit));
+       if(iostmt == IOREAD)
+               ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) );
+
+       if(intfile)
+       {
+               ioset(TYIOINT, XIRNUM, nump);
+               ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) );
+               ioseta(XIUNIT, unitp);
+       }
+       else
+               ioset(TYIOINT, XUNIT, (expptr) unitp);
+
+       if(recp)
+               ioset(TYIOINT, /* intfile ? XIREC : */ XREC, (expptr) recp);
+
+       if(varfmt)
+               ioseta( intfile ? XIFMT : XFMT , fmtp);
+       else
+               ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp);
+
+       ioroutine[0] = 's';
+       ioroutine[1] = '_';
+       ioroutine[2] = iostmt==IOREAD ? 'r' : 'w';
+       ioroutine[3] = "ds"[sequential];
+       ioroutine[4] = "ufln"[ioformatted];
+       ioroutine[5] = "ei"[intfile];
+       ioroutine[6] = '\0';
+
+       putiocall( call1(TYINT, ioroutine, cpexpr((expptr)ioblkp) ));
+
+       if(statstruct)
+       {
+               frexpr((expptr)ioblkp);
+               statstruct = NO;
+               ioblkp = 0;     /* unnecessary */
+       }
+}
+
+
+
+ LOCAL void
+dofopen()
+{
+       register expptr p;
+
+       if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
+               ioset(TYIOINT, XUNIT, cpexpr(p) );
+       else
+               err("bad unit in open");
+       if( (p = V(IOSFILE)) )
+               if(p->headblock.vtype == TYCHAR)
+                       ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) );
+               else
+                       err("bad file in open");
+
+       iosetc(XFNAME, p);
+
+       if(p = V(IOSRECL))
+               if( ISINT(p->headblock.vtype) )
+                       ioset(TYIOINT, XRECLEN, cpexpr(p) );
+               else
+                       err("bad recl");
+       else
+               ioset(TYIOINT, XRECLEN, ICON(0) );
+
+       iosetc(XSTATUS, V(IOSSTATUS));
+       iosetc(XACCESS, V(IOSACCESS));
+       iosetc(XFORMATTED, V(IOSFORM));
+       iosetc(XBLANK, V(IOSBLANK));
+
+       putiocall( call1(TYINT, "f_open", cpexpr((expptr)ioblkp) ));
+}
+
+
+ LOCAL void
+dofclose()
+{
+       register expptr p;
+
+       if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
+       {
+               ioset(TYIOINT, XUNIT, cpexpr(p) );
+               iosetc(XCLSTATUS, V(IOSSTATUS));
+               putiocall( call1(TYINT, "f_clos", cpexpr((expptr)ioblkp)) );
+       }
+       else
+               err("bad unit in close statement");
+}
+
+
+ LOCAL void
+dofinquire()
+{
+       register expptr p;
+       if(p = V(IOSUNIT))
+       {
+               if( V(IOSFILE) )
+                       err("inquire by unit or by file, not both");
+               ioset(TYIOINT, XUNIT, cpexpr(p) );
+       }
+       else if( ! V(IOSFILE) )
+               err("must inquire by unit or by file");
+       iosetlc(IOSFILE, XFILE, XFILELEN);
+       iosetip(IOSEXISTS, XEXISTS);
+       iosetip(IOSOPENED, XOPEN);
+       iosetip(IOSNUMBER, XNUMBER);
+       iosetip(IOSNAMED, XNAMED);
+       iosetlc(IOSNAME, XNAME, XNAMELEN);
+       iosetlc(IOSACCESS, XQACCESS, XQACCLEN);
+       iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN);
+       iosetlc(IOSDIRECT, XDIRECT, XDIRLEN);
+       iosetlc(IOSFORM, XFORM, XFORMLEN);
+       iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN);
+       iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN);
+       iosetip(IOSRECL, XQRECL);
+       iosetip(IOSNEXTREC, XNEXTREC);
+       iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN);
+
+       putiocall( call1(TYINT,  "f_inqu", cpexpr((expptr)ioblkp) ));
+}
+
+
+
+ LOCAL void
+dofmove(subname)
+ char *subname;
+{
+       register expptr p;
+
+       if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
+       {
+               ioset(TYIOINT, XUNIT, cpexpr(p) );
+               putiocall( call1(TYINT, subname, cpexpr((expptr)ioblkp) ));
+       }
+       else
+               err("bad unit in I/O motion statement");
+}
+
+static int ioset_assign = OPASSIGN;
+
+ LOCAL void
+ioset(type, offset, p)
+ int type, offset;
+ register expptr p;
+{
+       offset /= SZLONG;
+       if(statstruct && ISCONST(p)) {
+               register char *s;
+               switch(type) {
+                       case TYADDR:    /* stmt label */
+                               s = "fmt_";
+                               break;
+                       case TYIOINT:
+                               s = "";
+                               break;
+                       default:
+                               badtype("ioset", type);
+                       }
+               iob_list->fields[offset] =
+                       string_num(s, p->constblock.Const.ci);
+               frexpr(p);
+               }
+       else {
+               register Addrp q;
+
+               q = ALLOC(Addrblock);
+               q->tag = TADDR;
+               q->vtype = type;
+               q->vstg = STGAUTO;
+               q->ntempelt = 1;
+               q->isarray = 0;
+               q->memoffset = ICON(0);
+               q->uname_tag = UNAM_IDENT;
+               sprintf(q->user.ident, "%s.%s",
+                       statstruct ? iob_list->name : ioblkp->user.ident,
+                       io_fields[offset + 1]);
+               if (type == TYADDR && p->tag == TCONST
+                                  && p->constblock.vtype == TYADDR) {
+                       /* kludge */
+                       register Addrp p1;
+                       p1 = ALLOC(Addrblock);
+                       p1->tag = TADDR;
+                       p1->vtype = type;
+                       p1->vstg = STGAUTO;     /* wrong, but who cares? */
+                       p1->ntempelt = 1;
+                       p1->isarray = 0;
+                       p1->memoffset = ICON(0);
+                       p1->uname_tag = UNAM_IDENT;
+                       sprintf(p1->user.ident, "fmt_%ld",
+                               p->constblock.Const.ci);
+                       frexpr(p);
+                       p = (expptr)p1;
+                       }
+               if (type == TYADDR && p->headblock.vtype == TYCHAR)
+                       q->vtype = TYCHAR;
+               putexpr(mkexpr(ioset_assign, (expptr)q, p));
+               }
+}
+
+
+
+
+ LOCAL void
+iosetc(offset, p)
+ int offset;
+ register expptr p;
+{
+       extern Addrp putchop();
+
+       if(p == NULL)
+               ioset(TYADDR, offset, ICON(0) );
+       else if(p->headblock.vtype == TYCHAR) {
+               p = putx(fixtype((expptr)putchop(cpexpr(p))));
+               ioset(TYADDR, offset, addrof(p));
+               }
+       else
+               err("non-character control clause");
+}
+
+
+
+ LOCAL void
+ioseta(offset, p)
+ int offset;
+ register Addrp p;
+{
+       char *s, *s1;
+       static char who[] = "ioseta";
+       expptr e, mo;
+       Namep np;
+       ftnint ci;
+       int k;
+       char buf[24], buf1[24];
+       Extsym *comm;
+       extern int usedefsforcommon;
+
+       if(statstruct)
+       {
+               if (!p)
+                       return;
+               if (p->tag != TADDR)
+                       badtag(who, p->tag);
+               offset /= SZLONG;
+               switch(p->uname_tag) {
+                   case UNAM_NAME:
+                       mo = p->memoffset;
+                       if (mo->tag != TCONST)
+                               badtag("ioseta/memoffset", mo->tag);
+                       np = p->user.name;
+                       np->visused = 1;
+                       ci = mo->constblock.Const.ci - np->voffset;
+                       if (np->vstg == STGCOMMON
+                       && !np->vcommequiv
+                       && !usedefsforcommon) {
+                               comm = &extsymtab[np->vardesc.varno];
+                               sprintf(buf, "%d.", comm->curno);
+                               k = strlen(buf) + strlen(comm->cextname)
+                                       + strlen(np->cvarname);
+                               if (ci) {
+                                       sprintf(buf1, "+%ld", ci);
+                                       k += strlen(buf1);
+                                       }
+                               else
+                                       buf1[0] = 0;
+                               s = mem(k + 1, 0);
+                               sprintf(s, "%s%s%s%s", comm->cextname, buf,
+                                       np->cvarname, buf1);
+                               }
+                       else if (ci) {
+                               sprintf(buf,"%ld", ci);
+                               s1 = p->user.name->cvarname;
+                               k = strlen(buf) + strlen(s1);
+                               sprintf(s = mem(k+2,0), "%s+%s", s1, buf);
+                               }
+                       else
+                               s = cpstring(np->cvarname);
+                       break;
+                   case UNAM_CONST:
+                       s = tostring(p->user.Const.ccp1.ccp0,
+                               (int)p->vleng->constblock.Const.ci);
+                       break;
+                   default:
+                       badthing("uname_tag", who, p->uname_tag);
+                   }
+               /* kludge for Hollerith */
+               if (p->vtype != TYCHAR) {
+                       s1 = mem(strlen(s)+10,0);
+                       sprintf(s1, "(char *)%s%s", p->isarray ? "" : "&", s);
+                       s = s1;
+                       }
+               iob_list->fields[offset] = s;
+       }
+       else {
+               if (!p)
+                       e = ICON(0);
+               else if (p->vtype != TYCHAR) {
+                       NOEXT("non-character variable as format or internal unit");
+                       e = mkexpr(OPCHARCAST, (expptr)p, ENULL);
+                       }
+               else
+                       e = addrof((expptr)p);
+               ioset(TYADDR, offset, e);
+               }
+}
+
+
+
+
+ LOCAL void
+iosetip(i, offset)
+ int i, offset;
+{
+       register expptr p;
+
+       if(p = V(i))
+               if(p->tag==TADDR &&
+                   ONEOF(p->addrblock.vtype, inqmask) ) {
+                       ioset_assign = OPASSIGNI;
+                       ioset(TYADDR, offset, addrof(cpexpr(p)) );
+                       ioset_assign = OPASSIGN;
+                       }
+               else
+                       errstr("impossible inquire parameter %s", ioc[i].iocname);
+       else
+               ioset(TYADDR, offset, ICON(0) );
+}
+
+
+
+ LOCAL void
+iosetlc(i, offp, offl)
+ int i, offp, offl;
+{
+       register expptr p;
+       if( (p = V(i)) && p->headblock.vtype==TYCHAR)
+               ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) );
+       iosetc(offp, p);
+}

diff --git a/usr.bin/f2c/iob.h b/usr.bin/f2c/iob.h
new file mode 100644 (file)
index 0000000..9f2269b
--- /dev/null
+++ b/usr.bin/f2c/iob.h
@@ -0,0 +1,24 @@
+struct iob_data {
+       struct iob_data *next;
+       char *type;
+       char *name;
+       char *fields[1];
+       };
+struct io_setup {
+       char **fields;
+       int nelt, type;
+       };
+
+struct defines {
+       struct defines *next;
+       char defname[1];
+       };
+
+typedef struct iob_data iob_data;
+typedef struct io_setup io_setup;
+typedef struct defines defines;
+
+extern iob_data *iob_list;
+extern struct Addrblock *io_structs[9];
+extern void def_start(), new_iob_data(), other_undefs();
+extern char *tostring();

diff --git a/usr.bin/f2c/lex.c b/usr.bin/f2c/lex.c
new file mode 100644 (file)
index 0000000..a9900be
--- /dev/null
+++ b/usr.bin/f2c/lex.c
@@ -0,0 +1,1577 @@
+/****************************************************************
+Copyright 1990, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "tokdefs.h"
+#include "p1defs.h"
+
+#ifdef NO_EOF_CHAR_CHECK
+#undef EOF_CHAR
+#else
+#ifndef EOF_CHAR
+#define EOF_CHAR 26    /* ASCII control-Z */
+#endif
+#endif
+
+#define BLANK  ' '
+#define MYQUOTE (2)
+#define SEOF 0
+
+/* card types */
+
+#define STEOF 1
+#define STINITIAL 2
+#define STCONTINUE 3
+
+/* lex states */
+
+#define NEWSTMT        1
+#define FIRSTTOKEN     2
+#define OTHERTOKEN     3
+#define RETEOS 4
+
+
+LOCAL int stkey;       /* Type of the current statement (DO, END, IF, etc) */
+extern char token[];   /* holds the actual token text */
+static int needwkey;
+ftnint yystno;
+flag intonly;
+extern int new_dcl;
+LOCAL long int stno;
+LOCAL long int nxtstno;        /* Statement label */
+LOCAL int parlev;      /* Parentheses level */
+LOCAL int parseen;
+LOCAL int expcom;
+LOCAL int expeql;
+LOCAL char *nextch;
+LOCAL char *lastch;
+LOCAL char *nextcd     = NULL;
+LOCAL char *endcd;
+LOCAL long prevlin;
+LOCAL long thislin;
+LOCAL int code;                /* Card type; INITIAL, CONTINUE or EOF */
+LOCAL int lexstate     = NEWSTMT;
+LOCAL char *sbuf;      /* Main buffer for Fortran source input. */
+LOCAL char *send;      /* Was = sbuf+20*66 with sbuf[1390]. */
+LOCAL int maxcont;
+LOCAL int nincl        = 0;    /* Current number of include files */
+LOCAL long firstline;
+LOCAL char *laststb, *stb0;
+extern int addftnsrc;
+static char **linestart;
+LOCAL int ncont;
+LOCAL char comstart[Table_size];
+#define USC (unsigned char *)
+
+static char anum_buf[Table_size];
+#define isalnum_(x) anum_buf[x]
+#define isalpha_(x) (anum_buf[x] == 1)
+
+#define COMMENT_BUF_STORE 4088
+
+typedef struct comment_buf {
+       struct comment_buf *next;
+       char *last;
+       char buf[COMMENT_BUF_STORE];
+       } comment_buf;
+static comment_buf *cbfirst, *cbcur;
+static char *cbinit, *cbnext, *cblast;
+static void flush_comments();
+extern flag use_bs;
+
+
+/* Comment buffering data
+
+       Comments are kept in a list until the statement before them has
+   been parsed.  This list is implemented with the above comment_buf
+   structure and the pointers cbnext and cblast.
+
+       The comments are stored with terminating NULL, and no other
+   intervening space.  The last few bytes of each block are likely to
+   remain unused.
+*/
+
+/* struct Inclfile   holds the state information for each include file */
+struct Inclfile
+{
+       struct Inclfile *inclnext;
+       FILEP inclfp;
+       char *inclname;
+       int incllno;
+       char *incllinp;
+       int incllen;
+       int inclcode;
+       ftnint inclstno;
+};
+
+LOCAL struct Inclfile *inclp   =  NULL;
+struct Keylist {
+       char *keyname;
+       int keyval;
+       char notinf66;
+};
+struct Punctlist {
+       char punchar;
+       int punval;
+};
+struct Fmtlist {
+       char fmtchar;
+       int fmtval;
+};
+struct Dotlist {
+       char *dotname;
+       int dotval;
+       };
+LOCAL struct Keylist *keystart[26], *keyend[26];
+
+/* KEYWORD AND SPECIAL CHARACTER TABLES
+*/
+
+static struct Punctlist puncts[ ] =
+{
+       '(', SLPAR,
+       ')', SRPAR,
+       '=', SEQUALS,
+       ',', SCOMMA,
+       '+', SPLUS,
+       '-', SMINUS,
+       '*', SSTAR,
+       '/', SSLASH,
+       '$', SCURRENCY,
+       ':', SCOLON,
+       '<', SLT,
+       '>', SGT,
+       0, 0 };
+
+LOCAL struct Dotlist  dots[ ] =
+{
+       "and.", SAND,
+           "or.", SOR,
+           "not.", SNOT,
+           "true.", STRUE,
+           "false.", SFALSE,
+           "eq.", SEQ,
+           "ne.", SNE,
+           "lt.", SLT,
+           "le.", SLE,
+           "gt.", SGT,
+           "ge.", SGE,
+           "neqv.", SNEQV,
+           "eqv.", SEQV,
+           0, 0 };
+
+LOCAL struct Keylist  keys[ ] =
+{
+       { "assign",  SASSIGN  },
+       { "automatic",  SAUTOMATIC, YES  },
+       { "backspace",  SBACKSPACE  },
+       { "blockdata",  SBLOCK  },
+       { "call",  SCALL  },
+       { "character",  SCHARACTER, YES  },
+       { "close",  SCLOSE, YES  },
+       { "common",  SCOMMON  },
+       { "complex",  SCOMPLEX  },
+       { "continue",  SCONTINUE  },
+       { "data",  SDATA  },
+       { "dimension",  SDIMENSION  },
+       { "doubleprecision",  SDOUBLE  },
+       { "doublecomplex", SDCOMPLEX, YES  },
+       { "elseif",  SELSEIF, YES  },
+       { "else",  SELSE, YES  },
+       { "endfile",  SENDFILE  },
+       { "endif",  SENDIF, YES  },
+       { "enddo", SENDDO, YES },
+       { "end",  SEND  },
+       { "entry",  SENTRY, YES  },
+       { "equivalence",  SEQUIV  },
+       { "external",  SEXTERNAL  },
+       { "format",  SFORMAT  },
+       { "function",  SFUNCTION  },
+       { "goto",  SGOTO  },
+       { "implicit",  SIMPLICIT, YES  },
+       { "include",  SINCLUDE, YES  },
+       { "inquire",  SINQUIRE, YES  },
+       { "intrinsic",  SINTRINSIC, YES  },
+       { "integer",  SINTEGER  },
+       { "logical",  SLOGICAL  },
+       { "namelist", SNAMELIST, YES },
+       { "none", SUNDEFINED, YES },
+       { "open",  SOPEN, YES  },
+       { "parameter",  SPARAM, YES  },
+       { "pause",  SPAUSE  },
+       { "print",  SPRINT  },
+       { "program",  SPROGRAM, YES  },
+       { "punch",  SPUNCH, YES  },
+       { "read",  SREAD  },
+       { "real",  SREAL  },
+       { "return",  SRETURN  },
+       { "rewind",  SREWIND  },
+       { "save",  SSAVE, YES  },
+       { "static",  SSTATIC, YES  },
+       { "stop",  SSTOP  },
+       { "subroutine",  SSUBROUTINE  },
+       { "then",  STHEN, YES  },
+       { "undefined", SUNDEFINED, YES  },
+       { "while", SWHILE, YES  },
+       { "write",  SWRITE  },
+       { 0, 0 }
+};
+
+LOCAL void analyz(), crunch(), store_comment();
+LOCAL int getcd(), getcds(), getkwd(), gettok();
+LOCAL char *stbuf[3];
+
+inilex(name)
+char *name;
+{
+       stbuf[0] = Alloc(3*P1_STMTBUFSIZE);
+       stbuf[1] = stbuf[0] + P1_STMTBUFSIZE;
+       stbuf[2] = stbuf[1] + P1_STMTBUFSIZE;
+       nincl = 0;
+       inclp = NULL;
+       doinclude(name);
+       lexstate = NEWSTMT;
+       return(NO);
+}
+
+
+
+/* throw away the rest of the current line */
+flline()
+{
+       lexstate = RETEOS;
+}
+
+
+
+char *lexline(n)
+int *n;
+{
+       *n = (lastch - nextch) + 1;
+       return(nextch);
+}
+
+
+
+
+
+doinclude(name)
+char *name;
+{
+       FILEP fp;
+       struct Inclfile *t;
+       char *lastslash, *s, *s0, *temp;
+       int k;
+
+       if(inclp)
+       {
+               inclp->incllno = thislin;
+               inclp->inclcode = code;
+               inclp->inclstno = nxtstno;
+               if(nextcd)
+                       inclp->incllinp = copyn(inclp->incllen = endcd-nextcd , nextcd);
+               else
+                       inclp->incllinp = 0;
+       }
+       nextcd = NULL;
+
+       if(++nincl >= MAXINCLUDES)
+               Fatal("includes nested too deep");
+       if(name[0] == '\0')
+               fp = stdin;
+       else if(name[0] == '/' || inclp == NULL
+#ifdef MSDOS
+               || name[0] == '\\'
+               || name[1] == ':'
+#endif
+               )
+               fp = fopen(name, textread);
+       else {
+               lastslash = NULL;
+               s = s0 = inclp->inclname;
+#ifdef MSDOS
+               if (s[1] == ':')
+                       lastslash = s + 1;
+#endif
+               for(; *s ; ++s)
+                       if(*s == '/'
+#ifdef MSDOS
+                       || *s == '\\'
+#endif
+                       )
+                               lastslash = s;
+               if(lastslash) {
+                       k = lastslash - s0 + 1;
+                       temp = Alloc(k + strlen(name) + 1);
+                       strncpy(temp, s0, k);
+                       strcpy(temp+k, name);
+                       name = temp;
+                       }
+               fp = fopen(name, textread);
+               }
+       if (fp)
+       {
+               t = inclp;
+               inclp = ALLOC(Inclfile);
+               inclp->inclnext = t;
+               prevlin = thislin = 0;
+               infname = inclp->inclname = name;
+               infile = inclp->inclfp = fp;
+       }
+       else
+       {
+               fprintf(diagfile, "Cannot open file %s\n", name);
+               done(1);
+       }
+}
+
+
+
+
+LOCAL popinclude()
+{
+       struct Inclfile *t;
+       register char *p;
+       register int k;
+
+       if(infile != stdin)
+               clf(&infile, infname, 1);       /* Close the input file */
+       free(infname);
+
+       --nincl;
+       t = inclp->inclnext;
+       free( (charptr) inclp);
+       inclp = t;
+       if(inclp == NULL) {
+               infname = 0;
+               return(NO);
+               }
+
+       infile = inclp->inclfp;
+       infname = inclp->inclname;
+       prevlin = thislin = inclp->incllno;
+       code = inclp->inclcode;
+       stno = nxtstno = inclp->inclstno;
+       if(inclp->incllinp)
+       {
+               endcd = nextcd = sbuf;
+               k = inclp->incllen;
+               p = inclp->incllinp;
+               while(--k >= 0)
+                       *endcd++ = *p++;
+               free( (charptr) (inclp->incllinp) );
+       }
+       else
+               nextcd = NULL;
+       return(YES);
+}
+
+
+static char *lastfile = "??", *lastfile0 = "?";
+static char fbuf[P1_FILENAME_MAX];
+
+void p1_line_number (line_number)
+long line_number;
+{
+       if (lastfile != lastfile0) {
+               p1puts(P1_FILENAME, fbuf);
+               lastfile0 = lastfile;
+               }
+       fprintf(pass1_file, "%d: %ld\n", P1_SET_LINE, line_number);
+       }
+
+ static void
+putlineno()
+{
+       static long lastline;
+       extern int gflag;
+       register char *s0, *s1;
+
+       if (gflag) {
+               if (lastline)
+                       p1_line_number(lastline);
+               lastline = firstline;
+               if (lastfile != infname)
+                       if (lastfile = infname) {
+                               strncpy(fbuf, lastfile, sizeof(fbuf));
+                               fbuf[sizeof(fbuf)-1] = 0;
+                               }
+                       else
+                               fbuf[0] = 0;
+               }
+       if (addftnsrc) {
+               if (laststb && *laststb) {
+                       for(s1 = laststb; *s1; s1++) {
+                               for(s0 = s1; *s1 != '\n'; s1++)
+                                       if (*s1 == '*' && s1[1] == '/')
+                                               *s1 = '+';
+                               *s1 = 0;
+                               p1puts(P1_FORTRAN, s0);
+                               }
+                       *laststb = 0;   /* prevent trouble after EOF */
+                       }
+               laststb = stb0;
+               }
+       }
+
+
+yylex()
+{
+       static int  tokno;
+       int retval;
+
+       switch(lexstate)
+       {
+       case NEWSTMT :  /* need a new statement */
+               retval = getcds();
+               putlineno();
+               if(retval == STEOF) {
+                       retval = SEOF;
+                       break;
+               } /* if getcds() == STEOF */
+               crunch();
+               tokno = 0;
+               lexstate = FIRSTTOKEN;
+               yystno = stno;
+               stno = nxtstno;
+               toklen = 0;
+               retval = SLABEL;
+               break;
+
+first:
+       case FIRSTTOKEN :       /* first step on a statement */
+               analyz();
+               lexstate = OTHERTOKEN;
+               tokno = 1;
+               retval = stkey;
+               break;
+
+       case OTHERTOKEN :       /* return next token */
+               if(nextch > lastch)
+                       goto reteos;
+               ++tokno;
+               if( (stkey==SLOGIF || stkey==SELSEIF) && parlev==0 && tokno>3)
+                       goto first;
+
+               if(stkey==SASSIGN && tokno==3 && nextch<lastch &&
+                   nextch[0]=='t' && nextch[1]=='o')
+               {
+                       nextch+=2;
+                       retval = STO;
+                       break;
+               }
+               retval = gettok();
+               break;
+
+reteos:
+       case RETEOS:
+               lexstate = NEWSTMT;
+               retval = SEOS;
+               break;
+       default:
+               fatali("impossible lexstate %d", lexstate);
+               break;
+       }
+
+       if (retval == SEOF)
+           flush_comments ();
+
+       return retval;
+}
+
+ LOCAL void
+contmax()
+{
+       lineno = thislin;
+       many("continuation lines", 'C', maxcontin);
+       }
+
+/* Get Cards.
+
+   Returns STEOF or STINITIAL, never STCONTINUE.  Any continuation cards get
+merged into one long card (hence the size of the buffer named   sbuf)   */
+
+ LOCAL int
+getcds()
+{
+       register char *p, *q;
+
+       flush_comments ();
+top:
+       if(nextcd == NULL)
+       {
+               code = getcd( nextcd = sbuf, 1 );
+               stno = nxtstno;
+               prevlin = thislin;
+       }
+       if(code == STEOF)
+               if( popinclude() )
+                       goto top;
+               else
+                       return(STEOF);
+
+       if(code == STCONTINUE)
+       {
+               lineno = thislin;
+               nextcd = NULL;
+               goto top;
+       }
+
+/* Get rid of unused space at the head of the buffer */
+
+       if(nextcd > sbuf)
+       {
+               q = nextcd;
+               p = sbuf;
+               while(q < endcd)
+                       *p++ = *q++;
+               endcd = p;
+       }
+
+/* Be aware that the input (i.e. the string at the address   nextcd)   is NOT
+   NULL-terminated */
+
+/* This loop merges all continuations into one long statement, AND puts the next
+   card to be read at the end of the buffer (i.e. it stores the look-ahead card
+   when there's room) */
+
+       ncont = 0;
+       for(;;) {
+               nextcd = endcd;
+               if (ncont >= maxcont || nextcd+66 > send)
+                       contmax();
+               linestart[ncont++] = nextcd;
+               if ((code = getcd(nextcd,0)) != STCONTINUE)
+                       break;
+               if (ncont == 20 && noextflag) {
+                       lineno = thislin;
+                       errext("more than 19 continuation lines");
+                       }
+               }
+       nextch = sbuf;
+       lastch = nextcd - 1;
+
+       lineno = prevlin;
+       prevlin = thislin;
+       return(STINITIAL);
+}
+
+ static void
+bang(a,b,c,d,e)                /* save ! comments */
+ char *a, *b, *c;
+ register char *d, *e;
+{
+       char buf[COMMENT_BUFFER_SIZE + 1];
+       register char *p, *pe;
+
+       p = buf;
+       pe = buf + COMMENT_BUFFER_SIZE;
+       *pe = 0;
+       while(a < b)
+               if (!(*p++ = *a++))
+                       p[-1] = 0;
+       if (b < c)
+               *p++ = '\t';
+       while(d < e) {
+               if (!(*p++ = *d++))
+                       p[-1] = ' ';
+               if (p == pe) {
+                       store_comment(buf);
+                       p = buf;
+                       }
+               }
+       if (p > buf) {
+               while(--p >= buf && *p == ' ');
+               p[1] = 0;
+               store_comment(buf);
+               }
+       }
+
+
+/* getcd - Get next input card
+
+       This function reads the next input card from global file pointer   infile.
+It assumes that   b   points to currently empty storage somewhere in  sbuf  */
+
+ LOCAL int
+getcd(b, nocont)
+ register char *b;
+{
+       register int c;
+       register char *p, *bend;
+       int speclin;            /* Special line - true when the line is allowed
+                                  to have more than 66 characters (e.g. the
+                                  "&" shorthand for continuation, use of a "\t"
+                                  to skip part of the label columns) */
+       static char a[6];       /* Statement label buffer */
+       static char *aend       = a+6;
+       static char *stb, *stbend;
+       static int nst;
+       char *atend, *endcd0;
+       extern int warn72;
+       char buf72[24];
+       int amp, i;
+       char storage[COMMENT_BUFFER_SIZE + 1];
+       char *pointer;
+       long L;
+
+top:
+       endcd = b;
+       bend = b+66;
+       amp = speclin = NO;
+       atend = aend;
+
+/* Handle the continuation shorthand of "&" in the first column, which stands
+   for "     x" */
+
+       if( (c = getc(infile)) == '&')
+       {
+               a[0] = c;
+               a[1] = 0;
+               a[5] = 'x';
+               amp = speclin = YES;
+               bend = send;
+               p = aend;
+       }
+
+/* Handle the Comment cards (a 'C', 'c', '*', or '!' in the first column). */
+
+       else if(comstart[c & 0xfff])
+       {
+               if (feof (infile)
+#ifdef EOF_CHAR
+                        || c == EOF_CHAR
+#endif
+                                       )
+                   return STEOF;
+
+               if (c == '#') {
+                       *endcd++ = c;
+                       while((c = getc(infile)) != '\n')
+                               if (c == EOF)
+                                       return STEOF;
+                               else if (endcd < bend)
+                                       *endcd++ = c;
+                       ++thislin;
+                       *endcd = 0;
+                       if (b[1] == ' ')
+                               p = b + 2;
+                       else if (!strncmp(b,"#line ",6))
+                               p = b + 6;
+                       else {
+ bad_cpp:
+                               errstr("Bad # line: \"%s\"", b);
+                               goto top;
+                               }
+                       if (*p < '1' || *p > '9')
+                               goto bad_cpp;
+                       L = *p - '1';   /* bias down 1 */
+                       while((c = *++p) >= '0' && c <= '9')
+                               L = 10*L + c - '0';
+                       if (c != ' ' || *++p != '"')
+                               goto bad_cpp;
+                       bend = p;
+                       while(*++p != '"')
+                               if (!*p)
+                                       goto bad_cpp;
+                       *p = 0;
+                       i = p - bend++;
+                       thislin = L;
+                       if (!infname || strcmp(infname, bend)) {
+                               if (infname)
+                                       free(infname);
+                               infname = Alloc(i);
+                               strcpy(infname, bend);
+                               if (inclp)
+                                       inclp->inclname = infname;
+                               }
+                       goto top;
+                       }
+
+               storage[COMMENT_BUFFER_SIZE] = c = '\0';
+               pointer = storage;
+               while( !feof (infile) && (*pointer++ = c = getc(infile)) != '\n') {
+
+/* Handle obscure end of file conditions on many machines */
+
+                       if (feof (infile) && (c == '\377' || c == EOF)) {
+                           pointer--;
+                           break;
+                       } /* if (feof (infile)) */
+
+                       if (c == '\0')
+                               *(pointer - 1) = ' ';
+
+                       if (pointer == &storage[COMMENT_BUFFER_SIZE]) {
+                               store_comment (storage);
+                               pointer = storage;
+                       } /* if (pointer == BUFFER_SIZE) */
+               } /* while */
+
+               if (pointer > storage) {
+                   if (c == '\n')
+
+/* Get rid of the newline */
+
+                       pointer[-1] = 0;
+                   else
+                       *pointer = 0;
+
+                   store_comment (storage);
+               } /* if */
+
+               if (feof (infile))
+                   if (c != '\n')      /* To allow the line index to
+                                          increment correctly */
+                       return STEOF;
+
+               ++thislin;
+               goto top;
+       }
+
+       else if(c != EOF)
+       {
+
+/* Load buffer   a   with the statement label */
+
+               /* a tab in columns 1-6 skips to column 7 */
+               ungetc(c, infile);
+               for(p=a; p<aend && (c=getc(infile)) != '\n' && c!=EOF; )
+                       if(c == '\t')
+
+/* The tab character translates into blank characters in the statement label */
+
+                       {
+                               atend = p;
+                               while(p < aend)
+                                       *p++ = BLANK;
+                               speclin = YES;
+                               bend = send;
+                       }
+                       else
+                               *p++ = c;
+       }
+
+/* By now we've read either a continuation character or the statement label
+   field */
+
+       if(c == EOF)
+               return(STEOF);
+
+/* The next 'if' block handles lines that have fewer than 7 characters */
+
+       if(c == '\n')
+       {
+               while(p < aend)
+                       *p++ = BLANK;
+
+/* Blank out the buffer on lines which are not longer than 66 characters */
+
+               endcd0 = endcd;
+               if( ! speclin )
+                       while(endcd < bend)
+                               *endcd++ = BLANK;
+       }
+       else    {       /* read body of line */
+               if (warn72 & 2) {
+                       speclin = YES;
+                       bend = send;
+                       }
+               while( endcd<bend && (c=getc(infile)) != '\n' && c!=EOF )
+                       *endcd++ = c;
+               if(c == EOF)
+                       return(STEOF);
+
+/* Drop any extra characters on the input card; this usually means those after
+   column 72 */
+
+               if(c != '\n')
+               {
+                       i = 0;
+                       while( (c=getc(infile)) != '\n' && c != EOF)
+                               if (i < 23)
+                                       buf72[i++] = c;
+                       if (warn72 && i && !speclin) {
+                               buf72[i] = 0;
+                               if (i >= 23)
+                                       strcpy(buf72+20, "...");
+                               lineno = thislin + 1;
+                               errstr("text after column 72: %s", buf72);
+                               }
+                       if(c == EOF)
+                               return(STEOF);
+               }
+
+               endcd0 = endcd;
+               if( ! speclin )
+                       while(endcd < bend)
+                               *endcd++ = BLANK;
+       }
+
+/* The flow of control usually gets to this line (unless an earlier RETURN has
+   been taken) */
+
+       ++thislin;
+
+       /* Fortran 77 specifies that a 0 in column 6 */
+       /* does not signify continuation */
+
+       if( !isspace(a[5]) && a[5]!='0') {
+               if (!amp)
+                       for(p = a; p < aend;)
+                               if (*p++ == '!' && p != aend)
+                                       goto initcheck;
+               if (addftnsrc && stb) {
+                       if (stbend > stb + 7) { /* otherwise forget col 1-6 */
+                               /* kludge around funny p1gets behavior */
+                               *stb++ = '$';
+                               if (amp)
+                                       *stb++ = '&';
+                               else
+                                       for(p = a; p < atend;)
+                                               *stb++ = *p++;
+                               }
+                       if (endcd0 - b > stbend - stb) {
+                               if (stb > stbend)
+                                       stb = stbend;
+                               endcd0 = b + (stbend - stb);
+                               }
+                       for(p = b; p < endcd0;)
+                               *stb++ = *p++;
+                       *stb++ = '\n';
+                       *stb = 0;
+                       }
+               if (nocont) {
+                       lineno = thislin;
+                       errstr("illegal continuation card (starts \"%.6s\")",a);
+                       }
+               else if (!amp && strncmp(a,"     ",5)) {
+                       lineno = thislin;
+                       errstr("labeled continuation line (starts \"%.6s\")",a);
+                       }
+               return(STCONTINUE);
+               }
+initcheck:
+       for(p=a; p<atend; ++p)
+               if( !isspace(*p) ) {
+                       if (*p++ != '!')
+                               goto initline;
+                       bang(p, atend, aend, b, endcd);
+                       goto top;
+                       }
+       for(p = b ; p<endcd ; ++p)
+               if( !isspace(*p) ) {
+                       if (*p++ != '!')
+                               goto initline;
+                       bang(a, a, a, p, endcd);
+                       goto top;
+                       }
+
+/* Skip over blank cards by reading the next one right away */
+
+       goto top;
+
+initline:
+       if (addftnsrc) {
+               nst = (nst+1)%3;
+               if (!laststb && stb0)
+                       laststb = stb0;
+               stb0 = stb = stbuf[nst];
+               *stb++ = '$';   /* kludge around funny p1gets behavior */
+               stbend = stb + sizeof(stbuf[0])-2;
+               for(p = a; p < atend;)
+                       *stb++ = *p++;
+               if (atend < aend)
+                       *stb++ = '\t';
+               for(p = b; p < endcd0;)
+                       *stb++ = *p++;
+               *stb++ = '\n';
+               *stb = 0;
+               }
+
+/* Set   nxtstno   equal to the integer value of the statement label */
+
+       nxtstno = 0;
+       bend = a + 5;
+       for(p = a ; p < bend ; ++p)
+               if( !isspace(*p) )
+                       if(isdigit(*p))
+                               nxtstno = 10*nxtstno + (*p - '0');
+                       else if (*p == '!') {
+                               if (!addftnsrc)
+                                       bang(p+1,atend,aend,b,endcd);
+                               endcd = b;
+                               break;
+                               }
+                       else    {
+                               lineno = thislin;
+                               errstr(
+                               "nondigit in statement label field \"%.5s\"", a);
+                               nxtstno = 0;
+                               break;
+                       }
+       firstline = thislin;
+       return(STINITIAL);
+}
+
+
+/* crunch -- deletes all space characters, folds the backslash chars and
+   Hollerith strings, quotes the Fortran strings */
+
+ LOCAL void
+crunch()
+{
+       register char *i, *j, *j0, *j1, *prvstr;
+       int k, ten, nh, nh0, quote;
+
+       /* i is the next input character to be looked at
+          j is the next output character */
+
+       new_dcl = needwkey = parlev = parseen = 0;
+       expcom = 0;     /* exposed ','s */
+       expeql = 0;     /* exposed equal signs */
+       j = sbuf;
+       prvstr = sbuf;
+       k = 0;
+       for(i=sbuf ; i<=lastch ; ++i)
+       {
+               if(isspace(*i) )
+                       continue;
+               if (*i == '!') {
+                       while(i >= linestart[k])
+                               if (++k >= maxcont)
+                                       contmax();
+                       j0 = linestart[k];
+                       if (!addftnsrc)
+                               bang(sbuf,sbuf,sbuf,i+1,j0);
+                       i = j0-1;
+                       continue;
+                       }
+
+/* Keep everything in a quoted string */
+
+               if(*i=='\'' ||  *i=='"')
+               {
+                       int len = 0;
+
+                       quote = *i;
+                       *j = MYQUOTE; /* special marker */
+                       for(;;)
+                       {
+                               if(++i > lastch)
+                               {
+                                       err("unbalanced quotes; closing quote supplied");
+                                       if (j >= lastch)
+                                               j = lastch - 1;
+                                       break;
+                               }
+                               if(*i == quote)
+                                       if(i<lastch && i[1]==quote) ++i;
+                                       else break;
+                               else if(*i=='\\' && i<lastch && use_bs) {
+                                       ++i;
+                                       *i = escapes[*(unsigned char *)i];
+                                       }
+                               if (len < MAXTOKENLEN)
+                                   *++j = *i;
+                               else if (len == MAXTOKENLEN)
+                                   erri
+           ("String too long, truncating to %d chars", MAXTOKENLEN);
+                               len++;
+                       } /* for (;;) */
+
+                       j[1] = MYQUOTE;
+                       j += 2;
+                       prvstr = j;
+               }
+               else if( (*i=='h' || *i=='H')  && j>prvstr)     /* test for Hollerith strings */
+               {
+                       j0 = j - 1;
+                       if( ! isdigit(*j0)) goto copychar;
+                       nh = *j0 - '0';
+                       ten = 10;
+                       j1 = prvstr;
+                       if (j1+4 < j)
+                               j1 = j-4;
+                       for(;;) {
+                               if (j0-- <= j1)
+                                       goto copychar;
+                               if( ! isdigit(*j0 ) ) break;
+                               nh += ten * (*j0-'0');
+                               ten*=10;
+                               }
+                       /* a hollerith must be preceded by a punctuation mark.
+   '*' is possible only as repetition factor in a data statement
+   not, in particular, in character*2h
+*/
+
+                       if( !(*j0=='*'&&sbuf[0]=='d') && *j0!='/'
+                       && *j0!='(' && *j0!=',' && *j0!='=' && *j0!='.')
+                               goto copychar;
+                       nh0 = nh;
+                       if(i+nh > lastch || nh > MAXTOKENLEN)
+                       {
+                               erri("%dH too big", nh);
+                               nh = lastch - i;
+                               if (nh > MAXTOKENLEN)
+                                       nh = MAXTOKENLEN;
+                               nh0 = -1;
+                       }
+                       j0[1] = MYQUOTE; /* special marker */
+                       j = j0 + 1;
+                       while(nh-- > 0)
+                       {
+                               if (++i > lastch) {
+ hol_overflow:
+                                       if (nh0 >= 0)
+                                         erri("escapes make %dH too big",
+                                               nh0);
+                                       break;
+                                       }
+                               if(*i == '\\' && use_bs) {
+                                       if (++i > lastch)
+                                               goto hol_overflow;
+                                       *i = escapes[*(unsigned char *)i];
+                                       }
+                               *++j = *i;
+                       }
+                       j[1] = MYQUOTE;
+                       j+=2;
+                       prvstr = j;
+               }
+               else    {
+                       if(*i == '(') parseen = ++parlev;
+                       else if(*i == ')') --parlev;
+                       else if(parlev == 0)
+                               if(*i == '=') expeql = 1;
+                               else if(*i == ',') expcom = 1;
+copychar:              /*not a string or space -- copy, shifting case if necessary */
+                       if(shiftcase && isupper(*i))
+                               *j++ = tolower(*i);
+                       else    *j++ = *i;
+               }
+       }
+       lastch = j - 1;
+       nextch = sbuf;
+}
+
+ LOCAL void
+analyz()
+{
+       register char *i;
+
+       if(parlev != 0)
+       {
+               err("unbalanced parentheses, statement skipped");
+               stkey = SUNKNOWN;
+               lastch = sbuf - 1; /* prevent double error msg */
+               return;
+       }
+       if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(')
+       {
+               /* assignment or if statement -- look at character after balancing paren */
+               parlev = 1;
+               for(i=nextch+3 ; i<=lastch; ++i)
+                       if(*i == (MYQUOTE))
+                       {
+                               while(*++i != MYQUOTE)
+                                       ;
+                       }
+                       else if(*i == '(')
+                               ++parlev;
+                       else if(*i == ')')
+                       {
+                               if(--parlev == 0)
+                                       break;
+                       }
+               if(i >= lastch)
+                       stkey = SLOGIF;
+               else if(i[1] == '=')
+                       stkey = SLET;
+               else if( isdigit(i[1]) )
+                       stkey = SARITHIF;
+               else    stkey = SLOGIF;
+               if(stkey != SLET)
+                       nextch += 2;
+       }
+       else if(expeql) /* may be an assignment */
+       {
+               if(expcom && nextch<lastch &&
+                   nextch[0]=='d' && nextch[1]=='o')
+               {
+                       stkey = SDO;
+                       nextch += 2;
+               }
+               else    stkey = SLET;
+       }
+       else if (parseen && nextch + 7 < lastch
+                       && nextch[2] != 'u' /* screen out "double..." early */
+                       && nextch[0] == 'd' && nextch[1] == 'o'
+                       && ((nextch[2] >= '0' && nextch[2] <= '9')
+                               || nextch[2] == ','
+                               || nextch[2] == 'w'))
+               {
+               stkey = SDO;
+               nextch += 2;
+               needwkey = 1;
+               }
+       /* otherwise search for keyword */
+       else    {
+               stkey = getkwd();
+               if(stkey==SGOTO && lastch>=nextch)
+                       if(nextch[0]=='(')
+                               stkey = SCOMPGOTO;
+                       else if(isalpha_(* USC nextch))
+                               stkey = SASGOTO;
+       }
+       parlev = 0;
+}
+
+
+
+ LOCAL int
+getkwd()
+{
+       register char *i, *j;
+       register struct Keylist *pk, *pend;
+       int k;
+
+       if(! isalpha_(* USC nextch) )
+               return(SUNKNOWN);
+       k = letter(nextch[0]);
+       if(pk = keystart[k])
+               for(pend = keyend[k] ; pk<=pend ; ++pk )
+               {
+                       i = pk->keyname;
+                       j = nextch;
+                       while(*++i==*++j && *i!='\0')
+                               ;
+                       if(*i=='\0' && j<=lastch+1)
+                       {
+                               nextch = j;
+                               if(no66flag && pk->notinf66)
+                                       errstr("Not a Fortran 66 keyword: %s",
+                                           pk->keyname);
+                               return(pk->keyval);
+                       }
+               }
+       return(SUNKNOWN);
+}
+
+initkey()
+{
+       register struct Keylist *p;
+       register int i,j;
+       register char *s;
+
+       for(i = 0 ; i<26 ; ++i)
+               keystart[i] = NULL;
+
+       for(p = keys ; p->keyname ; ++p) {
+               j = letter(p->keyname[0]);
+               if(keystart[j] == NULL)
+                       keystart[j] = p;
+               keyend[j] = p;
+               }
+       i = (maxcontin + 2) * 66;
+       sbuf = (char *)ckalloc(i + 70);
+       send = sbuf + i;
+       maxcont = maxcontin + 1;
+       linestart = (char **)ckalloc(maxcont*sizeof(char*));
+       comstart['c'] = comstart['C'] = comstart['*'] = comstart['!'] =
+       comstart['#'] = 1;
+#ifdef EOF_CHAR
+       comstart[EOF_CHAR] = 1;
+#endif
+       s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_";
+       while(i = *s++)
+               anum_buf[i] = 1;
+       s = "0123456789";
+       while(i = *s++)
+               anum_buf[i] = 2;
+       }
+
+ LOCAL int
+hexcheck(key)
+ int key;
+{
+       register int radix;
+       register char *p;
+       char *kind;
+
+       switch(key) {
+               case 'z':
+               case 'Z':
+               case 'x':
+               case 'X':
+                       radix = 16;
+                       key = SHEXCON;
+                       kind = "hexadecimal";
+                       break;
+               case 'o':
+               case 'O':
+                       radix = 8;
+                       key = SOCTCON;
+                       kind = "octal";
+                       break;
+               case 'b':
+               case 'B':
+                       radix = 2;
+                       key = SBITCON;
+                       kind = "binary";
+                       break;
+               default:
+                       err("bad bit identifier");
+                       return(SNAME);
+               }
+       for(p = token; *p; p++)
+               if (hextoi(*p) >= radix) {
+                       errstr("invalid %s character", kind);
+                       break;
+                       }
+       return key;
+       }
+
+/* gettok -- moves the right amount of text from   nextch   into the   token
+   buffer.   token   initially contains garbage (leftovers from the prev token) */
+
+ LOCAL int
+gettok()
+{
+int havdot, havexp, havdbl;
+       int radix, val;
+       struct Punctlist *pp;
+       struct Dotlist *pd;
+       register int ch;
+
+       char *i, *j, *n1, *p;
+
+       ch = * USC nextch;
+       if(ch == (MYQUOTE))
+       {
+               ++nextch;
+               p = token;
+               while(*nextch != MYQUOTE)
+                       *p++ = *nextch++;
+               toklen = p - token;
+               *p = 0;
+               /* allow octal, binary, hex constants of the form 'abc'x (etc.) */
+               if (++nextch <= lastch && isalpha_(val = * USC nextch)) {
+                       ++nextch;
+                       return hexcheck(val);
+                       }
+               return (SHOLLERITH);
+       }
+
+       if(needkwd)
+       {
+               needkwd = 0;
+               return( getkwd() );
+       }
+
+       for(pp=puncts; pp->punchar; ++pp)
+               if(ch == pp->punchar) {
+                       val = pp->punval;
+                       if (++nextch <= lastch)
+                           switch(ch) {
+                               case '/':
+                                       if (*nextch == '/') {
+                                               nextch++;
+                                               val = SCONCAT;
+                                               }
+                                       else if (new_dcl && parlev == 0)
+                                               val = SSLASHD;
+                                       return val;
+                               case '*':
+                                       if (*nextch == '*') {
+                                               nextch++;
+                                               return SPOWER;
+                                               }
+                                       break;
+                               case '<':
+                                       if (*nextch == '=') {
+                                               nextch++;
+                                               val = SLE;
+                                               }
+                                       if (*nextch == '>') {
+                                               nextch++;
+                                               val = SNE;
+                                               }
+                                       goto extchk;
+                               case '=':
+                                       if (*nextch == '=') {
+                                               nextch++;
+                                               val = SEQ;
+                                               goto extchk;
+                                               }
+                                       break;
+                               case '>':
+                                       if (*nextch == '=') {
+                                               nextch++;
+                                               val = SGE;
+                                               }
+ extchk:
+                                       NOEXT("Fortran 8x comparison operator");
+                                       return val;
+                               }
+                       else if (ch == '/' && new_dcl && parlev == 0)
+                               return SSLASHD;
+                       switch(val) {
+                               case SLPAR:
+                                       ++parlev;
+                                       break;
+                               case SRPAR:
+                                       --parlev;
+                               }
+                       return(val);
+                       }
+       if(ch == '.')
+               if(nextch >= lastch) goto badchar;
+               else if(isdigit(nextch[1])) goto numconst;
+               else    {
+                       for(pd=dots ; (j=pd->dotname) ; ++pd)
+                       {
+                               for(i=nextch+1 ; i<=lastch ; ++i)
+                                       if(*i != *j) break;
+                                       else if(*i != '.') ++j;
+                                       else    {
+                                               nextch = i+1;
+                                               return(pd->dotval);
+                                       }
+                       }
+                       goto badchar;
+               }
+       if( isalpha_(ch) )
+       {
+               p = token;
+               *p++ = *nextch++;
+               while(nextch<=lastch)
+                       if( isalnum_(* USC nextch) )
+                               *p++ = *nextch++;
+                       else break;
+               toklen = p - token;
+               *p = 0;
+               if (needwkey) {
+                       needwkey = 0;
+                       if (toklen == 5
+                               && nextch <= lastch && *nextch == '(' /*)*/
+                               && !strcmp(token,"while"))
+                       return(SWHILE);
+                       }
+               if(inioctl && nextch<=lastch && *nextch=='=')
+               {
+                       ++nextch;
+                       return(SNAMEEQ);
+               }
+               if(toklen>8 && eqn(8,token,"function")
+               && isalpha_(* USC (token+8)) &&
+                   nextch<lastch && nextch[0]=='(' &&
+                   (nextch[1]==')' || isalpha_(* USC (nextch+1))) )
+               {
+                       nextch -= (toklen - 8);
+                       return(SFUNCTION);
+               }
+
+               if(toklen > 50)
+               {
+                       char buff[100];
+                       sprintf(buff, toklen >= 60
+                               ? "name %.56s... too long, truncated to %.*s"
+                               : "name %s too long, truncated to %.*s",
+                           token, 50, token);
+                       err(buff);
+                       toklen = 50;
+                       token[50] = '\0';
+               }
+               if(toklen==1 && *nextch==MYQUOTE) {
+                       val = token[0];
+                       ++nextch;
+                       for(p = token ; *nextch!=MYQUOTE ; )
+                               *p++ = *nextch++;
+                       ++nextch;
+                       toklen = p - token;
+                       *p = 0;
+                       return hexcheck(val);
+               }
+               return(SNAME);
+       }
+
+       if (isdigit(ch)) {
+
+               /* Check for NAG's special hex constant */
+
+               if (nextch[1] == '#' && nextch < lastch
+               ||  nextch[2] == '#' && isdigit(nextch[1]
+                                    && lastch - nextch >= 2)) {
+
+                   radix = atoi (nextch);
+                   if (*++nextch != '#')
+                       nextch++;
+                   if (radix != 2 && radix != 8 && radix != 16) {
+                       erri("invalid base %d for constant, defaulting to hex",
+                               radix);
+                       radix = 16;
+                   } /* if */
+                   if (++nextch > lastch)
+                       goto badchar;
+                   for (p = token; hextoi(*nextch) < radix;) {
+                       *p++ = *nextch++;
+                       if (nextch > lastch)
+                               break;
+                       }
+                   toklen = p - token;
+                   *p = 0;
+                   return (radix == 16) ? SHEXCON : ((radix == 8) ? SOCTCON :
+                           SBITCON);
+                   }
+               }
+       else
+               goto badchar;
+numconst:
+       havdot = NO;
+       havexp = NO;
+       havdbl = NO;
+       for(n1 = nextch ; nextch<=lastch ; ++nextch)
+       {
+               if(*nextch == '.')
+                       if(havdot) break;
+                       else if(nextch+2<=lastch && isalpha_(* USC (nextch+1))
+                           && isalpha_(* USC (nextch+2)))
+                               break;
+                       else    havdot = YES;
+               else if( !intonly && (*nextch=='d' || *nextch=='e') )
+               {
+                       p = nextch;
+                       havexp = YES;
+                       if(*nextch == 'd')
+                               havdbl = YES;
+                       if(nextch<lastch)
+                               if(nextch[1]=='+' || nextch[1]=='-')
+                                       ++nextch;
+                       if( ! isdigit(*++nextch) )
+                       {
+                               nextch = p;
+                               havdbl = havexp = NO;
+                               break;
+                       }
+                       for(++nextch ;
+                           nextch<=lastch && isdigit(* USC nextch);
+                           ++nextch);
+                       break;
+               }
+               else if( ! isdigit(* USC nextch) )
+                       break;
+       }
+       p = token;
+       i = n1;
+       while(i < nextch)
+               *p++ = *i++;
+       toklen = p - token;
+       *p = 0;
+       if(havdbl) return(SDCON);
+       if(havdot || havexp) return(SRCON);
+       return(SICON);
+badchar:
+       sbuf[0] = *nextch++;
+       return(SUNKNOWN);
+}
+
+/* Comment buffering code */
+
+ static void
+store_comment(str)
+ char *str;
+{
+       int len;
+       comment_buf *ncb;
+
+       if (nextcd == sbuf) {
+               flush_comments();
+               p1_comment(str);
+               return;
+               }
+       len = strlen(str) + 1;
+       if (cbnext + len > cblast) {
+               if (!cbcur || !(ncb = cbcur->next)) {
+                       ncb = (comment_buf *) Alloc(sizeof(comment_buf));
+                       if (cbcur) {
+                               cbcur->last = cbnext;
+                               cbcur->next = ncb;
+                               }
+                       else {
+                               cbfirst = ncb;
+                               cbinit = ncb->buf;
+                               }
+                       ncb->next = 0;
+                       }
+               cbcur = ncb;
+               cbnext = ncb->buf;
+               cblast = cbnext + COMMENT_BUF_STORE;
+               }
+       strcpy(cbnext, str);
+       cbnext += len;
+       }
+
+ static void
+flush_comments()
+{
+       register char *s, *s1;
+       register comment_buf *cb;
+       if (cbnext == cbinit)
+               return;
+       cbcur->last = cbnext;
+       for(cb = cbfirst;; cb = cb->next) {
+               for(s = cb->buf; s < cb->last; s = s1) {
+                       /* compute s1 = new s value first, since */
+                       /* p1_comment may insert nulls into s */
+                       s1 = s + strlen(s) + 1;
+                       p1_comment(s);
+                       }
+               if (cb == cbcur)
+                       break;
+               }
+       cbcur = cbfirst;
+       cbnext = cbinit;
+       cblast = cbnext + COMMENT_BUF_STORE;
+       }
+
+ void
+unclassifiable()
+{
+       register char *s, *se;
+
+       s = sbuf;
+       se = lastch;
+       if (se < sbuf)
+               return;
+       lastch = s - 1;
+       if (se - s > 10)
+               se = s + 10;
+       for(; s < se; s++)
+               if (*s == MYQUOTE) {
+                       se = s;
+                       break;
+                       }
+       *se = 0;
+       errstr("unclassifiable statement (starts \"%s\")", sbuf);
+       }

diff --git a/usr.bin/f2c/machdefs.h b/usr.bin/f2c/machdefs.h
new file mode 100644 (file)
index 0000000..3ab8961
--- /dev/null
+++ b/usr.bin/f2c/machdefs.h
@@ -0,0 +1,31 @@
+#define TYLENG TYLONG          /* char string length field */
+
+#define TYINT  TYLONG
+#define SZADDR 4
+#define SZSHORT        2
+#define SZINT  4
+
+#define SZLONG 4
+#define SZLENG SZLONG
+
+#define SZDREAL 8
+
+/* Alignment restrictions */
+
+#define ALIADDR SZADDR
+#define ALISHORT SZSHORT
+#define ALILONG 4
+#define ALIDOUBLE 8
+#define ALIINT ALILONG
+#define ALILENG        ALILONG
+
+#define BLANKCOMMON "_BLNK__"          /* Name for the unnamed
+                                          common block; this is unique
+                                          because of underscores */
+
+#define LABELFMT "%s:\n"
+
+#define MAXREGVAR 4
+#define TYIREG TYLONG
+#define MSKIREG  (M(TYSHORT)|M(TYLONG))        /* allowed types of DO indicies
+                                          which can be put in registers */

diff --git a/usr.bin/f2c/main.c b/usr.bin/f2c/main.c
new file mode 100644 (file)
index 0000000..a4bb2cd
--- /dev/null
+++ b/usr.bin/f2c/main.c
@@ -0,0 +1,611 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+extern char F2C_version[];
+
+#include "defs.h"
+#include "parse.h"
+
+int complex_seen, dcomplex_seen;
+
+LOCAL int Max_ftn_files;
+
+char **ftn_files;
+int current_ftn_file = 0;
+
+flag ftn66flag = NO;
+flag nowarnflag = NO;
+flag noextflag = NO;
+flag  no66flag = NO;           /* Must also set noextflag to this
+                                          same value */
+flag zflag = YES;              /* recognize double complex intrinsics */
+flag debugflag = NO;
+flag onetripflag = NO;
+flag shiftcase = YES;
+flag undeftype = NO;
+flag checksubs = NO;
+flag r8flag = NO;
+flag use_bs = YES;
+flag keepsubs = NO;
+#ifdef TYQUAD
+flag use_tyquad = YES;
+#endif
+int tyreal = TYREAL;
+int tycomplex = TYCOMPLEX;
+extern void r8fix(), read_Pfiles();
+
+int maxregvar = MAXREGVAR;     /* if maxregvar > MAXREGVAR, error */
+int maxequiv = MAXEQUIV;
+int maxext = MAXEXT;
+int maxstno = MAXSTNO;
+int maxctl = MAXCTL;
+int maxhash = MAXHASH;
+int maxliterals = MAXLITERALS;
+int maxcontin = MAXCONTIN;
+int maxlablist = MAXLABLIST;
+int extcomm, ext1comm, useauto;
+int can_include = YES; /* so we can disable includes for netlib */
+
+static char *def_i2 = "";
+
+static int useshortints = NO;  /* YES => tyint = TYSHORT */
+static int uselongints = NO;   /* YES => tyint = TYLONG */
+int addftnsrc = NO;            /* Include ftn source in output */
+int usedefsforcommon = NO;     /* Use #defines for common reference */
+int forcedouble = YES;         /* force real functions to double */
+int Ansi = NO;
+int def_equivs = YES;
+int tyioint = TYLONG;
+int szleng = SZLENG;
+int inqmask = M(TYLONG)|M(TYLOGICAL);
+int wordalign = NO;
+int forcereal = NO;
+int warn72 = NO;
+static int skipC, skipversion;
+char *file_name, *filename0, *parens;
+int Castargs = 1;
+static int Castargs1;
+static int typedefs = 0;
+int chars_per_wd, gflag, protostatus;
+int infertypes = 1;
+char used_rets[TYSUBR+1];
+extern char *tmpdir;
+static int h0align = 0;
+char *halign, *ohalign;
+int krparens = NO;
+int hsize;     /* for padding under -h */
+int htype;     /* for wr_equiv_init under -h */
+
+#define f2c_entry(swit,count,type,store,size) \
+       p_entry ("-", swit, 0, count, type, store, size)
+
+static arg_info table[] = {
+    f2c_entry ("w66", P_NO_ARGS, P_INT, &ftn66flag, YES),
+    f2c_entry ("w", P_NO_ARGS, P_INT, &nowarnflag, YES),
+    f2c_entry ("66", P_NO_ARGS, P_INT, &no66flag, YES),
+    f2c_entry ("d", P_ONE_ARG, P_INT, &debugflag, YES),
+    f2c_entry ("1", P_NO_ARGS, P_INT, &onetripflag, YES),
+    f2c_entry ("onetrip", P_NO_ARGS, P_INT, &onetripflag, YES),
+    f2c_entry ("I2", P_NO_ARGS, P_INT, &useshortints, YES),
+    f2c_entry ("I4", P_NO_ARGS, P_INT, &uselongints, YES),
+    f2c_entry ("U", P_NO_ARGS, P_INT, &shiftcase, NO),
+    f2c_entry ("u", P_NO_ARGS, P_INT, &undeftype, YES),
+    f2c_entry ("O", P_ONE_ARG, P_INT, &maxregvar, 0),
+    f2c_entry ("C", P_NO_ARGS, P_INT, &checksubs, YES),
+    f2c_entry ("Nq", P_ONE_ARG, P_INT, &maxequiv, 0),
+    f2c_entry ("Nx", P_ONE_ARG, P_INT, &maxext, 0),
+    f2c_entry ("Ns", P_ONE_ARG, P_INT, &maxstno, 0),
+    f2c_entry ("Nc", P_ONE_ARG, P_INT, &maxctl, 0),
+    f2c_entry ("Nn", P_ONE_ARG, P_INT, &maxhash, 0),
+    f2c_entry ("NL", P_ONE_ARG, P_INT, &maxliterals, 0),
+    f2c_entry ("NC", P_ONE_ARG, P_INT, &maxcontin, 0),
+    f2c_entry ("Nl", P_ONE_ARG, P_INT, &maxlablist, 0),
+    f2c_entry ("c", P_NO_ARGS, P_INT, &addftnsrc, YES),
+    f2c_entry ("p", P_NO_ARGS, P_INT, &usedefsforcommon, YES),
+    f2c_entry ("R", P_NO_ARGS, P_INT, &forcedouble, NO),
+    f2c_entry ("!R", P_NO_ARGS, P_INT, &forcedouble, YES),
+    f2c_entry ("A", P_NO_ARGS, P_INT, &Ansi, YES),
+    f2c_entry ("ext", P_NO_ARGS, P_INT, &noextflag, YES),
+    f2c_entry ("z", P_NO_ARGS, P_INT, &zflag, NO),
+    f2c_entry ("a", P_NO_ARGS, P_INT, &useauto, YES),
+    f2c_entry ("r8", P_NO_ARGS, P_INT, &r8flag, YES),
+    f2c_entry ("i2", P_NO_ARGS, P_INT, &tyioint, NO),
+    f2c_entry ("w8", P_NO_ARGS, P_INT, &wordalign, YES),
+    f2c_entry ("!I", P_NO_ARGS, P_INT, &can_include, NO),
+    f2c_entry ("W", P_ONE_ARG, P_INT, &chars_per_wd, 0),
+    f2c_entry ("g", P_NO_ARGS, P_INT, &gflag, YES),
+    f2c_entry ("T", P_ONE_ARG, P_STRING, &tmpdir, 0),
+    f2c_entry ("E", P_NO_ARGS, P_INT, &extcomm, 1),
+    f2c_entry ("e1c", P_NO_ARGS, P_INT, &ext1comm, 1),
+    f2c_entry ("ec", P_NO_ARGS, P_INT, &ext1comm, 2),
+    f2c_entry ("C++", P_NO_ARGS, P_INT, &Ansi, 2),
+    f2c_entry ("P", P_NO_ARGS, P_INT, &Castargs, 3),
+    f2c_entry ("Ps", P_NO_ARGS, P_INT, &protostatus, 1),
+    f2c_entry ("!P", P_NO_ARGS, P_INT, &Castargs, 0),
+    f2c_entry ("!c", P_NO_ARGS, P_INT, &skipC, 1),
+    f2c_entry ("!it", P_NO_ARGS, P_INT, &infertypes, 0),
+    f2c_entry ("h", P_NO_ARGS, P_INT, &h0align, 1),
+    f2c_entry ("hd", P_NO_ARGS, P_INT, &h0align, 2),
+    f2c_entry ("kr", P_NO_ARGS, P_INT, &krparens, 1),
+    f2c_entry ("krd", P_NO_ARGS, P_INT, &krparens, 2),
+    f2c_entry ("!bs", P_NO_ARGS, P_INT, &use_bs, NO),
+    f2c_entry ("r", P_NO_ARGS, P_INT, &forcereal, YES),
+    f2c_entry ("72", P_NO_ARGS, P_INT, &warn72, 1),
+    f2c_entry ("f", P_NO_ARGS, P_INT, &warn72, 2),
+    f2c_entry ("s", P_NO_ARGS, P_INT, &keepsubs, 1),
+#ifdef TYQUAD
+    f2c_entry ("!i8", P_NO_ARGS, P_INT, &use_tyquad, NO),
+#endif
+
+       /* options omitted from man pages */
+
+       /* -ev ==> implement equivalence with initialized pointers */
+    f2c_entry ("ev", P_NO_ARGS, P_INT, &def_equivs, NO),
+
+       /* -!it used to be the default when -it was more agressive */
+
+    f2c_entry ("it", P_NO_ARGS, P_INT, &infertypes, 1),
+
+       /* -Pd is similar to -P, but omits :ref: lines */
+    f2c_entry ("Pd", P_NO_ARGS, P_INT, &Castargs, 2),
+
+       /* -t ==> emit typedefs (under -A or -C++) for procedure
+               argument types used.  This is meant for netlib's
+               f2c service, so -A and -C++ will work with older
+               versions of f2c.h
+               */
+    f2c_entry ("t", P_NO_ARGS, P_INT, &typedefs, 1),
+
+       /* -!V ==> omit version msg (to facilitate using diff in
+               regression testing)
+               */
+    f2c_entry ("!V", P_NO_ARGS, P_INT, &skipversion, 1)
+
+}; /* table */
+
+extern char *c_functions;      /* "c_functions"        */
+extern char *coutput;          /* "c_output"           */
+extern char *initfname;                /* "raw_data"           */
+extern char *blkdfname;                /* "block_data"         */
+extern char *p1_file;          /* "p1_file"            */
+extern char *p1_bakfile;       /* "p1_file.BAK"        */
+extern char *sortfname;                /* "init_file"          */
+extern char *proto_fname;      /* "proto_file"         */
+FILE *protofile;
+
+extern void list_init_data(), set_tmp_names(), sigcatch(), Un_link_all();
+extern char *c_name();
+
+
+set_externs ()
+{
+    static char *hset[3] = { 0, "integer", "doublereal" };
+
+/* Adjust the global flags according to the command line parameters */
+
+    if (chars_per_wd > 0) {
+       typesize[TYADDR] = typesize[TYLONG] = typesize[TYREAL] =
+               typesize[TYLOGICAL] = chars_per_wd;
+       typesize[TYINT1] = typesize[TYLOGICAL1] = 1;
+       typesize[TYDREAL] = typesize[TYCOMPLEX] = chars_per_wd << 1;
+       typesize[TYDCOMPLEX] = chars_per_wd << 2;
+       typesize[TYSHORT] = typesize[TYLOGICAL2] = chars_per_wd >> 1;
+       typesize[TYCILIST] = 5*chars_per_wd;
+       typesize[TYICILIST] = 6*chars_per_wd;
+       typesize[TYOLIST] = 9*chars_per_wd;
+       typesize[TYCLLIST] = 3*chars_per_wd;
+       typesize[TYALIST] = 2*chars_per_wd;
+       typesize[TYINLIST] = 26*chars_per_wd;
+       }
+
+    if (wordalign)
+       typealign[TYDREAL] = typealign[TYDCOMPLEX] = typealign[TYREAL];
+    if (!tyioint) {
+       tyioint = TYSHORT;
+       szleng = typesize[TYSHORT];
+       def_i2 = "#define f2c_i2 1\n";
+       inqmask = M(TYSHORT)|M(TYLOGICAL);
+       goto checklong;
+       }
+    else
+       szleng = typesize[TYLONG];
+    if (useshortints) {
+       inqmask = M(TYLONG);
+ checklong:
+       protorettypes[TYLOGICAL] = typename[TYLOGICAL] = "shortlogical";
+       typesize[TYLOGICAL] = typesize[TYSHORT];
+       casttypes[TYLOGICAL] = "K_fp";
+       if (uselongints)
+               err ("Can't use both long and short ints");
+       else {
+               tyint = tylogical = TYSHORT;
+               tylog = TYLOGICAL2;
+               }
+       }
+    else if (uselongints)
+       tyint = TYLONG;
+
+    if (h0align) {
+       if (tyint == TYLONG && wordalign)
+               h0align = 1;
+       ohalign = halign = hset[h0align];
+       htype = h0align == 1 ? tyint : TYDREAL;
+       hsize = typesize[htype];
+       }
+
+    if (no66flag)
+       noextflag = no66flag;
+    if (noextflag)
+       zflag = 0;
+
+    if (r8flag) {
+       tyreal = TYDREAL;
+       tycomplex = TYDCOMPLEX;
+       r8fix();
+       }
+    if (forcedouble) {
+       protorettypes[TYREAL] = "E_f";
+       casttypes[TYREAL] = "E_fp";
+       }
+
+    if (maxregvar > MAXREGVAR) {
+       warni("-O%d: too many register variables", maxregvar);
+       maxregvar = MAXREGVAR;
+    } /* if maxregvar > MAXREGVAR */
+
+/* Check the list of input files */
+
+    {
+       int bad, i, cur_max = Max_ftn_files;
+
+       for (i = bad = 0; i < cur_max && ftn_files[i]; i++)
+           if (ftn_files[i][0] == '-') {
+               errstr ("Invalid flag '%s'", ftn_files[i]);
+               bad++;
+               }
+       if (bad)
+               exit(1);
+
+    } /* block */
+} /* set_externs */
+
+
+ static int
+comm2dcl()
+{
+       Extsym *ext;
+       if (ext1comm)
+               for(ext = extsymtab; ext < nextext; ext++)
+                       if (ext->extstg == STGCOMMON && !ext->extinit)
+                               return ext1comm;
+       return 0;
+       }
+
+ static void
+write_typedefs(outfile)
+ FILE *outfile;
+{
+       register int i;
+       register char *s, *p = 0;
+       static char st[4] = { TYREAL, TYCOMPLEX, TYDCOMPLEX, TYCHAR };
+       static char stl[4] = { 'E', 'C', 'Z', 'H' };
+
+       for(i = 0; i <= TYSUBR; i++)
+               if (s = usedcasts[i]) {
+                       if (!p) {
+                               p = Ansi == 1 ? "()" : "(...)";
+                               nice_printf(outfile,
+                               "/* Types for casting procedure arguments: */\
+\n\n#ifndef F2C_proc_par_types\n");
+                               if (i == 0) {
+                                       nice_printf(outfile,
+                       "typedef int /* Unknown procedure type */ (*%s)%s;\n",
+                                                s, p);
+                                       continue;
+                                       }
+                               }
+                       nice_printf(outfile, "typedef %s (*%s)%s;\n",
+                                       c_type_decl(i,1), s, p);
+                       }
+       for(i = !forcedouble; i < 4; i++)
+               if (used_rets[st[i]])
+                       nice_printf(outfile,
+                               "typedef %s %c_f; /* %s function */\n",
+                               p = i ? "VOID" : "doublereal",
+                               stl[i], ftn_types[st[i]]);
+       if (p)
+               nice_printf(outfile, "#endif\n\n");
+       }
+
+ static void
+commonprotos(outfile)
+ register FILE *outfile;
+{
+       register Extsym *e, *ee;
+       register Argtypes *at;
+       Atype *a, *ae;
+       int k;
+       extern int proc_protochanges;
+
+       if (!outfile)
+               return;
+       for (e = extsymtab, ee = nextext; e < ee; e++)
+               if (e->extstg == STGCOMMON && e->allextp)
+                       nice_printf(outfile, "/* comlen %s %ld */\n",
+                               e->cextname, e->maxleng);
+       if (Castargs1 < 3)
+               return;
+
+       /* -Pr: special comments conveying current knowledge
+           of external references */
+
+       k = proc_protochanges;
+       for (e = extsymtab, ee = nextext; e < ee; e++)
+               if (e->extstg == STGEXT
+               && e->cextname != e->fextname)  /* not a library function */
+                   if (at = e->arginfo) {
+                       if ((!e->extinit || at->changes & 1)
+                               /* not defined here or
+                                       changed since definition */
+                       && at->nargs >= 0) {
+                               nice_printf(outfile, "/*:ref: %s %d %d",
+                                       e->cextname, e->extype, at->nargs);
+                               a = at->atypes;
+                               for(ae = a + at->nargs; a < ae; a++)
+                                       nice_printf(outfile, " %d", a->type);
+                               nice_printf(outfile, " */\n");
+                               if (at->changes & 1)
+                                       k++;
+                               }
+                       }
+                   else if (e->extype)
+                       /* typed external, never invoked */
+                       nice_printf(outfile, "/*:ref: %s %d :*/\n",
+                               e->cextname, e->extype);
+       if (k) {
+               nice_printf(outfile,
+       "/* Rerunning f2c -P may change prototypes or declarations. */\n");
+               if (nerr)
+                       return;
+               if (protostatus)
+                       done(4);
+               if (protofile != stdout) {
+                       fprintf(diagfile,
+       "Rerunning \"f2c -P ... %s %s\" may change prototypes or declarations.\n",
+                               filename0, proto_fname);
+                       fflush(diagfile);
+                       }
+               }
+       }
+
+ int retcode = 0;
+
+main(argc, argv)
+int argc;
+char **argv;
+{
+       int c2d, k;
+       FILE *c_output;
+       char *cdfilename;
+       static char stderrbuf[BUFSIZ];
+       extern void def_commons();
+       extern char **dfltproc, *dflt1proc[];
+       extern char link_msg[];
+
+       diagfile = stderr;
+       setbuf(stderr, stderrbuf);      /* arrange for fast error msgs */
+
+       Max_ftn_files = argc - 1;
+       ftn_files = (char **)ckalloc((argc+1)*sizeof(char *));
+
+       parse_args (argc, argv, table, sizeof(table)/sizeof(arg_info),
+               ftn_files, Max_ftn_files);
+       if (!can_include && ext1comm == 2)
+               ext1comm = 1;
+       if (ext1comm && !extcomm)
+               extcomm = 2;
+       if (protostatus)
+               Castargs = 3;
+       Castargs1 = Castargs;
+       if (!Ansi) {
+               Castargs = 0;
+               parens = "()";
+               }
+       else if (!Castargs)
+               parens = Ansi == 1 ? "()" : "(...)";
+       else
+               dfltproc = dflt1proc;
+
+       set_externs();
+       fileinit();
+       read_Pfiles(ftn_files);
+
+       for(k = 1; ftn_files[k]; k++)
+               if (dofork())
+                       break;
+       filename0 = file_name = ftn_files[current_ftn_file = k - 1];
+
+       set_tmp_names();
+       sigcatch();
+
+       c_file   = opf(c_functions, textwrite);
+       pass1_file=opf(p1_file, binwrite);
+       initkey();
+       if (file_name && *file_name) {
+               if (debugflag != 1) {
+                       coutput = c_name(file_name,'c');
+                       if (Castargs1 >= 2)
+                               proto_fname = c_name(file_name,'P');
+                       }
+               cdfilename = coutput;
+               if (skipC)
+                       coutput = 0;
+               else if (!(c_output = fopen(coutput, textwrite))) {
+                       file_name = coutput;
+                       coutput = 0;    /* don't delete read-only .c file */
+                       fatalstr("can't open %.86s", file_name);
+                       }
+
+               if (Castargs1 >= 2
+               && !(protofile = fopen(proto_fname, textwrite)))
+                       fatalstr("Can't open %.84s\n", proto_fname);
+               }
+       else {
+               file_name = "";
+               cdfilename = "f2c_out.c";
+               c_output = stdout;
+               coutput = 0;
+               if (Castargs1 >= 2) {
+                       protofile = stdout;
+                       if (!skipC)
+                               printf("#ifdef P_R_O_T_O_T_Y_P_E_S\n");
+                       }
+               }
+
+       if(inilex( copys(file_name) ))
+               done(1);
+       if (filename0) {
+               fprintf(diagfile, "%s:\n", file_name);
+               fflush(diagfile);
+               }
+
+       procinit();
+       if(k = yyparse())
+       {
+               fprintf(diagfile, "Bad parse, return code %d\n", k);
+               done(1);
+       }
+
+       commonprotos(protofile);
+       if (protofile == stdout && !skipC)
+               printf("#endif\n\n");
+
+       if (nerr || skipC)
+               goto C_skipped;
+
+
+/* Write out the declarations which are global to this file */
+
+       if ((c2d = comm2dcl()) == 1)
+               nice_printf(c_output, "/*>>>'/dev/null'<<<*/\n\n\
+/* Split this into several files by piping it through\n\n\
+sed \"s/^\\/\\*>>>'\\(.*\\)'<<<\\*\\/\\$/cat >'\\1' <<'\\/*<<<\\1>>>*\\/'/\" | /bin/sh\n\
+ */\n\
+/*<<</dev/null>>>*/\n\
+/*>>>'%s'<<<*/\n", cdfilename);
+       if (gflag)
+               nice_printf (c_output, "#line 1 \"%s\"\n", file_name);
+       if (!skipversion) {
+               nice_printf (c_output, "/* %s -- translated by f2c ", file_name);
+               nice_printf (c_output, "(version %s).\n", F2C_version);
+               nice_printf (c_output,
+       "   You must link the resulting object file with the libraries:\n\
+       %s   (in that order)\n*/\n\n", link_msg);
+               }
+       if (Ansi == 2)
+               nice_printf(c_output,
+                       "#ifdef __cplusplus\nextern \"C\" {\n#endif\n");
+       nice_printf (c_output, "%s#include \"f2c.h\"\n\n", def_i2);
+       if (gflag)
+               nice_printf (c_output, "#line 1 \"%s\"\n", file_name);
+       if (Castargs && typedefs)
+               write_typedefs(c_output);
+       nice_printf (c_file, "\n");
+       fclose (c_file);
+       c_file = c_output;              /* HACK to get the next indenting
+                                          to work */
+       wr_common_decls (c_output);
+       if (blkdfile)
+               list_init_data(&blkdfile, blkdfname, c_output);
+       wr_globals (c_output);
+       if ((c_file = fopen (c_functions, textread)) == (FILE *) NULL)
+           Fatal("main - couldn't reopen c_functions");
+       ffilecopy (c_file, c_output);
+       if (*main_alias) {
+           nice_printf (c_output, "/* Main program alias */ ");
+           nice_printf (c_output, "int %s () { MAIN__ ();%s }\n",
+                   main_alias, Ansi ? " return 0;" : "");
+           }
+       if (Ansi == 2)
+               nice_printf(c_output,
+                       "#ifdef __cplusplus\n\t}\n#endif\n");
+       if (c2d) {
+               if (c2d == 1)
+                       fprintf(c_output, "/*<<<%s>>>*/\n", cdfilename);
+               else
+                       fclose(c_output);
+               def_commons(c_output);
+               }
+       if (c2d != 2)
+               fclose (c_output);
+
+ C_skipped:
+       if(parstate != OUTSIDE)
+               {
+               warn("missing final end statement");
+               endproc();
+               }
+       done(nerr ? 1 : 0);
+}
+
+
+FILEP opf(fn, mode)
+char *fn, *mode;
+{
+       FILEP fp;
+       if( fp = fopen(fn, mode) )
+               return(fp);
+
+       fatalstr("cannot open intermediate file %s", fn);
+       /* NOT REACHED */ return 0;
+}
+
+
+clf(p, what, quit)
+ FILEP *p;
+ char *what;
+ int quit;
+{
+       if(p!=NULL && *p!=NULL && *p!=stdout)
+       {
+               if(ferror(*p)) {
+                       fprintf(stderr, "I/O error on %s\n", what);
+                       if (quit)
+                               done(3);
+                       retcode = 3;
+                       }
+               fclose(*p);
+       }
+       *p = NULL;
+}
+
+
+done(k)
+int k;
+{
+       clf(&initfile, "initfile", 0);
+       clf(&c_file, "c_file", 0);
+       clf(&pass1_file, "pass1_file", 0);
+       Un_link_all(k);
+       exit(k|retcode);
+}

diff --git a/usr.bin/f2c/makefile b/usr.bin/f2c/makefile
new file mode 100644 (file)
index 0000000..d15fe2a
--- /dev/null
+++ b/usr.bin/f2c/makefile
@@ -0,0 +1,90 @@
+#      Makefile for f2c, a Fortran 77 to C converter
+
+g = -g
+CFLAGS = $g
+SHELL = /bin/sh
+
+OBJECTSd = main.o init.o gram.o lex.o proc.o equiv.o data.o format.o \
+         expr.o exec.o intr.o io.o misc.o error.o mem.o names.o \
+         output.o p1output.o pread.o put.o putpcc.o vax.o formatdata.o \
+         parse_args.o niceprintf.o cds.o sysdep.o version.o
+OBJECTS = $(OBJECTSd) malloc.o
+
+all: xsum.out f2c
+
+f2c: $(OBJECTS)
+       $(CC) $(LDFLAGS) $(OBJECTS) -o f2c
+
+gram.c:        gram.head gram.dcl gram.expr gram.exec gram.io defs.h tokdefs.h
+       ( sed <tokdefs.h "s/#define/%token/" ;\
+               cat gram.head gram.dcl gram.expr gram.exec gram.io ) >gram.in
+       $(YACC) $(YFLAGS) gram.in
+       echo "(expect 4 shift/reduce)"
+       sed 's/^# line.*/\/* & *\//' y.tab.c >gram.c
+       rm -f gram.in y.tab.c
+
+$(OBJECTSd): defs.h ftypes.h defines.h machdefs.h sysdep.h
+
+tokdefs.h: tokens
+       grep -n . <tokens | sed "s/\([^:]*\):\(.*\)/#define \2 \1/" >tokdefs.h
+
+cds.o: sysdep.h
+exec.o: p1defs.h names.h
+expr.o: output.h niceprintf.h names.h
+format.o: p1defs.h format.h output.h niceprintf.h names.h iob.h
+formatdata.o: format.h output.h niceprintf.h names.h
+gram.o: p1defs.h
+init.o: output.h niceprintf.h iob.h
+intr.o: names.h
+io.o: names.h iob.h
+lex.o : tokdefs.h p1defs.h
+main.o: parse.h usignal.h
+mem.o: iob.h
+names.o: iob.h names.h output.h niceprintf.h
+niceprintf.o: defs.h names.h output.h niceprintf.h
+output.o: output.h niceprintf.h names.h
+p1output.o: p1defs.h output.h niceprintf.h names.h
+parse_args.o: parse.h
+proc.o: tokdefs.h names.h niceprintf.h output.h p1defs.h
+put.o: names.h pccdefs.h p1defs.h
+putpcc.o: names.h
+vax.o: defs.h output.h pccdefs.h
+output.h: niceprintf.h
+
+put.o putpcc.o: pccdefs.h
+
+f2c.t: f2c.1t
+       troff -man f2c.1t >f2c.t
+
+f2c.1: f2c.1t
+       nroff -man f2c.1t | col -b | uniq >f2c.1
+
+clean:
+       rm -f gram.c *.o f2c tokdefs.h f2c.t
+
+b = Notice README cds.c data.c defines.h defs.h equiv.c error.c \
+       exec.c expr.c f2c.1 f2c.1t f2c.h format.c format.h formatdata.c \
+       ftypes.h gram.dcl gram.exec gram.expr gram.head gram.io \
+       init.c intr.c io.c iob.h lex.c machdefs.h main.c makefile \
+       malloc.c mem.c memset.c misc.c names.c names.h niceprintf.c \
+       niceprintf.h output.c output.h p1defs.h p1output.c \
+       parse.h parse_args.c pccdefs.h pread.c proc.c put.c putpcc.c \
+       sysdep.c sysdep.h tokens usignal.h vax.c version.c xsum.c
+
+bundle:
+       bundle $b xsum0.out >/tmp/f2c.bundle
+
+xsum: xsum.c
+       $(CC) -o xsum xsum.c
+
+#Check validity of transmitted source...
+xsum.out: xsum
+       ./xsum $b >xsum1.out
+       cmp xsum0.out xsum1.out && mv xsum1.out xsum.out
+
+#On non-Unix systems that end lines with carriage-return/newline pairs,
+#use "make xsumr.out" rather than "make xsum.out".  The -r flag ignores
+#carriage-return characters.
+xsumr.out: xsum
+       ./xsum -r $b >xsum1.out
+       cmp xsum0.out xsum1.out && mv xsum1.out xsumr.out

diff --git a/usr.bin/f2c/malloc.c b/usr.bin/f2c/malloc.c
new file mode 100644 (file)
index 0000000..e4414da
--- /dev/null
+++ b/usr.bin/f2c/malloc.c
@@ -0,0 +1,142 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#ifndef CRAY
+#define STACKMIN 512
+#define MINBLK (2*sizeof(struct mem) + 16)
+#define MSTUFF _malloc_stuff_
+#define F MSTUFF.free
+#define B MSTUFF.busy
+#define SBGULP 8192
+char *memcpy();
+
+struct mem {
+       struct mem *next;
+       unsigned len;
+       };
+
+struct {
+       struct mem *free;
+       char *busy;
+       } MSTUFF;
+
+char *
+malloc(size)
+register unsigned size;
+{
+       register struct mem *p, *q, *r, *s;
+       unsigned register k, m;
+       extern char *sbrk();
+       char *top, *top1;
+
+       size = (size+7) & ~7;
+       r = (struct mem *) &F;
+       for (p = F, q = 0; p; r = p, p = p->next) {
+               if ((k = p->len) >= size && (!q || m > k)) { m = k; q = p; s = r; }
+               }
+       if (q) {
+               if (q->len - size >= MINBLK) { /* split block */
+                       p = (struct mem *) (((char *) (q+1)) + size);
+                       p->next = q->next;
+                       p->len = q->len - size - sizeof(struct mem);
+                       s->next = p;
+                       q->len = size;
+                       }
+               else s->next = q->next;
+               }
+       else {
+               top = B ? B : (char *)(((long)sbrk(0) + 7) & ~7);
+               if (F && (char *)(F+1) + F->len == B)
+                       { q = F; F = F->next; }
+               else q = (struct mem *) top;
+               top1 = (char *)(q+1) + size;
+               if (top1 > top) {
+                       if (sbrk((int)(top1-top+SBGULP)) == (char *) -1)
+                               return 0;
+                       r = (struct mem *)top1;
+                       r->len = SBGULP - sizeof(struct mem);
+                       r->next = F;
+                       F = r;
+                       top1 += SBGULP;
+                       }
+               q->len = size;
+               B = top1;
+               }
+       return (char *) (q+1);
+       }
+
+free(f)
+char *f;
+{
+       struct mem *p, *q, *r;
+       char *pn, *qn;
+
+       if (!f) return;
+       q = (struct mem *) (f - sizeof(struct mem));
+       qn = f + q->len;
+       for (p = F, r = (struct mem *) &F; ; r = p, p = p->next) {
+               if (qn == (char *) p) {
+                       q->len += p->len + sizeof(struct mem);
+                       p = p->next;
+                       }
+               pn = p ? ((char *) (p+1)) + p->len : 0;
+               if (pn == (char *) q) {
+                       p->len += sizeof(struct mem) + q->len;
+                       q->len = 0;
+                       q->next = p;
+                       r->next = p;
+                       break;
+                       }
+               if (pn < (char *) q) {
+                       r->next = q;
+                       q->next = p;
+                       break;
+                       }
+               }
+       }
+
+char *
+realloc(f, size)
+char *f;
+unsigned size;
+{
+       struct mem *p;
+       char *q, *f1;
+       unsigned s1;
+
+       if (!f) return malloc(size);
+       p = (struct mem *) (f - sizeof(struct mem));
+       s1 = p->len;
+       free(f);
+       if (s1 > size) s1 = size + 7 & ~7;
+       if (!p->len) {
+               f1 = (char *)(p->next + 1);
+               memcpy(f1, f, s1);
+               f = f1;
+               }
+       q = malloc(size);
+       if (q && q != f)
+               memcpy(q, f, s1);
+       return q;
+       }
+#endif

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

diff --git a/usr.bin/f2c/memset.c b/usr.bin/f2c/memset.c
new file mode 100644 (file)
index 0000000..98a7ce7
--- /dev/null
+++ b/usr.bin/f2c/memset.c
@@ -0,0 +1,66 @@
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* This is for the benefit of people whose systems don't provide
+ * memset, memcpy, and memcmp.  If yours is such a system, adjust
+ * the makefile by adding memset.o to the "OBJECTS =" assignment.
+ * WARNING: the memcpy below is adequate for f2c, but is not a
+ * general memcpy routine (which must correctly handle overlapping
+ * fields).
+ */
+
+ int
+memcmp(s1, s2, n)
+ register char *s1, *s2;
+ int n;
+{
+       register char *se;
+
+       for(se = s1 + n; s1 < se; s1++, s2++)
+               if (*s1 != *s2)
+                       return *s1 - *s2;
+       return 0;
+       }
+
+ char *
+memcpy(s1, s2, n)
+ register char *s1, *s2;
+ int n;
+{
+       register char *s0 = s1, *se = s1 + n;
+
+       while(s1 < se)
+               *s1++ = *s2++;
+       return s0;
+       }
+
+memset(s, c, n)
+ register char *s;
+ register int c;
+ int n;
+{
+       register char *se = s + n;
+
+       while(s < se)
+               *s++ = c;
+       }

diff --git a/usr.bin/f2c/misc.c b/usr.bin/f2c/misc.c
new file mode 100644 (file)
index 0000000..d8ad3cf
--- /dev/null
+++ b/usr.bin/f2c/misc.c
@@ -0,0 +1,1054 @@
+/****************************************************************
+Copyright 1990, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+
+int oneof_stg (name, stg, mask)
+ Namep name;
+ int stg, mask;
+{
+       if (stg == STGCOMMON && name) {
+               if ((mask & M(STGEQUIV)))
+                       return name->vcommequiv;
+               if ((mask & M(STGCOMMON)))
+                       return !name->vcommequiv;
+               }
+       return ONEOF(stg, mask);
+       }
+
+
+/* op_assign -- given a binary opcode, return the associated assignment
+   operator */
+
+int op_assign (opcode)
+int opcode;
+{
+    int retval = -1;
+
+    switch (opcode) {
+        case OPPLUS: retval = OPPLUSEQ; break;
+       case OPMINUS: retval = OPMINUSEQ; break;
+       case OPSTAR: retval = OPSTAREQ; break;
+       case OPSLASH: retval = OPSLASHEQ; break;
+       case OPMOD: retval = OPMODEQ; break;
+       case OPLSHIFT: retval = OPLSHIFTEQ; break;
+       case OPRSHIFT: retval = OPRSHIFTEQ; break;
+       case OPBITAND: retval = OPBITANDEQ; break;
+       case OPBITXOR: retval = OPBITXOREQ; break;
+       case OPBITOR: retval = OPBITOREQ; break;
+       default:
+           erri ("op_assign:  bad opcode '%d'", opcode);
+           break;
+    } /* switch */
+
+    return retval;
+} /* op_assign */
+
+
+ char *
+Alloc(n)       /* error-checking version of malloc */
+               /* ckalloc initializes memory to 0; Alloc does not */
+ int n;
+{
+       char errbuf[32];
+       register char *rv;
+
+       rv = malloc(n);
+       if (!rv) {
+               sprintf(errbuf, "malloc(%d) failure!", n);
+               Fatal(errbuf);
+               }
+       return rv;
+       }
+
+
+cpn(n, a, b)
+register int n;
+register char *a, *b;
+{
+       while(--n >= 0)
+               *b++ = *a++;
+}
+
+
+
+eqn(n, a, b)
+register int n;
+register char *a, *b;
+{
+       while(--n >= 0)
+               if(*a++ != *b++)
+                       return(NO);
+       return(YES);
+}
+
+
+
+
+
+
+
+cmpstr(a, b, la, lb)   /* compare two strings */
+register char *a, *b;
+ftnint la, lb;
+{
+       register char *aend, *bend;
+       aend = a + la;
+       bend = b + lb;
+
+
+       if(la <= lb)
+       {
+               while(a < aend)
+                       if(*a != *b)
+                               return( *a - *b );
+                       else
+                       {
+                               ++a;
+                               ++b;
+                       }
+
+               while(b < bend)
+                       if(*b != ' ')
+                               return(' ' - *b);
+                       else
+                               ++b;
+       }
+
+       else
+       {
+               while(b < bend)
+                       if(*a != *b)
+                               return( *a - *b );
+                       else
+                       {
+                               ++a;
+                               ++b;
+                       }
+               while(a < aend)
+                       if(*a != ' ')
+                               return(*a - ' ');
+                       else
+                               ++a;
+       }
+       return(0);
+}
+
+
+/* hookup -- Same as LISP NCONC, that is a destructive append of two lists */
+
+chainp hookup(x,y)
+register chainp x, y;
+{
+       register chainp p;
+
+       if(x == NULL)
+               return(y);
+
+       for(p = x ; p->nextp ; p = p->nextp)
+               ;
+       p->nextp = y;
+       return(x);
+}
+
+
+
+struct Listblock *mklist(p)
+chainp p;
+{
+       register struct Listblock *q;
+
+       q = ALLOC(Listblock);
+       q->tag = TLIST;
+       q->listp = p;
+       return(q);
+}
+
+
+chainp mkchain(p,q)
+register char * p;
+register chainp q;
+{
+       register chainp r;
+
+       if(chains)
+       {
+               r = chains;
+               chains = chains->nextp;
+       }
+       else
+               r = ALLOC(Chain);
+
+       r->datap = p;
+       r->nextp = q;
+       return(r);
+}
+
+ chainp
+revchain(next)
+ register chainp next;
+{
+       register chainp p, prev = 0;
+
+       while(p = next) {
+               next = p->nextp;
+               p->nextp = prev;
+               prev = p;
+               }
+       return prev;
+       }
+
+
+/* addunder -- turn a cvarname into an external name */
+/* The cvarname may already end in _ (to avoid C keywords); */
+/* if not, it has room for appending an _. */
+
+ char *
+addunder(s)
+ register char *s;
+{
+       register int c, i;
+       char *s0 = s;
+
+       i = 0;
+       while(c = *s++)
+               if (c == '_')
+                       i++;
+               else
+                       i = 0;
+       if (!i) {
+               *s-- = 0;
+               *s = '_';
+               }
+       return( s0 );
+       }
+
+
+/* copyn -- return a new copy of the input Fortran-string */
+
+char *copyn(n, s)
+register int n;
+register char *s;
+{
+       register char *p, *q;
+
+       p = q = (char *) Alloc(n);
+       while(--n >= 0)
+               *q++ = *s++;
+       return(p);
+}
+
+
+
+/* copys -- return a new copy of the input C-string */
+
+char *copys(s)
+char *s;
+{
+       return( copyn( strlen(s)+1 , s) );
+}
+
+
+
+/* convci -- Convert Fortran-string to integer; assumes that input is a
+   legal number, with no trailing blanks */
+
+ftnint convci(n, s)
+register int n;
+register char *s;
+{
+       ftnint sum;
+       sum = 0;
+       while(n-- > 0)
+               sum = 10*sum + (*s++ - '0');
+       return(sum);
+}
+
+/* convic - Convert Integer constant to string */
+
+char *convic(n)
+ftnint n;
+{
+       static char s[20];
+       register char *t;
+
+       s[19] = '\0';
+       t = s+19;
+
+       do      {
+               *--t = '0' + n%10;
+               n /= 10;
+       } while(n > 0);
+
+       return(t);
+}
+
+
+
+/* mkname -- add a new identifier to the environment, including the closed
+   hash table. */
+
+Namep mkname(s)
+register char *s;
+{
+       struct Hashentry *hp;
+       register Namep q;
+       register int c, hash, i;
+       register char *t;
+       char *s0;
+       char errbuf[64];
+
+       hash = i = 0;
+       s0 = s;
+       while(c = *s++) {
+               hash += c;
+               if (c == '_')
+                       i = 2;
+               }
+       if (!i && in_vector(s0,c_keywords,n_keywords) >= 0)
+               i = 1;
+       hash %= maxhash;
+
+/* Add the name to the closed hash table */
+
+       hp = hashtab + hash;
+
+       while(q = hp->varp)
+               if( hash == hp->hashval && !strcmp(s0,q->fvarname) )
+                       return(q);
+               else if(++hp >= lasthash)
+                       hp = hashtab;
+
+       if(++nintnames >= maxhash-1)
+               many("names", 'n', maxhash);    /* Fatal error */
+       hp->varp = q = ALLOC(Nameblock);
+       hp->hashval = hash;
+       q->tag = TNAME; /* TNAME means the tag type is NAME */
+       c = s - s0;
+       if (c > 7 && noextflag) {
+               sprintf(errbuf, "\"%.35s%s\" over 6 characters long", s0,
+                       c > 36 ? "..." : "");
+               errext(errbuf);
+               }
+       q->fvarname = strcpy(mem(c,0), s0);
+       t = q->cvarname = mem(c + i + 1, 0);
+       s = s0;
+       /* add __ to the end of any name containing _ and to any C keyword */
+       while(*t = *s++)
+               t++;
+       if (i) {
+               do *t++ = '_';
+                       while(--i > 0);
+               *t = 0;
+               }
+       return(q);
+}
+
+
+struct Labelblock *mklabel(l)
+ftnint l;
+{
+       register struct Labelblock *lp;
+
+       if(l <= 0)
+               return(NULL);
+
+       for(lp = labeltab ; lp < highlabtab ; ++lp)
+               if(lp->stateno == l)
+                       return(lp);
+
+       if(++highlabtab > labtabend)
+               many("statement labels", 's', maxstno);
+
+       lp->stateno = l;
+       lp->labelno = newlabel();
+       lp->blklevel = 0;
+       lp->labused = NO;
+       lp->fmtlabused = NO;
+       lp->labdefined = NO;
+       lp->labinacc = NO;
+       lp->labtype = LABUNKNOWN;
+       lp->fmtstring = 0;
+       return(lp);
+}
+
+
+newlabel()
+{
+       return( ++lastlabno );
+}
+
+
+/* this label appears in a branch context */
+
+struct Labelblock *execlab(stateno)
+ftnint stateno;
+{
+       register struct Labelblock *lp;
+
+       if(lp = mklabel(stateno))
+       {
+               if(lp->labinacc)
+                       warn1("illegal branch to inner block, statement label %s",
+                           convic(stateno) );
+               else if(lp->labdefined == NO)
+                       lp->blklevel = blklevel;
+               if(lp->labtype == LABFORMAT)
+                       err("may not branch to a format");
+               else
+                       lp->labtype = LABEXEC;
+       }
+       else
+               execerr("illegal label %s", convic(stateno));
+
+       return(lp);
+}
+
+
+/* find or put a name in the external symbol table */
+
+Extsym *mkext(f,s)
+char *f, *s;
+{
+       Extsym *p;
+
+       for(p = extsymtab ; p<nextext ; ++p)
+               if(!strcmp(s,p->cextname))
+                       return( p );
+
+       if(nextext >= lastext)
+               many("external symbols", 'x', maxext);
+
+       nextext->fextname = strcpy(gmem(strlen(f)+1,0), f);
+       nextext->cextname = f == s
+                               ? nextext->fextname
+                               : strcpy(gmem(strlen(s)+1,0), s);
+       nextext->extstg = STGUNKNOWN;
+       nextext->extp = 0;
+       nextext->allextp = 0;
+       nextext->extleng = 0;
+       nextext->maxleng = 0;
+       nextext->extinit = 0;
+       nextext->curno = nextext->maxno = 0;
+       return( nextext++ );
+}
+
+
+Addrp builtin(t, s, dbi)
+int t, dbi;
+char *s;
+{
+       register Extsym *p;
+       register Addrp q;
+       extern chainp used_builtins;
+
+       p = mkext(s,s);
+       if(p->extstg == STGUNKNOWN)
+               p->extstg = STGEXT;
+       else if(p->extstg != STGEXT)
+       {
+               errstr("improper use of builtin %s", s);
+               return(0);
+       }
+
+       q = ALLOC(Addrblock);
+       q->tag = TADDR;
+       q->vtype = t;
+       q->vclass = CLPROC;
+       q->vstg = STGEXT;
+       q->memno = p - extsymtab;
+       q->dbl_builtin = dbi;
+
+/* A NULL pointer here tells you to use   memno   to check the external
+   symbol table */
+
+       q -> uname_tag = UNAM_EXTERN;
+
+/* Add to the list of used builtins */
+
+       if (dbi >= 0)
+               add_extern_to_list (q, &used_builtins);
+       return(q);
+}
+
+
+
+add_extern_to_list (addr, list_store)
+Addrp addr;
+chainp *list_store;
+{
+    chainp last = CHNULL;
+    chainp list;
+    int memno;
+
+    if (list_store == (chainp *) NULL || addr == (Addrp) NULL)
+       return;
+
+    list = *list_store;
+    memno = addr -> memno;
+
+    for (;list; last = list, list = list -> nextp) {
+       Addrp this = (Addrp) (list -> datap);
+
+       if (this -> tag == TADDR && this -> uname_tag == UNAM_EXTERN &&
+               this -> memno == memno)
+           return;
+    } /* for */
+
+    if (*list_store == CHNULL)
+       *list_store = mkchain((char *)cpexpr((expptr)addr), CHNULL);
+    else
+       last->nextp = mkchain((char *)cpexpr((expptr)addr), CHNULL);
+
+} /* add_extern_to_list */
+
+
+frchain(p)
+register chainp *p;
+{
+       register chainp q;
+
+       if(p==0 || *p==0)
+               return;
+
+       for(q = *p; q->nextp ; q = q->nextp)
+               ;
+       q->nextp = chains;
+       chains = *p;
+       *p = 0;
+}
+
+ void
+frexchain(p)
+ register chainp *p;
+{
+       register chainp q, r;
+
+       if (q = *p) {
+               for(;;q = r) {
+                       frexpr((expptr)q->datap);
+                       if (!(r = q->nextp))
+                               break;
+                       }
+               q->nextp = chains;
+               chains = *p;
+               *p = 0;
+               }
+       }
+
+
+tagptr cpblock(n,p)
+register int n;
+register char * p;
+{
+       register ptr q;
+
+       memcpy((char *)(q = ckalloc(n)), (char *)p, n);
+       return( (tagptr) q);
+}
+
+
+
+ftnint lmax(a, b)
+ftnint a, b;
+{
+       return( a>b ? a : b);
+}
+
+ftnint lmin(a, b)
+ftnint a, b;
+{
+       return(a < b ? a : b);
+}
+
+
+
+
+maxtype(t1, t2)
+int t1, t2;
+{
+       int t;
+
+       t = t1 >= t2 ? t1 : t2;
+       if(t==TYCOMPLEX && (t1==TYDREAL || t2==TYDREAL) )
+               t = TYDCOMPLEX;
+       return(t);
+}
+
+
+
+/* return log base 2 of n if n a power of 2; otherwise -1 */
+log_2(n)
+ftnint n;
+{
+       int k;
+
+       /* trick based on binary representation */
+
+       if(n<=0 || (n & (n-1))!=0)
+               return(-1);
+
+       for(k = 0 ;  n >>= 1  ; ++k)
+               ;
+       return(k);
+}
+
+
+
+frrpl()
+{
+       struct Rplblock *rp;
+
+       while(rpllist)
+       {
+               rp = rpllist->rplnextp;
+               free( (charptr) rpllist);
+               rpllist = rp;
+       }
+}
+
+
+
+/* Call a Fortran function with an arbitrary list of arguments */
+
+int callk_kludge;
+
+expptr callk(type, name, args)
+int type;
+char *name;
+chainp args;
+{
+       register expptr p;
+
+       p = mkexpr(OPCALL,
+               (expptr)builtin(callk_kludge ? callk_kludge : type, name, 0),
+               (expptr)args);
+       p->exprblock.vtype = type;
+       return(p);
+}
+
+
+
+expptr call4(type, name, arg1, arg2, arg3, arg4)
+int type;
+char *name;
+expptr arg1, arg2, arg3, arg4;
+{
+       struct Listblock *args;
+       args = mklist( mkchain((char *)arg1,
+                       mkchain((char *)arg2,
+                               mkchain((char *)arg3,
+                                       mkchain((char *)arg4, CHNULL)) ) ) );
+       return( callk(type, name, (chainp)args) );
+}
+
+
+
+
+expptr call3(type, name, arg1, arg2, arg3)
+int type;
+char *name;
+expptr arg1, arg2, arg3;
+{
+       struct Listblock *args;
+       args = mklist( mkchain((char *)arg1,
+                       mkchain((char *)arg2,
+                               mkchain((char *)arg3, CHNULL) ) ) );
+       return( callk(type, name, (chainp)args) );
+}
+
+
+
+
+
+expptr call2(type, name, arg1, arg2)
+int type;
+char *name;
+expptr arg1, arg2;
+{
+       struct Listblock *args;
+
+       args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) );
+       return( callk(type,name, (chainp)args) );
+}
+
+
+
+
+expptr call1(type, name, arg)
+int type;
+char *name;
+expptr arg;
+{
+       return( callk(type,name, (chainp)mklist(mkchain((char *)arg,CHNULL)) ));
+}
+
+
+expptr call0(type, name)
+int type;
+char *name;
+{
+       return( callk(type, name, CHNULL) );
+}
+
+
+
+struct Impldoblock *mkiodo(dospec, list)
+chainp dospec, list;
+{
+       register struct Impldoblock *q;
+
+       q = ALLOC(Impldoblock);
+       q->tag = TIMPLDO;
+       q->impdospec = dospec;
+       q->datalist = list;
+       return(q);
+}
+
+
+
+
+/* ckalloc -- Allocate 1 memory unit of size   n,   checking for out of
+   memory error */
+
+ptr ckalloc(n)
+register int n;
+{
+       register ptr p;
+       p = (ptr)calloc(1, (unsigned) n);
+       if (p || !n)
+               return(p);
+       fprintf(stderr, "failing to get %d bytes\n",n);
+       Fatal("out of memory");
+       /* NOT REACHED */ return 0;
+}
+
+
+
+isaddr(p)
+register expptr p;
+{
+       if(p->tag == TADDR)
+               return(YES);
+       if(p->tag == TEXPR)
+               switch(p->exprblock.opcode)
+               {
+               case OPCOMMA:
+                       return( isaddr(p->exprblock.rightp) );
+
+               case OPASSIGN:
+               case OPASSIGNI:
+               case OPPLUSEQ:
+               case OPMINUSEQ:
+               case OPSLASHEQ:
+               case OPMODEQ:
+               case OPLSHIFTEQ:
+               case OPRSHIFTEQ:
+               case OPBITANDEQ:
+               case OPBITXOREQ:
+               case OPBITOREQ:
+                       return( isaddr(p->exprblock.leftp) );
+               }
+       return(NO);
+}
+
+
+
+
+isstatic(p)
+register expptr p;
+{
+       extern int useauto;
+       if(p->headblock.vleng && !ISCONST(p->headblock.vleng))
+               return(NO);
+
+       switch(p->tag)
+       {
+       case TCONST:
+               return(YES);
+
+       case TADDR:
+               if(ONEOF(p->addrblock.vstg,MSKSTATIC) &&
+                   ISCONST(p->addrblock.memoffset) && !useauto)
+                       return(YES);
+
+       default:
+               return(NO);
+       }
+}
+
+
+
+/* addressable -- return True iff it is a constant value, or can be
+   referenced by constant values */
+
+addressable(p)
+register expptr p;
+{
+       switch(p->tag)
+       {
+       case TCONST:
+               return(YES);
+
+       case TADDR:
+               return( addressable(p->addrblock.memoffset) );
+
+       default:
+               return(NO);
+       }
+}
+
+
+/* isnegative_const -- returns true if the constant is negative.  Returns
+   false for imaginary and nonnumeric constants */
+
+int isnegative_const (cp)
+struct Constblock *cp;
+{
+    int retval;
+
+    if (cp == NULL)
+       return 0;
+
+    switch (cp -> vtype) {
+       case TYINT1:
+        case TYSHORT:
+       case TYLONG:
+#ifdef TYQUAD
+       case TYQUAD:
+#endif
+           retval = cp -> Const.ci < 0;
+           break;
+       case TYREAL:
+       case TYDREAL:
+               retval = cp->vstg ? *cp->Const.cds[0] == '-'
+                                 :  cp->Const.cd[0] < 0.0;
+           break;
+       default:
+
+           retval = 0;
+           break;
+    } /* switch */
+
+    return retval;
+} /* isnegative_const */
+
+negate_const(cp)
+ Constp cp;
+{
+    if (cp == (struct Constblock *) NULL)
+       return;
+
+    switch (cp -> vtype) {
+       case TYINT1:
+       case TYSHORT:
+       case TYLONG:
+#ifdef TYQUAD
+       case TYQUAD:
+#endif
+           cp -> Const.ci = - cp -> Const.ci;
+           break;
+       case TYCOMPLEX:
+       case TYDCOMPLEX:
+               if (cp->vstg)
+                   switch(*cp->Const.cds[1]) {
+                       case '-':
+                               ++cp->Const.cds[1];
+                               break;
+                       case '0':
+                               break;
+                       default:
+                               --cp->Const.cds[1];
+                       }
+               else
+                       cp->Const.cd[1] = -cp->Const.cd[1];
+               /* no break */
+       case TYREAL:
+       case TYDREAL:
+               if (cp->vstg)
+                   switch(*cp->Const.cds[0]) {
+                       case '-':
+                               ++cp->Const.cds[0];
+                               break;
+                       case '0':
+                               break;
+                       default:
+                               --cp->Const.cds[0];
+                       }
+               else
+                       cp->Const.cd[0] = -cp->Const.cd[0];
+           break;
+       case TYCHAR:
+       case TYLOGICAL1:
+       case TYLOGICAL2:
+       case TYLOGICAL:
+           erri ("negate_const:  can't negate type '%d'", cp -> vtype);
+           break;
+       default:
+           erri ("negate_const:  bad type '%d'",
+                   cp -> vtype);
+           break;
+    } /* switch */
+} /* negate_const */
+
+ffilecopy (infp, outfp)
+FILE *infp, *outfp;
+{
+    while (!feof (infp)) {
+       register c = getc (infp);
+       if (!feof (infp))
+       putc (c, outfp);
+    } /* while */
+} /* ffilecopy */
+
+
+/* in_vector -- verifies whether   str   is in c_keywords.
+   If so, the index is returned else  -1  is returned.
+   c_keywords must be in alphabetical order (as defined by strcmp).
+*/
+
+int in_vector(str, keywds, n)
+char *str; char **keywds; register int n;
+{
+       register char **K = keywds;
+       register int n1, t;
+
+       do {
+               n1 = n >> 1;
+               if (!(t = strcmp(str, K[n1])))
+                       return K - keywds + n1;
+               if (t < 0)
+                       n = n1;
+               else {
+                       n -= ++n1;
+                       K += n1;
+                       }
+               }
+               while(n > 0);
+
+       return -1;
+       } /* in_vector */
+
+
+int is_negatable (Const)
+Constp Const;
+{
+    int retval = 0;
+    if (Const != (Constp) NULL)
+       switch (Const -> vtype) {
+           case TYINT1:
+               retval = Const -> Const.ci >= -BIGGEST_CHAR;
+               break;
+           case TYSHORT:
+               retval = Const -> Const.ci >= -BIGGEST_SHORT;
+               break;
+           case TYLONG:
+#ifdef TYQUAD
+           case TYQUAD:
+#endif
+               retval = Const -> Const.ci >= -BIGGEST_LONG;
+               break;
+           case TYREAL:
+           case TYDREAL:
+           case TYCOMPLEX:
+           case TYDCOMPLEX:
+               retval = 1;
+               break;
+           case TYLOGICAL1:
+           case TYLOGICAL2:
+           case TYLOGICAL:
+           case TYCHAR:
+           case TYSUBR:
+           default:
+               retval = 0;
+               break;
+       } /* switch */
+
+    return retval;
+} /* is_negatable */
+
+backup(fname, bname)
+ char *fname, *bname;
+{
+       FILE *b, *f;
+       static char couldnt[] = "Couldn't open %.80s";
+
+       if (!(f = fopen(fname, binread))) {
+               warn1(couldnt, fname);
+               return;
+               }
+       if (!(b = fopen(bname, binwrite))) {
+               warn1(couldnt, bname);
+               return;
+               }
+       ffilecopy(f, b);
+       fclose(f);
+       fclose(b);
+       }
+
+
+/* struct_eq -- returns YES if structures have the same field names and
+   types, NO otherwise */
+
+int struct_eq (s1, s2)
+chainp s1, s2;
+{
+    struct Dimblock *d1, *d2;
+    Constp cp1, cp2;
+
+    if (s1 == CHNULL && s2 == CHNULL)
+       return YES;
+    for(; s1 && s2; s1 = s1->nextp, s2 = s2->nextp) {
+       register Namep v1 = (Namep) s1 -> datap;
+       register Namep v2 = (Namep) s2 -> datap;
+
+       if (v1 == (Namep) NULL || v1 -> tag != TNAME ||
+               v2 == (Namep) NULL || v2 -> tag != TNAME)
+           return NO;
+
+       if (v1->vtype != v2->vtype || v1->vclass != v2->vclass
+               || strcmp(v1->fvarname, v2->fvarname))
+           return NO;
+
+       /* compare dimensions (needed for comparing COMMON blocks) */
+
+       if (d1 = v1->vdim) {
+               if (!(cp1 = (Constp)d1->nelt) || cp1->tag != TCONST)
+                       return NO;
+               if (!(d2 = v2->vdim))
+                       if (cp1->Const.ci == 1)
+                               continue;
+                       else
+                               return NO;
+               if (!(cp2 = (Constp)d2->nelt) || cp2->tag != TCONST
+               ||  cp1->Const.ci != cp2->Const.ci)
+                       return NO;
+               }
+       else if ((d2 = v2->vdim) && (!(cp2 = (Constp)d2->nelt)
+                               || cp2->tag != TCONST
+                               || cp2->Const.ci != 1))
+               return NO;
+    } /* while s1 != CHNULL && s2 != CHNULL */
+
+    return s1 == CHNULL && s2 == CHNULL;
+} /* struct_eq */

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

diff --git a/usr.bin/f2c/names.h b/usr.bin/f2c/names.h
new file mode 100644 (file)
index 0000000..1ca17d0
--- /dev/null
+++ b/usr.bin/f2c/names.h
@@ -0,0 +1,22 @@
+#define CONST_IDENT_MAX 30
+#define IO_IDENT_MAX 30
+#define ARGUMENT_MAX 30
+#define USER_LABEL_MAX 30
+
+#define EQUIV_INIT_NAME "equiv"
+
+#define write_nv_ident(fp,a) wr_nv_ident_help ((fp), (struct Addrblock *) (a))
+#define nv_type(x) nv_type_help ((struct Addrblock *) x)
+
+extern char *c_keywords[];
+
+char *new_io_ident (/* char * */);
+char *new_func_length (/* char * */);
+char *new_arg_length (/* Namep */);
+void declare_new_addr (/* struct Addrblock * */);
+char *nv_ident_help (/* struct Addrblock * */);
+int nv_type_help (/* struct Addrblock */);
+char *user_label (/* int */);
+char *temp_name (/* int, char */);
+char *c_type_decl (/* int, int */);
+char *equiv_name (/* int, char * */);

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

diff --git a/usr.bin/f2c/niceprintf.h b/usr.bin/f2c/niceprintf.h
new file mode 100644 (file)
index 0000000..24c65d4
--- /dev/null
+++ b/usr.bin/f2c/niceprintf.h
@@ -0,0 +1,16 @@
+/* niceprintf.h -- contains constants and macros from the output filter
+   for the generated C code.  We use macros for increased speed, less
+   function overhead.  */
+
+#define MAX_OUTPUT_SIZE 6000   /* Number of chars on one output line PLUS
+                                  the length of the longest string
+                                  printed using   nice_printf   */
+
+
+
+#define next_tab(fp) (indent += tab_size)
+
+#define prev_tab(fp) (indent -= tab_size)
+
+
+

diff --git a/usr.bin/f2c/notice b/usr.bin/f2c/notice
new file mode 100644 (file)
index 0000000..64af9f1
--- /dev/null
+++ b/usr.bin/f2c/notice
@@ -0,0 +1,23 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+

diff --git a/usr.bin/f2c/output.c b/usr.bin/f2c/output.c
new file mode 100644 (file)
index 0000000..6d5bdd4
--- /dev/null
+++ b/usr.bin/f2c/output.c
@@ -0,0 +1,1495 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "names.h"
+#include "output.h"
+
+#ifndef TRUE
+#define TRUE 1
+#endif
+#ifndef FALSE
+#define FALSE 0
+#endif
+
+char _assoc_table[] = { 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 };
+
+/* Opcode table -- This array is indexed by the OP_____ macros defined in
+   defines.h; these macros are expected to be adjacent integers, so that
+   this table is as small as possible. */
+
+table_entry opcode_table[] = {
+                               { 0, 0, NULL },
+       /* OPPLUS 1 */          { BINARY_OP, 12, "%l + %r" },
+       /* OPMINUS 2 */         { BINARY_OP, 12, "%l - %r" },
+       /* OPSTAR 3 */          { BINARY_OP, 13, "%l * %r" },
+       /* OPSLASH 4 */         { BINARY_OP, 13, "%l / %r" },
+       /* OPPOWER 5 */         { BINARY_OP,  0, "power (%l, %r)" },
+       /* OPNEG 6 */           { UNARY_OP,  14, "-%l" },
+       /* OPOR 7 */            { BINARY_OP,  4, "%l || %r" },
+       /* OPAND 8 */           { BINARY_OP,  5, "%l && %r" },
+       /* OPEQV 9 */           { BINARY_OP,  9, "%l == %r" },
+       /* OPNEQV 10 */         { BINARY_OP,  9, "%l != %r" },
+       /* OPNOT 11 */          { UNARY_OP,  14, "! %l" },
+       /* OPCONCAT 12 */       { BINARY_OP,  0, "concat (%l, %r)" },
+       /* OPLT 13 */           { BINARY_OP, 10, "%l < %r" },
+       /* OPEQ 14 */           { BINARY_OP,  9, "%l == %r" },
+       /* OPGT 15 */           { BINARY_OP, 10, "%l > %r" },
+       /* OPLE 16 */           { BINARY_OP, 10, "%l <= %r" },
+       /* OPNE 17 */           { BINARY_OP,  9, "%l != %r" },
+       /* OPGE 18 */           { BINARY_OP, 10, "%l >= %r" },
+       /* OPCALL 19 */         { BINARY_OP, 15, SPECIAL_FMT },
+       /* OPCCALL 20 */        { BINARY_OP, 15, SPECIAL_FMT },
+
+/* Left hand side of an assignment cannot have outermost parens */
+
+       /* OPASSIGN 21 */       { BINARY_OP,  2, "%l = %r" },
+       /* OPPLUSEQ 22 */       { BINARY_OP,  2, "%l += %r" },
+       /* OPSTAREQ 23 */       { BINARY_OP,  2, "%l *= %r" },
+       /* OPCONV 24 */         { BINARY_OP, 14, "%l" },
+       /* OPLSHIFT 25 */       { BINARY_OP, 11, "%l << %r" },
+       /* OPMOD 26 */          { BINARY_OP, 13, "%l %% %r" },
+       /* OPCOMMA 27 */        { BINARY_OP,  1, "%l, %r" },
+
+/* Don't want to nest the colon operator in parens */
+
+       /* OPQUEST 28 */        { BINARY_OP, 3, "%l ? %r" },
+       /* OPCOLON 29 */        { BINARY_OP, 3, "%l : %r" },
+       /* OPABS 30 */          { UNARY_OP,  0, "abs(%l)" },
+       /* OPMIN 31 */          { BINARY_OP,   0, SPECIAL_FMT },
+       /* OPMAX 32 */          { BINARY_OP,   0, SPECIAL_FMT },
+       /* OPADDR 33 */         { UNARY_OP, 14, "&%l" },
+
+       /* OPCOMMA_ARG 34 */    { BINARY_OP, 15, SPECIAL_FMT },
+       /* OPBITOR 35 */        { BINARY_OP,  6, "%l | %r" },
+       /* OPBITAND 36 */       { BINARY_OP,  8, "%l & %r" },
+       /* OPBITXOR 37 */       { BINARY_OP,  7, "%l ^ %r" },
+       /* OPBITNOT 38 */       { UNARY_OP,  14, "~ %l" },
+       /* OPRSHIFT 39 */       { BINARY_OP, 11, "%l >> %r" },
+
+/* This isn't quite right -- it doesn't handle arrays, for instance */
+
+       /* OPWHATSIN 40 */      { UNARY_OP,  14, "*%l" },
+       /* OPMINUSEQ 41 */      { BINARY_OP,  2, "%l -= %r" },
+       /* OPSLASHEQ 42 */      { BINARY_OP,  2, "%l /= %r" },
+       /* OPMODEQ 43 */        { BINARY_OP,  2, "%l %%= %r" },
+       /* OPLSHIFTEQ 44 */     { BINARY_OP,  2, "%l <<= %r" },
+       /* OPRSHIFTEQ 45 */     { BINARY_OP,  2, "%l >>= %r" },
+       /* OPBITANDEQ 46 */     { BINARY_OP,  2, "%l &= %r" },
+       /* OPBITXOREQ 47 */     { BINARY_OP,  2, "%l ^= %r" },
+       /* OPBITOREQ 48 */      { BINARY_OP,  2, "%l |= %r" },
+       /* OPPREINC 49 */       { UNARY_OP,  14, "++%l" },
+       /* OPPREDEC 50 */       { UNARY_OP,  14, "--%l" },
+       /* OPDOT 51 */          { BINARY_OP, 15, "%l.%r" },
+       /* OPARROW 52 */        { BINARY_OP, 15, "%l -> %r"},
+       /* OPNEG1 53 */         { UNARY_OP,  14, "-%l" },
+       /* OPDMIN 54 */         { BINARY_OP, 0, "dmin(%l,%r)" },
+       /* OPDMAX 55 */         { BINARY_OP, 0, "dmax(%l,%r)" },
+       /* OPASSIGNI 56 */      { BINARY_OP,  2, "%l = &%r" },
+       /* OPIDENTITY 57 */     { UNARY_OP, 15, "%l" },
+       /* OPCHARCAST 58 */     { UNARY_OP, 14, "(char *)&%l" },
+       /* OPDABS 59 */         { UNARY_OP, 0, "dabs(%l)" },
+       /* OPMIN2 60 */         { BINARY_OP,   0, "min(%l,%r)" },
+       /* OPMAX2 61 */         { BINARY_OP,   0, "max(%l,%r)" },
+
+/* kludge to imitate (under forcedouble) f77's bizarre treatement of OPNEG... */
+
+       /* OPNEG KLUDGE */      { UNARY_OP,  14, "-(doublereal)%l" }
+}; /* opcode_table */
+
+#define OPNEG_KLUDGE (sizeof(opcode_table)/sizeof(table_entry) - 1)
+
+static char opeqable[sizeof(opcode_table)/sizeof(table_entry)];
+
+
+static void output_prim ();
+static void output_unary (), output_binary (), output_arg_list ();
+static void output_list (), output_literal ();
+
+
+void expr_out (fp, e)
+FILE *fp;
+expptr e;
+{
+    if (e == (expptr) NULL)
+       return;
+
+    switch (e -> tag) {
+       case TNAME:     out_name (fp, (struct Nameblock *) e);
+                       return;
+
+       case TCONST:    out_const(fp, &e->constblock);
+                       goto end_out;
+       case TEXPR:
+                       break;
+
+       case TADDR:     out_addr (fp, &(e -> addrblock));
+                       goto end_out;
+
+       case TPRIM:     warn ("expr_out: got TPRIM");
+                       output_prim (fp, &(e -> primblock));
+                       return;
+
+       case TLIST:     output_list (fp, &(e -> listblock));
+ end_out:              frexpr(e);
+                       return;
+
+       case TIMPLDO:   err ("expr_out: got TIMPLDO");
+                       return;
+
+       case TERROR:
+       default:
+                       erri ("expr_out: bad tag '%d'", e -> tag);
+    } /* switch */
+
+/* Now we know that the tag is TEXPR */
+
+/* Optimize on simple expressions, such as "a = a + b" ==> "a += b" */
+
+    if (e -> exprblock.opcode == OPASSIGN && e -> exprblock.rightp &&
+       e -> exprblock.rightp -> tag == TEXPR) {
+       int opcode;
+
+       opcode = e -> exprblock.rightp -> exprblock.opcode;
+
+       if (opeqable[opcode]) {
+           expptr leftp, rightp;
+
+           if ((leftp = e -> exprblock.leftp) &&
+               (rightp = e -> exprblock.rightp -> exprblock.leftp)) {
+
+               if (same_ident (leftp, rightp)) {
+                   expptr temp = e -> exprblock.rightp;
+
+                   e -> exprblock.opcode = op_assign(opcode);
+
+                   e -> exprblock.rightp = temp -> exprblock.rightp;
+                   temp->exprblock.rightp = 0;
+                   frexpr(temp);
+               } /* if same_ident (leftp, rightp) */
+           } /* if leftp && rightp */
+       } /* if opcode == OPPLUS || */
+    } /* if e -> exprblock.opcode == OPASSIGN */
+
+
+/* Optimize on increment or decrement by 1 */
+
+    {
+       int opcode = e -> exprblock.opcode;
+       expptr leftp = e -> exprblock.leftp;
+       expptr rightp = e -> exprblock.rightp;
+
+       if (leftp && rightp && (leftp -> headblock.vstg == STGARG ||
+               ISINT (leftp -> headblock.vtype)) &&
+               (opcode == OPPLUSEQ || opcode == OPMINUSEQ) &&
+               ISINT (rightp -> headblock.vtype) &&
+               ISICON (e -> exprblock.rightp) &&
+               (ISONE (e -> exprblock.rightp) ||
+               e -> exprblock.rightp -> constblock.Const.ci == -1)) {
+
+/* Allow for the '-1' constant value */
+
+           if (!ISONE (e -> exprblock.rightp))
+               opcode = (opcode == OPPLUSEQ) ? OPMINUSEQ : OPPLUSEQ;
+
+/* replace the existing opcode */
+
+           if (opcode == OPPLUSEQ)
+               e -> exprblock.opcode = OPPREINC;
+           else
+               e -> exprblock.opcode = OPPREDEC;
+
+/* Free up storage used by the right hand side */
+
+           frexpr (e -> exprblock.rightp);
+           e->exprblock.rightp = 0;
+       } /* if opcode == OPPLUS */
+    } /* block */
+
+
+    if (is_unary_op (e -> exprblock.opcode))
+       output_unary (fp, &(e -> exprblock));
+    else if (is_binary_op (e -> exprblock.opcode))
+       output_binary (fp, &(e -> exprblock));
+    else
+       erri ("expr_out: bad opcode '%d'", (int) e -> exprblock.opcode);
+
+    free((char *)e);
+
+} /* expr_out */
+
+
+void out_and_free_statement (outfile, expr)
+FILE *outfile;
+expptr expr;
+{
+    if (expr)
+       expr_out (outfile, expr);
+
+    nice_printf (outfile, ";\n");
+} /* out_and_free_statement */
+
+
+
+int same_ident (left, right)
+expptr left, right;
+{
+    if (!left || !right)
+       return 0;
+
+    if (left -> tag == TNAME && right -> tag == TNAME && left == right)
+       return 1;
+
+    if (left -> tag == TADDR && right -> tag == TADDR &&
+           left -> addrblock.uname_tag == right -> addrblock.uname_tag)
+       switch (left -> addrblock.uname_tag) {
+           case UNAM_REF:
+           case UNAM_NAME:
+
+/* Check for array subscripts */
+
+               if (left -> addrblock.user.name -> vdim ||
+                       right -> addrblock.user.name -> vdim)
+                   if (left -> addrblock.user.name !=
+                           right -> addrblock.user.name ||
+                           !same_expr (left -> addrblock.memoffset,
+                           right -> addrblock.memoffset))
+                       return 0;
+
+               return same_ident ((expptr) (left -> addrblock.user.name),
+                       (expptr) right -> addrblock.user.name);
+           case UNAM_IDENT:
+               return strcmp(left->addrblock.user.ident,
+                               right->addrblock.user.ident) == 0;
+           case UNAM_CHARP:
+               return strcmp(left->addrblock.user.Charp,
+                               right->addrblock.user.Charp) == 0;
+           default:
+               return 0;
+       } /* switch */
+
+    if (left->tag == TEXPR && left->exprblock.opcode == OPWHATSIN
+       && right->tag == TEXPR && right->exprblock.opcode == OPWHATSIN)
+               return same_ident(left->exprblock.leftp,
+                                right->exprblock.leftp);
+
+    return 0;
+} /* same_ident */
+
+ static int
+samefpconst(c1, c2, n)
+ register Constp c1, c2;
+ register int n;
+{
+       char *s1, *s2;
+       if (!c1->vstg && !c2->vstg)
+               return c1->Const.cd[n] == c2->Const.cd[n];
+       s1 = c1->vstg ? c1->Const.cds[n] : dtos(c1->Const.cd[n]);
+       s2 = c2->vstg ? c2->Const.cds[n] : dtos(c2->Const.cd[n]);
+       return !strcmp(s1, s2);
+       }
+
+ static int
+sameconst(c1, c2)
+ register Constp c1, c2;
+{
+       switch(c1->vtype) {
+               case TYCOMPLEX:
+               case TYDCOMPLEX:
+                       if (!samefpconst(c1,c2,1))
+                               return 0;
+               case TYREAL:
+               case TYDREAL:
+                       return samefpconst(c1,c2,0);
+               case TYCHAR:
+                       return c1->Const.ccp1.blanks == c2->Const.ccp1.blanks
+                           &&     c1->vleng->constblock.Const.ci
+                               == c2->vleng->constblock.Const.ci
+                           && !memcmp(c1->Const.ccp, c2->Const.ccp,
+                                       (int)c1->vleng->constblock.Const.ci);
+               case TYSHORT:
+               case TYINT:
+               case TYLOGICAL:
+                       return c1->Const.ci == c2->Const.ci;
+               }
+       err("unexpected type in sameconst");
+       return 0;
+       }
+
+/* same_expr -- Returns true only if   e1 and e2   match.  This is
+   somewhat pessimistic, but can afford to be because it's just used to
+   optimize on the assignment operators (+=, -=, etc). */
+
+int same_expr (e1, e2)
+expptr e1, e2;
+{
+    if (!e1 || !e2)
+       return !e1 && !e2;
+
+    if (e1 -> tag != e2 -> tag || e1 -> headblock.vtype != e2 -> headblock.vtype)
+       return 0;
+
+    switch (e1 -> tag) {
+        case TEXPR:
+           if (e1 -> exprblock.opcode != e2 -> exprblock.opcode)
+               return 0;
+
+           return same_expr (e1 -> exprblock.leftp, e2 -> exprblock.leftp) &&
+                  same_expr (e1 -> exprblock.rightp, e2 -> exprblock.rightp);
+       case TNAME:
+       case TADDR:
+           return same_ident (e1, e2);
+       case TCONST:
+           return sameconst(&e1->constblock, &e2->constblock);
+       default:
+           return 0;
+    } /* switch */
+} /* same_expr */
+
+
+
+void out_name (fp, namep)
+ FILE *fp;
+ Namep namep;
+{
+    extern int usedefsforcommon;
+    Extsym *comm;
+
+    if (namep == NULL)
+       return;
+
+/* DON'T want to use oneof_stg() here; need to find the right common name
+   */
+
+    if (namep->vstg == STGCOMMON && !namep->vcommequiv && !usedefsforcommon) {
+       comm = &extsymtab[namep->vardesc.varno];
+       extern_out(fp, comm);
+       nice_printf(fp, "%d.", comm->curno);
+    } /* if namep -> vstg == STGCOMMON */
+
+    if (namep->vprocclass == PTHISPROC && namep->vtype != TYSUBR)
+       nice_printf(fp, xretslot[namep->vtype]->user.ident);
+    else
+       nice_printf (fp, "%s", namep->cvarname);
+} /* out_name */
+
+
+static char *Longfmt = "%ld";
+
+#define cpd(n) cp->vstg ? cp->Const.cds[n] : dtos(cp->Const.cd[n])
+
+void out_const(fp, cp)
+ FILE *fp;
+ register Constp cp;
+{
+    static char real_buf[50], imag_buf[50];
+    unsigned int k;
+    int type = cp->vtype;
+
+    switch (type) {
+       case TYINT1:
+        case TYSHORT:
+           nice_printf (fp, "%ld", cp->Const.ci);      /* don't cast ci! */
+           break;
+       case TYLONG:
+#ifdef TYQUAD
+       case TYQUAD:
+#endif
+           nice_printf (fp, Longfmt, cp->Const.ci);    /* don't cast ci! */
+           break;
+       case TYREAL:
+           nice_printf(fp, "%s", flconst(real_buf, cpd(0)));
+           break;
+       case TYDREAL:
+           nice_printf(fp, "%s", cpd(0));
+           break;
+       case TYCOMPLEX:
+           nice_printf(fp, cm_fmt_string, flconst(real_buf, cpd(0)),
+                       flconst(imag_buf, cpd(1)));
+           break;
+       case TYDCOMPLEX:
+           nice_printf(fp, dcm_fmt_string, cpd(0), cpd(1));
+           break;
+       case TYLOGICAL1:
+       case TYLOGICAL2:
+       case TYLOGICAL:
+           nice_printf (fp, "%s", cp->Const.ci ? "TRUE_" : "FALSE_");
+           break;
+       case TYCHAR: {
+           char *c = cp->Const.ccp, *ce;
+
+           if (c == NULL) {
+               nice_printf (fp, "\"\"");
+               break;
+           } /* if c == NULL */
+
+           nice_printf (fp, "\"");
+           ce = c + cp->vleng->constblock.Const.ci;
+           while(c < ce) {
+               k = *(unsigned char *)c++;
+               nice_printf(fp, str_fmt[k], k);
+               }
+           for(k = cp->Const.ccp1.blanks; k > 0; k--)
+               nice_printf(fp, " ");
+           nice_printf (fp, "\"");
+           break;
+       } /* case TYCHAR */
+       default:
+           erri ("out_const:  bad type '%d'", (int) type);
+           break;
+    } /* switch */
+
+} /* out_const */
+#undef cpd
+
+ static void
+out_args(fp, ep) FILE *fp; expptr ep;
+{
+       chainp arglist;
+
+       if(ep->tag != TLIST)
+               badtag("out_args", ep->tag);
+       for(arglist = ep->listblock.listp;;) {
+               expr_out(fp, (expptr)arglist->datap);
+               arglist->datap = 0;
+               if (!(arglist = arglist->nextp))
+                       break;
+               nice_printf(fp, ", ");
+               }
+       }
+
+
+/* out_addr -- this routine isn't local because it is called by the
+   system-generated identifier printing routines */
+
+void out_addr (fp, addrp)
+FILE *fp;
+struct Addrblock *addrp;
+{
+       extern Extsym *extsymtab;
+       int was_array = 0;
+       char *s;
+
+
+       if (addrp == NULL)
+               return;
+       if (doin_setbound
+                       && addrp->vstg == STGARG
+                       && addrp->vtype != TYCHAR
+                       && ISICON(addrp->memoffset)
+                       && !addrp->memoffset->constblock.Const.ci)
+               nice_printf(fp, "*");
+
+       switch (addrp -> uname_tag) {
+           case UNAM_REF:
+               nice_printf(fp, "%s_%s(", addrp->user.name->cvarname,
+                       addrp->cmplx_sub ? "subscr" : "ref");
+               out_args(fp, addrp->memoffset);
+               nice_printf(fp, ")");
+               return;
+           case UNAM_NAME:
+               out_name (fp, addrp -> user.name);
+               break;
+           case UNAM_IDENT:
+               if (*(s = addrp->user.ident) == ' ') {
+                       if (multitype)
+                               nice_printf(fp, "%s",
+                                       xretslot[addrp->vtype]->user.ident);
+                       else
+                               nice_printf(fp, "%s", s+1);
+                       }
+               else {
+                       nice_printf(fp, "%s", s);
+                       }
+               break;
+           case UNAM_CHARP:
+               nice_printf(fp, "%s", addrp->user.Charp);
+               break;
+           case UNAM_EXTERN:
+               extern_out (fp, &extsymtab[addrp -> memno]);
+               break;
+           case UNAM_CONST:
+               switch(addrp->vstg) {
+                       case STGCONST:
+                               out_const(fp, (Constp)addrp);
+                               break;
+                       case STGMEMNO:
+                               output_literal (fp, (int)addrp->memno,
+                                       (Constp)addrp);
+                               break;
+                       default:
+                       Fatal("unexpected vstg in out_addr");
+                       }
+               break;
+           case UNAM_UNKNOWN:
+           default:
+               nice_printf (fp, "Unknown Addrp");
+               break;
+       } /* switch */
+
+/* It's okay to just throw in the brackets here because they have a
+   precedence level of 15, the highest value.  */
+
+    if ((addrp->uname_tag == UNAM_NAME && addrp->user.name->vdim
+                       || addrp->ntempelt > 1 || addrp->isarray)
+       && addrp->vtype != TYCHAR) {
+       expptr offset;
+
+       was_array = 1;
+
+       offset = addrp -> memoffset;
+       addrp->memoffset = 0;
+       if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV))
+               && addrp -> uname_tag == UNAM_NAME
+               && !addrp->skip_offset)
+           offset = mkexpr (OPMINUS, offset, mkintcon (
+                   addrp -> user.name -> voffset));
+
+       nice_printf (fp, "[");
+
+       offset = mkexpr (OPSLASH, offset,
+               ICON (typesize[addrp -> vtype] * (addrp -> Field ? 2 : 1)));
+       expr_out (fp, offset);
+       nice_printf (fp, "]");
+       }
+
+/* Check for structure field reference */
+
+    if (addrp -> Field && addrp -> uname_tag != UNAM_CONST &&
+           addrp -> uname_tag != UNAM_UNKNOWN) {
+       if (oneof_stg((addrp -> uname_tag == UNAM_NAME ? addrp -> user.name :
+               (Namep) NULL), addrp -> vstg, M(STGARG)|M(STGEQUIV))
+               && !was_array && (addrp->vclass != CLPROC || !multitype))
+           nice_printf (fp, "->%s", addrp -> Field);
+       else
+           nice_printf (fp, ".%s", addrp -> Field);
+    } /* if */
+
+/* Check for character subscripting */
+
+    if (addrp->vtype == TYCHAR &&
+           (addrp->vclass != CLPROC || addrp->uname_tag == UNAM_NAME
+                       && addrp->user.name->vprocclass == PTHISPROC) &&
+           addrp -> memoffset &&
+           (addrp -> uname_tag != UNAM_NAME ||
+            addrp -> user.name -> vtype == TYCHAR) &&
+           (!ISICON (addrp -> memoffset) ||
+            (addrp -> memoffset -> constblock.Const.ci))) {
+
+       int use_paren = 0;
+       expptr e = addrp -> memoffset;
+
+       if (!e)
+               return;
+       addrp->memoffset = 0;
+
+       if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV))
+        && addrp -> uname_tag == UNAM_NAME) {
+           e = mkexpr (OPMINUS, e, mkintcon (addrp -> user.name -> voffset));
+
+/* mkexpr will simplify it to zero if possible */
+           if (e->tag == TCONST && e->constblock.Const.ci == 0)
+               return;
+       } /* if addrp -> vstg == STGCOMMON */
+
+/* In the worst case, parentheses might be needed OUTSIDE the expression,
+   too.  But since I think this subscripting can only appear as a
+   parameter in a procedure call, I don't think outside parens will ever
+   be needed.  INSIDE parens are handled below */
+
+       nice_printf (fp, " + ");
+       if (e -> tag == TEXPR) {
+           int arg_prec = op_precedence (e -> exprblock.opcode);
+           int prec = op_precedence (OPPLUS);
+           use_paren = arg_prec && (arg_prec < prec || (arg_prec == prec &&
+                   is_left_assoc (OPPLUS)));
+       } /* if e -> tag == TEXPR */
+       if (use_paren) nice_printf (fp, "(");
+       expr_out (fp, e);
+       if (use_paren) nice_printf (fp, ")");
+    } /* if */
+} /* out_addr */
+
+
+static void output_literal (fp, memno, cp)
+ FILE *fp;
+ int memno;
+ Constp cp;
+{
+    struct Literal *litp, *lastlit;
+    extern char *lit_name ();
+
+    lastlit = litpool + nliterals;
+
+    for (litp = litpool; litp < lastlit; litp++) {
+       if (litp -> litnum == memno)
+           break;
+    } /* for litp */
+
+    if (litp >= lastlit)
+       out_const (fp, cp);
+    else {
+       nice_printf (fp, "%s", lit_name (litp));
+       litp->lituse++;
+       }
+} /* output_literal */
+
+
+static void output_prim (fp, primp)
+FILE *fp;
+struct Primblock *primp;
+{
+    if (primp == NULL)
+       return;
+
+    out_name (fp, primp -> namep);
+    if (primp -> argsp)
+       output_arg_list (fp, primp -> argsp);
+
+    if (primp -> fcharp != (expptr) NULL || primp -> lcharp != (expptr) NULL)
+       nice_printf (fp, "Sorry, no substrings yet");
+}
+
+
+
+static void output_arg_list (fp, listp)
+FILE *fp;
+struct Listblock *listp;
+{
+    chainp arg_list;
+
+    if (listp == (struct Listblock *) NULL || listp -> listp == (chainp) NULL)
+       return;
+
+    nice_printf (fp, "(");
+
+    for (arg_list = listp -> listp; arg_list; arg_list = arg_list -> nextp) {
+       expr_out (fp, (expptr) arg_list -> datap);
+       if (arg_list -> nextp != (chainp) NULL)
+
+/* Might want to add a hook in here to accomodate the style setting which
+   wants spaces after commas */
+
+           nice_printf (fp, ",");
+    } /* for arg_list */
+
+    nice_printf (fp, ")");
+} /* output_arg_list */
+
+
+
+static void output_unary (fp, e)
+FILE *fp;
+struct Exprblock *e;
+{
+    if (e == NULL)
+       return;
+
+    switch (e -> opcode) {
+        case OPNEG:
+               if (e->vtype == TYREAL && forcedouble) {
+                       e->opcode = OPNEG_KLUDGE;
+                       output_binary(fp,e);
+                       e->opcode = OPNEG;
+                       break;
+                       }
+       case OPNEG1:
+       case OPNOT:
+       case OPABS:
+       case OPBITNOT:
+       case OPWHATSIN:
+       case OPPREINC:
+       case OPPREDEC:
+       case OPADDR:
+       case OPIDENTITY:
+       case OPCHARCAST:
+       case OPDABS:
+           output_binary (fp, e);
+           break;
+       case OPCALL:
+       case OPCCALL:
+           nice_printf (fp, "Sorry, no OPCALL yet");
+           break;
+       default:
+           erri ("output_unary: bad opcode", (int) e -> opcode);
+           break;
+    } /* switch */
+} /* output_unary */
+
+
+ static char *
+findconst(m)
+ register long m;
+{
+       register struct Literal *litp, *litpe;
+
+       litp = litpool;
+       for(litpe = litp + nliterals; litp < litpe; litp++)
+               if (litp->litnum ==  m)
+                       return litp->cds[0];
+       Fatal("findconst failure!");
+       return 0;
+       }
+
+ static int
+opconv_fudge(fp,e)
+ FILE *fp;
+ struct Exprblock *e;
+{
+       /* special handling for ichar and character*1 */
+       register expptr lp;
+       register union Expression *Offset;
+       register char *cp;
+       int lt;
+       char buf[8];
+       unsigned int k;
+       Namep np;
+
+       if (!(lp = e->leftp))   /* possible with erroneous Fortran */
+               return 1;
+       lt = lp->headblock.vtype;
+       if (lt == TYCHAR) {
+               switch(lp->tag) {
+                       case TNAME:
+                               nice_printf(fp, "*");
+                               out_name(fp, (Namep)lp);
+                               return 1;
+                       case TCONST:
+ tconst:
+                               cp = lp->constblock.Const.ccp;
+ tconst1:
+                               k = *(unsigned char *)cp;
+                               sprintf(buf, chr_fmt[k], k);
+                               nice_printf(fp, "'%s'", buf);
+                               return 1;
+                       case TADDR:
+                               switch(lp->addrblock.vstg) {
+                                   case STGMEMNO:
+                                       if (halign && e->vtype != TYCHAR) {
+                                               nice_printf(fp, "*(%s *)",
+                                                   c_type_decl(e->vtype,0));
+                                               expr_out(fp, lp);
+                                               return 1;
+                                               }
+                                       cp = findconst(lp->addrblock.memno);
+                                       goto tconst1;
+                                   case STGCONST:
+                                       goto tconst;
+                                   }
+                               lp->addrblock.vtype = tyint;
+                               Offset = lp->addrblock.memoffset;
+                               switch(lp->addrblock.uname_tag) {
+                                 case UNAM_REF:
+                                       nice_printf(fp, "*");
+                                       return 0;
+                                 case UNAM_NAME:
+                                       np = lp->addrblock.user.name;
+                                       if (ONEOF(np->vstg,
+                                           M(STGCOMMON)|M(STGEQUIV)))
+                                               Offset = mkexpr(OPMINUS, Offset,
+                                                       ICON(np->voffset));
+                                       }
+                               lp->addrblock.memoffset = Offset ?
+                                       mkexpr(OPSTAR, Offset,
+                                               ICON(typesize[tyint]))
+                                       : ICON(0);
+                               lp->addrblock.isarray = 1;
+                               /* STGCOMMON or STGEQUIV would cause */
+                               /* voffset to be added in a second time */
+                               lp->addrblock.vstg = STGUNKNOWN;
+                               break;
+                       default:
+                               badtag("opconv_fudge", lp->tag);
+                       }
+               }
+       if (lt != e->vtype)
+               nice_printf(fp, "(%s) ",
+                       c_type_decl(e->vtype, 0));
+       return 0;
+       }
+
+
+static void output_binary (fp, e)
+FILE *fp;
+struct Exprblock *e;
+{
+    char *format;
+    extern table_entry opcode_table[];
+    int prec;
+
+    if (e == NULL || e -> tag != TEXPR)
+       return;
+
+/* Instead of writing a huge switch, I've incorporated the output format
+   into a table.  Things like "%l" and "%r" stand for the left and
+   right subexpressions.  This should allow both prefix and infix
+   functions to be specified (e.g. "(%l * %r", "z_div (%l, %r").  Of
+   course, I should REALLY think out the ramifications of writing out
+   straight text, as opposed to some intermediate format, which could
+   figure out and optimize on the the number of required blanks (we don't
+   want "x - (-y)" to become "x --y", for example).  Special cases (such as
+   incomplete implementations) could still be implemented as part of the
+   switch, they will just have some dummy value instead of the string
+   pattern.  Another difficulty is the fact that the complex functions
+   will differ from the integer and real ones */
+
+/* Handle a special case.  We don't want to output "x + - 4", or "y - - 3"
+*/
+    if ((e -> opcode == OPPLUS || e -> opcode == OPMINUS) &&
+           e -> rightp && e -> rightp -> tag == TCONST &&
+           isnegative_const (&(e -> rightp -> constblock)) &&
+           is_negatable (&(e -> rightp -> constblock))) {
+
+       e -> opcode = (e -> opcode == OPPLUS) ? OPMINUS : OPPLUS;
+       negate_const (&(e -> rightp -> constblock));
+    } /* if e -> opcode == PLUS or MINUS */
+
+    prec = op_precedence (e -> opcode);
+    format = op_format (e -> opcode);
+
+    if (format != SPECIAL_FMT) {
+       while (*format) {
+           if (*format == '%') {
+               int arg_prec, use_paren = 0;
+               expptr lp, rp;
+
+               switch (*(format + 1)) {
+                   case 'l':
+                       lp = e->leftp;
+                       if (lp && lp->tag == TEXPR) {
+                           arg_prec = op_precedence(lp->exprblock.opcode);
+
+                           use_paren = arg_prec &&
+                               (arg_prec < prec || (arg_prec == prec &&
+                                   is_right_assoc (prec)));
+                       } /* if e -> leftp */
+                       if (e->opcode == OPCONV && opconv_fudge(fp,e))
+                               break;
+                       if (use_paren)
+                           nice_printf (fp, "(");
+                       expr_out(fp, lp);
+                       if (use_paren)
+                           nice_printf (fp, ")");
+                       break;
+                   case 'r':
+                       rp = e->rightp;
+                       if (rp && rp->tag == TEXPR) {
+                           arg_prec = op_precedence(rp->exprblock.opcode);
+
+                           use_paren = arg_prec &&
+                               (arg_prec < prec || (arg_prec == prec &&
+                                   is_left_assoc (prec)));
+                           use_paren = use_paren ||
+                               (rp->exprblock.opcode == OPNEG
+                               && prec >= op_precedence(OPMINUS));
+                       } /* if e -> rightp */
+                       if (use_paren)
+                           nice_printf (fp, "(");
+                       expr_out(fp, rp);
+                       if (use_paren)
+                           nice_printf (fp, ")");
+                       break;
+                   case '\0':
+                   case '%':
+                       nice_printf (fp, "%%");
+                       break;
+                   default:
+                       erri ("output_binary: format err: '%%%c' illegal",
+                               (int) *(format + 1));
+                       break;
+               } /* switch */
+               format += 2;
+           } else
+               nice_printf (fp, "%c", *format++);
+       } /* while *format */
+    } else {
+
+/* Handle Special cases of formatting */
+
+       switch (e -> opcode) {
+               case OPCCALL:
+               case OPCALL:
+                       out_call (fp, (int) e -> opcode, e -> vtype,
+                                       e -> vleng, e -> leftp, e -> rightp);
+                       break;
+
+               case OPCOMMA_ARG:
+                       doin_setbound = 1;
+                       nice_printf(fp, "(");
+                       expr_out(fp, e->leftp);
+                       nice_printf(fp, ", &");
+                       doin_setbound = 0;
+                       expr_out(fp, e->rightp);
+                       nice_printf(fp, ")");
+                       break;
+
+               case OPADDR:
+               default:
+                       nice_printf (fp, "Sorry, can't format OPCODE '%d'",
+                               e -> opcode);
+                       break;
+               }
+
+    } /* else */
+} /* output_binary */
+
+
+out_call (outfile, op, ftype, len, name, args)
+FILE *outfile;
+int op, ftype;
+expptr len, name, args;
+{
+    chainp arglist;            /* Pointer to any actual arguments */
+    chainp cp;                 /* Iterator over argument lists */
+    Addrp ret_val = (Addrp) NULL;
+                               /* Function return value buffer, if any is
+                                  required */
+    int byvalue;               /* True iff we're calling a C library
+                                  routine */
+    int done_once;             /* Used for writing commas to   outfile   */
+    int narg, t;
+    register expptr q;
+    long L;
+    Argtypes *at;
+    Atype *A, *Ac;
+    Namep np;
+    extern int forcereal;
+
+/* Don't use addresses if we're calling a C function */
+
+    byvalue = op == OPCCALL;
+
+    if (args)
+       arglist = args -> listblock.listp;
+    else
+       arglist = CHNULL;
+
+/* If this is a CHARACTER function, the first argument is the result */
+
+    if (ftype == TYCHAR)
+       if (ISICON (len)) {
+           ret_val = (Addrp) (arglist -> datap);
+           arglist = arglist -> nextp;
+       } else {
+           err ("adjustable character function");
+           return;
+       } /* else */
+
+/* If this is a COMPLEX function, the first argument is the result */
+
+    else if (ISCOMPLEX (ftype)) {
+       ret_val = (Addrp) (arglist -> datap);
+       arglist = arglist -> nextp;
+    } /* if ISCOMPLEX */
+
+/* Now we can actually start to write out the function invocation */
+
+    if (ftype == TYREAL && forcereal)
+       nice_printf(outfile, "(real)");
+    if (name -> tag == TEXPR && name -> exprblock.opcode == OPWHATSIN) {
+       nice_printf (outfile, "(");
+       np = (Namep)name->exprblock.leftp; /*expr_out will free name */
+       expr_out (outfile, name);
+       nice_printf (outfile, ")");
+       }
+    else {
+       np = (Namep)name;
+       expr_out(outfile, name);
+       }
+
+    /* prepare to cast procedure parameters -- set A if we know how */
+
+    A = Ac = 0;
+    if (np->tag == TNAME && (at = np->arginfo)) {
+       if (at->nargs > 0)
+               A = at->atypes;
+       if (Ansi && (at->defined || at->nargs > 0))
+               Ac = at->atypes;
+       }
+
+    nice_printf(outfile, "(");
+
+    if (ret_val) {
+       if (ISCOMPLEX (ftype))
+           nice_printf (outfile, "&");
+       expr_out (outfile, (expptr) ret_val);
+       if (Ac)
+               Ac++;
+
+/* The length of the result of a character function is the second argument */
+/* It should be in place from putcall(), so we won't touch it explicitly */
+
+    } /* if ret_val */
+    done_once = ret_val ? TRUE : FALSE;
+
+/* Now run through the named arguments */
+
+    narg = -1;
+    for (cp = arglist; cp; cp = cp -> nextp, done_once = TRUE) {
+
+       if (done_once)
+           nice_printf (outfile, ", ");
+       narg++;
+
+       if (!( q = (expptr)cp->datap) )
+               continue;
+
+       if (q->tag == TADDR) {
+               if (q->addrblock.vtype > TYERROR) {
+                       /* I/O block */
+                       nice_printf(outfile, "&%s", q->addrblock.user.ident);
+                       continue;
+                       }
+               if (!byvalue && q->addrblock.isarray
+               && q->addrblock.vtype != TYCHAR
+               && q->addrblock.memoffset->tag == TCONST) {
+
+                       /* check for 0 offset -- after */
+                       /* correcting for equivalence. */
+                       L = q->addrblock.memoffset->constblock.Const.ci;
+                       if (ONEOF(q->addrblock.vstg, M(STGCOMMON)|M(STGEQUIV))
+                                       && q->addrblock.uname_tag == UNAM_NAME)
+                               L -= q->addrblock.user.name->voffset;
+                       if (L)
+                               goto skip_deref;
+
+                       if (Ac && narg < at->dnargs
+                        && q->headblock.vtype != (t = Ac[narg].type)
+                        && t > TYADDR && t < TYSUBR)
+                               nice_printf(outfile, "(%s*)", typename[t]);
+
+                       /* &x[0] == x */
+                       /* This also prevents &sizeof(doublereal)[0] */
+
+                       switch(q->addrblock.uname_tag) {
+                           case UNAM_NAME:
+                               out_name(outfile, q->addrblock.user.name);
+                               continue;
+                           case UNAM_IDENT:
+                               nice_printf(outfile, "%s",
+                                       q->addrblock.user.ident);
+                               continue;
+                           case UNAM_CHARP:
+                               nice_printf(outfile, "%s",
+                                       q->addrblock.user.Charp);
+                               continue;
+                           case UNAM_EXTERN:
+                               extern_out(outfile,
+                                       &extsymtab[q->addrblock.memno]);
+                               continue;
+                           }
+                       }
+               }
+
+/* Skip over the dereferencing operator generated only for the
+   intermediate file */
+ skip_deref:
+       if (q -> tag == TEXPR && q -> exprblock.opcode == OPWHATSIN)
+           q = q -> exprblock.leftp;
+
+       if (q->headblock.vclass == CLPROC) {
+           if (Castargs && (q->tag != TNAME
+                               || q->nameblock.vprocclass != PTHISPROC)
+                        && (q->tag != TADDR
+                               || q->addrblock.uname_tag != UNAM_NAME
+                               || q->addrblock.user.name->vprocclass
+                                                               != PTHISPROC))
+               {
+               if (A && (t = A[narg].type) >= 200)
+                       t %= 100;
+               else {
+                       t = q->headblock.vtype;
+                       if (q->tag == TNAME && q->nameblock.vimpltype)
+                               t = TYUNKNOWN;
+                       }
+               nice_printf(outfile, "(%s)", usedcasts[t] = casttypes[t]);
+               }
+           }
+       else if (Ac && narg < at->dnargs
+               && q->headblock.vtype != (t = Ac[narg].type)
+               && t > TYADDR && t < TYSUBR)
+               nice_printf(outfile, "(%s*)", typename[t]);
+
+       if ((q -> tag == TADDR || q-> tag == TNAME) &&
+               (byvalue || q -> headblock.vstg != STGREG)) {
+           if (q -> headblock.vtype != TYCHAR)
+             if (byvalue) {
+
+               if (q -> tag == TADDR &&
+                       q -> addrblock.uname_tag == UNAM_NAME &&
+                       ! q -> addrblock.user.name -> vdim &&
+                       oneof_stg(q -> addrblock.user.name, q -> addrblock.vstg,
+                                       M(STGARG)|M(STGEQUIV)) &&
+                       ! ISCOMPLEX(q->addrblock.user.name->vtype))
+                   nice_printf (outfile, "*");
+               else if (q -> tag == TNAME
+                       && oneof_stg(&q->nameblock, q -> nameblock.vstg,
+                               M(STGARG)|M(STGEQUIV))
+                       && !(q -> nameblock.vdim))
+                   nice_printf (outfile, "*");
+
+             } else {
+               expptr memoffset;
+
+               if (q->tag == TADDR &&
+                       !ONEOF (q -> addrblock.vstg, M(STGEXT)|M(STGLENG))
+                       && (
+                       ONEOF(q->addrblock.vstg,
+                               M(STGCOMMON)|M(STGEQUIV)|M(STGMEMNO))
+                       || ((memoffset = q->addrblock.memoffset)
+                               && (!ISICON(memoffset)
+                               || memoffset->constblock.Const.ci)))
+                       || ONEOF(q->addrblock.vstg,
+                                       M(STGINIT)|M(STGAUTO)|M(STGBSS))
+                               && !q->addrblock.isarray)
+                   nice_printf (outfile, "&");
+               else if (q -> tag == TNAME
+                       && !oneof_stg(&q->nameblock, q -> nameblock.vstg,
+                               M(STGARG)|M(STGEXT)|M(STGEQUIV)))
+                   nice_printf (outfile, "&");
+           } /* else */
+
+           expr_out (outfile, q);
+       } /* if q -> tag == TADDR || q -> tag == TNAME */
+
+/* Might be a Constant expression, e.g. string length, character constants */
+
+       else if (q -> tag == TCONST) {
+           if (tyioint == TYLONG)
+               Longfmt = "%ldL";
+           out_const(outfile, &q->constblock);
+           Longfmt = "%ld";
+           }
+
+/* Must be some other kind of expression, or register var, or constant.
+   In particular, this is likely to be a temporary variable assignment
+   which was generated in p1put_call */
+
+       else if (!ISCOMPLEX (q -> headblock.vtype) && !ISCHAR (q)){
+           int use_paren = q -> tag == TEXPR &&
+                   op_precedence (q -> exprblock.opcode) <=
+                   op_precedence (OPCOMMA);
+
+           if (use_paren) nice_printf (outfile, "(");
+           expr_out (outfile, q);
+           if (use_paren) nice_printf (outfile, ")");
+       } /* if !ISCOMPLEX */
+       else
+           err ("out_call:  unknown parameter");
+
+    } /* for (cp = arglist */
+
+    if (arglist)
+       frchain (&arglist);
+
+    nice_printf (outfile, ")");
+
+} /* out_call */
+
+
+ char *
+flconst(buf, x)
+ char *buf, *x;
+{
+       sprintf(buf, fl_fmt_string, x);
+       return buf;
+       }
+
+ char *
+dtos(x)
+ double x;
+{
+       static char buf[64];
+       sprintf(buf, db_fmt_string, x);
+       return buf;
+       }
+
+char tr_tab[Table_size];
+
+/* out_init -- Initialize the data structures used by the routines in
+   output.c.  These structures include the output format to be used for
+   Float, Double, Complex, and Double Complex constants. */
+
+void out_init ()
+{
+    extern int tab_size;
+    register char *s;
+
+    s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_+-.";
+    while(*s)
+       tr_tab[*s++] = 3;
+    tr_tab['>'] = 1;
+
+       opeqable[OPPLUS] = 1;
+       opeqable[OPMINUS] = 1;
+       opeqable[OPSTAR] = 1;
+       opeqable[OPSLASH] = 1;
+       opeqable[OPMOD] = 1;
+       opeqable[OPLSHIFT] = 1;
+       opeqable[OPBITAND] = 1;
+       opeqable[OPBITXOR] = 1;
+       opeqable[OPBITOR ] = 1;
+
+
+/* Set the output format for both types of floating point constants */
+
+    if (fl_fmt_string == NULL || *fl_fmt_string == '\0')
+       fl_fmt_string = Ansi == 1 ? "%sf" : "(float)%s";
+
+    if (db_fmt_string == NULL || *db_fmt_string == '\0')
+       db_fmt_string = "%.17g";
+
+/* Set the output format for both types of complex constants.  They will
+   have string parameters rather than float or double so that the decimal
+   point may be added to the strings generated by the {db,fl}_fmt_string
+   formats above */
+
+    if (cm_fmt_string == NULL || *cm_fmt_string == '\0') {
+       cm_fmt_string = "{%s,%s}";
+    } /* if cm_fmt_string == NULL */
+
+    if (dcm_fmt_string == NULL || *dcm_fmt_string == '\0') {
+       dcm_fmt_string = "{%s,%s}";
+    } /* if dcm_fmt_string == NULL */
+
+    tab_size = 4;
+} /* out_init */
+
+
+void extern_out (fp, extsym)
+FILE *fp;
+Extsym *extsym;
+{
+    if (extsym == (Extsym *) NULL)
+       return;
+
+    nice_printf (fp, "%s", extsym->cextname);
+
+} /* extern_out */
+
+
+
+static void output_list (fp, listp)
+FILE *fp;
+struct Listblock *listp;
+{
+    int did_one = 0;
+    chainp elts;
+
+    nice_printf (fp, "(");
+    if (listp)
+       for (elts = listp -> listp; elts; elts = elts -> nextp) {
+           if (elts -> datap) {
+               if (did_one)
+                   nice_printf (fp, ", ");
+               expr_out (fp, (expptr) elts -> datap);
+               did_one = 1;
+           } /* if elts -> datap */
+       } /* for elts */
+    nice_printf (fp, ")");
+} /* output_list */
+
+
+void out_asgoto (outfile, expr)
+FILE *outfile;
+expptr expr;
+{
+    char *user_label();
+    chainp value;
+    Namep namep;
+    int k;
+
+    if (expr == (expptr) NULL) {
+       err ("out_asgoto:  NULL variable expr");
+       return;
+    } /* if expr */
+
+    nice_printf (outfile, Ansi ? "switch (" : "switch ((int)"); /*)*/
+    expr_out (outfile, expr);
+    nice_printf (outfile, ") {\n");
+    next_tab (outfile);
+
+/* The initial addrp value will be stored as a namep pointer */
+
+    switch(expr->tag) {
+       case TNAME:
+               /* local variable */
+               namep = &expr->nameblock;
+               break;
+       case TEXPR:
+               if (expr->exprblock.opcode == OPWHATSIN
+                && expr->exprblock.leftp->tag == TNAME)
+                       /* argument */
+                       namep = &expr->exprblock.leftp->nameblock;
+               else
+                       goto bad;
+               break;
+       case TADDR:
+               if (expr->addrblock.uname_tag == UNAM_NAME) {
+                       /* initialized local variable */
+                       namep = expr->addrblock.user.name;
+                       break;
+                       }
+       default:
+ bad:
+               err("out_asgoto:  bad expr");
+               return;
+       }
+
+    for(k = 0, value = namep -> varxptr.assigned_values; value;
+           value = value->nextp, k++) {
+       nice_printf (outfile, "case %d: goto %s;\n", k,
+               user_label((long)value->datap));
+    } /* for value */
+    prev_tab (outfile);
+
+    nice_printf (outfile, "}\n");
+} /* out_asgoto */
+
+void out_if (outfile, expr)
+FILE *outfile;
+expptr expr;
+{
+    nice_printf (outfile, "if (");
+    expr_out (outfile, expr);
+    nice_printf (outfile, ") {\n");
+    next_tab (outfile);
+} /* out_if */
+
+ static void
+output_rbrace(outfile, s)
+ FILE *outfile;
+ char *s;
+{
+       extern int last_was_label;
+       register char *fmt;
+
+       if (last_was_label) {
+               last_was_label = 0;
+               fmt = ";%s";
+               }
+       else
+               fmt = "%s";
+       nice_printf(outfile, fmt, s);
+       }
+
+void out_else (outfile)
+FILE *outfile;
+{
+    prev_tab (outfile);
+    output_rbrace(outfile, "} else {\n");
+    next_tab (outfile);
+} /* out_else */
+
+void elif_out (outfile, expr)
+FILE *outfile;
+expptr expr;
+{
+    prev_tab (outfile);
+    output_rbrace(outfile, "} else ");
+    out_if (outfile, expr);
+} /* elif_out */
+
+void endif_out (outfile)
+FILE *outfile;
+{
+    prev_tab (outfile);
+    output_rbrace(outfile, "}\n");
+} /* endif_out */
+
+void end_else_out (outfile)
+FILE *outfile;
+{
+    prev_tab (outfile);
+    output_rbrace(outfile, "}\n");
+} /* end_else_out */
+
+
+
+void compgoto_out (outfile, index, labels)
+FILE *outfile;
+expptr index, labels;
+{
+    char *s1, *s2;
+
+    if (index == ENULL)
+       err ("compgoto_out:  null index for computed goto");
+    else if (labels && labels -> tag != TLIST)
+       erri ("compgoto_out:  expected label list, got tag '%d'",
+               labels -> tag);
+    else {
+       extern char *user_label ();
+       chainp elts;
+       int i = 1;
+
+       s2 = /*(*/ ") {\n"; /*}*/
+       if (Ansi)
+               s1 = "switch ("; /*)*/
+       else if (index->tag == TNAME || index->tag == TEXPR
+                               && index->exprblock.opcode == OPWHATSIN)
+               s1 = "switch ((int)"; /*)*/
+       else {
+               s1 = "switch ((int)(";
+               s2 = ")) {\n"; /*}*/
+               }
+       nice_printf(outfile, s1);
+       expr_out (outfile, index);
+       nice_printf (outfile, s2);
+       next_tab (outfile);
+
+       for (elts = labels -> listblock.listp; elts; elts = elts -> nextp, i++) {
+           if (elts -> datap) {
+               if (ISICON(((expptr) (elts -> datap))))
+                   nice_printf (outfile, "case %d:  goto %s;\n", i,
+                       user_label(((expptr)(elts->datap))->constblock.Const.ci));
+               else
+                   err ("compgoto_out:  bad label in label list");
+           } /* if (elts -> datap) */
+       } /* for elts */
+       prev_tab (outfile);
+       nice_printf (outfile, /*{*/ "}\n");
+    } /* else */
+} /* compgoto_out */
+
+
+void out_for (outfile, init, test, inc)
+FILE *outfile;
+expptr init, test, inc;
+{
+    nice_printf (outfile, "for (");
+    expr_out (outfile, init);
+    nice_printf (outfile, "; ");
+    expr_out (outfile, test);
+    nice_printf (outfile, "; ");
+    expr_out (outfile, inc);
+    nice_printf (outfile, ") {\n");
+    next_tab (outfile);
+} /* out_for */
+
+
+void out_end_for (outfile)
+FILE *outfile;
+{
+    prev_tab (outfile);
+    nice_printf (outfile, "}\n");
+} /* out_end_for */

diff --git a/usr.bin/f2c/output.h b/usr.bin/f2c/output.h
new file mode 100644 (file)
index 0000000..2bc21da
--- /dev/null
+++ b/usr.bin/f2c/output.h
@@ -0,0 +1,65 @@
+/* nice_printf -- same arguments as fprintf.
+
+       All output which is to become C code must be directed through this
+   function.  For now, no buffering is done.  Later on, every line of
+   output will be filtered to accomodate the style definitions (e.g. one
+   statement per line, spaces between function names and argument lists,
+   etc.)
+*/
+#include "niceprintf.h"
+
+extern int nice_printf ();
+
+
+/* Definitions for the opcode table.  The table is indexed by the macros
+   which are #defined in   defines.h   */
+
+#define UNARY_OP 01
+#define BINARY_OP 02
+
+#define SPECIAL_FMT NULL
+
+#define is_unary_op(x) (opcode_table[x].type == UNARY_OP)
+#define is_binary_op(x) (opcode_table[x].type == BINARY_OP)
+#define op_precedence(x) (opcode_table[x].prec)
+#define op_format(x) (opcode_table[x].format)
+
+/* _assoc_table -- encodes left-associativity and right-associativity
+   information; indexed by precedence level.  Only 2, 3, 14 are
+   right-associative.  Source:  Kernighan & Ritchie, p. 49 */
+
+extern char _assoc_table[];
+
+#define is_right_assoc(x) (_assoc_table [x])
+#define is_left_assoc(x) (! _assoc_table [x])
+
+
+typedef struct {
+    int type;                  /* UNARY_OP or BINARY_OP */
+    int prec;                  /* Precedence level, useful for adjusting
+                                  number of parens to insert.  Zero is a
+                                  special level, and 2, 3, 14 are
+                                  right-associative */
+    char *format;
+} table_entry;
+
+
+extern char *fl_fmt_string;    /* Float constant format string */
+extern char *db_fmt_string;    /* Double constant format string */
+extern char *cm_fmt_string;    /* Complex constant format string */
+extern char *dcm_fmt_string;   /* Double Complex constant format string */
+
+extern int indent;             /* Number of spaces to indent; this is a
+                                  temporary fix */
+extern int tab_size;           /* Number of spaces in each tab */
+extern int in_string;
+
+extern table_entry opcode_table[];
+
+
+void expr_out (), out_init (), out_addr (), out_const ();
+void out_name (), extern_out (), out_asgoto ();
+void out_if (), out_else (), elif_out ();
+void endif_out (), end_else_out ();
+void compgoto_out (), out_for ();
+void out_end_for (), out_and_free_statement ();

diff --git a/usr.bin/f2c/p1defs.h b/usr.bin/f2c/p1defs.h
new file mode 100644 (file)
index 0000000..16bda0e
--- /dev/null
+++ b/usr.bin/f2c/p1defs.h
@@ -0,0 +1,160 @@
+#define P1_UNKNOWN 0
+#define P1_COMMENT 1           /* Fortan comment string */
+#define P1_EOF 2               /* End of file dummy token */
+#define P1_SET_LINE 3          /* Reset the line counter */
+#define P1_FILENAME 4          /* Name of current input file */
+#define P1_NAME_POINTER 5      /* Pointer to hash table entry */
+#define P1_CONST 6             /* Some constant value */
+#define P1_EXPR 7              /* Followed by opcode */
+
+/* The next two tokens could be grouped together, since they always come
+   from an Addr structure */
+
+#define P1_IDENT 8             /* Char string identifier in addrp->user
+                                  field */
+#define P1_EXTERN 9            /* Pointer to external symbol entry */
+
+#define P1_HEAD 10             /* Function header info */
+#define P1_LIST 11             /* A list of data (e.g. arguments) will
+                                  follow the tag, type, and count */
+#define P1_LITERAL 12          /* Hold the index into the literal pool */
+#define P1_LABEL 13            /* label value */
+#define P1_ASGOTO 14           /* Store the hash table pointer of
+                                  variable used in assigned goto */
+#define P1_GOTO 15             /* Store the statement number */
+#define P1_IF 16               /* store the condition as an expression */
+#define P1_ELSE 17             /* No data */
+#define P1_ELIF 18             /* store the condition as an expression */
+#define P1_ENDIF 19            /* Marks the end of a block IF */
+#define P1_ENDELSE 20          /* Marks the end of a block ELSE */
+#define P1_ADDR 21             /* Addr data; used for arrays, common and
+                                  equiv addressing, NOT for names, idents
+                                  or externs */
+#define P1_SUBR_RET 22         /* Subroutine return; the return expression
+                                  follows */
+#define P1_COMP_GOTO 23                /* Computed goto; has expr, label list */
+#define P1_FOR 24              /* C FOR loop; three expressions follow */
+#define P1_ENDFOR 25           /* End of C FOR loop */
+#define P1_FORTRAN 26          /* original Fortran source */
+#define P1_CHARP 27            /* user.Charp field -- for long names */
+#define P1_WHILE1START 28      /* start of DO WHILE */
+#define P1_WHILE2START 29      /* rest of DO WHILE */
+#define P1_PROCODE 30          /* invoke procode() -- to adjust params */
+#define P1_ELSEIFSTART 31      /* handle extra code for abs, min, max
+                                  in else if() */
+
+#define P1_FILENAME_MAX        256     /* max filename length to retain (for -g) */
+#define P1_STMTBUFSIZE 1400
+
+
+
+#define COMMENT_BUFFER_SIZE 255        /* max number of chars in each comment */
+#define CONSTANT_STR_MAX 1000  /* max number of chars in string constant */
+
+extern void p1put (/* int */);
+extern void p1_comment (/* char * */);
+extern void p1_label (/* int */);
+extern void p1_line_number (/* int */);
+extern void p1put_filename();
+extern void p1_expr (/* expptr */);
+extern void p1_head (/* int, char * */);
+extern void p1_if (/* expptr */);
+extern void p1_else ();
+extern void p1_elif (/* expptr */);
+extern void p1_endif ();
+extern void p1else_end ();
+extern void p1_subr_ret (/* expptr */);
+extern void p1_goto(/* long */);
+extern void p1comp_goto (/* expptr, int, struct Labelblock *[] */);
+extern void p1_for (/* expptr, expptr, expptr */);
+extern void p1for_end ();
+
+
+extern void p1puts (/* int, char * */);
+
+/* The pass 1 intermediate file has the following format:
+
+       <ascii-integer-rep> [ : [ <sp> [ <data> ]]] \n
+
+   e.g.   1: This is a comment
+
+   This format is destined to change in the future, but for now a readable
+   form is more desirable than a compact form.
+
+   NOTES ABOUT THE P1 FORMAT
+   ----------------------------------------------------------------------
+
+       P1_COMMENT:  The comment string (in   <data>)   may be at most
+               COMMENT_BUFFER_SIZE bytes long.  It must contain no newlines
+               or null characters.  A side effect of the way comments are
+               read in   lex.c   is that no '\377' chars may be in a
+               comment either.
+
+       P1_SET_LINE:  <data>  holds the line number in the current source file.
+
+       P1_INC_LINE:  Increment the source line number;   <data>   is empty.
+
+       P1_NAME_POINTER:  <data>   holds the integer representation of a
+                         pointer into a hash table entry.
+
+       P1_CONST:  the first field in   <data>   is a type tag (one of the
+                  TYxxxx   macros), the next field holds the constant
+                  value
+
+       P1_EXPR:  <data>   holds the opcode number of the expression,
+                 followed by the type of the expression (required for
+                 OPCONV).  Next is the value of   vleng.
+                 The type of operation represented by the
+                 opcode determines how many of the following data items
+                 are part of this expression.
+
+       P1_IDENT:  <data>   holds the type, then storage, then the
+                  char string identifier in the   addrp->user   field.
+
+       P1_EXTERN:  <data>   holds an offset into the external symbol
+                   table entry
+
+       P1_HEAD:  the first field in   <data>  is the procedure class, the
+                 second is the name of the procedure
+
+       P1_LIST:  the first field in   <data>   is the tag, the second the
+                 type of the list, the third the number of elements in
+                 the list
+
+       P1_LITERAL:  <data>   holds the   litnum   of a value in the
+                    literal pool.
+
+       P1_LABEL:  <data>   holds the statement number of the current
+                  line
+
+       P1_ASGOTO:  <data>   holds the hash table pointer of the variable
+
+       P1_GOTO:  <data>   holds the statement number to jump to
+
+       P1_IF:  <data>   is empty, the following expression is the IF
+               condition.
+
+       P1_ELSE:  <data>   is empty.
+
+       P1_ELIF:  <data>   is empty, the following expression is the IF
+                 condition.
+
+       P1_ENDIF:  <data>   is empty.
+
+       P1_ENDELSE:  <data>   is empty.
+
+       P1_ADDR:   <data>   holds a direct copy of the structure.  The
+                 next expression is a copy of    vleng,   and the next a
+                 copy of    memoffset.
+
+       P1_SUBR_RET:  The next token is an expression for the return value.
+
+       P1_COMP_GOTO:  The next token is an integer expression, the
+                      following one a list of labels.
+
+       P1_FOR:  The next three expressions are the Init, Test, and
+                Increment expressions of a C FOR loop.
+
+       P1_ENDFOR:  Marks the end of the body of a FOR loop
+
+*/

diff --git a/usr.bin/f2c/p1output.c b/usr.bin/f2c/p1output.c
new file mode 100644 (file)
index 0000000..d4419b5
--- /dev/null
+++ b/usr.bin/f2c/p1output.c
@@ -0,0 +1,567 @@
+/****************************************************************
+Copyright 1990, 1991, 1993 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "p1defs.h"
+#include "output.h"
+#include "names.h"
+
+
+static void p1_addr(), p1_big_addr(), p1_binary(), p1_const(), p1_list(),
+       p1_literal(), p1_name(), p1_unary(), p1putn();
+static void p1putd (/* int, int */);
+static void p1putds (/* int, int, char * */);
+static void p1putdds (/* int, int, int, char * */);
+static void p1putdd (/* int, int, int */);
+static void p1putddd (/* int, int, int, int */);
+
+
+/* p1_comment -- save the text of a Fortran comment in the intermediate
+   file.  Make sure that there are no spurious "/ *" or "* /" characters by
+   mapping them onto "/+" and "+/".   str   is assumed to hold no newlines and be
+   null terminated; it may be modified by this function. */
+
+void p1_comment (str)
+char *str;
+{
+    register unsigned char *pointer, *ustr;
+
+    if (!str)
+       return;
+
+/* Get rid of any open or close comment combinations that may be in the
+   Fortran input */
+
+       ustr = (unsigned char *)str;
+       for(pointer = ustr; *pointer; pointer++)
+               if (*pointer == '*' && (pointer[1] == '/'
+                                       || pointer > ustr && pointer[-1] == '/'))
+                       *pointer = '+';
+       /* trim trailing white space */
+#ifdef isascii
+       while(--pointer >= ustr && (!isascii(*pointer) || isspace(*pointer)));
+#else
+       while(--pointer >= ustr && isspace(*pointer));
+#endif
+       pointer[1] = 0;
+       p1puts (P1_COMMENT, str);
+} /* p1_comment */
+
+/* p1_name -- Writes the address of a hash table entry into the
+   intermediate file */
+
+static void p1_name (namep)
+Namep namep;
+{
+       p1putd (P1_NAME_POINTER, (long) namep);
+       namep->visused = 1;
+} /* p1_name */
+
+
+
+void p1_expr (expr)
+expptr expr;
+{
+/* An opcode of 0 means a null entry */
+
+    if (expr == ENULL) {
+       p1putdd (P1_EXPR, 0, TYUNKNOWN);        /* Should this be TYERROR? */
+       return;
+    } /* if (expr == ENULL) */
+
+    switch (expr -> tag) {
+        case TNAME:
+               p1_name ((Namep) expr);
+               return;
+       case TCONST:
+               p1_const(&expr->constblock);
+               return;
+       case TEXPR:
+               /* Fall through the switch */
+               break;
+       case TADDR:
+               p1_addr (&(expr -> addrblock));
+               goto freeup;
+       case TPRIM:
+               warn ("p1_expr:  got TPRIM");
+               return;
+       case TLIST:
+               p1_list (&(expr->listblock));
+               frchain( &(expr->listblock.listp) );
+               return;
+       case TERROR:
+               return;
+       default:
+               erri ("p1_expr: bad tag '%d'", (int) (expr -> tag));
+               return;
+       }
+
+/* Now we know that the tag is TEXPR */
+
+    if (is_unary_op (expr -> exprblock.opcode))
+       p1_unary (&(expr -> exprblock));
+    else if (is_binary_op (expr -> exprblock.opcode))
+       p1_binary (&(expr -> exprblock));
+    else
+       erri ("p1_expr:  bad opcode '%d'", (int) expr -> exprblock.opcode);
+ freeup:
+    free((char *)expr);
+
+} /* p1_expr */
+
+
+
+static void p1_const(cp)
+ register Constp cp;
+{
+       int type = cp->vtype;
+       expptr vleng = cp->vleng;
+       union Constant *c = &cp->Const;
+       char cdsbuf0[64], cdsbuf1[64];
+       char *cds0, *cds1;
+
+    switch (type) {
+       case TYINT1:
+        case TYSHORT:
+       case TYLONG:
+#ifdef TYQUAD
+       case TYQUAD:
+#endif
+       case TYLOGICAL:
+       case TYLOGICAL1:
+       case TYLOGICAL2:
+           fprintf(pass1_file, "%d: %d %ld\n", P1_CONST, type, c->ci);
+           break;
+       case TYREAL:
+       case TYDREAL:
+               fprintf(pass1_file, "%d: %d %s\n", P1_CONST, type,
+                       cp->vstg ? c->cds[0] : cds(dtos(c->cd[0]), cdsbuf0));
+           break;
+       case TYCOMPLEX:
+       case TYDCOMPLEX:
+               if (cp->vstg) {
+                       cds0 = c->cds[0];
+                       cds1 = c->cds[1];
+                       }
+               else {
+                       cds0 = cds(dtos(c->cd[0]), cdsbuf0);
+                       cds1 = cds(dtos(c->cd[1]), cdsbuf1);
+                       }
+               fprintf(pass1_file, "%d: %d %s %s\n", P1_CONST, type,
+                       cds0, cds1);
+           break;
+       case TYCHAR:
+           if (vleng && !ISICON (vleng))
+               erri("p1_const:  bad vleng '%d'\n", (int) vleng);
+           else
+               fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type,
+                       cpexpr((expptr)cp));
+           break;
+       default:
+           erri ("p1_const:  bad constant type '%d'", type);
+           break;
+    } /* switch */
+} /* p1_const */
+
+
+void p1_asgoto (addrp)
+Addrp addrp;
+{
+    p1put (P1_ASGOTO);
+    p1_addr (addrp);
+} /* p1_asgoto */
+
+
+void p1_goto (stateno)
+ftnint stateno;
+{
+    p1putd (P1_GOTO, stateno);
+} /* p1_goto */
+
+
+static void p1_addr (addrp)
+ register struct Addrblock *addrp;
+{
+    int stg;
+
+    if (addrp == (struct Addrblock *) NULL)
+       return;
+
+    stg = addrp -> vstg;
+
+    if (ONEOF(stg, M(STGINIT)|M(STGREG))
+       || ONEOF(stg, M(STGCOMMON)|M(STGEQUIV)) &&
+               (!ISICON(addrp->memoffset)
+               || (addrp->uname_tag == UNAM_NAME
+                       ? addrp->memoffset->constblock.Const.ci
+                               != addrp->user.name->voffset
+                       : addrp->memoffset->constblock.Const.ci))
+       || ONEOF(stg, M(STGBSS)|M(STGINIT)|M(STGAUTO)|M(STGARG)) &&
+               (!ISICON(addrp->memoffset)
+                       || addrp->memoffset->constblock.Const.ci)
+       || addrp->Field || addrp->isarray || addrp->vstg == STGLENG)
+       {
+               p1_big_addr (addrp);
+               return;
+       }
+
+/* Write out a level of indirection for non-array arguments, which have
+   addrp -> memoffset   set and are handled by   p1_big_addr().
+   Lengths are passed by value, so don't check STGLENG
+   28-Jun-89 (dmg)  Added the check for != TYCHAR
+ */
+
+    if (oneof_stg ( addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : NULL,
+           stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) {
+       p1putdd (P1_EXPR, OPWHATSIN, addrp -> vtype);
+       p1_expr (ENULL);        /* Put dummy   vleng   */
+    } /* if stg == STGARG */
+
+    switch (addrp -> uname_tag) {
+        case UNAM_NAME:
+           p1_name (addrp -> user.name);
+           break;
+       case UNAM_IDENT:
+           p1putdds(P1_IDENT, addrp->vtype, addrp->vstg,
+                               addrp->user.ident);
+           break;
+       case UNAM_CHARP:
+               p1putdds(P1_CHARP, addrp->vtype, addrp->vstg,
+                               addrp->user.Charp);
+               break;
+       case UNAM_EXTERN:
+           p1putd (P1_EXTERN, (long) addrp -> memno);
+           if (addrp->vclass == CLPROC)
+               extsymtab[addrp->memno].extype = addrp->vtype;
+           break;
+       case UNAM_CONST:
+           if (addrp -> memno != BAD_MEMNO)
+               p1_literal (addrp -> memno);
+           else
+               p1_const((struct Constblock *)addrp);
+           break;
+       case UNAM_UNKNOWN:
+       default:
+           erri ("p1_addr:  unknown uname_tag '%d'", addrp -> uname_tag);
+           break;
+    } /* switch */
+} /* p1_addr */
+
+
+static void p1_list (listp)
+struct Listblock *listp;
+{
+    chainp lis;
+    int count = 0;
+
+    if (listp == (struct Listblock *) NULL)
+       return;
+
+/* Count the number of parameters in the list */
+
+    for (lis = listp -> listp; lis; lis = lis -> nextp)
+       count++;
+
+    p1putddd (P1_LIST, listp -> tag, listp -> vtype, count);
+
+    for (lis = listp -> listp; lis; lis = lis -> nextp)
+       p1_expr ((expptr) lis -> datap);
+
+} /* p1_list */
+
+
+void p1_label (lab)
+long lab;
+{
+       if (parstate < INDATA)
+               earlylabs = mkchain((char *)lab, earlylabs);
+       else
+               p1putd (P1_LABEL, lab);
+       }
+
+
+
+static void p1_literal (memno)
+long memno;
+{
+    p1putd (P1_LITERAL, memno);
+} /* p1_literal */
+
+
+void p1_if (expr)
+expptr expr;
+{
+    p1put (P1_IF);
+    p1_expr (expr);
+} /* p1_if */
+
+
+
+
+void p1_elif (expr)
+expptr expr;
+{
+    p1put (P1_ELIF);
+    p1_expr (expr);
+} /* p1_elif */
+
+
+
+
+void p1_else ()
+{
+    p1put (P1_ELSE);
+} /* p1_else */
+
+
+
+
+void p1_endif ()
+{
+    p1put (P1_ENDIF);
+} /* p1_endif */
+
+
+
+
+void p1else_end ()
+{
+    p1put (P1_ENDELSE);
+} /* p1else_end */
+
+
+static void p1_big_addr (addrp)
+Addrp addrp;
+{
+    if (addrp == (Addrp) NULL)
+       return;
+
+    p1putn (P1_ADDR, (int)sizeof(struct Addrblock), (char *) addrp);
+    p1_expr (addrp -> vleng);
+    p1_expr (addrp -> memoffset);
+    if (addrp->uname_tag == UNAM_NAME)
+       addrp->user.name->visused = 1;
+} /* p1_big_addr */
+
+
+
+static void p1_unary (e)
+struct Exprblock *e;
+{
+    if (e == (struct Exprblock *) NULL)
+       return;
+
+    p1putdd (P1_EXPR, (int) e -> opcode, e -> vtype);
+    p1_expr (e -> vleng);
+
+    switch (e -> opcode) {
+        case OPNEG:
+       case OPNEG1:
+       case OPNOT:
+       case OPABS:
+       case OPBITNOT:
+       case OPPREINC:
+       case OPPREDEC:
+       case OPADDR:
+       case OPIDENTITY:
+       case OPCHARCAST:
+       case OPDABS:
+           p1_expr(e -> leftp);
+           break;
+       default:
+           erri ("p1_unary: bad opcode '%d'", (int) e -> opcode);
+           break;
+    } /* switch */
+
+} /* p1_unary */
+
+
+static void p1_binary (e)
+struct Exprblock *e;
+{
+    if (e == (struct Exprblock *) NULL)
+       return;
+
+    p1putdd (P1_EXPR, e -> opcode, e -> vtype);
+    p1_expr (e -> vleng);
+    p1_expr (e -> leftp);
+    p1_expr (e -> rightp);
+} /* p1_binary */
+
+
+void p1_head (class, name)
+int class;
+char *name;
+{
+    p1putds (P1_HEAD, class, name ? name : "");
+} /* p1_head */
+
+
+void p1_subr_ret (retexp)
+expptr retexp;
+{
+
+    p1put (P1_SUBR_RET);
+    p1_expr (cpexpr(retexp));
+} /* p1_subr_ret */
+
+
+
+void p1comp_goto (index, count, labels)
+expptr index;
+int count;
+struct Labelblock *labels[];
+{
+    struct Constblock c;
+    int i;
+    register struct Labelblock *L;
+
+    p1put (P1_COMP_GOTO);
+    p1_expr (index);
+
+/* Write out a P1_LIST directly, to avoid the overhead of allocating a
+   list before it's needed HACK HACK HACK */
+
+    p1putddd (P1_LIST, TLIST, TYUNKNOWN, count);
+    c.vtype = TYLONG;
+    c.vleng = 0;
+
+    for (i = 0; i < count; i++) {
+       L = labels[i];
+       L->labused = 1;
+       c.Const.ci = L->stateno;
+       p1_const(&c);
+    } /* for i = 0 */
+} /* p1comp_goto */
+
+
+
+void p1_for (init, test, inc)
+expptr init, test, inc;
+{
+    p1put (P1_FOR);
+    p1_expr (init);
+    p1_expr (test);
+    p1_expr (inc);
+} /* p1_for */
+
+
+void p1for_end ()
+{
+    p1put (P1_ENDFOR);
+} /* p1for_end */
+
+
+
+
+/* ----------------------------------------------------------------------
+   The intermediate file actually gets written ONLY by the routines below.
+   To change the format of the file, you need only change these routines.
+   ----------------------------------------------------------------------
+*/
+
+
+/* p1puts -- Put a typed string into the Pass 1 intermediate file.  Assumes that
+   str   contains no newlines and is null-terminated. */
+
+void p1puts (type, str)
+int type;
+char *str;
+{
+    fprintf (pass1_file, "%d: %s\n", type, str);
+} /* p1puts */
+
+
+/* p1putd -- Put a typed integer into the Pass 1 intermediate file. */
+
+static void p1putd (type, value)
+int type;
+long value;
+{
+    fprintf (pass1_file, "%d: %ld\n", type, value);
+} /* p1_putd */
+
+
+/* p1putdd -- Put a typed pair of integers into the intermediate file. */
+
+static void p1putdd (type, v1, v2)
+int type, v1, v2;
+{
+    fprintf (pass1_file, "%d: %d %d\n", type, v1, v2);
+} /* p1putdd */
+
+
+/* p1putddd -- Put a typed triple of integers into the intermediate file. */
+
+static void p1putddd (type, v1, v2, v3)
+int type, v1, v2, v3;
+{
+    fprintf (pass1_file, "%d: %d %d %d\n", type, v1, v2, v3);
+} /* p1putddd */
+
+ union dL {
+       double d;
+       long L[2];
+       };
+
+static void p1putn (type, count, str)
+int type, count;
+char *str;
+{
+    int i;
+
+    fprintf (pass1_file, "%d: ", type);
+
+    for (i = 0; i < count; i++)
+       putc (str[i], pass1_file);
+
+    putc ('\n', pass1_file);
+} /* p1putn */
+
+
+
+/* p1put -- Put a type marker into the intermediate file. */
+
+void p1put(type)
+int type;
+{
+    fprintf (pass1_file, "%d:\n", type);
+} /* p1put */
+
+
+
+static void p1putds (type, i, str)
+int type;
+int i;
+char *str;
+{
+    fprintf (pass1_file, "%d: %d %s\n", type, i, str);
+} /* p1putds */
+
+
+static void p1putdds (token, type, stg, str)
+int token, type, stg;
+char *str;
+{
+    fprintf (pass1_file, "%d: %d %d %s\n", token, type, stg, str);
+} /* p1putdds */

diff --git a/usr.bin/f2c/parse.h b/usr.bin/f2c/parse.h
new file mode 100644 (file)
index 0000000..1eb2c54
--- /dev/null
+++ b/usr.bin/f2c/parse.h
@@ -0,0 +1,39 @@
+#ifndef PARSE_INCLUDE
+#define PARSE_INCLUDE
+
+/* macros for the   parse_args   routine */
+
+#define P_STRING 1             /* Macros for the result_type attribute */
+#define P_CHAR 2
+#define P_SHORT 3
+#define P_INT 4
+#define P_LONG 5
+#define P_FILE 6
+#define P_OLD_FILE 7
+#define P_NEW_FILE 8
+#define P_FLOAT 9
+#define P_DOUBLE 10
+
+#define P_CASE_INSENSITIVE 01  /* Macros for the   flags   attribute */
+#define P_REQUIRED_PREFIX 02
+
+#define P_NO_ARGS 0            /* Macros for the   arg_count   attribute */
+#define P_ONE_ARG 1
+#define P_INFINITE_ARGS 2
+
+#define p_entry(pref,swit,flag,count,type,store,size) \
+    { (pref), (swit), (flag), (count), (type), (int *) (store), (size) }
+
+typedef struct {
+    char *prefix;
+    char *string;
+    int flags;
+    int count;
+    int result_type;
+    int *result_ptr;
+    int table_size;
+} arg_info;
+
+extern int parse_args ();
+
+#endif

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

diff --git a/usr.bin/f2c/pccdefs.h b/usr.bin/f2c/pccdefs.h
new file mode 100644 (file)
index 0000000..bde8117
--- /dev/null
+++ b/usr.bin/f2c/pccdefs.h
@@ -0,0 +1,64 @@
+/* The following numbers are strange, and implementation-dependent */
+
+#define P2BAD -1
+#define P2NAME 2
+#define P2ICON 4               /* Integer constant */
+#define P2PLUS 6
+#define P2PLUSEQ 7
+#define P2MINUS 8
+#define P2NEG 10
+#define P2STAR 11
+#define P2STAREQ 12
+#define P2INDIRECT 13
+#define P2BITAND 14
+#define P2BITOR 17
+#define P2BITXOR 19
+#define P2QUEST 21
+#define P2COLON 22
+#define P2ANDAND 23
+#define P2OROR 24
+#define P2GOTO 37
+#define P2LISTOP 56
+#define P2ASSIGN 58
+#define P2COMOP 59
+#define P2SLASH 60
+#define P2MOD 62
+#define P2LSHIFT 64
+#define P2RSHIFT 66
+#define P2CALL 70
+#define P2CALL0 72
+
+#define P2NOT 76
+#define P2BITNOT 77
+#define P2EQ 80
+#define P2NE 81
+#define P2LE 82
+#define P2LT 83
+#define P2GE 84
+#define P2GT 85
+#define P2REG 94
+#define P2OREG 95
+#define P2CONV 104
+#define P2FORCE 108
+#define P2CBRANCH 109
+
+/* special operators included only for fortran's use */
+
+#define P2PASS 200
+#define P2STMT 201
+#define P2SWITCH 202
+#define P2LBRACKET 203
+#define P2RBRACKET 204
+#define P2EOF 205
+#define P2ARIF 206
+#define P2LABEL 207
+
+#define P2SHORT 3
+#define P2INT 4
+#define P2LONG 4
+
+#define P2CHAR 2
+#define P2REAL 6
+#define P2DREAL 7
+#define P2PTR 020
+#define P2FUNCT 040

diff --git a/usr.bin/f2c/permission b/usr.bin/f2c/permission
new file mode 100644 (file)
index 0000000..20d431e
--- /dev/null
+++ b/usr.bin/f2c/permission
@@ -0,0 +1,41 @@
+From ches Tue Mar  6 09:06:22 EST 1990
+It think it probably is.  I am told the line is 89% utilized.  But the throughpu
+t
+is shared, so I wouldn't worry about it.
+>From ehg Tue Mar  6 08:16 EST 1990
+Received: by coma; Tue Mar  6 08:17:21 1990
+From: pyxis!ehg
+Date: Tue, 6 Mar 90 08:16 EST
+To: coma!ches
+
+Thanks.  Is it reasonable for people to ask for the 600KB f2c source over
+uunet's dedicated line?    I'm just trying to find out if there's a problem
+before there's a disaster.
+>From ches Tue Mar  6 07:16:18 EST 1990
+Inet has no dialers.  All its calls go through the internet.  The mcsun addresse
+s
+were uunet.uu.net!mcsun!..., which will travel to uunet via Internet and
+then across the ocean on uunet's dedicated line.
+/****************************************************************
+Copyright 1990 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+

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

diff --git a/usr.bin/f2c/proc.c b/usr.bin/f2c/proc.c
new file mode 100644 (file)
index 0000000..ca3043e
--- /dev/null
+++ b/usr.bin/f2c/proc.c
@@ -0,0 +1,1602 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "names.h"
+#include "output.h"
+#include "p1defs.h"
+
+#define EXNULL (union Expression *)0
+
+LOCAL dobss(), docomleng(), docommon(), doentry(),
+       epicode(), nextarg(), retval();
+
+static char Blank[] = BLANKCOMMON;
+
+ static char *postfix[] = { "g", "h", "i",
+#ifdef TYQUAD
+                                       "j",
+#endif
+                                       "r", "d", "c", "z", "g", "h", "i" };
+
+ chainp new_procs;
+ int prev_proc, proc_argchanges, proc_protochanges;
+
+ void
+changedtype(q)
+ Namep q;
+{
+       char buf[200];
+       int qtype, type1;
+       register Extsym *e;
+       Argtypes *at;
+
+       if (q->vtypewarned)
+               return;
+       q->vtypewarned = 1;
+       qtype = q->vtype;
+       e = &extsymtab[q->vardesc.varno];
+       if (!(at = e->arginfo)) {
+               if (!e->exused)
+                       return;
+               }
+       else if (at->changes & 2 && qtype != TYUNKNOWN && !at->defined)
+               proc_protochanges++;
+       type1 = e->extype;
+       if (type1 == TYUNKNOWN)
+               return;
+       if (qtype == TYUNKNOWN)
+               /* e.g.,
+                       subroutine foo
+                       end
+                       external foo
+                       call goo(foo)
+                       end
+               */
+               return;
+       sprintf(buf, "%.90s: inconsistent declarations:\n\
+       here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype],
+               qtype == TYSUBR ? "" : " function",
+               ftn_types[type1], type1 == TYSUBR ? "" : " function");
+       warn(buf);
+       }
+
+ void
+unamstring(q, s)
+ register Addrp q;
+ register char *s;
+{
+       register int k;
+       register char *t;
+
+       k = strlen(s);
+       if (k < IDENT_LEN) {
+               q->uname_tag = UNAM_IDENT;
+               t = q->user.ident;
+               }
+       else {
+               q->uname_tag = UNAM_CHARP;
+               q->user.Charp = t = mem(k+1, 0);
+               }
+       strcpy(t, s);
+       }
+
+ static void
+fix_entry_returns()    /* for multiple entry points */
+{
+       Addrp a;
+       int i;
+       struct Entrypoint *e;
+       Namep np;
+
+       e = entries = (struct Entrypoint *)revchain((chainp)entries);
+       allargs = revchain(allargs);
+       if (!multitype)
+               return;
+
+       /* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */
+
+       for(i = TYINT1; i <= TYLOGICAL; i++)
+               if (a = xretslot[i])
+                       sprintf(a->user.ident, "(*ret_val).%s",
+                               postfix[i-TYINT1]);
+
+       do {
+               np = e->enamep;
+               switch(np->vtype) {
+                       case TYINT1:
+                       case TYSHORT:
+                       case TYLONG:
+#ifdef TYQUAD
+                       case TYQUAD:
+#endif
+                       case TYREAL:
+                       case TYDREAL:
+                       case TYCOMPLEX:
+                       case TYDCOMPLEX:
+                       case TYLOGICAL1:
+                       case TYLOGICAL2:
+                       case TYLOGICAL:
+                               np->vstg = STGARG;
+                       }
+               }
+               while(e = e->entnextp);
+       }
+
+ static void
+putentries(outfile)    /* put out wrappers for multiple entries */
+ FILE *outfile;
+{
+       char base[IDENT_LEN];
+       struct Entrypoint *e;
+       Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
+       chainp args, lengths, length_comp();
+       void listargs(), list_arg_types();
+       int i, k, mt, nL, type;
+       extern char *dfltarg[], **dfltproc;
+
+       e = entries;
+       if (!e->enamep) /* only possible with erroneous input */
+               return;
+       nL = (nallargs + nallchargs) * sizeof(Namep *);
+       A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **));
+       Ae = A + nallargs;
+       Alp = (Namep **)(Ae1 = Ae + nallchargs);
+       i = k = 0;
+       for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) {
+               np = (Namep)args->datap;
+               if (np->vtype == TYCHAR && np->vclass != CLPROC)
+                       *a1 = &Ae[i++];
+               }
+
+       mt = multitype;
+       multitype = 0;
+       sprintf(base, "%s0_", e->enamep->cvarname);
+       do {
+               np = e->enamep;
+               lengths = length_comp(e, 0);
+               proctype = type = np->vtype;
+               if (protofile)
+                       protowrite(protofile, type, np->cvarname, e, lengths);
+               nice_printf(outfile, "\n%s ", c_type_decl(type, 1));
+               nice_printf(outfile, "%s", np->cvarname);
+               if (!Ansi) {
+                       listargs(outfile, e, 0, lengths);
+                       nice_printf(outfile, "\n");
+                       }
+               list_arg_types(outfile, e, lengths, 0, "\n");
+               nice_printf(outfile, "{\n");
+               frchain(&lengths);
+               next_tab(outfile);
+               if (mt)
+                       nice_printf(outfile,
+                               "Multitype ret_val;\n%s(%d, &ret_val",
+                               base, k); /*)*/
+               else if (ISCOMPLEX(type))
+                       nice_printf(outfile, "%s(%d,%s", base, k,
+                               xretslot[type]->user.ident); /*)*/
+               else if (type == TYCHAR)
+                       nice_printf(outfile,
+                               "%s(%d, ret_val, ret_val_len", base, k); /*)*/
+               else
+                       nice_printf(outfile, "return %s(%d", base, k); /*)*/
+               k++;
+               memset((char *)A, 0, nL);
+               for(args = e->arglist; args; args = args->nextp) {
+                       np = (Namep)args->datap;
+                       A[np->argno] = np;
+                       if (np->vtype == TYCHAR && np->vclass != CLPROC)
+                               *Alp[np->argno] = np;
+                       }
+               args = allargs;
+               for(a = A; a < Ae; a++, args = args->nextp)
+                       nice_printf(outfile, ", %s", (np = *a)
+                               ? np->cvarname
+                               : ((Namep)args->datap)->vclass == CLPROC
+                               ? dfltproc[((Namep)args->datap)->vtype]
+                               : dfltarg[((Namep)args->datap)->vtype]);
+               for(; a < Ae1; a++)
+                       if (np = *a)
+                               nice_printf(outfile, ", %s_len", np->fvarname);
+                       else
+                               nice_printf(outfile, ", (ftnint)0");
+               nice_printf(outfile, /*(*/ ");\n");
+               if (mt) {
+                       if (type == TYCOMPLEX)
+                               nice_printf(outfile,
+                   "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\n");
+                       else if (type == TYDCOMPLEX)
+                               nice_printf(outfile,
+                   "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\n");
+                       else if (type <= TYLOGICAL)
+                               nice_printf(outfile, "return ret_val.%s;\n",
+                                       postfix[type-TYINT1]);
+                       }
+               nice_printf(outfile, "}\n");
+               prev_tab(outfile);
+               }
+               while(e = e->entnextp);
+       free((char *)A);
+       }
+
+ static void
+entry_goto(outfile)
+ FILEP outfile;
+{
+       struct Entrypoint *e = entries;
+       int k = 0;
+
+       nice_printf(outfile, "switch(n__) {\n");
+       next_tab(outfile);
+       while(e = e->entnextp)
+               nice_printf(outfile, "case %d: goto %s;\n", ++k,
+                       user_label((long)(extsymtab - e->entryname - 1)));
+       nice_printf(outfile, "}\n\n");
+       prev_tab(outfile);
+       }
+
+/* start a new procedure */
+
+newproc()
+{
+       if(parstate != OUTSIDE)
+       {
+               execerr("missing end statement", CNULL);
+               endproc();
+       }
+
+       parstate = INSIDE;
+       procclass = CLMAIN;     /* default */
+}
+
+ static void
+zap_changes()
+{
+       register chainp cp;
+       register Argtypes *at;
+
+       /* arrange to get correct count of prototypes that would
+          change by running f2c again */
+
+       if (prev_proc && proc_argchanges)
+               proc_protochanges++;
+       prev_proc = proc_argchanges = 0;
+       for(cp = new_procs; cp; cp = cp->nextp)
+               if (at = ((Namep)cp->datap)->arginfo)
+                       at->changes &= ~1;
+       frchain(&new_procs);
+       }
+
+/* end of procedure. generate variables, epilogs, and prologs */
+
+endproc()
+{
+       struct Labelblock *lp;
+       Extsym *ext;
+
+       if(parstate < INDATA)
+               enddcl();
+       if(ctlstack >= ctls)
+               err("DO loop or BLOCK IF not closed");
+       for(lp = labeltab ; lp < labtabend ; ++lp)
+               if(lp->stateno!=0 && lp->labdefined==NO)
+                       errstr("missing statement label %s",
+                               convic(lp->stateno) );
+
+/* Save copies of the common variables in extptr -> allextp */
+
+       for (ext = extsymtab; ext < nextext; ext++)
+               if (ext -> extstg == STGCOMMON && ext -> extp) {
+                       extern int usedefsforcommon;
+
+/* Write out the abbreviations for common block reference */
+
+                       copy_data (ext -> extp);
+                       if (usedefsforcommon) {
+                               wr_abbrevs (c_file, 1, ext -> extp);
+                               ext -> used_here = 1;
+                               }
+                       else
+                               ext -> extp = CHNULL;
+
+                       }
+
+       if (nentry > 1)
+               fix_entry_returns();
+       epicode();
+       donmlist();
+       dobss();
+       start_formatting ();
+       if (nentry > 1)
+               putentries(c_file);
+
+       zap_changes();
+       procinit();     /* clean up for next procedure */
+}
+
+
+
+/* End of declaration section of procedure.  Allocate storage. */
+
+enddcl()
+{
+       register struct Entrypoint *ep;
+       struct Entrypoint *ep0;
+       extern void freetemps();
+       chainp cp;
+       extern char *err_proc;
+       static char comblks[] = "common blocks";
+
+       err_proc = comblks;
+       docommon();
+
+/* Now the hash table entries for fields of common blocks have STGCOMMON,
+   vdcldone, voffset, and varno.  And the common blocks themselves have
+   their full sizes in extleng. */
+
+       err_proc = "equivalences";
+       doequiv();
+
+       err_proc = comblks;
+       docomleng();
+
+/* This implies that entry points in the declarations are buffered in
+   entries   but not written out */
+
+       err_proc = "entries";
+       if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
+               /* entries could be 0 in case of an error */
+               do doentry(ep);
+                       while(ep = ep->entnextp);
+               entries = (struct Entrypoint *)revchain((chainp)ep0);
+               }
+
+       err_proc = 0;
+       parstate = INEXEC;
+       p1put(P1_PROCODE);
+       freetemps();
+       if (earlylabs) {
+               for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
+                       p1_label((long)cp->datap);
+               frchain(&earlylabs);
+               }
+       p1_line_number(lineno); /* for files that start with a MAIN program */
+                               /* that starts with an executable statement */
+}
+
+/* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
+
+/* Main program or Block data */
+
+startproc(progname, class)
+Extsym * progname;
+int class;
+{
+       register struct Entrypoint *p;
+
+       p = ALLOC(Entrypoint);
+       if(class == CLMAIN) {
+               puthead(CNULL, CLMAIN);
+               if (progname)
+                   strcpy (main_alias, progname->cextname);
+       } else
+               puthead(CNULL, CLBLOCK);
+       if(class == CLMAIN)
+               newentry( mkname(" MAIN"), 0 )->extinit = 1;
+       p->entryname = progname;
+       entries = p;
+
+       procclass = class;
+       fprintf(diagfile, "   %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
+       if(progname) {
+               fprintf(diagfile, " %s", progname->fextname);
+               procname = progname->cextname;
+               }
+       fprintf(diagfile, ":\n");
+       fflush(diagfile);
+}
+
+/* subroutine or function statement */
+
+Extsym *newentry(v, substmsg)
+ register Namep v;
+ int substmsg;
+{
+       register Extsym *p;
+       char buf[128], badname[64];
+       static int nbad = 0;
+       static char already[] = "external name already used";
+
+       p = mkext(v->fvarname, addunder(v->cvarname));
+
+       if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
+       {
+               sprintf(badname, "%s_bad%d", v->fvarname, ++nbad);
+               if (substmsg) {
+                       sprintf(buf,"%s\n\tsubstituting \"%s\"",
+                               already, badname);
+                       dclerr(buf, v);
+                       }
+               else
+                       dclerr(already, v);
+               p = mkext(v->fvarname, badname);
+       }
+       v->vstg = STGAUTO;
+       v->vprocclass = PTHISPROC;
+       v->vclass = CLPROC;
+       if (p->extstg == STGEXT)
+               prev_proc = 1;
+       else
+               p->extstg = STGEXT;
+       p->extinit = YES;
+       v->vardesc.varno = p - extsymtab;
+       return(p);
+}
+
+
+entrypt(class, type, length, entry, args)
+int class, type;
+ftnint length;
+Extsym *entry;
+chainp args;
+{
+       register Namep q;
+       register struct Entrypoint *p;
+
+       if(class != CLENTRY)
+               puthead( procname = entry->cextname, class);
+       else
+               fprintf(diagfile, "       entry ");
+       fprintf(diagfile, "   %s:\n", entry->fextname);
+       fflush(diagfile);
+       q = mkname(entry->fextname);
+       if (type == TYSUBR)
+               q->vstg = STGEXT;
+
+       type = lengtype(type, length);
+       if(class == CLPROC)
+       {
+               procclass = CLPROC;
+               proctype = type;
+               procleng = type == TYCHAR ? length : 0;
+       }
+
+       p = ALLOC(Entrypoint);
+
+       p->entnextp = entries;
+       entries = p;
+
+       p->entryname = entry;
+       p->arglist = revchain(args);
+       p->enamep = q;
+
+       if(class == CLENTRY)
+       {
+               class = CLPROC;
+               if(proctype == TYSUBR)
+                       type = TYSUBR;
+       }
+
+       q->vclass = class;
+       q->vprocclass = 0;
+       settype(q, type, length);
+       q->vprocclass = PTHISPROC;
+       /* hold all initial entry points till end of declarations */
+       if(parstate >= INDATA)
+               doentry(p);
+}
+
+/* generate epilogs */
+
+/* epicode -- write out the proper function return mechanism at the end of
+   the procedure declaration.  Handles multiple return value types, as
+   well as cooercion into the proper value */
+
+LOCAL epicode()
+{
+       extern int lastwasbranch;
+
+       if(procclass==CLPROC)
+       {
+               if(proctype==TYSUBR)
+               {
+
+/* Return a zero only when the alternate return mechanism has been
+   specified in the function header */
+
+                       if ((substars || Ansi) && lastwasbranch != YES)
+                           p1_subr_ret (ICON(0));
+               }
+               else if (!multitype && lastwasbranch != YES)
+                       retval(proctype);
+       }
+       else if (procclass == CLMAIN && Ansi && lastwasbranch != YES)
+               p1_subr_ret (ICON(0));
+       lastwasbranch = NO;
+}
+
+
+/* generate code to return value of type  t */
+
+LOCAL retval(t)
+register int t;
+{
+       register Addrp p;
+
+       switch(t)
+       {
+       case TYCHAR:
+       case TYCOMPLEX:
+       case TYDCOMPLEX:
+               break;
+
+       case TYLOGICAL:
+               t = tylogical;
+       case TYINT1:
+       case TYADDR:
+       case TYSHORT:
+       case TYLONG:
+#ifdef TYQUAD
+       case TYQUAD:
+#endif
+       case TYREAL:
+       case TYDREAL:
+       case TYLOGICAL1:
+       case TYLOGICAL2:
+               p = (Addrp) cpexpr((expptr)retslot);
+               p->vtype = t;
+               p1_subr_ret (mkconv (t, fixtype((expptr)p)));
+               break;
+
+       default:
+               badtype("retval", t);
+       }
+}
+
+
+/* Do parameter adjustments */
+
+procode(outfile)
+FILE *outfile;
+{
+       prolog(outfile, allargs);
+
+       if (nentry > 1)
+               entry_goto(outfile);
+       }
+
+/* Finish bound computations now that all variables are declared.
+ * This used to be in setbound(), but under -u the following incurred
+ * an erroneous error message:
+ *     subroutine foo(x,n)
+ *     real x(n)
+ *     integer n
+ */
+
+ static void
+dim_finish(v)
+ Namep v;
+{
+       register struct Dimblock *p;
+       register expptr q;
+       register int i, nd;
+       extern expptr make_int_expr();
+
+       p = v->vdim;
+       v->vdimfinish = 0;
+       nd = p->ndim;
+       doin_setbound = 1;
+       for(i = 0; i < nd; i++)
+               if (q = p->dims[i].dimexpr) {
+                       q = p->dims[i].dimexpr = make_int_expr(putx(fixtype(q)));
+                       if (!ONEOF(q->headblock.vtype, MSKINT|MSKREAL))
+                               errstr("bad dimension type for %.70s",
+                                       v->fvarname);
+                       }
+       if (q = p->basexpr)
+               p->basexpr = make_int_expr(putx(fixtype(q)));
+       doin_setbound = 0;
+       }
+
+ static void
+duparg(q)
+ Namep q;
+{ errstr("duplicate argument %.80s", q->fvarname); }
+
+/*
+   manipulate argument lists (allocate argument slot positions)
+ * keep track of return types and labels
+ */
+
+LOCAL doentry(ep)
+struct Entrypoint *ep;
+{
+       register int type;
+       register Namep np;
+       chainp p, p1;
+       register Namep q;
+       Addrp mkarg(), rs;
+       int it, k;
+       extern char dflttype[26];
+       Extsym *entryname = ep->entryname;
+
+       if (++nentry > 1)
+               p1_label((long)(extsymtab - entryname - 1));
+
+/* The main program isn't allowed to have parameters, so any given
+   parameters are ignored */
+
+       if(procclass == CLMAIN || procclass == CLBLOCK)
+               return;
+
+/* So now we're working with something other than CLMAIN or CLBLOCK.
+   Determine the type of its return value. */
+
+       impldcl( np = mkname(entryname->fextname) );
+       type = np->vtype;
+       proc_argchanges = prev_proc && type != entryname->extype;
+       entryname->extseen = 1;
+       if(proctype == TYUNKNOWN)
+               if( (proctype = type) == TYCHAR)
+                       procleng = np->vleng ? np->vleng->constblock.Const.ci
+                                            : (ftnint) (-1);
+
+       if(proctype == TYCHAR)
+       {
+               if(type != TYCHAR)
+                       err("noncharacter entry of character function");
+
+/* Functions returning type   char   can only have multiple entries if all
+   entries return the same length */
+
+               else if( (np->vleng ? np->vleng->constblock.Const.ci :
+                   (ftnint) (-1)) != procleng)
+                       err("mismatched character entry lengths");
+       }
+       else if(type == TYCHAR)
+               err("character entry of noncharacter function");
+       else if(type != proctype)
+               multitype = YES;
+       if(rtvlabel[type] == 0)
+               rtvlabel[type] = newlabel();
+       ep->typelabel = rtvlabel[type];
+
+       if(type == TYCHAR)
+       {
+               if(chslot < 0)
+               {
+                       chslot = nextarg(TYADDR);
+                       chlgslot = nextarg(TYLENG);
+               }
+               np->vstg = STGARG;
+
+/* Put a new argument in the function, one which will hold the result of
+   a character function.  This will have to be named sometime, probably in
+   mkarg(). */
+
+               if(procleng < 0) {
+                       np->vleng = (expptr) mkarg(TYLENG, chlgslot);
+                       np->vleng->addrblock.uname_tag = UNAM_IDENT;
+                       strcpy (np -> vleng -> addrblock.user.ident,
+                               new_func_length());
+                       }
+               if (!xretslot[TYCHAR]) {
+                       xretslot[TYCHAR] = rs =
+                               autovar(0, type, ISCONST(np->vleng)
+                                       ? np->vleng : ICON(0), "");
+                       strcpy(rs->user.ident, "ret_val");
+                       }
+       }
+
+/* Handle a   complex   return type -- declare a new parameter (pointer to
+   a complex value) */
+
+       else if( ISCOMPLEX(type) ) {
+               if (!xretslot[type])
+                       xretslot[type] =
+                               autovar(0, type, EXNULL, " ret_val");
+                               /* the blank is for use in out_addr */
+               np->vstg = STGARG;
+               if(cxslot < 0)
+                       cxslot = nextarg(TYADDR);
+               }
+       else if (type != TYSUBR) {
+               if (type == TYUNKNOWN) {
+                       dclerr("untyped function", np);
+                       proctype = type = np->vtype =
+                               dflttype[letter(np->fvarname[0])];
+                       }
+               if (!xretslot[type])
+                       xretslot[type] = retslot =
+                               autovar(1, type, EXNULL, " ret_val");
+                               /* the blank is for use in out_addr */
+               np->vstg = STGAUTO;
+               }
+
+       for(p = ep->arglist ; p ; p = p->nextp)
+               if(! (( q = (Namep) (p->datap) )->vknownarg) ) {
+                       q->vknownarg = 1;
+                       q->vardesc.varno = nextarg(TYADDR);
+                       allargs = mkchain((char *)q, allargs);
+                       q->argno = nallargs++;
+                       }
+               else if (nentry == 1)
+                       duparg(q);
+               else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp)
+                       if ((Namep)p1->datap == q)
+                               duparg(q);
+
+       k = 0;
+       for(p = ep->arglist ; p ; p = p->nextp) {
+               if(! (( q = (Namep) (p->datap) )->vdcldone) )
+                       {
+                       impldcl(q);
+                       q->vdcldone = YES;
+                       if(q->vtype == TYCHAR)
+                               {
+
+/* If we don't know the length of a char*(*) (i.e. a string), we must add
+   in this additional length argument. */
+
+                               ++nallchargs;
+                               if (q->vclass == CLPROC)
+                                       nallchargs--;
+                               else if (q->vleng == NULL) {
+                                       /* character*(*) */
+                                       q->vleng = (expptr)
+                                           mkarg(TYLENG, nextarg(TYLENG) );
+                                       unamstring((Addrp)q->vleng,
+                                               new_arg_length(q));
+                                       }
+                               }
+                       }
+               if (q->vdimfinish)
+                       dim_finish(q);
+               if (q->vtype == TYCHAR && q->vclass != CLPROC)
+                       k++;
+               }
+
+       if (entryname->extype != type)
+               changedtype(np);
+
+       /* save information for checking consistency of arg lists */
+
+       it = infertypes;
+       if (entryname->exproto)
+               infertypes = 1;
+       save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo,
+                       0, np->fvarname, STGEXT, k, np->vtype, 2);
+       infertypes = it;
+}
+
+
+
+LOCAL nextarg(type)
+int type;
+{ return(lastargslot++); }
+
+ LOCAL
+dim_check(q)
+ Namep q;
+{
+       register struct Dimblock *vdim = q->vdim;
+
+       if(!vdim->nelt || !ISICON(vdim->nelt))
+               dclerr("adjustable dimension on non-argument", q);
+       else if (vdim->nelt->constblock.Const.ci <= 0)
+               dclerr("nonpositive dimension", q);
+       }
+
+LOCAL dobss()
+{
+       register struct Hashentry *p;
+       register Namep q;
+       int qstg, qclass, qtype;
+       Extsym *e;
+
+       for(p = hashtab ; p<lasthash ; ++p)
+               if(q = p->varp)
+               {
+                       qstg = q->vstg;
+                       qtype = q->vtype;
+                       qclass = q->vclass;
+
+                       if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
+                           (qclass==CLVAR && qstg==STGUNKNOWN) ) {
+                               if (!(q->vis_assigned | q->vimpldovar))
+                                       warn1("local variable %s never used",
+                                               q->fvarname);
+                               }
+                       else if(qclass==CLVAR && qstg==STGBSS)
+                       { ; }
+
+/* Give external procedures the proper storage class */
+
+                       else if(qclass==CLPROC && q->vprocclass==PEXTERNAL
+                                       && qstg!=STGARG) {
+                               e = mkext(q->fvarname,addunder(q->cvarname));
+                               e->extstg = STGEXT;
+                               q->vardesc.varno = e - extsymtab;
+                               if (e->extype != qtype)
+                                       changedtype(q);
+                               }
+                       if(qclass==CLVAR) {
+                           if (qstg != STGARG && q->vdim)
+                               dim_check(q);
+                       } /* if qclass == CLVAR */
+               }
+
+}
+
+
+
+donmlist()
+{
+       register struct Hashentry *p;
+       register Namep q;
+
+       for(p=hashtab; p<lasthash; ++p)
+               if( (q = p->varp) && q->vclass==CLNAMELIST)
+                       namelist(q);
+}
+
+
+/* iarrlen -- Returns the size of the array in bytes, or -1 */
+
+ftnint iarrlen(q)
+register Namep q;
+{
+       ftnint leng;
+
+       leng = typesize[q->vtype];
+       if(leng <= 0)
+               return(-1);
+       if(q->vdim)
+               if( ISICON(q->vdim->nelt) )
+                       leng *= q->vdim->nelt->constblock.Const.ci;
+               else    return(-1);
+       if(q->vleng)
+               if( ISICON(q->vleng) )
+                       leng *= q->vleng->constblock.Const.ci;
+               else return(-1);
+       return(leng);
+}
+
+namelist(np)
+Namep np;
+{
+       register chainp q;
+       register Namep v;
+       int y;
+
+       if (!np->visused)
+               return;
+       y = 0;
+
+       for(q = np->varxptr.namelist ; q ; q = q->nextp)
+       {
+               vardcl( v = (Namep) (q->datap) );
+               if( !ONEOF(v->vstg, MSKSTATIC) )
+                       dclerr("may not appear in namelist", v);
+               else {
+                       v->vnamelist = 1;
+                       v->visused = 1;
+                       v->vsave = 1;
+                       y = 1;
+                       }
+       np->visused = y;
+       }
+}
+
+/* docommon -- called at the end of procedure declarations, before
+   equivalences and the procedure body */
+
+LOCAL docommon()
+{
+    register Extsym *extptr;
+    register chainp q, q1;
+    struct Dimblock *t;
+    expptr neltp;
+    register Namep comvar;
+    ftnint size;
+    int i, k, pref, type;
+    extern int type_pref[];
+
+    for(extptr = extsymtab ; extptr<nextext ; ++extptr)
+       if (extptr->extstg == STGCOMMON && (q = extptr->extp)) {
+
+/* If a common declaration also had a list of variables ... */
+
+           q = extptr->extp = revchain(q);
+           pref = 1;
+           for(k = TYCHAR; q ; q = q->nextp)
+           {
+               comvar = (Namep) (q->datap);
+
+               if(comvar->vdcldone == NO)
+                   vardcl(comvar);
+               type = comvar->vtype;
+               if (pref < type_pref[type])
+                       pref = type_pref[k = type];
+               if(extptr->extleng % typealign[type] != 0) {
+                   dclerr("common alignment", comvar);
+                   --nerr; /* don't give bad return code for this */
+#if 0
+                   extptr->extleng = roundup(extptr->extleng, typealign[type]);
+#endif
+               } /* if extptr -> extleng % */
+
+/* Set the offset into the common block */
+
+               comvar->voffset = extptr->extleng;
+               comvar->vardesc.varno = extptr - extsymtab;
+               if(type == TYCHAR)
+                   size = comvar->vleng->constblock.Const.ci;
+               else
+                   size = typesize[type];
+               if(t = comvar->vdim)
+                   if( (neltp = t->nelt) && ISCONST(neltp) )
+                       size *= neltp->constblock.Const.ci;
+                   else
+                       dclerr("adjustable array in common", comvar);
+
+/* Adjust the length of the common block so far */
+
+               extptr->extleng += size;
+           } /* for */
+
+           extptr->extype = k;
+
+/* Determine curno and, if new, save this identifier chain */
+
+           q1 = extptr->extp;
+           for (q = extptr->allextp, i = 0; q; i++, q = q->nextp)
+               if (struct_eq((chainp)q->datap, q1))
+                       break;
+           if (q)
+               extptr->curno = extptr->maxno - i;
+           else {
+               extptr->curno = ++extptr->maxno;
+               extptr->allextp = mkchain((char *)extptr->extp,
+                                               extptr->allextp);
+               }
+       } /* if extptr -> extstg == STGCOMMON */
+
+/* Now the hash table entries have STGCOMMON, vdcldone, voffset, and
+   varno.  And the common block itself has its full size in extleng. */
+
+} /* docommon */
+
+
+/* copy_data -- copy the Namep entries so they are available even after
+   the hash table is empty */
+
+copy_data (list)
+chainp list;
+{
+    for (; list; list = list -> nextp) {
+       Namep namep = ALLOC (Nameblock);
+       int size, nd, i;
+       struct Dimblock *dp;
+
+       cpn(sizeof(struct Nameblock), list->datap, (char *)namep);
+       namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0),
+               namep->fvarname);
+       namep->cvarname = strcmp(namep->fvarname, namep->cvarname)
+               ? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname)
+               : namep->fvarname;
+       if (namep -> vleng)
+           namep -> vleng = (expptr) cpexpr (namep -> vleng);
+       if (namep -> vdim) {
+           nd = namep -> vdim -> ndim;
+           size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr);
+           dp = (struct Dimblock *) ckalloc (size);
+           cpn(size, (char *)namep->vdim, (char *)dp);
+           namep -> vdim = dp;
+           dp->nelt = (expptr)cpexpr(dp->nelt);
+           for (i = 0; i < nd; i++) {
+               dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize);
+           } /* for */
+       } /* if */
+       list -> datap = (char *) namep;
+    } /* for */
+} /* copy_data */
+
+
+
+LOCAL docomleng()
+{
+       register Extsym *p;
+
+       for(p = extsymtab ; p < nextext ; ++p)
+               if(p->extstg == STGCOMMON)
+               {
+                       if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
+                           && strcmp(Blank, p->cextname) )
+                               warn1("incompatible lengths for common block %.60s",
+                                   p->fextname);
+                       if(p->maxleng < p->extleng)
+                               p->maxleng = p->extleng;
+                       p->extleng = 0;
+               }
+}
+
+
+/* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
+
+frtemp(p)
+Addrp p;
+{
+       /* put block on chain of temps to be reclaimed */
+       holdtemps = mkchain((char *)p, holdtemps);
+}
+
+ void
+freetemps()
+{
+       register chainp p, p1;
+       register Addrp q;
+       register int t;
+
+       p1 = holdtemps;
+       while(p = p1) {
+               q = (Addrp)p->datap;
+               t = q->vtype;
+               if (t == TYCHAR && q->varleng != 0) {
+                       /* restore clobbered character string lengths */
+                       frexpr(q->vleng);
+                       q->vleng = ICON(q->varleng);
+                       }
+               p1 = p->nextp;
+               p->nextp = templist[t];
+               templist[t] = p;
+               }
+       holdtemps = 0;
+       }
+
+/* allocate an automatic variable slot for each of   nelt   variables */
+
+Addrp autovar(nelt0, t, lengp, name)
+register int nelt0, t;
+expptr lengp;
+char *name;
+{
+       ftnint leng;
+       register Addrp q;
+       char *temp_name ();
+       register int nelt = nelt0 > 0 ? nelt0 : 1;
+       extern char *av_pfix[];
+
+       if(t == TYCHAR)
+               if( ISICON(lengp) )
+                       leng = lengp->constblock.Const.ci;
+               else    {
+                       Fatal("automatic variable of nonconstant length");
+               }
+       else
+               leng = typesize[t];
+
+       q = ALLOC(Addrblock);
+       q->tag = TADDR;
+       q->vtype = t;
+       if(t == TYCHAR)
+       {
+               q->vleng = ICON(leng);
+               q->varleng = leng;
+       }
+       q->vstg = STGAUTO;
+       q->ntempelt = nelt;
+       q->isarray = (nelt > 1);
+       q->memoffset = ICON(0);
+
+       /* kludge for nls so we can have ret_val rather than ret_val_4 */
+       if (*name == ' ')
+               unamstring(q, name);
+       else {
+               q->uname_tag = UNAM_IDENT;
+               temp_name(av_pfix[t], ++autonum[t], q->user.ident);
+               }
+       if (nelt0 > 0)
+               declare_new_addr (q);
+       return(q);
+}
+
+
+/* Returns a temporary of the appropriate type.  Will reuse existing
+   temporaries when possible */
+
+Addrp mktmpn(nelt, type, lengp)
+int nelt;
+register int type;
+expptr lengp;
+{
+       ftnint leng;
+       chainp p, oldp;
+       register Addrp q;
+
+       if(type==TYUNKNOWN || type==TYERROR)
+               badtype("mktmpn", type);
+
+       if(type==TYCHAR)
+               if(lengp && ISICON(lengp) )
+                       leng = lengp->constblock.Const.ci;
+               else    {
+                       err("adjustable length");
+                       return( (Addrp) errnode() );
+               }
+       else if (type > TYCHAR || type < TYADDR) {
+               erri("mktmpn: unexpected type %d", type);
+               exit(1);
+               }
+/*
+ * if a temporary of appropriate shape is on the templist,
+ * remove it from the list and return it
+ */
+       for(oldp=CHNULL, p=templist[type];  p  ;  oldp=p, p=p->nextp)
+       {
+               q = (Addrp) (p->datap);
+               if(q->ntempelt==nelt &&
+                   (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) )
+               {
+                       if(oldp)
+                               oldp->nextp = p->nextp;
+                       else
+                               templist[type] = p->nextp;
+                       free( (charptr) p);
+                       return(q);
+               }
+       }
+       q = autovar(nelt, type, lengp, "");
+       return(q);
+}
+
+
+
+
+/* mktmp -- create new local variable; call it something like   name
+   lengp   is taken directly, not copied */
+
+Addrp mktmp(type, lengp)
+int type;
+expptr lengp;
+{
+       Addrp rv;
+       /* arrange for temporaries to be recycled */
+       /* at the end of this statement... */
+       rv = mktmpn(1,type,lengp);
+       frtemp((Addrp)cpexpr((expptr)rv));
+       return rv;
+}
+
+/* mktmp0 omits frtemp() */
+Addrp mktmp0(type, lengp)
+int type;
+expptr lengp;
+{
+       Addrp rv;
+       /* arrange for temporaries to be recycled */
+       /* when this Addrp is freed */
+       rv = mktmpn(1,type,lengp);
+       rv->istemp = YES;
+       return rv;
+}
+
+/* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
+
+/* comblock -- Declare a new common block.  Input parameters name the block;
+   s   will be NULL if the block is unnamed */
+
+Extsym *comblock(s)
+ register char *s;
+{
+       Extsym *p;
+       register char *t;
+       register int c, i;
+       char cbuf[256], *s0;
+
+/* Give the unnamed common block a unique name */
+
+       if(*s == 0)
+               p = mkext(Blank,Blank);
+       else {
+               s0 = s;
+               t = cbuf;
+               for(i = 0; c = *t = *s++; t++)
+                       if (c == '_')
+                               i = 1;
+               if (i)
+                       *t++ = '_';
+               t[0] = '_';
+               t[1] = 0;
+               p = mkext(s0,cbuf);
+               }
+       if(p->extstg == STGUNKNOWN)
+               p->extstg = STGCOMMON;
+       else if(p->extstg != STGCOMMON)
+       {
+               errstr("%.68s cannot be a common block name", s);
+               return(0);
+       }
+
+       return( p );
+}
+
+
+/* incomm -- add a new variable to a common declaration */
+
+incomm(c, v)
+Extsym *c;
+Namep v;
+{
+       if (!c)
+               return;
+       if(v->vstg != STGUNKNOWN && !v->vimplstg)
+               dclerr(v->vstg == STGARG
+                       ? "dummy arguments cannot be in common"
+                       : "incompatible common declaration", v);
+       else
+       {
+               v->vstg = STGCOMMON;
+               c->extp = mkchain((char *)v, c->extp);
+       }
+}
+
+
+
+
+/* settype -- set the type or storage class of a Namep object.  If
+   v -> vstg == STGUNKNOWN && type < 0,   attempt to reset vstg to be
+   -type.  This function will not change any earlier definitions in   v,
+   in will only attempt to fill out more information give the other params */
+
+settype(v, type, length)
+register Namep  v;
+register int type;
+register ftnint length;
+{
+       int type1;
+
+       if(type == TYUNKNOWN)
+               return;
+
+       if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
+       {
+               v->vtype = TYSUBR;
+               frexpr(v->vleng);
+               v->vleng = 0;
+               v->vimpltype = 0;
+       }
+       else if(type < 0)       /* storage class set */
+       {
+               if(v->vstg == STGUNKNOWN)
+                       v->vstg = - type;
+               else if(v->vstg != -type)
+                       dclerr("incompatible storage declarations", v);
+       }
+       else if(v->vtype == TYUNKNOWN || v->vimpltype && v->vtype != type)
+       {
+               if( (v->vtype = lengtype(type, length))==TYCHAR )
+                       if (length>=0)
+                               v->vleng = ICON(length);
+                       else if (parstate >= INDATA)
+                               v->vleng = ICON(1);     /* avoid a memory fault */
+               v->vimpltype = 0;
+
+               if (v->vclass == CLPROC) {
+                       if (v->vstg == STGEXT
+                        && (type1 = extsymtab[v->vardesc.varno].extype)
+                        &&  type1 != v->vtype)
+                               changedtype(v);
+                       else if (v->vprocclass == PTHISPROC
+                                       && (parstate >= INDATA
+                                               || procclass == CLMAIN)
+                                       && !xretslot[type]) {
+                               xretslot[type] = autovar(ONEOF(type,
+                                       MSKCOMPLEX|MSKCHAR) ? 0 : 1, type,
+                                       v->vleng, " ret_val");
+                               if (procclass == CLMAIN)
+                                       errstr(
+                               "illegal use of %.60s (main program name)",
+                                       v->fvarname);
+                               /* not completely right, but enough to */
+                               /* avoid memory faults; we won't */
+                               /* emit any C as we have illegal Fortran */
+                               }
+                       }
+       }
+       else if(v->vtype!=type) {
+ incompat:
+               dclerr("incompatible type declarations", v);
+               }
+       else if (type==TYCHAR)
+               if (v->vleng && v->vleng->constblock.Const.ci != length)
+                       goto incompat;
+               else if (parstate >= INDATA)
+                       v->vleng = ICON(1);     /* avoid a memory fault */
+}
+
+
+
+
+
+/* lengtype -- returns the proper compiler type, given input of Fortran
+   type and length specifier */
+
+lengtype(type, len)
+register int type;
+ftnint len;
+{
+       register int length = (int)len;
+       switch(type)
+       {
+       case TYREAL:
+               if(length == typesize[TYDREAL])
+                       return(TYDREAL);
+               if(length == typesize[TYREAL])
+                       goto ret;
+               break;
+
+       case TYCOMPLEX:
+               if(length == typesize[TYDCOMPLEX])
+                       return(TYDCOMPLEX);
+               if(length == typesize[TYCOMPLEX])
+                       goto ret;
+               break;
+
+       case TYINT1:
+       case TYSHORT:
+       case TYDREAL:
+       case TYDCOMPLEX:
+       case TYCHAR:
+       case TYLOGICAL1:
+       case TYLOGICAL2:
+       case TYUNKNOWN:
+       case TYSUBR:
+       case TYERROR:
+#ifdef TYQUAD
+       case TYQUAD:
+#endif
+               goto ret;
+
+       case TYLOGICAL:
+               switch(length) {
+                       case 0: return tylog;
+                       case 1: return TYLOGICAL1;
+                       case 2: return TYLOGICAL2;
+                       case 4: goto ret;
+                       }
+#if 0 /*!!??!!*/
+               if(length == typesize[TYLOGICAL])
+                       goto ret;
+#endif
+               break;
+
+       case TYLONG:
+               if(length == 0)
+                       return(tyint);
+               if (length == 1)
+                       return TYINT1;
+               if(length == typesize[TYSHORT])
+                       return(TYSHORT);
+#ifdef TYQUAD
+               if(length == typesize[TYQUAD] && use_tyquad)
+                       return(TYQUAD);
+#endif
+               if(length == typesize[TYLONG])
+                       goto ret;
+               break;
+       default:
+               badtype("lengtype", type);
+       }
+
+       if(len != 0)
+               err("incompatible type-length combination");
+
+ret:
+       return(type);
+}
+
+
+
+
+
+/* setintr -- Set Intrinsic function */
+
+setintr(v)
+register Namep  v;
+{
+       int k;
+
+       if(v->vstg == STGUNKNOWN)
+               v->vstg = STGINTR;
+       else if(v->vstg!=STGINTR)
+               dclerr("incompatible use of intrinsic function", v);
+       if(v->vclass==CLUNKNOWN)
+               v->vclass = CLPROC;
+       if(v->vprocclass == PUNKNOWN)
+               v->vprocclass = PINTRINSIC;
+       else if(v->vprocclass != PINTRINSIC)
+               dclerr("invalid intrinsic declaration", v);
+       if(k = intrfunct(v->fvarname)) {
+               if ((*(struct Intrpacked *)&k).f4)
+                       if (noextflag)
+                               goto unknown;
+                       else
+                               dcomplex_seen++;
+               v->vardesc.varno = k;
+               }
+       else {
+ unknown:
+               dclerr("unknown intrinsic function", v);
+               }
+}
+
+
+
+/* setext -- Set External declaration -- assume that unknowns will become
+   procedures */
+
+setext(v)
+register Namep  v;
+{
+       if(v->vclass == CLUNKNOWN)
+               v->vclass = CLPROC;
+       else if(v->vclass != CLPROC)
+               dclerr("invalid external declaration", v);
+
+       if(v->vprocclass == PUNKNOWN)
+               v->vprocclass = PEXTERNAL;
+       else if(v->vprocclass != PEXTERNAL)
+               dclerr("invalid external declaration", v);
+} /* setext */
+
+
+
+
+/* create dimensions block for array variable */
+
+setbound(v, nd, dims)
+register Namep  v;
+int nd;
+struct Dims dims[ ];
+{
+       register expptr q, t;
+       register struct Dimblock *p;
+       int i;
+       extern chainp new_vars;
+       char buf[256];
+
+       if(v->vclass == CLUNKNOWN)
+               v->vclass = CLVAR;
+       else if(v->vclass != CLVAR)
+       {
+               dclerr("only variables may be arrays", v);
+               return;
+       }
+
+       v->vdim = p = (struct Dimblock *)
+           ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) );
+       p->ndim = nd--;
+       p->nelt = ICON(1);
+       doin_setbound = 1;
+
+       for(i = 0; i <= nd; ++i)
+       {
+               if( (q = dims[i].ub) == NULL)
+               {
+                       if(i == nd)
+                       {
+                               frexpr(p->nelt);
+                               p->nelt = NULL;
+                       }
+                       else
+                               err("only last bound may be asterisk");
+                       p->dims[i].dimsize = ICON(1);
+                       p->dims[i].dimexpr = NULL;
+               }
+               else
+               {
+
+                       if(dims[i].lb)
+                       {
+                               q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
+                               q = mkexpr(OPPLUS, q, ICON(1) );
+                       }
+                       if( ISCONST(q) )
+                       {
+                               p->dims[i].dimsize = q;
+                               p->dims[i].dimexpr = (expptr) PNULL;
+                       }
+                       else {
+                               sprintf(buf, " %s_dim%d", v->fvarname, i+1);
+                               p->dims[i].dimsize = (expptr)
+                                       autovar(1, tyint, EXNULL, buf);
+                               p->dims[i].dimexpr = q;
+                               if (i == nd)
+                                       v->vlastdim = new_vars;
+                               v->vdimfinish = 1;
+                       }
+                       if(p->nelt)
+                               p->nelt = mkexpr(OPSTAR, p->nelt,
+                                   cpexpr(p->dims[i].dimsize) );
+               }
+       }
+
+       q = dims[nd].lb;
+       if(q == NULL)
+               q = ICON(1);
+
+       for(i = nd-1 ; i>=0 ; --i)
+       {
+               t = dims[i].lb;
+               if(t == NULL)
+                       t = ICON(1);
+               if(p->dims[i].dimsize)
+                       q = mkexpr(OPPLUS, t,
+                               mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q));
+       }
+
+       if( ISCONST(q) )
+       {
+               p->baseoffset = q;
+               p->basexpr = NULL;
+       }
+       else
+       {
+               sprintf(buf, " %s_offset", v->fvarname);
+               p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf);
+               p->basexpr = q;
+               v->vdimfinish = 1;
+       }
+       doin_setbound = 0;
+}
+
+
+
+wr_abbrevs (outfile, function_head, vars)
+FILE *outfile;
+int function_head;
+chainp vars;
+{
+    for (; vars; vars = vars -> nextp) {
+       Namep name = (Namep) vars -> datap;
+       if (!name->visused)
+               continue;
+
+       if (function_head)
+           nice_printf (outfile, "#define ");
+       else
+           nice_printf (outfile, "#undef ");
+       out_name (outfile, name);
+
+       if (function_head) {
+           Extsym *comm = &extsymtab[name -> vardesc.varno];
+
+           nice_printf (outfile, " (");
+           extern_out (outfile, comm);
+           nice_printf (outfile, "%d.", comm->curno);
+           nice_printf (outfile, "%s)", name->cvarname);
+       } /* if function_head */
+       nice_printf (outfile, "\n");
+    } /* for */
+} /* wr_abbrevs */

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

diff --git a/usr.bin/f2c/putpcc.c b/usr.bin/f2c/putpcc.c
new file mode 100644 (file)
index 0000000..d96e5e2
--- /dev/null
+++ b/usr.bin/f2c/putpcc.c
@@ -0,0 +1,1843 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* INTERMEDIATE CODE GENERATION FOR S. C. JOHNSON C COMPILERS */
+/* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
+
+#include "defs.h"
+#include "pccdefs.h"
+#include "output.h"            /* for nice_printf */
+#include "names.h"
+#include "p1defs.h"
+
+Addrp realpart();
+LOCAL Addrp intdouble(), putcx1(), putcxeq (), putch1 ();
+LOCAL putct1 ();
+
+expptr putcxop();
+LOCAL expptr putcall (), putmnmx (), putcheq(), putcat ();
+LOCAL expptr putaddr(), putchcmp (), putpower(), putop();
+LOCAL expptr putcxcmp ();
+expptr imagpart();
+ftnint lencat();
+
+#define FOUR 4
+extern int ops2[];
+extern int proc_argchanges, proc_protochanges;
+extern int krparens;
+
+#define P2BUFFMAX 128
+
+/* Puthead -- output the header information about subroutines, functions
+   and entry points */
+
+puthead(s, class)
+char *s;
+int class;
+{
+       if (headerdone == NO) {
+               if (class == CLMAIN)
+                       s = "MAIN__";
+               p1_head (class, s);
+               headerdone = YES;
+               }
+}
+
+putif(p, else_if_p)
+ register expptr p;
+ int else_if_p;
+{
+       register int k;
+       int n;
+       long where;
+
+       if (else_if_p) {
+               p1put(P1_ELSEIFSTART);
+               where = ftell(pass1_file);
+               }
+       if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype )) )
+       {
+               if(k != TYERROR)
+                       err("non-logical expression in IF statement");
+               }
+       else {
+               if (else_if_p) {
+                       if (ei_next >= ei_last)
+                               {
+                               k = ei_last - ei_first;
+                               n = k + 100;
+                               ei_next = mem(n,0);
+                               ei_last = ei_first + n;
+                               if (k)
+                                       memcpy(ei_next, ei_first, k);
+                               ei_first =  ei_next;
+                               ei_next += k;
+                               ei_last = ei_first + n;
+                               }
+                       p = putx(p);
+                       if (*ei_next++ = ftell(pass1_file) > where) {
+                               p1_if(p);
+                               new_endif();
+                               }
+                       else
+                               p1_elif(p);
+                       }
+               else {
+                       p = putx(p);
+                       p1_if(p);
+                       }
+               }
+       }
+
+
+putout(p)
+expptr p;
+{
+       p1_expr (p);
+
+/* Used to make temporaries in holdtemps available here, but they */
+/* may be reused too soon (e.g. when multiple **'s are involved). */
+}
+
+
+
+putcmgo(index, nlab, labs)
+expptr index;
+int nlab;
+struct Labelblock *labs[];
+{
+       if(! ISINT(index->headblock.vtype) )
+       {
+               execerr("computed goto index must be integer", CNULL);
+               return;
+       }
+
+       p1comp_goto (index, nlab, labs);
+}
+
+ static expptr
+krput(p)
+ register expptr p;
+{
+       register expptr e, e1;
+       register unsigned op;
+       int t = krparens == 2 ? TYDREAL : p->exprblock.vtype;
+
+       op = p->exprblock.opcode;
+       e = p->exprblock.leftp;
+       if (e->tag == TEXPR && e->exprblock.opcode == op) {
+               e1 = (expptr)mktmp(t, ENULL);
+               putout(putassign(cpexpr(e1), e));
+               p->exprblock.leftp = e1;
+               }
+       else
+               p->exprblock.leftp = putx(e);
+
+       e = p->exprblock.rightp;
+       if (e->tag == TEXPR && e->exprblock.opcode == op) {
+               e1 = (expptr)mktmp(t, ENULL);
+               putout(putassign(cpexpr(e1), e));
+               p->exprblock.rightp = e1;
+               }
+       else
+               p->exprblock.rightp = putx(e);
+       return p;
+       }
+
+expptr putx(p)
+ register expptr p;
+{
+       int opc;
+       int k;
+
+       if (p)
+         switch(p->tag)
+       {
+       case TERROR:
+               break;
+
+       case TCONST:
+               switch(p->constblock.vtype)
+               {
+               case TYLOGICAL1:
+               case TYLOGICAL2:
+               case TYLOGICAL:
+#ifdef TYQUAD
+               case TYQUAD:
+#endif
+               case TYLONG:
+               case TYSHORT:
+               case TYINT1:
+                       break;
+
+               case TYADDR:
+                       break;
+               case TYREAL:
+               case TYDREAL:
+
+/* Don't write it out to the p2 file, since you'd need to call putconst,
+   which is just what we need to avoid in the translator */
+
+                       break;
+               default:
+                       p = putx( (expptr)putconst((Constp)p) );
+                       break;
+               }
+               break;
+
+       case TEXPR:
+               switch(opc = p->exprblock.opcode)
+               {
+               case OPCALL:
+               case OPCCALL:
+                       if( ISCOMPLEX(p->exprblock.vtype) )
+                               p = putcxop(p);
+                       else    p = putcall(p, (Addrp *)NULL);
+                       break;
+
+               case OPMIN:
+               case OPMAX:
+                       p = putmnmx(p);
+                       break;
+
+
+               case OPASSIGN:
+                       if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype)
+                           || ISCOMPLEX(p->exprblock.rightp->headblock.vtype)) {
+                               (void) putcxeq(p);
+                               p = ENULL;
+                       } else if( ISCHAR(p) )
+                               p = putcheq(p);
+                       else
+                               goto putopp;
+                       break;
+
+               case OPEQ:
+               case OPNE:
+                       if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ||
+                           ISCOMPLEX(p->exprblock.rightp->headblock.vtype) )
+                       {
+                               p = putcxcmp(p);
+                               break;
+                       }
+               case OPLT:
+               case OPLE:
+               case OPGT:
+               case OPGE:
+                       if(ISCHAR(p->exprblock.leftp))
+                       {
+                               p = putchcmp(p);
+                               break;
+                       }
+                       goto putopp;
+
+               case OPPOWER:
+                       p = putpower(p);
+                       break;
+
+               case OPSTAR:
+                       /*   m * (2**k) -> m<<k   */
+                       if(INT(p->exprblock.leftp->headblock.vtype) &&
+                           ISICON(p->exprblock.rightp) &&
+                           ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) )
+                       {
+                               p->exprblock.opcode = OPLSHIFT;
+                               frexpr(p->exprblock.rightp);
+                               p->exprblock.rightp = ICON(k);
+                               goto putopp;
+                       }
+                       if (krparens && ISREAL(p->exprblock.vtype))
+                               return krput(p);
+
+               case OPMOD:
+                       goto putopp;
+               case OPPLUS:
+                       if (krparens && ISREAL(p->exprblock.vtype))
+                               return krput(p);
+               case OPMINUS:
+               case OPSLASH:
+               case OPNEG:
+               case OPNEG1:
+               case OPABS:
+               case OPDABS:
+                       if( ISCOMPLEX(p->exprblock.vtype) )
+                               p = putcxop(p);
+                       else    goto putopp;
+                       break;
+
+               case OPCONV:
+                       if( ISCOMPLEX(p->exprblock.vtype) )
+                               p = putcxop(p);
+                       else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) )
+                       {
+                               p = putx( mkconv(p->exprblock.vtype,
+                                   (expptr)realpart(putcx1(p->exprblock.leftp))));
+                       }
+                       else    goto putopp;
+                       break;
+
+               case OPNOT:
+               case OPOR:
+               case OPAND:
+               case OPEQV:
+               case OPNEQV:
+               case OPADDR:
+               case OPPLUSEQ:
+               case OPSTAREQ:
+               case OPCOMMA:
+               case OPQUEST:
+               case OPCOLON:
+               case OPBITOR:
+               case OPBITAND:
+               case OPBITXOR:
+               case OPBITNOT:
+               case OPLSHIFT:
+               case OPRSHIFT:
+               case OPASSIGNI:
+               case OPIDENTITY:
+               case OPCHARCAST:
+               case OPMIN2:
+               case OPMAX2:
+               case OPDMIN:
+               case OPDMAX:
+putopp:
+                       p = putop(p);
+                       break;
+
+               case OPCONCAT:
+                       /* weird things like ichar(a//a) */
+                       p = (expptr)putch1(p);
+                       break;
+
+               default:
+                       badop("putx", opc);
+                       p = errnode ();
+               }
+               break;
+
+       case TADDR:
+               p = putaddr(p);
+               break;
+
+       default:
+               badtag("putx", p->tag);
+               p = errnode ();
+       }
+
+       return p;
+}
+
+
+
+LOCAL expptr putop(p)
+expptr p;
+{
+       expptr lp, tp;
+       int pt, lt, lt1;
+       int comma;
+
+       switch(p->exprblock.opcode)     /* check for special cases and rewrite */
+       {
+       case OPCONV:
+               pt = p->exprblock.vtype;
+               lp = p->exprblock.leftp;
+               lt = lp->headblock.vtype;
+
+/* Simplify nested type casts */
+
+               while(p->tag==TEXPR && p->exprblock.opcode==OPCONV &&
+                   ( (ISREAL(pt)&&ONEOF(lt,MSKREAL|MSKCOMPLEX)) ||
+                   (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) ))
+               {
+                       if(pt==TYDREAL && lt==TYREAL)
+                       {
+                               if(lp->tag==TEXPR
+                               && lp->exprblock.opcode == OPCONV) {
+                                   lt1 = lp->exprblock.leftp->headblock.vtype;
+                                   if (lt1 == TYDREAL) {
+                                       lp->exprblock.leftp =
+                                               putx(lp->exprblock.leftp);
+                                       return p;
+                                       }
+                                   if (lt1 == TYDCOMPLEX) {
+                                       lp->exprblock.leftp = putx(
+                                               (expptr)realpart(
+                                               putcx1(lp->exprblock.leftp)));
+                                       return p;
+                                       }
+                                   }
+                               break;
+                       }
+                       else if (ISREAL(pt) && ISCOMPLEX(lt)) {
+                               p->exprblock.leftp = putx(mkconv(pt,
+                                       (expptr)realpart(
+                                               putcx1(p->exprblock.leftp))));
+                               break;
+                               }
+                       if(lt==TYCHAR && lp->tag==TEXPR &&
+                           lp->exprblock.opcode==OPCALL)
+                       {
+
+/* May want to make a comma expression here instead.  I had one, but took
+   it out for my convenience, not for the convenience of the end user */
+
+                               putout (putcall (lp, (Addrp *) &(p ->
+                                   exprblock.leftp)));
+                               return putop (p);
+                       }
+                       if (lt == TYCHAR) {
+                               p->exprblock.leftp = putx(p->exprblock.leftp);
+                               return p;
+                               }
+                       frexpr(p->exprblock.vleng);
+                       free( (charptr) p );
+                       p = lp;
+                       if (p->tag != TEXPR)
+                               goto retputx;
+                       pt = lt;
+                       lp = p->exprblock.leftp;
+                       lt = lp->headblock.vtype;
+               } /* while */
+               if(p->tag==TEXPR && p->exprblock.opcode==OPCONV)
+                       break;
+ retputx:
+               return putx(p);
+
+       case OPADDR:
+               comma = NO;
+               lp = p->exprblock.leftp;
+               free( (charptr) p );
+               if(lp->tag != TADDR)
+               {
+                       tp = (expptr)
+                           mktmp(lp->headblock.vtype,lp->headblock.vleng);
+                       p = putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
+                       lp = tp;
+                       comma = YES;
+               }
+               if(comma)
+                       p = mkexpr(OPCOMMA, p, putaddr(lp));
+               else
+                       p = (expptr)putaddr(lp);
+               return p;
+
+       case OPASSIGN:
+       case OPASSIGNI:
+       case OPLT:
+       case OPLE:
+       case OPGT:
+       case OPGE:
+       case OPEQ:
+       case OPNE:
+           ;
+       }
+
+       if( ops2[p->exprblock.opcode] <= 0)
+               badop("putop", p->exprblock.opcode);
+       p -> exprblock.leftp = putx (p -> exprblock.leftp);
+       if (p -> exprblock.rightp)
+           p -> exprblock.rightp = putx (p -> exprblock.rightp);
+       return p;
+}
+
+LOCAL expptr putpower(p)
+expptr p;
+{
+       expptr base;
+       Addrp t1, t2;
+       ftnint k;
+       int type;
+       char buf[80];                   /* buffer for text of comment */
+
+       if(!ISICON(p->exprblock.rightp) ||
+           (k = p->exprblock.rightp->constblock.Const.ci)<2)
+               Fatal("putpower: bad call");
+       base = p->exprblock.leftp;
+       type = base->headblock.vtype;
+       t1 = mktmp(type, ENULL);
+       t2 = NULL;
+
+       free ((charptr) p);
+       p = putassign (cpexpr((expptr) t1), base);
+
+       sprintf (buf, "Computing %ld%s power", k,
+               k == 2 ? "nd" : k == 3 ? "rd" : "th");
+       p1_comment (buf);
+
+       for( ; (k&1)==0 && k>2 ; k>>=1 )
+       {
+               p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
+       }
+
+       if(k == 2) {
+
+/* Write the power computation out immediately */
+               putout (p);
+               p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)));
+       } else {
+               t2 = mktmp(type, ENULL);
+               p = mkexpr (OPCOMMA, p, putassign(cpexpr((expptr)t2),
+                                               cpexpr((expptr)t1)));
+
+               for(k>>=1 ; k>1 ; k>>=1)
+               {
+                       p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
+                       if(k & 1)
+                       {
+                               p = mkexpr (OPCOMMA, p, putsteq(t2, t1));
+                       }
+               }
+/* Write the power computation out immediately */
+               putout (p);
+               p = putx( mkexpr(OPSTAR, cpexpr((expptr)t2),
+                   mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))));
+       }
+       frexpr((expptr)t1);
+       if(t2)
+               frexpr((expptr)t2);
+       return p;
+}
+
+
+
+
+LOCAL Addrp intdouble(p)
+Addrp p;
+{
+       register Addrp t;
+
+       t = mktmp(TYDREAL, ENULL);
+       putout (putassign(cpexpr((expptr)t), (expptr)p));
+       return(t);
+}
+
+
+
+
+
+/* Complex-type variable assignment */
+
+LOCAL Addrp putcxeq(p)
+register expptr p;
+{
+       register Addrp lp, rp;
+       expptr code;
+
+       if(p->tag != TEXPR)
+               badtag("putcxeq", p->tag);
+
+       lp = putcx1(p->exprblock.leftp);
+       rp = putcx1(p->exprblock.rightp);
+       code = putassign ( (expptr)realpart(lp), (expptr)realpart(rp));
+
+       if( ISCOMPLEX(p->exprblock.vtype) )
+       {
+               code = mkexpr (OPCOMMA, code, putassign
+                       (imagpart(lp), imagpart(rp)));
+       }
+       putout (code);
+       frexpr((expptr)rp);
+       free ((charptr) p);
+       return lp;
+}
+
+
+
+/* putcxop -- used to write out embedded calls to complex functions, and
+   complex arguments to procedures */
+
+expptr putcxop(p)
+expptr p;
+{
+       return (expptr)putaddr((expptr)putcx1(p));
+}
+
+#define PAIR(x,y) mkexpr (OPCOMMA, (x), (y))
+
+LOCAL Addrp putcx1(p)
+register expptr p;
+{
+       expptr q;
+       Addrp lp, rp;
+       register Addrp resp;
+       int opcode;
+       int ltype, rtype;
+       long ts, tskludge;
+       expptr mkrealcon();
+
+       if(p == NULL)
+               return(NULL);
+
+       switch(p->tag)
+       {
+       case TCONST:
+               if( ISCOMPLEX(p->constblock.vtype) )
+                       p = (expptr) putconst((Constp)p);
+               return( (Addrp) p );
+
+       case TADDR:
+               resp = &p->addrblock;
+               if (addressable(p))
+                       return (Addrp) p;
+               ts = tskludge = 0;
+               if (q = resp->memoffset) {
+                       if (resp->uname_tag == UNAM_REF) {
+                               q = cpexpr((tagptr)resp);
+                               q->addrblock.vtype = tyint;
+                               q->addrblock.cmplx_sub = 1;
+                               p->addrblock.skip_offset = 1;
+                               resp->user.name->vsubscrused = 1;
+                               resp->uname_tag = UNAM_NAME;
+                               tskludge = typesize[resp->vtype]
+                                       * (resp->Field ? 2 : 1);
+                               }
+                       else if (resp->isarray
+                                       && resp->vtype != TYCHAR) {
+                               if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
+                                         && resp->uname_tag == UNAM_NAME)
+                                       q = mkexpr(OPMINUS, q,
+                                         mkintcon(resp->user.name->voffset));
+                               ts = typesize[resp->vtype]
+                                       * (resp->Field ? 2 : 1);
+                               q = resp->memoffset = mkexpr(OPSLASH, q,
+                                                               ICON(ts));
+                               }
+                       }
+               resp = mktmp(tyint, ENULL);
+               putout(putassign(cpexpr((expptr)resp), q));
+               p->addrblock.memoffset = tskludge
+                       ? mkexpr(OPSTAR, (expptr)resp, ICON(tskludge))
+                       : (expptr)resp;
+               if (ts) {
+                       resp = &p->addrblock;
+                       q = mkexpr(OPSTAR, resp->memoffset, ICON(ts));
+                       if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
+                               && resp->uname_tag == UNAM_NAME)
+                               q = mkexpr(OPPLUS, q,
+                                   mkintcon(resp->user.name->voffset));
+                       resp->memoffset = q;
+                       }
+               return (Addrp) p;
+
+       case TEXPR:
+               if( ISCOMPLEX(p->exprblock.vtype) )
+                       break;
+               resp = mktmp(TYDREAL, ENULL);
+               putout (putassign( cpexpr((expptr)resp), p));
+               return(resp);
+
+       default:
+               badtag("putcx1", p->tag);
+       }
+
+       opcode = p->exprblock.opcode;
+       if(opcode==OPCALL || opcode==OPCCALL)
+       {
+               Addrp t;
+               p = putcall(p, &t);
+               putout(p);
+               return t;
+       }
+       else if(opcode == OPASSIGN)
+       {
+               return putcxeq (p);
+       }
+
+/* BUG  (inefficient)  Generates too many temporary variables */
+
+       resp = mktmp(p->exprblock.vtype, ENULL);
+       if(lp = putcx1(p->exprblock.leftp) )
+               ltype = lp->vtype;
+       if(rp = putcx1(p->exprblock.rightp) )
+               rtype = rp->vtype;
+
+       switch(opcode)
+       {
+       case OPCOMMA:
+               frexpr((expptr)resp);
+               resp = rp;
+               rp = NULL;
+               break;
+
+       case OPNEG:
+       case OPNEG1:
+               putout (PAIR (
+                       putassign( (expptr)realpart(resp),
+                               mkexpr(OPNEG, (expptr)realpart(lp), ENULL)),
+                       putassign( imagpart(resp),
+                               mkexpr(OPNEG, imagpart(lp), ENULL))));
+               break;
+
+       case OPPLUS:
+       case OPMINUS: { expptr r;
+               r = putassign( (expptr)realpart(resp),
+                   mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp) ));
+               if(rtype < TYCOMPLEX)
+                       q = putassign( imagpart(resp), imagpart(lp) );
+               else if(ltype < TYCOMPLEX)
+               {
+                       if(opcode == OPPLUS)
+                               q = putassign( imagpart(resp), imagpart(rp) );
+                       else
+                               q = putassign( imagpart(resp),
+                                   mkexpr(OPNEG, imagpart(rp), ENULL) );
+               }
+               else
+                       q = putassign( imagpart(resp),
+                           mkexpr(opcode, imagpart(lp), imagpart(rp) ));
+               r = PAIR (r, q);
+               putout (r);
+               break;
+           } /* case OPPLUS, OPMINUS: */
+       case OPSTAR:
+               if(ltype < TYCOMPLEX)
+               {
+                       if( ISINT(ltype) )
+                               lp = intdouble(lp);
+                       putout (PAIR (
+                               putassign( (expptr)realpart(resp),
+                                   mkexpr(OPSTAR, cpexpr((expptr)lp),
+                                       (expptr)realpart(rp))),
+                               putassign( imagpart(resp),
+                                   mkexpr(OPSTAR, cpexpr((expptr)lp), imagpart(rp)))));
+               }
+               else if(rtype < TYCOMPLEX)
+               {
+                       if( ISINT(rtype) )
+                               rp = intdouble(rp);
+                       putout (PAIR (
+                               putassign( (expptr)realpart(resp),
+                                   mkexpr(OPSTAR, cpexpr((expptr)rp),
+                                       (expptr)realpart(lp))),
+                               putassign( imagpart(resp),
+                                   mkexpr(OPSTAR, cpexpr((expptr)rp), imagpart(lp)))));
+               }
+               else    {
+                       putout (PAIR (
+                               putassign( (expptr)realpart(resp), mkexpr(OPMINUS,
+                                   mkexpr(OPSTAR, (expptr)realpart(lp),
+                                       (expptr)realpart(rp)),
+                                   mkexpr(OPSTAR, imagpart(lp), imagpart(rp)))),
+                               putassign( imagpart(resp), mkexpr(OPPLUS,
+                                   mkexpr(OPSTAR, (expptr)realpart(lp), imagpart(rp)),
+                                   mkexpr(OPSTAR, imagpart(lp),
+                                       (expptr)realpart(rp))))));
+               }
+               break;
+
+       case OPSLASH:
+               /* fixexpr has already replaced all divisions
+                * by a complex by a function call
+                */
+               if( ISINT(rtype) )
+                       rp = intdouble(rp);
+               putout (PAIR (
+                       putassign( (expptr)realpart(resp),
+                           mkexpr(OPSLASH, (expptr)realpart(lp), cpexpr((expptr)rp))),
+                       putassign( imagpart(resp),
+                           mkexpr(OPSLASH, imagpart(lp), cpexpr((expptr)rp)))));
+               break;
+
+       case OPCONV:
+               if( ISCOMPLEX(lp->vtype) )
+                       q = imagpart(lp);
+               else if(rp != NULL)
+                       q = (expptr) realpart(rp);
+               else
+                       q = mkrealcon(TYDREAL, "0");
+               putout (PAIR (
+                       putassign( (expptr)realpart(resp), (expptr)realpart(lp)),
+                       putassign( imagpart(resp), q)));
+               break;
+
+       default:
+               badop("putcx1", opcode);
+       }
+
+       frexpr((expptr)lp);
+       frexpr((expptr)rp);
+       free( (charptr) p );
+       return(resp);
+}
+
+
+
+
+/* Only .EQ. and .NE. may be performed on COMPLEX data, other relations
+   are not defined */
+
+LOCAL expptr putcxcmp(p)
+register expptr p;
+{
+       int opcode;
+       register Addrp lp, rp;
+       expptr q;
+
+       if(p->tag != TEXPR)
+               badtag("putcxcmp", p->tag);
+
+       opcode = p->exprblock.opcode;
+       lp = putcx1(p->exprblock.leftp);
+       rp = putcx1(p->exprblock.rightp);
+
+       q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
+           mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp)),
+           mkexpr(opcode, imagpart(lp), imagpart(rp)) );
+
+       free( (charptr) lp);
+       free( (charptr) rp);
+       free( (charptr) p );
+       if (ISCONST(q))
+               return q;
+       return  putx( fixexpr((Exprp)q) );
+}
+
+/* putch1 -- Forces constants into the literal pool, among other things */
+
+LOCAL Addrp putch1(p)
+register expptr p;
+{
+       Addrp t;
+       expptr e;
+
+       switch(p->tag)
+       {
+       case TCONST:
+               return( putconst((Constp)p) );
+
+       case TADDR:
+               return( (Addrp) p );
+
+       case TEXPR:
+               switch(p->exprblock.opcode)
+               {
+                       expptr q;
+
+               case OPCALL:
+               case OPCCALL:
+
+                       p = putcall(p, &t);
+                       putout (p);
+                       break;
+
+               case OPCONCAT:
+                       t = mktmp(TYCHAR, ICON(lencat(p)));
+                       q = (expptr) cpexpr(p->headblock.vleng);
+                       p = putcat( cpexpr((expptr)t), p );
+                       /* put the correct length on the block */
+                       frexpr(t->vleng);
+                       t->vleng = q;
+                       putout (p);
+                       break;
+
+               case OPCONV:
+                       if(!ISICON(p->exprblock.vleng)
+                           || p->exprblock.vleng->constblock.Const.ci!=1
+                           || ! INT(p->exprblock.leftp->headblock.vtype) )
+                               Fatal("putch1: bad character conversion");
+                       t = mktmp(TYCHAR, ICON(1));
+                       e = mkexpr(OPCONV, (expptr)t, ENULL);
+                       e->headblock.vtype = TYCHAR;
+                       p = putop( mkexpr(OPASSIGN, cpexpr(e), p));
+                       putout (p);
+                       break;
+               default:
+                       badop("putch1", p->exprblock.opcode);
+               }
+               return(t);
+
+       default:
+               badtag("putch1", p->tag);
+       }
+       /* NOT REACHED */ return 0;
+}
+
+
+/* putchop -- Write out a character actual parameter; that is, this is
+   part of a procedure invocation */
+
+Addrp putchop(p)
+expptr p;
+{
+       p = putaddr((expptr)putch1(p));
+       return (Addrp)p;
+}
+
+
+
+
+LOCAL expptr putcheq(p)
+register expptr p;
+{
+       expptr lp, rp;
+       int nbad;
+
+       if(p->tag != TEXPR)
+               badtag("putcheq", p->tag);
+
+       lp = p->exprblock.leftp;
+       rp = p->exprblock.rightp;
+       frexpr(p->exprblock.vleng);
+       free( (charptr) p );
+
+/* If s = t // u, don't bother copying the result, write it directly into
+   this buffer */
+
+       nbad = badchleng(lp) + badchleng(rp);
+       if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT )
+               p = putcat(lp, rp);
+       else if( !nbad
+               && ISONE(lp->headblock.vleng)
+               && ISONE(rp->headblock.vleng) ) {
+               lp = mkexpr(OPCONV, lp, ENULL);
+               rp = mkexpr(OPCONV, rp, ENULL);
+               lp->headblock.vtype = rp->headblock.vtype = TYCHAR;
+               p = putop(mkexpr(OPASSIGN, lp, rp));
+               }
+       else
+               p = putx( call2(TYSUBR, "s_copy", lp, rp) );
+       return p;
+}
+
+
+
+
+LOCAL expptr putchcmp(p)
+register expptr p;
+{
+       expptr lp, rp;
+
+       if(p->tag != TEXPR)
+               badtag("putchcmp", p->tag);
+
+       lp = p->exprblock.leftp;
+       rp = p->exprblock.rightp;
+
+       if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) {
+               lp = mkexpr(OPCONV, lp, ENULL);
+               rp = mkexpr(OPCONV, rp, ENULL);
+               lp->headblock.vtype = rp->headblock.vtype = TYCHAR;
+               }
+       else {
+               lp = call2(TYINT,"s_cmp", lp, rp);
+               rp = ICON(0);
+               }
+       p->exprblock.leftp = lp;
+       p->exprblock.rightp = rp;
+       p = putop(p);
+       return p;
+}
+
+
+
+
+
+/* putcat -- Writes out a concatenation operation.  Two temporary arrays
+   are allocated,   putct1()   is called to initialize them, and then a
+   call to runtime library routine   s_cat()   is inserted.
+
+       This routine generates code which will perform an  (nconc lhs rhs)
+   at runtime.  The runtime funciton does not return a value, the routine
+   that calls this   putcat   must remember the name of   lhs.
+*/
+
+
+LOCAL expptr putcat(lhs0, rhs)
+ expptr lhs0;
+ register expptr rhs;
+{
+       register Addrp lhs = (Addrp)lhs0;
+       int n, tyi;
+       Addrp length_var, string_var;
+       expptr p;
+       static char Writing_concatenation[] = "Writing concatenation";
+
+/* Create the temporary arrays */
+
+       n = ncat(rhs);
+       length_var = mktmpn(n, tyioint, ENULL);
+       string_var = mktmpn(n, TYADDR, ENULL);
+       frtemp((Addrp)cpexpr((expptr)length_var));
+       frtemp((Addrp)cpexpr((expptr)string_var));
+
+/* Initialize the arrays */
+
+       n = 0;
+       /* p1_comment scribbles on its argument, so we
+        * cannot safely pass a string literal here. */
+       p1_comment(Writing_concatenation);
+       putct1(rhs, length_var, string_var, &n);
+
+/* Create the invocation */
+
+       tyi = tyint;
+       tyint = tyioint;        /* for -I2 */
+       p = putx (call4 (TYSUBR, "s_cat",
+                               (expptr)lhs,
+                               (expptr)string_var,
+                               (expptr)length_var,
+                               (expptr)putconst((Constp)ICON(n))));
+       tyint = tyi;
+
+       return p;
+}
+
+
+
+
+
+LOCAL putct1(q, length_var, string_var, ip)
+register expptr q;
+register Addrp length_var, string_var;
+int *ip;
+{
+       int i;
+       Addrp length_copy, string_copy;
+       expptr e;
+       extern int szleng;
+
+       if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT)
+       {
+               putct1(q->exprblock.leftp, length_var, string_var,
+                   ip);
+               putct1(q->exprblock.rightp, length_var, string_var,
+                   ip);
+               frexpr (q -> exprblock.vleng);
+               free ((charptr) q);
+       }
+       else
+       {
+               i = (*ip)++;
+               e = cpexpr(q->headblock.vleng);
+               if (!e)
+                       return; /* error -- character*(*) */
+               length_copy = (Addrp) cpexpr((expptr)length_var);
+               length_copy->memoffset =
+                   mkexpr(OPPLUS,length_copy->memoffset, ICON(i*szleng));
+               string_copy = (Addrp) cpexpr((expptr)string_var);
+               string_copy->memoffset =
+                   mkexpr(OPPLUS, string_copy->memoffset,
+                       ICON(i*typesize[TYADDR]));
+               putout (PAIR (putassign((expptr)length_copy, e),
+                       putassign((expptr)string_copy, addrof((expptr)putch1(q)))));
+       }
+}
+
+/* putaddr -- seems to write out function invocation actual parameters */
+
+LOCAL expptr putaddr(p0)
+ expptr p0;
+{
+       register Addrp p;
+       chainp cp;
+
+       if (!(p = (Addrp)p0))
+               return ENULL;
+
+       if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) )
+       {
+               frexpr((expptr)p);
+               return ENULL;
+       }
+       if (p->isarray && p->memoffset)
+               if (p->uname_tag == UNAM_REF) {
+                       cp = p->memoffset->listblock.listp;
+                       for(; cp; cp = cp->nextp)
+                               cp->datap = (char *)fixtype((tagptr)cp->datap);
+                       }
+               else
+                       p->memoffset = putx(p->memoffset);
+       return (expptr) p;
+}
+
+ LOCAL expptr
+addrfix(e)             /* fudge character string length if it's a TADDR */
+ expptr e;
+{
+       return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e;
+       }
+
+ LOCAL int
+typekludge(ccall, q, at, j)
+ int ccall;
+ register expptr q;
+ Atype *at;
+ int j;        /* alternate type */
+{
+       register int i, k;
+       extern int iocalladdr;
+       register Namep np;
+
+       /* Return value classes:
+        *      < 100 ==> Fortran arg (pointer to type)
+        *      < 200 ==> C arg
+        *      < 300 ==> procedure arg
+        *      < 400 ==> external, no explicit type
+        *      < 500 ==> arg that may turn out to be
+        *                either a variable or a procedure
+        */
+
+       k = q->headblock.vtype;
+       if (ccall) {
+               if (k == TYREAL)
+                       k = TYDREAL;    /* force double for library routines */
+               return k + 100;
+               }
+       if (k == TYADDR)
+               return iocalladdr;
+       i = q->tag;
+       if ((i == TEXPR && q->exprblock.opcode != OPCOMMA_ARG)
+       ||  (i == TADDR && q->addrblock.charleng)
+       ||   i == TCONST)
+               k = TYFTNLEN + 100;
+       else if (i == TADDR)
+           switch(q->addrblock.vclass) {
+               case CLPROC:
+                       if (q->addrblock.uname_tag != UNAM_NAME)
+                               k += 200;
+                       else if ((np = q->addrblock.user.name)->vprocclass
+                                       != PTHISPROC) {
+                               if (k && !np->vimpltype)
+                                       k += 200;
+                               else {
+                                       if (j > 200 && infertypes && j < 300) {
+                                               k = j;
+                                               inferdcl(np, j-200);
+                                               }
+                                       else k = (np->vstg == STGEXT
+                                               ? extsymtab[np->vardesc.varno].extype
+                                               : 0) + 200;
+                                       at->cp = mkchain((char *)np, at->cp);
+                                       }
+                               }
+                       else if (k == TYSUBR)
+                               k += 200;
+                       break;
+
+               case CLUNKNOWN:
+                       if (q->addrblock.vstg == STGARG
+                        && q->addrblock.uname_tag == UNAM_NAME) {
+                               k += 400;
+                               at->cp = mkchain((char *)q->addrblock.user.name,
+                                               at->cp);
+                               }
+               }
+       else if (i == TNAME && q->nameblock.vstg == STGARG) {
+               np = &q->nameblock;
+               switch(np->vclass) {
+                   case CLPROC:
+                       if (!np->vimpltype)
+                               k += 200;
+                       else if (j <= 200 || !infertypes || j >= 300)
+                               k += 300;
+                       else {
+                               k = j;
+                               inferdcl(np, j-200);
+                               }
+                       goto add2chain;
+
+                   case CLUNKNOWN:
+                       /* argument may be a scalar variable or a function */
+                       if (np->vimpltype && j && infertypes
+                       && j < 300) {
+                               inferdcl(np, j % 100);
+                               k = j;
+                               }
+                       else
+                               k += 400;
+
+                       /* to handle procedure args only so far known to be
+                        * external, save a pointer to the symbol table entry...
+                        */
+ add2chain:
+                       at->cp = mkchain((char *)np, at->cp);
+                   }
+               }
+       return k;
+       }
+
+ char *
+Argtype(k, buf)
+ int k;
+ char *buf;
+{
+       if (k < 100) {
+               sprintf(buf, "%s variable", ftn_types[k]);
+               return buf;
+               }
+       if (k < 200) {
+               k -= 100;
+               return ftn_types[k];
+               }
+       if (k < 300) {
+               k -= 200;
+               if (k == TYSUBR)
+                       return ftn_types[TYSUBR];
+               sprintf(buf, "%s function", ftn_types[k]);
+               return buf;
+               }
+       if (k < 400)
+               return "external argument";
+       k -= 400;
+       sprintf(buf, "%s argument", ftn_types[k]);
+       return buf;
+       }
+
+ static void
+atype_squawk(at, msg)
+ Argtypes *at;
+ char *msg;
+{
+       register Atype *a, *ae;
+       warn(msg);
+       for(a = at->atypes, ae = a + at->nargs; a < ae; a++)
+               frchain(&a->cp);
+       at->nargs = -1;
+       if (at->changes & 2 && !at->defined)
+               proc_protochanges++;
+       }
+
+ static char inconsist[] = "inconsistent calling sequences for ";
+
+ void
+bad_atypes(at, fname, i, j, k, here, prev)
+ Argtypes *at;
+ char *fname, *here, *prev;
+ int i, j, k;
+{
+       char buf[208], buf1[32], buf2[32];
+
+       sprintf(buf, "%s%.90s,\n\targ %d: %s%s%s %s.",
+               inconsist, fname, i, here, Argtype(k, buf1),
+               prev, Argtype(j, buf2));
+       atype_squawk(at, buf);
+       }
+
+ int
+type_fixup(at,a,k)
+ Argtypes *at;
+ Atype *a;
+ int k;
+{
+       register struct Entrypoint *ep;
+       if (!infertypes)
+               return 0;
+       for(ep = entries; ep; ep = ep->entnextp)
+               if (at == ep->entryname->arginfo) {
+                       a->type = k % 100;
+                       return proc_argchanges = 1;
+                       }
+       return 0;
+       }
+
+
+ void
+save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type, zap)
+ chainp arglist;
+ Argtypes **at0, **at1;
+ int ccall, stg, nchargs, type, zap;
+ char *fname;
+{
+       Argtypes *at;
+       chainp cp;
+       int i, i0, j, k, nargs, nbad, *t, *te;
+       Atype *atypes;
+       expptr q;
+       char buf[208], buf1[32], buf2[32];
+       static int initargs[4] = {TYCOMPLEX, TYDCOMPLEX, TYCHAR, TYFTNLEN+100};
+       static int *init_ap[TYSUBR+1] = {0,0,0,0,0,0,0,
+#ifdef TYQUAD
+                                                       0,
+#endif
+                               initargs, initargs+1,0,0,0,initargs+2};
+       extern int init_ac[TYSUBR+1];
+
+       i0 = init_ac[type];
+       t = init_ap[type];
+       te = t + i0;
+       if (at = *at0) {
+               *at1 = at;
+               nargs = at->nargs;
+               if (nargs < 0 && type && at->changes & 2 && !at->defined)
+                       --proc_protochanges;
+               if (at->dnargs >= 0 && zap != 2)
+                       type = 0;
+               if (nargs < 0) { /* inconsistent usage seen */
+                       if (type)
+                               goto newlist;
+                       return;
+                       }
+               atypes = at->atypes;
+               i = nchargs;
+               for(nbad = 0; t < te; atypes++) {
+                       if (++i > nargs) {
+ toomany:
+                               i = nchargs + i0;
+                               for(cp = arglist; cp; cp = cp->nextp)
+                                       i++;
+ toofew:
+                               switch(zap) {
+                                       case 2: zap = 6; break;
+                                       case 1: if (at->defined & 4)
+                                                       return;
+                                       }
+                               sprintf(buf,
+               "%s%.90s:\n\there %d, previously %d args and string lengths.",
+                                       inconsist, fname, i, nargs);
+                               atype_squawk(at, buf);
+                               if (type)
+                                       goto newlist;
+                               return;
+                               }
+                       j = atypes->type;
+                       k = *t++;
+                       if (j != k)
+                               goto badtypes;
+                       }
+               for(cp = arglist; cp; atypes++, cp = cp->nextp) {
+                       if (++i > nargs)
+                               goto toomany;
+                       j = atypes->type;
+                       if (!(q = (expptr)cp->datap))
+                               continue;
+                       k = typekludge(ccall, q, atypes, j);
+                       if (k >= 300 || k == j)
+                               continue;
+                       if (j >= 300) {
+                               if (k >= 200) {
+                                       if (k == TYUNKNOWN + 200)
+                                               continue;
+                                       if (j % 100 != k - 200
+                                        && k != TYSUBR + 200
+                                        && j != TYUNKNOWN + 300
+                                        && !type_fixup(at,atypes,k))
+                                               goto badtypes;
+                                       }
+                               else if (j % 100 % TYSUBR != k % TYSUBR
+                                               && !type_fixup(at,atypes,k))
+                                       goto badtypes;
+                               }
+                       else if (k < 200 || j < 200)
+                               if (j) {
+                                       if (k == TYUNKNOWN
+                                        && q->tag == TNAME
+                                        && q->nameblock.vinfproc) {
+                                               q->nameblock.vdcldone = 0;
+                                               impldcl((Namep)q);
+                                               }
+                                       goto badtypes;
+                                       }
+                               else ; /* fall through to update */
+                       else if (k == TYUNKNOWN+200)
+                               continue;
+                       else if (j != TYUNKNOWN+200)
+                               {
+ badtypes:
+                               if (++nbad == 1)
+                                       bad_atypes(at, fname, i, j, k, "here ",
+                                               ", previously");
+                               else
+                                       fprintf(stderr,
+                                        "\targ %d: here %s, previously %s.\n",
+                                               i, Argtype(k,buf1),
+                                               Argtype(j,buf2));
+                               continue;
+                               }
+                       /* We've subsequently learned the right type,
+                          as in the call on zoo below...
+
+                               subroutine foo(x, zap)
+                               external zap
+                               call goo(zap)
+                               x = zap(3)
+                               call zoo(zap)
+                               end
+                        */
+                       if (!nbad) {
+                               atypes->type = k;
+                               at->changes |= 1;
+                               }
+                       }
+               if (i < nargs)
+                       goto toofew;
+               if (nbad) {
+                       if (type) {
+                               /* we're defining the procedure */
+                               t = init_ap[type];
+                               te = t + i0;
+                               proc_argchanges = 1;
+                               goto newlist;
+                               }
+                       return;
+                       }
+               if (zap == 1 && (at->changes & 5) != 5)
+                       at->changes = 0;
+               return;
+               }
+ newlist:
+       i = i0 + nchargs;
+       for(cp = arglist; cp; cp = cp->nextp)
+               i++;
+       k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
+       *at0 = *at1 = at = stg == STGEXT ? (Argtypes *)gmem(k,1)
+                                        : (Argtypes *) mem(k,1);
+       at->dnargs = at->nargs = i;
+       at->defined = zap & 6;
+       at->changes = type ? 0 : 4;
+       atypes = at->atypes;
+       for(; t < te; atypes++) {
+               atypes->type = *t++;
+               atypes->cp = 0;
+               }
+       for(cp = arglist; cp; atypes++, cp = cp->nextp) {
+               atypes->cp = 0;
+               atypes->type = (q = (expptr)cp->datap)
+                       ? typekludge(ccall, q, atypes, 0)
+                       : 0;
+               }
+       for(; --nchargs >= 0; atypes++) {
+               atypes->type = TYFTNLEN + 100;
+               atypes->cp = 0;
+               }
+       }
+
+ void
+saveargtypes(p)                /* for writing prototypes */
+ register Exprp p;
+{
+       Addrp a;
+       Argtypes **at0, **at1;
+       Namep np;
+       chainp arglist;
+       expptr rp;
+       Extsym *e;
+       char *fname;
+
+       a = (Addrp)p->leftp;
+       switch(a->vstg) {
+               case STGEXT:
+                       switch(a->uname_tag) {
+                               case UNAM_EXTERN:       /* e.g., sqrt() */
+                                       e = extsymtab + a->memno;
+                                       at0 = at1 = &e->arginfo;
+                                       fname = e->fextname;
+                                       break;
+                               case UNAM_NAME:
+                                       np = a->user.name;
+                                       at0 = &extsymtab[np->vardesc.varno].arginfo;
+                                       at1 = &np->arginfo;
+                                       fname = np->fvarname;
+                                       break;
+                               default:
+                                       goto bug;
+                               }
+                       break;
+               case STGARG:
+                       if (a->uname_tag != UNAM_NAME)
+                               goto bug;
+                       np = a->user.name;
+                       at0 = at1 = &np->arginfo;
+                       fname = np->fvarname;
+                       break;
+               default:
+        bug:
+                       Fatal("Confusion in saveargtypes");
+               }
+       rp = p->rightp;
+       arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0;
+       save_argtypes(arglist, at0, at1, p->opcode == OPCCALL,
+               fname, a->vstg, 0, 0, 0);
+       }
+
+/* putcall - fix up the argument list, and write out the invocation.   p
+   is expected to be initialized and point to an OPCALL or OPCCALL
+   expression.  The return value is a pointer to a temporary holding the
+   result of a COMPLEX or CHARACTER operation, or NULL. */
+
+LOCAL expptr putcall(p0, temp)
+ expptr p0;
+ Addrp *temp;
+{
+    register Exprp p = (Exprp)p0;
+    chainp arglist;            /* Pointer to actual arguments, if any */
+    chainp charsp;             /* List of copies of the variables which
+                                  hold the lengths of character
+                                  parameters (other than procedure
+                                  parameters) */
+    chainp cp;                 /* Iterator over argument lists */
+    register expptr q;         /* Pointer to the current argument */
+    Addrp fval;                        /* Function return value */
+    int type;                  /* type of the call - presumably this was
+                                  set elsewhere */
+    int byvalue;               /* True iff we don't want to massage the
+                                  parameter list, since we're calling a C
+                                  library routine */
+    char *s;
+    extern struct Listblock *mklist();
+
+    type = p -> vtype;
+    charsp = NULL;
+    byvalue =  (p->opcode == OPCCALL);
+
+/* Verify the actual parameters */
+
+    if (p == (Exprp) NULL)
+       err ("putcall:  NULL call expression");
+    else if (p -> tag != TEXPR)
+       erri ("putcall:  expected TEXPR, got '%d'", p -> tag);
+
+/* Find the argument list */
+
+    if(p->rightp && p -> rightp -> tag == TLIST)
+       arglist = p->rightp->listblock.listp;
+    else
+       arglist = NULL;
+
+/* Count the number of explicit arguments, including lengths of character
+   variables */
+
+    for(cp = arglist ; cp ; cp = cp->nextp)
+       if(!byvalue) {
+           q = (expptr) cp->datap;
+           if( ISCONST(q) )
+           {
+
+/* Even constants are passed by reference, so we need to put them in the
+   literal table */
+
+               q = (expptr) putconst((Constp)q);
+               cp->datap = (char *) q;
+           }
+
+/* Save the length expression of character variables (NOT character
+   procedures) for the end of the argument list */
+
+           if( ISCHAR(q) &&
+               (q->headblock.vclass != CLPROC
+               || q->headblock.vstg == STGARG
+                       && q->tag == TADDR
+                       && q->addrblock.uname_tag == UNAM_NAME
+                       && q->addrblock.user.name->vprocclass == PTHISPROC))
+           {
+               p0 = cpexpr(q->headblock.vleng);
+               charsp = mkchain((char *)p0, charsp);
+               if (q->headblock.vclass == CLUNKNOWN
+                && q->headblock.vstg == STGARG)
+                       q->addrblock.user.name->vpassed = 1;
+               else if (q->tag == TADDR
+                               && q->addrblock.uname_tag == UNAM_CONST)
+                       p0->constblock.Const.ci
+                               += q->addrblock.user.Const.ccp1.blanks;
+           }
+       }
+    charsp = revchain(charsp);
+
+/* If the routine is a CHARACTER function ... */
+
+    if(type == TYCHAR)
+    {
+       if( ISICON(p->vleng) )
+       {
+
+/* Allocate a temporary to hold the return value of the function */
+
+           fval = mktmp(TYCHAR, p->vleng);
+       }
+       else    {
+               err("adjustable character function");
+               if (temp)
+                       *temp = 0;
+               return 0;
+               }
+    }
+
+/* If the routine is a COMPLEX function ... */
+
+    else if( ISCOMPLEX(type) )
+       fval = mktmp(type, ENULL);
+    else
+       fval = NULL;
+
+/* Write the function name, without taking its address */
+
+    p -> leftp = putx(fixtype(putaddr(p->leftp)));
+
+    if(fval)
+    {
+       chainp prepend;
+
+/* Prepend a copy of the function return value buffer out as the first
+   argument. */
+
+       prepend = mkchain((char *)putx(putaddr(cpexpr((expptr)fval))), arglist);
+
+/* If it's a character function, also prepend the length of the result */
+
+       if(type==TYCHAR)
+       {
+
+           prepend->nextp = mkchain((char *)putx(mkconv(TYLENG,
+                                       p->vleng)), arglist);
+       }
+       if (!(q = p->rightp))
+               p->rightp = q = (expptr)mklist(CHNULL);
+       q->listblock.listp = prepend;
+    }
+
+/* Scan through the fortran argument list */
+
+    for(cp = arglist ; cp ; cp = cp->nextp)
+    {
+       q = (expptr) (cp->datap);
+       if (q == ENULL)
+           err ("putcall:  NULL argument");
+
+/* call putaddr only when we've got a parameter for a C routine or a
+   memory resident parameter */
+
+       if (q -> tag == TCONST && !byvalue)
+           q = (expptr) putconst ((Constp)q);
+
+       if(q->tag==TADDR && (byvalue || q->addrblock.vstg!=STGREG) ) {
+               if (q->addrblock.parenused
+                && !byvalue && q->headblock.vtype != TYCHAR)
+                       goto make_copy;
+               cp->datap = (char *)putaddr(q);
+               }
+       else if( ISCOMPLEX(q->headblock.vtype) )
+           cp -> datap = (char *) putx (fixtype(putcxop(q)));
+       else if (ISCHAR(q) )
+           cp -> datap = (char *) putx (fixtype((expptr)putchop(q)));
+       else if( ! ISERROR(q) )
+       {
+           if(byvalue
+           || q->tag == TEXPR && q->exprblock.opcode == OPCHARCAST)
+               cp -> datap = (char *) putx(q);
+           else {
+               expptr t, t1;
+
+/* If we've got a register parameter, or (maybe?) a constant, save it in a
+   temporary first */
+ make_copy:
+               t = (expptr) mktmp(q->headblock.vtype, q->headblock.vleng);
+
+/* Assign to temporary variables before invoking the subroutine or
+   function */
+
+               t1 = putassign( cpexpr(t), q );
+               if (doin_setbound)
+                       t = mkexpr(OPCOMMA_ARG, t1, t);
+               else
+                       putout(t1);
+               cp -> datap = (char *) t;
+           } /* else */
+       } /* if !ISERROR(q) */
+    }
+
+/* Now adjust the lengths of the CHARACTER parameters */
+
+    for(cp = charsp ; cp ; cp = cp->nextp)
+       cp->datap = (char *)addrfix(putx(
+                       /* in case MAIN has a character*(*)... */
+                       (s = cp->datap) ? mkconv(TYLENG,(expptr)s)
+                                        : ICON(0)));
+
+/* ... and add them to the end of the argument list */
+
+    hookup (arglist, charsp);
+
+/* Return the name of the temporary used to hold the results, if any was
+   necessary. */
+
+    if (temp) *temp = fval;
+    else frexpr ((expptr)fval);
+
+    saveargtypes(p);
+
+    return (expptr) p;
+}
+
+
+
+/* putmnmx -- Put min or max.   p   must point to an EXPR, not just a
+   CONST */
+
+LOCAL expptr putmnmx(p)
+register expptr p;
+{
+       int op, op2, type;
+       expptr arg, qp, temp;
+       chainp p0, p1;
+       Addrp sp, tp;
+       char comment_buf[80];
+       char *what;
+
+       if(p->tag != TEXPR)
+               badtag("putmnmx", p->tag);
+
+       type = p->exprblock.vtype;
+       op = p->exprblock.opcode;
+       op2 = op == OPMIN ? OPMIN2 : OPMAX2;
+       p0 = p->exprblock.leftp->listblock.listp;
+       free( (charptr) (p->exprblock.leftp) );
+       free( (charptr) p );
+
+       /* special case for two addressable operands */
+
+       if (addressable((expptr)p0->datap)
+        && (p1 = p0->nextp)
+        && addressable((expptr)p1->datap)
+        && !p1->nextp) {
+               if (type == TYREAL && forcedouble)
+                       op2 = op == OPMIN ? OPDMIN : OPDMAX;
+               p = mkexpr(op2, mkconv(type, cpexpr((expptr)p0->datap)),
+                               mkconv(type, cpexpr((expptr)p1->datap)));
+               frchain(&p0);
+               return p;
+               }
+
+       /* general case */
+
+       sp = mktmp(type, ENULL);
+
+/* We only need a second temporary if the arg list has an unaddressable
+   value */
+
+       tp = (Addrp) NULL;
+       qp = ENULL;
+       for (p1 = p0 -> nextp; p1; p1 = p1 -> nextp)
+               if (!addressable ((expptr) p1 -> datap)) {
+                       tp = mktmp(type, ENULL);
+                       qp = mkexpr(op2, cpexpr((expptr)sp), cpexpr((expptr)tp));
+                       qp = fixexpr((Exprp)qp);
+                       break;
+               } /* if */
+
+/* Now output the appropriate number of assignments and comparisons.  Min
+   and max are implemented by the simple O(n) algorithm:
+
+       min (a, b, c, d) ==>
+       { <type> t1, t2;
+
+           t1 = a;
+           t2 = b; t1 = (t1 < t2) ? t1 : t2;
+           t2 = c; t1 = (t1 < t2) ? t1 : t2;
+           t2 = d; t1 = (t1 < t2) ? t1 : t2;
+       }
+*/
+
+       if (!doin_setbound) {
+               switch(op) {
+                       case OPLT:
+                       case OPMIN:
+                       case OPDMIN:
+                       case OPMIN2:
+                               what = "IN";
+                               break;
+                       default:
+                               what = "AX";
+                       }
+               sprintf (comment_buf, "Computing M%s", what);
+               p1_comment (comment_buf);
+               }
+
+       p1 = p0->nextp;
+       temp = (expptr)p0->datap;
+       if (addressable(temp) && addressable((expptr)p1->datap)) {
+               p = mkconv(type, cpexpr(temp));
+               arg = mkconv(type, cpexpr((expptr)p1->datap));
+               temp = mkexpr(op2, p, arg);
+               if (!ISCONST(temp))
+                       temp = fixexpr((Exprp)temp);
+               p1 = p1->nextp;
+               }
+       p = putassign (cpexpr((expptr)sp), temp);
+
+       for(; p1 ; p1 = p1->nextp)
+       {
+               if (addressable ((expptr) p1 -> datap)) {
+                       arg = mkconv(type, cpexpr((expptr)p1->datap));
+                       temp = mkexpr(op2, cpexpr((expptr)sp), arg);
+                       temp = fixexpr((Exprp)temp);
+               } else {
+                       temp = (expptr) cpexpr (qp);
+                       p = mkexpr(OPCOMMA, p,
+                               putassign(cpexpr((expptr)tp), (expptr)p1->datap));
+               } /* else */
+
+               if(p1->nextp)
+                       p = mkexpr(OPCOMMA, p,
+                               putassign(cpexpr((expptr)sp), temp));
+               else {
+                       if (type == TYREAL && forcedouble)
+                               temp->exprblock.opcode =
+                                       op == OPMIN ? OPDMIN : OPDMAX;
+                       if (doin_setbound)
+                               p = mkexpr(OPCOMMA, p, temp);
+                       else {
+                               putout (p);
+                               p = putx(temp);
+                               }
+                       if (qp)
+                               frexpr (qp);
+               } /* else */
+       } /* for */
+
+       frchain( &p0 );
+       return p;
+}
+
+
+ void
+putwhile(p)
+ expptr p;
+{
+       long where;
+       int k, n;
+
+       if (wh_next >= wh_last)
+               {
+               k = wh_last - wh_first;
+               n = k + 100;
+               wh_next = mem(n,0);
+               wh_last = wh_first + n;
+               if (k)
+                       memcpy(wh_next, wh_first, k);
+               wh_first =  wh_next;
+               wh_next += k;
+               wh_last = wh_first + n;
+               }
+       p1put(P1_WHILE1START);
+       where = ftell(pass1_file);
+       if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype)))
+               {
+               if(k != TYERROR)
+                       err("non-logical expression in DO WHILE statement");
+               }
+       else    {
+               p = putx(p);
+               *wh_next++ = ftell(pass1_file) > where;
+               p1put(P1_WHILE2START);
+               p1_expr(p);
+               }
+       }

diff --git a/usr.bin/f2c/readme b/usr.bin/f2c/readme
new file mode 100644 (file)
index 0000000..ed88aaa
--- /dev/null
+++ b/usr.bin/f2c/readme
@@ -0,0 +1,94 @@
+Type "make" to check the validity of the f2c source and compile f2c.
+
+On a PC, you may need to compile xsum.c with -DMSDOS (i.e., with
+MSDOS #defined).  If your system does not understand ANSI/ISO C
+syntax (i.e., if you have a K&R C compiler), compile xsum.c with
+-DKR_headers.  (Eventually this will also be required of the f2c
+source proper.)
+
+On non-Unix systems where files have separate binary and text modes,
+you may need to "make xsumr.out" rather than "make xsum.out".
+
+If (in accordance with what follows) you need to modify the makefile
+or any of the source files, first issue a "make xsum.out" (or, if
+appropriate, "make xsumr.out") to check the validity of the f2c source,
+then make your changes, then type "make f2c".
+
+The file usignal.h is for the benefit of strictly ANSI include files
+on a UNIX system -- the ANSI signal.h does not define SIGHUP or SIGQUIT.
+You may need to modify usignal.h if you are not running f2c on a UNIX
+system.
+
+Should you get the message "xsum0.out xsum1.out differ", see what lines
+are different (`diff xsum0.out xsum1.out`) and ask netlib to send you
+the files in question "from f2c/src".  For example, if exec.c and
+expr.c have incorrect check sums, you would send netlib the message
+       send exec.c expr.c from f2c/src
+
+On some systems, the malloc and free in malloc.c let f2c run faster
+than do the standard malloc and free.  Other systems cannot tolerate
+redefinition of malloc and free.  If yours is such a system, you may
+either modify the makefile appropriately, or simply execute
+       cc -c -DCRAY malloc.c
+before typing "make".  Still other systems have a -lmalloc that
+provides performance competitive with that from malloc.c; you may
+wish to compare the two on your system.
+
+On some BSD systems, you may need to create a file named "string.h"
+whose single line is
+#include <strings.h>
+you may need to add " -Dstrchr=index" to the "CFLAGS =" assignment
+in the makefile, and you may need to add " memset.o" to the "OBJECTS ="
+assignment in the makefile -- see the comments in memset.c .
+
+For non-UNIX systems, you may need to change some things in sysdep.c,
+such as the choice of intermediate file names.
+
+On some systems, you may need to modify parts of sysdep.h (which is
+included by defs.h).  In particular, for Sun 4.1 systems and perhaps
+some others, you need to comment out the typedef of size_t.  For some
+systems (e.g., IRIX 4.0.1 and AIX) it is better to add
+#define ANSI_Libraries
+to the beginning of sysdep.h (or to supply -DANSI_Libraries in the
+makefile).
+
+Alas, some systems #define __STDC__ but do not provide a true standard
+(ANSI or ISO) C environment, e.g. do not provide stdlib.h .  If yours
+is such a system, then (a) you should complain loudly to your vendor
+about __STDC__ being erroneously defined, and (b) you should insert
+#undef __STDC__
+at the beginning of sysdep.h .  You may need to make other adjustments.
+
+For some non-ANSI versions of stdio, you must change the values given
+to binread and binwrite in sysdep.c from "rb" and "wb" to "r" and "w".
+You may need to make this change if you run f2c and get an error
+message of the form
+       Compiler error ... cannot open intermediate file ...
+
+On many systems, it is best to combine libF77 and libI77 into a single
+library, say libf2c, as suggested in "readme from f2c".  If you do this,
+then you should adjust the definition of link_msg in sysdep.c
+appropriately (e.g., replacing "-lF77 -lI77" by "-lf2c").
+
+Some older C compilers object to
+       typedef void (*foo)();
+or to
+       typedef void zap;
+       zap (*foo)();
+If yours is such a compiler, change the definition of VOID in
+f2c.h from void to int.
+
+For convenience with systems that use control-Z to denote end-of-file,
+f2c treats control-Z characters (ASCII 26, '\x1a') that appear at the
+beginning of a line as an end-of-file indicator.  You can disable this
+test by compiling lex.c with NO_EOF_CHAR_CHECK #defined, or can
+change control-Z to some other character by #defining EOF_CHAR to
+be the desired value.
+
+Please send bug reports to dmg@research.att.com .  The old index file
+(now called "readme" due to unfortunate changes in netlib conventions:
+"send readme from f2c") will report recent changes in the recent-change
+log at its end; all changes will be shown in the "changes" file
+("send changes from f2c").  To keep current source, you will need to
+request xsum0.out and version.c, in addition to the changed source
+files.

diff --git a/usr.bin/f2c/sysdep.c b/usr.bin/f2c/sysdep.c
new file mode 100644 (file)
index 0000000..81bc5af
--- /dev/null
+++ b/usr.bin/f2c/sysdep.c
@@ -0,0 +1,442 @@
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+#include "defs.h"
+#include "usignal.h"
+
+char binread[] = "rb", textread[] = "r";
+char binwrite[] = "wb", textwrite[] = "w";
+char *c_functions      = "c_functions";
+char *coutput          = "c_output";
+char *initfname                = "raw_data";
+char *initbname                = "raw_data.b";
+char *blkdfname                = "block_data";
+char *p1_file          = "p1_file";
+char *p1_bakfile       = "p1_file.BAK";
+char *sortfname                = "init_file";
+char *proto_fname      = "proto_file";
+
+char link_msg[]                = "-lf2c -lm"; /* was "-lF77 -lI77 -lm -lc"; */
+
+#ifndef TMPDIR
+#ifdef MSDOS
+#define TMPDIR ""
+#else
+#define TMPDIR "/tmp"
+#endif
+#endif
+
+char *tmpdir = TMPDIR;
+
+ void
+Un_link_all(cdelete)
+{
+       if (!debugflag) {
+               unlink(c_functions);
+               unlink(initfname);
+               unlink(p1_file);
+               unlink(sortfname);
+               unlink(blkdfname);
+               if (cdelete && coutput)
+                       unlink(coutput);
+               }
+       }
+
+ void
+set_tmp_names()
+{
+       int k;
+       if (debugflag == 1)
+               return;
+       k = strlen(tmpdir) + 16;
+       c_functions = (char *)ckalloc(7*k);
+       initfname = c_functions + k;
+       initbname = initfname + k;
+       blkdfname = initbname + k;
+       p1_file = blkdfname + k;
+       p1_bakfile = p1_file + k;
+       sortfname = p1_bakfile + k;
+       {
+#ifdef MSDOS
+       char buf[64], *s, *t;
+       if (!*tmpdir || *tmpdir == '.' && !tmpdir[1])
+               t = "";
+       else {
+               /* substitute \ for / to avoid confusion with a
+                * switch indicator in the system("sort ...")
+                * call in formatdata.c
+                */
+               for(s = tmpdir, t = buf; *s; s++, t++)
+                       if ((*t = *s) == '/')
+                               *t = '\\';
+               if (t[-1] != '\\')
+                       *t++ = '\\';
+               *t = 0;
+               t = buf;
+               }
+       sprintf(c_functions, "%sf2c_func", t);
+       sprintf(initfname, "%sf2c_rd", t);
+       sprintf(blkdfname, "%sf2c_blkd", t);
+       sprintf(p1_file, "%sf2c_p1f", t);
+       sprintf(p1_bakfile, "%sf2c_p1fb", t);
+       sprintf(sortfname, "%sf2c_sort", t);
+#else
+       int pid = getpid();
+       sprintf(c_functions, "%s/f2c%d_func", tmpdir, pid);
+       sprintf(initfname, "%s/f2c%d_rd", tmpdir, pid);
+       sprintf(blkdfname, "%s/f2c%d_blkd", tmpdir, pid);
+       sprintf(p1_file, "%s/f2c%d_p1f", tmpdir, pid);
+       sprintf(p1_bakfile, "%s/f2c%d_p1fb", tmpdir, pid);
+       sprintf(sortfname, "%s/f2c%d_sort", tmpdir, pid);
+#endif
+       sprintf(initbname, "%s.b", initfname);
+       }
+       if (debugflag)
+               fprintf(diagfile, "%s %s %s %s %s %s\n", c_functions,
+                       initfname, blkdfname, p1_file, p1_bakfile, sortfname);
+       }
+
+ char *
+c_name(s,ft)char *s;
+{
+       char *b, *s0;
+       int c;
+
+       b = s0 = s;
+       while(c = *s++)
+               if (c == '/')
+                       b = s;
+       if (--s < s0 + 3 || s[-2] != '.'
+                        || ((c = *--s) != 'f' && c != 'F')) {
+               infname = s0;
+               Fatal("file name must end in .f or .F");
+               }
+       *s = ft;
+       b = copys(b);
+       *s = c;
+       return b;
+       }
+
+ static void
+killed(sig)
+{
+       signal(SIGINT, SIG_IGN);
+#ifdef SIGQUIT
+       signal(SIGQUIT, SIG_IGN);
+#endif
+#ifdef SIGHUP
+       signal(SIGHUP, SIG_IGN);
+#endif
+       signal(SIGTERM, SIG_IGN);
+       Un_link_all(1);
+       exit(126);
+       }
+
+ static void
+sig1catch(sig)
+{
+       if (signal(sig, SIG_IGN) != SIG_IGN)
+               signal(sig, killed);
+       }
+
+ static void
+flovflo(sig)
+{
+       Fatal("floating exception during constant evaluation; cannot recover");
+       /* vax returns a reserved operand that generates
+          an illegal operand fault on next instruction,
+          which if ignored causes an infinite loop.
+       */
+       signal(SIGFPE, flovflo);
+}
+
+ void
+sigcatch(sig)
+{
+       sig1catch(SIGINT);
+#ifdef SIGQUIT
+       sig1catch(SIGQUIT);
+#endif
+#ifdef SIGHUP
+       sig1catch(SIGHUP);
+#endif
+       sig1catch(SIGTERM);
+       signal(SIGFPE, flovflo);  /* catch overflows */
+       }
+
+
+dofork()
+{
+#ifdef MSDOS
+       Fatal("Only one Fortran input file allowed under MS-DOS");
+#else
+       int pid, status, w;
+       extern int retcode;
+
+       if (!(pid = fork()))
+               return 1;
+       if (pid == -1)
+               Fatal("bad fork");
+       while((w = wait(&status)) != pid)
+               if (w == -1)
+                       Fatal("bad wait code");
+       retcode |= status >> 8;
+#endif
+       return 0;
+       }
+
+/* Initialization of tables that change with the character set... */
+
+char escapes[Table_size];
+
+#ifdef non_ASCII
+char *str_fmt[Table_size];
+static char *str0fmt[127] = { /*}*/
+#else
+char *str_fmt[Table_size] = {
+#endif
+ "\\000", "\\001", "\\002", "\\003", "\\004", "\\005", "\\006", "\\007",
+   "\\b",   "\\t",   "\\n", "\\013",   "\\f",   "\\r", "\\016", "\\017",
+ "\\020", "\\021", "\\022", "\\023", "\\024", "\\025", "\\026", "\\027",
+ "\\030", "\\031", "\\032", "\\033", "\\034", "\\035", "\\036", "\\037",
+     " ",     "!",  "\\\"",     "#",     "$",     "%%",    "&",     "'",
+     "(",     ")",     "*",     "+",     ",",     "-",     ".",     "/",
+     "0",     "1",     "2",     "3",     "4",     "5",     "6",     "7",
+     "8",     "9",     ":",     ";",     "<",     "=",     ">",     "?",
+     "@",     "A",     "B",     "C",     "D",     "E",     "F",     "G",
+     "H",     "I",     "J",     "K",     "L",     "M",     "N",     "O",
+     "P",     "Q",     "R",     "S",     "T",     "U",     "V",     "W",
+     "X",     "Y",     "Z",     "[",  "\\\\",     "]",     "^",     "_",
+     "`",     "a",     "b",     "c",     "d",     "e",     "f",     "g",
+     "h",     "i",     "j",     "k",     "l",     "m",     "n",     "o",
+     "p",     "q",     "r",     "s",     "t",     "u",     "v",     "w",
+     "x",     "y",     "z",     "{",     "|",     "}",     "~"
+     };
+
+#ifdef non_ASCII
+char *chr_fmt[Table_size];
+static char *chr0fmt[127] = {  /*}*/
+#else
+char *chr_fmt[Table_size] = {
+#endif
+   "\\0",   "\\1",   "\\2",   "\\3",   "\\4",   "\\5",   "\\6",   "\\7",
+   "\\b",   "\\t",   "\\n",  "\\13",   "\\f",   "\\r",  "\\16",  "\\17",
+  "\\20",  "\\21",  "\\22",  "\\23",  "\\24",  "\\25",  "\\26",  "\\27",
+  "\\30",  "\\31",  "\\32",  "\\33",  "\\34",  "\\35",  "\\36",  "\\37",
+     " ",     "!",    "\"",     "#",     "$",     "%%",    "&",   "\\'",
+     "(",     ")",     "*",     "+",     ",",     "-",     ".",     "/",
+     "0",     "1",     "2",     "3",     "4",     "5",     "6",     "7",
+     "8",     "9",     ":",     ";",     "<",     "=",     ">",     "?",
+     "@",     "A",     "B",     "C",     "D",     "E",     "F",     "G",
+     "H",     "I",     "J",     "K",     "L",     "M",     "N",     "O",
+     "P",     "Q",     "R",     "S",     "T",     "U",     "V",     "W",
+     "X",     "Y",     "Z",     "[",  "\\\\",     "]",     "^",     "_",
+     "`",     "a",     "b",     "c",     "d",     "e",     "f",     "g",
+     "h",     "i",     "j",     "k",     "l",     "m",     "n",     "o",
+     "p",     "q",     "r",     "s",     "t",     "u",     "v",     "w",
+     "x",     "y",     "z",     "{",     "|",     "}",     "~"
+     };
+
+ void
+fmt_init()
+{
+       static char *str1fmt[6] =
+               { "\\b", "\\t", "\\n", "\\f", "\\r", "\\%03o" };
+       register int i, j;
+       register char *s;
+
+       /* str_fmt */
+
+#ifdef non_ASCII
+       i = 0;
+#else
+       i = 127;
+#endif
+       for(; i < Table_size; i++)
+               str_fmt[i] = "\\%03o";
+#ifdef non_ASCII
+       for(i = 32; i < 127; i++) {
+               s = str0fmt[i];
+               str_fmt[*(unsigned char *)s] = s;
+               }
+       str_fmt['"'] = "\\\"";
+#else
+       if (Ansi == 1)
+               str_fmt[7] = chr_fmt[7] = "\\a";
+#endif
+
+       /* chr_fmt */
+
+#ifdef non_ASCII
+       for(i = 0; i < 32; i++)
+               chr_fmt[i] = chr0fmt[i];
+#else
+       i = 127;
+#endif
+       for(; i < Table_size; i++)
+               chr_fmt[i] = "\\%o";
+#ifdef non_ASCII
+       for(i = 32; i < 127; i++) {
+               s = chr0fmt[i];
+               j = *(unsigned char *)s;
+               if (j == '\\')
+                       j = *(unsigned char *)(s+1);
+               chr_fmt[j] = s;
+               }
+#endif
+
+       /* escapes (used in lex.c) */
+
+       for(i = 0; i < Table_size; i++)
+               escapes[i] = i;
+       for(s = "btnfr0", i = 0; i < 6; i++)
+               escapes[*(unsigned char *)s++] = "\b\t\n\f\r"[i];
+       /* finish str_fmt and chr_fmt */
+
+       if (Ansi)
+               str1fmt[5] = "\\v";
+       if ('\v' == 'v') { /* ancient C compiler */
+               str1fmt[5] = "v";
+#ifndef non_ASCII
+               escapes['v'] = 11;
+#endif
+               }
+       else
+               escapes['v'] = '\v';
+       for(s = "\b\t\n\f\r\v", i = 0; j = *(unsigned char *)s++;)
+               str_fmt[j] = chr_fmt[j] = str1fmt[i++];
+       /* '\v' = 11 for both EBCDIC and ASCII... */
+       chr_fmt[11] = Ansi ? "\\v" : "\\13";
+       }
+
+
+
+/* Unless SYSTEM_SORT is defined, the following gives a simple
+ * in-core version of dsort().  On Fortran source with huge DATA
+ * statements, the in-core version may exhaust the available memory,
+ * in which case you might either recompile this source file with
+ * SYSTEM_SORT defined (if that's reasonable on your system), or
+ * replace the dsort below with a more elaborate version that
+ * does a merging sort with the help of auxiliary files.
+ */
+
+#ifdef SYSTEM_SORT
+
+dsort(from, to)
+ char *from, *to;
+{
+       char buf[200];
+       sprintf(buf, "sort <%s >%s", from, to);
+       return system(buf) >> 8;
+       }
+#else
+
+ static int
+compare(a,b)
+ char *a, *b;
+{ return strcmp(*(char **)a, *(char **)b); }
+
+dsort(from, to)
+ char *from, *to;
+{
+       extern char *Alloc();
+
+       struct Memb {
+               struct Memb *next;
+               int n;
+               char buf[32000];
+               };
+       typedef struct Memb memb;
+       memb *mb, *mb1;
+       register char *x, *x0, *xe;
+       register int c, n;
+       FILE *f;
+       char **z, **z0;
+       int nn = 0;
+
+       f = opf(from, textread);
+       mb = (memb *)Alloc(sizeof(memb));
+       mb->next = 0;
+       x0 = x = mb->buf;
+       xe = x + sizeof(mb->buf);
+       n = 0;
+       for(;;) {
+               c = getc(f);
+               if (x >= xe && (c != EOF || x != x0)) {
+                       if (!n)
+                               return 126;
+                       nn += n;
+                       mb->n = n;
+                       mb1 = (memb *)Alloc(sizeof(memb));
+                       mb1->next = mb;
+                       mb = mb1;
+                       memcpy(mb->buf, x0, n = x-x0);
+                       x0 = mb->buf;
+                       x = x0 + n;
+                       xe = x0 + sizeof(mb->buf);
+                       n = 0;
+                       }
+               if (c == EOF)
+                       break;
+               if (c == '\n') {
+                       ++n;
+                       *x++ = 0;
+                       x0 = x;
+                       }
+               else
+                       *x++ = c;
+               }
+       clf(&f, from, 1);
+       f = opf(to, textwrite);
+       if (x > x0) { /* shouldn't happen */
+               *x = 0;
+               ++n;
+               }
+       mb->n = n;
+       nn += n;
+       if (!nn) /* shouldn't happen */
+               goto done;
+       z = z0 = (char **)Alloc(nn*sizeof(char *));
+       for(mb1 = mb; mb1; mb1 = mb1->next) {
+               x = mb1->buf;
+               n = mb1->n;
+               for(;;) {
+                       *z++ = x;
+                       if (--n <= 0)
+                               break;
+                       while(*x++);
+                       }
+               }
+       qsort((char *)z0, nn, sizeof(char *), compare);
+       for(n = nn, z = z0; n > 0; n--)
+               fprintf(f, "%s\n", *z++);
+       free((char *)z0);
+ done:
+       clf(&f, to, 1);
+       do {
+               mb1 = mb->next;
+               free((char *)mb);
+               }
+               while(mb = mb1);
+       return 0;
+       }
+#endif

diff --git a/usr.bin/f2c/sysdep.h b/usr.bin/f2c/sysdep.h
new file mode 100644 (file)
index 0000000..aef7335
--- /dev/null
+++ b/usr.bin/f2c/sysdep.h
@@ -0,0 +1,101 @@
+/****************************************************************
+Copyright 1990, 1991 by AT&T Bell Laboratories, Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+/* This file is included at the start of defs.h; this file
+ * is an initial attempt to gather in one place some declarations
+ * that may need to be tweaked on some systems.
+ */
+
+#ifdef __STDC__
+#ifndef ANSI_Libraries
+#define ANSI_Libraries
+#endif
+#ifndef ANSI_Prototypes
+#define ANSI_Prototypes
+#endif
+#endif
+
+#ifdef __BORLANDC__
+#define MSDOS
+extern int ind_printf(), nice_printf();
+#endif
+
+#ifdef __ZTC__ /* Zortech */
+#define MSDOS
+extern int ind_printf(...), nice_printf(...);
+#endif
+
+#ifdef MSDOS
+#define ANSI_Libraries
+#define ANSI_Prototypes
+#define LONG_CAST (long)
+#else
+#define LONG_CAST
+#endif
+
+#include <stdio.h>
+
+#ifdef ANSI_Libraries
+#include <stddef.h>
+#include <stdlib.h>
+#else
+char *calloc(), *malloc(), *memcpy(), *memset(), *realloc();
+typedef int size_t;
+#ifdef ANSI_Prototypes
+extern double atof(const char *);
+#else
+extern double atof();
+#endif
+#endif
+
+#ifdef ANSI_Prototypes
+extern char *gmem(int, int);
+extern char *mem(int, int);
+extern char *Alloc(int);
+extern int* ckalloc(int);
+#else
+extern char *Alloc(), *gmem(), *mem();
+int *ckalloc();
+#endif
+
+/* On systems like VMS where fopen might otherwise create
+ * multiple versions of intermediate files, you may wish to
+ * #define scrub(x) unlink(x)
+ */
+#ifndef scrub
+#define scrub(x) /* do nothing */
+#endif
+
+/* On systems that severely limit the total size of statically
+ * allocated arrays, you may need to change the following to
+ *     extern char **chr_fmt, *escapes, **str_fmt;
+ * and to modify sysdep.c appropriately
+ */
+extern char *chr_fmt[], escapes[], *str_fmt[];
+
+#include <string.h>
+
+#include "ctype.h"
+
+#define Table_size 256
+/* Table_size should be 1 << (bits/byte) */

diff --git a/usr.bin/f2c/tokens b/usr.bin/f2c/tokens
new file mode 100644 (file)
index 0000000..d97fb52
--- /dev/null
+++ b/usr.bin/f2c/tokens
@@ -0,0 +1,99 @@
+SEOS
+SCOMMENT
+SLABEL
+SUNKNOWN
+SHOLLERITH
+SICON
+SRCON
+SDCON
+SBITCON
+SOCTCON
+SHEXCON
+STRUE
+SFALSE
+SNAME
+SNAMEEQ
+SFIELD
+SSCALE
+SINCLUDE
+SLET
+SASSIGN
+SAUTOMATIC
+SBACKSPACE
+SBLOCK
+SCALL
+SCHARACTER
+SCLOSE
+SCOMMON
+SCOMPLEX
+SCONTINUE
+SDATA
+SDCOMPLEX
+SDIMENSION
+SDO
+SDOUBLE
+SELSE
+SELSEIF
+SEND
+SENDFILE
+SENDIF
+SENTRY
+SEQUIV
+SEXTERNAL
+SFORMAT
+SFUNCTION
+SGOTO
+SASGOTO
+SCOMPGOTO
+SARITHIF
+SLOGIF
+SIMPLICIT
+SINQUIRE
+SINTEGER
+SINTRINSIC
+SLOGICAL
+SNAMELIST
+SOPEN
+SPARAM
+SPAUSE
+SPRINT
+SPROGRAM
+SPUNCH
+SREAD
+SREAL
+SRETURN
+SREWIND
+SSAVE
+SSTATIC
+SSTOP
+SSUBROUTINE
+STHEN
+STO
+SUNDEFINED
+SWRITE
+SLPAR
+SRPAR
+SEQUALS
+SCOLON
+SCOMMA
+SCURRENCY
+SPLUS
+SMINUS
+SSTAR
+SSLASH
+SPOWER
+SCONCAT
+SAND
+SOR
+SNEQV
+SEQV
+SNOT
+SEQ
+SLT
+SGT
+SLE
+SGE
+SNE
+SENDDO
+SWHILE
+SSLASHD

diff --git a/usr.bin/f2c/usignal.h b/usr.bin/f2c/usignal.h
new file mode 100644 (file)
index 0000000..ba4ee6a
--- /dev/null
+++ b/usr.bin/f2c/usignal.h
@@ -0,0 +1,7 @@
+#include <signal.h>
+#ifndef SIGHUP
+#define        SIGHUP  1       /* hangup */
+#endif
+#ifndef SIGQUIT
+#define        SIGQUIT 3       /* quit */
+#endif

diff --git a/usr.bin/f2c/vax.c b/usr.bin/f2c/vax.c
new file mode 100644 (file)
index 0000000..e5a6572
--- /dev/null
+++ b/usr.bin/f2c/vax.c
@@ -0,0 +1,503 @@
+/****************************************************************
+Copyright 1990, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness.  In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+#include "defs.h"
+#include "pccdefs.h"
+#include "output.h"
+
+int regnum[] =  {
+       11, 10, 9, 8, 7, 6 };
+
+/* Put out a constant integer */
+
+prconi(fp, n)
+FILEP fp;
+ftnint n;
+{
+       fprintf(fp, "\t%ld\n", n);
+}
+
+
+
+/* Put out a constant address */
+
+prcona(fp, a)
+FILEP fp;
+ftnint a;
+{
+       fprintf(fp, "\tL%ld\n", a);
+}
+
+
+
+prconr(fp, x, k)
+ FILEP fp;
+ int k;
+ Constp x;
+{
+       char *x0, *x1;
+       char cdsbuf0[64], cdsbuf1[64];
+
+       if (k > 1) {
+               if (x->vstg) {
+                       x0 = x->Const.cds[0];
+                       x1 = x->Const.cds[1];
+                       }
+               else {
+                       x0 = cds(dtos(x->Const.cd[0]), cdsbuf0);
+                       x1 = cds(dtos(x->Const.cd[1]), cdsbuf1);
+                       }
+               fprintf(fp, "\t%s %s\n", x0, x1);
+               }
+       else
+               fprintf(fp, "\t%s\n", x->vstg ? x->Const.cds[0]
+                               : cds(dtos(x->Const.cd[0]), cdsbuf0));
+}
+
+
+char *memname(stg, mem)
+ int stg;
+ long mem;
+{
+       static char s[20];
+
+       switch(stg)
+       {
+       case STGCOMMON:
+       case STGEXT:
+               sprintf(s, "_%s", extsymtab[mem].cextname);
+               break;
+
+       case STGBSS:
+       case STGINIT:
+               sprintf(s, "v.%ld", mem);
+               break;
+
+       case STGCONST:
+               sprintf(s, "L%ld", mem);
+               break;
+
+       case STGEQUIV:
+               sprintf(s, "q.%ld", mem+eqvstart);
+               break;
+
+       default:
+               badstg("memname", stg);
+       }
+       return(s);
+}
+
+/* make_int_expr -- takes an arbitrary expression, and replaces all
+   occurrences of arguments with indirection */
+
+expptr make_int_expr (e)
+expptr e;
+{
+    if (e != ENULL)
+       switch (e -> tag) {
+           case TADDR:
+               if (e -> addrblock.vstg == STGARG
+                && !e->addrblock.isarray)
+                   e = mkexpr (OPWHATSIN, e, ENULL);
+               break;
+           case TEXPR:
+               e -> exprblock.leftp = make_int_expr (e -> exprblock.leftp);
+               e -> exprblock.rightp = make_int_expr (e -> exprblock.rightp);
+               break;
+           default:
+               break;
+       } /* switch */
+
+    return e;
+} /* make_int_expr */
+
+
+
+/* prune_left_conv -- used in prolog() to strip type cast away from
+   left-hand side of parameter adjustments.  This is necessary to avoid
+   error messages from cktype() */
+
+expptr prune_left_conv (e)
+expptr e;
+{
+    struct Exprblock *leftp;
+
+    if (e && e -> tag == TEXPR && e -> exprblock.leftp &&
+           e -> exprblock.leftp -> tag == TEXPR) {
+       leftp = &(e -> exprblock.leftp -> exprblock);
+       if (leftp -> opcode == OPCONV) {
+           e -> exprblock.leftp = leftp -> leftp;
+           free ((charptr) leftp);
+       }
+    }
+
+    return e;
+} /* prune_left_conv */
+
+
+ static int wrote_comment;
+ static FILE *comment_file;
+
+ static void
+write_comment()
+{
+       if (!wrote_comment) {
+               wrote_comment = 1;
+               nice_printf (comment_file, "/* Parameter adjustments */\n");
+               }
+       }
+
+ static int *
+count_args()
+{
+       register int *ac;
+       register chainp cp;
+       register struct Entrypoint *ep;
+       register Namep q;
+
+       ac = (int *)ckalloc(nallargs*sizeof(int));
+
+       for(ep = entries; ep; ep = ep->entnextp)
+               for(cp = ep->arglist; cp; cp = cp->nextp)
+                       if (q = (Namep)cp->datap)
+                               ac[q->argno]++;
+       return ac;
+       }
+
+ static int nu, *refs, *used;
+ static void awalk();
+
+ static void
+aawalk(P)
+ struct Primblock *P;
+{
+       chainp p;
+       expptr q;
+
+       for(p = P->argsp->listp; p; p = p->nextp) {
+               q = (expptr)p->datap;
+               if (q->tag != TCONST)
+                       awalk(q);
+               }
+       if (P->namep->vtype == TYCHAR) {
+               if (q = P->fcharp)
+                       awalk(q);
+               if (q = P->lcharp)
+                       awalk(q);
+               }
+       }
+
+ static void
+afwalk(P)
+ struct Primblock *P;
+{
+       chainp p;
+       expptr q;
+       Namep np;
+
+       for(p = P->argsp->listp; p; p = p->nextp) {
+               q = (expptr)p->datap;
+               switch(q->tag) {
+                 case TPRIM:
+                       np = q->primblock.namep;
+                       if (np->vknownarg)
+                               if (!refs[np->argno]++)
+                                       used[nu++] = np->argno;
+                       if (q->primblock.argsp == 0) {
+                               if (q->primblock.namep->vclass == CLPROC
+                                && q->primblock.namep->vprocclass
+                                               != PTHISPROC
+                                || q->primblock.namep->vdim != NULL)
+                                       continue;
+                               }
+                 default:
+                       awalk(q);
+                       /* no break */
+                 case TCONST:
+                       continue;
+                 }
+               }
+       }
+
+ static void
+awalk(e)
+ expptr e;
+{
+       Namep np;
+ top:
+       if (!e)
+               return;
+       switch(e->tag) {
+         default:
+               badtag("awalk", e);
+         case TCONST:
+         case TERROR:
+         case TLIST:
+               return;
+         case TADDR:
+               if (e->addrblock.uname_tag == UNAM_NAME) {
+                       np = e->addrblock.user.name;
+                       if (np->vknownarg && !refs[np->argno]++)
+                               used[nu++] = np->argno;
+                       }
+               e = e->addrblock.memoffset;
+               goto top;
+         case TPRIM:
+               np = e->primblock.namep;
+               if (np->vknownarg && !refs[np->argno]++)
+                       used[nu++] = np->argno;
+               if (e->primblock.argsp && np->vclass != CLVAR)
+                       afwalk((struct Primblock *)e);
+               else
+                       aawalk((struct Primblock *)e);
+               return;
+         case TEXPR:
+               awalk(e->exprblock.rightp);
+               e = e->exprblock.leftp;
+               goto top;
+         }
+       }
+
+ static chainp
+argsort(p0)
+ chainp p0;
+{
+       Namep *args, q, *stack;
+       int i, nargs, nout, nst;
+       chainp *d, *da, p, rv, *rvp;
+       struct Dimblock *dp;
+
+       if (!p0)
+               return p0;
+       for(nargs = 0, p = p0; p; p = p->nextp)
+               nargs++;
+       args = (Namep *)ckalloc(i = nargs*(sizeof(Namep) + 2*sizeof(chainp)
+                       + 2*sizeof(int)));
+       memset((char *)args, 0, i);
+       stack = args + nargs;
+       d = (chainp *)(stack + nargs);
+       refs = (int *)(d + nargs);
+       used = refs + nargs;
+
+       for(p = p0; p; p = p->nextp) {
+               q = (Namep) p->datap;
+               args[q->argno] = q;
+               }
+       for(p = p0; p; p = p->nextp) {
+               q = (Namep) p->datap;
+               if (!(dp = q->vdim))
+                       continue;
+               i = dp->ndim;
+               while(--i >= 0)
+                       awalk(dp->dims[i].dimexpr);
+               awalk(dp->basexpr);
+               while(nu > 0) {
+                       refs[i = used[--nu]] = 0;
+                       d[i] = mkchain((char *)q, d[i]);
+                       }
+               }
+       for(i = nst = 0; i < nargs; i++)
+               for(p = d[i]; p; p = p->nextp)
+                       refs[((Namep)p->datap)->argno]++;
+       while(--i >= 0)
+               if (!refs[i])
+                       stack[nst++] = args[i];
+       if (nst == nargs) {
+               rv = p0;
+               goto done;
+               }
+       nout = 0;
+       rv = 0;
+       rvp = &rv;
+       while(nst > 0) {
+               nout++;
+               q = stack[--nst];
+               *rvp = p = mkchain((char *)q, CHNULL);
+               rvp = &p->nextp;
+               da = d + q->argno;
+               for(p = *da; p; p = p->nextp)
+                       if (!--refs[(q = (Namep)p->datap)->argno])
+                               stack[nst++] = q;
+               frchain(*da);
+               }
+       if (nout < nargs)
+               for(i = 0; i < nargs; i++)
+                       if (refs[i]) {
+                               q = args[i];
+                               errstr("Can't adjust %.38s correctly\n\
+       due to dependencies among arguments.",
+                                       q->fvarname);
+                               *rvp = p = mkchain((char *)q, CHNULL);
+                               rvp = &p->nextp;
+                               frchain(d[i]);
+                               }
+ done:
+       free((char *)args);
+       return rv;
+       }
+
+prolog(outfile, p)
+ FILE *outfile;
+ register chainp p;
+{
+       int addif, addif0, i, nd, size;
+       int *ac;
+       register Namep q;
+       register struct Dimblock *dp;
+       chainp p0, p1;
+
+       if(procclass == CLBLOCK)
+               return;
+       p0 = p;
+       p1 = p = argsort(p);
+       wrote_comment = 0;
+       comment_file = outfile;
+       ac = 0;
+
+/* Compute the base addresses and offsets for the array parameters, and
+   assign these values to local variables */
+
+       addif = addif0 = nentry > 1;
+       for(; p ; p = p->nextp)
+       {
+           q = (Namep) p->datap;
+           if(dp = q->vdim)    /* if this param is an array ... */
+           {
+               expptr Q, expr;
+
+               /* See whether to protect the following with an if. */
+               /* This only happens when there are multiple entries. */
+
+               nd = dp->ndim - 1;
+               if (addif0) {
+                       if (!ac)
+                               ac = count_args();
+                       if (ac[q->argno] == nentry)
+                               addif = 0;
+                       else if (dp->basexpr
+                                   || dp->baseoffset->constblock.Const.ci)
+                               addif = 1;
+                       else for(addif = i = 0; i <= nd; i++)
+                               if (dp->dims[i].dimexpr
+                               && (i < nd || !q->vlastdim)) {
+                                       addif = 1;
+                                       break;
+                                       }
+                       if (addif) {
+                               write_comment();
+                               nice_printf(outfile, "if (%s) {\n", /*}*/
+                                               q->cvarname);
+                               next_tab(outfile);
+                               }
+                       }
+               for(i = 0 ; i <= nd; ++i)
+
+/* Store the variable length of each dimension (which is fixed upon
+   runtime procedure entry) into a local variable */
+
+                   if ((Q = dp->dims[i].dimexpr)
+                       && (i < nd || !q->vlastdim)) {
+                       expr = (expptr)cpexpr(Q);
+                       write_comment();
+                       out_and_free_statement (outfile, mkexpr (OPASSIGN,
+                               fixtype(cpexpr(dp->dims[i].dimsize)), expr));
+                   } /* if dp -> dims[i].dimexpr */
+
+/* size   will equal the size of a single element, or -1 if the type is
+   variable length character type */
+
+               size = typesize[ q->vtype ];
+               if(q->vtype == TYCHAR)
+                   if( ISICON(q->vleng) )
+                       size *= q->vleng->constblock.Const.ci;
+                   else
+                       size = -1;
+
+               /* Fudge the argument pointers for arrays so subscripts
+                * are 0-based. Not done if array bounds are being checked.
+                */
+               if(dp->basexpr) {
+
+/* Compute the base offset for this procedure */
+
+                   write_comment();
+                   out_and_free_statement (outfile, mkexpr (OPASSIGN,
+                           cpexpr(fixtype(dp->baseoffset)),
+                           cpexpr(fixtype(dp->basexpr))));
+               } /* if dp -> basexpr */
+
+               if(! checksubs) {
+                   if(dp->basexpr) {
+                       expptr tp;
+
+/* If the base of this array has a variable adjustment ... */
+
+                       tp = (expptr) cpexpr (dp -> baseoffset);
+                       if(size < 0 || q -> vtype == TYCHAR)
+                           tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng));
+
+                       write_comment();
+                       tp = mkexpr (OPMINUSEQ,
+                               mkconv (TYADDR, (expptr)p->datap),
+                               mkconv(TYINT, fixtype
+                               (fixtype (tp))));
+/* Avoid type clash by removing the type conversion */
+                       tp = prune_left_conv (tp);
+                       out_and_free_statement (outfile, tp);
+                   } else if(dp->baseoffset->constblock.Const.ci != 0) {
+
+/* if the base of this array has a nonzero constant adjustment ... */
+
+                       expptr tp;
+
+                       write_comment();
+                       if(size > 0 && q -> vtype != TYCHAR) {
+                           tp = prune_left_conv (mkexpr (OPMINUSEQ,
+                                   mkconv (TYADDR, (expptr)p->datap),
+                                   mkconv (TYINT, fixtype
+                                   (cpexpr (dp->baseoffset)))));
+                           out_and_free_statement (outfile, tp);
+                       } else {
+                           tp = prune_left_conv (mkexpr (OPMINUSEQ,
+                                   mkconv (TYADDR, (expptr)p->datap),
+                                   mkconv (TYINT, fixtype
+                                   (mkexpr (OPSTAR, cpexpr (dp -> baseoffset),
+                                   cpexpr (q -> vleng))))));
+                           out_and_free_statement (outfile, tp);
+                       } /* else */
+                   } /* if dp -> baseoffset -> const */
+               } /* if !checksubs */
+
+               if (addif) {
+                       nice_printf(outfile, /*{*/ "}\n");
+                       prev_tab(outfile);
+                       }
+           }
+       }
+       if (wrote_comment)
+           nice_printf (outfile, "\n/* Function Body */\n");
+       if (ac)
+               free((char *)ac);
+       if (p0 != p1)
+               frchain(p1);
+} /* prolog */

diff --git a/usr.bin/f2c/version.c b/usr.bin/f2c/version.c
new file mode 100644 (file)
index 0000000..e1fabf5
--- /dev/null
+++ b/usr.bin/f2c/version.c
@@ -0,0 +1,2 @@
+char F2C_version[] = "19931217";
+char xxxvers[] = "\n@(#) FORTRAN 77 to C Translator, VERSION 19931217\n";

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

diff --git a/usr.bin/f2c/xsum0.out b/usr.bin/f2c/xsum0.out
new file mode 100644 (file)
index 0000000..0eecb1c
--- /dev/null
+++ b/usr.bin/f2c/xsum0.out
@@ -0,0 +1,56 @@
+Notice 1211689a        1195
+README 110fc3e8        4398
+cds.c  38ec751 4076
+data.c fa8cecd6        9370
+defines.h      e500bb1a        8464
+defs.h 72515cc 24172
+equiv.c        f6b65bcc        8831
+error.c        7e4ede  3648
+exec.c e279d99 17980
+expr.c 1d64bc48        60705
+f2c.1  fa354030        6042
+f2c.1t e571e717        5988
+f2c.h  1be46b90        4271
+format.c       ed4c1a9 52848
+format.h       e861ad39        300
+formatdata.c   eb45f76a        24861
+ftypes.h       18b86a27        1377
+gram.dcl       11121871        7977
+gram.exec      e190cb8e        3026
+gram.expr      e3da3320        3137
+gram.head      ecf8a5e0        7554
+gram.io        1b7c281c        3294
+init.c ffd3616 11452
+intr.c e9519537        19813
+io.c   feb30d5a        29027
+iob.h  fe479ed3        459
+lex.c  ffae6a9f        31482
+machdefs.h     4950e5b 659
+main.c 54cb955 17040
+makefile       f3877062        2766
+malloc.c       5c2be2a 3422
+mem.c  133c066 4839
+memset.c       17404d52        1964
+misc.c fe327633        18006
+names.c        3123927 19947
+names.h        f25436a3        689
+niceprintf.c   f976e7dd        9781
+niceprintf.h   c31f08c 412
+output.c       f0627d49        38529
+output.h       edfe9e59        2113
+p1defs.h       e4e11c4e        5776
+p1output.c     157a2c7e        12175
+parse.h        e457df2e        855
+parse_args.c   e01b1fe9        13035
+pccdefs.h      1b4fbbee        1195
+pread.c        5ac0d2  16490
+proc.c 116a13d2        34930
+put.c  fe8a1281        9480
+putpcc.c       1cebcba8        40081
+sysdep.c       174741bc        10939
+sysdep.h       1021aa5e        2834
+tokens 194fccfe        727
+usignal.h      1c4ce909        124
+vax.c  cf2e339 11030
+version.c      3351b7b 107
+xsum.c e2d50e0b        6437