Remove obsolete dependencies.

48 files changed, 0 insertions, 36387 deletions

diff --git a/contrib/tools/f2c/README b/contrib/tools/f2c/README
deleted file mode 100644
index 1416f5217d4..00000000000
--- a/contrib/tools/f2c/README
+++ /dev/null
@@ -1,186 +0,0 @@
-To compile f2c on Linux or Unix systems, copy makefile.u to makefile,
-edit makefile if necessary (see the comments in it and below) and
-type "make" (or maybe "nmake", depending on your system).
-
-To compile f2c.exe on MS Windows systems with Microsoft Visual C++,
-
-	copy makefile.vc makefile
-	nmake
-
-With other PC compilers, you may need to compile xsum.c with -DMSDOS
-(i.e., with MSDOS #defined).
-
-If your compiler does not understand ANSI/ISO C syntax (i.e., if
-you have a K&R C compiler), compile with -DKR_headers .
-
-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 any of the source
-files (excluding the makefile), 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
-(e.g., [email protected]) to send you the files in question,
-plus the current xsum0.out (which may have changed) "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 xsum0.out from f2c/src
-You can also ftp these files from netlib.bell-labs.com; for more
-details, ask [email protected] to "send readme from f2c".
-
-On some systems, the malloc and free in malloc.c let f2c run faster
-than do the standard malloc and free.  Other systems may not tolerate
-redefinition of malloc and free (though changes of 8 Nov. 1994 may
-render this less of a problem than hitherto).  If your system permits
-use of a user-supplied malloc, you may wish to change the MALLOC =
-line in the makefile to "MALLOC = malloc.o", or to type
-	make MALLOC=malloc.o
-instead of
-	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.  If your system does not permit user-supplied malloc
-routines, then f2c may fault with "MALLOC=malloc.o", or may display
-other untoward behavior.
-
-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 ...
-
-In the days of yore, two libraries, libF77 and libI77, were used with
-f77 (the Fortran compiler on which f2c is based).  Separate source for
-these libraries is still available from netlib, but it is more
-convenient to combine them into a single library, libf2c.  Source for
-this combined library is also available from netlib in f2c/libf2c.zip,
-e.g.,
-	http://netlib.bell-labs.com/netlib/f2c/libf2c.zip
-or
-	http://www.netlib.org/f2c/libf2c.zip
-
-(and similarly for other netlib mirrors).  After unzipping libf2c.zip,
-copy the relevant makefile.* to makefile, edit makefile if necessary
-(see the comments in it and in libf2c/README) and invoke "make" or
-"nmake".  The resulting library is called *f2c.lib on MS Windows
-systems and libf2c.a or libf2c.so on Linux and Unix systems;
-makefile.u just shows how to make libf2c.a.  Details on creating the
-shared-library variant, libf2c.so, are system-dependent; some that
-have worked under Linux appear below.  For some other systems, you can
-glean the details from the system-dependent makefile variants in
-directory http://www.netlib.org/ampl/solvers/funclink or
-http://netlib.bell-labs.com/netlib/ampl/solvers/funclink, etc.
-
-In general, under Linux it is necessary to compile libf2c (or libI77)
-with -DNON_UNIX_STDIO .  Under at least one variant of Linux, you can
-make and install a shared-library version of libf2c by compiling
-libI77 with -DNON_UNIX_STDIO, creating libf2c.a as above, and then
-executing
-
-	mkdir t
-	ln lib?77/*.o t
-	cd t; cc -shared -o ../libf2c.so -Wl,-soname,libf2c.so.1 *.o
-	cd ..
-	rm -r t
-	rm /usr/lib/libf2c*
-	mv libf2c.a libf2c.so /usr/lib
-	cd /usr/lib
-	ln libf2c.so libf2c.so.1
-	ln libf2c.so libf2c.so.1.0.0
-
-On some other systems, /usr/local/lib is the appropriate installation
-directory.
-
-
-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.
-
-
-If your machine has IEEE, VAX, or IBM-mainframe arithmetic, but your
-printf is inaccurate (e.g., with Symantec C++ version 6.0,
-printf("%.17g",12.) prints 12.000000000000001), you can make f2c print
-correctly rounded numbers by compiling with -DUSE_DTOA and adding
-dtoa.o g_fmt.o to the makefile's OBJECTS = line, so it becomes
-
-	OBJECTS = $(OBJECTSd) malloc.o dtoa.o g_fmt.o
-
-Also add the rule
-
-	dtoa.o: dtoa.c
-		$(CC) -c $(CFLAGS) -DMALLOC=ckalloc -DIEEE... dtoa.c
-
-(without the initial tab) to the makefile, where IEEE... is one of
-IEEE_MC68k, IEEE_8087, VAX, or IBM, depending on your machine's
-arithmetic.  See the comments near the start of dtoa.c.
-
-The relevant source files, dtoa.c and g_fmt.c, are available
-separately from netlib's fp directory.  For example, you could
-send the E-mail message
-
-	send dtoa.c g_fmt.c from fp
-
-to [email protected] (or use anonymous ftp from
-ftp.netlib.org and look in directory /netlib/fp).
-
-The makefile has a rule for creating tokdefs.h.  If you cannot use the
-makefile, an alternative is to extract tokdefs.h from the beginning of
-gram.c: it's the first 100 lines.
-
-File mem.c has #ifdef CRAY lines that are appropriate for machines
-with the conventional CRAY architecture, but not for "Cray" machines
-based on DEC Alpha chips, such as the T3E; on such machines, you may
-need to make a suitable adjustment, e.g., add #undef CRAY to sysdep.h.
-
-
-Please send bug reports to dmg at acm.org (with " at " changed to "@").
-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/contrib/tools/f2c/src/Notice b/contrib/tools/f2c/src/Notice
deleted file mode 100644
index 261b719bc57..00000000000
--- a/contrib/tools/f2c/src/Notice
+++ /dev/null
@@ -1,23 +0,0 @@
-/****************************************************************
-Copyright 1990 - 1997 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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/contrib/tools/f2c/src/README b/contrib/tools/f2c/src/README
deleted file mode 100644
index 1416f5217d4..00000000000
--- a/contrib/tools/f2c/src/README
+++ /dev/null
@@ -1,186 +0,0 @@
-To compile f2c on Linux or Unix systems, copy makefile.u to makefile,
-edit makefile if necessary (see the comments in it and below) and
-type "make" (or maybe "nmake", depending on your system).
-
-To compile f2c.exe on MS Windows systems with Microsoft Visual C++,
-
-	copy makefile.vc makefile
-	nmake
-
-With other PC compilers, you may need to compile xsum.c with -DMSDOS
-(i.e., with MSDOS #defined).
-
-If your compiler does not understand ANSI/ISO C syntax (i.e., if
-you have a K&R C compiler), compile with -DKR_headers .
-
-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 any of the source
-files (excluding the makefile), 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
-(e.g., [email protected]) to send you the files in question,
-plus the current xsum0.out (which may have changed) "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 xsum0.out from f2c/src
-You can also ftp these files from netlib.bell-labs.com; for more
-details, ask [email protected] to "send readme from f2c".
-
-On some systems, the malloc and free in malloc.c let f2c run faster
-than do the standard malloc and free.  Other systems may not tolerate
-redefinition of malloc and free (though changes of 8 Nov. 1994 may
-render this less of a problem than hitherto).  If your system permits
-use of a user-supplied malloc, you may wish to change the MALLOC =
-line in the makefile to "MALLOC = malloc.o", or to type
-	make MALLOC=malloc.o
-instead of
-	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.  If your system does not permit user-supplied malloc
-routines, then f2c may fault with "MALLOC=malloc.o", or may display
-other untoward behavior.
-
-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 ...
-
-In the days of yore, two libraries, libF77 and libI77, were used with
-f77 (the Fortran compiler on which f2c is based).  Separate source for
-these libraries is still available from netlib, but it is more
-convenient to combine them into a single library, libf2c.  Source for
-this combined library is also available from netlib in f2c/libf2c.zip,
-e.g.,
-	http://netlib.bell-labs.com/netlib/f2c/libf2c.zip
-or
-	http://www.netlib.org/f2c/libf2c.zip
-
-(and similarly for other netlib mirrors).  After unzipping libf2c.zip,
-copy the relevant makefile.* to makefile, edit makefile if necessary
-(see the comments in it and in libf2c/README) and invoke "make" or
-"nmake".  The resulting library is called *f2c.lib on MS Windows
-systems and libf2c.a or libf2c.so on Linux and Unix systems;
-makefile.u just shows how to make libf2c.a.  Details on creating the
-shared-library variant, libf2c.so, are system-dependent; some that
-have worked under Linux appear below.  For some other systems, you can
-glean the details from the system-dependent makefile variants in
-directory http://www.netlib.org/ampl/solvers/funclink or
-http://netlib.bell-labs.com/netlib/ampl/solvers/funclink, etc.
-
-In general, under Linux it is necessary to compile libf2c (or libI77)
-with -DNON_UNIX_STDIO .  Under at least one variant of Linux, you can
-make and install a shared-library version of libf2c by compiling
-libI77 with -DNON_UNIX_STDIO, creating libf2c.a as above, and then
-executing
-
-	mkdir t
-	ln lib?77/*.o t
-	cd t; cc -shared -o ../libf2c.so -Wl,-soname,libf2c.so.1 *.o
-	cd ..
-	rm -r t
-	rm /usr/lib/libf2c*
-	mv libf2c.a libf2c.so /usr/lib
-	cd /usr/lib
-	ln libf2c.so libf2c.so.1
-	ln libf2c.so libf2c.so.1.0.0
-
-On some other systems, /usr/local/lib is the appropriate installation
-directory.
-
-
-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.
-
-
-If your machine has IEEE, VAX, or IBM-mainframe arithmetic, but your
-printf is inaccurate (e.g., with Symantec C++ version 6.0,
-printf("%.17g",12.) prints 12.000000000000001), you can make f2c print
-correctly rounded numbers by compiling with -DUSE_DTOA and adding
-dtoa.o g_fmt.o to the makefile's OBJECTS = line, so it becomes
-
-	OBJECTS = $(OBJECTSd) malloc.o dtoa.o g_fmt.o
-
-Also add the rule
-
-	dtoa.o: dtoa.c
-		$(CC) -c $(CFLAGS) -DMALLOC=ckalloc -DIEEE... dtoa.c
-
-(without the initial tab) to the makefile, where IEEE... is one of
-IEEE_MC68k, IEEE_8087, VAX, or IBM, depending on your machine's
-arithmetic.  See the comments near the start of dtoa.c.
-
-The relevant source files, dtoa.c and g_fmt.c, are available
-separately from netlib's fp directory.  For example, you could
-send the E-mail message
-
-	send dtoa.c g_fmt.c from fp
-
-to [email protected] (or use anonymous ftp from
-ftp.netlib.org and look in directory /netlib/fp).
-
-The makefile has a rule for creating tokdefs.h.  If you cannot use the
-makefile, an alternative is to extract tokdefs.h from the beginning of
-gram.c: it's the first 100 lines.
-
-File mem.c has #ifdef CRAY lines that are appropriate for machines
-with the conventional CRAY architecture, but not for "Cray" machines
-based on DEC Alpha chips, such as the T3E; on such machines, you may
-need to make a suitable adjustment, e.g., add #undef CRAY to sysdep.h.
-
-
-Please send bug reports to dmg at acm.org (with " at " changed to "@").
-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/contrib/tools/f2c/src/cds.c b/contrib/tools/f2c/src/cds.c
deleted file mode 100644
index 05f3d5013e2..00000000000
--- a/contrib/tools/f2c/src/cds.c
+++ /dev/null
@@ -1,195 +0,0 @@
-/****************************************************************
-Copyright 1990, 1993, 1994, 2000 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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 "defs.h"
-
- char *
-#ifdef KR_headers
-cds(s, z0)
-	char *s;
-	char *z0;
-#else
-cds(char *s, char *z0)
-#endif
-{
-	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; */ /* 20010820: preserve sign of 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 += (int)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/contrib/tools/f2c/src/changes b/contrib/tools/f2c/src/changes
deleted file mode 100644
index 73ecd411797..00000000000
--- a/contrib/tools/f2c/src/changes
+++ /dev/null
@@ -1,3504 +0,0 @@
-31 Aug. 1989:
-   1. A(min(i,j)) now is translated correctly (where A is an array).
-   2. 7 and 8 character variable names are allowed (but elicit a
-      complaint under -ext).
-   3. LOGICAL*1 is treated as LOGICAL, with just one error message
-      per LOGICAL*1 statement (rather than one per variable declared
-      in that statement).  [Note that LOGICAL*1 is not in Fortran 77.]
-      Like f77, f2c now allows the format in a read or write statement
-      to be an integer array.
-
-5 Sept. 1989:
-   Fixed botch in argument passing of substrings of equivalenced
-variables.
-
-15 Sept. 1989:
-   Warn about incorrect code generated when a character-valued
-function is not declared external and is passed as a parameter
-(in violation of the Fortran 77 standard) before it is invoked.
-Example:
-
-	subroutine foo(a,b)
-	character*10 a,b
-	call goo(a,b)
-	b = a(3)
-	end
-
-18 Sept. 1989:
-   Complain about overlapping initializations.
-
-20 Sept. 1989:
-   Warn about names declared EXTERNAL but never referenced;
-include such names as externs in the generated C (even
-though most C compilers will discard them).
-
-24 Sept. 1989:
-   New option -w8 to suppress complaint when COMMON or EQUIVALENCE
-forces word alignment of a double.
-   Under -A (for ANSI C), ensure that floating constants (terminated
-by 'f') contain either a decimal point or an exponent field.
-   Repair bugs sometimes encountered with CHAR and ICHAR intrinsic
-functions.
-   Restore f77's optimizations for copying and comparing character
-strings of length 1.
-   Always assume floating-point valued routines in libF77 return
-doubles, even under -R.
-   Repair occasional omission of arguments in routines having multiple
-entry points.
-   Repair bugs in computing offsets of character strings involved
-in EQUIVALENCE.
-   Don't omit structure qualification when COMMON variables are used
-as FORMATs or internal files.
-
-2 Oct. 1989:
-   Warn about variables that appear only in data stmts; don't emit them.
-   Fix bugs in character DATA for noncharacter variables
-involved in EQUIVALENCE.
-   Treat noncharacter variables initialized (at least partly) with
-character data as though they were equivalenced -- put out a struct
-and #define the variables.  This eliminates the hideous and nonportable
-numeric values that were used to initialize such variables.
-   Treat IMPLICIT NONE as IMPLICIT UNDEFINED(A-Z) .
-   Quit when given invalid options.
-
-8 Oct. 1989:
-  Modified naming scheme for generated intermediate variables;
-more are recycled, fewer distinct ones used.
-  New option -W nn specifies nn characters/word for Hollerith
-data initializing non-character variables.
-  Bug fix: x(i:min(i+10,j)) used to elicit "Can't handle opcode 31 yet".
-  Integer expressions of the form (i+const1) - (i+const2), where
-i is a scalar integer variable, are now simplified to (const1-const2);
-this leads to simpler translation of some substring expressions.
-  Initialize uninitialized portions of character string arrays to 0
-rather than to blanks.
-
-9 Oct. 1989:
-  New option -c to insert comments showing original Fortran source.
-  New option -g to insert line numbers of original Fortran source.
-
-10 Oct. 1989:
-  ! recognized as in-line comment delimiter (a la Fortran 88).
-
-24 Oct. 1989:
-  New options to ease coping with systems that want the structs
-that result from COMMON blocks to be defined just once:
-  -E causes uninitialized COMMON blocks to be declared Extern;
-if Extern is undefined, f2c.h #defines it to be extern.
-  -ec causes a separate .c file to be emitted for each
-uninitialized COMMON block: COMMON /ABC/ yields abc_com.c;
-thus one can compile *_com.c into a library to ensure
-precisely one definition.
-  -e1c is similar to -ec, except that everything goes into
-one file, along with comments that give a sed script for
-splitting the file into the pieces that -ec would give.
-This is for use with netlib's "execute f2c" service (for which
--ec is coerced into -e1c, and the sed script will put everything
-but the COMMON definitions into f2c_out.c ).
-
-28 Oct. 1989:
-  Convert "i = i op ..." into "i op= ...;" even when i is a
-dummy argument.
-
-13 Nov. 1989:
-  Name integer constants (passed as arguments) c__... rather
-than c_... so
-	common /c/stuff
-	call foo(1)
-	...
-is translated correctly.
-
-19 Nov. 1989:
-  Floating-point constants are now kept as strings unless they
-are involved in constant expressions that get simplified.  The
-floating-point constants kept as strings can have arbitrarily
-many significant figures and a very large exponent field (as
-large as long int allows on the machine on which f2c runs).
-Thus, for example, the body of
-
-	subroutine zot(x)
-	double precision x(6), pi
-	parameter (pi=3.1415926535897932384626433832795028841972)
-	x(1) = pi
-	x(2) = pi+1
-	x(3) = 9287349823749272.7429874923740978492734D-298374
-	x(4) = .89
-	x(5) = 4.0005
-	x(6) = 10D7
-	end
-
-now gets translated into
-
-    x[1] = 3.1415926535897932384626433832795028841972;
-    x[2] = 4.1415926535897931;
-    x[3] = 9.2873498237492727429874923740978492734e-298359;
-    x[4] = (float).89;
-    x[5] = (float)4.0005;
-    x[6] = 1e8;
-
-rather than the former
-
-    x[1] = 3.1415926535897931;
-    x[2] = 4.1415926535897931;
-    x[3] = 0.;
-    x[4] = (float)0.89000000000000003;
-    x[5] = (float)4.0004999999999997;
-    x[6] = 100000000.;
-
-  Recognition of f77 machine-constant intrinsics deleted, i.e.,
-epbase, epprec, epemin, epemax, eptiny, ephuge, epmrsp.
-
-22 Nov. 1989:
-  Workarounds for glitches on some Sun systems...
-  libf77: libF77/makefile modified to point out possible need
-to compile libF77/main.c with -Donexit=on_exit .
-  libi77: libI77/wref.c (and libI77/README) modified so non-ANSI
-systems can compile with USE_STRLEN defined, which will cause
-	sprintf(b = buf, "%#.*f", d, x);
-	n = strlen(b) + d1;
-rather than
-	n = sprintf(b = buf, "%#.*f", d, x) + d1;
-to be compiled.
-
-26 Nov. 1989:
-  Longer names are now accepted (up to 50 characters); names may
-contain underscores (in which case they will have two underscores
-appended, to avoid clashes with library names).
-
-28 Nov. 1989:
-  libi77 updated:
-	1. Allow 3 (or, on Crays, 4) digit exponents under format Ew.d .
-	2. Try to get things right on machines where ints have 16 bits.
-
-29 Nov. 1989:
-  Supplied missing semicolon in parameterless subroutines that
-have multiple entry points (all of them parameterless).
-
-30 Nov. 1989:
-  libf77 and libi77 revised to use types from f2c.h.
-  f2c now types floating-point valued C library routines as "double"
-rather than "doublereal" (for use with nonstandard C compilers for
-which "double" is IEEE double extended).
-
-1 Dec. 1989:
-  f2c.h updated to eliminate #defines rendered unnecessary (and,
-indeed, dangerous) by change of 26 Nov. to long names possibly
-containing underscores.
-  libi77 further revised: yesterday's change omitted two tweaks to fmt.h
-(tweaks which only matter if float and real or double and doublereal are
-different types).
-
-2 Dec. 1989:
-  Better error message (than "bad tag") for NAMELIST, which no longer
-inhibits C output.
-
-4 Dec. 1989:
-  Allow capital letters in hex constants (f77 extension; e.g.,
-x'a012BCd', X'A012BCD' and x'a012bcd' are all treated as the integer
-167848909).
-  libi77 further revised: lio.c lio.h lread.c wref.c wrtfmt.c tweaked
-again to allow float and real or double and doublereal to be different.
-
-6 Dec. 1989:
-  Revised f2c.h -- required for the following...
-  Simpler looking translations for abs, min, max, using #defines in
-revised f2c.h .
-  libi77: more corrections to types; additions for NAMELIST.
-  Corrected casts in some I/O calls.
-  Translation of NAMELIST; libi77 must still be revised.  Currently
-libi77 gives you a run-time error message if you attempt NAMELIST I/O.
-
-7 Dec. 1989:
-  Fixed bug that prevented local integer variables that appear in DATA
-stmts from being ASSIGNed statement labels.
-  Fillers (for DATA statements initializing EQUIVALENCEd variables and
-variables in COMMON) typed integer rather than doublereal (for slightly
-more portability, e.g. to Crays).
-  libi77: missing return values supplied in a few places; some tests
-reordered for better working on the Cray.
-  libf77: better accuracy for complex divide, complex square root,
-real mod function (casts to double; double temporaries).
-
-9 Dec. 1989:
-  Fixed bug that caused needless (albeit harmless) empty lines to be
-inserted in the C output when a comment line contained trailing blanks.
-  Further tweak to type of fillers: allow doublereal fillers if the
-struct has doublereal data.
-
-11 Dec. 1989:
-  Alteration of rule for producing external (C) names from names that
-contain underscores.  Now the external name is always obtained by
-appending a pair of underscores.
-
-12 Dec. 1989:
-  C production inhibited after most errors.
-
-15 Dec. 1989:
-  Fixed bug in headers for subroutines having two or more character
-strings arguments:  the length arguments were reversed.
-
-19 Dec. 1989:
-  f2c.h libf77 libi77: adjusted so #undefs in f2c.h should not foil
-compilation of libF77 and libI77.
-  libf77: getenv_ adjusted to work with unsorted environments.
-  libi77: the iostat= specifier should now work right with internal I/O.
-
-20 Dec. 1989:
-  f2c bugs fixed: In the absence of an err= specifier, the iostat=
-specifier was generally set wrong.  Character strings containing
-explicit nulls (\0) were truncated at the first null.
-  Unlabeled DO loops recognized; must be terminated by ENDDO.
-(Don't ask for CYCLE, EXIT, named DO loops, or DO WHILE.)
-
-29 Dec. 1989:
-  Nested unlabeled DO loops now handled properly; new warning for
-extraneous text at end of FORMAT.
-
-30 Dec. 1989:
-  Fixed bug in translating dble(real(...)), dble(sngl(...)), and
-dble(float(...)), where ... is either of type double complex or
-is an expression requiring assignment to intermediate variables (e.g.,
-dble(real(foo(x+1))), where foo is a function and x is a variable).
-Regard nonblank label fields on continuation lines as an error.
-
-3 Jan. 1990:
-  New option -C++ yields output that should be understood
-by C++ compilers.
-
-6 Jan. 1989:
-  -a now excludes variables that appear in a namelist from those
-that it makes automatic.  (As before, it also excludes variables
-that appear in a common, data, equivalence, or save statement.)
-  The syntactically correct Fortran
-	read(*,i) x
-	end
-now yields syntactically correct C (even though both the Fortran
-and C are buggy -- no FORMAT has not been ASSIGNed to i).
-
-7 Jan. 1990:
-  libi77: routines supporting NAMELIST added.  Surrounding quotes
-made optional when no ambiguity arises in a list or namelist READ
-of a character-string value.
-
-9 Jan. 1990:
-  f2c.src made available.
-
-16 Jan. 1990:
-  New options -P to produce ANSI C or C++ prototypes for procedures
-defined.  Change to -A and -C++: f2c tries to infer prototypes for
-invoked procedures unless the new -!P option is given.  New warning
-messages for inconsistent calling sequences among procedures within
-a single file.  Most of f2c/src is affected.
-  f2c.h: typedefs for procedure arguments added; netlib's f2c service
-will insert appropriate typedefs for use with older versions of f2c.h.
-
-17 Jan. 1990:
-  f2c/src: defs.h exec.c format.c proc.c putpcc.c version.c xsum0.out
-updated.  Castargs and protofile made extern in defs.h; exec.c
-modified so superfluous else clauses are diagnosed; unused variables
-omitted from declarations in format.c proc.c putpcc.c .
-
-21 Jan. 1990:
-  No C emitted for procedures declared external but not referenced.
-  f2c.h: more new types added for use with -P.
-  New feature: f2c accepts as arguments files ending in .p or .P;
-such files are assumed to be prototype files, such as produced by
-the -P option.  All prototype files are read before any Fortran files
-and apply globally to all Fortran files.  Suitable prototypes help f2c
-warn about calling-sequence errors and can tell f2c how to type
-procedures declared external but not explicitly typed; the latter is
-mainly of interest for users of the -A and -C++ options.  (Prototype
-arguments are not available to netlib's "execute f2c" service.)
-  New option -it tells f2c to try to infer types of untyped external
-arguments from their use as parameters to prototyped or previously
-defined procedures.
-  f2c/src: many minor cleanups; most modules changed.  Individual
-files in f2c/src are now in "bundle" format.  The former f2c.1 is
-now f2c.1t; "f2c.1t from f2c" and "f2c.1t from f2c/src" are now the
-same, as are "f2c.1 from f2c" and "f2c.1 from f2c/src".  People who
-do not obtain a new copy of "all from f2c/src" should at least add
-	fclose(sortfp);
-after the call on do_init_data(outfile, sortfp) in format_data.c .
-
-22 Jan. 1990:
-  Cleaner man page wording (thanks to Doug McIlroy).
-  -it now also applies to all untyped EXTERNAL procedures, not just
-arguments.
-
-23 Jan. 01:34:00 EST 1990:
-  Bug fixes: under -A and -C++, incorrect C was generated for
-subroutines having multiple entries but no arguments.
-  Under -A -P, subroutines of no arguments were given prototype
-calling sequence () rather than (void).
-  Character-valued functions elicited erroneous warning messages
-about inconsistent calling sequences when referenced by another
-procedure in the same file.
-  f2c.1t: omit first appearance of libF77.a in FILES section;
-load order of libraries is -lF77 -lI77, not vice versa (bug
-introduced in yesterday's edits); define .F macro for those whose
--man lacks it.  (For a while after yesterday's fixes were posted,
-f2c.1t was out of date.  Sorry!)
-
-23 Jan. 9:53:24 EST 1990:
-  Character substring expressions involving function calls having
-character arguments (including the intrinsic len function) yielded
-incorrect C.
-  Procedures defined after invocation (in the same file) with
-conflicting argument types also got an erroneous message about
-the wrong number of arguments.
-
-24 Jan. 11:44:00 EST 1990:
-  Bug fixes: -p omitted #undefs; COMMON block names containing
-underscores had their C names incorrectly computed; a COMMON block
-having the name of a previously defined procedure wreaked havoc;
-if all arguments were .P files, f2c tried reading the second as a
-Fortran file.
-  New feature: -P emits comments showing COMMON block lengths, so one
-can get warnings of incompatible COMMON block lengths by having f2c
-read .P (or .p) files.  Now by running f2c twice, first with -P -!c
-(or -P!c),  then with *.P among the arguments, you can be warned of
-inconsistent COMMON usage, and COMMON blocks having inconsistent
-lengths will be given the maximum length.  (The latter always did
-happen within each input file; now -P lets you extend this behavior
-across files.)
-
-26 Jan. 16:44:00 EST 1990:
-  Option -it made less aggressive: untyped external procedures that
-are invoked are now typed by the rules of Fortran, rather than by
-previous use of procedures to which they are passed as arguments
-before being invoked.
-  Option -P now includes information about references, i.e., called
-procedures, in the prototype files (in the form of special comments).
-This allows iterative invocations of f2c to infer more about untyped
-external names, particularly when multiple Fortran files are involved.
-  As usual, there are some obscure bug fixes:
-1.  Repair of erroneous warning messages about inconsistent number of
-arguments that arose when a character dummy parameter was discovered
-to be a function or when multiple entry points involved character
-variables appearing in a previous entry point.
-2.  Repair of memory fault after error msg about "adjustable character
-function".
-3.  Under -U, allow MAIN_ as a subroutine name (in the same file as a
-main program).
-4.  Change for consistency: a known function invoked as a subroutine,
-then as a function elicits a warning rather than an error.
-
-26 Jan. 22:32:00 EST 1990:
-  Fixed two bugs that resulted in incorrect C for substrings, within
-the body of a character-valued function, of the function's name, when
-those substrings were arguments to another function (even implicitly,
-as in character-string assignment).
-
-28 Jan. 18:32:00 EST 1990:
-  libf77, libi77: checksum files added; "make check" looks for
-transmission errors.  NAMELIST read modified to allow $ rather than &
-to precede a namelist name, to allow $ rather than / to terminate
-input where the name of another variable would otherwise be expected,
-and to regard all nonprinting ASCII characters <= ' ' as spaces.
-
-29 Jan. 02:11:00 EST 1990:
-  "fc from f2c" added.
-  -it option made the default; -!it turns it off.  Type information is
-now updated in a previously missed case.
-  -P option tweaked again; message about when rerunning f2c may change
-prototypes or declarations made more accurate.
-  New option -Ps implies -P and returns exit status 4 if rerunning
-f2c -P with prototype inputs might change prototypes or declarations.
-Now you can execute a crude script like
-
-	cat *.f >zap.F
-	rm -f zap.P
-	while :; do
-		f2c -Ps -!c zap.[FP]
-		case $? in 4) ;; *) break;; esac
-		done
-
-to get a file zap.P of the best prototypes f2c can determine for *.f .
-
-Jan. 29 07:30:21 EST 1990:
-  Forgot to check for error status when setting return code 4 under -Ps;
-error status (1, 2, 3, or, for caught signal, 126) now takes precedence.
-
-Jan 29 14:17:00 EST 1990:
-  Incorrect handling of
-	open(n,'filename')
-repaired -- now treated as
-	open(n,file='filename')
-(and, under -ext, given an error message).
-  New optional source file memset.c for people whose systems don't
-provide memset, memcmp, and memcpy; #include <string.h> in mem.c
-changed to #include "string.h" so BSD people can create a local
-string.h that simply says #include <strings.h> .
-
-Jan 30 10:34:00 EST 1990:
-  Fix erroneous warning at end of definition of a procedure with
-character arguments when the procedure had previously been called with
-a numeric argument instead of a character argument.  (There were two
-warnings, the second one incorrectly complaining of a wrong number of
-arguments.)
-
-Jan 30 16:29:41 EST 1990:
-  Fix case where -P and -Ps erroneously reported another iteration
-necessary.  (Only harm is the extra iteration.)
-
-Feb 3 01:40:00 EST 1990:
-  Supply semicolon occasionally omitted under -c .
-  Try to force correct alignment when numeric variables are initialized
-with character data (a non-standard and non-portable practice).  You
-must use the -W option if your code has such data statements and is
-meant to run on a machine with other than 4 characters/word; e.g., for
-code meant to run on a Cray, you would specify -W8 .
-  Allow parentheses around expressions in output lists (in write and
-print statements).
-  Rename source files so their names are <= 12 characters long
-(so there's room to append .Z and still have <= 14 characters);
-renamed files:  formatdata.c niceprintf.c niceprintf.h safstrncpy.c .
-  f2c material made available by anonymous ftp from research.att.com
-(look in dist/f2c ).
-
-Feb 3 03:49:00 EST 1990:
-  Repair memory fault that arose from use (in an assignment or
-call) of a non-argument variable declared CHARACTER*(*).
-
-Feb 9 01:35:43 EST 1990:
-  Fix erroneous error msg about bad types in
-	subroutine foo(a,adim)
-	dimension a(adim)
-	integer adim
-  Fix improper passing of character args (and possible memory fault)
-in the expression part of a computed goto.
-  Fix botched calling sequences in array references involving
-functions having character args.
-  Fix memory fault caused by invocation of character-valued functions
-of no arguments.
-  Fix botched calling sequence of a character*1-valued function
-assigned to a character*1 variable.
-  Fix bug in error msg for inconsistent number of args in prototypes.
-  Allow generation of C output despite inconsistencies in prototypes,
-but give exit code 8.
-  Simplify include logic (by removing some bogus logic); never
-prepend "/usr/include/" to file names.
-  Minor cleanups (that should produce no visible change in f2c's
-behavior) in intr.c parse.h main.c defs.h formatdata.c p1output.c .
-
-Feb 10 00:19:38 EST 1990:
-  Insert (integer) casts when floating-point expressions are used
-as subscripts.
-  Make SAVE stmt (with no variable list) override -a .
-  Minor cleanups: change field to Field in struct Addrblock (for the
-benefit of buggy C compilers); omit system("/bin/cp ...") in misc.c .
-
-Feb 13 00:39:00 EST 1990:
-  Error msg fix in gram.dcl: change "cannot make %s parameter"
-to "cannot make into parameter".
-
-Feb 14 14:02:00 EST 1990:
-  Various cleanups (invisible on systems with 4-byte ints), thanks
-to Dave Regan: vaxx.c eliminated; %d changed to %ld various places;
-external names adjusted for the benefit of stupid systems (that ignore
-case and recognize only 6 significant characters in external names);
-buffer shortened in xsum.c (e.g. for MS-DOS); fopen modes distinguish
-text and binary files; several unused functions eliminated; missing
-arg supplied to an unlikely fatalstr invocation.
-
-Thu Feb 15 19:15:53 EST 1990:
-  More cleanups (invisible on systems with 4 byte ints); casts inserted
-so most complaints from cyntax(1) and lint(1) go away; a few (int)
-versus (long) casts corrected.
-
-Fri Feb 16 19:55:00 EST 1990:
-  Recognize and translate unnamed Fortran 8x do while statements.
-  Fix bug that occasionally caused improper breaking of character
-strings.
-  New error message for attempts to provide DATA in a type-declaration
-statement.
-
-Sat Feb 17 11:43:00 EST 1990:
-  Fix infinite loop clf -> Fatal -> done -> clf after I/O error.
-  Change "if (addrp->vclass = CLPROC)" to "if (addrp->vclass == CLPROC)"
-in p1_addr (in p1output.c); this was probably harmless.
-  Move a misplaced } in lex.c (which slowed initkey()).
-  Thanks to Gary Word for pointing these things out.
-
-Sun Feb 18 18:07:00 EST 1990:
-  Detect overlapping initializations of arrays and scalar variables
-in previously missed cases.
-  Treat logical*2 as logical (after issuing a warning).
-  Don't pass string literals to p1_comment().
-  Correct a cast (introduced 16 Feb.) in gram.expr; this matters e.g.
-on a Cray.
-  Attempt to isolate UNIX-specific things in sysdep.c (a new source
-file).  Unless sysdep.c is compiled with SYSTEM_SORT defined, the
-intermediate files created for DATA statements are now sorted in-core
-without invoking system().
-
-Tue Feb 20 16:10:35 EST 1990:
-  Move definition of binread and binwrite from init.c to sysdep.c .
-  Recognize Fortran 8x tokens < <= == >= > <> as synonyms for
-.LT. .LE. .EQ. .GE. .GT. .NE.
-  Minor cleanup in putpcc.c:  fully remove simoffset().
-  More discussion of system dependencies added to libI77/README.
-
-Tue Feb 20 21:44:07 EST 1990:
-  Minor cleanups for the benefit of EBCDIC machines -- try to remove
-the assumption that 'a' through 'z' are contiguous.  (Thanks again to
-Gary Word.)  Also, change log2 to log_2 (shouldn't be necessary).
-
-Wed Feb 21 06:24:56 EST 1990:
-  Fix botch in init.c introduced in previous change; only matters
-to non-ASCII machines.
-
-Thu Feb 22 17:29:12 EST 1990:
-  Allow several entry points to mention the same array.  Protect
-parameter adjustments with if's (for the case that an array is not
-an argument to all entrypoints).
-  Under -u, allow
-	subroutine foo(x,n)
-	real x(n)
-	integer n
-  Compute intermediate variables used to evaluate dimension expressions
-at the right time.  Example previously mistranslated:
-	subroutine foo(x,k,m,n)
-	real x(min(k,m,n))
-	...
-	write(*,*) x
-  Detect duplicate arguments.  (The error msg points to the first
-executable stmt -- not wonderful, but not worth fixing.)
-  Minor cleanup of min/max computation (sometimes slightly simpler).
-
-Sun Feb 25 09:39:01 EST 1990:
-  Minor tweak to multiple entry points: protect parameter adjustments
-with if's only for (array) args that do not appear in all entry points.
-  Minor tweaks to format.c and io.c (invisible unless your compiler
-complained at the duplicate #defines of IOSUNIT and IOSFMT or at
-comparisons of p1gets(...) with NULL).
-
-Sun Feb 25 18:40:10 EST 1990:
-  Fix bug introduced Feb. 22: if a subprogram contained DATA and the
-first executable statement was labeled, then the label got lost.
-(Just change INEXEC to INDATA in p1output.c; it occurs just once.)
-
-Mon Feb 26 17:45:10 EST 1990:
-  Fix bug in handling of " and ' in comments.
-
-Wed Mar 28 01:43:06 EST 1990:
-libI77:
- 1. Repair nasty I/O bug: opening two files and closing the first
-(after possibly reading or writing it), then writing the second caused
-the last buffer of the second to be lost.
- 2. Formatted reads of logical values treated all letters other than
-t or T as f (false).
- libI77 files changed: err.c rdfmt.c Version.c
- (Request "libi77 from f2c" -- you can't get these files individually.)
-
-f2c itself:
-  Repair nasty bug in translation of
-	ELSE IF (condition involving complicated abs, min, or max)
--- auxiliary statements were emitted at the wrong place.
-  Supply semicolon previously omitted from the translation of a label
-(of a CONTINUE) immediately preceding an ELSE IF or an ELSE.  This
-bug made f2c produce invalid C.
-  Correct a memory fault that occurred (on some machines) when the
-error message "adjustable dimension on non-argument" should be given.
-  Minor tweaks to remove some harmless warnings by overly chatty C
-compilers.
-  Argument arays having constant dimensions but a variable lower bound
-(e.g., x(n+1:n+3)) had a * omitted from scalar arguments involved in
-the array offset computation.
-
-Wed Mar 28 18:47:59 EST 1990:
-libf77: add exit(0) to end of main [return(0) encounters a Cray bug]
-
-Sun Apr  1 16:20:58 EDT 1990:
-  Avoid dereferencing null when processing equivalences after an error.
-
-Fri Apr  6 08:29:49 EDT 1990:
-  Calls involving alternate return specifiers omitted processing
-needed for things like min, max, abs, and // (concatenation).
-  INTEGER*2 PARAMETERs were treated as INTEGER*4.
-  Convert some O(n^2) parsing to O(n).
-
-Tue Apr 10 20:07:02 EDT 1990:
-  When inconsistent calling sequences involve differing numbers of
-arguments, report the first differing argument rather than the numbers
-of arguments.
-  Fix bug under -a: formatted I/O in which either the unit or the
-format was a local character variable sometimes resulted in invalid C
-(a static struct initialized with an automatic component).
-  Improve error message for invalid flag after elided -.
-  Complain when literal table overflows, rather than infinitely
-looping.  (The complaint mentions the new and otherwise undocumented
--NL option for specifying a larger literal table.)
-  New option -h for forcing strings to word (or, with -hd, double-word)
-boundaries where possible.
-  Repair a bug that could cause improper splitting of strings.
-  Fix bug (cast of c to doublereal) in
-	subroutine foo(c,r)
-	double complex c
-	double precision r
-	c = cmplx(r,real(c))
-	end
-  New include file "sysdep.h" has some things from defs.h (and
-elsewhere) that one may need to modify on some systems.
-  Some large arrays that were previously statically allocated are now
-dynamically allocated when f2c starts running.
-  f2c/src files changed:
-	README cds.c defs.h f2c.1 f2c.1t format.c formatdata.c init.c
-	io.c lex.c main.c makefile mem.c misc.c names.c niceprintf.c
-	output.c parse_args.c pread.c put.c putpcc.c sysdep.h
-	version.c xsum0.out
-
-Wed Apr 11 18:27:12 EDT 1990:
-  Fix bug in argument consistency checking of character, complex, and
-double complex valued functions.  If the same source file contained a
-definition of such a function with arguments not explicitly typed,
-then subsequent references to the function might get erroneous
-warnings of inconsistent calling sequences.
-  Tweaks to sysdep.h for partially ANSI systems.
-  New options -kr and -krd cause f2c to use temporary variables to
-enforce Fortran evaluation-order rules with pernicious, old-style C
-compilers that apply the associative law to floating-point operations.
-
-Sat Apr 14 15:50:15 EDT 1990:
-  libi77: libI77 adjusted to allow list-directed and namelist I/O
-of internal files; bug in namelist I/O of logical and character arrays
-fixed; list input of complex numbers adjusted to permit d or D to
-denote the start of the exponent field of a component.
-  f2c itself: fix bug in handling complicated lower-bound
-expressions for character substrings; e.g., min and max did not work
-right, nor did function invocations involving character arguments.
-  Switch to octal notation, rather than hexadecimal, for nonprinting
-characters in character and string constants.
-  Fix bug (when neither -A nor -C++ was specified) in typing of
-external arguments of type complex, double complex, or character:
-	subroutine foo(c)
-	external c
-	complex c
-now results in
-	/* Complex */ int (*c) ();
-(as, indeed, it once did) rather than
-	complex (*c) ();
-
-Sat Apr 14 22:50:39 EDT 1990:
-  libI77/makefile: updated "make check" to omit lio.c
-  lib[FI]77/makefile: trivial change: define CC = cc, reference $(CC).
-  (Request, e.g., "libi77 from f2c" -- you can't ask for individual
-files from lib[FI]77.)
-
-Wed Apr 18 00:56:37 EDT 1990:
-  Move declaration of atof() from defs.h to sysdep.h, where it is
-now not declared if stdlib.h is included.  (NeXT's stdlib.h has a
-#define atof that otherwise wreaks havoc.)
-  Under -u, provide a more intelligible error message (than "bad tag")
-for an attempt to define a function without specifying its type.
-
-Wed Apr 18 17:26:27 EDT 1990:
-  Recognize \v (vertical tab) in Hollerith as well as quoted strings;
-add recognition of \r (carriage return).
-  New option -!bs turns off recognition of escapes in character strings
-(\0, \\, \b, \f, \n, \r, \t, \v).
-  Move to sysdep.c initialization of some arrays whose initialization
-assumed ASCII; #define Table_size in sysdep.h rather than using
-hard-coded 256 in allocating arrays of size 1 << (bits/byte).
-
-Thu Apr 19 08:13:21 EDT 1990:
-  Warn when escapes would make Hollerith extend beyond statement end.
-  Omit max() definition from misc.c (should be invisible except on
-systems that erroneously #define max in stdlib.h).
-
-Mon Apr 23 22:24:51 EDT 1990:
-  When producing default-style C (no -A or -C++), cast switch
-expressions to (int).
-  Move "-lF77 -lI77 -lm -lc" to link_msg, defined in sysdep.c .
-  Add #define scrub(x) to sysdep.h, with invocations in format.c and
-formatdata.c, so that people who have systems like VMS that would
-otherwise create multiple versions of intermediate files can
-#define scrub(x) unlink(x)
-
-Tue Apr 24 18:28:36 EDT 1990:
-  Pass string lengths once rather than twice to a function of character
-arguments involved in comparison of character strings of length 1.
-
-Fri Apr 27 13:11:52 EDT 1990:
-  Fix bug that made f2c gag on concatenations involving char(...) on
-some systems.
-
-Sat Apr 28 23:20:16 EDT 1990:
-  Fix control-stack bug in
-	if(...) then
-	else if (complicated condition)
-	else
-	endif
-(where the complicated condition causes assignment to an auxiliary
-variable, e.g., max(a*b,c)).
-
-Mon Apr 30 13:30:10 EDT 1990:
-  Change fillers for DATA with holes from substructures to arrays
-(in an attempt to make things work right with C compilers that have
-funny padding rules for substructures, e.g., Sun C compilers).
-  Minor cleanup of exec.c (should not affect generated C).
-
-Mon Apr 30 23:13:51 EDT 1990:
-  Fix bug in handling return values of functions having multiple
-entry points of differing return types.
-
-Sat May  5 01:45:18 EDT 1990:
-  Fix type inference bug in
-	subroutine foo(x)
-	call goo(x)
-	end
-	subroutine goo(i)
-	i = 3
-	end
-Instead of warning of inconsistent calling sequences for goo,
-f2c was simply making i a real variable; now i is correctly
-typed as an integer variable, and f2c issues an error message.
-  Adjust error messages issued at end of declarations so they
-don't blame the first executable statement.
-
-Sun May  6 01:29:07 EDT 1990:
-  Fix bug in -P and -Ps: warn when the definition of a subprogram adds
-information that would change prototypes or previous declarations.
-
-Thu May 10 18:09:15 EDT 1990:
-  Fix further obscure bug with (default) -it: inconsistent calling
-sequences and I/O statements could interact to cause a memory fault.
-Example:
-      SUBROUTINE FOO
-      CALL GOO(' Something') ! Forgot integer first arg
-      END
-      SUBROUTINE GOO(IUNIT,MSG)
-      CHARACTER*(*)MSG
-      WRITE(IUNIT,'(1X,A)') MSG
-      END
-
-Fri May 11 16:49:11 EDT 1990:
-  Under -!c, do not delete any .c files (when there are errors).
-  Avoid dereferencing 0 when a fatal error occurs while reading
-Fortran on stdin.
-
-Wed May 16 18:24:42 EDT 1990:
-  f2c.ps made available.
-
-Mon Jun  4 12:53:08 EDT 1990:
-  Diagnose I/O units of invalid type.
-  Add specific error msg about dummy arguments in common.
-
-Wed Jun 13 12:43:17 EDT 1990:
-  Under -A, supply a missing "[1]" for CHARACTER*1 variables that appear
-both in a DATA statement and in either COMMON or EQUIVALENCE.
-
-Mon Jun 18 16:58:31 EDT 1990:
-  Trivial updates to f2c.ps .  ("Fortran 8x" --> "Fortran 90"; omit
-"(draft)" from "(draft) ANSI C".)
-
-Tue Jun 19 07:36:32 EDT 1990:
-  Fix incorrect code generated for ELSE IF(expression involving
-function call passing non-constant substring).
-  Under -h, preserve the property that strings are null-terminated
-where possible.
-  Remove spaces between # and define in lex.c output.c parse.h .
-
-Mon Jun 25 07:22:59 EDT 1990:
-  Minor tweak to makefile to reduce unnecessary recompilations.
-
-Tue Jun 26 11:49:53 EDT 1990:
-  Fix unintended truncation of some integer constants on machines
-where casting a long to (int) may change the value.  E.g., when f2c
-ran on machines with 16-bit ints, "i = 99999" was being translated
-to "i = -31073;".
-
-Wed Jun 27 11:05:32 EDT 1990:
-  Arrange for CHARACTER-valued PARAMETERs to honor their length
-specifications.  Allow CHAR(nn) in expressions defining such PARAMETERs.
-
-Fri Jul 20 09:17:30 EDT 1990:
-  Avoid dereferencing 0 when a FORMAT statement has no label.
-
-Thu Jul 26 11:09:39 EDT 1990:
-  Remarks about VOID and binread,binwrite added to README.
-  Tweaks to parse_args: should be invisible unless your compiler
-complained at (short)*store.
-
-Thu Aug  2 02:07:58 EDT 1990:
-  f2c.ps: change the first line of page 5 from
-	include stuff
-to
-	include 'stuff'
-
-Tue Aug 14 13:21:24 EDT 1990:
-  libi77: libI77 adjusted to treat tabs as spaces in list input.
-
-Fri Aug 17 07:24:53 EDT 1990:
-  libi77: libI77 adjusted so a blank='ZERO' clause (upper case Z)
-in an open of a currently open file works right.
-
-Tue Aug 28 01:56:44 EDT 1990:
-  Fix bug in warnings of inconsistent calling sequences: if an
-argument to a subprogram was never referenced, then a previous
-invocation of the subprogram (in the same source file) that
-passed something of the wrong type for that argument did not
-elicit a warning message.
-
-Thu Aug 30 09:46:12 EDT 1990:
-  libi77: prevent embedded blanks in list output of complex values;
-omit exponent field in list output of values of magnitude between
-10 and 1e8; prevent writing stdin and reading stdout or stderr;
-don't close stdin, stdout, or stderr when reopening units 5, 6, 0.
-
-Tue Sep  4 12:30:57 EDT 1990:
-  Fix bug in C emitted under -I2 or -i2 for INTEGER*4 FUNCTION.
-  Warn of missing final END even if there are previous errors.
-
-Fri Sep  7 13:55:34 EDT 1990:
-  Remark about "make xsum.out" and "make f2c" added to README.
-
-Tue Sep 18 23:50:01 EDT 1990:
-  Fix null dereference (and, on some systems, writing of bogus *_com.c
-files) under -ec or -e1c when a prototype file (*.p or *.P) describes
-COMMON blocks that do not appear in the Fortran source.
-  libi77:
-    Add some #ifdef lines (#ifdef MSDOS, #ifndef MSDOS) to avoid
-references to stat and fstat on non-UNIX systems.
-    On UNIX systems, add component udev to unit; decide that old
-and new files are the same iff both the uinode and udev components
-of unit agree.
-    When an open stmt specifies STATUS='OLD', use stat rather than
-access (on UNIX systems) to check the existence of the file (in case
-directories leading to the file have funny permissions and this is
-a setuid or setgid program).
-
-Thu Sep 27 16:04:09 EDT 1990:
-  Supply missing entry for Impldoblock in blksize array of cpexpr
-(in expr.c).  No examples are known where this omission caused trouble.
-
-Tue Oct  2 22:58:09 EDT 1990:
-  libf77: test signal(...) == SIG_IGN rather than & 01 in main().
-  libi77: adjust rewind.c so two successive rewinds after a write
-don't clobber the file.
-
-Thu Oct 11 18:00:14 EDT 1990:
-  libi77: minor cleanups: add #include "fcntl.h" to endfile.c, err.c,
-open.c; adjust g_char in util.c for segmented memories; in f_inqu
-(inquire.c), define x appropriately when MSDOS is defined.
-
-Mon Oct 15 20:02:11 EDT 1990:
-  Add #ifdef MSDOS pointer adjustments to mem.c; treat NAME= as a
-synonym for FILE= in OPEN statements.
-
-Wed Oct 17 16:40:37 EDT 1990:
-  libf77, libi77: minor cleanups: _cleanup() and abort() invocations
-replaced by invocations of sig_die in main.c; some error messages
-previously lost in buffers will now appear.
-
-Mon Oct 22 16:11:27 EDT 1990:
-  libf77: separate sig_die from main (for folks who don't want to use
-the main in libF77).
-  libi77: minor tweak to comments in README.
-
-Fri Nov  2 13:49:35 EST 1990:
-  Use two underscores rather than one in generated temporary variable
-names to avoid conflict with COMMON names.  f2c.ps updated to reflect
-this change and the NAME= extension introduced 15 Oct.
-  Repair a rare memory fault in io.c .
-
-Mon Nov  5 16:43:55 EST 1990:
-  libi77: changes to open.c (and err.c): complain if an open stmt
-specifies new= and the file already exists (as specified by Fortrans 77
-and 90); allow file= to be omitted in open stmts and allow
-status='replace' (Fortran 90 extensions).
-
-Fri Nov 30 10:10:14 EST 1990:
-  Adjust malloc.c for unusual systems whose sbrk() can return values
-not properly aligned for doubles.
-  Arrange for slightly more helpful and less repetitive warnings for
-non-character variables initialized with character data; these warnings
-are (still) suppressed by -w66.
-
-Fri Nov 30 15:57:59 EST 1990:
-  Minor tweak to README (about changing VOID in f2c.h).
-
-Mon Dec  3 07:36:20 EST 1990:
-  Fix spelling of "character" in f2c.1t.
-
-Tue Dec  4 09:48:56 EST 1990:
-  Remark about link_msg and libf2c added to f2c/README.
-
-Thu Dec  6 08:33:24 EST 1990:
-  Under -U, render label nnn as L_nnn rather than Lnnn.
-
-Fri Dec  7 18:05:00 EST 1990:
-  Add more names from f2c.h (e.g. integer, real) to the c_keywords
-list of names to which an underscore is appended to avoid confusion.
-
-Mon Dec 10 19:11:15 EST 1990:
-  Minor tweaks to makefile (./xsum) and README (binread/binwrite).
-  libi77: a few modifications for POSIX systems; meant to be invisible
-elsewhere.
-
-Sun Dec 16 23:03:16 EST 1990:
-  Fix null dereference caused by unusual erroneous input, e.g.
-	call foo('abc')
-	end
-	subroutine foo(msg)
-	data n/3/
-	character*(*) msg
-	end
-(Subroutine foo is illegal because the character statement comes after a
-data statement.)
-  Use decimal rather than hex constants in xsum.c (to prevent
-erroneous warning messages about constant overflow).
-
-Mon Dec 17 12:26:40 EST 1990:
-  Fix rare extra underscore in character length parameters passed
-for multiple entry points.
-
-Wed Dec 19 17:19:26 EST 1990:
-  Allow generation of C despite error messages about bad alignment
-forced by equivalence.
-  Allow variable-length concatenations in I/O statements, such as
-	open(3, file=bletch(1:n) // '.xyz')
-
-Fri Dec 28 17:08:30 EST 1990:
-  Fix bug under -p with formats and internal I/O "units" in COMMON,
-as in
-      COMMON /FIGLEA/F
-      CHARACTER*20 F
-      F = '(A)'
-      WRITE (*,FMT=F) 'Hello, world!'
-      END
-
-Tue Jan 15 12:00:24 EST 1991:
-  Fix bug when two equivalence groups are merged, the second with
-nonzero offset, and the result is then merged into a common block.
-Example:
-      INTEGER W(3), X(3), Y(3), Z(3)
-      COMMON /ZOT/ Z
-      EQUIVALENCE (W(1),X(1)), (X(2),Y(1)), (Z(3),X(1))
-***** W WAS GIVEN THE WRONG OFFSET
-  Recognize Fortran 90's optional NML= in NAMELIST READs and WRITEs.
-(Currently NML= and FMT= are treated as synonyms -- there's no
-error message if, e.g., NML= specifies a format.)
-  libi77: minor adjustment to allow internal READs from character
-string constants in read-only memory.
-
-Fri Jan 18 22:56:15 EST 1991:
-  Add comment to README about needing to comment out the typedef of
-size_t in sysdep.h on some systems, e.g. Sun 4.1.
-  Fix misspelling of "statement" in an error message in lex.c
-
-Wed Jan 23 00:38:48 EST 1991:
-  Allow hex, octal, and binary constants to have the qualifying letter
-(z, x, o, or b) either before or after the quoted string containing the
-digits.  For now this change will not be reflected in f2c.ps .
-
-Tue Jan 29 16:23:45 EST 1991:
-  Arrange for character-valued statement functions to give results of
-the right length (that of the statement function's name).
-
-Wed Jan 30 07:05:32 EST 1991:
-  More tweaks for character-valued statement functions: an error
-check and an adjustment so a right-hand side of nonconstant length
-(e.g., a substring) is handled right.
-
-Wed Jan 30 09:49:36 EST 1991:
-  Fix p1_head to avoid printing (char *)0 with %s.
-
-Thu Jan 31 13:53:44 EST 1991:
-  Add a test after the cleanup call generated for I/O statements with
-ERR= or END= clauses to catch the unlikely event that the cleanup
-routine encounters an error.
-
-Mon Feb  4 08:00:58 EST 1991:
-  Minor cleanup: omit unneeded jumps and labels from code generated for
-some NAMELIST READs and WRITEs with IOSTAT=, ERR=, and/or END=.
-
-Tue Feb  5 01:39:36 EST 1991:
-  Change Mktemp to mktmp (for the benefit of systems so brain-damaged
-that they do not distinguish case in external names -- and that for
-some reason want to load mktemp).  Try to get xsum0.out right this
-time (it somehow didn't get updated on 4 Feb. 1991).
-  Add note to libi77/README about adjusting the interpretation of
-RECL= specifiers in OPENs for direct unformatted I/O.
-
-Thu Feb  7 17:24:42 EST 1991:
-  New option -r casts values of REAL functions, including intrinsics,
-to REAL.  This only matters for unportable code like
-	real r
-	r = asin(1.)
-	if (r .eq. asin(1.)) ...
-[The behavior of such code varies with the Fortran compiler used --
-and sometimes is affected by compiler options.]  For now, the man page
-at the end of f2c.ps is the only part of f2c.ps that reflects this new
-option.
-
-Fri Feb  8 18:12:51 EST 1991:
-  Cast pointer differences passed as arguments to the appropriate type.
-This matters, e.g., with MSDOS compilers that yield a long pointer
-difference but have int == short.
-  Disallow nonpositive dimensions.
-
-Fri Feb 15 12:24:15 EST 1991:
-  Change %d to %ld in sprintf call in putpower in putpcc.c.
-  Free more memory (e.g. allowing translation of larger Fortran
-files under MS-DOS).
-  Recognize READ (character expression) and WRITE (character expression)
-as formatted I/O with the format given by the character expression.
-  Update year in Notice.
-
-Sat Feb 16 00:42:32 EST 1991:
-  Recant recognizing WRITE(character expression) as formatted output
--- Fortran 77 is not symmetric in its syntax for READ and WRITE.
-
-Mon Mar  4 15:19:42 EST 1991:
-  Fix bug in passing the real part of a complex argument to an intrinsic
-function.  Omit unneeded parentheses in nested calls to intrinsics.
-Example:
-	subroutine foo(x, y)
-	complex y
-	x = exp(sin(real(y))) + exp(imag(y))
-	end
-
-Fri Mar  8 15:05:42 EST 1991:
-  Fix a comment in expr.c; omit safstrncpy.c (which had bugs in
-cases not used by f2c).
-
-Wed Mar 13 02:27:23 EST 1991:
-  Initialize firstmemblock->next in mem_init in mem.c .  [On most
-systems it was fortuituously 0, but with System V, -lmalloc could
-trip on this missed initialization.]
-
-Wed Mar 13 11:47:42 EST 1991:
-  Fix a reference to freed memory.
-
-Wed Mar 27 00:42:19 EST 1991:
-  Fix a memory fault caused by such illegal Fortran as
-       function foo
-       x = 3
-       logical foo	! declaration among executables
-       foo=.false.	! used to suffer memory fault
-       end
-
-Fri Apr  5 08:30:31 EST 1991:
-  Fix loss of % in some format expressions, e.g.
-	write(*,'(1h%)')
-  Fix botch introduced 27 March 1991 that caused subroutines with
-multiple entry points to have extraneous declarations of ret_val.
-
-Fri Apr  5 12:44:02 EST 1991
-  Try again to omit extraneous ret_val declarations -- this morning's
-fix was sometimes wrong.
-
-Mon Apr  8 13:47:06 EDT 1991:
-  Arrange for s_rnge to have the right prototype under -A -C .
-
-Wed Apr 17 13:36:03 EDT 1991:
-  New fatal error message for apparent invocation of a recursive
-statement function.
-
-Thu Apr 25 15:13:37 EDT 1991:
-  F2c and libi77 adjusted so NAMELIST works with -i2.  (I forgot
-about -i2 when adding NAMELIST.)  This required a change to f2c.h
-(that only affects NAMELIST I/O under -i2.)  Man-page description of
--i2 adjusted to reflect that -i2 stores array lengths in short ints.
-
-Fri Apr 26 02:54:41 EDT 1991:
-  Libi77: fix some bugs in NAMELIST reading of multi-dimensional arrays
-(file rsne.c).
-
-Thu May  9 02:13:51 EDT 1991:
-  Omit a trailing space in expr.c (could cause a false xsum value if
-a mailer drops the trailing blank).
-
-Thu May 16 13:14:59 EDT 1991:
-  Libi77: increase LEFBL in lio.h to overcome a NeXT bug.
-  Tweak for compilers that recognize "nested" comments: inside comments,
-turn /* into /+ (as well as */ into +/).
-
-Sat May 25 11:44:25 EDT 1991:
-  libf77: s_rnge: declare line long int rather than int.
-
-Fri May 31 07:51:50 EDT 1991:
-  libf77: system_: officially return status.
-
-Mon Jun 17 16:52:53 EDT 1991:
-  Minor tweaks: omit unnecessary declaration of strcmp (that caused
-trouble on a system where strcmp was a macro) from misc.c; add
-SHELL = /bin/sh to makefiles.
-  Fix a dereference of null when a CHARACTER*(*) declaration appears
-(illegally) after DATA.  Complain only once per subroutine about
-declarations appearing after DATA.
-
-Mon Jul  1 00:28:13 EDT 1991:
-  Add test and error message for illegal use of subroutine names, e.g.
-      SUBROUTINE ZAP(A)
-      ZAP = A
-      END
-
-Mon Jul  8 21:49:20 EDT 1991:
-  Issue a warning about things like
-	integer i
-	i = 'abc'
-(which is treated as i = ichar('a')).  [It might be nice to treat 'abc'
-as an integer initialized (in a DATA statement) with 'abc', but
-other matters have higher priority.]
-  Render
-	i = ichar('A')
-as
-	i = 'A';
-rather than
-	i = 65;
-(which assumes ASCII).
-
-Fri Jul 12 07:41:30 EDT 1991:
-  Note added to README about erroneous definitions of __STDC__ .
-
-Sat Jul 13 13:38:54 EDT 1991:
-  Fix bugs in double type convesions of complex values, e.g.
-sngl(real(...)) or dble(real(...)) (where ... is complex).
-
-Mon Jul 15 13:21:42 EDT 1991:
-  Fix bug introduced 8 July 1991 that caused erroneous warnings
-"ichar([first char. of] char. string) assumed for conversion to numeric"
-when a subroutine had an array of character strings as an argument.
-
-Wed Aug 28 01:12:17 EDT 1991:
-  Omit an unused function in format.c, an unused variable in proc.c .
-  Under -r8, promote complex to double complex (as the man page claims).
-
-Fri Aug 30 17:19:17 EDT 1991:
-  f2c.ps updated: slightly expand description of intrinsics and,or,xor,
-not; add mention of intrinsics lshift, rshift; add note about f2c
-accepting Fortran 90 inline comments (starting with !); update Cobalt
-Blue address.
-
-Tue Sep 17 07:17:33 EDT 1991:
-  libI77: err.c and open.c modified to use modes "rb" and "wb"
-when (f)opening unformatted files; README updated to point out
-that it may be necessary to change these modes to "r" and "w"
-on some non-ANSI systems.
-
-Tue Oct 15 10:25:49 EDT 1991:
-  Minor tweaks that make some PC compilers happier: insert some
-casts, add args to signal functions.
-  Change -g to emit uncommented #line lines -- and to emit more of them;
-update fc, f2c.1, f2c.1t, f2c.ps to reflect this.
-  Change uchar to Uchar in xsum.c .
-  Bring gram.c up to date.
-
-Thu Oct 17 09:22:05 EDT 1991:
-  libi77: README, fio.h, sue.c, uio.c changed so the length field
-in unformatted sequential records has type long rather than int
-(unless UIOLEN_int is #defined).  This is for systems where sizeof(int)
-can vary, depending on the compiler or compiler options.
-
-Thu Oct 17 13:42:59 EDT 1991:
-  libi77: inquire.c: when MSDOS is defined, don't strcmp units[i].ufnm
-when it is NULL.
-
-Fri Oct 18 15:16:00 EDT 1991:
-  Correct xsum0.out in "all from f2c/src" (somehow botched on 15 Oct.).
-
-Tue Oct 22 18:12:56 EDT 1991:
-  Fix memory fault when a character*(*) argument is used (illegally)
-as a dummy variable in the definition of a statement function.  (The
-memory fault occurred when the statement function was invoked.)
-  Complain about implicit character*(*).
-
-Thu Nov 14 08:50:42 EST 1991:
-  libi77: change uint to Uint in fmt.h, rdfmt.c, wrtfmt.c; this change
-should be invisible unless you're running a brain-damaged system.
-
-Mon Nov 25 19:04:40 EST 1991:
-  libi77: correct botches introduced 17 Oct. 1991 and 14 Nov. 1991
-(change uint to Uint in lwrite.c; other changes that only matter if
-sizeof(int) != sizeof(long)).
-  Add a more meaningful error message when bailing out due to an attempt
-to invoke a COMMON variable as a function.
-
-Sun Dec  1 19:29:24 EST 1991:
-  libi77: uio.c: add test for read failure (seq. unformatted reads);
-adjust an error return from EOF to off end of record.
-
-Tue Dec 10 17:42:28 EST 1991:
-  Add tests to prevent memory faults with bad uses of character*(*).
-
-Thu Dec 12 11:24:41 EST 1991:
-  libi77: fix bug with internal list input that caused the last
-character of each record to be ignored; adjust error message in
-internal formatted input from "end-of-file" to "off end of record"
-if the format specifies more characters than the record contains.
-
-Wed Dec 18 17:48:11 EST 1991:
-  Fix bug in translating nonsensical ichar invocations involving
-concatenations.
-  Fix bug in passing intrinsics lle, llt, lge, lgt as arguments;
-hl_le was being passed rather than l_le, etc.
-  libf77: adjust length parameters from long to ftnlen, for
-compiling with f2c_i2 defined.
-
-Sat Dec 21 15:30:57 EST 1991:
-  Allow DO nnn ... to end with an END DO statement labelled nnn.
-
-Tue Dec 31 13:53:47 EST 1991:
-  Fix bug in handling dimension a(n**3,2) -- pow_ii was called
-incorrectly.
-  Fix bug in translating
-	subroutine x(abc,n)
-	character abc(n)
-	write(abc,'(i10)') 123
-	end
-(omitted declaration and initialiation of abc_dim1).
-  Complain about dimension expressions of such invalid types
-as complex and logical.
-
-Fri Jan 17 11:54:20 EST 1992:
-  Diagnose some illegal uses of main program name (rather than
-memory faulting).
-  libi77:  (1) In list and namelist input, treat "r* ," and "r*,"
-alike (where r is a positive integer constant), and fix a bug in
-handling null values following items with repeat counts (e.g.,
-2*1,,3).  (2) For namelist reading of a numeric array, allow a new
-name-value subsequence to terminate the current one (as though the
-current one ended with the right number of null values).
-(3) [lio.h, lwrite.c]:  omit insignificant zeros in list and namelist
-output.  (Compile with -DOld_list_output to get the old behavior.)
-
-Sat Jan 18 15:58:01 EST 1992:
-  libi77:  make list output consistent with F format by printing .1
-rather than 0.1 (introduced yesterday).
-
-Wed Jan 22 08:32:43 EST 1992:
-  libi77:  add comment to README pointing out preconnection of
-Fortran units 5, 6, 0 to stdin, stdout, stderr (respectively).
-
-Mon Feb  3 11:57:53 EST 1992:
-  libi77:  fix namelist read bug that caused the character following
-a comma to be ignored.
-
-Fri Feb 28 01:04:26 EST 1992:
-  libf77:  fix buggy z_sqrt.c (double precision square root), which
-misbehaved for arguments in the southwest quadrant.
-
-Thu Mar 19 15:05:18 EST 1992:
-  Fix bug (introduced 17 Jan 1992) in handling multiple entry points
-of differing types (with implicitly typed entries appearing after
-the first executable statement).
-  Fix memory fault in the following illegal Fortran:
-        double precision foo(i)
-*	illegal: above should be "double precision function foo(i)"
-        foo = i * 3.2
-        entry moo(i)
-        end
-  Note about ANSI_Libraries (relevant, e.g., to IRIX 4.0.1 and AIX)
-added to README.
-  Abort zero divides during constant simplification.
-
-Sat Mar 21 01:27:09 EST 1992:
-  Tweak ckalloc (misc.c) for systems where malloc(0) = 0; this matters
-for subroutines with multiple entry points but no arguments.
-  Add "struct memblock;" to init.c (irrelevant to most compilers).
-
-Wed Mar 25 13:31:05 EST 1992:
-  Fix bug with IMPLICIT INTEGER*4(...): under -i2 or -I2, the *4 was
-ignored.
-
-Tue May  5 09:53:55 EDT 1992:
-  Tweaks to README; e.g., ANSI_LIbraries changed to ANSI_Libraries .
-
-Wed May  6 23:49:07 EDT 1992
-  Under -A and -C++, have subroutines return 0 (even if they have
-no * arguments).
-  Adjust libi77 (rsne.c and lread.c) for systems where ungetc is
-a macro.  Tweak lib[FI]77/makefile to use unique intermediate file
-names (for parallel makes).
-
-Tue May 19 09:03:05 EDT 1992:
-  Adjust libI77 to make err= work with internal list and formatted I/O.
-
-Sat May 23 18:17:42 EDT 1992:
-  Under -A and -C++, supply "return 0;" after the code generated for
-a STOP statement -- the C compiler doesn't know that s_stop won't
-return.
-  New (mutually exclusive) options:
-	-f	treats all input lines as free-format lines,
-		honoring text that appears after column 72
-		and not padding lines shorter than 72 characters
-		with blanks (which matters if a character string
-		is continued across 2 or more lines).
-	-72	treats text appearing after column 72 as an error.
-
-Sun May 24 09:45:37 EDT 1992:
-  Tweak description of -f in f2c.1 and f2c.1t; update f2c.ps .
-
-Fri May 29 01:17:15 EDT 1992:
-  Complain about externals used as variables.  Example
-	subroutine foo(a,b)
-	external b
-	a = a*b		! illegal use of b; perhaps should be b()
-	end
-
-Mon Jun 15 11:15:27 EDT 1992:
-  Fix bug in handling namelists with names that have underscores.
-
-Sat Jun 27 17:30:59 EDT 1992:
-  Under -A and -C++, end Main program aliases with "return 0;".
-  Under -A and -C++, use .P files and usage in previous subprograms
-in the current file to give prototypes for functions declared EXTERNAL
-but not invoked.
-  Fix memory fault under -d1 -P .
-  Under -A and -C++, cast arguments to the right types in calling
-a function that has been defined in the current file or in a .P file.
-  Fix bug in handling multi-dimensional arrays with array references
-in their leading dimensions.
-  Fix bug in the intrinsic cmplx function when the first argument
-involves an expression for which f2c generates temporary variables,
-e.g. cmplx(abs(real(a)),1.) .
-
-Sat Jul 18 07:36:58 EDT 1992:
-  Fix buglet with -e1c (invisible on most systems) temporary file
-f2c_functions was unlinked before being closed.
-  libf77: fix bugs in evaluating m**n for integer n < 0 and m an
-integer different from 1 or a real or double precision 0.
-Catch SIGTRAP (to print "Trace trap" before aborting).  Programs
-that previously erroneously computed 1 for 0**-1 may now fault.
-Relevant routines: main.c pow_di.c pow_hh.c pow_ii.c pow_ri.c .
-
-Sat Jul 18 08:40:10 EDT 1992:
-  libi77: allow namelist input to end with & (e.g. &end).
-
-Thu Jul 23 00:14:43 EDT 1992
-  Append two underscores rather than one to C keywords used as
-local variables to avoid conflicts with similarly named COMMON blocks.
-
-Thu Jul 23 11:20:55 EDT 1992:
-  libf77, libi77 updated to assume ANSI prototypes unless KR_headers
-is #defined.
-  libi77 now recognizes a Z format item as in Fortran 90;
-the implementation assumes 8-bit bytes and botches character strings
-on little-endian machines (by printing their bytes from right to
-left): expect this bug to persist; fixing it would require a
-change to the I/O calling sequences.
-
-Tue Jul 28 15:18:33 EDT 1992:
-  libi77: insert missed "#ifdef KR_headers" lines around getnum
-header in rsne.c.  Version not updated.
-
-NOTE: "index from f2c" now ends with current timestamps of files in
-"all from f2c/src", sorted by time.  To bring your source up to date,
-obtain source files with a timestamp later than the time shown in your
-version.c.
-
-Fri Aug 14 08:07:09 EDT 1992:
-  libi77: tweak wrt_E in wref.c to avoid signing NaNs.
-
-Sun Aug 23 19:05:22 EDT 1992:
-  fc: supply : after O in getopt invocation (for -O1 -O2 -O3).
-
-Mon Aug 24 18:37:59 EDT 1992:
-  Recant above tweak to fc: getopt is dumber than I thought;
-it's necessary to say -O 1 (etc.).
-  libF77/README: add comments about ABORT, ERF, DERF, ERFC, DERFC,
-GETARG, GETENV, IARGC, SIGNAL, and SYSTEM.
-
-Tue Oct 27 01:57:42 EST 1992:
-  libf77, libi77:
-    1.  Fix botched indirection in signal_.c.
-    2.  Supply missing l_eof = 0 assignment to s_rsne() in rsne.c (so
-end-of-file on other files won't confuse namelist reads of external
-files).
-    3.  Prepend f__ to external names that are only of internal
-interest to lib[FI]77.
-
-Thu Oct 29 12:37:18 EST 1992:
-  libf77: Fix botch in signal_.c when KR_headers is #defined;
-add CFLAGS to makefile.
-  libi77: trivial change to makefile for consistency with
-libF77/makefile.
-
-Wed Feb  3 02:05:16 EST 1993:
-  Recognize types INTEGER*1, LOGICAL*1, LOGICAL*2, INTEGER*8.
-INTEGER*8 is not well tested and will only work reasonably on
-systems where int = 4 bytes, long = 8 bytes; on such systems,
-you'll have to modify f2c.h appropriately, changing integer
-from long to int and adding typedef long longint.  You'll also
-have to compile libI77 with Allow_TYQUAD #defined and adjust
-libF77/makefile to compile pow_qq.c.  In the f2c source, changes
-for INTEGER*8 are delimited by #ifdef TYQUAD ... #endif.  You
-can omit the INTEGER*8 changes by compiling with NO_TYQUAD
-#defined.  Otherwise, the new command-line option -!i8
-disables recognition of INTEGER*8.
-  libf77: add pow_qq.c
-  libi77: add #ifdef Allow_TYQUAD stuff.  Changes for INTEGER*1,
-LOGICAL*1, and LOGICAL*2 came last 23 July 1992.  Fix bug in
-backspace (that only bit when the last character of the second
-or subsequent buffer read was the previous newline).  Guard
-against L_tmpnam being too small in endfile.c.  For MSDOS,
-close and reopen files when copying to truncate.  Lengthen
-LINTW (buffer size in lwrite.c).
-  Add \ to the end of #define lines that get broken.
-  Fix bug in handling NAMELIST of items in EQUIVALENCE.
-  Under -h (or -hd), convert Hollerith to integer in general expressions
-(e.g., assignments), not just when they're passed as arguments, and
-blank-pad rather than 0-pad the Hollerith to a multiple of
-sizeof(integer) or sizeof(doublereal).
-  Add command-line option -s, which instructs f2c preserve multi-
-dimensional subscripts (by emitting and using appropriate #defines).
-  Fix glitch (with default type inferences) in examples like
-	call foo('abc')
-	end
-	subroutine foo(goo)
-	end
-This gave two warning messages:
-	Warning on line 4 of y.f: inconsistent calling sequences for foo:
-	        here 1, previously 2 args and string lengths.
-	Warning on line 4 of y.f: inconsistent calling sequences for foo:
-	        here 2, previously 1 args and string lengths.
-Now the second Warning is suppressed.
-  Complain about all inconsistent arguments, not just the first.
-  Switch to automatic creation of "all from f2c/src".  For folks
-getting f2c source via ftp, this means f2c/src/all.Z is now an
-empty file rather than a bundle.
-  Separate -P and -A: -P no longer implies -A.
-
-Thu Feb  4 00:32:20 EST 1993:
-  Fix some glitches (introduced yesterday) with -h .
-
-Fri Feb  5 01:40:38 EST 1993:
-  Fix bug in types conveyed for namelists (introduced 3 Feb. 1993).
-
-Fri Feb  5 21:26:43 EST 1993:
-  libi77: tweaks to NAMELIST and open (after comments by Harold
-Youngren):
- 1. Reading a ? instead of &name (the start of a namelist) causes
-    the namelist being sought to be written to stdout (unit 6);
-    to omit this feature, compile rsne.c with -DNo_Namelist_Questions.
- 2. Reading the wrong namelist name now leads to an error message
-    and an attempt to skip input until the right namelist name is found;
-    to omit this feature, compile rsne.c with -DNo_Bad_Namelist_Skip.
- 3. Namelist writes now insert newlines before each variable; to omit
-    this feature, compile xwsne.c with -DNo_Extra_Namelist_Newlines.
- 4. For OPEN of sequential files, ACCESS='APPEND' (or
-    access='anything else starting with "A" or "a"') causes the file to
-    be positioned at end-of-file, so a write will append to the file.
-    (This is nonstandard, but does not require modifying data
-    structures.)
-
-Mon Feb  8 14:40:37 EST 1993:
-  Increase number of continuation lines allowed from 19 to 99,
-and allow changing this limit with -NC (e.g. -NC200 for 200 lines).
-  Treat control-Z (at the beginning of a line) as end-of-file: see
-the new penultimate paragraph of README.
-  Fix a rarely seen glitch that could make an error messages to say
-"line 0".
-
-Tue Feb  9 02:05:40 EST 1993
-  libi77: change some #ifdef MSDOS lines to #ifdef NON_UNIX_STDIO,
-and, in err.c under NON_UNIX_STDIO, avoid close(creat(name,0666))
-when the unit has another file descriptor for name.
-
-Tue Feb  9 17:12:49 EST 1993
-  libi77: more tweaks for NON_UNIX_STDIO: use stdio routines
-rather than open, close, creat, seek, fdopen (except for f__isdev).
-
-Fri Feb 12 15:49:33 EST 1993
-  Update src/gram.c (which was forgotten in the recent updates).
-Most folks regenerate it anyway (wity yacc or bison).
-
-Thu Mar  4 17:07:38 EST 1993
-  Increase default max labels in computed gotos and alternate returns
-to 257, and allow -Nl1234 to specify this number.
-  Tweak put.c to check p->tag == TADDR in realpart() and imagpart().
-  Adjust fc script to allow .r (RATFOR) files and -C (check subscripts).
-  Avoid declaring strchr in niceprintf.c under -DANSI_Libraries .
-  gram.c updated again.
-  libi77: err.c, open.c: take declaration of fdopen from rawio.h.
-
-Sat Mar  6 07:09:11 EST 1993
-  libi77: uio.c: adjust off-end-of-record test for sequential
-unformatted reads to respond to err= rather than end= .
-
-Sat Mar  6 16:12:47 EST 1993
-  Treat scalar arguments of the form (v) and v+0, where v is a variable,
-as expressions: assign to a temporary variable, and pass the latter.
-  gram.c updated.
-
-Mon Mar  8 09:35:38 EST 1993
-  "f2c.h from f2c" updated to add types logical1 and integer1 for
-LOGICAL*1 and INTEGER*1.  ("f2c.h from f2c" is supposed to be the
-same as "f2c.h from f2c/src", which was updated 3 Feb. 1993.)
-
-Mon Mar  8 17:57:55 EST 1993
-  Fix rarely seen bug that could cause strange casts in function
-invocations (revealed by an example with msdos/f2c.exe).
-  msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only).
-
-Fri Mar 12 12:37:01 EST 1993
-  Fix bug with -s in handling subscripts involving min, max, and
-complicated expressions requiring temporaries.
-  Fix bug in handling COMMONs that need padding by a char array.
-  msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only).
-
-Fri Mar 12 17:16:16 EST 1993
-  libf77, libi77: updated for compiling under C++.
-
-Mon Mar 15 16:21:37 EST 1993
-  libi77: more minor tweaks (for -DKR_headers); Version.c not changed.
-
-Thu Mar 18 12:37:30 EST 1993
-  Flag -r (for discarding carriage-returns on systems that end lines
-with carriage-return/newline pairs, e.g. PCs) added to xsum, and
-xsum.c converted to ANSI/ISO syntax (with K&R syntax available with
--DKR_headers).  [When time permits, the f2c source will undergo a
-similar conversion.]
-  libi77: tweaks to #includes in endfile.c, err.c, open.c, rawio.h;
-Version.c not changed.
-  f2c.ps updated (to pick up revision of 2 Feb. 1993 to f2c.1).
-
-Fri Mar 19 09:19:26 EST 1993
-  libi77: add (char *) casts to malloc and realloc invocations
-in err.c, open.c; Version.c not changed.
-
-Tue Mar 30 07:17:15 EST 1993
-  Fix bug introduced 6 March 1993: possible memory corruption when
-loops in data statements involve constant subscripts, as in
-	 DATA (GUNIT(1,I),I=0,14)/15*-1/
-
-Tue Mar 30 16:17:42 EST 1993
-  Fix bug with -s: (floating-point array item)*(complex item)
-generates an _subscr() reference for the floating-point array,
-but a #define for the _subscr() was omitted.
-
-Tue Apr  6 12:11:22 EDT 1993
-  libi77: adjust error returns for formatted inputs to flush the current
-input line when err= is specified.  To restore the old behavior (input
-left mid-line), either adjust the #definition of errfl in fio.h or omit
-the invocation of f__doend in err__fl (in err.c).
-
-Tue Apr  6 13:30:04 EDT 1993
-  Fix bug revealed in
-	subroutine foo(i)
-	call goo(int(i))
-	end
-which now passes a copy of i, rather than i itself.
-
-Sat Apr 17 11:41:02 EDT 1993
-  Adjust appending of underscores to conform with f2c.ps ("A Fortran
-to C Converter"): names that conflict with C keywords or f2c type
-names now have just one underscore appended (rather than two); add
-"integer1", "logical1", "longint" to the keyword list.
-  Append underscores to names that appear in EQUIVALENCE and are
-component names in a structure declared in f2c.h, thus avoiding a
-problem caused by the #defines emitted for equivalences.  Example:
-	complex a
-	equivalence (i,j)
-	a = 1	! a.i went awry because of #define i
-	j = 2
-	write(*,*) a, i
-	end
-  Adjust line-breaking logic to avoid splitting very long constants
-(and names).  Example:
-	! The next line starts with tab and thus is a free-format line.
-	a=.012345689012345689012345689012345689012345689012345689012345689012345689
-	end
-  Omit extraneous "return 0;" from entry stubs emitted for multiple
-entry points of type character, complex, or double complex.
-
-Sat Apr 17 14:35:05 EDT 1993
-  Fix bug (introduced 4 Feb.) in separating -P from -A that kept f2c
-from re-reading a .P file written without -A or -C++ describing a
-routine with an external argument.  [See the just-added note about
-separating -P from -A in the changes above for 3 Feb. 1993.]
-  Fix bug (type UNKNOWN for V in the example below) revealed by
-	subroutine a()
-	external c
-	call b(c)
-	end
-	subroutine b(v)
-	end
-
-Sun Apr 18 19:55:26 EDT 1993
-  Fix wrong calling sequence for mem() in yesterday's addition to
-equiv.c .
-
-Wed Apr 21 17:39:46 EDT 1993
-  Fix bug revealed in
-
-      ASSIGN 10 TO L1
-      GO TO 20
- 10   ASSIGN 30 TO L2
-      STOP 10
-
- 20   ASSIGN 10 TO L2	! Bug here because 10 had been assigned
-			! to another label, then defined.
-      GO TO L2
- 30   END
-
-Fri Apr 23 18:38:50 EDT 1993
-  Fix bug with -h revealed in
-	CHARACTER*9 FOO
-	WRITE(FOO,'(I6)') 1
-	WRITE(FOO,'(I6)') 2	! struct icilist io___3 botched
-	END
-
-Tue Apr 27 16:08:28 EDT 1993
-  Tweak to makefile: remove "size f2c".
-
-Tue May  4 23:48:20 EDT 1993
-  libf77: tweak signal_ line of f2ch.add .
-
-Tue Jun  1 13:47:13 EDT 1993
-  Fix bug introduced 3 Feb. 1993 in handling multiple entry
-points with differing return types -- the postfix array in proc.c
-needed a new entry for integer*8 (which resulted in wrong
-Multitype suffixes for non-integral types).
-  For (default) K&R C, generate VOID rather than int functions for
-functions of Fortran type character, complex, and double complex.
-  msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only).
-
-Tue Jun  1 23:11:15 EDT 1993
-  f2c.h: add Multitype component g and commented type longint.
-  proc.c: omit "return 0;" from stubs for complex and double complex
-entries (when entries have multiple types); add test to avoid memory
-fault with illegal combinations of entry types.
-
-Mon Jun  7 12:00:47 EDT 1993
-  Fix memory fault in
-	common /c/ m
-	integer m(1)
-	data m(1)/1/, m(2)/2/	! one too many initializers
-	end
-  msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only).
-
-Fri Jun 18 13:55:51 EDT 1993
-  libi77: change type of signal_ in f2ch.add; change type of il in
-union Uint from long to integer (for machines like the DEC Alpha,
-where integer should be the same as int).  Version.c not changed.
-  Tweak gram.dcl and gram.head: add semicolons after some rules that
-lacked them, and remove an extraneous semicolon.  These changes are
-completely transparent to our local yacc programs, but apparently
-matter on some VMS systems.
-
-Wed Jun 23 01:02:56 EDT 1993
-  Update "fc" shell script, and bring f2c.1 and f2c.1t up to date:
-they're meant to be linked with (i.e., the same as) src/f2c.1 and
-src/f2c.1t .  [In the last update of f2c.1* (2 Feb. 1993), only
-src/f2c.1 and src/f2c.1t got changed -- a mistake.]
-
-Wed Jun 23 09:04:31 EDT 1993
-  libi77: fix bug in format reversions for internal writes.
-Example:
-	character*60 lines(2)
-	write(lines,"('n =',i3,2(' more text',i3))") 3, 4, 5, 6
-	write(*,*) 'lines(1) = ', lines(1)
-	write(*,*) 'lines(2) = ', lines(2)
-	end
-gave an error message that began "iio: off end of record", rather
-than giving the correct output:
-
- lines(1) = n =  3 more text  4 more text  5
- lines(2) =  more text  6 more text
-
-Thu Aug  5 11:31:14 EDT 1993
-  libi77: lread.c: fix bug in handling repetition counts for logical
-data (during list or namelist input).  Change struct f__syl to
-struct syl (for buggy compilers).
-
-Sat Aug  7 16:05:30 EDT 1993
-  libi77: lread.c (again): fix bug in namelist reading of incomplete
-logical arrays.
-  Fix minor calling-sequence errors in format.c, output.c, putpcc.c:
-should be invisible.
-
-Mon Aug  9 09:12:38 EDT 1993
-  Fix erroneous cast under -A in translating
-	character*(*) function getc()
-	getc(2:3)=' '		!wrong cast in first arg to s_copy
-	end
-  libi77: lread.c: fix bug in namelist reading of an incomplete array
-of numeric data followed by another namelist item whose name starts
-with 'd', 'D', 'e', or 'E'.
-
-Fri Aug 20 13:22:10 EDT 1993
-  Fix bug in do while revealed by
-	subroutine skdig (line, i)
-	character line*(*), ch*1
-	integer i
-	logical isdigit
-	isdigit(ch) = ch.ge.'0' .and. ch.le.'9'
-	do while (isdigit(line(i:i)))	! ch__1[0] was set before
-					! "while(...) {...}"
-		i = i + 1
-		enddo
-	end
-
-Fri Aug 27 08:22:54 EDT 1993
-  Add #ifdefs to avoid declaring atol when it is a macro; version.c
-not updated.
-
-Wed Sep  8 12:24:26 EDT 1993
-  libi77: open.c: protect #include "sys/..." with
-#ifndef NON_UNIX_STDIO; Version date not changed.
-
-Thu Sep  9 08:51:21 EDT 1993
-  Adjust "include" to interpret file names relative to the directory
-of the file that contains the "include".
-
-Fri Sep 24 00:56:12 EDT 1993
-  Fix offset error resulting from repeating the same equivalence
-statement twice.  Example:
-	real a(2), b(2)
-	equivalence (a(2), b(2))
-	equivalence (a(2), b(2))
-	end
-  Increase MAXTOKENLEN (to roughly the largest allowed by ANSI C).
-
-Mon Sep 27 08:55:09 EDT 1993
-  libi77: endfile.c: protect #include "sys/types.h" with
-#ifndef NON_UNIX_STDIO; Version.c not changed.
-
-Fri Oct 15 15:37:26 EDT 1993
-  Fix rarely seen parsing bug illustrated by
-	subroutine foo(xabcdefghij)
-	character*(*) xabcdefghij
-               IF (xabcdefghij.NE.'##') GOTO 40
- 40	end
-in which the spacing in the IF line is crucial.
-
-Thu Oct 21 13:55:11 EDT 1993
-  Give more meaningful error message (then "unexpected character in
-cds") when constant simplification leads to Infinity or NaN.
-
-Wed Nov 10 15:01:05 EST 1993
-  libi77: backspace.c: adjust, under -DMSDOS, to cope with MSDOS
-text files, as handled by some popular PC C compilers.  Beware:
-the (defective) libraries associated with these compilers assume lines
-end with \r\n (conventional MS-DOS text files) -- and ftell (and
-hence the current implementation of backspace) screws up if lines with
-just \n.
-
-Thu Nov 18 09:37:47 EST 1993
-  Give a better error (than "control stack empty") for an extraneous
-ENDDO.  Example:
-	enddo
-	end
-  Update comments about ftp in "readme from f2c".
-
-Sun Nov 28 17:26:50 EST 1993
-  Change format of time stamp in version.c to yyyymmdd.
-  Sort parameter adjustments (or complain of impossible dependencies)
-so that dummy arguments are referenced only after being adjusted.
-Example:
-	subroutine foo(a,b)
-	integer a(2)		! a must be adjusted before b
-	double precision b(a(1),a(2))
-	call goo(b(3,4))
-	end
-  Adjust structs for initialized common blocks and equivalence classes
-to omit the trailing struct component added to force alignment when
-padding already forces the desired alignment.  Example:
-	PROGRAM TEST
-	COMMON /Z/ A, CC
-	CHARACTER*4 CC
-	DATA cc /'a'/
-	END
-now gives
-	struct {
-	    integer fill_1[1];
-	    char e_2[4];
-	    } z_ = { {0}, {'a', ' ', ' ', ' '} };
-rather than
-struct {
-    integer fill_1[1];
-    char e_2[4];
-    real e_3;
-    } z_ = { {0}, {'a', ' ', ' ', ' '}, (float)0. };
-
-Wed Dec  8 16:24:43 EST 1993
-  Adjust lex.c to recognize # nnn "filename" lines emitted by cpp;
-this affects the file names and line numbers in error messages and
-the #line lines emitted under -g.
-  Under -g, arrange for a file that starts with an executable
-statement to have the first #line line indicate line 1, rather
-than the line number of the END statement ending the main program.
-  Adjust fc script to run files ending in .F through /lib/cpp.
-  Fix bug ("Impossible tag 2") in
-	if (t .eq. (0,2)) write(*,*) 'Bug!'
-	end
-  libi77: iio.c: adjust internal formatted reads to treat short records
-as though padded with blanks (rather than causing an "off end of record"
-error).
-
-Wed Dec 15 15:19:15 EST 1993
-  fc: adjusted for .F files to pass -D and -I options to cpp.
-
-Fri Dec 17 20:03:38 EST 1993
-  Fix botch introduced 28 Nov. 1993 in vax.c; change "version of"
-to "version".
-
-Tue Jan  4 15:39:52 EST 1994
-  msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only).
-
-Wed Jan 19 08:55:19 EST 1994
-  Arrange to accept
-	integer	Nx, Ny, Nz
-	parameter	(Nx = 10, Ny = 20)
-	parameter	(Nz = max(Nx, Ny))
-	integer	c(Nz)
-	call foo(c)
-	end
-rather than complaining "Declaration error for c: adjustable dimension
-on non-argument".  The necessary changes cause some hitherto unfolded
-constant expressions to be folded.
-  Accept BYTE as a synonym for INTEGER*1.
-
-Thu Jan 27 08:57:40 EST 1994
-  Fix botch in changes of 19 Jan. 1994 that broke entry points with
-multi-dimensional array arguments that did not appear in the subprogram
-argument list and whose leading dimensions depend on arguments.
-
-Mon Feb  7 09:24:30 EST 1994
-  Remove artifact in "fc" script that caused -O to be ignored:
-	87c87
-	<		# lcc ignores -O...
-	---
-	>		CFLAGS="$CFLAGS $O"
-
-Sun Feb 20 17:04:58 EST 1994
-  Fix bugs reading .P files for routines with arguments of type
-INTEGER*1, INTEGER*8, LOGICAL*2.
-  Fix glitch in reporting inconsistent arguments for routines involving
-character arguments:  "arg n" had n too large by the number of
-character arguments.
-
-Tue Feb 22 20:50:08 EST 1994
-  Trivial changes to data.c format.c main.c niceprintf.c output.h and
-sysdep.h (consistency improvements).
-  libI77: lread.c: check for NULL return from realloc.
-
-Fri Feb 25 23:56:08 EST 1994
-  output.c, sysdep.h: arrange for -DUSE_DTOA to use dtoa.c and g_fmt.c
-for correctly rounded decimal values on IEEE-arithmetic machines
-(plus machines with VAX and IBM-mainframe arithmetic).  These
-routines are available from netlib's fp directory.
-  msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only); the
-former uses -DUSE_DTOA to keep 12 from printing as 12.000000000000001.
-  vax.c: fix wrong arguments to badtag and frchain introduced
-28 Nov. 1993.
-  Source for f2c converted to ANSI/ISO format, with the K&R format
-available by compilation with -DKR_headers .
-  Arrange for (double precision expression) relop (single precision
-constant) to retain the single-precision nature of the constant.
-Example:
-	double precision t
-	if (t .eq. 0.3) ...
-
-Mon Feb 28 11:40:24 EST 1994
-  README updated to reflect a modification just made to netlib's
-"dtoa.c from fp":
-96a97,105
-> Also add the rule
->
-> 	dtoa.o: dtoa.c
-> 		$(CC) -c $(CFLAGS) -DMALLOC=ckalloc -DIEEE... dtoa.c
->
-> (without the initial tab) to the makefile, where IEEE... is one of
-> IEEE_MC68k, IEEE_8087, VAX, or IBM, depending on your machine's
-> arithmetic.  See the comments near the start of dtoa.c.
->
-
-Sat Mar  5 09:41:52 EST 1994
-  Complain about functions with the name of a previously declared
-common block (which is illegal).
-  New option -d specifies the directory for output .c and .P files;
-f2c.1 and f2c.1t updated.  The former undocumented debug option -dnnn
-is now -Dnnn.
-
-Thu Mar 10 10:21:44 EST 1994
-  libf77: add #undef min and #undef max lines to s_paus.c s_stop.c
-and system_.c; Version.c not changed.
-  libi77: add -DPad_UDread lines to uio.c and explanation to README:
-    Some buggy Fortran programs use unformatted direct I/O to write
-    an incomplete record and later read more from that record than
-    they have written.  For records other than the last, the unwritten
-    portion of the record reads as binary zeros.  The last record is
-    a special case: attempting to read more from it than was written
-    gives end-of-file -- which may help one find a bug.  Some other
-    Fortran I/O libraries treat the last record no differently than
-    others and thus give no help in finding the bug of reading more
-    than was written.  If you wish to have this behavior, compile
-    uio.c with -DPad_UDread .
-Version.c not changed.
-
-Tue Mar 29 17:27:54 EST 1994
-  Adjust make_param so dimensions involving min, max, and other
-complicated constant expressions do not provoke error messages
-about adjustable dimensions on non-arguments.
-  Fix botch introduced 19 Jan 1994: "adjustable dimension on non-
-argument" messages could cause some things to be freed twice.
-
-Tue May 10 07:55:12 EDT 1994
-  Trivial changes to exec.c, p1output.c, parse_args.c, proc.c,
-and putpcc.c: change arguments from
-	type foo[]
-to
-	type *foo
-for consistency with defs.h.  For most compilers, this makes no
-difference.
-
-Thu Jun  2 12:18:18 EDT 1994
-  Fix bug in handling FORMAT statements that have adjacent character
-(or Hollerith) strings: an extraneous \002 appeared between the
-strings.
-  libf77: under -DNO_ONEXIT, arrange for f_exit to be called just
-once; previously, upon abnormal termination (including stop statements),
-it was called twice.
-
-Mon Jun  6 15:52:57 EDT 1994
-  libf77: Avoid references to SIGABRT and SIGIOT if neither is defined;
-Version.c not changed.
-  libi77: Add cast to definition of errfl() in fio.h; this only matters
-on systems with sizeof(int) < sizeof(long).  Under -DNON_UNIX_STDIO,
-use binary mode for direct formatted files (to avoid any confusion
-connected with \n characters).
-
-Fri Jun 10 16:47:31 EDT 1994
-  Fix bug under -A in handling unreferenced (and undeclared)
-external arguments in subroutines with multiple entry points.  Example:
-	subroutine m(fcn,futil)
-	external fcn,futil
-	call fcn
-	entry mintio(i1) ! (D_fp)0 rather than (U_fp)0 for futil
-	end
-
-Wed Jun 15 10:38:14 EDT 1994
-  Allow char(constant expression) function in parameter declarations.
-(This was probably broken in the changes of 29 March 1994.)
-
-Fri Jul  1 23:54:00 EDT 1994
-  Minor adjustments to makefile (rule for f2c.1 commented out) and
-sysdep.h (#undef KR_headers if __STDC__ is #defined, and base test
-for ANSI_Libraries and ANSI_Prototypes on KR_headers rather than
-__STDC__); version.c touched but not changed.
-  libi77: adjust fp.h so local.h is only needed under -DV10;
-Version.c not changed.
-
-Tue Jul  5 03:05:46 EDT 1994
-  Fix segmentation fault in
-	subroutine foo(a,b,k)
-	data i/1/
-	double precision a(k,1)	! sequence error: must precede data
-	b = a(i,1)
-	end
-  libi77: Fix bug (introduced 6 June 1994?) in reopening files under
-NON_UNIX_STDIO.
-  Fix some error messages caused by illegal Fortran.  Examples:
-* 1.
-	x(i) = 0  !Missing declaration for array x
-	call f(x) !Said Impossible storage class 8 in routine mkaddr
-	end	  !Now says invalid use of statement function x
-* 2.
-	f = g	!No declaration for g; by default it's a real variable
-	call g	!Said invalid class code 2 for function g
-	end	!Now says g cannot be called
-* 3.
-	intrinsic foo	!Invalid intrinsic name
-	a = foo(b)	!Said intrcall: bad intrgroup 0
-	end		!Now just complains about line 1
-
-Tue Jul  5 11:14:26 EDT 1994
-  Fix glitch in handling erroneous statement function declarations.
-Example:
-	a(j(i) - i) = a(j(i) - i) + 1	! bad statement function
-	call foo(a(3))	! Said Impossible type 0 in routine mktmpn
-	end		! Now warns that i and j are not used
-
-Wed Jul  6 17:31:25 EDT 1994
-  Tweak test for statement functions that (illegally) call themselves;
-f2c will now proceed to check for other errors, rather than bailing
-out at the first recursive statement function reference.
-  Warn about but retain divisions by 0 (instead of calling them
-"compiler errors" and quiting).  On IEEE machines, this permits
-	double precision nan, ninf, pinf
-	nan = 0.d0/0.d0
-	pinf = 1.d0/0.d0
-	ninf = -1.d0/0.d0
-	write(*,*) 'nan, pinf, ninf = ', nan, pinf, ninf
-	end
-to print
-	nan, pinf, ninf =   NaN  Infinity -Infinity
-  libi77: wref.c: protect with #ifdef GOOD_SPRINTF_EXPONENT an
-optimization that requires exponents to have 2 digits when 2 digits
-suffice.  lwrite.c wsfe.c (list and formatted external output):
-omit ' ' carriage-control when compiled with -DOMIT_BLANK_CC .
-Off-by-one bug fixed in character count for list output of character
-strings.  Omit '.' in list-directed printing of Nan, Infinity.
-
-Mon Jul 11 13:05:33 EDT 1994
-  src/gram.c updated.
-
-Tue Jul 12 10:24:42 EDT 1994
-  libi77: wrtfmt.c: under G11.4, write 0. as "  .0000    " rather
-than "  .0000E+00".
-
-Thu Jul 14 17:55:46 EDT 1994
-  Fix glitch in changes of 6 July 1994 that could cause erroneous
-"division by zero" warnings (or worse).  Example:
-	subroutine foo(a,b)
-	y = b
-	a = a / y	! erroneous warning of division by zero
-	end
-
-Mon Aug  1 16:45:17 EDT 1994
-  libi77: lread.c rsne.c: for benefit of systems with a buggy stdio.h,
-declare ungetc when neither KR_headers nor ungetc is #defined.
-Version.c not changed.
-
-Wed Aug  3 01:53:00 EDT 1994
-  libi77: lwrite.c (list output): do not insert a newline when
-appending an oversize item to an empty line.
-
-Mon Aug  8 00:51:01 EDT 1994
-  Fix bug (introduced 3 Feb. 1993) that, under -i2, kept LOGICAL*2
-variables from appearing in INQUIRE statements.  Under -I2, allow
-LOGICAL*4 variables to appear in INQUIRE.  Fix intrinsic function
-LEN so it returns a short value under -i2, a long value otherwise.
-  exec.c: fix obscure memory fault possible with bizarre (and highly
-erroneous) DO-loop syntax.
-
-Fri Aug 12 10:45:57 EDT 1994
-  libi77: fix glitch that kept ERR= (in list- or format-directed input)
-from working after a NAMELIST READ.
-
-Thu Aug 25 13:58:26 EDT 1994
-  Suppress -s when -C is specified.
-  Give full pathname ([email protected]) for netlib in readme and
-src/README.
-
-Wed Sep  7 22:13:20 EDT 1994
-  libi77: typesize.c: adjust to allow types LOGICAL*1, LOGICAL*2,
-INTEGER*1, and (under -DAllow_TYQUAD) INTEGER*8 in NAMELISTs.
-
-Fri Sep 16 17:50:18 EDT 1994
-  Change name adjustment for reserved words: instead of just appending
-"_" (a single underscore), append "_a_" to local variable names to avoid
-trouble when a common block is named a reserved word and the same
-reserved word is also a local variable name.  Example:
-	common /const/ a,b,c
-	real const(3)
-	equivalence (const(1),a)
-	a = 1.234
-	end
-  Arrange for ichar() to treat characters as unsigned.
-  libf77: s_cmp.c: treat characters as unsigned in comparisons.
-These changes for unsignedness only matter for strings that contain
-non-ASCII characters.  Now ichar() should always be >= 0.
-
-Sat Sep 17 11:19:32 EDT 1994
-  fc: set rc=$? before exit (to get exit code right in trap code).
-
-Mon Sep 19 17:49:43 EDT 1994
-  libf77: s_paus.c: flush stderr after PAUSE; add #ifdef MSDOS stuff.
-  libi77: README: point out general need for -DMSDOS under MS-DOS.
-
-Tue Sep 20 11:42:30 EDT 1994
-  Fix bug in comparing identically named common blocks, in which
-all components have the same names and types, but at least one is
-dimensioned (1) and the other is not dimensioned.  Example:
-	subroutine foo
-	common /ab/ a
-	a=1.	!!! translated correctly to ab_1.a = (float)1.;
-	end
-	subroutine goo
-	common /ab/ a(1)
-	a(1)=2.	!!! translated erroneously to ab_1.a[0] = (float)2.
-	end
-
-Tue Sep 27 23:47:34 EDT 1994
-  Fix bug introduced 16 Sept. 1994: don't add _a_ to C keywords
-used as external names.  In fact, return to earlier behavior of
-appending __ to C keywords unless they are used as external names,
-in which case they get just one underscore appended.
-  Adjust constant handling so integer and logical PARAMETERs retain
-type information, particularly under -I2.  Example:
-	SUBROUTINE FOO
-	INTEGER I
-	INTEGER*1 I1
-	INTEGER*2 I2
-	INTEGER*4 I4
-	LOGICAL L
-	LOGICAL*1 L1
-	LOGICAL*2 L2
-	LOGICAL*4 L4
-	PARAMETER (L=.FALSE., L1=.FALSE., L2=.FALSE., L4=.FALSE.)
-	PARAMETER (I=0,I1=0,I2=0,I4=0)
-	CALL DUMMY(I, I1, I2, I4, L, L1, L2, L4)
-	END
-  f2c.1t: Change f\^2c to f2c (omit half-narrow space) in line following
-".SH NAME" for benefit of systems that cannot cope with troff commands
-in this context.
-
-Wed Sep 28 12:45:19 EDT 1994
-  libf77: s_cmp.c fix glitch in -DKR_headers version introduced
-12 days ago.
-
-Thu Oct  6 09:46:53 EDT 1994
-  libi77: util.c: omit f__mvgbt (which is never used).
-  f2c.h: change "long" to "long int" to facilitate the adjustments
-by means of sed described above.  Comment out unused typedef of Long.
-
-Fri Oct 21 18:02:24 EDT 1994
-  libf77: add s_catow.c and adjust README to point out that changing
-"s_cat.o" to "s_catow.o" in the makefile will permit the target of a
-concatenation to appear on its right-hand side (contrary to the
-Fortran 77 Standard and at the cost of some run-time efficiency).
-
-Wed Nov  2 00:03:58 EST 1994
-  Adjust -g output to contain only one #line line per statement,
-inserting \ before the \n ending lines broken because of their
-length [this insertion was recanted 10 Dec. 1994].  This change
-accommodates an idiocy in the ANSI/ISO C standard, which leaves
-undefined the behavior of #line lines that occur within the arguments
-to a macro call.
-
-Wed Nov  2 14:44:27 EST 1994
-  libi77: under compilation with -DALWAYS_FLUSH, flush buffers at
-the end of each write statement, and test (via the return from
-fflush) for write failures, which can be caught with an ERR=
-specifier in the write statement.  This extra flushing slows
-execution, but can abort execution or alter the flow of control
-when a disk fills up.
-  f2c/src/io.c: Add ERR= test to e_wsle invocation (end of
-list-directed external output) to catch write failures when libI77
-is compiled with -DALWAYS_FLUSH.
-
-Thu Nov  3 10:59:13 EST 1994
-  Fix bug in handling dimensions involving certain intrinsic
-functions of constant expressions: the expressions, rather than
-pointers to them, were passed.  Example:
-      subroutine subtest(n,x)
-      real x(2**n,n) ! pow_ii(2,n) was called; now it's pow_ii(&c__2,n)
-      x(2,2)=3.
-      end
-
-Tue Nov  8 23:56:30 EST 1994
-  malloc.c: remove assumption that only malloc calls sbrk.  This
-appears to make malloc.c useful on RS6000 systems.
-
-Sun Nov 13 13:09:38 EST 1994
-  Turn off constant folding of integers used in floating-point
-expressions, so the assignment in
-	subroutine foo(x)
-	double precision x
-	x = x*1000000*500000
-	end
-is rendered as
-	*x = *x * 1000000 * 500000;
-rather than as
-	*x *= 1783793664;
-
-Sat Dec 10 16:31:40 EST 1994
-  Supply a better error message (than "Impossible type 14") for
-	subroutine foo
-	foo = 3
-	end
-  Under -g, convey name of included files to #line lines.
-  Recant insertion of \ introduced (under -g) 2 Nov. 1994.
-
-Thu Dec 15 14:33:55 EST 1994
-  New command-line option -Idir specifies directories in which to
-look for non-absolute include files (after looking in the directory
-of the current input file).  There can be several -Idir options, each
-specifying one directory.  All -Idir options are considered, from
-left to right, until a suitably named file is found.  The -I2 and -I4
-command-line options have precedence, so directories named 2 or 4
-must be spelled by some circumlocation, such as -I./2 .
-  f2c.ps updated to mention the new -Idir option, correct a typo,
-and bring the man page at the end up to date.
-  lex.c: fix bug in reading line numbers in #line lines.
-  fc updated to pass -Idir options to f2c.
-
-Thu Dec 29 09:48:03 EST 1994
-  Fix bug (e.g., addressing fault) in diagnosing inconsistency in
-the type of function eta in the following example:
-	function foo(c1,c2)
-	double complex foo,c1,c2
-	double precision eta
-	foo = eta(c1,c2)
-	end
-	function eta(c1,c2)
-	double complex eta,c1,c2
-	eta = c1*c2
-	end
-
-Mon Jan  2 13:27:26 EST 1995
-  Retain casts for SNGL (or FLOAT) that were erroneously optimized
-away.  Example:
-	subroutine foo(a,b)
-	double precision a,b
-	a = float(b)	! now rendered as *a = (real) (*b);
-	end
-  Use float (rather than double) temporaries in certain expressions
-of type complex.  Example: the temporary for sngl(b) in
-	complex a
-	double precision b
-	a = sngl(b) - (3.,4.)
-is now of type float.
-
-Fri Jan  6 00:00:27 EST 1995
-  Adjust intrinsic function cmplx to act as dcmplx (returning
-double complex rather than complex) if either of its args is of
-type double precision.  The double temporaries used prior to 2 Jan.
-1995 previously gave it this same behavior.
-
-Thu Jan 12 12:31:35 EST 1995
-  Adjust -krd to use double temporaries in some calculations of
-type complex.
-  libf77: pow_[dhiqrz][hiq].c: adjust x**i to work on machines
-that sign-extend right shifts when i is the most negative integer.
-
-Wed Jan 25 00:14:42 EST 1995
-  Fix memory fault in handling overlapping initializations in
-	block data
-	common /zot/ d
-	double precision d(3)
-	character*6 v(4)
-	real r(2)
-	equivalence (d(3),r(1)), (d(1),v(1))
-	data v/'abcdef', 'ghijkl', 'mnopqr', 'stuvwx'/
-	data r/4.,5./
-	end
-  names.c: add "far", "huge", "near" to c_keywords (causing them
-to have __ appended when used as local variables).
-  libf77: add s_copyow.c, an alternative to s_copy.c for handling
-(illegal) character assignments where the right- and left-hand
-sides overlap, as in a(2:4) = a(1:3).
-
-Thu Jan 26 14:21:19 EST 1995
-  libf77: roll s_catow.c and s_copyow.c into s_cat.c and s_copy.c,
-respectively, allowing the left-hand side of a character assignment
-to appear on its right-hand side unless s_cat.c and s_copy.c are
-compiled with -DNO_OVERWRITE (which is a bit more efficient).
-Fortran 77 forbids the left-hand side from participating in the
-right-hand side (of a character assignment), but Fortran 90 allows it.
-  libi77: wref.c: fix glitch in printing the exponent of 0 when
-GOOD_SPRINTF_EXPONENT is not #defined.
-
-Fri Jan 27 12:25:41 EST 1995
-  Under -C++ -ec (or -C++ -e1c), surround struct declarations with
-	#ifdef __cplusplus
-	extern "C" {
-	#endif
-and
-	#ifdef __cplusplus
-	}
-	#endif
-(This isn't needed with cfront, but apparently is necessary with
-some other C++ compilers.)
-  libf77: minor tweak to s_copy.c: copy forward whenever possible
-(for better cache behavior).
-
-Wed Feb  1 10:26:12 EST 1995
-  Complain about parameter statements that assign values to dummy
-arguments, as in
-	subroutine foo(x)
-	parameter(x = 3.4)
-	end
-
-Sat Feb  4 20:22:02 EST 1995
-  fc: omit "lib=/lib/num/lib.lo".
-
-Wed Feb  8 08:41:14 EST 1995
-  Minor changes to exec.c, putpcc.c to avoid "bad tag" or "error
-in frexpr" with certain invalid Fortran.
-
-Sat Feb 11 08:57:39 EST 1995
-  Complain about integer overflows, both in simplifying integer
-expressions, and in converting integers from decimal to binary.
-  Fix a memory fault in putcx1() associated with invalid input.
-
-Thu Feb 23 11:20:59 EST 1995
-  Omit MAXTOKENLEN; realloc token if necessary (to handle very long
-strings).
-
-Fri Feb 24 11:02:00 EST 1995
-  libi77: iio.c: z_getc: insert (unsigned char *) to allow internal
-reading of characters with high-bit set (on machines that sign-extend
-characters).
-
-Tue Mar 14 18:22:42 EST 1995
-  Fix glitch (in io.c) in handling 0-length strings in format
-statements, as in
-	write(*,10)
- 10	format(' ab','','cd')
-  libi77: lread.c and rsfe.c: adjust s_rsle and s_rsfe to check for
-end-of-file (to prevent infinite loops with empty read statements).
-
-Wed Mar 22 10:01:46 EST 1995
-  f2c.ps: adjust discussion of -P on p. 7 to reflect a change made
-3 Feb. 1993: -P no longer implies -A.
-
-Fri Apr 21 18:35:00 EDT 1995
-  fc script: remove absolute paths (since PATH specifies only standard
-places).  On most systems, it's still necessary to adjust the PATH
-assignment at the start of fc to fit the local conventions.
-
-Fri May 26 10:03:17 EDT 1995
-  fc script: add recognition of -P and .P files.
-  libi77: iio.c: z_wnew: fix bug in handling T format items in internal
-writes whose last item is written to an earlier position than some
-previous item.
-
-Wed May 31 11:39:48 EDT 1995
-  libf77: added subroutine exit(rc) (with integer return code rc),
-which works like a stop statement but supplies rc as the program's
-return code.
-
-Fri Jun  2 11:56:50 EDT 1995
-  Fix memory fault in
-	parameter (x=2.)
-	data x /2./
-	end
-This now elicits two error messages; the second ("too many
-initializers"), though not desirable, seems hard to eliminate
-without considerable hassle.
-
-Mon Jul 17 23:24:20 EDT 1995
-  Fix botch in simplifying constants in certain complex
-expressions.  Example:
-	subroutine foo(s,z)
-	double complex z
-	double precision s, M, P
-	parameter ( M = 100.d0, P = 2.d0 )
-	z = M * M  / s  * dcmplx (1.d0, P/M)
-*** The imaginary part of z was miscomputed ***
-	end
-  Under -ext, complain about nonintegral dimensions.
-
-Fri Jul 21 11:18:36 EDT 1995
-  Fix glitch on line 159 of init.c: change
-	"(shortlogical *)0)",
-to
-	"(shortlogical *)0",
-This affects multiple entry points when some but not all have
-arguments of type logical*2.
-  libi77: adjust lwrite.c, wref.c, wrtfmt.c so compiling with
--DWANT_LEAD_0 causes formatted writes of floating-point numbers of
-magnitude < 1 to have an explicit 0 before the decimal point (if the
-field-width permits it).  Note that the Fortran 77 Standard leaves it
-up to the implementation whether to supply these superfluous zeros.
-
-Tue Aug  1 09:25:56 EDT 1995
-  Permit real (or double precision) parameters in dimension expressions.
-
-Mon Aug  7 08:04:00 EDT 1995
-  Append "_eqv" rather than just "_" to names that that appear in
-EQUIVALENCE statements as well as structs in f2c.h (to avoid a
-conflict when these names also name common blocks).
-
-Tue Aug  8 12:49:02 EDT 1995
-  Modify yesterday's change: merge st_fields with c_keywords, to
-cope with equivalences introduced to permit initializing numeric
-variables with character data.  DATA statements causing these
-equivalences can appear after executable statements, so the only
-safe course is to rename all local variable with names in the
-former st_fields list.  This has the unfortunate side effect that
-the common local variable "i" will henceforth be renamed "i__".
-
-Wed Aug 30 00:19:32 EDT 1995
-  libf77: add F77_aloc, now used in s_cat and system_ (to allocate
-memory and check for failure in so doing).
-  libi77: improve MSDOS logic in backspace.c.
-
-Wed Sep  6 09:06:19 EDT 1995
-  libf77: Fix return type of system_ (integer) under -DKR_headers.
-  libi77: Move some f_init calls around for people who do not use
-libF77's main(); now open and namelist read statements that are the
-first I/O statements executed should work right in that context.
-Adjust namelist input to treat a subscripted name whose subscripts do
-not involve colons similarly to the name without a subscript:  accept
-several values, stored in successive elements starting at the
-indicated subscript.  Adjust namelist output to quote character
-strings (avoiding confusion with arrays of character strings).
-
-Thu Sep  7 00:36:04 EDT 1995
-  Fix glitch in integer*8 exponentiation function: it's pow_qq, not
-pow_qi.
-  libi77: fix some bugs with -DAllow_TYQUAD (for integer*8); when
-looking for the &name that starts NAMELIST input, treat lines whose
-first nonblank character is something other than &, $, or ? as
-comment lines (i.e., ignore them), unless rsne.c is compiled with
--DNo_Namelist_Comments.
-
-Thu Sep  7 09:05:40 EDT 1995
-  libi77: rdfmt.c:  one more tweak for -DAllow_TYQUAD.
-
-Tue Sep 19 00:03:02 EDT 1995
-  Adjust handling of floating-point subscript bounds (a questionable
-f2c extension) so subscripts in the generated C are of integral type.
-  Move #define of roundup to proc.c (where its use is commented out);
-version.c left at 19950918.
-
-Wed Sep 20 17:24:19 EDT 1995
-  Fix bug in handling ichar() under -h.
-
-Thu Oct  5 07:52:56 EDT 1995
-  libi77: wrtfmt.c: fix bug with t editing (f__cursor was not always
-zeroed in mv_cur).
-
-Tue Oct 10 10:47:54 EDT 1995
-  Under -ext, warn about X**-Y and X**+Y.  Following the original f77,
-f2c treats these as X**(-Y) and X**(+Y), respectively.  (They are not
-allowed by the official Fortran 77 Standard.)  Some Fortran compilers
-give a bizarre interpretation to larger contexts, making multiplication
-noncommutative: they treat X**-Y*Z as X**(-Y*Z) rather than X**(-Y)*Z,
-which, following the rules of Fortran 77, is the same as (X**(-Y))*Z.
-
-Wed Oct 11 13:27:05 EDT 1995
-  libi77: move defs of f__hiwater, f__svic, f__icptr from wrtfmt.c
-to err.c.  This should work around a problem with buggy loaders and
-sometimes leads to smaller executable programs.
-
-Sat Oct 21 23:54:22 EDT 1995
-  Under -h, fix bug in the treatment of ichar('0') in arithmetic
-expressions.
-  Demote to -dneg (a new command-line option not mentioned in the
-man page) imitation of the original f77's treatment of unary minus
-applied to a REAL operand (yielding a DOUBLE PRECISION result).
-Previously this imitation (which was present for debugging) occurred
-under (the default) -!R.  It is still suppressed by -R.
-
-Tue Nov  7 23:52:57 EST 1995
-  Adjust assigned GOTOs to honor SAVE declarations.
-  Add comments about ranlib to lib[FI]77/README and makefile.
-
-Tue Dec 19 22:54:06 EST 1995
-  libf77: s_cat.c: fix bug when 2nd or later arg overlaps lhs.
-
-Tue Jan  2 17:54:00 EST 1996
-  libi77: rdfmt.c: move #include "ctype.h" up before "stdlib.h"; no
-change to Version.c.
-
-Sun Feb 25 22:20:20 EST 1996
-  Adjust expr.c to permit raising the integer constants 1 and -1 to
-negative constant integral powers.
-  Avoid faulting when -T and -d are not followed by a directory name
-(immediately, without intervening spaces).
-
-Wed Feb 28 12:49:01 EST 1996
-  Fix a glitch in handling complex parameters assigned a "wrong" type.
-Example:
-	complex d, z
-	parameter(z = (0d0,0d0))
-	data d/z/	! elicited "non-constant initializer"
-	call foo(d)
-	end
-
-Thu Feb 29 00:53:12 EST 1996
-  Fix bug in handling character parameters assigned a char() value.
-Example:
-	character*2 b,c
-	character*1 esc
-	parameter(esc = char(27))
-	integer i
-	data (b(i:i),i=1,2)/esc,'a'/
-	data (c(i:i),i=1,2)/esc,'b'/	! memory fault
-	call foo(b,c)
-	end
-
-Fri Mar  1 23:44:51 EST 1996
-  Fix glitch in evaluating .EQ. and .NE. when both operands are
-logical constants (.TRUE. or .FALSE.).
-
-Fri Mar 15 17:29:54 EST 1996
-  libi77: lread.c, rsfe.c: honor END= in READ stmts with empty iolist.
-
-Tue Mar 19 23:08:32 EST 1996
-  lex.c: arrange for a "statement" consisting of a single short bogus
-keyword to elicit an error message showing the whole keyword.  The
-error message formerly omitted the last letter of the bad keyword.
-  libf77: s_cat.c: supply missing break after overlap detection.
-
-Mon May 13 23:35:26 EDT 1996
-  Recognize Fortran 90's /= as a synonym for .NE..  (<> remains a
-synonym for .NE..)
-  Emit an empty int function of no arguments to supply an external
-name to named block data subprograms (so they can be called somewhere
-to force them to be loaded from a library).
-  Fix bug (memory fault) in handling the following illegal Fortran:
-	parameter(i=1)
-	equivalence(i,j)
-	end
-  Treat cdabs, cdcos, cdexp, cdlog, cdsin, and cdsqrt as synonyms for
-the double complex intrinsics zabs, zcos, zexp, zlog, zsin, and zsqrt,
-respectively, unless -cd is specified.
-  Recognize the Fortran 90 bit-manipulation intrinsics btest, iand,
-ibclr, ibits, ibset, ieor, ior, ishft, and ishftc, unless -i90 is
-specified.  Note that iand, ieor, and ior are thus now synonyms for
-"and", "xor", and "or", respectively.
-  Add three macros (bit_test, bit_clear, bit_set) to f2c.h for use
-with btest, ibclr, and ibset, respectively.  Add new functions
-[lq]bit_bits, [lq]bit_shift, and [lq]_bit_cshift to libF77 for
-use with ibits, ishft, and ishftc, respectively.
-  Add integer function ftell(unit) (returning -1 on error) and
-subroutine fseek(unit, offset, whence, *) to libI77 (with branch to
-label * on error).
-
-Tue May 14 23:21:12 EDT 1996
-  Fix glitch (possible memory fault, or worse) in handling multiple
-entry points with names over 28 characters long.
-
-Mon Jun 10 01:20:16 EDT 1996
-  Update netlib E-mail and ftp addresses in f2c/readme and
-f2c/src/readme (which are different files) -- to reflect the upcoming
-breakup of AT&T.
-  libf77: trivial tweaks to F77_aloc.c and system_.c; Version.c not
-changed.
-  libi77: Adjust rsli.c and lread.c so internal list input with too
-few items in the input string will honor end= .
-
-Mon Jun 10 22:59:57 EDT 1996
-  Add Bits_per_Byte to sysdep.h and adjust definition of Table_size
-to depend on Bits_per_Byte (forcing Table_size to be a power of 2); in
-lex.c, change "comstart[c & 0xfff]" to "comstart[c & (Table_size-1)]"
-to avoid an out-of-range subscript on end-of-file.
-
-Wed Jun 12 00:24:28 EDT 1996
-  Fix bug in output.c (dereferencing a freed pointer) revealed in
-	print *		!np in out_call in output.c clobbered by free
-	end		!during out_expr.
-
-Wed Jun 19 08:12:47 EDT 1996
-  f2c.h: add types uinteger, ulongint (for libF77); add qbit_clear
-and qbit_set macros (in a commented-out section) for integer*8.
-  For integer*8, use qbit_clear and qbit_set for ibclr and ibset.
-  libf77: add casts to unsigned in [lq]bitshft.c.
-
-Thu Jun 20 13:30:43 EDT 1996
-  Complain at character*(*) in common (rather than faulting).
-  Fix bug in recognizing hex constants that start with "16#" (e.g.,
-16#1234abcd, which is a synonym for z'1234abcd').
-  Fix bugs in constant folding of expressions involving btest, ibclr,
-and ibset.
-  Fix bug in constant folding of rshift(16#80000000, -31) (on a 32-bit
-machine; more generally, the bug was in constant folding of
-rshift(ibset(0,NBITS-1), 1-NBITS) when f2c runs on a machine with
-long ints having NBITS bits.
-
-Mon Jun 24 07:58:53 EDT 1996
-  Adjust struct Literal and newlabel() function to accommodate huge
-source files (with more than 32767 newlabel() invocations).
-  Omit .c file when the .f file has a missing final end statement.
-
-Wed Jun 26 14:00:02 EDT 1996
-  libi77: Add discussion of MXUNIT (highest allowed Fortran unit number)
-to libI77/README.
-
-Fri Jun 28 14:16:11 EDT 1996
-  Fix glitch with -onetrip: the temporary variable used for nonconstant
-initial loop variable values was recycled too soon.  Example:
-	do i = j+1, k
-		call foo(i+1)	! temp for j+1 was reused here
-		enddo
-	end
-
-Tue Jul  2 16:11:27 EDT 1996
-  formatdata.c: add a 0 to the end of the basetype array (for TYBLANK)
-(an omission that was harmless on most machines).
-  expr.c: fix a dereference of NULL that was only possible with buggy
-input, such as
-	subroutine $sub(s)	! the '$' is erroneous
-	character s*(*)
-	s(1:) = ' '
-	end
-
-Sat Jul  6 00:44:56 EDT 1996
-  Fix glitch in the intrinsic "real" function when applied to a
-complex (or double complex) variable and passed as an argument to
-some intrinsic functions.  Example:
-	complex a
-	b = sqrt(a)
-	end
-  Fix glitch (only visible if you do not use f2c's malloc and the
-malloc you do use is defective in the sense that malloc(0) returns 0)
-in handling include files that end with another include (perhaps
-followed by comments).
-  Fix glitch with character*(*) arguments named "h" and "i" when
-the body of the subroutine invokes the intrinsic LEN function.
-  Arrange that after a previous "f2c -P foo.f" has produced foo.P,
-running "f2c foo.P foo.f" will produce valid C when foo.f contains
-	call sub('1234')
-	end
-	subroutine sub(msg)
-	end
-Specifically, the length argument in "call sub" is now suppressed.
-With or without foo.P, it is also now suppressed when the order of
-subprograms in file foo.f is reversed:
-	subroutine sub(msg)
-	end
-	call sub('1234')
-	end
-  Adjust copyright notices to reflect AT&T breakup.
-
-Wed Jul 10 09:25:49 EDT 1996
-  Fix bug (possible memory fault) in handling erroneously placed
-and inconsistent declarations.  Example that faulted:
-	character*1 w(8)
-	call foo(w)
-	end
-	subroutine foo(m)
-	data h /0.5/
-	integer m(2)	! should be before data
-	end
-  Fix bug (possible fault) in handling illegal "if" constructions.
-Example (that faulted):
-	subroutine foo(i,j)
-	if (i) then		! bug: i is integer, not logical
-	else if (j) then	! bug: j is integer, not logical
-	endif
-	end
-  Fix glitch with character*(*) argument named "ret_len" to a
-character*(*) function.
-
-Wed Jul 10 23:04:16 EDT 1996
-  Fix more glitches in the intrinsic "real" function when applied to a
-complex (or double complex) variable and passed as an argument to
-some intrinsic functions.  Example:
-	complex a, b
-	r = sqrt(real(conjg(a))) + sqrt(real(a*b))
-	end
-
-Thu Jul 11 17:27:16 EDT 1996
-  Fix a memory fault associated with complicated, illegal input.
-Example:
-	subroutine goo
-	character a
-	call foo(a)	! inconsistent with subsequent def and call
-	end
-	subroutine foo(a)
-	end
-	call foo(a)
-	end
-
-Wed Jul 17 19:18:28 EDT 1996
-  Fix yet another case of intrinsic "real" applied to a complex
-argument.  Example:
-	complex a(3)
-	x = sqrt(real(a(2)))	! gave error message about bad tag
-	end
-
-Mon Aug 26 11:28:57 EDT 1996
-  Tweak sysdep.c for non-Unix systems in which process ID's can be
-over 5 digits long.
-
-Tue Aug 27 08:31:32 EDT 1996
-  Adjust the ishft intrinsic to use unsigned right shifts.  (Previously,
-a negative constant second operand resulted in a possibly signed shift.)
-
-Thu Sep 12 14:04:07 EDT 1996
-  equiv.c: fix glitch with -DKR_headers.
-  libi77: fmtlib.c: fix bug in printing the most negative integer.
-
-Fri Sep 13 08:54:40 EDT 1996
-  Diagnose some illegal appearances of substring notation.
-
-Tue Sep 17 17:48:09 EDT 1996
-  Fix fault in handling some complex parameters.  Example:
-	subroutine foo(a)
-	double complex a, b
-	parameter(b = (0,1))
-	a = b	! f2c faulted here
-	end
-
-Thu Sep 26 07:47:10 EDT 1996
-  libi77:  fmt.h:  for formatted writes of negative integer*1 values,
-make ic signed on ANSI systems.  If formatted writes of integer*1
-values trouble you when using a K&R C compiler, switch to an ANSI
-compiler or use a compiler flag that makes characters signed.
-
-Tue Oct  1 14:41:36 EDT 1996
-  Give a better error message when dummy arguments appear in data
-statements.
-
-Thu Oct 17 13:37:22 EDT 1996
-  Fix bug in typechecking arguments to character and complex (or
-double complex) functions; the bug could cause length arguments
-for character arguments to be omitted on invocations appearing
-textually after the first invocation.  For example, in
-	subroutine foo
-	character c
-	complex zot
-	call goo(zot(c), zot(c))
-	end
-the length was omitted from the second invocation of zot, and
-there was an erroneous error message about inconsistent calling
-sequences.
-
-Wed Dec  4 13:59:14 EST 1996
-  Fix bug revealed by
-	subroutine test(cdum,rdum)
-	complex cdum
-	rdum=cos(real(cdum))	! "Unexpected tag 3 in opconv_fudge"
-	end
-  Fix glitch in parsing "DO 10 D0 = 1, 10".
-  Fix glitch in parsing
-	real*8 x
-	real*8 x	! erroneous "incompatible type" message
-	call foo(x)
-	end
-
-Mon Dec  9 23:15:02 EST 1996
-  Fix glitch in parameter adjustments for arrays whose lower
-bound depends on a scalar argument.  Example:
-	subroutine bug(p,z,m,n)
-	integer z(*),m,n
-	double precision p(z(m):z(m) + n)	! p_offset botched
-	call foo(p(0), p(n))
-	end
-  libi77: complain about non-positive rec= in direct read and write
-statements.
-  libf77: trivial adjustments; Version.c not changed.
-
-Wed Feb 12 00:18:03 EST 1997
-  output.c: fix (seldom problematic) glitch in out_call: put parens
-around the ... in a test of the form "if (q->tag == TADDR && ...)".
-  vax.c: fix bug revealed in the "psi_offset =" assignment in the
-following example:
-	subroutine foo(psi,m)
-	integer z(100),m
-	common /a/ z
-	double precision psi(z(m):z(m) + 10)
-	call foo(m+1, psi(0),psi(10))
-	end
-
-Mon Feb 24 23:44:54 EST 1997
-  For consistency with f2c's current treatment of adjacent character
-strings in FORMAT statements, recognize a Hollerith string following
-a string (and merge adjacent strings in FORMAT statements).
-
-Wed Feb 26 13:41:11 EST 1997
-  New libf2c.zip, a combination of the libf77 and libi77 bundles (and
-available only by ftp).
-  libf77: adjust functions with a complex output argument to permit
-aliasing it with input arguments.  (For now, at least, this is just
-for possible benefit of g77.)
-  libi77: tweak to ftell_.c for systems with strange definitions of
-SEEK_SET, etc.
-
-Tue Apr  8 20:57:08 EDT 1997
-  libf77: [cz]_div.c: tweaks invisible on most systems (that may
-improve things slightly with optimized compilation on systems that use
-gratuitous extra precision).
-  libi77: fmt.c: adjust to complain at missing numbers in formats
-(but still treat missing ".nnn" as ".0").
-
-Fri Apr 11 14:05:57 EDT 1997
-  libi77: err.c: attempt to make stderr line buffered rather than
-fully buffered.  (Buffering is needed for format items T and TR.)
-
-Thu Apr 17 22:42:43 EDT 1997
- libf77: add F77_aloc.o to makefile (and makefile.u in libf2c.zip).
-
-Fri Apr 25 19:32:09 EDT 1997
- libf77: add [de]time_.c (which may give trouble on some systems).
-
-Tue May 27 09:18:52 EDT 1997
- libi77: ftell_.c: fix typo that caused the third argument to be
-treated as 2 on some systems.
-
-Mon Jun  9 00:04:37 EDT 1997
- libi77 (and libf2c.zip): adjust include order in err.c lread.c wref.c
-rdfmt.c to include fmt.h (etc.) after system includes.  Version.c not
-changed.
-
-Mon Jul 21 16:04:54 EDT 1997
-  proc.c: fix glitch in logic for "nonpositive dimension" message.
-  libi77: inquire.c: always include string.h (for possible use with
--DNON_UNIX_STDIO); Version.c not changed.
-
-Thu Jul 24 17:11:23 EDT 1997
-  Tweak "Notice" to reflect the AT&T breakup -- we missed it when
-updating the copyright notices in the source files last summer.
-  Adjust src/makefile so malloc.o is not used by default, but can
-be specified with "make MALLOC=malloc.o".
-  Add comments to src/README about the "CRAY" T3E.
-
-Tue Aug  5 14:53:25 EDT 1997
-  Add definition of calloc to malloc.c; this makes f2c's malloc
-work on some systems where trouble hitherto arose because references
-to calloc brought in the system's malloc.  (On sensible systems,
-calloc is defined separately from malloc.  To avoid confusion on
-other systems, f2c/malloc.c now defines calloc.)
-  libi77: lread.c: adjust to accord with a change to the Fortran 8X
-draft (in 1990 or 1991) that rescinded permission to elide quote marks
-in namelist input of character data; to get the old behavior, compile
-with F8X_NML_ELIDE_QUOTES #defined.  wrtfmt.o: wrt_G: tweak to print
-the right number of 0's for zero under G format.
-
-Sat Aug 16 05:45:32 EDT 1997
-  libi77: iio.c: fix bug in internal writes to an array of character
-strings that sometimes caused one more array element than required by
-the format to be blank-filled.  Example: format(1x).
-
-Wed Sep 17 00:39:29 EDT 1997
-  libi77: fmt.[ch] rdfmt.c wrtfmt.c: tweak struct syl for machines
-with 64-bit pointers and 32-bit ints that did not 64-bit align
-struct syl (e.g., Linux on the DEC Alpha).  This change should be
-invisible on other machines.
-
-Sun Sep 21 22:05:19 EDT 1997
-  libf77: [de]time_.c (Unix systems only): change return type to double.
-
-Thu Dec  4 22:10:09 EST 1997
-  Fix bug with handling large blocks of comments (over 4k); parts of the
-second and subsequent blocks were likely to be lost (not copied into
-comments in the resulting C).  Allow comment lines to be longer before
-breaking them.
-
-Mon Jan 19 17:19:27 EST 1998
-  makefile: change the rule for making gram.c to one for making gram1.c;
-henceforth, asking netlib to "send all from f2c/src" will bring you a
-working gram.c.  Nowadays there are simply too many broken versions of
-yacc floating around.
-  libi77: backspace.c: for b->ufmt==0, change sizeof(int) to
-sizeof(uiolen).  On machines where this would make a difference, it is
-best for portability to compile libI77 with -DUIOLEN_int, which will
-render the change invisible.
-
-Tue Feb 24 08:35:33 EST 1998
-  makefile: remove gram.c from the "make clean" rule.
-
-Wed Feb 25 08:29:39 EST 1998
-  makefile: change CFLAGS assignment to -O; add "veryclean" rule.
-
-Wed Mar  4 13:13:21 EST 1998
-  libi77: open.c: fix glitch in comparing file names under
--DNON_UNIX_STDIO.
-
-Mon Mar  9 23:56:56 EST 1998
-  putpcc.c: omit an unnecessary temporary variable in computing
-(expr)**3.
-  libf77, libi77: minor tweaks to make some C++ compilers happy;
-Version.c not changed.
-
-Wed Mar 18 18:08:47 EST 1998
-  libf77: minor tweaks to [ed]time_.c; Version.c not changed.
-  libi77: endfile.c, open.c: acquire temporary files from tmpfile(),
-unless compiled with -DNON_ANSI_STDIO, which uses mktemp().
-New buffering scheme independent of NON_UNIX_STDIO for handling T
-format items.  Now -DNON_UNIX_STDIO is no longer be necessary for
-Linux, and libf2c no longer causes stderr to be buffered -- the former
-setbuf or setvbuf call for stderr was to make T format items work.
-open.c: use the Posix access() function to check existence or
-nonexistence of files, except under -DNON_POSIX_STDIO, where trial
-fopen calls are used.  In open.c, fix botch in changes of 19980304.
-  libf2c.zip: the PC makefiles are now set for NT/W95, with comments
-about changes for DOS.
-
-Fri Apr  3 17:22:12 EST 1998
-  Adjust fix of 19960913 to again permit substring notation on
-character variables in data statements.
-
-Sun Apr  5 19:26:50 EDT 1998
-  libi77: wsfe.c: make $ format item work: this was lost in the changes
-of 17 March 1998.
-
-Sat May 16 19:08:51 EDT 1998
-  Adjust output of ftnlen constants: rather than appending L,
-prepend (ftnlen).  This should make the resulting C more portable,
-e.g., to systems (such as DEC Alpha Unix systems) on which long
-may be longer than ftnlen.
-  Adjust -r so it also casts REAL expressions passed to intrinsic
-functions to REAL.
-
-Wed May 27 16:02:35 EDT 1998
-  libf2c.zip: tweak description of compiling libf2c for INTEGER*8
-to accord with makefile.u rather than libF77/makefile.
-
-Thu May 28 22:45:59 EDT 1998
-  libi77: backspace.c dfe.c due.c iio.c lread.c rsfe.c sue.c wsfe.c:
-set f__curunit sooner so various error messages will correctly
-identify the I/O unit involved.
-  libf2c.zip: above, plus tweaks to PC makefiles: for some purposes,
-it's still best to compile with -DMSDOS (even for use with NT).
-
-Thu Jun 18 01:22:52 EDT 1998
-  libi77: lread.c: modified so floating-point numbers (containing
-either a decimal point or an exponent field) are treated as errors
-when they appear as list input for integer data.  Compile lread.c with
--DALLOW_FLOAT_IN_INTEGER_LIST_INPUT to restore the old behavior.
-
-Mon Aug 31 10:38:54 EDT 1998
-  formatdata.c: if possible, and assuming doubles must be aligned on
-double boundaries, use existing holes in DATA for common blocks to
-force alignment of the block.  For example,
-	block data
-	common /abc/ a, b
-	double precision a
-	integer b(2)
-	data b(2)/1/
-	end
-used to generate
-	struct {
-	    integer fill_1[3];
-	    integer e_2;
-	    doublereal e_3;
-	    } abc_ = { {0}, 1, 0. };
-and now generates
-	struct {
-	    doublereal fill_1[1];
-	    integer fill_2[1];
-	    integer e_3;
-	    } abc_ = { {0}, {0}, 1 };
-In the old generated C, e_3 was added to force alignment; in the new C,
-fill_1 does this job.
-
-Mon Sep  7 19:48:51 EDT 1998
-  libi77: move e_wdfe from sfe.c to dfe.c, where it was originally.
-Why did it ever move to sfe.c?
-
-Tue Sep  8 10:22:50 EDT 1998
-  Treat dreal as a synonym for dble unless -cd is specified on the
-command line.
-
-Sun Sep 13 22:23:41 EDT 1998
-  format.c: fix bug in writing prototypes under f2c -A ... *.P:
-under some circumstances involving external functions with no known
-type, a null pointer was passed to printf.
-
-Tue Oct 20 23:25:54 EDT 1998
-  Comments added to libf2c/README and libF77/README, pointing out
-the need to modify signal1.h on some systems.
-
-Wed Feb 10 22:59:52 EST 1999
-  defs.h lex.c: permit long names (up to at least roughly
-MAX_SHARPLINE_LEN = 1000 characters long) in #line lines (which only
-matters under -g).
-  fc: add -U option; recognize .so files.
-
-Sat Feb 13 10:18:27 EST 1999
- libf2c: endfile.c, lread.c, signal1.h0: minor tweaks to make some
-(C++) compilers happier; f77_aloc.c: make exit_() visible to C++
-compilers.  Version strings not changed.
-
-Thu Mar 11 23:14:02 EST 1999
-  Modify f2c (exec.c, expr.c) to diagnose incorrect mixing of types
-when (f2c extended) intrinsic functions are involved, as in
-(not(17) .and. 4).  Catching this in the first executable statement
-is a bit tricky, as some checking must be postponed until all statement
-function declarations have been parsed.  Thus there is a chance of
-today's changes introducing bugs under (let us hope) unusual conditions.
-
-Sun Mar 28 13:17:44 EST 1999
-  lex.c: tweak to get the file name right in error messages caused
-by statements just after a # nnn "filename" line emitted by the C
-preprocessor.  (The trouble is that the line following the # nnn line
-must be read to see if it is a continuation of the stuff that preceded
-the # nnn line.)  When # nnn "filename" lines appear among the lines
-for a Fortran statement, the filename reported in an error message for
-the statement should now be the file that was current when the first
-line of the statement was read.
-
-Sun May  2 22:38:25 EDT 1999
-  libf77, libi77, libf2c.zip: make getenv_() more portable (call
-getenv() rather than knowing about char **environ); adjust some
-complex intrinsics to work with overlapping arguments (caused by
-inappropriate use of equivalence); open.c: get "external" versus
-"internal" right in the error message if a file cannot be opened;
-err.c: cast a pointer difference to (int) for %d; rdfmt.c: omit
-fixed-length buffer that could be overwritten by formats Inn or Lnn
-with nn > 83.
-
-Mon May  3 13:14:07 EDT 1999
-  "Invisible" changes to omit a few compiler warnings in f2c and
-libf2c; two new casts in libf2c/open.c that matter with 64-bit longs,
-and one more tweak (libf2c/c_log.c) for pathological equivalences.
-  Minor update to "fc" script: new -L flag and comment correction.
-
-Fri Jun 18 02:33:08 EDT 1999
-  libf2c.zip: rename backspace.c backspac.c, and fix a glitch in it
--- b->ufd may change in t_runc().  (For now, it's still backspace.c
-in the libi77 bundle.)
-
-Sun Jun 27 22:05:47 EDT 1999
-  libf2c.zip, libi77: rsne.c: fix bug in namelist input: a misplaced
-increment could cause wrong array elements to be assigned; e.g.,
-"&input k(5)=10*1 &end" assigned k(5) and k(15 .. 23).
-
-Tue Sep  7 14:10:24 EDT 1999
-  f2c.h, libf2c/f2c.h0, libf2c/README: minor tweaks so a simple
-sed command converts f2c.h == libf2c/f2c.h0 to a form suitable for
-machines with 8-byte longs and doubles, 4-byte int's and floats,
-while working with a forthcoming (ill-advised) update to the C
-standard that outlaws plain "unsigned".
-  f2c.h, libf2c/f2c.h0: change "if 0" to "#ifdef INTEGER_STAR_8".
-  libf77, libf2c.zip: [cz]_div.c and README: arrange for compilation
-under -DIEEE_COMPLEX_DIVIDE to make these routines avoid calling sig_die
-when the denominator of a complex or double complex division vanishes;
-instead, they return pairs of NaNs or Infinities, depending whether the
-numerator also vanishes or not.
-
-Tue Oct  5 23:50:14 EDT 1999
-  formatdata.c, io.c, output.c, sysdep.c: adjust to make format
-strings legal when they contain 8-bit characters with the high bit on.
-(For many C compilers, this is not necessary, but it the ANSI/ISO C
-standard does not require this to work.)
-  libf2c.zip: tweak README and correct xsum0.out.
-
-Mon Oct 25 17:30:54 EDT 1999
-  io.c: fix glitch introduced in the previous change (19991005) that
-caused format(' %') to print "%%" rather than "%".
-
-Mon Nov 15 12:10:35 EST 1999
-  libf2c.zip: fix bug with the sequence backspace(n); endfile(n);
-rewind(n); read(n).  Supply missing (long) casts in a couple of places
-where they matter when size(ftnint) == sizeof(int) < sizeof(long).
-
-Tue Jan 18 19:22:24 EST 2000
-  Arrange for parameter statements involving min(...) and max(...)
-functions of three or more arguments to work.
-  Warn about text after "end" (rather than reporting a syntax error
-with a surprising line number).
-  Accept preprocessor line numbers of the form "# 1234" (possibly
-with trailing blanks).
-  Accept a comma after write(...) and before a list of things to write.
-
-Fri Jan 21 17:26:27 EST 2000
-  Minor updates to make compiling Win32 console binaries easier.  A
-side effect is that the MSDOS restriction of only one Fortran file
-per invocation is lifted (and "f2c *.f") works.
-
-Tue Feb  1 18:38:32 EST 2000
-  f2c/src/tokdefs.h added (to help people on non-Unix systems -- the
-makefile has always had a rule for generating tokdefs.h).
-
-Fri Mar 10 18:48:17 EST 2000
-  libf77, libf2c.zip: z_log.c: the real part of the double complex log
-of numbers near, e.g., (+-1,eps) with |eps| small is now more accurate.
-For example if z = (1,1d-7), then "write(*,*) z" now writes
-"(5.E-15,1.E-07" rather than the previous "(4.88498131E-15,1.E-07)".
-
-Thu Apr 20 13:02:54 EDT 2000
-  libf77, libi77, libf2c.zip: s_cat.c, rsne.c, xwsne.c: fix type
-errors that only matter if sizeof(ftnint) != sizeof(ftnlen).
-
-Tue May 30 23:36:18 EDT 2000
-  expr.c: adjust subcheck() to use a temporary variable of type TYLONG
-rather than TYSHORT under -C -I2.
-
-Wed May 31 08:48:03 EDT 2000
-  Simplify yesterday's adjustment; today's change should be invisible.
-
-Tue Jul  4 22:52:21 EDT 2000
-  misc.c, function "addressable": fix fault with "f2c -I2 foo.f" when
-foo.f consists of the 4 lines
-	subroutine foo(c)
-	character*(*) c
-	i = min(len(c),23)
-	end
-  Sundry files: tweaks for portability, e.g., for compilation by overly
-fastidious C++ compilers; "false" and "true" now treated as C keywords
-(so they get two underscores appended).
-  libf77, libi77, libf2c.zip: "invisible" adjustments to permit
-compilation by C++ compilers; version numbers not changed.
-
-Thu Jul  6 23:46:07 EDT 2000
-  Various files: tweaks to banish more compiler warnings.
-  lib?77, libf2c.zip/makefile.u: add "|| true" to ranlib invocations.
-  Thanks to Nelson H. F. Beebe for messages leading to these changes
-(and to many of the ones two days ago).
-  xsum.c: tweak include order.
-
-Fri Jul  7 18:01:25 EDT 2000
-  fc: accept -m xxx or -mxxx, pass them to the compiler as -mxxx
-(suggestion of Nelson Beebe).  Note that fc simply appends to CFLAGS,
-so system-specific stuff can be supplied in the environment variable
-CFLAGS.  With some shells, invocations of the form
-	CFLAGS='system-specific stuff' fc ...
-are one way to do this.
-
-Thu Aug 17 21:38:36 EDT 2000
-  Fix obscure glitch: in "Error on line nnn of ...: Bad # line:...",
-get nnn right.
-
-Sat Sep 30 00:28:30 EDT 2000
-  libf77, libf2c.zip: dtime_.c, etime_.c: use floating-point divide;
-dtime_.d, erf_.c, erfc_.c, etime.c: for use with "f2c -R", compile with
--DREAL=float.
-
-Tue Dec  5 22:55:56 EST 2000
-  lread.c: under namelist input, when reading a logical array, treat
-Tstuff= and Fstuff= as new assignments rather than as logical constants.
-
-Fri Feb 23 00:43:56 EST 2001
-  libf2c: endfile.c: adjust to use truncate() unless compiled with
--DNO_TRUNCATE (or with -DMSDOS).  Add libf2c/mkfile.plan9.
-
-Sat Feb 24 21:14:24 EST 2001
-  Prevent malloc(0) when a subroutine of no arguments has an entry
-with no arguments, as in
-	subroutine foo
-	entry goo
-	end
-  Fix a fault that was possible when MAIN (illegally) had entry points.
-  Fix a buffer overflow connected with the error message for names more
-than MAXNAMELEN (i.e., 50) bytes long.
-  Fix a bug in command-line argument passing that caused the invocation
-"f2c -!czork foo.f" to complain about two invalid flags ('-ork' and
-'-oo.f') instead of just one ('-ork').
-  fc: add -s option (strip executable); portability tweaks.
-  Adjustments to handing of integer*8 to permit processing 8-byte hex,
-binary, octal, and decimal constants.  The adjustments are only
-available when type long long (for >= 64 bit integers) is available to
-f2c; they are assumed available unless f2c is compiled with either
--DNO_TYQUAD or -DNO_LONGLONG.  As has long been the case, compilation
-of f2c itself with -DNO_TYQUAD eliminates recognition of integer*8
-altogether.  Compilation with just -DNO_LONGLONG permits the previous
-handling of integer*8, which could only handle 32-bit constants
-associated with integer*8 variables.
-  New command-line argument -i8const (available only when f2c itself
-is compiled with neither -DNO_TYQUAD nor -DNO_LONGLONG) suppresses
-the new automatic promotion of integer constants too long to express
-as 32-bit values to type integer*8.  There are corresponding updates
-to f2c.1 and f2c.1t.
-
-Wed Feb 28 00:50:04 EST 2001
-  Adjust misc.c for (older) systems that recognize long long but do not
-have LLONG_MAX or LONGLONG_MAX in limits.h.
-  main.c: filter out bad files before dofork loop to avoid trouble
-in Win32 "f2c.exe" binaries.
-
-Thu Mar  1 16:25:19 EST 2001
-  Cosmetic change for consistency with some other netlib directories:
-change NO_LONGLONG to NO_LONG_LONG.  (This includes adjusting the above
-entry for Feb 23 2001.)  No change (other than timestamp) to version.c.
-  libf2c:  endfile.c:  switch to ftruncate (absent -DNO_TRUNCATE),
-thus permitting truncation of scratch files on true Unix systems,
-where scratch files have no name.  Add an fflush() (surprisingly)
-needed on some Linux systems.
-
-Tue Mar 20 22:03:23 EST 2001
-  expr.c:  complain ("impossible conversion") about attempts to assign
-character expressions ... to integer variables, rather than implicitly
-assigning ichar(...).
-
-Sat Jun 23 23:08:22 EDT 2001
-  New command-line option -trapuv adds calls on _uninit_f2c() to prologs
-to dynamically initialize local variables, except those appearing in
-SAVE or DATA statements, with values that may help find references to
-uninitialized variables.  For example, with IEEE arithmetic, floating-
-point variables are initialized to signaling NaNs.
-  expr.c: new warning for out-of-bounds constant substring expressions.
-Under -C, such expressions now inhibit C output.
-  libf2c/mkfile.plan9: fix glitch with rule for "check" (or xsum.out).
-  libf2c.zip: add uninit.c (for _uninit_f2c()) in support of -trapuv.
-  fc, f2c.1, f2c.1t: adjust for -trapuv.
-
-Thu Jul  5 22:00:51 EDT 2001
-  libf2c.zip: modify uninit.c for __mc68k__ under Linux.
-
-Wed Aug 22 08:01:37 EDT 2001
-  cds.c, expr.c: in constants, preserve the sign of 0.
-  expr.c: fix some glitches in folding constants to integer*8
-(when NO_LONG_LONG is not #defined).
-  intr.c: fold constant min(...) and max(...) expressions.
-
-Fri Nov 16 02:00:03 EST 2001
-  libf2c.zip:  tweak to permit handling files over 2GB long where
-possible, with suitable -D options, provided for some systems in
-new header file sysdep1.h (copied from sysdep1.h0 by default).
-Add an fseek to endfile.c to fix a glitch on some systems.
-
-Wed Nov 28 17:58:12 EST 2001
-  libf2c.zip:  on IEEE systems, print -0 as -0 when the relevant
-libf2c/makefile.* is suitably adjusted:  see comments about
--DSIGNED_ZEROS in libf2c/makefile.*.
-
-Fri Jan 18 16:17:44 EST 2002
-  libf2c.zip:   fix bugs (reported by Holger Helmke) in qbit_bits():
-wrong return type, missing ~ on y in return value.  This affects
-the intrinsic ibits function for first argument of type integer*8.
-
-Thu Feb  7 17:14:43 EST 2002
-  Fix bug handling leading array dimensions in common:  invalid C
-resulted.  Example (after one provided by Dmitry G. Baksheyev):
-
-	subroutine foo(a)
-	common/c/m
-	integer m, n
-	equivalence(m,n)
-	integer a(n,2)
-	a(1,2) = 3
-	end
-
-  Fix a bug, apparently introduced sometime after 19980913, in
-handling certain substring expressions that involve temporary
-assignments and the first invocation of an implicitly typed function.
-When the expressions appeared in "else if (...)"  and "do while(...)",
-the temporary assignments appeared too soon.  Examples are hard to
-find, but here is one (after an example provided by Nat Bachman):
-
-	subroutine foo(n)
-	character*8 s
-	do while (moo(s(n+1:n+2)) .ge. 2)
-		n = n + 1
-		enddo
-	end
-
-It is hard for f2c to get this sort of example correct when the
-"untyped" function is a generic intrinsic.  When incorrect code would
-otherwise result, f2c now issues an error message and declines to
-produce C.  For example,
-
-	subroutine foo(n)
-	character*8 s
-	double precision goo
-	do while (sin(goo(s(n+1:n+2))) .ge. 2)
-		n = n + 1
-		enddo
-	end
-
-gives the new error message, but both
-
-	subroutine foo(n)
-	character*8 s
-	double precision goo
-	do while (dsin(goo(s(n+1:n+2))) .ge. 2)
-		n = n + 1
-		enddo
-	end
-and
-	subroutine foo(n)
-	character*8 s
-	double precision goo
-	do while (sin(goo(min(n, (n-3)**2))) .ge. 2)
-		n = n + 1
-		enddo
-	end
-
-give correct C.
-
-Fri Feb  8 08:43:40 EST 2002
-  Make a cleaner fix of the bug fixed yesterday in handling certain
-"do while(...)" and "else if (...)" constructs involving auxiliary
-assignments.  (Yesterday's changes to expr.c are recanted; expr.c
-is now restored to that of 20010820.)  Now
-
-	subroutine foo(n)
-	character*8 s
-	double precision goo
-	do while (sin(goo(s(n+1:n+2))) .ge. 0.2)
-		n = n + 1
-		enddo
-	end
-
-is correctly translated.
-
-Thu Mar 14 12:53:08 EST 2002
-  lex.c:  adjust to avoid an error message under -72 when source files
-are in CRLF form ("text mode" on Microsoft systems), a source line is
-exactly 72 characters long, and f2c is run on a system (such as a Unix
-or Linux system) that does not distinguish text and binary modes.
-Example (in CRLF form):
-      write(*,*)"Hello world, with a source line that is 72 chars long."
-      end
-  libf2c/z_log.c:  add code to cope with buggy compilers (e.g., some
-versions of gcc under -O2 or -O3) that do floating-point comparisons
-against values computed into extended-precision registers on some
-systems (such as Intel IA32 systems).  Compile with
--DNO_DOUBLE_EXTENDED to omit the kludge that circumvents this bug.
-
-Thu May  2 19:09:01 EDT 2002
-  src/misc.c, src/sysdep.h, src/gram.c: tweaks for KR_headers (a rare
-concern today); version.c touched but left unchanged.
-  libf2c: fix glitch in makefile.vc; KR_header tweaks in s_stop.c
-and uninit.c (which also had a misplaced #endif).
-
-Wed Jun  5 16:13:34 EDT 2002
-  libf2c: uninit.c: for Linux on an ARM processor, add some
-#ifndef _FPU... tests; f77vers.c not changed.
-
-Tue Jun 25 15:13:32 EDT 2002
-  New command-line option -K requests old-style ("K&R") C.  The
-default is changed to -A (ANSI/ISO style).
-  Under -K, cast string-length arguments to (ftnlen).  This should
-matter only in the unusual case that "readme" instructs obtaining
-f2c.h by
-	sed 's/long int /long long /' f2c.h0 >f2c.h
-  Increase defaults for some table sizes:  make -Nn802 -Nq300 -Nx400
-the default.
-
-Fri Sep  6 18:39:24 EDT 2002
-  libf2c.zip: rsne.c: fix bug with multiple repeat counts in reading
-namelists, e.g., &nl a(2) = 3*1.0, 2*2.0, 3*3.0 /
-(Bug found by Jim McDonald, reported by Toon Moene.)
-
-Fri Oct  4 10:23:51 EDT 2002
-  libf2c.zip: uninit.c: on IRIX systems, omit references to shell
-variables (a dreg).  This only matters with f2c -trapuv .
-
-Thu Dec 12 22:16:00 EST 2002
-  proc.c: tweak to omit "* 1" from "a_offset = 1 + a_dim1 * 1;".
-  libf2c.zip: uninit.c: adjust to work with HP-UX B.11.11 as well as
-HP-UX B.10.20; f77vers.c not changed.
-
-Tue Feb 11 08:19:54 EST 2003
-  Fix a fault with f2c -s on the following example of invalid Fortran
-(reported by Nickolay A. Khokhlov); "function" should appear before
-"cat" on the first line:
-	character*(*) cat(a, b)
-	character*(*) a, b
-	cat = a // b
-	end
-  Issue warnings about inappropriate uses of arrays a, b, c and pass
-a temporary for d in
-	real a(2), b(2), c(2), d
-	call foo((a), 1*b, +c, +d)
-	end
-(correcting bugs reported by Arnaud Desitter).
-
-Thu Mar  6 22:48:08 EST 2003
-  output.c: fix a bug leading to "Unexpected tag 4 in opconv_fudge"
-when f2c -s processes the real part of a complex array reference.
-Example (simplified from netlib/linpack/zchdc.f):
-
-	subroutine foo(a,work,n,k)
-	integer k, n
-	complex*16 a(n,n), work(n)
-	work(k) = dcmplx(dsqrt(dreal(a(k,k))),0.0d0)
-	end
-
-(Thanks to Nickolay A. Khokhlov for the bug report.)
-
-Thu Mar 20 13:50:12 EST 2003
-  format.c:  code around a bug (reported by Nelson H. F. Beebe) in
-some versions of FreeBSD.  Compiling with __FreeBSD__ but not
-NO_FSCANF_LL_BUG #defined or with FSCANF_LL_BUG #defined causes
-special logic to replace  fscanf(infile, "%llx", result)  with
-custom logic.  Here's an example (from Beebe) where the bug bit:
-	integer*8 m, n
-	m = 9223372036854775807
-	end
-
-Fri Mar 21 13:14:05 EST 2003
-  libf2c.zip: err.c: before writing to a file after reading from it,
-do an f_seek(file, 0, SEEK_CUR) to make writing legal in ANSI C.
-
-Fri Jun  6 14:56:44 EDT 2003
-libf2c.zip:  add comments about libf2c.so (and a rule that works under
-Linux, after an adjustment to the CFLAGS = line) to libf2c/makefile.u.
-
-Sat Oct 25 07:57:53 MDT 2003
-README, main.c, sysdep.c:  adjust comments about libf2c and expand the
-comments thereon in the C that f2c writes (since too few people read
-the README files).  Change makefile to makefile.u (with the
-expectation that people will "cp makefile.u makefile" and edit
-makefile if necessary) and add makefile.vc (for Microsoft Visual C++).
-
-Thu Oct  7 23:25:28 MDT 2004
-names.c: for convenience of MSVC++ users, map "cdecl" to "cdecl__".
-
-Fri Mar  4 18:40:48 MST 2005
-sysdep.c, makefile.u, new file sysdeptest.c:  changes in response to a
-message forwarded by Eric Grosse from Thierry Carrez <[email protected]>
-(who is apparently unaware of f2c's -T option) about an unlikely
-security issue:  that a local attacker could plant symbolic links in
-/tmp corresponding to temporary file names that f2c generates and thus
-cause overwriting of arbitrary files.  Today's change is that if
-neither -T nor the unusual debugging flag -Dn is specified and the
-system is not an MS-Windows system (which cannot have symbolic links,
-as far as I know), then f2c's temporary files will be written in a
-temporary directory that is readable and writable only by the user and
-that is removed at the end of f2c's execution.  To disable today's
-change, compile sysdep.c with -DNO_TEMPDIR (i.e., with NO_TEMPDIR
-#defined).
-
-Sun Mar 27 20:06:49 MST 2005
-sysdep.c: in set_tmp_names(), fix botched placement of
-"if (debugflag == 1) return;":  move it below declarations.
-
-Sun May  1 21:45:46 MDT 2005
-sysdep.c:  fix a possible fault under -DMSDOS and improper handling
-of a tmpnam failure under the unusual combination of both -DNO_MKDTEMP
-and -DNO_MKSTEMP (without -DNO_TEMPDIR).
-
-Tue Oct  4 23:38:54 MDT 2005
-libf2c.zip:  uninit.c:  on IA32 Linux systems, leave the rounding
-precision alone rather than forcing it to 53 bits; compile with
--DUNINIT_F2C_PRECISION_53 to get the former behavior.  This only
-affects Fortran files translated by f2c -trapuv .
-
-Sun May  7 00:38:59 MDT 2006
-  main.c, version.c:  add options -? (or --help) that print out
-pointers to usage documentation and -v (or --version) that print
-the current version.
-  fc script:  fix botch with -O[123]; recognize --version (or -v)
-and --help (or -?).
-  Add f2c.pdf == PDF version of f2c.ps.
-
-Sun Oct  8 02:45:04 MDT 2006
-  putpcc.c: fix glitch in subscripting complex variables:  subscripts
-of type integer*8 were converted to integer*4, which causes trouble
-when 32-bit addressing does not suffice.
-
-Tue Sep 11 23:54:05 MDT 2007
-  xsum.c:  insert explicit "int" before main.
-
-Mon Dec  3 20:53:24 MST 2007
-  libf2c/main.c: insert explicit "int" before main.
-
-Sat Apr  5 21:39:57 MDT 2008
-  libf2c.zip: tweaks for political C++ and const correctness, and
-to fix ctype trouble in some recent Linux versions.  No behavior
-should change.
-
-Sun Apr  6 22:38:56 MDT 2008
-  libf2c.zip: adjust alternate makefiles to reflect yesterday's change.
-
-Wed Nov 26 23:23:27 MST 2008
-  libf2c.zip: add brief discussion of MacOSX to comments in makefile.u.
-
-Fri Jan  2 23:13:25 MST 2009
-  libf2c.zip: add  -DNO_ISATTY to CFLAGS assignment in makefile.vc.
-
-Sat Apr 11 18:06:00 MDT 2009
-  src/sysdep.c src/sysdeptest.c: tweak for MacOSX (include <unistd.h>).
-
-Wed Jul  7 10:51:12 MDT 2010
-  src/data.c, src/format.c, src/p1output.c:  "invisible" tweaks to
-silence warnings seen in compilation under Ubuntu; version.c not changed.
-
-Fri Aug 27 09:14:17 MDT 2010
-  format.c: make sizeof(buf) depend on MAXNAMELEN to fix a bug with long
-names.  Update mswin/f2c.exe.gz accordingly.
-
-Fri Sep  3 16:03:24 MDT 2010
-  fc:  have "-m ..." modify CC rather than CFLAGS (to affect linking).
-
-Mon Aug  1 13:46:40 MDT 2011
-  README, README in libf2c.zip: update some netlib pointers.
-
-Thu Sep 26 16:42:35 MDT 2013
-  arithchk.c and sysdep1.h0 updated.  The former has a new
-"#ifdef NO_SSZIZE_T" section for use elsewhere.  The latter has a
-change supplied by Gregor Richards for use with some libc variants.
-
-Fri Jul 11 16:29:03 MDT 2014
-  comptry.bat in libf2c.zip updated.
-
-NOTE:  the old libf77 and libi77 bundles are no longer being updated.
-Use libf2c.zip instead.
-
-20160102
-  malloc.c:  use memmove rather than memcpy in realloc().
-
-20181026
-  Fix an allocation glitch in proc.c:
-1149c1149
-< 	    size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr);
----
-> 	    size = sizeof(struct Dimblock) + 2*sizeof(expptr)*(nd-1);
-Thanks to Ole Streicher for pointing out the need for this change.
-
-20190311
-  main.c:  update URL's in "f2c -?" and "f2c --help" output.
diff --git a/contrib/tools/f2c/src/data.c b/contrib/tools/f2c/src/data.c
deleted file mode 100644
index 7da3ecb0462..00000000000
--- a/contrib/tools/f2c/src/data.c
+++ /dev/null
@@ -1,502 +0,0 @@
-/****************************************************************
-Copyright 1990, 1993-1996, 1999, 2001 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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 */
- void
-#ifdef KR_headers
-dataval(repp, valp)
-	register expptr repp;
-	register expptr valp;
-#else
-dataval(register expptr repp, register expptr valp)
-#endif
-{
-	ftnint elen, i, nrep;
-	register Addrp p;
-
-	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) ) {
-		if (valp->tag == TADDR
-		 && valp->addrblock.uname_tag == UNAM_CONST) {
-			/* kludge */
-			frexpr(valp->addrblock.memoffset);
-			valp->tag = TCONST;
-			}
-		else {
-			err("non-constant initializer");
-			goto ret;
-			}
-		}
-
-	if(toomanyinit) goto ret;
-	for(i = 0 ; i < nrep ; ++i)
-	{
-		p = nextdata(&elen);
-		if(p == NULL)
-		{
-			if (lineno != err_lineno)
-				err("too many initializers");
-			toomanyinit = YES;
-			goto ret;
-		}
-		setdata((Addrp)p, (Constp)valp, elen);
-		frexpr((expptr)p);
-	}
-
-ret:
-	frexpr(valp);
-}
-
-
- Addrp
-#ifdef KR_headers
-nextdata(elenp)
-	ftnint *elenp;
-#else
-nextdata(ftnint *elenp)
-#endif
-{
-	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) {
-				char buf[100];
-				sprintf(buf, "bad impldoblock #%lx",
-					(unsigned long)ip);
-				Fatal(buf);
-				}
-			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;
-
- void
-#ifdef KR_headers
-setdata(varp, valp, elen)
-	register Addrp varp;
-	register Constp valp;
-	ftnint elen;
-#else
-setdata(register Addrp varp, register Constp valp, ftnint elen)
-#endif
-{
-	struct Constblock con;
-	register int type;
-	int j, valtype;
-	ftnint i, k, offset;
-	char *varname;
-	static Addrp badvar;
-	register unsigned char *s;
-	static long 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);
-	}
-
-	j = 1;
-
-	switch(type)
-	{
-	case TYLOGICAL:
-	case TYINT1:
-	case TYLOGICAL1:
-	case TYLOGICAL2:
-	case TYSHORT:
-	case TYLONG:
-#ifdef TYQUAD0
-	case TYQUAD:
-#endif
-		dataline(varname, offset, type);
-		prconi(dfile, con.Const.ci);
-		break;
-#ifndef NO_LONG_LONG
-	case TYQUAD:
-		dataline(varname, offset, type);
-		prconq(dfile, con.Const.cq);
-		break;
-#endif
-
-	case TYADDR:
-		dataline(varname, offset, type);
-		prcona(dfile, con.Const.ci);
-		break;
-
-	case TYCOMPLEX:
-	case TYDCOMPLEX:
-		j = 2;
-	case TYREAL:
-	case TYDREAL:
-		dataline(varname, offset, type);
-		prconr(dfile, &con, j);
-		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", (int)k);
-			}
-		break;
-
-	default:
-		badtype("setdata", type);
-	}
-
-}
-
-
-
-/*
-   output form of name is padded with blanks and preceded
-   with a storage class digit
-*/
- char*
-#ifdef KR_headers
-dataname(stg, memno)
-	int stg;
-	long memno;
-#else
-dataname(int stg, long memno)
-#endif
-{
-	static char varname[64];
-	register char *s, *t;
-	char buf[16];
-
-	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);
-}
-
-
-
-
- void
-#ifdef KR_headers
-frdata(p0)
-	chainp p0;
-#else
-frdata(chainp p0)
-#endif
-{
-	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);
-}
-
-
- void
-#ifdef KR_headers
-dataline(varname, offset, type)
-	char *varname;
-	ftnint offset;
-	int type;
-#else
-dataline(char *varname, ftnint offset, int type)
-#endif
-{
-	fprintf(dfile, datafmt, varname, offset, type);
-}
-
- void
-#ifdef KR_headers
-make_param(p, e)
-	register struct Paramblock *p;
-	expptr e;
-#else
-make_param(register struct Paramblock *p, expptr e)
-#endif
-{
-	register expptr q;
-	Constp qc;
-
-	if (p->vstg == STGARG)
-		errstr("Dummy argument %.50s appears in a parameter statement.",
-			p->fvarname);
-	p->vclass = CLPARAM;
-	impldcl((Namep)p);
-	if (e->headblock.vtype != TYCHAR)
-		e = putx(fixtype(e));
-	p->paramval = q = mkconv(p->vtype, e);
-	if (p->vtype == TYCHAR) {
-		if (q->tag == TEXPR)
-			p->paramval = q = fixexpr((Exprp)q);
-		if (q->tag == TADDR && q->addrblock.uname_tag == UNAM_CONST) {
-			qc = mkconst(TYCHAR);
-			qc->Const = q->addrblock.user.Const;
-			qc->vleng = q->addrblock.vleng;
-			q->addrblock.vleng = 0;
-			frexpr(q);
-			p->paramval = q = (expptr)qc;
-			}
-		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/contrib/tools/f2c/src/defines.h b/contrib/tools/f2c/src/defines.h
deleted file mode 100644
index 1ed4537eeca..00000000000
--- a/contrib/tools/f2c/src/defines.h
+++ /dev/null
@@ -1,300 +0,0 @@
-#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 */
-#define OPBITTEST 62		/* btest */
-#define OPBITCLR 63		/* ibclr */
-#define OPBITSET 64		/* ibset */
-#define OPQBITCLR 65		/* ibclr, integer*8 */
-#define OPQBITSET 66		/* ibset, integer*8 */
-#define OPBITBITS 67		/* ibits */
-#define OPBITSH 68		/* ishft */
-#define OPBITSHC 69		/* ishftc */
-
-/* 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) */
-#define INTRBGEN 8	/* bit manipulation */
-
-
-/* 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 */
-#define MAXNAMELEN 50		/* Maximum Fortran name length */
-
-/* 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)
diff --git a/contrib/tools/f2c/src/defs.h b/contrib/tools/f2c/src/defs.h
deleted file mode 100644
index 0f0a1c2d81b..00000000000
--- a/contrib/tools/f2c/src/defs.h
+++ /dev/null
@@ -1,1073 +0,0 @@
-/****************************************************************
-Copyright 1990 - 1996, 1999-2001 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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 MAXCTL 20
-#define MAXHASH 802
-#define MAXSTNO 801
-#define MAXEXT 400
-#define MAXEQUIV 300
-#define MAXLABLIST 258		/* Max number of labels in an alternate
-				   return CALL or computed GOTO */
-#define MAXCONTIN 99		/* Max continuation lines */
-#define MAX_SHARPLINE_LEN 1000	/* Elbow room for #line lines with long names */
-/* 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 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 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 maxtoklen, toklen;
-extern long err_lineno, 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 long 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 doinit;		/* for use with -onetrip */
-	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:4;
-	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 int opcode;
-	expptr leftp;
-	expptr rightp;
-	int typefixed;
-	};
-
-
-union Constant
-	{
-	struct {
-		char *ccp0;
-		ftnint blanks;
-		} ccp1;
-	ftnint ci;		/* Constant integer */
-#ifndef NO_LONG_LONG
-	Llong cq;		/* for TYQUAD integer */
-	ULlong ucq;
-#endif
-	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 eqvtop;
-	long eqvbottom;
-	int eqvtype;
-	} ;
-#define eqvleng eqvtop
-
-extern struct Equivblock *eqvclass;
-
-
-struct Eqvchain
-	{
-	struct Eqvchain *eqvnextp;
-	union
-		{
-		struct Primblock *eqvlhs;
-		Namep eqvname;
-		} eqvitem;
-	long 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 lituse;		/* usage count */
-	long litnum;			/* numeric part of the assembler
-					   label for this constant value */
-	union	{
-		ftnint litival;
-		double litdval[2];
-		ftnint litival2[2];	/* length, nblanks for strings */
-#ifndef NO_LONG_LONG
-		Llong litqval;
-#endif
-		} litval;
-	char *cds[2];
-	};
-
-extern struct Literal *litpool;
-extern int maxliterals, nliterals;
-extern unsigned char Letters[];
-#define letter(x) Letters[x]
-
-struct Dims { expptr lb, ub; };
-
-extern int forcedouble;		/* force real functions to double */
-extern int doin_setbound;	/* special handling for array bounds */
-extern int Ansi;
-extern unsigned 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 char binread[], binwrite[], textread[], textwrite[];
-extern char *ei_first, *ei_last, *ei_next;
-extern char *wh_first, *wh_last, *wh_next;
-extern char *halign, *outbuf, *outbtail;
-extern flag keepsubs;
-#ifdef TYQUAD
-extern flag use_tyquad;
-extern unsigned long ff;
-#ifndef NO_LONG_LONG
-extern flag allow_i8c;
-#endif
-#endif /*TYQUAD*/
-extern int n_keywords;
-extern char *c_keywords[];
-
-#ifdef KR_headers
-#define Argdcl(x) ()
-#define Void /* void */
-#else
-#define Argdcl(x) x
-#define Void void
-#endif
-
-char*	Alloc Argdcl((int));
-char*	Argtype Argdcl((int, char*));
-void	Fatal Argdcl((char*));
-struct	Impldoblock* mkiodo Argdcl((chainp, chainp));
-tagptr	Inline Argdcl((int, int, chainp));
-struct	Labelblock* execlab Argdcl((long));
-struct	Labelblock* mklabel Argdcl((long));
-struct	Listblock* mklist Argdcl((chainp));
-void	Un_link_all Argdcl((int));
-void	add_extern_to_list Argdcl((Addrp, chainp*));
-int	addressable Argdcl((tagptr));
-tagptr	addrof Argdcl((tagptr));
-char*	addunder Argdcl((char*));
-void	argkludge Argdcl((int*, char***));
-Addrp	autovar Argdcl((int, int, tagptr, char*));
-void	backup Argdcl((char*, char*));
-void	bad_atypes Argdcl((Argtypes*, char*, int, int, int, char*, char*));
-int	badchleng Argdcl((tagptr));
-void	badop Argdcl((char*, int));
-void	badstg Argdcl((char*, int));
-void	badtag Argdcl((char*, int));
-void	badthing Argdcl((char*, char*, int));
-void	badtype Argdcl((char*, int));
-Addrp	builtin Argdcl((int, char*, int));
-char*	c_name Argdcl((char*, int));
-tagptr	call0 Argdcl((int, char*));
-tagptr	call1 Argdcl((int, char*, tagptr));
-tagptr	call2 Argdcl((int, char*, tagptr, tagptr));
-tagptr	call3 Argdcl((int, char*, tagptr, tagptr, tagptr));
-tagptr	call4 Argdcl((int, char*, tagptr, tagptr, tagptr, tagptr));
-tagptr	callk Argdcl((int, char*, chainp));
-void	cast_args Argdcl((int, chainp));
-char*	cds Argdcl((char*, char*));
-void	changedtype Argdcl((Namep));
-ptr	ckalloc Argdcl((int));
-int	cktype Argdcl((int, int, int));
-void	clf Argdcl((FILEP*, char*, int));
-int	cmpstr Argdcl((char*, char*, long, long));
-char*	c_type_decl Argdcl((int, int));
-Extsym*	comblock Argdcl((char*));
-char*	comm_union_name Argdcl((int));
-void	consconv Argdcl((int, Constp, Constp));
-void	consnegop Argdcl((Constp));
-int	conssgn Argdcl((tagptr));
-char*	convic Argdcl((long));
-void	copy_data Argdcl((chainp));
-char*	copyn Argdcl((int, char*));
-char*	copys Argdcl((char*));
-tagptr	cpblock Argdcl((int, char*));
-tagptr	cpexpr Argdcl((tagptr));
-void	cpn Argdcl((int, char*, char*));
-char*	cpstring Argdcl((char*));
-void	dataline Argdcl((char*, long, int));
-char*	dataname Argdcl((int, long));
-void	dataval Argdcl((tagptr, tagptr));
-void	dclerr Argdcl((const char*, Namep));
-void	def_commons Argdcl((FILEP));
-void	def_start Argdcl((FILEP, char*, char*, char*));
-void	deregister Argdcl((Namep));
-void	do_uninit_equivs Argdcl((FILEP, ptr));
-void	doequiv(Void);
-int	dofork Argdcl((char*));
-void	doinclude Argdcl((char*));
-void	doio Argdcl((chainp));
-void	done Argdcl((int));
-void	donmlist(Void);
-int	dsort Argdcl((char*, char*));
-char*	dtos Argdcl((double));
-void	elif_out Argdcl((FILEP, tagptr));
-void	end_else_out Argdcl((FILEP));
-void	enddcl(Void);
-void	enddo Argdcl((int));
-void	endio(Void);
-void	endioctl(Void);
-void	endproc(Void);
-void	entrypt Argdcl((int, int, long, Extsym*, chainp));
-int	eqn Argdcl((int, char*, char*));
-char*	equiv_name Argdcl((int, char*));
-void	err Argdcl((char*));
-void	err66 Argdcl((char*));
-void	errext Argdcl((char*));
-void	erri Argdcl((char*, int));
-void	errl Argdcl((char*, long));
-tagptr	errnode(Void);
-void	errstr Argdcl((const char*, const char*));
-void	exarif Argdcl((tagptr, struct Labelblock*, struct Labelblock*, struct Labelblock*));
-void	exasgoto Argdcl((Namep));
-void	exassign Argdcl((Namep, struct Labelblock*));
-void	excall Argdcl((Namep, struct Listblock*, int, struct Labelblock**));
-void	exdo Argdcl((int, Namep, chainp));
-void	execerr Argdcl((char*, char*));
-void	exelif Argdcl((tagptr));
-void	exelse(Void);
-void	exenddo Argdcl((Namep));
-void	exendif(Void);
-void	exequals Argdcl((struct Primblock*, tagptr));
-void	exgoto Argdcl((struct Labelblock*));
-void	exif Argdcl((tagptr));
-void	exreturn Argdcl((tagptr));
-void	exstop Argdcl((int, tagptr));
-void	extern_out Argdcl((FILEP, Extsym*));
-void	fatali Argdcl((char*, int));
-void	fatalstr Argdcl((char*, char*));
-void	ffilecopy Argdcl((FILEP, FILEP));
-void	fileinit(Void);
-int	fixargs Argdcl((int, struct Listblock*));
-tagptr	fixexpr Argdcl((Exprp));
-tagptr	fixtype Argdcl((tagptr));
-char*	flconst Argdcl((char*, char*));
-void	flline(Void);
-void	fmt_init(Void);
-void	fmtname Argdcl((Namep, Addrp));
-int	fmtstmt Argdcl((struct Labelblock*));
-tagptr	fold Argdcl((tagptr));
-void	frchain Argdcl((chainp*));
-void	frdata Argdcl((chainp));
-void	freetemps(Void);
-void	freqchain Argdcl((struct Equivblock*));
-void	frexchain Argdcl((chainp*));
-void	frexpr Argdcl((tagptr));
-void	frrpl(Void);
-void	frtemp Argdcl((Addrp));
-char*	gmem Argdcl((int, int));
-void	hashclear(Void);
-chainp	hookup Argdcl((chainp, chainp));
-expptr	imagpart Argdcl((Addrp));
-void	impldcl Argdcl((Namep));
-int	in_vector Argdcl((char*, char**, int));
-void	incomm Argdcl((Extsym*, Namep));
-void	inferdcl Argdcl((Namep, int));
-int	inilex Argdcl((char*));
-void	initkey(Void);
-int	inregister Argdcl((Namep));
-long	int commlen Argdcl((chainp));
-long	int convci Argdcl((int, char*));
-long	int iarrlen Argdcl((Namep));
-long	int lencat Argdcl((expptr));
-long	int lmax Argdcl((long, long));
-long	int lmin Argdcl((long, long));
-long	int wr_char_len Argdcl((FILEP, struct Dimblock*, ftnint, int));
-Addrp	intraddr Argdcl((Namep));
-tagptr	intrcall Argdcl((Namep, struct Listblock*, int));
-int	intrfunct Argdcl((char*));
-void	ioclause Argdcl((int, expptr));
-int	iocname(Void);
-int	is_negatable Argdcl((Constp));
-int	isaddr Argdcl((tagptr));
-int	isnegative_const Argdcl((Constp));
-int	isstatic Argdcl((tagptr));
-chainp	length_comp Argdcl((struct Entrypoint*, int));
-int	lengtype Argdcl((int, long));
-char*	lexline Argdcl((ptr));
-void	list_arg_types Argdcl((FILEP, struct Entrypoint*, chainp, int, char*));
-void	list_decls Argdcl((FILEP));
-void	list_init_data Argdcl((FILE **, char *, FILE *));
-void	listargs Argdcl((FILEP, struct Entrypoint*, int, chainp));
-char*	lit_name Argdcl((struct Literal*));
-int	log_2 Argdcl((long));
-char*	lower_string Argdcl((char*, char*));
-int	main Argdcl((int, char**));
-expptr	make_int_expr Argdcl((expptr));
-void	make_param Argdcl((struct Paramblock*, tagptr));
-void	many Argdcl((char*, char, int));
-void	margin_printf Argdcl((FILEP, const char*, ...));
-int	maxtype Argdcl((int, int));
-char*	mem Argdcl((int, int));
-void	mem_init(Void);
-char*	memname Argdcl((int, long));
-Addrp	memversion Argdcl((Namep));
-tagptr	mkaddcon Argdcl((long));
-Addrp	mkaddr Argdcl((Namep));
-Addrp	mkarg Argdcl((int, int));
-tagptr	mkbitcon Argdcl((int, int, char*));
-chainp	mkchain Argdcl((char*, chainp));
-Constp	mkconst Argdcl((int));
-tagptr	mkconv Argdcl((int, tagptr));
-tagptr	mkcxcon Argdcl((tagptr, tagptr));
-tagptr	mkexpr Argdcl((int, tagptr, tagptr));
-Extsym*	mkext Argdcl((char*, char*));
-Extsym*	mkext1 Argdcl((char*, char*));
-Addrp	mkfield Argdcl((Addrp, char*, int));
-tagptr	mkfunct Argdcl((tagptr));
-tagptr	mkintcon Argdcl((long));
-tagptr	mkintqcon Argdcl((int, char*));
-tagptr	mklhs Argdcl((struct Primblock*, int));
-tagptr	mklogcon Argdcl((int));
-Namep	mkname Argdcl((char*));
-Addrp	mkplace Argdcl((Namep));
-tagptr	mkprim Argdcl((Namep, struct Listblock*, chainp));
-tagptr	mkrealcon Argdcl((int, char*));
-Addrp	mkscalar Argdcl((Namep));
-void	mkstfunct Argdcl((struct Primblock*, tagptr));
-tagptr	mkstrcon Argdcl((int, char*));
-Addrp	mktmp Argdcl((int, tagptr));
-Addrp	mktmp0 Argdcl((int, tagptr));
-Addrp	mktmpn Argdcl((int, int, tagptr));
-void	namelist Argdcl((Namep));
-int	ncat Argdcl((expptr));
-void	negate_const Argdcl((Constp));
-void	new_endif(Void);
-Extsym*	newentry Argdcl((Namep, int));
-long	newlabel(Void);
-void	newproc(Void);
-Addrp	nextdata Argdcl((long*));
-void	nice_printf Argdcl((FILEP, const char*, ...));
-void	not_both Argdcl((char*));
-void	np_init(Void);
-int	oneof_stg Argdcl((Namep, int, int));
-int	op_assign Argdcl((int));
-tagptr	opconv Argdcl((tagptr, int));
-FILEP	opf Argdcl((char*, char*));
-void	out_addr Argdcl((FILEP, Addrp));
-void	out_asgoto Argdcl((FILEP, tagptr));
-void	out_call Argdcl((FILEP, int, int, tagptr, tagptr, tagptr));
-void	out_const Argdcl((FILEP, Constp));
-void	out_else Argdcl((FILEP));
-void	out_for Argdcl((FILEP, tagptr, tagptr, tagptr));
-void	out_init(Void);
-void	outbuf_adjust(Void);
-void	p1_label Argdcl((long));
-void	paren_used Argdcl((struct Primblock*));
-void	prcona Argdcl((FILEP, long));
-void	prconi Argdcl((FILEP, long));
-#ifndef NO_LONG_LONG
-void	prconq Argdcl((FILEP, Llong));
-#endif
-void	prconr Argdcl((FILEP, Constp, int));
-void	procinit(Void);
-void	procode Argdcl((FILEP));
-void	prolog Argdcl((FILEP, chainp));
-void	protowrite Argdcl((FILEP, int, char*, struct Entrypoint*, chainp));
-expptr	prune_left_conv Argdcl((expptr));
-int	put_one_arg Argdcl((int, char*, char**, char*, char*));
-expptr	putassign Argdcl((expptr, expptr));
-Addrp	putchop Argdcl((tagptr));
-void	putcmgo Argdcl((tagptr, int, struct Labelblock**));
-Addrp	putconst Argdcl((Constp));
-tagptr	putcxop Argdcl((tagptr));
-void	puteq Argdcl((expptr, expptr));
-void	putexpr Argdcl((expptr));
-void	puthead Argdcl((char*, int));
-void	putif Argdcl((tagptr, int));
-void	putout Argdcl((tagptr));
-expptr	putsteq Argdcl((Addrp, Addrp));
-void	putwhile Argdcl((tagptr));
-tagptr	putx Argdcl((tagptr));
-void	r8fix(Void);
-int	rdlong Argdcl((FILEP, long*));
-int	rdname Argdcl((FILEP, ptr, char*));
-void	read_Pfiles Argdcl((char**));
-Addrp	realpart Argdcl((Addrp));
-chainp	revchain Argdcl((chainp));
-int	same_expr Argdcl((tagptr, tagptr));
-int	same_ident Argdcl((tagptr, tagptr));
-void	save_argtypes Argdcl((chainp, Argtypes**, Argtypes**, int, char*, int, int, int, int));
-void	saveargtypes Argdcl((Exprp));
-void	set_externs(Void);
-void	set_tmp_names(Void);
-void	setbound Argdcl((Namep, int, struct Dims*));
-void	setdata Argdcl((Addrp, Constp, long));
-void	setext Argdcl((Namep));
-void	setfmt Argdcl((struct Labelblock*));
-void	setimpl Argdcl((int, long, int, int));
-void	setintr Argdcl((Namep));
-void	settype Argdcl((Namep, int, long));
-void	sigcatch Argdcl((int));
-void	sserr Argdcl((Namep));
-void	start_formatting(Void);
-void	startioctl(Void);
-void	startproc Argdcl((Extsym*, int));
-void	startrw(Void);
-char*	string_num Argdcl((char*, long));
-int	struct_eq Argdcl((chainp, chainp));
-tagptr	subcheck Argdcl((Namep, tagptr));
-tagptr	suboffset Argdcl((struct Primblock*));
-int	type_fixup Argdcl((Argtypes*, Atype*, int));
-void	unamstring Argdcl((Addrp, char*));
-void	unclassifiable(Void);
-void	vardcl Argdcl((Namep));
-void	warn Argdcl((char*));
-void	warn1 Argdcl((const char*, const char*));
-void	warni Argdcl((char*, int));
-void	westart Argdcl((int));
-void	wr_abbrevs Argdcl((FILEP, int, chainp));
-char*	wr_ardecls Argdcl((FILE*, struct Dimblock*, long));
-void	wr_array_init Argdcl((FILEP, int, chainp));
-void	wr_common_decls Argdcl((FILEP));
-void	wr_equiv_init Argdcl((FILEP, int, chainp*, int));
-void	wr_globals Argdcl((FILEP));
-void	wr_nv_ident_help Argdcl((FILEP, Addrp));
-void	wr_struct Argdcl((FILEP, chainp));
-void	wronginf Argdcl((Namep));
-void	yyerror Argdcl((char*));
-int	yylex(Void);
-int	yyparse(Void);
-
-#ifdef USE_DTOA
-#define atof(x) strtod(x,0)
-void	g_fmt Argdcl((char*, double));
-#endif
diff --git a/contrib/tools/f2c/src/equiv.c b/contrib/tools/f2c/src/equiv.c
deleted file mode 100644
index bcf07e7211a..00000000000
--- a/contrib/tools/f2c/src/equiv.c
+++ /dev/null
@@ -1,412 +0,0 @@
-/****************************************************************
-Copyright 1990, 1993-6, 2000 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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 void eqvcommon Argdcl((struct Equivblock*, int, long int));
-static void eqveqv Argdcl((int, int, long int));
-static int nsubs Argdcl((struct Listblock*));
-
-/* ROUTINES RELATED TO EQUIVALENCE CLASS PROCESSING */
-
-/* called at end of declarations section to process chains
-   created by EQUIVALENCE statements
- */
- void
-doequiv(Void)
-{
-	register int i;
-	int inequiv;			/* True if one namep occurs in
-					   several EQUIV declarations */
-	int comno;		/* Index into Extsym table of the last
-				   COMMON block seen (implicitly assuming
-				   that only one will be given) */
-	int ovarno;
-	ftnint comoffset;	/* Index into the COMMON block */
-	ftnint offset;		/* Offset from array base */
-	ftnint leng;
-	register struct Equivblock *equivdecl;
-	register struct Eqvchain *q;
-	struct Primblock *primp;
-	register Namep np;
-	int k, k1, ns, pref, t;
-	chainp cp;
-	extern int type_pref[];
-
-	for(i = 0 ; i < nequiv ; ++i)
-	{
-
-/* Handle each equivalence declaration */
-
-		equivdecl = &eqvclass[i];
-		equivdecl->eqvbottom = equivdecl->eqvtop = 0;
-		comno = -1;
-
-
-
-		for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
-		{
-			offset = 0;
-			if (!(primp = q->eqvitem.eqvlhs))
-				continue;
-			vardcl(np = primp->namep);
-			if(primp->argsp || primp->fcharp)
-			{
-				expptr offp;
-
-/* Pad ones onto the end of an array declaration when needed */
-
-				if(np->vdim!=NULL && np->vdim->ndim>1 &&
-				    nsubs(primp->argsp)==1 )
-				{
-					if(! ftn66flag)
-						warni
-			("1-dim subscript in EQUIVALENCE, %d-dim declared",
-						    np -> vdim -> ndim);
-					cp = NULL;
-					ns = np->vdim->ndim;
-					while(--ns > 0)
-						cp = mkchain((char *)ICON(1), cp);
-					primp->argsp->listp->nextp = cp;
-				}
-
-				offp = suboffset(primp);
-				if(ISICON(offp))
-					offset = offp->constblock.Const.ci;
-				else	{
-					dclerr
-			("nonconstant subscript in equivalence ",
-					    np);
-					np = NULL;
-				}
-				frexpr(offp);
-			}
-
-/* Free up the primblock, since we now have a hash table (Namep) entry */
-
-			frexpr((expptr)primp);
-
-			if(np && (leng = iarrlen(np))<0)
-			{
-				dclerr("adjustable in equivalence", np);
-				np = NULL;
-			}
-
-			if(np) switch(np->vstg)
-			{
-			case STGUNKNOWN:
-			case STGBSS:
-			case STGEQUIV:
-				break;
-
-			case STGCOMMON:
-
-/* The code assumes that all COMMON references in a given EQUIVALENCE will
-   be to the same COMMON block, and will all be consistent */
-
-				comno = np->vardesc.varno;
-				comoffset = np->voffset + offset;
-				break;
-
-			default:
-				dclerr("bad storage class in equivalence", np);
-				np = NULL;
-				break;
-			}
-
-			if(np)
-			{
-				q->eqvoffset = offset;
-
-/* eqvbottom   gets the largest difference between the array base address
-   and the address specified in the EQUIV declaration */
-
-				equivdecl->eqvbottom =
-				    lmin(equivdecl->eqvbottom, -offset);
-
-/* eqvtop   gets the largest difference between the end of the array and
-   the address given in the EQUIVALENCE */
-
-				equivdecl->eqvtop =
-				    lmax(equivdecl->eqvtop, leng-offset);
-			}
-			q->eqvitem.eqvname = np;
-		}
-
-/* Now all equivalenced variables are in the hash table with the proper
-   offset, and   eqvtop and eqvbottom   are set. */
-
-		if(comno >= 0)
-
-/* Get rid of all STGEQUIVS, they will be mapped onto STGCOMMON variables
-   */
-
-			eqvcommon(equivdecl, comno, comoffset);
-		else for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
-		{
-			if(np = q->eqvitem.eqvname)
-			{
-				inequiv = NO;
-				if(np->vstg==STGEQUIV)
-					if( (ovarno = np->vardesc.varno) == i)
-					{
-
-/* Can't EQUIV different elements of the same array */
-
-						if(np->voffset + q->eqvoffset != 0)
-							dclerr
-			("inconsistent equivalence", np);
-					}
-					else	{
-						offset = np->voffset;
-						inequiv = YES;
-					}
-
-				np->vstg = STGEQUIV;
-				np->vardesc.varno = i;
-				np->voffset = - q->eqvoffset;
-
-				if(inequiv)
-
-/* Combine 2 equivalence declarations */
-
-					eqveqv(i, ovarno, q->eqvoffset + offset);
-			}
-		}
-	}
-
-/* Now each equivalence declaration is distinct (all connections have been
-   merged in eqveqv()), and some may be empty. */
-
-	for(i = 0 ; i < nequiv ; ++i)
-	{
-		equivdecl = & eqvclass[i];
-		if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) {
-
-/* a live chain */
-
-			k = TYCHAR;
-			pref = 1;
-			for(q = equivdecl->equivs ; q; q = q->eqvnextp)
-			    if ((np = q->eqvitem.eqvname)
-			    		&& !np->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 void
-#ifdef KR_headers
-eqvcommon(p, comno, comoffset)
-	struct Equivblock *p;
-	int comno;
-	ftnint comoffset;
-#else
-eqvcommon(struct Equivblock *p, int comno, ftnint comoffset)
-#endif
-{
-	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 void
-#ifdef KR_headers
-eqveqv(nvarno, ovarno, delta)
-	int nvarno;
-	int ovarno;
-	ftnint delta;
-#else
-eqveqv(int nvarno, int ovarno, ftnint delta)
-#endif
-{
-	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;
-}
-
-
-
- void
-#ifdef KR_headers
-freqchain(p)
-	register struct Equivblock *p;
-#else
-freqchain(register struct Equivblock *p)
-#endif
-{
-	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 int
-#ifdef KR_headers
-nsubs(p)
-	register struct Listblock *p;
-#else
-nsubs(register struct Listblock *p)
-#endif
-{
-	register int n;
-	register chainp q;
-
-	n = 0;
-	if(p)
-		for(q = p->listp ; q ; q = q->nextp)
-			++n;
-
-	return(n);
-}
-
- struct Primblock *
-#ifdef KR_headers
-primchk(e) expptr e;
-#else
-primchk(expptr e)
-#endif
-{
-	if (e->headblock.tag != TPRIM) {
-		err("Invalid name in EQUIVALENCE.");
-		return 0;
-		}
-	return &e->primblock;
-	}
diff --git a/contrib/tools/f2c/src/error.c b/contrib/tools/f2c/src/error.c
deleted file mode 100644
index d0064f03020..00000000000
--- a/contrib/tools/f2c/src/error.c
+++ /dev/null
@@ -1,347 +0,0 @@
-/****************************************************************
-Copyright 1990, 1993, 1994, 2000 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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"
-
- void
-#ifdef KR_headers
-warni(s, t)
-	char *s;
-	int t;
-#else
-warni(char *s, int t)
-#endif
-{
-	char buf[100];
-	sprintf(buf,s,t);
-	warn(buf);
-	}
-
- void
-#ifdef KR_headers
-warn1(s, t)
-	char *s;
-	char *t;
-#else
-warn1(const char *s, const char *t)
-#endif
-{
-	char buff[100];
-	sprintf(buff, s, t);
-	warn(buff);
-}
-
- void
-#ifdef KR_headers
-warn(s)
-	char *s;
-#else
-warn(char *s)
-#endif
-{
-	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;
-}
-
- void
-#ifdef KR_headers
-errstr(s, t)
-	char *s;
-	char *t;
-#else
-errstr(const char *s, const char *t)
-#endif
-{
-	char buff[100];
-	sprintf(buff, s, t);
-	err(buff);
-}
-
-
- void
-#ifdef KR_headers
-erri(s, t)
-	char *s;
-	int t;
-#else
-erri(char *s, int t)
-#endif
-{
-	char buff[100];
-	sprintf(buff, s, t);
-	err(buff);
-}
-
- void
-#ifdef KR_headers
-errl(s, t)
-	char *s;
-	long t;
-#else
-errl(char *s, long t)
-#endif
-{
-	char buff[100];
-	sprintf(buff, s, t);
-	err(buff);
-}
-
- char *err_proc = 0;
-
- void
-#ifdef KR_headers
-err(s)
-	char *s;
-#else
-err(char *s)
-#endif
-{
-	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;
-}
-
- void
-#ifdef KR_headers
-yyerror(s)
-	char *s;
-#else
-yyerror(char *s)
-#endif
-{
-	err(s);
-}
-
-
- void
-#ifdef KR_headers
-dclerr(s, v)
-	char *s;
-	Namep v;
-#else
-dclerr(const char *s, Namep v)
-#endif
-{
-	char buff[100];
-
-	if(v)
-	{
-		sprintf(buff, "Declaration error for %s: %s", v->fvarname, s);
-		err(buff);
-	}
-	else
-		errstr("Declaration error %s", s);
-}
-
-
- void
-#ifdef KR_headers
-execerr(s, n)
-	char *s;
-	char *n;
-#else
-execerr(char *s, char *n)
-#endif
-{
-	char buf1[100], buf2[100];
-
-	sprintf(buf1, "Execution error %s", s);
-	sprintf(buf2, buf1, n);
-	err(buf2);
-}
-
-
- void
-#ifdef KR_headers
-Fatal(t)
-	char *t;
-#else
-Fatal(char *t)
-#endif
-{
-	fprintf(diagfile, "Compiler error line %ld", lineno);
-	if (infname)
-		fprintf(diagfile, " of %s", infname);
-	fprintf(diagfile, ": %s\n", t);
-	done(3);
-}
-
-
-
- void
-#ifdef KR_headers
-fatalstr(t, s)
-	char *t;
-	char *s;
-#else
-fatalstr(char *t, char *s)
-#endif
-{
-	char buff[100];
-	sprintf(buff, t, s);
-	Fatal(buff);
-}
-
-
- void
-#ifdef KR_headers
-fatali(t, d)
-	char *t;
-	int d;
-#else
-fatali(char *t, int d)
-#endif
-{
-	char buff[100];
-	sprintf(buff, t, d);
-	Fatal(buff);
-}
-
-
- void
-#ifdef KR_headers
-badthing(thing, r, t)
-	char *thing;
-	char *r;
-	int t;
-#else
-badthing(char *thing, char *r, int t)
-#endif
-{
-	char buff[50];
-	sprintf(buff, "Impossible %s %d in routine %s", thing, t, r);
-	Fatal(buff);
-}
-
-
- void
-#ifdef KR_headers
-badop(r, t)
-	char *r;
-	int t;
-#else
-badop(char *r, int t)
-#endif
-{
-	badthing("opcode", r, t);
-}
-
-
- void
-#ifdef KR_headers
-badtag(r, t)
-	char *r;
-	int t;
-#else
-badtag(char *r, int t)
-#endif
-{
-	badthing("tag", r, t);
-}
-
-
-
-
- void
-#ifdef KR_headers
-badstg(r, t)
-	char *r;
-	int t;
-#else
-badstg(char *r, int t)
-#endif
-{
-	badthing("storage class", r, t);
-}
-
-
-
- void
-#ifdef KR_headers
-badtype(r, t)
-	char *r;
-	int t;
-#else
-badtype(char *r, int t)
-#endif
-{
-	badthing("type", r, t);
-}
-
- void
-#ifdef KR_headers
-many(s, c, n)
-	char *s;
-	char c;
-	int n;
-#else
-many(char *s, char c, int n)
-#endif
-{
-	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);
-}
-
- void
-#ifdef KR_headers
-err66(s)
-	char *s;
-#else
-err66(char *s)
-#endif
-{
-	errstr("Fortran 77 feature used: %s", s);
-	--nerr;
-}
-
-
- void
-#ifdef KR_headers
-errext(s)
-	char *s;
-#else
-errext(char *s)
-#endif
-{
-	errstr("f2c extension used: %s", s);
-	--nerr;
-}
diff --git a/contrib/tools/f2c/src/exec.c b/contrib/tools/f2c/src/exec.c
deleted file mode 100644
index 88932222fe9..00000000000
--- a/contrib/tools/f2c/src/exec.c
+++ /dev/null
@@ -1,984 +0,0 @@
-/****************************************************************
-Copyright 1990, 1993 - 1996, 2000 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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"
-
-static void exar2 Argdcl((int, tagptr, struct Labelblock*, struct Labelblock*));
-static void popctl Argdcl((void));
-static void pushctl Argdcl((int));
-
-/*   Logical IF codes
-*/
-
- void
-#ifdef KR_headers
-exif(p)
-	expptr p;
-#else
-exif(expptr p)
-#endif
-{
-    pushctl(CTLIF);
-    putif(p, 0);	/* 0 => if, not elseif */
-}
-
-
- void
-#ifdef KR_headers
-exelif(p)
-	expptr p;
-#else
-exelif(expptr p)
-#endif
-{
-    if (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLIFX)
-	putif(p, 1);	/* 1 ==> elseif */
-    else
-	execerr("elseif out of place", CNULL);
-}
-
-
-
-
- void
-exelse(Void)
-{
-	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);
-	}
-
- void
-#ifdef KR_headers
-exendif()
-#else
-exendif()
-#endif
-{
-	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);
-	}
-
-
- void
-#ifdef KR_headers
-new_endif()
-#else
-new_endif()
-#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
-#ifdef KR_headers
-pushctl(code)
-	int code;
-#else
-pushctl(int code)
-#endif
-{
-	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;
-	ctlstack->domax = ctlstack->dostep = 0;	/* in case of errors */
-	++blklevel;
-}
-
-
- LOCAL void
-popctl(Void)
-{
-	if( ctlstack-- < ctls )
-		Fatal("control stack empty");
-	--blklevel;
-}
-
-
-
-/* poplab -- update the flags in   labeltab   */
-
- LOCAL void
-poplab(Void)
-{
-	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
-*/
- void
-#ifdef KR_headers
-exgoto(lab)
-	struct Labelblock *lab;
-#else
-exgoto(struct Labelblock *lab)
-#endif
-{
-	lab->labused = 1;
-	p1_goto (lab -> stateno);
-}
-
-
- static expptr
-#ifdef KR_headers
-cktype1(p) expptr p;
-#else
-cktype1(expptr p)
-#endif
-{
-	/* Do things omitted because we might have been parsing a */
-	/* statement function...  Check types and fold constants. */
-
-	chainp c;
-	tagptr t;
-
-	if(p == 0)
-		return(0);
-
-	switch(p->tag) {
-	  case TCONST:
-	  case TADDR:
-	  case TERROR:
-		break;
-
-/* This case means that   fixexpr   can't call   fixtype   with any expr,
-   only a subexpr of its parameter. */
-
-	  case TEXPR:
-		t = mkexpr(p->exprblock.opcode, cktype1(p->exprblock.leftp),
-				cktype1(p->exprblock.rightp));
-		free((charptr)p);
-		p = (expptr) t;
-		break;
-
-	  case TLIST:
-		for(c = p->listblock.listp; c; c = c->nextp)
-			c->datap = (char*)cktype1((expptr)c->datap);
-		break;
-
-	  case TPRIM:
-		p->primblock.argsp = (struct Listblock*)
-			cktype1((expptr)p->primblock.argsp);
-		p->primblock.fcharp = cktype1(p->primblock.fcharp);
-		p->primblock.lcharp = cktype1(p->primblock.lcharp);
-		break;
-
-	  default:
-		badtag("cktype1", p->tag);
-	  }
-	return p;
-	}
-
-
- void
-#ifdef KR_headers
-exequals(lp, rp)
-	register struct Primblock *lp;
-	register expptr rp;
-#else
-exequals(register struct Primblock *lp, register expptr rp)
-#endif
-{
-	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)
-			errstr("statement function %.62s amid executables.",
-				lp->namep->fvarname);
-		mkstfunct(lp, rp);
-	}
-	else if (lp->vtype == TYSUBR)
-		err("illegal use of subroutine name");
-	else
-	{
-		expptr new_lp, new_rp;
-
-		if(parstate < INDATA) {
-			enddcl();
-			lp = (struct Primblock *)cktype1((expptr)lp);
-			rp = cktype1(rp);
-			}
-		new_lp = mklhs (lp, keepsubs);
-		new_rp = fixtype (rp);
-		puteq(new_lp, new_rp);
-	}
-}
-
-
-
-/* Make Statement Function */
-
-long laststfcn = -1, thisstno;
-int doing_stmtfcn;
-
- void
-#ifdef KR_headers
-mkstfunct(lp, rp)
-	struct Primblock *lp;
-	expptr rp;
-#else
-mkstfunct(struct Primblock *lp, expptr rp)
-#endif
-{
-	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");
-			args->datap = 0;
-			}
-		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
-#ifdef KR_headers
-mixed_type(np)
-	Namep np;
-#else
-mixed_type(Namep np)
-#endif
-{
-	char buf[128];
-	sprintf(buf, "%s function %.90s invoked as subroutine",
-		ftn_types[np->vtype], np->fvarname);
-	warn(buf);
-	}
-
- void
-#ifdef KR_headers
-excall(name, args, nstars, labels)
-	Namep name;
-	struct Listblock *args;
-	int nstars;
-	struct Labelblock **labels;
-#else
-excall(Namep name, struct Listblock *args, int nstars, struct Labelblock **labels)
-#endif
-{
-	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) );
-	if (p->tag == TERROR)
-		return;
-
-/* 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);
-}
-
-
- void
-#ifdef KR_headers
-exstop(stop, p)
-	int stop;
-	register expptr p;
-#else
-exstop(int stop, register expptr p)
-#endif
-{
-	char *str;
-	int n;
-
-	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, (char*)(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()   ) */
-
- void
-#ifdef KR_headers
-exdo(range, loopname, spec)
-	int range;
-	Namep loopname;
-	chainp spec;
-#else
-exdo(int range, Namep loopname, chainp spec)
-#endif
-			/* range = end label */
-			/* 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 */
-
-	ctlstack->doinit = 0;
-	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  {
-	    if (onetripflag)
-	   	ctlstack->doinit = doinit = (expptr) mktmp0(dotype, ENULL);
-	    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),
-			ctlstack->doinit ? cpexpr(doinit) : 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);
-}
-
- void
-#ifdef KR_headers
-exenddo(np)
-	Namep np;
-#else
-exenddo(Namep np)
-#endif
-{
-	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);
-	}
-
- void
-#ifdef KR_headers
-enddo(here)
-	int here;
-#else
-enddo(int here)
-#endif
-{
-	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;
-			/* ctlstack->dostep and ctlstack->domax can be zero */
-			/* with sufficiently bizarre (erroneous) syntax */
-			if (e = ctlstack->dostep)
-				if (e->tag == TADDR && e->addrblock.istemp)
-					frtemp((Addrp)e);
-				else
-					frexpr(e);
-			if (e = ctlstack->domax)
-				if (e->tag == TADDR && e->addrblock.istemp)
-					frtemp((Addrp)e);
-				else
-					frexpr(e);
-			if (e = ctlstack->doinit)
-				frtemp((Addrp)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;
-			}
-	}
-}
-
- void
-#ifdef KR_headers
-exassign(vname, labelval)
-	register Namep vname;
-	struct Labelblock *labelval;
-#else
-exassign(register Namep vname, struct Labelblock *labelval)
-#endif
-{
-	Addrp p;
-	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) {
-
-		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 */
-
-
- void
-#ifdef KR_headers
-exarif(expr, neglab, zerlab, poslab)
-	expptr expr;
-	struct Labelblock *neglab;
-	struct Labelblock *zerlab;
-	struct Labelblock *poslab;
-#else
-exarif(expptr expr, struct Labelblock *neglab, struct Labelblock *zerlab, struct Labelblock *poslab)
-#endif
-{
-    ftnint 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
-#ifdef KR_headers
-exar2(op, e, l1, l2)
-	int op;
-	expptr e;
-	struct Labelblock *l1;
-	struct Labelblock *l2;
-#else
-exar2(int op, expptr e, struct Labelblock *l1, struct Labelblock *l2)
-#endif
-{
-	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 */
-
- void
-#ifdef KR_headers
-exreturn(p)
-	register expptr p;
-#else
-exreturn(register expptr p)
-#endif
-{
-	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);
-}
-
-
- void
-#ifdef KR_headers
-exasgoto(labvar)
-	Namep labvar;
-#else
-exasgoto(Namep labvar)
-#endif
-{
-	register Addrp p;
-
-	p = mkplace(labvar);
-	if( ! ISINT(p->vtype) )
-		err("assigned goto variable must be integer");
-	else {
-		p1_asgoto (p);
-	} /* else */
-}
diff --git a/contrib/tools/f2c/src/expr.c b/contrib/tools/f2c/src/expr.c
deleted file mode 100644
index d9f86c0f17b..00000000000
--- a/contrib/tools/f2c/src/expr.c
+++ /dev/null
@@ -1,3738 +0,0 @@
-/****************************************************************
-Copyright 1990 - 1996, 2000-2001 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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"
-
-typedef struct { double dreal, dimag; } dcomplex;
-
-static void consbinop Argdcl((int, int, Constp, Constp, Constp));
-static void conspower Argdcl((Constp, Constp, long int));
-static void zdiv Argdcl((dcomplex*, dcomplex*, dcomplex*));
-static tagptr mkpower Argdcl((tagptr));
-static tagptr stfcall Argdcl((Namep, struct Listblock*));
-
-extern char dflttype[26];
-extern int htype;
-
-/* little routines to create constant blocks */
-
- Constp
-#ifdef KR_headers
-mkconst(t)
-	int t;
-#else
-mkconst(int t)
-#endif
-{
-	Constp p;
-
-	p = ALLOC(Constblock);
-	p->tag = TCONST;
-	p->vtype = t;
-	return(p);
-}
-
-
-/* mklogcon -- Make Logical Constant */
-
- expptr
-#ifdef KR_headers
-mklogcon(l)
-	int l;
-#else
-mklogcon(int l)
-#endif
-{
-	Constp  p;
-
-	p = mkconst(tylog);
-	p->Const.ci = l;
-	return( (expptr) p );
-}
-
-
-
-/* mkintcon -- Make Integer Constant */
-
- expptr
-#ifdef KR_headers
-mkintcon(l)
-	ftnint l;
-#else
-mkintcon(ftnint l)
-#endif
-{
-	Constp p;
-
-	p = mkconst(tyint);
-	p->Const.ci = l;
-	return( (expptr) p );
-}
-
-
-
-
-/* mkaddcon -- Make Address Constant, given integer value */
-
- expptr
-#ifdef KR_headers
-mkaddcon(l)
-	long l;
-#else
-mkaddcon(long l)
-#endif
-{
-	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
-#ifdef KR_headers
-mkrealcon(t, d)
-	int t;
-	char *d;
-#else
-mkrealcon(int t, char *d)
-#endif
-{
-	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. */
-
- expptr
-#ifdef KR_headers
-mkbitcon(shift, leng, s)
-	int shift;
-	int leng;
-	char *s;
-#else
-mkbitcon(int shift, int leng, char *s)
-#endif
-{
-	Constp p;
-	unsigned long m, ovfl, x, y, z;
-	int L32, len;
-	char buff[100], *s0 = s;
-#ifndef NO_LONG_LONG
-	ULlong u;
-#endif
-	static char *kind[3] = { "Binary", "Hex", "Octal" };
-
-	p = mkconst(TYLONG);
-	/* Song and dance to convert to TYQUAD only if ftnint is too small. */
-	m = x = y = ovfl = 0;
-	/* Older C compilers may not know about */
-	/* UL suffixes on hex constants... */
-	while(--leng >= 0)
-		if(*s != ' ') {
-			if (!m) {
-				z = x;
-				x = ((x << shift) | hextoi(*s++)) & ff;
-				if (!((x >> shift) - z))
-					continue;
-				m = (ff << (L32 = 32 - shift)) & ff;
-				--s;
-				x = z;
-				}
-			ovfl |= y & m;
-			y = y << shift | (x >> L32);
-			x = ((x << shift) | hextoi(*s++)) & ff;
-			}
-	/* Don't change the type to short for short constants, as
-	 * that is dangerous -- there is no syntax for long constants
-	 * with small values.
-	 */
-	p->Const.ci = (ftnint)x;
-#ifndef NO_LONG_LONG
-	if (m) {
-		if (allow_i8c) {
-			u = y;
-			p->Const.ucq = (u << 32) | x;
-			p->vtype = TYQUAD;
-			}
-		else
-			ovfl = 1;
-		}
-#else
-	ovfl |= m;
-#endif
-	if (ovfl) {
-		if (--shift == 3)
-			shift = 1;
-		if ((len = (int)leng) > 60)
-			sprintf(buff, "%s constant '%.60s' truncated.",
-				kind[shift], s0);
-		else
-			sprintf(buff, "%s constant '%.*s' truncated.",
-				kind[shift], len, s0);
-		err(buff);
-		}
-	return( (expptr) p );
-}
-
-
-
-
-
-/* mkstrcon -- Make string constant.  Allocates storage and initializes
-   the memory for a copy of the input Fortran-string. */
-
- expptr
-#ifdef KR_headers
-mkstrcon(l, v)
-	int l;
-	char *v;
-#else
-mkstrcon(int l, char *v)
-#endif
-{
-	Constp p;
-	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
-#ifdef KR_headers
-mkcxcon(realp, imagp)
-	expptr realp;
-	expptr imagp;
-#else
-mkcxcon(expptr realp, expptr imagp)
-#endif
-{
-	int rtype, itype;
-	Constp p;
-
-	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(Void)
-{
-	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
-#ifdef KR_headers
-mkconv(t, p)
-	int t;
-	expptr p;
-#else
-mkconv(int t, expptr p)
-#endif
-{
-	expptr q;
-	int pt, charwarn = 1;
-
-	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
-		|| p->tag == TADDR && p->addrblock.uname_tag == UNAM_CONST)
-	{
-#ifndef NO_LONG_LONG
-		if (t != TYQUAD && pt != TYQUAD)	/*20010820*/
-#endif
-		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 );
-		if (p->tag == TADDR)
-			q->constblock.vstg = p->addrblock.user.kludge.vstg1;
-		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
-#ifdef KR_headers
-opconv(p, t)
-	expptr p;
-	int t;
-#else
-opconv(expptr p, int t)
-#endif
-{
-	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
-#ifdef KR_headers
-addrof(p)
-	expptr p;
-#else
-addrof(expptr p)
-#endif
-{
-	return( mkexpr(OPADDR, p, ENULL) );
-}
-
-
-
-/* cpexpr - Returns a new copy of input expression   p   */
-
- tagptr
-#ifdef KR_headers
-cpexpr(p)
-	tagptr p;
-#else
-cpexpr(tagptr p)
-#endif
-{
-	tagptr e;
-	int tag;
-	chainp ep, pp;
-
-/* 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   */
-
- void
-#ifdef KR_headers
-frexpr(p)
-	tagptr p;
-#else
-frexpr(tagptr p)
-#endif
-{
-	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
-#ifdef KR_headers
-wronginf(np)
-	Namep np;
-#else
-wronginf(Namep np)
-#endif
-{
-	int c;
-	ftnint 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
-#ifdef KR_headers
-fixtype(p)
-	tagptr p;
-#else
-fixtype(tagptr p)
-#endif
-{
-
-	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:
-		if (((Exprp)p)->typefixed)
-			return (expptr)p;
-		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
-#ifdef KR_headers
-badchleng(p)
-	expptr p;
-#else
-badchleng(expptr p)
-#endif
-{
-	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
-#ifdef KR_headers
-cplenexpr(p)
-	expptr p;
-#else
-cplenexpr(expptr p)
-#endif
-{
-	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
-#ifdef KR_headers
-fixexpr(p)
-	Exprp p;
-#else
-fixexpr(Exprp p)
-#endif
-{
-	expptr lp, rp, q;
-	char *hsave;
-	int opcode, ltype, rtype, ptype, mtype;
-
-	if( ISERROR(p) || p->typefixed )
-		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");
- eret:
-		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)
-		goto eret;
-
-/* 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)
-		goto eret;
-
-	if (ltype == TYCHAR && ISCONST(lp)) {
-		if (opcode == OPCONV) {
-			hsave = halign;
-			halign = 0;
-			lp = (expptr)putconst((Constp)lp);
-			halign = hsave;
-			}
-		else
-			lp = (expptr)putconst((Constp)lp);
-		p->leftp = 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)
-		 || rtype == TYDREAL && ltype == TYREAL && !ISCONST(rp))
-			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 */
-
-			    (char*)(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:
-		rp = mkpower((expptr)p);
-		if (rp->tag == TEXPR)
-			rp->exprblock.typefixed = 1;
-		return rp;
-
-	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 || rtype==TYREAL))
-			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;
-	p->typefixed = 1;
-	return((expptr) p);
-}
-
-
-/* fix an argument list, taking due care for special first level cases */
-
- int
-#ifdef KR_headers
-fixargs(doput, p0)
-	int doput;
-	struct Listblock *p0;
-#else
-fixargs(int doput, struct Listblock *p0)
-#endif
-	/* doput is true if constants need to be passed by reference */
-{
-	chainp p;
-	tagptr q, t;
-	int qtag, nargs;
-
-	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;
-				continue;
-			}
-
-/* Take a function name and turn it into an Addr.  This only happens when
-   nothing else has figured out the function beforehand */
-
-			if (qtag == TPRIM && q->primblock.argsp == 0) {
-			    if (q->primblock.namep->vclass==CLPROC
-			     && q->primblock.namep->vprocclass != PTHISPROC) {
-				p->datap = (char *)mkaddr(q->primblock.namep);
-				continue;
-				}
-
-			    if (q->primblock.namep->vdim != NULL) {
-				p->datap = (char *)mkscalar(q->primblock.namep);
-				if ((q->primblock.fcharp||q->primblock.lcharp)
-				 && (q->primblock.namep->vtype != TYCHAR
-				  || q->primblock.namep->vdim))
-					sserr(q->primblock.namep);
-				continue;
-				}
-
-			    if (q->primblock.namep->vdovar
-			     && (t = (tagptr) memversion(q->primblock.namep))) {
-				p->datap = (char *)fixtype(t);
-				continue;
-				}
-			    }
-			p->datap = (char *)fixtype(q);
-		}
-	return(nargs);
-}
-
-
-
-/* mkscalar -- only called by   fixargs   above, and by some routines in
-   io.c */
-
- Addrp
-#ifdef KR_headers
-mkscalar(np)
-	Namep np;
-#else
-mkscalar(Namep np)
-#endif
-{
-	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)
-	{
-		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
-#ifdef KR_headers
-adjust_arginfo(np)
-	Namep np;
-#else
-adjust_arginfo(Namep np)
-#endif
-			/* adjust arginfo to omit the length arg for the
-			   arg that we now know to be a character-valued
-			   function */
-{
-	struct Entrypoint *ep;
-	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
-#ifdef KR_headers
-mkfunct(p0)
-	expptr p0;
-#else
-mkfunct(expptr p0)
-#endif
-{
-	struct Primblock *p = (struct Primblock *)p0;
-	struct Entrypoint *ep;
-	Addrp ap;
-	Extsym *extp;
-	Namep np;
-	expptr q;
-	extern chainp new_procs;
-	int k, nargs;
-	int vclass;
-
-	if(p->tag != TPRIM)
-		return( errnode() );
-
-	np = p->namep;
-	vclass = np->vclass;
-
-
-	if(vclass == CLUNKNOWN)
-	{
-		np->vclass = vclass = 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(vclass != CLPROC) {
-		if (np->vstg == STGCOMMON)
-			fatalstr(
-			 "Cannot invoke common variable %.50s as a function.",
-				np->fvarname);
-		errstr("%.80s cannot be called.", np->fvarname);
-		goto error;
-		}
-
-/* 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() );
-}
-
-
-
- static expptr
-#ifdef KR_headers
-stfcall(np, actlist)
-	Namep np;
-	struct Listblock *actlist;
-#else
-stfcall(Namep np, struct Listblock *actlist)
-#endif
-{
-	chainp actuals;
-	int nargs;
-	chainp oactp, formals;
-	int type;
-	expptr Ln, Lq, q, q1, rhs, ap;
-	Namep tnp;
-	struct Rplblock *rp;
-	struct Rplblock *tlist;
-
-	if (np->arginfo) {
-		errstr("statement function %.66s calls itself.",
-			np->fvarname);
-		return ICON(0);
-		}
-	np->arginfo = (Argtypes *)np;	/* arbitrary nonzero value */
-	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)
-	{
-		if (!(tnp = (Namep) formals->datap)) {
-			/* buggy statement function declaration */
-			q = ICON(1);
-			goto done;
-			}
-		rp = ALLOC(Rplblock);
-		rp->rplnp = tnp;
-		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;
-	}
- done:
-	frchain( &oactp );
-	np->arginfo = 0;
-	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
-#ifdef KR_headers
-mkplace(np)
-	Namep np;
-#else
-mkplace(Namep np)
-#endif
-{
-	Addrp s;
-	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
-#ifdef KR_headers
-subskept(p, a)
-	struct Primblock *p;
-	Addrp a;
-#else
-subskept(struct Primblock *p, Addrp a)
-#endif
-{
-	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 void
-#ifdef KR_headers
-substrerr(np) Namep np;
-#else
-substrerr(Namep np)
-#endif
-{
-	void (*f) Argdcl((const char*, const char*));
-	f = checksubs ? errstr : warn1;
-	(*f)("substring of %.65s is out of bounds.", np->fvarname);
-	}
-
- 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
-#ifdef KR_headers
-mklhs(p, subkeep)
-	struct Primblock *p;
-	int subkeep;
-#else
-mklhs(struct Primblock *p, int subkeep)
-#endif
-{
-	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 && p->argsp
-				&& (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)
-			sserr(np);
-		else	{
-			if(p->lcharp == NULL)
-				p->lcharp = (expptr)(
-					/* s->vleng == 0 only with errors */
-					s->vleng ? cpexpr(s->vleng) : ICON(1));
-			else if (ISCONST(p->lcharp)
-				 && ISCONST(np->vleng)
-				 && p->lcharp->constblock.Const.ci
-					> np->vleng->constblock.Const.ci)
-						substrerr(np);
-			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;
-				}
-			if (s->memoffset
-			 && ISCONST(s->memoffset)
-			 && s->memoffset->constblock.Const.ci < 0)
-				substrerr(np);
-		}
-	}
-
-	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) */
-
- void
-#ifdef KR_headers
-deregister(np)
-	Namep np;
-#else
-deregister(Namep np)
-#endif
-{
-	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
-#ifdef KR_headers
-memversion(np)
-	Namep np;
-#else
-memversion(Namep np)
-#endif
-{
-	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 */
-
- int
-#ifdef KR_headers
-inregister(np)
-	Namep np;
-#else
-inregister(Namep np)
-#endif
-{
-	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
-#ifdef KR_headers
-suboffset(p)
-	struct Primblock *p;
-#else
-suboffset(struct Primblock *p)
-#endif
-{
-	int n;
-	expptr si, size;
-	chainp cp;
-	expptr e, e1, offp, prod;
-	struct Dimblock *dimp;
-	expptr sub[MAXDIM+1];
-	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
-#ifdef KR_headers
-subcheck(np, p)
-	Namep np;
-	expptr p;
-#else
-subcheck(Namep np, expptr p)
-#endif
-{
-	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(TYLONG, 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
-#ifdef KR_headers
-mkaddr(p)
-	Namep p;
-#else
-mkaddr(Namep p)
-#endif
-{
-	Extsym *extp;
-	Addrp t;
-	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));
-
-	case STGSTFUNCT:
-
-		errstr("invalid use of statement function %.64s.", p->fvarname);
-		return putconst((Constp)ICON(0));
-	}
-	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
-#ifdef KR_headers
-mkarg(type, argno)
-	int type;
-	int argno;
-#else
-mkarg(int type, int argno)
-#endif
-{
-	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
-#ifdef KR_headers
-mkprim(v0, args, substr)
-	Namep v0;
-	struct Listblock *args;
-	chainp substr;
-#else
-mkprim(Namep v0, struct Listblock *args, chainp substr)
-#endif
-{
-	typedef union {
-		struct Paramblock paramblock;
-		struct Nameblock nameblock;
-		struct Headblock headblock;
-		} *Primu;
-	Primu v = (Primu)v0;
-	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 */
-
- void
-#ifdef KR_headers
-vardcl(v)
-	Namep v;
-#else
-vardcl(Namep v)
-#endif
-{
-	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 */
-
- void
-#ifdef KR_headers
-impldcl(p)
-	Namep p;
-#else
-impldcl(Namep p)
-#endif
-{
-	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
-#ifdef KR_headers
-inferdcl(np, type)
-	Namep np;
-	int type;
-#else
-inferdcl(Namep np, int type)
-#endif
-{
-	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;
-	}
-
- LOCAL int
-#ifdef KR_headers
-zeroconst(e)
-	expptr e;
-#else
-zeroconst(expptr e)
-#endif
-{
-	Constp c = (Constp) e;
-	if (c->tag == TCONST)
-		switch(c->vtype) {
-		case TYINT1:
-		case TYSHORT:
-		case TYLONG:
-#ifdef TYQUAD0
-		case TYQUAD:
-#endif
-			return c->Const.ci == 0;
-#ifndef NO_LONG_LONG
-		case TYQUAD:
-			return c->Const.cq == 0;
-#endif
-
-		case TYREAL:
-		case TYDREAL:
-			if (c->vstg == 1)
-				return !strcmp(c->Const.cds[0],"0.");
-			return c->Const.cd[0] == 0.;
-
-		case TYCOMPLEX:
-		case TYDCOMPLEX:
-			if (c->vstg == 1)
-				return !strcmp(c->Const.cds[0],"0.")
-				    && !strcmp(c->Const.cds[1],"0.");
-			return c->Const.cd[0] == 0. && c->Const.cd[1] == 0.;
-		}
-	return 0;
-	}
-
- void
-#ifdef KR_headers
-paren_used(p) struct Primblock *p;
-#else
-paren_used(struct Primblock *p)
-#endif
-{
-	Namep np;
-
-	p->parenused = 1;
-	if (!p->argsp && (np = p->namep) && np->vdim)
-		warn1("inappropriate operation on unsubscripted array %.50s",
-			np->fvarname);
-	}
-
-#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
-#ifdef KR_headers
-mkexpr(opcode, lp, rp)
-	int opcode;
-	expptr lp;
-	expptr rp;
-#else
-mkexpr(int opcode, expptr lp, expptr rp)
-#endif
-{
-	expptr e, e1;
-	int etype;
-	int ltype, rtype;
-	int ltag, rtag;
-	long L;
-	static long divlineno;
-
-	if (parstate < INEXEC) {
-
-		/* Song and dance to get statement functions right */
-		/* while catching incorrect type combinations in the */
-		/* first executable statement. */
-
-		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;
-		goto no_fold;
-		}
-
-	ltype = lp->headblock.vtype;
-	if (ltype == TYUNKNOWN) {
-		lp = fixtype(lp);
-		ltype = lp->headblock.vtype;
-		}
-	ltag = lp->tag;
-	if(rp && opcode!=OPCALL && opcode!=OPCCALL)
-	{
-		rtype = rp->headblock.vtype;
-		if (rtype == TYUNKNOWN) {
-			rp = fixtype(rp);
-			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( zeroconst(rp) && lineno != divlineno ) {
-			warn("attempted division by zero");
-			divlineno = lineno;
-			}
-		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 (!ISINT(etype) || 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 OPBITTEST:
-	case OPBITCLR:
-	case OPBITSET:
-#ifdef TYQUAD
-	case OPQBITCLR:
-	case OPQBITSET:
-#endif
-
-	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);
-	}
-
- no_fold:
-	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)
-		paren_used(&lp->primblock);
-	return(lp);
-
-retright:
-	frexpr(lp);
-	if (rp->tag == TPRIM)
-		paren_used(&rp->primblock);
-	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 */
-
- int
-#ifdef KR_headers
-cktype(op, lt, rt)
-	int op;
-	int lt;
-	int rt;
-#else
-cktype(int op, int lt, int rt)
-#endif
-{
-	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")
-	case OPBITTEST:
-		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)
-		||  ISINT(lt) && rt == TYCHAR)
-			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 (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 OPBITCLR:
-	case OPBITSET:
-#ifdef TYQUAD0
-	case OPQBITCLR:
-	case OPQBITSET:
-#endif
-		if (lt < TYLONG)
-			lt = TYLONG;
-		return(lt);
-#ifndef NO_LONG_LONG
-	case OPQBITCLR:
-	case OPQBITSET:
-		return TYQUAD;
-#endif
-
-	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);
-	default:
-		badop("cktype", op);
-	}
-error:
-	err(errs);
-error1:
-	return(TYERROR);
-}
-
- static void
-intovfl(Void)
-{ err("overflow simplifying integer constants."); }
-
-#ifndef NO_LONG_LONG
- static void
-#ifdef KR_headers
-LRget(Lp, Rp, lp, rp) Llong *Lp, *Rp; expptr lp, rp;
-#else
-LRget(Llong *Lp, Llong *Rp, expptr lp, expptr rp)
-#endif
-{
-	if (lp->headblock.vtype == TYQUAD)
-		*Lp = lp->constblock.Const.cq;
-	else
-		*Lp = lp->constblock.Const.ci;
-	if (rp->headblock.vtype == TYQUAD)
-		*Rp = rp->constblock.Const.cq;
-	else
-		*Rp = rp->constblock.Const.ci;
-	}
-#endif /*NO_LONG_LONG*/
-
-/* fold -- simplifies constant expressions; it assumes that e -> leftp and
-   e -> rightp are TCONST or NULL */
-
- expptr
-#ifdef KR_headers
-fold(e)
-	expptr e;
-#else
-fold(expptr e)
-#endif
-{
-	Constp p;
-	expptr lp, rp;
-	int etype, mtype, ltype, rtype, opcode;
-	ftnint i, bl, ll, lr;
-	char *q, *s;
-	struct Constblock lcon, rcon;
-	ftnint L;
-	double d;
-#ifndef NO_LONG_LONG
-	Llong LL, LR;
-#endif
-
-	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:
-#ifndef NO_LONG_LONG
-			if (ltype == TYQUAD)
-			 lp->constblock.Const.cq = ! lp->constblock.Const.cq;
-			else
-#endif
-			 lp->constblock.Const.ci = ! lp->constblock.Const.ci;
- retlp:
-			e->exprblock.leftp = 0;
-			frexpr(e);
-			return(lp);
-
-		case OPBITNOT:
-#ifndef NO_LONG_LONG
-			if (ltype == TYQUAD)
-			 lp->constblock.Const.cq = ~ lp->constblock.Const.cq;
-			else
-#endif
-			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:
-				if ((L = lp->constblock.Const.ci) < 0) {
-					lp->constblock.Const.ci = -L;
-					if (L != -lp->constblock.Const.ci)
-						intovfl();
-					}
-				goto retlp;
-#ifndef NO_LONG_LONG
-			    case TYQUAD:
-				if ((LL = lp->constblock.Const.cq) < 0) {
-					lp->constblock.Const.cq = -LL;
-					if (LL != -lp->constblock.Const.cq)
-						intovfl();
-					}
-				goto retlp;
-#endif
-			    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:
-		goto ereturn;
-
-	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:
-#ifndef NO_LONG_LONG
-		if (etype == TYQUAD) {
-			LRget(&LL, &LR, lp, rp);
-			p->Const.cq = LL & LR;
-			}
-		else
-#endif
-		p->Const.ci = lp->constblock.Const.ci &
-		    rp->constblock.Const.ci;
-		break;
-
-	case OPBITOR:
-#ifndef NO_LONG_LONG
-		if (etype == TYQUAD) {
-			LRget(&LL, &LR, lp, rp);
-			p->Const.cq = LL | LR;
-			}
-		else
-#endif
-		p->Const.ci = lp->constblock.Const.ci |
-		    rp->constblock.Const.ci;
-		break;
-
-	case OPBITXOR:
-#ifndef NO_LONG_LONG
-		if (etype == TYQUAD) {
-			LRget(&LL, &LR, lp, rp);
-			p->Const.cq = LL ^ LR;
-			}
-		else
-#endif
-		p->Const.ci = lp->constblock.Const.ci ^
-		    rp->constblock.Const.ci;
-		break;
-
-	case OPLSHIFT:
-#ifndef NO_LONG_LONG
-		if (etype == TYQUAD) {
-			LRget(&LL, &LR, lp, rp);
-			p->Const.cq = LL << (int)LR;
-			if (p->Const.cq >> (int)LR != LL)
-				intovfl();
-			break;
-			}
-#endif
-		p->Const.ci = lp->constblock.Const.ci <<
-		    rp->constblock.Const.ci;
-		if ((((unsigned long)p->Const.ci) >> rp->constblock.Const.ci)
-				!= lp->constblock.Const.ci)
-			intovfl();
-		break;
-
-	case OPRSHIFT:
-#ifndef NO_LONG_LONG
-		if (etype == TYQUAD) {
-			LRget(&LL, &LR, lp, rp);
-			p->Const.cq = LL >> (int)LR;
-			}
-		else
-#endif
-		p->Const.ci = (unsigned long)lp->constblock.Const.ci >>
-		    rp->constblock.Const.ci;
-		break;
-
-	case OPBITTEST:
-#ifndef NO_LONG_LONG
-		if (ltype == TYQUAD)
-			p->Const.ci = (lp->constblock.Const.cq &
-				1LL << rp->constblock.Const.ci) != 0;
-		else
-#endif
-		p->Const.ci = (lp->constblock.Const.ci &
-				1L << rp->constblock.Const.ci) != 0;
-		break;
-
-	case OPBITCLR:
-#ifndef NO_LONG_LONG
-		if (etype == TYQUAD) {
-			LRget(&LL, &LR, lp, rp);
-			p->Const.cq = LL & ~(1LL << (int)LR);
-			}
-		else
-#endif
-		p->Const.ci = lp->constblock.Const.ci &
-				~(1L << rp->constblock.Const.ci);
-		break;
-
-	case OPBITSET:
-#ifndef NO_LONG_LONG
-		if (etype == TYQUAD) {
-			LRget(&LL, &LR, lp, rp);
-			p->Const.cq = LL | (1LL << (int)LR);
-			}
-		else
-#endif
-		p->Const.ci = lp->constblock.Const.ci |
-				1L << 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)
-		 || rp->constblock.Const.ci < 0 && zeroconst(lp))
-			goto ereturn;
-		conspower(p, (Constp)lp, rp->constblock.Const.ci);
-		break;
-
-	case OPSLASH:
-		if (zeroconst(rp))
-			goto ereturn;
-		/* no 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 );
- ereturn:
-	free((char *)p);
-	return e;
-}
-
-
-
-/* assign constant l = r , doing coercion */
-
- void
-#ifdef KR_headers
-consconv(lt, lc, rc)
-	int lt;
-	Constp lc;
-	Constp rc;
-#else
-consconv(int lt, Constp lc, Constp rc)
-#endif
-{
-	int rt = rc->vtype;
-	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)) = (char)rv->ci;
-		lv->ccp1.blanks = 0;
-		break;
-
-	case TYINT1:
-	case TYSHORT:
-	case TYLONG:
-#ifdef TYQUAD0
-	case TYQUAD:
-#endif
-		if(rt == TYCHAR)
-			lv->ci = rv->ccp[0];
-		else if( ISINT(rt) ) {
-#ifndef NO_LONG_LONG
-			if (rt == TYQUAD)
-				lv->ci = rv->cq;
-			else
-#endif
-			lv->ci = rv->ci;
-			}
-		else	lv->ci = (ftnint)(rc->vstg
-					? atof(rv->cds[0]) : rv->cd[0]);
-
-		break;
-#ifndef NO_LONG_LONG
-	case TYQUAD:
-		if(rt == TYCHAR)
-			lv->cq = rv->ccp[0];
-		else if( ISINT(rt) ) {
-			if (rt == TYQUAD)
-				lv->cq = rv->cq;
-			else
-				lv->cq = rv->ci;
-			}
-		else	lv->cq = (ftnint)(rc->vstg
-					? atof(rv->cds[0]) : rv->cd[0]);
-
-		break;
-#endif
-
-	case TYCOMPLEX:
-	case TYDCOMPLEX:
-		lv->cd[1] = 0.;
-
-	case TYREAL:
-	case TYDREAL:
-#ifndef NO_LONG_LONG
-		if (rt == TYQUAD)
-			lv->cd[0] = rv->cq;
-		else
-#endif
-		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 */
-
- void
-#ifdef KR_headers
-consnegop(p)
-	Constp p;
-#else
-consnegop(Constp p)
-#endif
-{
-	char *s;
-	ftnint L;
-#ifndef NO_LONG_LONG
-	Llong LL;
-#endif
-
-	if (p->vstg) {
-		/* 20010820: comment out "*s == '0' ? s :" to preserve */
-		/* the sign of zero */
-		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 TYQUAD0
-	case TYQUAD:
-#endif
-		p->Const.ci = -(L = p->Const.ci);
-		if (L != -p->Const.ci)
-			intovfl();
-		break;
-#ifndef NO_LONG_LONG
-	case TYQUAD:
-		p->Const.cq = -(LL = p->Const.cq);
-		if (LL != -p->Const.cq)
-			intovfl();
-		break;
-#endif
-	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
-#ifdef KR_headers
-conspower(p, ap, n)
-	Constp p;
-	Constp ap;
-	ftnint n;
-#else
-conspower(Constp p, Constp ap, ftnint n)
-#endif
-{
-	union Constant *powp = &p->Const;
-	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 TYQUAD0
-	case TYQUAD:
-#endif
-		powp->ci = 1;
-		break;
-#ifndef NO_LONG_LONG
-	case TYQUAD:
-		powp->cq = 1;
-		break;
-#endif
-	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 TYQUAD0
-	case TYQUAD:
-#endif
-		x0.Const.ci = ap->Const.ci;
-		break;
-#ifndef NO_LONG_LONG
-	case TYQUAD:
-		x0.Const.cq = ap->Const.cq;
-		break;
-#endif
-	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)
-	{
-		n = -n;
-		if( ISINT(type) )
-		{
-			switch(ap->Const.ci) {
-				case 0:
-					err("0 ** negative number");
-					return;
-				case 1:
-				case -1:
-					goto mult;
-				}
-			err("integer ** negative number");
-			return;
-		}
-		else if (!x0.Const.cd[0]
-				&& (!ISCOMPLEX(type) || !x0.Const.cd[1])) {
-			err("0.0 ** negative number");
-			return;
-			}
-		consbinop(OPSLASH, type, &x, p, &x0);
-	}
-	else
- mult:		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
-#ifdef KR_headers
-consbinop(opcode, type, cpp, app, bpp)
-	int opcode;
-	int type;
-	Constp cpp;
-	Constp app;
-	Constp bpp;
-#else
-consbinop(int opcode, int type, Constp cpp, Constp app, Constp bpp)
-#endif
-{
-	union Constant *ap = &app->Const,
-				*bp = &bpp->Const,
-				*cp = &cpp->Const;
-	ftnint k;
-	double ad[2], bd[2], temp;
-	ftnint a, b;
-#ifndef NO_LONG_LONG
-	Llong aL, bL;
-#endif
-
-	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 TYQUAD0
-		case TYQUAD:
-#endif
-			cp->ci = ap->ci + bp->ci;
-			if (ap->ci != cp->ci - bp->ci)
-				intovfl();
-			break;
-#ifndef NO_LONG_LONG
-		case TYQUAD:
-			cp->cq = ap->cq + bp->cq;
-			if (ap->cq != cp->cq - bp->cq)
-				intovfl();
-			break;
-#endif
-		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 TYQUAD0
-		case TYQUAD:
-#endif
-			cp->ci = ap->ci - bp->ci;
-			if (ap->ci != bp->ci + cp->ci)
-				intovfl();
-			break;
-#ifndef NO_LONG_LONG
-		case TYQUAD:
-			cp->cq = ap->cq - bp->cq;
-			if (ap->cq != bp->cq + cp->cq)
-				intovfl();
-			break;
-#endif
-		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 TYQUAD0
-		case TYQUAD:
-#endif
-			cp->ci = (a = ap->ci) * (b = bp->ci);
-			if (a && cp->ci / a != b)
-				intovfl();
-			break;
-#ifndef NO_LONG_LONG
-		case TYQUAD:
-			cp->cq = (aL = ap->cq) * (bL = bp->cq);
-			if (aL && cp->cq / aL != bL)
-				intovfl();
-			break;
-#endif
-		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 TYQUAD0
-		case TYQUAD:
-#endif
-			cp->ci = ap->ci / bp->ci;
-			break;
-#ifndef NO_LONG_LONG
-		case TYQUAD:
-			cp->cq = ap->cq / bp->cq;
-			break;
-#endif
-		case TYREAL:
-		case TYDREAL:
-			cp->cd[0] = ad[0] / bd[0];
-			break;
-		case TYCOMPLEX:
-		case TYDCOMPLEX:
-			zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd);
-			break;
-		}
-		break;
-
-	case OPMOD:
-		if( ISINT(type) )
-		{
-#ifndef NO_LONG_LONG
-			if (type == TYQUAD)
-				cp->cq = ap->cq % bp->cq;
-			else
-#endif
-				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 TYQUAD0
-		case TYQUAD:
-#endif
-			cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci;
-			break;
-#ifndef NO_LONG_LONG
-		case TYQUAD:
-			cp->cq = ap->cq <= bp->cq ? ap->cq : bp->cq;
-			break;
-#endif
-		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 TYQUAD0
-		case TYQUAD:
-#endif
-			cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci;
-			break;
-#ifndef NO_LONG_LONG
-		case TYQUAD:
-			cp->cq = ap->cq >= bp->cq ? ap->cq : bp->cq;
-			break;
-#endif
-		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 TYQUAD0
-		case TYQUAD:
-#endif
-			if(ap->ci < bp->ci)
-				k = -1;
-			else if(ap->ci == bp->ci)
-				k = 0;
-			else	k = 1;
-			break;
-#ifndef NO_LONG_LONG
-		case TYQUAD:
-			if(ap->cq < bp->cq)
-				k = -1;
-			else if(ap->cq == bp->cq)
-				k = 0;
-			else	k = 1;
-			break;
-#endif
-		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;
-		case TYLOGICAL:
-			k = ap->ci - bp->ci;
-		}
-
-		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 */
-
- int
-#ifdef KR_headers
-conssgn(p)
-	expptr p;
-#else
-conssgn(expptr p)
-#endif
-{
-	char *s;
-
-	if( ! ISCONST(p) )
-		Fatal( "sgn(nonconstant)" );
-
-	switch(p->headblock.vtype)
-	{
-	case TYINT1:
-	case TYSHORT:
-	case TYLONG:
-#ifdef TYQUAD0
-	case TYQUAD:
-#endif
-		if(p->constblock.Const.ci > 0) return(1);
-		if(p->constblock.Const.ci < 0) return(-1);
-		return(0);
-#ifndef NO_LONG_LONG
-	case TYQUAD:
-		if(p->constblock.Const.cq > 0) return(1);
-		if(p->constblock.Const.cq < 0) return(-1);
-		return(0);
-#endif
-
-	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_qq",
-#endif
-		  "pow_ri", "pow_di", "pow_ci", "pow_zi" };
-
- LOCAL expptr
-#ifdef KR_headers
-mkpower(p)
-	expptr p;
-#else
-mkpower(expptr p)
-#endif
-{
-	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
-#ifdef KR_headers
-zdiv(c, a, b)
-	dcomplex *c;
-	dcomplex *a;
-	dcomplex *b;
-#else
-zdiv(dcomplex *c, dcomplex *a, dcomplex *b)
-#endif
-{
-	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;
-	}
-}
-
-
- void
-#ifdef KR_headers
-sserr(np) Namep np;
-#else
-sserr(Namep np)
-#endif
-{
-	errstr(np->vtype == TYCHAR
-		? "substring of character array %.70s"
-		: "substring of noncharacter %.73s", np->fvarname);
-	}
diff --git a/contrib/tools/f2c/src/format.c b/contrib/tools/f2c/src/format.c
deleted file mode 100644
index 96f2acf995c..00000000000
--- a/contrib/tools/f2c/src/format.c
+++ /dev/null
@@ -1,2613 +0,0 @@
-/****************************************************************
-Copyright 1990-1996, 1999-2001 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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 tagptr do_format Argdcl((FILEP, FILEP));
-static void do_p1_1while Argdcl((FILEP));
-static void do_p1_2while Argdcl((FILEP, FILEP));
-static tagptr do_p1_addr Argdcl((FILEP, FILEP));
-static void do_p1_asgoto Argdcl((FILEP, FILEP));
-static tagptr do_p1_charp Argdcl((FILEP));
-static void do_p1_comment Argdcl((FILEP, FILEP));
-static void do_p1_comp_goto Argdcl((FILEP, FILEP));
-static tagptr do_p1_const Argdcl((FILEP));
-static void do_p1_elif Argdcl((FILEP, FILEP));
-static void do_p1_else Argdcl((FILEP));
-static void do_p1_elseifstart Argdcl((FILEP));
-static void do_p1_end_for Argdcl((FILEP));
-static void do_p1_endelse Argdcl((FILEP));
-static void do_p1_endif Argdcl((FILEP));
-static tagptr do_p1_expr Argdcl((FILEP, FILEP));
-static tagptr do_p1_extern Argdcl((FILEP));
-static void do_p1_for Argdcl((FILEP, FILEP));
-static void do_p1_fortran Argdcl((FILEP, FILEP));
-static void do_p1_goto Argdcl((FILEP, FILEP));
-static tagptr do_p1_head Argdcl((FILEP, FILEP));
-static tagptr do_p1_ident Argdcl((FILEP));
-static void do_p1_if Argdcl((FILEP, FILEP));
-static void do_p1_label Argdcl((FILEP, FILEP));
-static tagptr do_p1_list Argdcl((FILEP, FILEP));
-static tagptr do_p1_literal Argdcl((FILEP));
-static tagptr do_p1_name_pointer Argdcl((FILEP));
-static void do_p1_set_line Argdcl((FILEP));
-static void do_p1_subr_ret Argdcl((FILEP, FILEP));
-static int get_p1_token Argdcl((FILEP));
-static int p1get_const Argdcl((FILEP, int, Constp*));
-static int p1getd Argdcl((FILEP, long int*));
-static int p1getf Argdcl((FILEP, char**));
-static int p1getn Argdcl((FILEP, int, char**));
-static int p1gets Argdcl((FILEP, char*, int));
-static void proto Argdcl((FILEP, Argtypes*, char*));
-
-extern chainp assigned_fmts;
-char filename[P1_FILENAME_MAX];
-extern int gflag, sharp_line, trapuv;
-extern int typeconv[];
-int gflag1;
-extern char *parens;
-
- void
-start_formatting(Void)
-{
-    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 = sharp_line = 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
-#ifdef KR_headers
-put_semi(outfile)
-	FILE *outfile;
-#else
-put_semi(FILE *outfile)
-#endif
-{
-	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
-#ifdef KR_headers
-do_format(infile, outfile)
-	FILE *infile;
-	FILE *outfile;
-#else
-do_format(FILE *infile, FILE *outfile)
-#endif
-{
-    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 = sharp_line = 0;
-	    retval = do_p1_head (infile, outfile);
-	    gflag1 = sharp_line = 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
-#ifdef KR_headers
-do_p1_comment(infile, outfile)
-	FILE *infile;
-	FILE *outfile;
-#else
-do_p1_comment(FILE *infile, FILE *outfile)
-#endif
-{
-    extern int in_comment;
-
-    char storage[COMMENT_BUFFER_SIZE + 1];
-    int length;
-
-    if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1))
-	return;
-
-    length = strlen (storage);
-
-    gflag1 = sharp_line = 0;
-    in_comment = 1;
-    margin_printf(outfile, length ? "/* %s */\n" : "\n", storage);
-    in_comment = 0;
-    gflag1 = sharp_line = gflag;
-} /* do_p1_comment */
-
- static void
-#ifdef KR_headers
-do_p1_set_line(infile)
-	FILE *infile;
-#else
-do_p1_set_line(FILE *infile)
-#endif
-{
-    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
-#ifdef KR_headers
-do_p1_name_pointer(infile)
-	FILE *infile;
-#else
-do_p1_name_pointer(FILE *infile)
-#endif
-{
-    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: '#%lx'\n",
-		(unsigned long) namep);
-
-    return (expptr) namep;
-} /* do_p1_name_pointer */
-
-
-
- static expptr
-#ifdef KR_headers
-do_p1_const(infile)
-	FILE *infile;
-#else
-do_p1_const(FILE *infile)
-#endif
-{
-    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 */
-
- void
-#ifdef KR_headers
-addrlit(addrp)
-	Addrp addrp;
-#else
-addrlit(Addrp addrp)
-#endif
-{
-	long memno = addrp->memno;
-	struct Literal *litp, *lastlit;
-
-	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));
-		addrp->vstg = STGMEMNO;
-		return;
-		}
-	err("addrlit failure!");
-	}
-
- static expptr
-#ifdef KR_headers
-do_p1_literal(infile)
-	FILE *infile;
-#else
-do_p1_literal(FILE *infile)
-#endif
-{
-    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 {
-	addrp = ALLOC (Addrblock);
-	addrp -> tag = TADDR;
-	addrp -> vtype = TYUNKNOWN;
-	addrp -> Field = NULL;
-	addrp -> memno = memno;
-	addrlit(addrp);
-	addrp -> uname_tag = UNAM_CONST;
-    } /* else */
-
-    return (expptr) addrp;
-} /* do_p1_literal */
-
-
- static void
-#ifdef KR_headers
-do_p1_label(infile, outfile)
-	FILE *infile;
-	FILE *outfile;
-#else
-do_p1_label(FILE *infile, FILE *outfile)
-#endif
-{
-    int status;
-    ftnint stateno;
-    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
-#ifdef KR_headers
-do_p1_asgoto(infile, outfile)
-	FILE *infile;
-	FILE *outfile;
-#else
-do_p1_asgoto(FILE *infile, FILE *outfile)
-#endif
-{
-    expptr expr;
-
-    expr = do_format (infile, outfile);
-    out_asgoto (outfile, expr);
-
-} /* do_p1_asgoto */
-
-
- static void
-#ifdef KR_headers
-do_p1_goto(infile, outfile)
-	FILE *infile;
-	FILE *outfile;
-#else
-do_p1_goto(FILE *infile, FILE *outfile)
-#endif
-{
-    int status;
-    long stateno;
-
-    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
-#ifdef KR_headers
-do_p1_if(infile, outfile)
-	FILE *infile;
-	FILE *outfile;
-#else
-do_p1_if(FILE *infile, FILE *outfile)
-#endif
-{
-    expptr cond;
-
-    do {
-        cond = do_format (infile, outfile);
-    } while (cond == ENULL);
-
-    out_if (outfile, cond);
-} /* do_p1_if */
-
-
- static void
-#ifdef KR_headers
-do_p1_else(outfile)
-	FILE *outfile;
-#else
-do_p1_else(FILE *outfile)
-#endif
-{
-    out_else (outfile);
-} /* do_p1_else */
-
-
- static void
-#ifdef KR_headers
-do_p1_elif(infile, outfile)
-	FILE *infile;
-	FILE *outfile;
-#else
-do_p1_elif(FILE *infile, FILE *outfile)
-#endif
-{
-    expptr cond;
-
-    do {
-        cond = do_format (infile, outfile);
-    } while (cond == ENULL);
-
-    elif_out (outfile, cond);
-} /* do_p1_elif */
-
- static void
-#ifdef KR_headers
-do_p1_endif(outfile)
-	FILE *outfile;
-#else
-do_p1_endif(FILE *outfile)
-#endif
-{
-    endif_out (outfile);
-} /* do_p1_endif */
-
-
- static void
-#ifdef KR_headers
-do_p1_endelse(outfile)
-	FILE *outfile;
-#else
-do_p1_endelse(FILE *outfile)
-#endif
-{
-    end_else_out (outfile);
-} /* do_p1_endelse */
-
-
- static expptr
-#ifdef KR_headers
-do_p1_addr(infile, outfile)
-	FILE *infile;
-	FILE *outfile;
-#else
-do_p1_addr(FILE *infile, FILE *outfile)
-#endif
-{
-    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
-#ifdef KR_headers
-do_p1_subr_ret(infile, outfile)
-	FILE *infile;
-	FILE *outfile;
-#else
-do_p1_subr_ret(FILE *infile, FILE *outfile)
-#endif
-{
-    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
-#ifdef KR_headers
-do_p1_comp_goto(infile, outfile)
-	FILE *infile;
-	FILE *outfile;
-#else
-do_p1_comp_goto(FILE *infile, FILE *outfile)
-#endif
-{
-    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
-#ifdef KR_headers
-do_p1_for(infile, outfile)
-	FILE *infile;
-	FILE *outfile;
-#else
-do_p1_for(FILE *infile, FILE *outfile)
-#endif
-{
-    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
-#ifdef KR_headers
-do_p1_end_for(outfile)
-	FILE *outfile;
-#else
-do_p1_end_for(FILE *outfile)
-#endif
-{
-    out_end_for (outfile);
-} /* do_p1_end_for */
-
-
- static void
-#ifdef KR_headers
-do_p1_fortran(infile, outfile)
-	FILE *infile;
-	FILE *outfile;
-#else
-do_p1_fortran(FILE *infile, FILE *outfile)
-#endif
-{
-	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
-#ifdef KR_headers
-do_p1_expr(infile, outfile)
-	FILE *infile;
-	FILE *outfile;
-#else
-do_p1_expr(FILE *infile, FILE *outfile)
-#endif
-{
-    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 = (field)type;
-	    result -> opcode = (unsigned int)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
-#ifdef KR_headers
-do_p1_ident(infile)
-	FILE *infile;
-#else
-do_p1_ident(FILE *infile)
-#endif
-{
-	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 = (field)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 = (field)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
-#ifdef KR_headers
-do_p1_charp(infile)
-	FILE *infile;
-#else
-do_p1_charp(FILE *infile)
-#endif
-{
-	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 = (field)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 = (field)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
-#ifdef KR_headers
-do_p1_extern(infile)
-	FILE *infile;
-#else
-do_p1_extern(FILE *infile)
-#endif
-{
-    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
-#ifdef KR_headers
-do_p1_head(infile, outfile)
-	FILE *infile;
-	FILE *outfile;
-#else
-do_p1_head(FILE *infile, FILE *outfile)
-#endif
-{
-    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 */ int ");
-	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
-#ifdef KR_headers
-do_p1_list(infile, outfile)
-	FILE *infile;
-	FILE *outfile;
-#else
-do_p1_list(FILE *infile, FILE *outfile)
-#endif
-{
-    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 = (field)tag;
-	result -> listblock.vtype = (field)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
-#ifdef KR_headers
-length_comp(e, add_n)
-	struct Entrypoint *e;
-	int add_n;
-#else
-length_comp(struct Entrypoint *e, int add_n)
-#endif
-		/* get lengths of characters args */
-{
-	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
-#ifdef KR_headers
-listargs(outfile, entryp, add_n_, lengths)
-	FILE *outfile;
-	struct Entrypoint *entryp;
-	int add_n_;
-	chainp lengths;
-#else
-listargs(FILE *outfile, struct Entrypoint *entryp, int add_n_, chainp lengths)
-#endif
-{
-	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
-#ifdef KR_headers
-list_arg_types(outfile, entryp, lengths, add_n_, finalnl)
-	FILE *outfile;
-	struct Entrypoint *entryp;
-	chainp lengths;
-	int add_n_;
-	char *finalnl;
-#else
-list_arg_types(FILE *outfile, struct Entrypoint *entryp, chainp lengths, int add_n_, char *finalnl)
-#endif
-{
-    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, vclass = arg -> vclass;
-
-	    if (vclass == CLPROC)
-		if (arg->vimpltype)
-			type = Castargs ? TYUNKNOWN : TYSUBR;
-		else if (type == TYREAL && forcedouble && !Castargs)
-			type = TYDREAL;
-
-	    if (type == last_type && vclass == last_class && did_one)
-		nice_printf (outfile, ", ");
-	    else
-		if ((is_ext = vclass == 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 (vclass == 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 = vclass;
-	    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
-#ifdef KR_headers
-write_formats(outfile)
-	FILE *outfile;
-#else
-write_formats(FILE *outfile)
-#endif
-{
-	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
-#ifdef KR_headers
-write_ioblocks(outfile)
-	FILE *outfile;
-#else
-write_ioblocks(FILE *outfile)
-#endif
-{
-	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
-#ifdef KR_headers
-write_assigned_fmts(outfile)
-	FILE *outfile;
-#else
-write_assigned_fmts(FILE *outfile)
-#endif
-{
-	register chainp cp;
-	Namep np;
-	char *comma, *type;
-	int did_one = 0;
-
-	cp = assigned_fmts = revchain(assigned_fmts);
-	nice_printf(outfile, "/* Assigned format variables */\n");
-	do {
-		np = (Namep)cp->datap;
-		if (did_one == np->vstg) {
-			comma = ", ";
-			type = "";
-			}
-		else {
-			comma = (char*)(did_one ? ";\n" : "");
-			type = (char*)(np->vstg == STGAUTO
-						? "char " : "static char ");
-			did_one = np->vstg;
-			}
-		nice_printf(outfile, "%s%s*%s_fmt", comma, type, np->fvarname);
-		}
-		while(cp = cp->nextp);
-	nice_printf(outfile, ";\n\n");
-	}
-
- static char *
-#ifdef KR_headers
-to_upper(s)
-	register char *s;
-#else
-to_upper(register char *s)
-#endif
-{
-	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
-#ifdef KR_headers
-write_namelists(nmch, outfile)
-	chainp nmch;
-	FILE *outfile;
-#else
-write_namelists(chainp nmch, FILE *outfile)
-#endif
-{
-	Namep var;
-	struct Hashentry *entry;
-	struct Dimblock *dimp;
-	int i, nd, type;
-	char *comma, *name;
-	register chainp q;
-	register Namep v;
-
-	nice_printf(outfile, "/* Namelist stuff */\n\n");
-	for (entry = hashtab; entry < lasthash; ++entry) {
-		if (!(v = entry->varp) || !v->vnamelist)
-			continue;
-		type = v->vtype;
-		name = v->cvarname;
-		if (dimp = v->vdim) {
-			nd = dimp->ndim;
-			nice_printf(outfile,
-				"static ftnlen %s_dims[] = { %d, %ld, %ld",
-				name, nd,
-				dimp->nelt->constblock.Const.ci,
-				dimp->baseoffset->constblock.Const.ci);
-			for(i = 0, --nd; i < nd; i++)
-				nice_printf(outfile, ", %ld",
-				  dimp->dims[i].dimsize->constblock.Const.ci);
-			nice_printf(outfile, " };\n");
-			}
-		nice_printf(outfile, "static Vardesc %s_dv = { \"%s\", %s",
-			name, to_upper(v->fvarname),
-			type == TYCHAR ? ""
-				: (dimp || 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
-#ifdef KR_headers
-fixexttype(var)
-	Namep var;
-#else
-fixexttype(Namep var)
-#endif
-{
-	Extsym *e;
-	int type, type1;
-
-	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
-#ifdef KR_headers
-ref_defs(outfile, refdefs)
-	FILE *outfile;
-	chainp refdefs;
-#else
-ref_defs(FILE *outfile, chainp refdefs)
-#endif
-{
-	chainp cp;
-	int eb, i, j, n;
-	struct Dimblock *dimp;
-	expptr b, vl;
-	Namep var;
-	char *amp, *comma;
-
-	margin_printf(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 /* || checksubs */ )
-		 && (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)) {
-			margin_printf(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, ")");
-			}
-		margin_printf(outfile, "]\n" + eb);
-		}
-	nice_printf(outfile, "\n");
-	frchain(&refdefs);
-	}
-
- static long
-#ifdef KR_headers
-n_elt(vd) struct Dimblock *vd;
-#else
-n_elt(struct Dimblock *vd)
-#endif
-{
-	expptr ne;
-	long nv = 1;
-	if (vd) {
-		if (!(ne = vd->nelt))
-			Fatal("Null nelt in n_elt");
-		if (ne->tag != TCONST)
-			fatali("Unexpected nelt tag %d in n_elt", ne->tag);
-		if (!ISINT(ne->constblock.vtype))
-			fatali("Unexpected vtype %d in n_elt",
-				ne->constblock.vtype);
-		nv = ne->constblock.Const.ci;
-		}
-	return nv;
-	}
-
- void
-#ifdef KR_headers
-list_decls(outfile)
-	FILE *outfile;
-#else
-list_decls(FILE *outfile)
-#endif
-{
-    extern chainp used_builtins;
-    extern struct Hashentry *hashtab;
-    struct Hashentry *entry;
-    int write_header = 1;
-    int last_class = -1, last_stg = -1;
-    Namep var;
-    int Alias, Define, did_one, last_type, stg, 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;
-	ftnint k;
-	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))
-			&& (k = Var->vleng->constblock.Const.ci) > 0)
-		nice_printf (outfile, "[%ld]", (long)k);
-
-	    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 vclass = var -> vclass;
-	    stg = var -> vstg;
-	    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 (vclass) {
-	        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",
-			    vclass);
-		    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 && vclass == 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 && vclass != 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);
-			margin_printf(outfile, "_st.val\n");
-			last_type = -1;
-			write_header = 2;
-			continue;
-			}
-		nice_printf(outfile, "%s ",
-			c_type_decl(type, vclass == CLPROC));
-	    } /* else */
-
-/* Character type is really a string type.  Put out a '*' for variable
-   length strings, and also for equivalences */
-
-	    if (type == TYCHAR && vclass != 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 (vclass == 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,
-				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;
-		ftnint voff = var -> voffset;
-		int et0, expr_type, k;
-		Extsym *E;
-		struct Equivblock *eb;
-		char buf[MAXNAMELEN+30]; /*30 should be overkill*/
-
-/* 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) {
-			margin_printf(outfile, ")\n");
-			write_header = 2;
-			}
-		continue;
-		}
-	    write_header = 0;
-	    last_type = type;
-	    last_class = vclass;
-	    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);
-
-    if (trapuv) {
-	for (entry = hashtab; entry < lasthash; ++entry)
-	    if ((var = entry->varp)
-		&& ONEOF(var->vstg, M(STGAUTO)|M(STGBSS))
-		&& ISNUMERIC(var->vtype)
-		&& var->vclass == CLVAR
-		&& !var->vsave)
-			nice_printf(outfile, "_uninit_f2c(&%s,%d,%ldL);\n",
-				var->cvarname, typeconv[var->vtype],
-				n_elt(var->vdim));
-	}
-
-} /* list_decls */
-
- void
-#ifdef KR_headers
-do_uninit_equivs(outfile, did_one)
-	FILE *outfile;
-	int *did_one;
-#else
-do_uninit_equivs(FILE *outfile, int *did_one)
-#endif
-{
-    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 *
-#ifdef KR_headers
-wr_ardecls(outfile, dimp, size)
-	FILE *outfile;
-	struct Dimblock *dimp;
-	long size;
-#else
-wr_ardecls(FILE *outfile, struct Dimblock *dimp, long size)
-#endif
-{
-    int i, k;
-    ftnint j;
-    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 (ISCONST(this_size)) {
-		if (ISINT(this_size->constblock.vtype))
-			j = this_size -> constblock.Const.ci;
-		else if (ISREAL(this_size->constblock.vtype))
-			j = (ftnint)this_size -> constblock.Const.cd[0];
-		else
-			goto non_const;
-		size *= j;
-	   	sprintf(buf+k, "[%ld]", j);
-	    	k += strlen(buf+k);
-		/* BSD prevents getting strlen from sprintf */
-		}
-	else {
- non_const:
-	    err ("wr_ardecls:  nonconstant array size");
-		}
-    } /* 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
-#ifdef KR_headers
-get_p1_token(infile)
-	FILE *infile;
-#else
-get_p1_token(FILE *infile)
-#endif
-{
-    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
-#ifdef KR_headers
-p1gets(fp, str, size)
-	FILE *fp;
-	char *str;
-	int size;
-#else
-p1gets(FILE *fp, char *str, int size)
-#endif
-{
-    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 */
-
-
-#ifndef NO_LONG_LONG
- static int
-#ifdef KR_headers
-p1getq(infile, result) FILE *infile; Llong *result;
-#else
-p1getq(FILE *infile, Llong *result)
-#endif
-{
-#ifdef __FreeBSD__
-#ifndef NO_FSCANF_LL_BUG
-#define FSCANF_LL_BUG
-#endif
-#endif
-#ifdef FSCANF_LL_BUG
-	ULlong x = 0;
-	int c, have_c = 0;
-	for(;;) {
-		c = getc(infile);
-		if (c == EOF)
-			break;
-		if (c <= ' ') {
-			if (!have_c)
-				continue;
-			goto done;
-			}
-		if (c >= '0' && c <= '9')
-			c -= '0';
-		else if (c >= 'a' && c <= 'f')
-			c += 10 - 'a';
-		else if (c >= 'A' && c <= 'F')
-			c += 10 - 'A';
-		else {
- done:
-			ungetc(c, infile);
-			break;
-			}
-		x = x << 4 | c;
-		have_c = 1;
-		}
-	if (have_c) {
-		*result = (Llong)x;
-		return 1;
-		}
-	return 0;
-#else
-	return fscanf(infile, "%llx", result);
-#endif
-	}
-#endif
-
- static int
-#ifdef KR_headers
-p1get_const(infile, type, resultp)
-	FILE *infile;
-	int type;
-	struct Constblock **resultp;
-#else
-p1get_const(FILE *infile, int type, struct Constblock **resultp)
-#endif
-{
-    int status;
-    unsigned long a;
-    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:
-	case TYLOGICAL1:
-	case TYLOGICAL2:
-	    status = p1getd (infile, &(result -> Const.ci));
-	    break;
-#ifndef NO_LONG_LONG
-	case TYQUAD:
-		status = p1getq(infile, &result->Const.cq);
-		break;
-#endif
-	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", &a);
-	    *resultp = (struct Constblock *) a;
-	    break;
-	default:
-	    erri ("p1get_const:  bad constant type '%d'", type);
-	    status = 0;
-	    break;
-    } /* switch */
-
-    return status;
-} /* p1get_const */
-
- static int
-#ifdef KR_headers
-p1getd(infile, result)
-	FILE *infile;
-	long *result;
-#else
-p1getd(FILE *infile, long *result)
-#endif
-{
-    return fscanf (infile, "%ld", result);
-} /* p1getd */
-
- static int
-#ifdef KR_headers
-p1getf(infile, result)
-	FILE *infile;
-	char **result;
-#else
-p1getf(FILE *infile, char **result)
-#endif
-{
-
-	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
-#ifdef KR_headers
-p1getn(infile, count, result)
-	FILE *infile;
-	int count;
-	char **result;
-#else
-p1getn(FILE *infile, int count, char **result)
-#endif
-{
-
-    char *bufptr;
-
-    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
-#ifdef KR_headers
-proto(outfile, at, fname)
-	FILE *outfile;
-	Argtypes *at;
-	char *fname;
-#else
-proto(FILE *outfile,  Argtypes *at,  char *fname)
-#endif
-{
-	int i, j, k, n;
-	char *comma;
-	Atype *atypes;
-	Namep np;
-	chainp cp;
-
-	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;
-			if (k >= 100)
-				k -= 100;
-			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
-#ifdef KR_headers
-protowrite(protofile, type, name, e, lengths)
-	FILE *protofile;
-	int type;
-	char *name;
-	struct Entrypoint *e;
-	chainp lengths;
-#else
-protowrite(FILE *protofile, int type, char *name, struct Entrypoint *e, chainp lengths)
-#endif
-{
-	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
-#ifdef KR_headers
-do_p1_1while(outfile)
-	FILE *outfile;
-#else
-do_p1_1while(FILE *outfile)
-#endif
-{
-	if (*wh_next) {
-		nice_printf(outfile,
-			"for(;;) { /* while(complicated condition) */\n" /*}*/ );
-		next_tab(outfile);
-		}
-	else
-		nice_printf(outfile, "while(" /*)*/ );
-	}
-
- static void
-#ifdef KR_headers
-do_p1_2while(infile, outfile)
-	FILE *infile;
-	FILE *outfile;
-#else
-do_p1_2while(FILE *infile, FILE *outfile)
-#endif
-{
-	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
-#ifdef KR_headers
-do_p1_elseifstart(outfile)
-	FILE *outfile;
-#else
-do_p1_elseifstart(FILE *outfile)
-#endif
-{ /* with sufficiently illegal input, ei_next == ei_last == 0 is possible */
-	if (ei_next < ei_last && *ei_next++) {
-		prev_tab(outfile);
-		nice_printf(outfile, /*{*/
-			"} else /* if(complicated condition) */ {\n" /*}*/ );
-		next_tab(outfile);
-		}
-	}
diff --git a/contrib/tools/f2c/src/format.h b/contrib/tools/f2c/src/format.h
deleted file mode 100644
index 3de97f6f89f..00000000000
--- a/contrib/tools/f2c/src/format.h
+++ /dev/null
@@ -1,12 +0,0 @@
-#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 */
-
-chainp	data_value Argdcl((FILEP, long int, int));
-int	do_init_data Argdcl((FILEP, FILEP));
-void	list_init_data Argdcl((FILEP*, char*, FILEP));
-char*	wr_ardecls Argdcl((FILEP, struct Dimblock*, long int));
-void	wr_one_init Argdcl((FILEP, char*, chainp*, int));
-void	wr_output_values Argdcl((FILEP, Namep, chainp));
diff --git a/contrib/tools/f2c/src/formatdata.c b/contrib/tools/f2c/src/formatdata.c
deleted file mode 100644
index c399c61869a..00000000000
--- a/contrib/tools/f2c/src/formatdata.c
+++ /dev/null
@@ -1,1263 +0,0 @@
-/****************************************************************
-Copyright 1990-1, 1993-6, 1999-2001 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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 VNAME_MAX 64
-
-static int memno2info Argdcl((int, Namep*));
-
-typedef unsigned long Ulong;
-
- extern char *initbname;
-
- void
-#ifdef KR_headers
-list_init_data(Infile, Inname, outfile)
-	FILE **Infile;
-	char *Inname;
-	FILE *outfile;
-#else
-list_init_data(FILE **Infile, char *Inname, FILE *outfile)
-#endif
-{
-    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
-#ifdef KR_headers
-do_init_data(outfile, infile)
-	FILE *outfile;
-	FILE *infile;
-#else
-do_init_data(FILE *outfile, FILE *infile)
-#endif
-{
-    char varname[VNAME_MAX], ovarname[VNAME_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
-#ifdef KR_headers
-wr_char_len(outfile, dimp, n, extra1)
-	FILE *outfile;
-	struct Dimblock *dimp;
-	ftnint n;
-	int extra1;
-#else
-wr_char_len(FILE *outfile, struct Dimblock *dimp, ftnint n, int extra1)
-#endif
-{
-	int i, nd;
-	expptr e;
-	ftnint j, rv;
-
-	if (!dimp) {
-		nice_printf (outfile, extra1 ? "[%ld+1]" : "[%ld]", (long)n);
-		return n + extra1;
-		}
-	nice_printf(outfile, "[%ld", (long)n);
-	nd = dimp->ndim;
-	rv = n;
-	for(i = 0; i < nd; i++) {
-		e = dimp->dims[i].dimsize;
-		if (ISCONST(e)) {
-			if (ISINT(e->constblock.vtype))
-				j = e->constblock.Const.ci;
-			else if (ISREAL(e->constblock.vtype))
-				j = (ftnint)e->constblock.Const.cd[0];
-			else
-				goto non_const;
-			nice_printf(outfile, "*%ld", j);
-			rv *= j;
-			}
-		else {
- non_const:
-			err ("wr_char_len:  nonconstant array size");
-			}
-		}
-	/* 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
-#ifdef KR_headers
-write_char_init(outfile, Values, namep)
-	FILE *outfile;
-	chainp *Values;
-	Namep namep;
-#else
-write_char_init(FILE *outfile, chainp *Values, Namep namep)
-#endif
-{
-	struct Equivblock *eqv;
-	long size;
-	struct Dimblock *dimp;
-	int i, nd, type;
-	ftnint j;
-	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 (ISCONST(ds)) {
-				if (ISINT(ds->constblock.vtype))
-					j = ds->constblock.Const.ci;
-				else if (ISREAL(ds->constblock.vtype))
-					j = (ftnint)ds->constblock.Const.cd[0];
-				else
-					goto non_const;
-				size *= j;
-				}
-			else {
- non_const:
-				err("write_char_values: nonconstant array size");
-				}
-			}
-	*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)
-		margin_printf(outfile, "((char *)&equiv_%d)\n\n", eqvmemno);
-	else
-		margin_printf(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
-#ifdef KR_headers
-wr_one_init(outfile, varname, Values, keepit)
-	FILE *outfile;
-	char *varname;
-	chainp *Values;
-	int keepit;
-#else
-wr_one_init(FILE *outfile, char *varname, chainp *Values, int keepit)
-#endif
-{
-    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 = (Ulong)cp->nextp->datap == TYBLANK
-			? loc + (Ulong)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);
-		margin_printf(outfile, "_st.val\n");
-		goto done;
-		}
-	}
-    else {
-	size = typesize[type];
-	loc = 0;
-	for(; values; values = values->nextp) {
-		if ((Ulong)((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
-#ifdef KR_headers
-data_value(infile, offset, type)
-	FILE *infile;
-	ftnint offset;
-	int type;
-#else
-data_value(FILE *infile, ftnint offset, int type)
-#endif
-{
-    char line[MAX_INIT_LINE + 1], *pointer;
-    chainp vals, prev_val;
-    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 */
-
-#ifdef NO_LONG_LONG
-	if (ONEOF(type, MSKREAL|MSKCOMPLEX))
-#else
-	if (ONEOF(type, MSKREAL|MSKCOMPLEX|M(TYQUAD)))
-#endif
-		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 *)(Ulong)type, vals));
-} /* data_value */
-
- static void
-overlapping(Void)
-{
-	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 Argdcl((int, union Constant*, chainp));
- static long charlen;
-
- void
-#ifdef KR_headers
-wr_output_values(outfile, namep, values)
-	FILE *outfile;
-	Namep namep;
-	chainp values;
-#else
-wr_output_values(FILE *outfile, Namep namep, chainp values)
-#endif
-{
-	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, type, 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 {
-#ifndef NO_LONG_LONG
-			if (type == TYQUAD)
-				Const.Const.cd[1] = 123.456; /* kludge */
-				/* kludge assumes max(sizeof(char*), */
-				/* sizeof(long long)) <= sizeof(double) */
-#endif
-			out_const (outfile, &Const);
-			}
-		}
-	}
-
-
- void
-#ifdef KR_headers
-wr_array_init(outfile, type, values)
-	FILE *outfile;
-	int type;
-	chainp values;
-#else
-wr_array_init(FILE *outfile, int type, chainp values)
-#endif
-{
-    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)(Ulong) ((chainp) values->datap)->
-				nextp->nextp->datap;
-		if ((Ulong)((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]);
-		k++;
-		} /* case TYCHAR */
-	        break;
-
-#ifdef TYQUAD
-	    case TYQUAD:
-#ifndef NO_LONG_LONG
-		Const.Const.cd[1] = 123.456;
-#endif
-#endif
-	    case TYINT1:
-	    case TYSHORT:
-	    case TYLONG:
-	    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
-#ifdef KR_headers
-make_one_const(type, storage, values)
-	int type;
-	union Constant *storage;
-	chainp values;
-#else
-make_one_const(int type, union Constant *storage, chainp values)
-#endif
-{
-    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)(Ulong) (((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)(Ulong) (((chainp) values->datap)->datap);
-
-	    if (index < main_index)
-		overlapping();
-	    while (index > main_index++)
-		*str_ptr++ = ' ';
-
-		k = (int)(Ulong)(((chainp)values->datap)->nextp->nextp->datap);
-		if ((Ulong)((chainp)values->datap)->nextp->datap == TYBLANK) {
-			b = k;
-			break;
-			}
-		*str_ptr = (char)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 */
-
-
- int
-#ifdef KR_headers
-rdname(infile, vargroupp, name)
-	FILE *infile;
-	int *vargroupp;
-	char *name;
-#else
-rdname(FILE *infile, int *vargroupp, char *name)
-#endif
-{
-    register int i, c;
-
-    c = getc (infile);
-
-    if (feof (infile))
-	return NO;
-
-    *vargroupp = c - '0';
-    for (i = 1;; i++) {
-	if (i >= VNAME_MAX)
-		Fatal("rdname: oversize name");
-	c = getc (infile);
-	if (feof (infile))
-	    return NO;
-	if (c == '\t')
-		break;
-	*name++ = c;
-    }
-    *name = 0;
-    return YES;
-} /* rdname */
-
- int
-#ifdef KR_headers
-rdlong(infile, n)
-	FILE *infile;
-	ftnint *n;
-#else
-rdlong(FILE *infile, ftnint *n)
-#endif
-{
-    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
-#ifdef KR_headers
-memno2info(memno, info)
-	int memno;
-	Namep *info;
-#else
-memno2info(int memno, Namep *info)
-#endif
-{
-    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
-#ifdef KR_headers
-do_string(outfile, v, nloc)
-	FILE *outfile;
-	register chainp v;
-	ftnint *nloc;
-#else
-do_string(FILE *outfile, register chainp v, ftnint *nloc)
-#endif
-{
-	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((Ulong)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) || !(cp = (chainp)v->datap))
-			break;
-		dloc = (ftnint)cp->datap;
-		if (loc != dloc)
-			break;
-		}
- done:
-	nice_printf(outfile, "}");
-	*nloc = loc;
-	return v0;
-	}
-
- static chainp
-#ifdef KR_headers
-Ado_string(outfile, v, nloc)
-	FILE *outfile;
-	register chainp v;
-	ftnint *nloc;
-#else
-Ado_string(FILE *outfile, register chainp v, ftnint *nloc)
-#endif
-{
-	register chainp cp, v0;
-	ftnint dloc, k, loc;
-
-	nice_printf(outfile, "\"");
-	cp = (chainp)v->datap;
-	loc = (ftnint)cp->datap;
-	for(v0 = v;;) {
-		switch((Ulong)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]);
-				loc++;
-				break;
-			default:
-				goto done;
-			}
-		v0 = v;
-		if (!(v = v->nextp) || !(cp = (chainp)v->datap))
-			break;
-		dloc = (ftnint)cp->datap;
-		if (loc != dloc)
-			break;
-		}
- done:
-	nice_printf(outfile, "\"");
-	*nloc = loc;
-	return v0;
-	}
-
- static char *
-#ifdef KR_headers
-Len(L, type)
-	long L;
-	int type;
-#else
-Len(long L, int type)
-#endif
-{
-	static char buf[24];
-	if (L == 1 && type != TYCHAR)
-		return "";
-	sprintf(buf, "[%ld]", L);
-	return buf;
-	}
-
- static void
-#ifdef KR_headers
-fill_dcl(outfile, t, k, L) FILE *outfile; int t; int k; ftnint L;
-#else
-fill_dcl(FILE *outfile, int t, int k, ftnint L)
-#endif
-{
-	nice_printf(outfile, "%s fill_%d[%ld];\n", Typename[t], k, L);
-	}
-
- static int
-#ifdef KR_headers
-fill_type(L, loc, xtype) ftnint L; ftnint loc; int xtype;
-#else
-fill_type(ftnint L, ftnint loc, int xtype)
-#endif
-{
-	int ft, ft1, szshort;
-
-	if (xtype == TYCHAR)
-		return xtype;
-	szshort = typesize[TYSHORT];
-	ft = L % szshort ? TYCHAR : type_choice[L/szshort % 4];
-	ft1 = loc % szshort ? TYCHAR : type_choice[loc/szshort % 4];
-	if (typesize[ft] > typesize[ft1])
-		ft = ft1;
-	return ft;
-	}
-
- static ftnint
-#ifdef KR_headers
-get_fill(dloc, loc, t0, t1, L0, L1, xtype) ftnint dloc; ftnint loc; int *t0; int *t1; ftnint *L0; ftnint *L1; int xtype;
-#else
-get_fill(ftnint dloc, ftnint loc, int *t0, int *t1, ftnint *L0, ftnint *L1, int xtype)
-#endif
-{
-	ftnint L, L2, loc0;
-
-	if (L = loc % typesize[xtype]) {
-		loc0 = loc;
-		loc += L = typesize[xtype] - L;
-		if (L % typesize[TYSHORT])
-			*t0 = TYCHAR;
-		else
-			L /= typesize[*t0 = fill_type(L, loc0, xtype)];
-		}
-	if (dloc < loc + typesize[xtype])
-		return 0;
-	*L0 = L;
-	L2 = (dloc - loc) / typesize[xtype];
-	loc += L2*typesize[xtype];
-	if (dloc -= loc)
-		dloc /= typesize[*t1 = fill_type(dloc, loc, xtype)];
-	*L1 = dloc;
-	return L2;
-	}
-
- void
-#ifdef KR_headers
-wr_equiv_init(outfile, memno, Values, iscomm)
-	FILE *outfile;
-	int memno;
-	chainp *Values;
-	int iscomm;
-#else
-wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm)
-#endif
-{
-	struct Equivblock *eqv;
-	int btype, curtype, dtype, filltype, j, k, n, t0, t1;
-	int wasblank, xfilled, xtype;
-	static char Blank[] = "";
-	register char *comma = Blank;
-	register chainp cp, v;
-	chainp sentinel, values, v1, vlast;
-	ftnint L, L0, L1, L2, 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, 0 /* for TYBLANK */ };
-	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;
-	xtype = typepref[xtype];
-	*Values = values = revchain(vlast = *Values);
-
-	xfilled = 2;
-	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 = (int)(L % k))
-					L += k - j;
-				v = mkchain((char *)L,
-					mkchain((char *)(Ulong)dtype,
-						mkchain(z, CHNULL)));
-				vlast = vlast->nextp =
-					mkchain((char *)v, CHNULL);
-				L += k;
-				break;
-				}
-			cp = (chainp)v->datap;
-			if (basetype[(Ulong)cp->nextp->datap] == btype)
-				break;
-			dloc = (ftnint)cp->datap;
-			if (get_fill(dloc, loc, &t0, &t1, &L0, &L1, xtype)) {
-				xfilled = 0;
-				break;
-				}
-			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)(Ulong)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((Ulong)((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 ((Ulong)cp->nextp->datap != TYERROR) {
-				v1 = cp;
-				frchain(&v1);
-				v->datap = 0;
-				}
-			continue;
-			}
-		dtype = (int)(Ulong)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) {
-			filltype = fill_type(L, loc, xtype);
-			L1 = L / typesize[filltype];
-			if (!xfilled && (L2 = get_fill(dloc, loc, &t0, &t1,
-							&L0, &L1, xtype))) {
-				xfilled = 1;
-				if (L0)
-					fill_dcl(outfile, t0, ++k, L0);
-				fill_dcl(outfile, xtype, ++k, L2);
-				if (L1)
-					fill_dcl(outfile, t1, ++k, L1);
-				}
-			else
-				fill_dcl(outfile, 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;
-	xfilled &= 2;
-	for(v = values; ; v = v->nextp) {
-		cp = (chainp)v->datap;
-		if (!cp)
-			continue;
-		dtype = (int)(Ulong)cp->nextp->datap;
-		if (dtype == TYERROR)
-			break;
-		dloc = (ftnint)cp->datap;
-		if (dloc > loc) {
-			n = 1;
-			if (!xfilled && (L2 = get_fill(dloc, loc, &t0, &t1,
-							&L0, &L1, xtype))) {
-				xfilled = 1;
-				if (L0)
-					n = 2;
-				if (L1)
-					n++;
-				}
-			while(n--) {
-				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 TYQUAD0
-			case TYQUAD:
-#endif
-				nice_printf(outfile, "%ld", Const.ci);
-				break;
-#ifndef NO_LONG_LONG
-			case TYQUAD:
-				nice_printf(outfile, "%s", Const.cds[0]);
-				break;
-#endif
-			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/contrib/tools/f2c/src/ftypes.h b/contrib/tools/f2c/src/ftypes.h
deleted file mode 100644
index 8181d87602d..00000000000
--- a/contrib/tools/f2c/src/ftypes.h
+++ /dev/null
@@ -1,64 +0,0 @@
-
-/* variable types (stored in the   vtype  field of   expptr)
- * numeric assumptions:
- *	int < reals < complexes
- *	TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX
- */
-
-#undef TYQUAD0
-#ifdef NO_TYQUAD
-#undef TYQUAD
-#define TYQUAD_inc 0
-#undef NO_LONG_LONG
-#define NO_LONG_LONG
-#else
-#define TYQUAD 5
-#define TYQUAD_inc 1
-#ifdef NO_LONG_LONG
-#define TYQUAD0
-#else
-#ifndef Llong
-typedef long long Llong;
-#endif
-#ifndef ULlong
-typedef unsigned long long ULlong;
-#endif
-#endif /*NO_LONG_LONG*/
-#endif /*NO_TYQUAD*/
-
-#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/contrib/tools/f2c/src/gram.c b/contrib/tools/f2c/src/gram.c
deleted file mode 100644
index 0a60fc6f0ab..00000000000
--- a/contrib/tools/f2c/src/gram.c
+++ /dev/null
@@ -1,1957 +0,0 @@
-#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
-#define	SBYTE	100
-
-/* #line	125	"/n/bopp/v5/dmg/f2c/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 */
-extern void endcheck Argdcl((void));
-extern struct Primblock *primchk Argdcl((expptr));
-
-#define ESNULL (Extsym *)0
-#define NPNULL (Namep)0
-#define LBNULL (struct Listblock *)0
-
- static void
-pop_datastack(Void) {
-	chainp d0 = datastack;
-	if (d0->datap)
-		curdtp = (chainp)d0->datap;
-	datastack = d0->nextp;
-	d0->nextp = 0;
-	frchain(&d0);
-	}
-
-
-/* #line	172	"/n/bopp/v5/dmg/f2c/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;
-extern	int	yyerrflag;
-#ifndef	YYMAXDEPTH
-#define	YYMAXDEPTH	150
-#endif
-YYSTYPE	yylval;
-YYSTYPE	yyval;
-#define YYEOFCODE 1
-#define YYERRCODE 2
-short	yyexca[] =
-{-1, 1,
-	1, -1,
-	-2, 0,
--1, 20,
-	4, 38,
-	-2, 231,
--1, 24,
-	4, 42,
-	-2, 231,
--1, 151,
-	4, 247,
-	-2, 189,
--1, 175,
-	4, 269,
-	81, 269,
-	-2, 189,
--1, 225,
-	80, 174,
-	-2, 140,
--1, 246,
-	77, 231,
-	-2, 228,
--1, 273,
-	4, 290,
-	-2, 144,
--1, 277,
-	4, 299,
-	81, 299,
-	-2, 146,
--1, 330,
-	80, 175,
-	-2, 142,
--1, 360,
-	4, 271,
-	17, 271,
-	77, 271,
-	81, 271,
-	-2, 190,
--1, 439,
-	94, 0,
-	95, 0,
-	96, 0,
-	97, 0,
-	98, 0,
-	99, 0,
-	-2, 154,
--1, 456,
-	4, 293,
-	81, 293,
-	-2, 144,
--1, 458,
-	4, 295,
-	81, 295,
-	-2, 144,
--1, 460,
-	4, 297,
-	81, 297,
-	-2, 144,
--1, 462,
-	4, 300,
-	81, 300,
-	-2, 145,
--1, 506,
-	81, 293,
-	-2, 144,
-};
-#define	YYNPROD	305
-#define	YYPRIVATE 57344
-#define	YYLAST	1455
-short	yyact[] =
-{
- 239, 359, 474, 306, 416, 427, 299, 389, 473, 267,
- 315, 231, 400, 358, 318, 415, 328, 253, 319, 100,
- 224, 297, 294, 280, 402, 401, 305, 117, 185, 265,
-  17, 122, 204, 275, 196, 191, 202, 203, 119, 129,
- 107, 271, 200, 184, 112, 104, 338, 102, 166, 167,
- 336, 337, 338, 344, 343, 342, 121, 157, 120, 345,
- 347, 346, 349, 348, 350, 261, 276, 336, 337, 338,
- 131, 132, 133, 134, 104, 136, 539, 158, 399, 158,
- 313, 166, 167, 336, 337, 338, 344, 343, 342, 341,
- 340, 311, 345, 347, 346, 349, 348, 350, 399, 398,
- 105, 514, 115, 537, 166, 167, 336, 337, 338, 344,
- 343, 342, 341, 340, 238, 345, 347, 346, 349, 348,
- 350, 106, 130, 104, 478, 211, 187, 188, 412, 320,
- 259, 260, 261, 411,  95, 166, 167, 336, 337, 338,
- 186, 213, 296, 212, 194, 486, 195, 542, 245,  96,
-  97,  98, 527, 104, 529, 158, 523, 449, 258, 158,
- 241, 243, 484, 101, 487, 485, 216, 274, 471, 222,
- 217, 472, 221, 158, 483, 465, 430, 220, 166, 167,
- 259, 260, 261, 262, 158, 166, 167, 336, 337, 338,
- 344, 156, 121, 156, 120, 464, 345, 347, 346, 349,
- 348, 350, 463, 373, 281, 282, 283, 236, 104, 232,
- 242, 242, 249, 101, 292, 301, 263, 468, 290, 302,
- 279, 296, 291, 288, 289, 166, 167, 259, 260, 261,
- 264, 317, 455, 335, 189, 351, 312, 310, 446, 453,
- 431, 284, 425, 335, 166, 167, 259, 260, 261, 262,
- 258, 466, 325, 158, 467, 450, 380,  99, 449, 158,
- 158, 158, 158, 158, 258, 258, 357, 379, 269, 156,
- 234, 420, 266, 156, 421, 409, 393, 335, 410, 394,
- 361, 333, 323, 362, 334, 258, 378, 156, 270, 208,
- 326, 101, 330, 178, 113, 332, 374, 111, 156, 375,
- 376, 403, 352, 110, 109, 108, 354, 355, 385, 386,
- 363, 356, 384, 225, 377, 425, 367, 368, 369, 370,
- 371, 422, 223, 364, 335, 538, 391, 335, 534, 533,
- 532, 335, 423, 335, 372, 413, 408, 395, 390, 166,
- 167, 259, 260, 261, 262, 381, 434, 528, 531, 526,
- 494, 429, 237, 335, 496, 335, 335, 335, 104, 104,
- 490, 298, 138, 158, 258, 335, 448, 156, 258, 258,
- 258, 258, 258, 156, 156, 156, 156, 156, 251, 192,
- 451, 103, 335, 454, 309, 277, 277, 360, 287, 426,
- 118, 352, 166, 167, 259, 260, 261, 262, 137, 387,
- 403, 232, 435, 436, 437, 438, 439, 440, 441, 442,
- 443, 444, 477, 247, 469, 406, 482, 470, 308, 269,
- 452, 166, 167, 336, 337, 338, 344, 335, 479, 155,
- 244, 155, 488, 228, 225, 499, 335, 335, 335, 335,
- 335, 335, 335, 335, 335, 335, 383, 497, 273, 273,
- 495, 502, 201, 258, 150, 151, 214, 175, 103, 103,
- 103, 103, 501, 190, 475, 454, 210, 172, 193, 142,
- 503, 197, 198, 199, 504, 510, 335, 156, 207, 403,
- 277, 513, 507, 508, 509, 331, 277, 482, 517, 489,
- 335, 520, 492, 335, 197, 218, 219, 242, 498, 335,
- 525, 519, 518, 516, 515, 524, 353, 155, 404, 512,
- 246, 155, 248, 104, 406, 417,  30, 535, 406, 511,
- 390, 209, 213, 335, 227, 155, 268,  93,   6, 541,
- 250, 335, 171, 173, 177,  82, 155, 335,   4, 475,
-  81, 335,   5, 273, 543,  80, 457, 459, 461, 382,
- 124,  79, 103, 174, 304, 295, 307, 522,  78,  77,
-  76,  60,  49, 242,  48,  45, 424, 322,  33, 114,
- 530, 118, 206, 316, 414, 321, 205, 397, 396, 300,
- 197, 536, 481, 135, 215, 392, 277, 277, 277, 314,
- 540, 116,  26, 406,  25, 353,  24,  23,  22,  21,
- 388, 286,   9,   8,   7, 155,   2, 404, 303,  20,
- 165, 155, 155, 155, 155, 155,  51, 491, 293, 268,
- 230, 329, 268, 268, 166, 167, 336, 337, 338, 344,
- 343, 457, 459, 461, 327, 345, 347, 346, 349, 348,
- 350, 418,  92, 256,  53, 339,  19,  55,  37, 456,
- 458, 460, 226,   3,   1,   0,   0,   0,   0,   0,
-   0, 307,   0, 405, 197,   0,   0,   0,   0,   0,
-   0, 277, 277, 277, 419,   0,   0,   0, 353,   0,
- 321,   0,   0,   0,   0,   0, 404,   0,   0,   0,
- 493,   0,   0,   0, 432, 166, 167, 336, 337, 338,
- 344, 343, 342, 341, 340,   0, 345, 347, 346, 349,
- 348, 350,   0,   0,   0, 155,   0, 500,   0,   0,
-   0,   0,   0,   0,   0,   0, 268,   0,   0,   0,
-   0,   0, 462,   0, 506, 458, 460, 166, 167, 336,
- 337, 338, 344, 343, 342, 341, 340,   0, 345, 347,
- 346, 349, 348, 350,   0,   0,   0, 295,   0,   0,
-   0,   0, 405, 480,   0, 307, 405,   0,   0, 447,
-   0,   0,   0,   0, 166, 167, 336, 337, 338, 344,
- 343, 342, 341, 340, 316, 345, 347, 346, 349, 348,
- 350,   0,   0, 445,   0,   0,   0,   0, 166, 167,
- 336, 337, 338, 344, 343, 342, 341, 340, 268, 345,
- 347, 346, 349, 348, 350,   0,   0,   0, 505,   0,
-   0,   0,   0,   0,   0,   0, 505, 505, 505,   0,
-   0,   0,   0,   0,   0,   0, 307,  12,   0,   0,
-   0, 405,   0,   0,   0,   0, 505,   0,   0,   0,
- 521,  10,  56,  46,  73,  86,  14,  61,  70,  91,
-  38,  66,  47,  42,  68,  72,  31,  67,  35,  34,
-  11,  88,  36,  18,  41,  39,  28,  16,  57,  58,
-  59,  50,  54,  43,  89,  64,  40,  69,  44,  90,
-  29,  62,  85,  13,   0,  83,  65,  52,  87,  27,
-  74,  63,  15, 433,   0,  71,  84,   0, 166, 167,
- 336, 337, 338, 344, 343, 342, 341, 340,   0, 345,
- 347, 346, 349, 348, 350,   0,   0,   0,   0,   0,
-  32,   0,   0,  75, 166, 167, 336, 337, 338, 344,
- 343, 342, 341, 340,   0, 345, 347, 346, 349, 348,
- 350,  73,   0,   0,   0,  70,   0,   0,  66,   0,
-   0,  68,  72,   0,  67, 161, 162, 163, 164, 170,
- 169, 168, 159, 160, 104,   0,   0,   0,   0,   0,
-   0,   0,  64,   0,  69,   0,   0,   0,   0,   0,
-   0,   0,   0,  65,   0,   0,   0,  74,   0,   0,
-   0,   0,  71, 161, 162, 163, 164, 170, 169, 168,
- 159, 160, 104,   0, 161, 162, 163, 164, 170, 169,
- 168, 159, 160, 104,   0,   0,   0,   0,   0,   0,
-  75,   0,   0,   0, 235,   0,   0,   0,   0,   0,
- 166, 167, 365,   0, 366,   0,   0,   0,   0,   0,
- 240, 161, 162, 163, 164, 170, 169, 168, 159, 160,
- 104,   0, 161, 162, 163, 164, 170, 169, 168, 159,
- 160, 104, 235, 229,   0,   0,   0,   0, 166, 167,
- 233,   0,   0, 235,   0,   0,   0,   0, 240, 166,
- 167, 476,   0,   0,   0,   0,   0,   0,   0, 240,
- 161, 162, 163, 164, 170, 169, 168, 159, 160, 104,
- 161, 162, 163, 164, 170, 169, 168, 159, 160, 104,
- 235,   0,   0,   0,   0,   0, 166, 167, 233,   0,
-   0, 235,   0,   0,   0,   0, 240, 166, 167, 428,
-   0,   0,   0,   0,   0,   0,   0, 240, 161, 162,
- 163, 164, 170, 169, 168, 159, 160, 104,   0, 161,
- 162, 163, 164, 170, 169, 168, 159, 160, 104, 278,
-   0,   0,   0, 272,   0, 166, 167,   0,   0,   0,
-   0,   0,   0,   0,   0, 240, 161, 162, 163, 164,
- 170, 169, 168, 159, 160, 104,   0,   0,   0,   0,
-   0,   0,   0,   0,   0,  94, 161, 162, 163, 164,
- 170, 169, 168, 159, 160, 104, 257, 235,   0,   0,
-   0,   0,   0, 166, 167,   0,   0,   0, 278,   0,
-   0,   0,   0, 240, 166, 167,   0, 123,   0,   0,
- 126, 127, 128,   0, 240,   0,   0,   0,   0,   0,
-   0,   0, 139, 140,   0, 324, 141,   0, 143, 144,
- 145, 166, 167, 146, 147, 148,   0, 149,   0,   0,
-   0, 240,   0,   0,   0, 252,   0,   0,   0,   0,
-   0, 166, 167, 254,   0, 255,   0, 179, 180, 181,
- 182, 183, 161, 162, 163, 164, 170, 169, 168, 159,
- 160, 104,   0, 161, 162, 163, 164, 170, 169, 168,
- 159, 160, 104, 161, 162, 163, 164, 170, 169, 168,
- 159, 160, 104, 161, 162, 163, 164, 170, 169, 168,
- 159, 160, 104, 161, 162, 163, 164, 170, 169, 168,
- 159, 160, 104,   0,   0,   0,   0,   0,   0,   0,
-   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
-   0, 154,   0,   0,   0,   0,   0, 166, 167, 152,
-   0, 153, 252,   0,   0,   0,   0,   0, 166, 167,
- 285,   0, 154,   0,   0,   0,   0,   0, 166, 167,
- 176,   0, 407,   0,   0,   0,   0,   0, 166, 167,
-  56,  46, 252,  86,   0,  61,   0,  91, 166, 167,
-  47,   0,   0,   0,   0,   0,   0,   0,   0,  88,
-   0,   0,   0,   0,   0,   0,  57,  58,  59,  50,
-   0,   0,  89,   0,   0,   0,   0,  90,   0,  62,
-  85,   0,   0,  83,   0,  52,  87,   0,   0,  63,
-   0, 125,   0,   0,  84
-};
-short	yypact[] =
-{
--1000, 536, 524, 830,-1000,-1000,-1000,-1000,-1000,-1000,
- 519,-1000,-1000,-1000,-1000,-1000,-1000, 210, 496,  19,
- 224, 223, 222, 216,  82, 213,  16, 106,-1000,-1000,
--1000,-1000,-1000,1378,-1000,-1000,-1000,  37,-1000,-1000,
--1000,-1000,-1000,-1000,-1000, 496,-1000,-1000,-1000,-1000,
--1000, 392,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,
--1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,
--1000,-1000,-1000,-1000,-1000,-1000,1284, 390,1305, 390,
- 212,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,
--1000,-1000,-1000,-1000,-1000, 496, 496, 496, 496,-1000,
- 496,-1000, 302,-1000,-1000, 496,-1000, -30, 496, 496,
- 496, 375,-1000,-1000,-1000, 496, 208,-1000,-1000,-1000,
--1000, 504, 389, 132,-1000,-1000, 379,-1000,-1000,-1000,
--1000, 106, 496, 496, 375,-1000,-1000, 243, 357, 515,
--1000, 356, 995,1140,1140, 353, 513, 496, 336, 496,
--1000,-1000,-1000,-1000,1198,-1000,-1000,  95,1325,-1000,
--1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000,
--1000,-1000,1198, 191, 207,-1000,-1000,1092,1151,-1000,
--1000,-1000,-1000,1295, 311,-1000,-1000, 302, 302, 496,
--1000,-1000, 136, 284,-1000,  82,-1000, 284,-1000,-1000,
--1000, 496,-1000, 341,-1000, 307, 927,   5, 106,  -6,
- 496,  82,  28,-1000,-1000,1178,-1000, 496,-1000,-1000,
--1000,-1000,-1000,1140,-1000,1140, 411,-1000,1140,-1000,
- 203,-1000, 851, 513,-1000,1140,-1000,-1000,-1000,1140,
-1140,-1000, 851,-1000,1140,-1000,  82, 513,-1000, 309,
- 202,-1000,1325,-1000,-1000,-1000, 957,-1000,1325,1325,
-1325,1325,1325, -22, 256, 122, 342,-1000,-1000, 342,
- 342,-1000,1151, 205, 186, 175, 851,-1000,1151,-1000,
--1000,-1000,-1000,-1000,  95,-1000,-1000, 321,-1000,-1000,
- 302,-1000,-1000, 198,-1000,-1000,-1000,  37,-1000,  -3,
-1315, 496,-1000, 197,-1000,  47,-1000,-1000, 341, 498,
--1000, 496,-1000,-1000, 193,-1000, 242,  28,-1000,-1000,
--1000, 163,1140, 851,1054,-1000, 851, 273,  96, 159,
- 851, 496, 825,-1000,1043,1140,1140,1140,1140,1140,
-1140,1140,1140,1140,1140,-1000,-1000,-1000,-1000,-1000,
--1000,-1000, 715, 157, -41, 102, 691, 289, 177,-1000,
--1000,-1000,1198, 161, 851,-1000,-1000,  45, -22, -22,
- -22, 142,-1000, 342, 122, 151, 122,-1000,1151,1151,
-1151, 654, 121, 114,  94,-1000,-1000,-1000, 173,-1000,
- 138,-1000, 284,-1000,  57,-1000,  90,1006,-1000,1315,
--1000,-1000,  39,1102,-1000,-1000,-1000,1140,-1000,-1000,
- 496,-1000, 341,  93,  84,-1000,  61,-1000,  83,-1000,
--1000, 496,1140,-1000, 283,1140, 612,-1000, 272, 277,
-1140,1140,-1000, 513,-1000, -18, -41, -41, -41, 338,
- -35, -35, 541, 102,  52,-1000,1140,-1000, 513, 513,
-  82,-1000,  95,-1000,-1000, 342,-1000,-1000,-1000,-1000,
--1000,-1000,-1000,1151,1151,1151,-1000, 503, 502,  37,
--1000,-1000,1006,-1000,-1000,  21,-1000,-1000,1315,-1000,
--1000,-1000,-1000, 341,-1000, 498, 498, 496,-1000, 851,
-1140,  75, 851, 432,-1000,-1000,1140, 271, 851,  71,
- 269,  76,-1000,1140, 270, 236, 269, 252, 251, 250,
--1000,-1000,-1000,-1000,1006,-1000,-1000,  17, 247,-1000,
--1000,-1000,  -2,1140,-1000,-1000,-1000, 513,-1000,-1000,
- 851,-1000,-1000,-1000,-1000,-1000, 851,-1000,-1000,-1000,
- 851,  66, 513,-1000
-};
-short	yypgo[] =
-{
-   0, 654, 653,   1, 652, 167,   9,  30, 648, 647,
- 646,   4,   0, 645, 644, 643,  39, 642,   3,  26,
- 641, 634, 621,  18,  14, 620,  35, 618, 617,  29,
-  41,  33,  20, 362,  22, 616,  34, 352,  66, 270,
-  16,  57, 378,   2,  24,  25,  11, 207, 114, 610,
- 609,  38,  28,  43, 608, 606, 604, 603, 602,1205,
- 134, 601, 600,   7, 599, 598, 597, 596, 594, 592,
- 591,  31, 589,  19, 585,  21,  37,   6, 584,   5,
-  42, 583,  36, 582, 579,  12,  27,  10, 578, 577,
-   8,  13,  32, 576, 574, 572,  15, 569, 516, 568,
- 567, 566, 565, 564, 562, 561, 560, 454, 559, 558,
- 553, 551, 545, 540,  23, 535, 530,  17
-};
-short	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,   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, 100,  58,  58,  58,  99,
-  23,  24, 101,  24,  98,  98,  98,  98,  98,  98,
-  98,  98,  98,  98,  98,   4, 102, 103, 103, 103,
- 103,  73,  73,  35,  25,  25,  46,  46,  14,  14,
-  28,  28,  59,  78,  79, 104, 105, 105, 105, 105,
- 105, 105, 105, 105, 105, 105, 105, 105, 105, 105,
- 105, 106, 113, 113, 113, 108, 115, 115, 115, 110,
- 110, 107, 107, 116, 116, 117, 117, 117, 117, 117,
- 117,  15, 109, 111, 112, 112,  29,  29,   6,   6,
-  30,  30,  30,  31,  31,  31,  31,  31,  31,   5,
-   5,   5,   5,   5, 114
-};
-short	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,   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,
-   5,   4,   1,   2,   2,   0,   7,   2,   2,   5,
-   3,   1,   0,   5,   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,   4,   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
-};
-short	yychk[] =
-{
--1000,  -1, -55,  -2,   2,   6,   4, -56, -57, -58,
-  21,  40,   7,  63,  26,  72,  47,  -7,  43, -10,
- -50, -64, -65, -66, -67, -68, -69,  69,  46,  60,
- -98,  36, 100, -99,  39,  38,  42,  -8,  30,  45,
-  56,  44,  33,  53,  58,-102,  23,  32,-103,-104,
-  51, -35,  67, -14,  52,  -9,  22,  48,  49,  50,
--105,  27,  61,  71,  55,  66,  31,  37,  34,  57,
-  28,  75,  35,  24,  70, 103,-106,-108,-109,-111,
--112,-113,-115,  65,  76,  62,  25,  68,  41,  54,
-  59,  29, -17,   8, -59, -60, -60, -60, -60,  47,
- -73,  81, -52, -33,  17,  81, 102, -73,  81,  81,
-  81,  81, -73,  81, -97,  86, -70, -86, -33, -51,
-  88,  86, -71, -59, -98,  73, -59, -59, -59, -16,
-  85, -71, -71, -71, -71, -81, -71, -37, -33, -59,
- -59, -59,  77, -59, -59, -59, -59, -59, -59, -59,
--107, -42,  85,  87,  77, -37, -48, -41, -12,  15,
-  16,   8,   9,  10,  11, -49,  83,  84,  14,  13,
-  12,-107,  77,-107,-110, -42,  85,-107,  81, -59,
- -59, -59, -59, -59, -53, -52, -53, -52, -52, -60,
- -33, -26,  77, -33, -76, -51, -36, -33, -33, -33,
- -80,  77, -82, -76, -92, -93, -95, -33,  81,  17,
-  77,  -3, -73,   9,  77, -78, -36, -51, -33, -33,
- -80, -82, -92,  79, -32,  77,  -4,   9,  77,  78,
- -25, -46, -38,  85, -39,  77, -47, -37, -48, -12,
-  93, -40, -38, -40,  77,  -3, -33,  77, -33, -41,
--116, -42,  77,-117,  85,  87, -15,  18, -12,  85,
-  86,  87,  88, -41, -41, -29,  81,  -6, -37,  77,
-  81, -30,  81, -39,  -5, -31, -38, -47,  77, -30,
--114,-114,-114,-114, -41,  85, -61,  77, -26, -26,
- -52, -71,  78, -27, -34, -33,  85, -75,  77, -77,
- -84, -73, -75, -54, -37, -19, -18, -37,  77,  77,
-  -7,  86, -86,  86, -72, -87, -33, -73, -24, -23,
- 101, -33,-100, -38,  77, -36, -38, -21, -40, -22,
- -38,  74, -38,  78,  81, -12,  85,  86,  87, -13,
-  92,  91,  90,  89,  88,  94,  96,  95,  98,  97,
-  99,  -3, -38, -39, -38, -38, -38, -73, -91,  -3,
-  78,  78,  81, -41, -38,  85,  87, -41, -41, -41,
- -41, -41,  78,  81, -29, -29, -29, -30,  81,  81,
-  81, -38, -39,  -5, -31,-114,-114,  78, -62, -63,
-  17, -26, -74,  78,  81, -16, -88, -89, 102,  81,
- -85, -45, -44, -12, -47, -33, -48,  77, -36,  78,
-  81,  86,  81, -19, -94, -96, -11,  17, -20, -33,
-  78,  81,  79, -24,-101,  79, -38, -79,  85,  78,
-  80,  81, -33,  78, -46, -38, -38, -38, -38, -38,
- -38, -38, -38, -38, -38,  78,  81,  78,  77,  81,
-  78,-117, -41,  78,  -6,  81, -39,  -5, -39,  -5,
- -39,  -5,  78,  81,  81,  81,  78,  81,  79, -75,
- -34,  78,  81, -90, -43, -38,  85, -85,  85, -44,
- -37, -83, -18,  81,  78,  81,  84,  81, -87, -38,
-  77, -28, -38,  78,  78, -32,  77, -40, -38,  -3,
- -39, -91,  -3, -73, -23, -33, -39, -23, -23, -23,
- -63,  17, -16, -90,  80, -45, -44, -77, -23, -96,
- -11, -33, -38,  81,  73, -79,  78,  81,  78,  78,
- -38,  78,  78,  78,  78, -43, -38,  86,  78,  78,
- -38,  -3,  81,  -3
-};
-short	yydef[] =
-{
-   1,  -2,   0,   0,   9,  10,   2,   3,   4,   5,
-   0, 242,   8,  18,  18,  18,  18, 231,   0,  37,
-  -2,  39,  40,  41,  -2,  43,  44,  45,  47, 139,
- 199, 242, 202,   0, 242, 242, 242,  67, 139, 139,
- 139, 139,  87, 139, 134,   0, 242, 242, 217, 218,
- 242, 220, 242, 242, 242,  54, 226, 242, 242, 242,
- 245, 242, 238, 239,  55,  56,  57,  58,  59,  60,
-  61,  62,  63,  64,  65,  66,   0,   0,   0,   0,
- 259, 242, 242, 242, 242, 242, 262, 263, 264, 266,
- 267, 268,   6,  36,   7,  21,  21,   0,   0,  18,
-   0, 232,  29,  19,  20,   0,  89,   0, 232,   0,
-   0,   0,  89, 127, 135,   0,  46,  99, 101, 102,
-  74,   0,   0, 231, 203, 204,   0, 207, 208,  53,
- 243,   0,   0,   0,   0,  89, 127,   0, 169,   0,
- 216,   0,   0, 174, 174,   0,   0,   0,   0,   0,
- 246,  -2, 248, 249,   0, 191, 192,   0,   0, 178,
- 179, 180, 181, 182, 183, 184, 161, 162, 186, 187,
- 188, 250,   0, 251, 252,  -2, 270, 256,   0, 304,
- 304, 304, 304,   0,  11,  22,  13,  29,  29,   0,
- 139,  17,   0, 111,  91, 231,  73, 111,  77,  79,
-  81,   0,  86,   0, 124, 126,   0,   0,   0,   0,
-   0, 231,   0, 122, 205,   0,  70,   0,  76,  78,
-  80,  85, 123,   0, 170,  -2,   0, 225,   0, 221,
-   0, 234, 236,   0, 144,   0, 146, 147, 148,   0,
-   0, 223, 175, 224,   0, 227,  -2,   0, 233, 275,
-   0, 189,   0, 273, 276, 277,   0, 281,   0,   0,
-   0,   0,   0, 197, 275, 253,   0, 286, 288,   0,
-   0, 257,   0,  -2, 291, 292,   0,  -2,   0, 260,
- 261, 265, 282, 283, 304, 304,  12,   0,  14,  15,
-  29,  52,  30,   0,  32,  34,  35,  67, 113,   0,
-   0,   0, 106,   0,  83,   0, 109, 107,   0,   0,
- 128,   0, 100,  75,   0, 103,   0,   0, 201, 211,
- 212,   0,   0, 244,   0,  71, 214,   0,   0, 141,
-  -2,   0,   0, 222,   0,   0,   0,   0,   0,   0,
-   0,   0,   0,   0,   0, 163, 164, 165, 166, 167,
- 168, 237,   0, 144, 153, 159,   0,   0,   0, 120,
-  -2, 272,   0,   0, 278, 279, 280, 193, 194, 195,
- 196, 198, 271,   0, 255,   0, 254, 258,   0,   0,
-   0,   0, 144,   0,   0, 284, 285,  23,   0,  25,
-  27,  16, 111,  31,   0,  50,   0,   0,  51,   0,
-  92,  94,  96,   0,  98, 176, 177,   0,  72,  82,
-   0,  90,   0,   0,   0, 129, 131, 133, 136, 137,
-  48,   0,   0, 200,   0,   0,   0,  68,   0, 171,
- 174,   0, 215,   0, 235, 149, 150, 151, 152,  -2,
- 155, 156, 157, 158, 160, 145,   0, 209,   0,   0,
- 231, 274, 275, 190, 287,   0,  -2, 294,  -2, 296,
-  -2, 298,  -2,   0,   0,   0,  24,   0,   0,  67,
-  33, 112,   0, 114, 116, 119, 118,  93,   0,  97,
-  84,  91, 110,   0, 125,   0,   0,   0, 104, 105,
-   0, 210, 240,   0, 244, 172, 174,   0, 143,   0,
- 144,   0, 121,   0,   0, 169,  -2,   0,   0,   0,
-  26,  28,  49, 115,   0,  95,  96,   0,   0, 130,
- 132, 138,   0,   0, 206,  69, 173,   0, 185, 229,
- 230, 289, 301, 302, 303, 117, 119,  88, 108, 213,
- 241,   0,   0, 219
-};
-short	yytok1[] =
-{
-   1,   4,   5,   6,   7,   8,   9,  10,  11,  12,
-  13,  14,  15,  16,  17,  18,  19,  20,  21,  22,
-  23,  24,  25,  26,  27,  28,  29,  30,  31,  32,
-  33,  34,  35,  36,  37,  38,  39,  40,  41,  42,
-  43,  44,  45,  46,  47,  48,  49,  50,  51,  52,
-  53,  54,  55,  56,  57,  58,  59,  60,  61,  62,
-  63,  64,  65,  66,  67,  68,  69,  70,  71,  72,
-  73,  74,  75,  76,  77,  78,  79,  80,  81,  82,
-  83,  84,  85,  86,  87,  88,  89,  90,  91,  92,
-  93,  94,  95,  96,  97,  98,  99, 100, 101, 102,
- 103
-};
-short	yytok2[] =
-{
-   2,   3
-};
-long	yytok3[] =
-{
-   0
-};
-#define YYFLAG 		-1000
-#define YYERROR		goto yyerrlab
-#define YYACCEPT	return(0)
-#define YYABORT		return(1)
-#define	yyclearin	yychar = -1
-#define	yyerrok		yyerrflag = 0
-
-#ifdef	yydebug
-//#include	"y.debug"
-#else
-#define	yydebug		0
-char*	yytoknames[1];		/* for debugging */
-char*	yystates[1];		/* for debugging */
-#endif
-
-/*	parser for yacc output	*/
-
-int	yynerrs = 0;		/* number of errors */
-int	yyerrflag = 0;		/* error recovery flag */
-
-extern	int	fprint(int, char*, ...);
-extern	int	sprint(char*, char*, ...);
-
-char*
-yytokname(int yyc)
-{
-	static char x[10];
-
-	if(yyc > 0 && yyc <= sizeof(yytoknames)/sizeof(yytoknames[0]))
-	if(yytoknames[yyc-1])
-		return yytoknames[yyc-1];
-	sprintf(x, "<%d>", yyc);
-	return x;
-}
-
-char*
-yystatname(int yys)
-{
-	static char x[10];
-
-	if(yys >= 0 && yys < sizeof(yystates)/sizeof(yystates[0]))
-	if(yystates[yys])
-		return yystates[yys];
-	sprintf(x, "<%d>\n", yys);
-	return x;
-}
-
-long
-yylex1(void)
-{
-	long yychar;
-	long *t3p;
-	int c;
-
-	yychar = yylex();
-	if(yychar <= 0) {
-		c = yytok1[0];
-		goto out;
-	}
-	if(yychar < sizeof(yytok1)/sizeof(yytok1[0])) {
-		c = yytok1[yychar];
-		goto out;
-	}
-	if(yychar >= YYPRIVATE)
-		if(yychar < YYPRIVATE+sizeof(yytok2)/sizeof(yytok2[0])) {
-			c = yytok2[yychar-YYPRIVATE];
-			goto out;
-		}
-	for(t3p=yytok3;; t3p+=2) {
-		c = t3p[0];
-		if(c == yychar) {
-			c = t3p[1];
-			goto out;
-		}
-		if(c == 0)
-			break;
-	}
-	c = 0;
-
-out:
-	if(c == 0)
-		c = yytok2[1];	/* unknown char */
-	if(yydebug >= 3)
-		printf("lex %.4lX %s\n", yychar, yytokname(c));
-	return c;
-}
-
-int
-yyparse(void)
-{
-	struct
-	{
-		YYSTYPE	yyv;
-		int	yys;
-	} yys[YYMAXDEPTH], *yyp, *yypt;
-	short *yyxi;
-	int yyj, yym, yystate, yyn, yyg;
-	YYSTYPE save1, save2;
-	int save3, save4;
-	long yychar;
-
-	save1 = yylval;
-	save2 = yyval;
-	save3 = yynerrs;
-	save4 = yyerrflag;
-
-	yystate = 0;
-	yychar = -1;
-	yynerrs = 0;
-	yyerrflag = 0;
-	yyp = &yys[-1];
-	goto yystack;
-
-ret0:
-	yyn = 0;
-	goto ret;
-
-ret1:
-	yyn = 1;
-	goto ret;
-
-ret:
-	yylval = save1;
-	yyval = save2;
-	yynerrs = save3;
-	yyerrflag = save4;
-	return yyn;
-
-yystack:
-	/* put a state and value onto the stack */
-	if(yydebug >= 4)
-		printf("char %s in %s", yytokname(yychar), yystatname(yystate));
-
-	yyp++;
-	if(yyp >= &yys[YYMAXDEPTH]) {
-		yyerror("yacc stack overflow");
-		goto ret1;
-	}
-	yyp->yys = yystate;
-	yyp->yyv = yyval;
-
-yynewstate:
-	yyn = yypact[yystate];
-	if(yyn <= YYFLAG)
-		goto yydefault; /* simple state */
-	if(yychar < 0)
-		yychar = yylex1();
-	yyn += yychar;
-	if(yyn < 0 || yyn >= YYLAST)
-		goto yydefault;
-	yyn = yyact[yyn];
-	if(yychk[yyn] == yychar) { /* valid shift */
-		yychar = -1;
-		yyval = yylval;
-		yystate = yyn;
-		if(yyerrflag > 0)
-			yyerrflag--;
-		goto yystack;
-	}
-
-yydefault:
-	/* default state action */
-	yyn = yydef[yystate];
-	if(yyn == -2) {
-		if(yychar < 0)
-			yychar = yylex1();
-
-		/* look through exception table */
-		for(yyxi=yyexca;; yyxi+=2)
-			if(yyxi[0] == -1 && yyxi[1] == yystate)
-				break;
-		for(yyxi += 2;; yyxi += 2) {
-			yyn = yyxi[0];
-			if(yyn < 0 || yyn == yychar)
-				break;
-		}
-		yyn = yyxi[1];
-		if(yyn < 0)
-			goto ret0;
-	}
-	if(yyn == 0) {
-		/* error ... attempt to resume parsing */
-		switch(yyerrflag) {
-		case 0:   /* brand new error */
-			yyerror("syntax error");
-			if(yydebug >= 1) {
-				printf("%s", yystatname(yystate));
-				printf("saw %s\n", yytokname(yychar));
-			}
-yyerrlab:
-			yynerrs++;
-
-		case 1:
-		case 2: /* incompletely recovered error ... try again */
-			yyerrflag = 3;
-
-			/* find a state where "error" is a legal shift action */
-			while(yyp >= yys) {
-				yyn = yypact[yyp->yys] + YYERRCODE;
-				if(yyn >= 0 && yyn < YYLAST) {
-					yystate = yyact[yyn];  /* simulate a shift of "error" */
-					if(yychk[yystate] == YYERRCODE)
-						goto yystack;
-				}
-
-				/* the current yyp has no shift onn "error", pop stack */
-				if(yydebug >= 2)
-					printf("error recovery pops state %d, uncovers %d\n",
-						yyp->yys, (yyp-1)->yys );
-				yyp--;
-			}
-			/* there is no state on the stack with an error shift ... abort */
-			goto ret1;
-
-		case 3:  /* no shift yet; clobber input char */
-			if(yydebug >= YYEOFCODE)
-				printf("error recovery discards %s\n", yytokname(yychar));
-			if(yychar == YYEOFCODE)
-				goto ret1;
-			yychar = -1;
-			goto yynewstate;   /* try again in the same state */
-		}
-	}
-
-	/* reduction by production yyn */
-	if(yydebug >= 2)
-		printf("reduce %d in:\n\t%s", yyn, yystatname(yystate));
-
-	yypt = yyp;
-	yyp -= yyr2[yyn];
-	yyval = (yyp+1)->yyv;
-	yym = yyn;
-
-	/* consult goto table to find next state */
-	yyn = yyr1[yyn];
-	yyg = yypgo[yyn];
-	yyj = yyg + yyp->yys + 1;
-
-	if(yyj >= YYLAST || yychk[yystate=yyact[yyj]] != -yyn)
-		yystate = yyact[yyg];
-	switch(yym) {
-
-case 3:
-/* #line	220	"/n/bopp/v5/dmg/f2c/gram.in" */
-{
-/* stat:   is the nonterminal for Fortran statements */
-
-		  lastwasbranch = NO; } break;
-case 5:
-/* #line	226	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ /* forbid further statement function definitions... */
-		  if (parstate == INDATA && laststfcn != thisstno)
-			parstate = INEXEC;
-		  thisstno++;
-		  if(yypt[-1].yyv.labval && (yypt[-1].yyv.labval->labelno==dorange))
-			enddo(yypt[-1].yyv.labval->labelno);
-		  if(lastwasbranch && thislabel==NULL)
-			warn("statement cannot be reached");
-		  lastwasbranch = thiswasbranch;
-		  thiswasbranch = NO;
-		  if(yypt[-1].yyv.labval)
-			{
-			if(yypt[-1].yyv.labval->labtype == LABFORMAT)
-				err("label already that of a format");
-			else
-				yypt[-1].yyv.labval->labtype = LABEXEC;
-			}
-		  freetemps();
-		} break;
-case 6:
-/* #line	246	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if (can_include)
-			doinclude( yypt[-0].yyv.charpval );
-		  else {
-			fprintf(diagfile, "Cannot open file %s\n", yypt[-0].yyv.charpval);
-			done(1);
-			}
-		} break;
-case 7:
-/* #line	254	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if (yypt[-2].yyv.labval)
-			lastwasbranch = NO;
-		  endcheck();
-		  endproc(); /* lastwasbranch = NO; -- set in endproc() */
-		} break;
-case 8:
-/* #line	260	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ unclassifiable();
-
-/* flline flushes the current line, ignoring the rest of the text there */
-
-		  flline(); } break;
-case 9:
-/* #line	266	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ flline();  needkwd = NO;  inioctl = NO;
-		  yyerrok; yyclearin; } break;
-case 10:
-/* #line	271	"/n/bopp/v5/dmg/f2c/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	299	"/n/bopp/v5/dmg/f2c/gram.in" */
-{startproc(yypt[-0].yyv.extval, CLMAIN); } break;
-case 12:
-/* #line	301	"/n/bopp/v5/dmg/f2c/gram.in" */
-{	warn("ignoring arguments to main program");
-			/* hashclear(); */
-			startproc(yypt[-1].yyv.extval, CLMAIN); } break;
-case 13:
-/* #line	305	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if(yypt[-0].yyv.extval) NO66("named BLOCKDATA");
-		  startproc(yypt[-0].yyv.extval, CLBLOCK); } break;
-case 14:
-/* #line	308	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ entrypt(CLPROC, TYSUBR, (ftnint) 0,  yypt[-1].yyv.extval, yypt[-0].yyv.chval); } break;
-case 15:
-/* #line	310	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, yypt[-1].yyv.extval, yypt[-0].yyv.chval); } break;
-case 16:
-/* #line	312	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ entrypt(CLPROC, yypt[-4].yyv.ival, varleng, yypt[-1].yyv.extval, yypt[-0].yyv.chval); } break;
-case 17:
-/* #line	314	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if(parstate==OUTSIDE || procclass==CLMAIN
-			|| procclass==CLBLOCK)
-				execerr("misplaced entry statement", CNULL);
-		  entrypt(CLENTRY, 0, (ftnint) 0, yypt[-1].yyv.extval, yypt[-0].yyv.chval);
-		} break;
-case 18:
-/* #line	322	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ newproc(); } break;
-case 19:
-/* #line	326	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.extval = newentry(yypt[-0].yyv.namval, 1); } break;
-case 20:
-/* #line	330	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.namval = mkname(token); } break;
-case 21:
-/* #line	333	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.extval = NULL; } break;
-case 29:
-/* #line	351	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = 0; } break;
-case 30:
-/* #line	353	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NO66(" () argument list");
-		  yyval.chval = 0; } break;
-case 31:
-/* #line	356	"/n/bopp/v5/dmg/f2c/gram.in" */
-{yyval.chval = yypt[-1].yyv.chval; } break;
-case 32:
-/* #line	360	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = (yypt[-0].yyv.namval ? mkchain((char *)yypt[-0].yyv.namval,CHNULL) : CHNULL ); } break;
-case 33:
-/* #line	362	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if(yypt[-0].yyv.namval) yypt[-2].yyv.chval = yyval.chval = mkchain((char *)yypt[-0].yyv.namval, yypt[-2].yyv.chval); } break;
-case 34:
-/* #line	366	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if(yypt[-0].yyv.namval->vstg!=STGUNKNOWN && yypt[-0].yyv.namval->vstg!=STGARG)
-			dclerr("name declared as argument after use", yypt[-0].yyv.namval);
-		  yypt[-0].yyv.namval->vstg = STGARG;
-		} break;
-case 35:
-/* #line	371	"/n/bopp/v5/dmg/f2c/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	387	"/n/bopp/v5/dmg/f2c/gram.in" */
-{
-		char *s;
-		s = copyn(toklen+1, token);
-		s[toklen] = '\0';
-		yyval.charpval = s;
-		} break;
-case 45:
-/* #line	403	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NO66("SAVE statement");
-		  saveall = YES; } break;
-case 46:
-/* #line	406	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NO66("SAVE statement"); } break;
-case 47:
-/* #line	408	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ fmtstmt(thislabel); setfmt(thislabel); } break;
-case 48:
-/* #line	410	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NO66("PARAMETER statement"); } break;
-case 49:
-/* #line	414	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ settype(yypt[-4].yyv.namval, yypt[-6].yyv.ival, yypt[-0].yyv.lval);
-		  if(ndim>0) setbound(yypt[-4].yyv.namval,ndim,dims);
-		} break;
-case 50:
-/* #line	418	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ settype(yypt[-2].yyv.namval, yypt[-4].yyv.ival, yypt[-0].yyv.lval);
-		  if(ndim>0) setbound(yypt[-2].yyv.namval,ndim,dims);
-		} break;
-case 51:
-/* #line	422	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if (new_dcl == 2) {
-			err("attempt to give DATA in type-declaration");
-			new_dcl = 1;
-			}
-		} break;
-case 52:
-/* #line	429	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ new_dcl = 2; } break;
-case 53:
-/* #line	432	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ varleng = yypt[-0].yyv.lval; } break;
-case 54:
-/* #line	436	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ varleng = (yypt[-0].yyv.ival<0 || ONEOF(yypt[-0].yyv.ival,M(TYLOGICAL)|M(TYLONG))
-				? 0 : typesize[yypt[-0].yyv.ival]);
-		  vartype = yypt[-0].yyv.ival; } break;
-case 55:
-/* #line	441	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.ival = TYLONG; } break;
-case 56:
-/* #line	442	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.ival = tyreal; } break;
-case 57:
-/* #line	443	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ ++complex_seen; yyval.ival = tycomplex; } break;
-case 58:
-/* #line	444	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.ival = TYDREAL; } break;
-case 59:
-/* #line	445	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); yyval.ival = TYDCOMPLEX; } break;
-case 60:
-/* #line	446	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.ival = TYLOGICAL; } break;
-case 61:
-/* #line	447	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NO66("CHARACTER statement"); yyval.ival = TYCHAR; } break;
-case 62:
-/* #line	448	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.ival = TYUNKNOWN; } break;
-case 63:
-/* #line	449	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.ival = TYUNKNOWN; } break;
-case 64:
-/* #line	450	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NOEXT("AUTOMATIC statement"); yyval.ival = - STGAUTO; } break;
-case 65:
-/* #line	451	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NOEXT("STATIC statement"); yyval.ival = - STGBSS; } break;
-case 66:
-/* #line	452	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.ival = TYINT1; } break;
-case 67:
-/* #line	456	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.lval = varleng; } break;
-case 68:
-/* #line	458	"/n/bopp/v5/dmg/f2c/gram.in" */
-{
-		expptr p;
-		p = yypt[-1].yyv.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 69:
-/* #line	484	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NO66("length specification *(*)"); yyval.lval = -1; } break;
-case 70:
-/* #line	488	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ incomm( yyval.extval = comblock("") , yypt[-0].yyv.namval ); } break;
-case 71:
-/* #line	490	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.extval = yypt[-1].yyv.extval;  incomm(yypt[-1].yyv.extval, yypt[-0].yyv.namval); } break;
-case 72:
-/* #line	492	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.extval = yypt[-2].yyv.extval;  incomm(yypt[-2].yyv.extval, yypt[-0].yyv.namval); } break;
-case 73:
-/* #line	494	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ incomm(yypt[-2].yyv.extval, yypt[-0].yyv.namval); } break;
-case 74:
-/* #line	498	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.extval = comblock(""); } break;
-case 75:
-/* #line	500	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.extval = comblock(token); } break;
-case 76:
-/* #line	504	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ setext(yypt[-0].yyv.namval); } break;
-case 77:
-/* #line	506	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ setext(yypt[-0].yyv.namval); } break;
-case 78:
-/* #line	510	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NO66("INTRINSIC statement"); setintr(yypt[-0].yyv.namval); } break;
-case 79:
-/* #line	512	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ setintr(yypt[-0].yyv.namval); } break;
-case 82:
-/* #line	520	"/n/bopp/v5/dmg/f2c/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 = yypt[-1].yyv.eqvval;
-		} break;
-case 83:
-/* #line	533	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.eqvval=ALLOC(Eqvchain);
-		  yyval.eqvval->eqvitem.eqvlhs = primchk(yypt[-0].yyv.expval);
-		} break;
-case 84:
-/* #line	537	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.eqvval=ALLOC(Eqvchain);
-		  yyval.eqvval->eqvitem.eqvlhs = primchk(yypt[-0].yyv.expval);
-		  yyval.eqvval->eqvnextp = yypt[-2].yyv.eqvval;
-		} break;
-case 87:
-/* #line	548	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if(parstate == OUTSIDE)
-			{
-			newproc();
-			startproc(ESNULL, CLMAIN);
-			}
-		  if(parstate < INDATA)
-			{
-			enddcl();
-			parstate = INDATA;
-			datagripe = 1;
-			}
-		} break;
-case 88:
-/* #line	563	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ ftnint junk;
-		  if(nextdata(&junk) != NULL)
-			err("too few initializers");
-		  frdata(yypt[-4].yyv.chval);
-		  frrpl();
-		} break;
-case 89:
-/* #line	571	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ frchain(&datastack); curdtp = 0; } break;
-case 90:
-/* #line	573	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ pop_datastack(); } break;
-case 91:
-/* #line	575	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ toomanyinit = NO; } break;
-case 94:
-/* #line	580	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ dataval(ENULL, yypt[-0].yyv.expval); } break;
-case 95:
-/* #line	582	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ dataval(yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break;
-case 97:
-/* #line	587	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if( yypt[-1].yyv.ival==OPMINUS && ISCONST(yypt[-0].yyv.expval) )
-			consnegop((Constp)yypt[-0].yyv.expval);
-		  yyval.expval = yypt[-0].yyv.expval;
-		} break;
-case 101:
-/* #line	599	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ int k;
-		  yypt[-0].yyv.namval->vsave = YES;
-		  k = yypt[-0].yyv.namval->vstg;
-		if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) )
-			dclerr("can only save static variables", yypt[-0].yyv.namval);
-		} break;
-case 105:
-/* #line	613	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if(yypt[-2].yyv.namval->vclass == CLUNKNOWN)
-			make_param((struct Paramblock *)yypt[-2].yyv.namval, yypt[-0].yyv.expval);
-		  else dclerr("cannot make into parameter", yypt[-2].yyv.namval);
-		} break;
-case 106:
-/* #line	620	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if(ndim>0) setbound(yypt[-1].yyv.namval, ndim, dims); } break;
-case 107:
-/* #line	624	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ Namep np;
-		  struct Primblock *pp = (struct Primblock *)yypt[-0].yyv.expval;
-		  int tt = yypt[-0].yyv.expval->tag;
-		  if (tt != TPRIM) {
-			if (tt == TCONST)
-				err("parameter in data statement");
-			else
-				erri("tag %d in data statement",tt);
-			yyval.chval = 0;
-			err_lineno = lineno;
-			break;
-			}
-		  np = pp -> namep;
-		  vardcl(np);
-		  if ((pp->fcharp || pp->lcharp)
-		   && (np->vtype != TYCHAR || np->vdim && !pp->argsp))
-			sserr(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) {
-			errstr(np->vstg == STGARG
-				? "Dummy argument \"%.60s\" in data statement."
-				: "Cannot give data to \"%.75s\"",
-				np->fvarname);
-			yyval.chval = 0;
-			err_lineno = lineno;
-			break;
-			}
-		  yyval.chval = mkchain((char *)yypt[-0].yyv.expval, CHNULL);
-		} break;
-case 108:
-/* #line	657	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ chainp p; struct Impldoblock *q;
-		pop_datastack();
-		q = ALLOC(Impldoblock);
-		q->tag = TIMPLDO;
-		(q->varnp = (Namep) (yypt[-1].yyv.chval->datap))->vimpldovar = 1;
-		p = yypt[-1].yyv.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( & (yypt[-1].yyv.chval) );
-		yyval.chval = mkchain((char *)q, CHNULL);
-		q->datalist = hookup(yypt[-3].yyv.chval, yyval.chval);
-		} break;
-case 109:
-/* #line	673	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if (!datastack)
-			curdtp = 0;
-		  datastack = mkchain((char *)curdtp, datastack);
-		  curdtp = yypt[-0].yyv.chval; curdtelt = 0;
-		  } break;
-case 110:
-/* #line	679	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = hookup(yypt[-2].yyv.chval, yypt[-0].yyv.chval); } break;
-case 111:
-/* #line	683	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ ndim = 0; } break;
-case 113:
-/* #line	687	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ ndim = 0; } break;
-case 116:
-/* #line	692	"/n/bopp/v5/dmg/f2c/gram.in" */
-{
-		  if(ndim == maxdim)
-			err("too many dimensions");
-		  else if(ndim < maxdim)
-			{ dims[ndim].lb = 0;
-			  dims[ndim].ub = yypt[-0].yyv.expval;
-			}
-		  ++ndim;
-		} break;
-case 117:
-/* #line	702	"/n/bopp/v5/dmg/f2c/gram.in" */
-{
-		  if(ndim == maxdim)
-			err("too many dimensions");
-		  else if(ndim < maxdim)
-			{ dims[ndim].lb = yypt[-2].yyv.expval;
-			  dims[ndim].ub = yypt[-0].yyv.expval;
-			}
-		  ++ndim;
-		} break;
-case 118:
-/* #line	714	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = 0; } break;
-case 120:
-/* #line	719	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ nstars = 1; labarray[0] = yypt[-0].yyv.labval; } break;
-case 121:
-/* #line	721	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if(nstars < maxlablist)  labarray[nstars++] = yypt[-0].yyv.labval; } break;
-case 122:
-/* #line	725	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.labval = execlab( convci(toklen, token) ); } break;
-case 123:
-/* #line	729	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NO66("IMPLICIT statement"); } break;
-case 126:
-/* #line	735	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if (vartype != TYUNKNOWN)
-			dclerr("-- expected letter range",NPNULL);
-		  setimpl(vartype, varleng, 'a', 'z'); } break;
-case 127:
-/* #line	740	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ needkwd = 1; } break;
-case 131:
-/* #line	749	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ setimpl(vartype, varleng, yypt[-0].yyv.ival, yypt[-0].yyv.ival); } break;
-case 132:
-/* #line	751	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ setimpl(vartype, varleng, yypt[-2].yyv.ival, yypt[-0].yyv.ival); } break;
-case 133:
-/* #line	755	"/n/bopp/v5/dmg/f2c/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 136:
-/* #line	769	"/n/bopp/v5/dmg/f2c/gram.in" */
-{
-		if(yypt[-2].yyv.namval->vclass == CLUNKNOWN)
-			{
-			yypt[-2].yyv.namval->vclass = CLNAMELIST;
-			yypt[-2].yyv.namval->vtype = TYINT;
-			yypt[-2].yyv.namval->vstg = STGBSS;
-			yypt[-2].yyv.namval->varxptr.namelist = yypt[-0].yyv.chval;
-			yypt[-2].yyv.namval->vardesc.varno = ++lastvarno;
-			}
-		else dclerr("cannot be a namelist name", yypt[-2].yyv.namval);
-		} break;
-case 137:
-/* #line	783	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = mkchain((char *)yypt[-0].yyv.namval, CHNULL); } break;
-case 138:
-/* #line	785	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = hookup(yypt[-2].yyv.chval, mkchain((char *)yypt[-0].yyv.namval, CHNULL)); } break;
-case 139:
-/* #line	789	"/n/bopp/v5/dmg/f2c/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 140:
-/* #line	811	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = 0; } break;
-case 141:
-/* #line	813	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = revchain(yypt[-0].yyv.chval); } break;
-case 142:
-/* #line	817	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = mkchain((char *)yypt[-0].yyv.expval, CHNULL); } break;
-case 143:
-/* #line	819	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = mkchain((char *)yypt[-0].yyv.expval, yypt[-2].yyv.chval); } break;
-case 145:
-/* #line	824	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = yypt[-1].yyv.expval; if (yyval.expval->tag == TPRIM)
-					paren_used(&yyval.expval->primblock); } break;
-case 149:
-/* #line	832	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = mkexpr(yypt[-1].yyv.ival, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break;
-case 150:
-/* #line	834	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = mkexpr(OPSTAR, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break;
-case 151:
-/* #line	836	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = mkexpr(OPSLASH, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break;
-case 152:
-/* #line	838	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = mkexpr(OPPOWER, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break;
-case 153:
-/* #line	840	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if(yypt[-1].yyv.ival == OPMINUS)
-			yyval.expval = mkexpr(OPNEG, yypt[-0].yyv.expval, ENULL);
-		  else {
-			yyval.expval = yypt[-0].yyv.expval;
-			if (yyval.expval->tag == TPRIM)
-				paren_used(&yyval.expval->primblock);
-			}
-		} break;
-case 154:
-/* #line	849	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = mkexpr(yypt[-1].yyv.ival, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break;
-case 155:
-/* #line	851	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NO66(".EQV. operator");
-		  yyval.expval = mkexpr(OPEQV, yypt[-2].yyv.expval,yypt[-0].yyv.expval); } break;
-case 156:
-/* #line	854	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NO66(".NEQV. operator");
-		  yyval.expval = mkexpr(OPNEQV, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break;
-case 157:
-/* #line	857	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = mkexpr(OPOR, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break;
-case 158:
-/* #line	859	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = mkexpr(OPAND, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break;
-case 159:
-/* #line	861	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = mkexpr(OPNOT, yypt[-0].yyv.expval, ENULL); } break;
-case 160:
-/* #line	863	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NO66("concatenation operator //");
-		  yyval.expval = mkexpr(OPCONCAT, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break;
-case 161:
-/* #line	867	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.ival = OPPLUS; } break;
-case 162:
-/* #line	868	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.ival = OPMINUS; } break;
-case 163:
-/* #line	871	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.ival = OPEQ; } break;
-case 164:
-/* #line	872	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.ival = OPGT; } break;
-case 165:
-/* #line	873	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.ival = OPLT; } break;
-case 166:
-/* #line	874	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.ival = OPGE; } break;
-case 167:
-/* #line	875	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.ival = OPLE; } break;
-case 168:
-/* #line	876	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.ival = OPNE; } break;
-case 169:
-/* #line	880	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = mkprim(yypt[-0].yyv.namval, LBNULL, CHNULL); } break;
-case 170:
-/* #line	882	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NO66("substring operator :");
-		  yyval.expval = mkprim(yypt[-1].yyv.namval, LBNULL, yypt[-0].yyv.chval); } break;
-case 171:
-/* #line	885	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = mkprim(yypt[-3].yyv.namval, mklist(yypt[-1].yyv.chval), CHNULL); } break;
-case 172:
-/* #line	887	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NO66("substring operator :");
-		  yyval.expval = mkprim(yypt[-4].yyv.namval, mklist(yypt[-2].yyv.chval), yypt[-0].yyv.chval); } break;
-case 173:
-/* #line	892	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = mkchain((char *)yypt[-3].yyv.expval, mkchain((char *)yypt[-1].yyv.expval,CHNULL)); } break;
-case 174:
-/* #line	896	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = 0; } break;
-case 176:
-/* #line	901	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if(yypt[-0].yyv.namval->vclass == CLPARAM)
-			yyval.expval = (expptr) cpexpr(
-				( (struct Paramblock *) (yypt[-0].yyv.namval) ) -> paramval);
-		} break;
-case 178:
-/* #line	908	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = mklogcon(1); } break;
-case 179:
-/* #line	909	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = mklogcon(0); } break;
-case 180:
-/* #line	910	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = mkstrcon(toklen, token); } break;
-case 181:
-/* #line	911	"/n/bopp/v5/dmg/f2c/gram.in" */
- { yyval.expval = mkintqcon(toklen, token); } break;
-case 182:
-/* #line	912	"/n/bopp/v5/dmg/f2c/gram.in" */
- { yyval.expval = mkrealcon(tyreal, token); } break;
-case 183:
-/* #line	913	"/n/bopp/v5/dmg/f2c/gram.in" */
- { yyval.expval = mkrealcon(TYDREAL, token); } break;
-case 185:
-/* #line	918	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = mkcxcon(yypt[-3].yyv.expval,yypt[-1].yyv.expval); } break;
-case 186:
-/* #line	922	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NOEXT("hex constant");
-		  yyval.expval = mkbitcon(4, toklen, token); } break;
-case 187:
-/* #line	925	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NOEXT("octal constant");
-		  yyval.expval = mkbitcon(3, toklen, token); } break;
-case 188:
-/* #line	928	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NOEXT("binary constant");
-		  yyval.expval = mkbitcon(1, toklen, token); } break;
-case 190:
-/* #line	934	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = yypt[-1].yyv.expval; } break;
-case 193:
-/* #line	940	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = mkexpr(yypt[-1].yyv.ival, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break;
-case 194:
-/* #line	942	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = mkexpr(OPSTAR, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break;
-case 195:
-/* #line	944	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = mkexpr(OPSLASH, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break;
-case 196:
-/* #line	946	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.expval = mkexpr(OPPOWER, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break;
-case 197:
-/* #line	948	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if(yypt[-1].yyv.ival == OPMINUS)
-			yyval.expval = mkexpr(OPNEG, yypt[-0].yyv.expval, ENULL);
-		  else yyval.expval = yypt[-0].yyv.expval;
-		} break;
-case 198:
-/* #line	953	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ NO66("concatenation operator //");
-		  yyval.expval = mkexpr(OPCONCAT, yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break;
-case 200:
-/* #line	958	"/n/bopp/v5/dmg/f2c/gram.in" */
-{
-		if(yypt[-2].yyv.labval->labdefined)
-			execerr("no backward DO loops", CNULL);
-		yypt[-2].yyv.labval->blklevel = blklevel+1;
-		exdo(yypt[-2].yyv.labval->labelno, NPNULL, yypt[-0].yyv.chval);
-		} break;
-case 201:
-/* #line	965	"/n/bopp/v5/dmg/f2c/gram.in" */
-{
-		exdo((int)(ctls - ctlstack - 2), NPNULL, yypt[-0].yyv.chval);
-		NOEXT("DO without label");
-		} break;
-case 202:
-/* #line	970	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ exenddo(NPNULL); } break;
-case 203:
-/* #line	972	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ exendif();  thiswasbranch = NO; } break;
-case 205:
-/* #line	974	"/n/bopp/v5/dmg/f2c/gram.in" */
-{westart(1);} break;
-case 206:
-/* #line	975	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ exelif(yypt[-2].yyv.expval); lastwasbranch = NO; } break;
-case 207:
-/* #line	977	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ exelse(); lastwasbranch = NO; } break;
-case 208:
-/* #line	979	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ exendif(); lastwasbranch = NO; } break;
-case 209:
-/* #line	983	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ exif(yypt[-1].yyv.expval); } break;
-case 210:
-/* #line	987	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = mkchain((char *)yypt[-2].yyv.namval, yypt[-0].yyv.chval); } break;
-case 212:
-/* #line	991	"/n/bopp/v5/dmg/f2c/gram.in" */
-{westart(0);} break;
-case 213:
-/* #line	992	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = mkchain(CNULL, (chainp)yypt[-1].yyv.expval); } break;
-case 214:
-/* #line	996	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ exequals((struct Primblock *)yypt[-2].yyv.expval, yypt[-0].yyv.expval); } break;
-case 215:
-/* #line	998	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ exassign(yypt[-0].yyv.namval, yypt[-2].yyv.labval); } break;
-case 218:
-/* #line	1002	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ inioctl = NO; } break;
-case 219:
-/* #line	1004	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ exarif(yypt[-6].yyv.expval, yypt[-4].yyv.labval, yypt[-2].yyv.labval, yypt[-0].yyv.labval);  thiswasbranch = YES; } break;
-case 220:
-/* #line	1006	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ excall(yypt[-0].yyv.namval, LBNULL, 0, labarray); } break;
-case 221:
-/* #line	1008	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ excall(yypt[-2].yyv.namval, LBNULL, 0, labarray); } break;
-case 222:
-/* #line	1010	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if(nstars < maxlablist)
-			excall(yypt[-3].yyv.namval, mklist(revchain(yypt[-1].yyv.chval)), nstars, labarray);
-		  else
-			many("alternate returns", 'l', maxlablist);
-		} break;
-case 223:
-/* #line	1016	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ exreturn(yypt[-0].yyv.expval);  thiswasbranch = YES; } break;
-case 224:
-/* #line	1018	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ exstop(yypt[-2].yyv.ival, yypt[-0].yyv.expval);  thiswasbranch = yypt[-2].yyv.ival; } break;
-case 225:
-/* #line	1022	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.labval = mklabel( convci(toklen, token) ); } break;
-case 226:
-/* #line	1026	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if(parstate == OUTSIDE)
-			{
-			newproc();
-			startproc(ESNULL, CLMAIN);
-			}
-		} break;
-case 227:
-/* #line	1035	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ exgoto(yypt[-0].yyv.labval);  thiswasbranch = YES; } break;
-case 228:
-/* #line	1037	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ exasgoto(yypt[-0].yyv.namval);  thiswasbranch = YES; } break;
-case 229:
-/* #line	1039	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ exasgoto(yypt[-4].yyv.namval);  thiswasbranch = YES; } break;
-case 230:
-/* #line	1041	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if(nstars < maxlablist)
-			putcmgo(putx(fixtype(yypt[-0].yyv.expval)), nstars, labarray);
-		  else
-			many("labels in computed GOTO list", 'l', maxlablist);
-		} break;
-case 233:
-/* #line	1053	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ nstars = 0; yyval.namval = yypt[-0].yyv.namval; } break;
-case 234:
-/* #line	1057	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = yypt[-0].yyv.expval ? mkchain((char *)yypt[-0].yyv.expval,CHNULL) : CHNULL; } break;
-case 235:
-/* #line	1059	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = yypt[-0].yyv.expval ? mkchain((char *)yypt[-0].yyv.expval, yypt[-2].yyv.chval) : yypt[-2].yyv.chval; } break;
-case 237:
-/* #line	1064	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ if(nstars < maxlablist) labarray[nstars++] = yypt[-0].yyv.labval; yyval.expval = 0; } break;
-case 238:
-/* #line	1068	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.ival = 0; } break;
-case 239:
-/* #line	1070	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.ival = 2; } break;
-case 240:
-/* #line	1074	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = mkchain((char *)yypt[-0].yyv.expval, CHNULL); } break;
-case 241:
-/* #line	1076	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = hookup(yypt[-2].yyv.chval, mkchain((char *)yypt[-0].yyv.expval,CHNULL) ); } break;
-case 242:
-/* #line	1080	"/n/bopp/v5/dmg/f2c/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 243:
-/* #line	1093	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ intonly = YES; } break;
-case 244:
-/* #line	1097	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ intonly = NO; } break;
-case 245:
-/* #line	1102	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ endio(); } break;
-case 247:
-/* #line	1107	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ ioclause(IOSUNIT, yypt[-0].yyv.expval); endioctl(); } break;
-case 248:
-/* #line	1109	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ ioclause(IOSUNIT, ENULL); endioctl(); } break;
-case 249:
-/* #line	1111	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ ioclause(IOSUNIT, IOSTDERR); endioctl(); } break;
-case 251:
-/* #line	1114	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ doio(CHNULL); } break;
-case 252:
-/* #line	1116	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ doio(CHNULL); } break;
-case 253:
-/* #line	1118	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ doio(revchain(yypt[-0].yyv.chval)); } break;
-case 254:
-/* #line	1120	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ doio(revchain(yypt[-0].yyv.chval)); } break;
-case 255:
-/* #line	1122	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ doio(revchain(yypt[-0].yyv.chval)); } break;
-case 256:
-/* #line	1124	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ doio(CHNULL); } break;
-case 257:
-/* #line	1126	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ doio(revchain(yypt[-0].yyv.chval)); } break;
-case 258:
-/* #line	1128	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ doio(revchain(yypt[-0].yyv.chval)); } break;
-case 259:
-/* #line	1130	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ doio(CHNULL); } break;
-case 260:
-/* #line	1132	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ doio(revchain(yypt[-0].yyv.chval)); } break;
-case 262:
-/* #line	1139	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ iostmt = IOBACKSPACE; } break;
-case 263:
-/* #line	1141	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ iostmt = IOREWIND; } break;
-case 264:
-/* #line	1143	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ iostmt = IOENDFILE; } break;
-case 266:
-/* #line	1150	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ iostmt = IOINQUIRE; } break;
-case 267:
-/* #line	1152	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ iostmt = IOOPEN; } break;
-case 268:
-/* #line	1154	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ iostmt = IOCLOSE; } break;
-case 269:
-/* #line	1158	"/n/bopp/v5/dmg/f2c/gram.in" */
-{
-		ioclause(IOSUNIT, ENULL);
-		ioclause(IOSFMT, yypt[-0].yyv.expval);
-		endioctl();
-		} break;
-case 270:
-/* #line	1164	"/n/bopp/v5/dmg/f2c/gram.in" */
-{
-		ioclause(IOSUNIT, ENULL);
-		ioclause(IOSFMT, ENULL);
-		endioctl();
-		} break;
-case 271:
-/* #line	1172	"/n/bopp/v5/dmg/f2c/gram.in" */
-{
-		  ioclause(IOSUNIT, yypt[-1].yyv.expval);
-		  endioctl();
-		} break;
-case 272:
-/* #line	1177	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ endioctl(); } break;
-case 275:
-/* #line	1185	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ ioclause(IOSPOSITIONAL, yypt[-0].yyv.expval); } break;
-case 276:
-/* #line	1187	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ ioclause(IOSPOSITIONAL, ENULL); } break;
-case 277:
-/* #line	1189	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ ioclause(IOSPOSITIONAL, IOSTDERR); } break;
-case 278:
-/* #line	1191	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ ioclause(yypt[-1].yyv.ival, yypt[-0].yyv.expval); } break;
-case 279:
-/* #line	1193	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ ioclause(yypt[-1].yyv.ival, ENULL); } break;
-case 280:
-/* #line	1195	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ ioclause(yypt[-1].yyv.ival, IOSTDERR); } break;
-case 281:
-/* #line	1199	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.ival = iocname(); } break;
-case 282:
-/* #line	1203	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ iostmt = IOREAD; } break;
-case 283:
-/* #line	1207	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ iostmt = IOWRITE; } break;
-case 284:
-/* #line	1211	"/n/bopp/v5/dmg/f2c/gram.in" */
-{
-		iostmt = IOWRITE;
-		ioclause(IOSUNIT, ENULL);
-		ioclause(IOSFMT, yypt[-1].yyv.expval);
-		endioctl();
-		} break;
-case 285:
-/* #line	1218	"/n/bopp/v5/dmg/f2c/gram.in" */
-{
-		iostmt = IOWRITE;
-		ioclause(IOSUNIT, ENULL);
-		ioclause(IOSFMT, ENULL);
-		endioctl();
-		} break;
-case 286:
-/* #line	1227	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = mkchain((char *)yypt[-0].yyv.tagval, CHNULL); } break;
-case 287:
-/* #line	1229	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = mkchain((char *)yypt[-0].yyv.tagval, yypt[-2].yyv.chval); } break;
-case 288:
-/* #line	1233	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.tagval = (tagptr) yypt[-0].yyv.expval; } break;
-case 289:
-/* #line	1235	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.tagval = (tagptr) mkiodo(yypt[-1].yyv.chval,revchain(yypt[-3].yyv.chval)); } break;
-case 290:
-/* #line	1239	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = mkchain((char *)yypt[-0].yyv.expval, CHNULL); } break;
-case 291:
-/* #line	1241	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = mkchain((char *)yypt[-0].yyv.tagval, CHNULL); } break;
-case 293:
-/* #line	1246	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = mkchain((char *)yypt[-0].yyv.expval, mkchain((char *)yypt[-2].yyv.expval, CHNULL) ); } break;
-case 294:
-/* #line	1248	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = mkchain((char *)yypt[-0].yyv.tagval, mkchain((char *)yypt[-2].yyv.expval, CHNULL) ); } break;
-case 295:
-/* #line	1250	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = mkchain((char *)yypt[-0].yyv.expval, mkchain((char *)yypt[-2].yyv.tagval, CHNULL) ); } break;
-case 296:
-/* #line	1252	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = mkchain((char *)yypt[-0].yyv.tagval, mkchain((char *)yypt[-2].yyv.tagval, CHNULL) ); } break;
-case 297:
-/* #line	1254	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = mkchain((char *)yypt[-0].yyv.expval, yypt[-2].yyv.chval); } break;
-case 298:
-/* #line	1256	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.chval = mkchain((char *)yypt[-0].yyv.tagval, yypt[-2].yyv.chval); } break;
-case 299:
-/* #line	1260	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.tagval = (tagptr) yypt[-0].yyv.expval; } break;
-case 300:
-/* #line	1262	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.tagval = (tagptr) yypt[-1].yyv.expval; } break;
-case 301:
-/* #line	1264	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.tagval = (tagptr) mkiodo(yypt[-1].yyv.chval, mkchain((char *)yypt[-3].yyv.expval, CHNULL) ); } break;
-case 302:
-/* #line	1266	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.tagval = (tagptr) mkiodo(yypt[-1].yyv.chval, mkchain((char *)yypt[-3].yyv.tagval, CHNULL) ); } break;
-case 303:
-/* #line	1268	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ yyval.tagval = (tagptr) mkiodo(yypt[-1].yyv.chval, revchain(yypt[-3].yyv.chval)); } break;
-case 304:
-/* #line	1272	"/n/bopp/v5/dmg/f2c/gram.in" */
-{ startioctl(); } break;
-	}
-	goto yystack;  /* stack new state and value */
-}
diff --git a/contrib/tools/f2c/src/init.c b/contrib/tools/f2c/src/init.c
deleted file mode 100644
index 752c99a893d..00000000000
--- a/contrib/tools/f2c/src/init.c
+++ /dev/null
@@ -1,526 +0,0 @@
-/****************************************************************
-Copyright 1990, 1992-1996, 2000-2001 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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;
-int maxtoklen, toklen;
-long err_lineno;
-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;
-long 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];
-unsigned char hextoi_tab[Table_size], Letters[Table_size];
-char *ei_first, *ei_next, *ei_last;
-char *wh_first, *wh_next, *wh_last;
-#ifdef TYQUAD
-unsigned long ff;
-#endif
-
-#define ALLOCN(n,x)	(struct x *) ckalloc((n)*sizeof(struct x))
-
- void
-fileinit(Void)
-{
-	register char *s;
-	register int i, j;
-
-	lastiolabno = 100000;
-	lastlabno = 0;
-	lastvarno = 0;
-	nliterals = 0;
-	nerr = 0;
-
-	infile = stdin;
-
-	maxtoklen = 502;
-	token = (char *)ckalloc(maxtoklen+2);
-	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;
-#ifdef TYQUAD
-	/* Older C compilers may not understand UL suffixes. */
-	/* It would be much simpler to use 0xffffffffUL some places... */
-	ff = 0xffff;
-	ff = (ff << 16) | ff;
-#endif
-	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 ();
-}
-
- void
-hashclear(Void)	/* 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;
-		}
-	}
-
- extern struct memblock *curmemblock, *firstmemblock;
- extern char *mem_first, *mem_next, *mem_last, *mem0_last;
-
- void
-procinit(Void)
-{
-	register struct Labelblock *lp;
-	struct Chain *cp;
-	int i;
-	struct memblock;
-
-	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 */
-}
-
-
-
- void
-#ifdef KR_headers
-setimpl(type, length, c1, c2)
-	int type;
-	ftnint length;
-	int c1;
-	int c2;
-#else
-setimpl(int type, ftnint length, int c1, int c2)
-#endif
-{
-	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/contrib/tools/f2c/src/intr.c b/contrib/tools/f2c/src/intr.c
deleted file mode 100644
index 9da67573204..00000000000
--- a/contrib/tools/f2c/src/intr.c
+++ /dev/null
@@ -1,1087 +0,0 @@
-/****************************************************************
-Copyright 1990, 1992, 1994-6, 1998 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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"
-
-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 */
-	char extflag;	/* for -cd, -i90 */
-	};
-
-/* 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 }},
-{"dreal",	{ INTRCONV, TYDREAL, 0, 0, 0, 1 }},
-{"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 }},
-
-{"cdabs", 	{ INTRSPEC, TYDREAL,	13, 1, 0, 1 }},
-{"cdsqrt", 	{ INTRSPEC, TYDCOMPLEX, 38, 1, 0, 1 }},
-{"cdexp", 	{ INTRSPEC, TYDCOMPLEX, 42, 1, 0, 1 }},
-{"cdlog", 	{ INTRSPEC, TYDCOMPLEX, 46, 1, 0, 1 }},
-{"cdsin", 	{ INTRSPEC, TYDCOMPLEX, 52, 1, 0, 1 }},
-{"cdcos", 	{ INTRSPEC, TYDCOMPLEX, 56, 1, 0, 1 }},
-
-{"iand",		{ INTRBOOL, TYUNKNOWN, OPBITAND, 0, 0, 2 }},
-{"ior",		{ INTRBOOL, TYUNKNOWN, OPBITOR,  0, 0, 2 }},
-{"ieor",		{ INTRBOOL, TYUNKNOWN, OPBITXOR, 0, 0, 2 }},
-
-{"btest",	{ INTRBGEN, TYLOGICAL, OPBITTEST,0, 0, 2 }},
-{"ibclr",	{ INTRBGEN, TYUNKNOWN, OPBITCLR, 0, 0, 2 }},
-{"ibset",	{ INTRBGEN, TYUNKNOWN, OPBITSET, 0, 0, 2 }},
-{"ibits",	{ INTRBGEN, TYUNKNOWN, OPBITBITS,0, 0, 2 }},
-{"ishft",	{ INTRBGEN, TYUNKNOWN, OPBITSH,  0, 0, 2 }},
-{"ishftc",	{ INTRBGEN, TYUNKNOWN, OPBITSHC, 0, 0, 2 }},
-
-{"" }};
-
-
-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(Void)	/* 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");
-			    }
-		}
-	}
-
- static expptr
-#ifdef KR_headers
-foldminmax(ismin, argsp) int ismin; struct Listblock *argsp;
-#else
-foldminmax(int ismin, struct Listblock *argsp)
-#endif
-{
-#ifndef NO_LONG_LONG
-	Llong cq, cq1;
-#endif
-	Constp h;
-	double cd, cd1;
-	ftnint ci;
-	int mtype;
-	struct Chain *cp, *cpx;
-
-	mtype = argsp->vtype;
-	cp = cpx = argsp->listp;
-	h = &((expptr)cp->datap)->constblock;
-#ifndef NO_LONG_LONG
-	if (mtype == TYQUAD) {
-		cq = h->vtype == TYQUAD ? h->Const.cq : h->Const.ci;
-		while(cp = cp->nextp) {
-			h = &((expptr)cp->datap)->constblock;
-			cq1 = h->vtype == TYQUAD ? h->Const.cq : h->Const.ci;
-			if (ismin) {
-				if (cq > cq1) {
-					cq = cq1;
-					cpx = cp;
-					}
-				}
-			else {
-				if (cq < cq1) {
-					cq = cq1;
-					cpx = cp;
-					}
-				}
-			}
-		}
-	else
-#endif
-	if (ISINT(mtype)) {
-		ci = h->Const.ci;
-		if (ismin)
-			while(cp = cp->nextp) {
-				h = &((expptr)cp->datap)->constblock;
-				if (ci > h->Const.ci) {
-					ci = h->Const.ci;
-					cpx = cp;
-					}
-				}
-		else
-			while(cp = cp->nextp) {
-				h = &((expptr)cp->datap)->constblock;
-				if (ci < h->Const.ci) {
-					ci = h->Const.ci;
-					cpx = cp;
-					}
-				}
-		}
-	else {
-		if (ISREAL(h->vtype))
-			cd = h->vstg ? atof(h->Const.cds[0]) : h->Const.cd[0];
-#ifndef NO_LONG_LONG
-		else if (h->vtype == TYQUAD)
-			cd = h->Const.cq;
-#endif
-		else
-			cd = h->Const.ci;
-		while(cp = cp->nextp) {
-			h = &((expptr)cp->datap)->constblock;
-			if (ISREAL(h->vtype))
-				cd1 = h->vstg	? atof(h->Const.cds[0])
-						: h->Const.cd[0];
-#ifndef NO_LONG_LONG
-			else if (h->vtype == TYQUAD)
-				cd1 = h->Const.cq;
-#endif
-			else
-				cd1 = h->Const.ci;
-			if (ismin) {
-				if (cd > cd1) {
-					cd = cd1;
-					cpx = cp;
-					}
-				}
-			else {
-				if (cd < cd1) {
-					cd = cd1;
-					cpx = cp;
-					}
-				}
-			}
-		}
-	h = &((expptr)cpx->datap)->constblock;
-	cpx->datap = 0;
-	frexpr((tagptr)argsp);
-	if (h->vtype != mtype)
-		return mkconv(mtype, (expptr)h);
-	return (expptr)h;
-	}
-
-
- expptr
-#ifdef KR_headers
-intrcall(np, argsp, nargs)
-	Namep np;
-	struct Listblock *argsp;
-	int nargs;
-#else
-intrcall(Namep np, struct Listblock *argsp, int nargs)
-#endif
-{
-	int i, rettype;
-	ftnint k;
-	Addrp ap;
-	register struct Specblock *sp;
-	register struct Chain *cp;
-	expptr q, ep;
-	int constargs, mtype, op;
-	int f1field, f2field, f3field;
-	char *s;
-	static char	bit_bits[] =	"?bit_bits",
-			bit_shift[] =	"?bit_shift",
-			bit_cshift[] = 	"?bit_cshift";
-	static char *bitop[3] = { bit_bits, bit_shift, bit_cshift };
-	static int t_pref[2] = { 'l', 'q' };
-
-	packed.ijunk = np->vardesc.varno;
-	f1field = packed.bits.f1;
-	f2field = packed.bits.f2;
-	f3field = packed.bits.f3;
-	if(nargs == 0)
-		goto badnargs;
-
-	mtype = 0;
-	constargs = 1;
-	for(cp = argsp->listp ; cp ; cp = cp->nextp)
-	{
-		ep = (expptr)cp->datap;
-		if (!ISCONST(ep))
-			constargs = 0;
-		else if( ep->headblock.vtype==TYSHORT )
-			cp->datap = (char *) mkconv(tyint, ep);
-		mtype = maxtype(mtype, ep->headblock.vtype);
-	}
-
-	switch(f1field)
-	{
-	case INTRBGEN:
-		op = f3field;
-		if( ! ONEOF(mtype, MSKINT) )
-			goto badtype;
-		if (op < OPBITBITS) {
-			if(nargs != 2)
-				goto badnargs;
-			if (op != OPBITTEST) {
-#ifdef TYQUAD
-				if (mtype == TYQUAD)
-					op += 2;
-#endif
-				goto intrbool2;
-				}
-			q = mkexpr(op, (expptr)argsp->listp->datap,
-			    		(expptr)argsp->listp->nextp->datap);
-			q->exprblock.vtype = TYLOGICAL;
-			goto intrbool2a;
-			}
-		if (nargs != 2 && (nargs != 3 || op == OPBITSH))
-			goto badnargs;
-		cp = argsp->listp;
-		ep = (expptr)cp->datap;
-		if (ep->headblock.vtype < TYLONG)
-			cp->datap = (char *)mkconv(TYLONG, ep);
-		while(cp->nextp) {
-			cp = cp->nextp;
-			ep = (expptr)cp->datap;
-			if (ep->headblock.vtype != TYLONG)
-				cp->datap = (char *)mkconv(TYLONG, ep);
-			}
-		if (op == OPBITSH) {
-			ep = (expptr)argsp->listp->nextp->datap;
-			if (ISCONST(ep)) {
-				if ((k = ep->constblock.Const.ci) < 0) {
-					q = (expptr)argsp->listp->datap;
-					if (ISCONST(q)) {
-						ep->constblock.Const.ci = -k;
-						op = OPRSHIFT;
-						goto intrbool2;
-						}
-					}
-				else {
-					op = OPLSHIFT;
-					goto intrbool2;
-					}
-				}
-			}
-		else if (nargs == 2) {
-			if (op == OPBITBITS)
-				goto badnargs;
-			cp->nextp = mkchain((char*)ICON(-1), 0);
-			}
-		ep = (expptr)argsp->listp->datap;
-		i = ep->headblock.vtype;
-		s = bitop[op - OPBITBITS];
-		*s = t_pref[i - TYLONG];
-		ap = builtin(i, s, 1);
-		return fixexpr((Exprp)
-				mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );
-
-	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;
- intrbool2:
-			q = mkexpr(op, (expptr)argsp->listp->datap,
-			    		(expptr)argsp->listp->nextp->datap);
-		}
- intrbool2a:
-		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 (qr->headblock.vtype == TYDREAL
-			 || qi->headblock.vtype == TYDREAL)
-				rettype = TYDCOMPLEX;
-			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;
-		if (constargs)
-			q = foldminmax(f1field==INTRMIN, argsp);
-		else
-			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() );
-}
-
-
-
- int
-#ifdef KR_headers
-intrfunct(s)
-	char *s;
-#else
-intrfunct(char *s)
-#endif
-{
-	register struct Intrblock *p;
-	int i;
-	extern int intr_omit;
-
-	for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p)
-	{
-		if( !strcmp(s, p->intrfname) )
-		{
-			if (i = p->intrval.extflag) {
-				if (i & intr_omit)
-					return 0;
-				if (noextflag)
-					errext(s);
-				}
-			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
-#ifdef KR_headers
-intraddr(np)
-	Namep np;
-#else
-intraddr(Namep np)
-#endif
-{
-	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:
-	case INTRBGEN:
-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
-#ifdef KR_headers
-cast_args(maxtype, args)
-	int maxtype;
-	chainp args;
-#else
-cast_args(int maxtype, chainp args)
-#endif
-{
-    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
-#ifdef KR_headers
-Inline(fno, type, args)
-	int fno;
-	int type;
-	struct Chain *args;
-#else
-Inline(int fno, int type, struct Chain *args)
-#endif
-{
-	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 mkconv(tyioint, q);
-
-	case 14:	/* half-integer mod */
-	case 15:	/* mod */
-		return mkexpr(OPMOD, (expptr) args->datap,
-		    		(expptr) args->nextp->datap);
-	}
-	return(NULL);
-}
diff --git a/contrib/tools/f2c/src/io.c b/contrib/tools/f2c/src/io.c
deleted file mode 100644
index b35a0f627a5..00000000000
--- a/contrib/tools/f2c/src/io.c
+++ /dev/null
@@ -1,1509 +0,0 @@
-/****************************************************************
-Copyright 1990, 1991, 1993, 1994, 1996, 2000 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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 byterev, inqmask;
-
-static void dofclose Argdcl((void));
-static void dofinquire Argdcl((void));
-static void dofmove Argdcl((char*));
-static void dofopen Argdcl((void));
-static void doiolist Argdcl((chainp));
-static void ioset Argdcl((int, int, expptr));
-static void ioseta Argdcl((int, Addrp));
-static void iosetc Argdcl((int, expptr));
-static void iosetip Argdcl((int, int));
-static void iosetlc Argdcl((int, int, int));
-static void putio Argdcl((expptr, expptr));
-static void putiocall Argdcl((expptr));
-
-iob_data *iob_list;
-Addrp io_structs[9];
-
-LOCAL char ioroutine[12];
-
-LOCAL long ioendlab;
-LOCAL long ioerrlab;
-LOCAL int endbit;
-LOCAL int errbit;
-LOCAL long jumplab;
-LOCAL long skiplab;
-LOCAL int ioformatted;
-LOCAL int statstruct = NO;
-LOCAL struct Labelblock *skiplabel;
-Addrp ioblkp;
-
-#define UNFORMATTED 0
-#define FORMATTED 1
-#define LISTDIRECTED 2
-#define NAMEDIRECTED 3
-
-#define V(z)	ioc[z].iocval
-
-#define IOALL 07777
-
-LOCAL struct Ioclist
-{
-	char *iocname;
-	int iotype;
-	expptr iocval;
-}
-ioc[ ] =
-{
-	{ "", 0 },
-	{ "unit", IOALL },
-	{ "fmt", M(IOREAD) | M(IOWRITE) },
-	{ "err", IOALL },
-	{ "end", M(IOREAD) },
-	{ "iostat", IOALL },
-	{ "rec", M(IOREAD) | M(IOWRITE) },
-	{ "recl", M(IOOPEN) | M(IOINQUIRE) },
-	{ "file", M(IOOPEN) | M(IOINQUIRE) },
-	{ "status", M(IOOPEN) | M(IOCLOSE) },
-	{ "access", M(IOOPEN) | M(IOINQUIRE) },
-	{ "form", M(IOOPEN) | M(IOINQUIRE) },
-	{ "blank", M(IOOPEN) | M(IOINQUIRE) },
-	{ "exist", M(IOINQUIRE) },
-	{ "opened", M(IOINQUIRE) },
-	{ "number", M(IOINQUIRE) },
-	{ "named", M(IOINQUIRE) },
-	{ "name", M(IOINQUIRE) },
-	{ "sequential", M(IOINQUIRE) },
-	{ "direct", M(IOINQUIRE) },
-	{ "formatted", M(IOINQUIRE) },
-	{ "unformatted", M(IOINQUIRE) },
-	{ "nextrec", M(IOINQUIRE) },
-	{ "nml", M(IOREAD) | M(IOWRITE) }
-};
-
-#define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1)
-
-/* #define IOSUNIT 1 */
-/* #define IOSFMT 2 */
-#define IOSERR 3
-#define IOSEND 4
-#define IOSIOSTAT 5
-#define IOSREC 6
-#define IOSRECL 7
-#define IOSFILE 8
-#define IOSSTATUS 9
-#define IOSACCESS 10
-#define IOSFORM 11
-#define IOSBLANK 12
-#define IOSEXISTS 13
-#define IOSOPENED 14
-#define IOSNUMBER 15
-#define IOSNAMED 16
-#define IOSNAME 17
-#define IOSSEQUENTIAL 18
-#define IOSDIRECT 19
-#define IOSFORMATTED 20
-#define IOSUNFORMATTED 21
-#define IOSNEXTREC 22
-#define IOSNML 23
-
-#define IOSTP V(IOSIOSTAT)
-
-
-/* offsets in generated structures */
-
-#define SZFLAG SZIOINT
-
-/* offsets for external READ and WRITE statements */
-
-#define XERR 0
-#define XUNIT	SZFLAG
-#define XEND	SZFLAG + SZIOINT
-#define XFMT	2*SZFLAG + SZIOINT
-#define XREC	2*SZFLAG + SZIOINT + SZADDR
-
-/* offsets for internal READ and WRITE statements */
-
-#define XIUNIT	SZFLAG
-#define XIEND	SZFLAG + SZADDR
-#define XIFMT	2*SZFLAG + SZADDR
-#define XIRLEN	2*SZFLAG + 2*SZADDR
-#define XIRNUM	2*SZFLAG + 2*SZADDR + SZIOINT
-#define XIREC	2*SZFLAG + 2*SZADDR + 2*SZIOINT
-
-/* offsets for OPEN statements */
-
-#define XFNAME	SZFLAG + SZIOINT
-#define XFNAMELEN	SZFLAG + SZIOINT + SZADDR
-#define XSTATUS	SZFLAG + 2*SZIOINT + SZADDR
-#define XACCESS	SZFLAG + 2*SZIOINT + 2*SZADDR
-#define XFORMATTED	SZFLAG + 2*SZIOINT + 3*SZADDR
-#define XRECLEN	SZFLAG + 2*SZIOINT + 4*SZADDR
-#define XBLANK	SZFLAG + 3*SZIOINT + 4*SZADDR
-
-/* offset for CLOSE statement */
-
-#define XCLSTATUS	SZFLAG + SZIOINT
-
-/* offsets for INQUIRE statement */
-
-#define XFILE	SZFLAG + SZIOINT
-#define XFILELEN	SZFLAG + SZIOINT + SZADDR
-#define XEXISTS	SZFLAG + 2*SZIOINT + SZADDR
-#define XOPEN	SZFLAG + 2*SZIOINT + 2*SZADDR
-#define XNUMBER	SZFLAG + 2*SZIOINT + 3*SZADDR
-#define XNAMED	SZFLAG + 2*SZIOINT + 4*SZADDR
-#define XNAME	SZFLAG + 2*SZIOINT + 5*SZADDR
-#define XNAMELEN	SZFLAG + 2*SZIOINT + 6*SZADDR
-#define XQACCESS	SZFLAG + 3*SZIOINT + 6*SZADDR
-#define XQACCLEN	SZFLAG + 3*SZIOINT + 7*SZADDR
-#define XSEQ	SZFLAG + 4*SZIOINT + 7*SZADDR
-#define XSEQLEN	SZFLAG + 4*SZIOINT + 8*SZADDR
-#define XDIRECT	SZFLAG + 5*SZIOINT + 8*SZADDR
-#define XDIRLEN	SZFLAG + 5*SZIOINT + 9*SZADDR
-#define XFORM	SZFLAG + 6*SZIOINT + 9*SZADDR
-#define XFORMLEN	SZFLAG + 6*SZIOINT + 10*SZADDR
-#define XFMTED	SZFLAG + 7*SZIOINT + 10*SZADDR
-#define XFMTEDLEN	SZFLAG + 7*SZIOINT + 11*SZADDR
-#define XUNFMT	SZFLAG + 8*SZIOINT + 11*SZADDR
-#define XUNFMTLEN	SZFLAG + 8*SZIOINT + 12*SZADDR
-#define XQRECL	SZFLAG + 9*SZIOINT + 12*SZADDR
-#define XNEXTREC	SZFLAG + 9*SZIOINT + 13*SZADDR
-#define XQBLANK	SZFLAG + 9*SZIOINT + 14*SZADDR
-#define XQBLANKLEN	SZFLAG + 9*SZIOINT + 15*SZADDR
-
-LOCAL char *cilist_names[] = {
-	"cilist",
-	"cierr",
-	"ciunit",
-	"ciend",
-	"cifmt",
-	"cirec"
-	};
-LOCAL char *icilist_names[] = {
-	"icilist",
-	"icierr",
-	"iciunit",
-	"iciend",
-	"icifmt",
-	"icirlen",
-	"icirnum"
-	};
-LOCAL char *olist_names[] = {
-	"olist",
-	"oerr",
-	"ounit",
-	"ofnm",
-	"ofnmlen",
-	"osta",
-	"oacc",
-	"ofm",
-	"orl",
-	"oblnk"
-	};
-LOCAL char *cllist_names[] = {
-	"cllist",
-	"cerr",
-	"cunit",
-	"csta"
-	};
-LOCAL char *alist_names[] = {
-	"alist",
-	"aerr",
-	"aunit"
-	};
-LOCAL char *inlist_names[] = {
-	"inlist",
-	"inerr",
-	"inunit",
-	"infile",
-	"infilen",
-	"inex",
-	"inopen",
-	"innum",
-	"innamed",
-	"inname",
-	"innamlen",
-	"inacc",
-	"inacclen",
-	"inseq",
-	"inseqlen",
-	"indir",
-	"indirlen",
-	"infmt",
-	"infmtlen",
-	"inform",
-	"informlen",
-	"inunf",
-	"inunflen",
-	"inrecl",
-	"innrec",
-	"inblank",
-	"inblanklen"
-	};
-
-LOCAL char **io_fields;
-
-#define zork(n,t) n, sizeof(n)/sizeof(char *) - 1, t
-
-LOCAL io_setup io_stuff[] = {
-	{zork(cilist_names, TYCILIST)},	/* external read/write */
-	{zork(inlist_names, TYINLIST)},	/* inquire */
-	{zork(olist_names,  TYOLIST)},	/* open */
-	{zork(cllist_names, TYCLLIST)},	/* close */
-	{zork(alist_names,  TYALIST)},	/* rewind */
-	{zork(alist_names,  TYALIST)},	/* backspace */
-	{zork(alist_names,  TYALIST)},	/* endfile */
-	{zork(icilist_names,TYICILIST)},	/* internal read */
-	{zork(icilist_names,TYICILIST)}	/* internal write */
-	};
-
-#undef zork
-
- int
-#ifdef KR_headers
-fmtstmt(lp)
-	register struct Labelblock *lp;
-#else
-fmtstmt(register struct Labelblock *lp)
-#endif
-{
-	if(lp == NULL)
-	{
-		execerr("unlabeled format statement" , CNULL);
-		return(-1);
-	}
-	if(lp->labtype == LABUNKNOWN)
-	{
-		lp->labtype = LABFORMAT;
-		lp->labelno = (int)newlabel();
-	}
-	else if(lp->labtype != LABFORMAT)
-	{
-		execerr("bad format number", CNULL);
-		return(-1);
-	}
-	return(lp->labelno);
-}
-
-
- void
-#ifdef KR_headers
-setfmt(lp)
-	struct Labelblock *lp;
-#else
-setfmt(struct Labelblock *lp)
-#endif
-{
-	char *s, *s0, *sc, *se, *t;
-	int k, n, parity;
-
-	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 */
-
-	parity = 1;
-	str_fmt['%'] = "%";
-	while(s < se) {
-		k = *(unsigned char *)s++;
-		if (k == 2) {
-			if ((parity ^= 1) && *s == 2) {
-				t -= 2;
-				++s;
-				}
-			else
-				t += 3;
-			}
-		else {
-			sc = str_fmt[k];
-			while(*++sc)
-				t++;
-			}
-		}
-	s = s0;
-	parity = 1;
-	if (lp) {
-		lp->fmtstring = t = mem((int)(t - s + 1), 0);
-		while(s < se) {
-			k = *(unsigned char *)s++;
-			if (k == 2) {
-				if ((parity ^= 1) && *s == 2)
-					s++;
-				else {
-					t[0] = '\\';
-					t[1] = '0';
-					t[2] = '0';
-					t[3] = '2';
-					t += 4;
-					}
-				}
-			else {
-				sc = str_fmt[k];
-				do *t++ = *sc++;
-				   while(*sc);
-				}
-			}
-		*t = 0;
-		}
-	str_fmt['%'] = "%%";
-	flline();
-}
-
-
- void
-#ifdef KR_headers
-startioctl()
-#else
-startioctl()
-#endif
-{
-	register int i;
-
-	inioctl = YES;
-	nioctl = 0;
-	ioformatted = UNFORMATTED;
-	for(i = 1 ; i<=NIOS ; ++i)
-		V(i) = NULL;
-}
-
- static long
-newiolabel(Void) {
-	long rv;
-	rv = ++lastiolabno;
-	skiplabel = mklabel(rv);
-	skiplabel->labdefined = 1;
-	return rv;
-	}
-
- void
-endioctl(Void)
-{
-	int i;
-	expptr p;
-	struct io_setup *ios;
-
-	inioctl = NO;
-
-	/* set up for error recovery */
-
-	ioerrlab = ioendlab = skiplab = jumplab = 0;
-
-	if(p = V(IOSEND))
-		if(ISICON(p))
-			execlab(ioendlab = p->constblock.Const.ci);
-		else
-			err("bad end= clause");
-
-	if(p = V(IOSERR))
-		if(ISICON(p))
-			execlab(ioerrlab = p->constblock.Const.ci);
-		else
-			err("bad err= clause");
-
-	if(IOSTP)
-		if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) )
-		{
-			err("iostat must be an integer variable");
-			frexpr(IOSTP);
-			IOSTP = NULL;
-		}
-
-	if(iostmt == IOREAD)
-	{
-		if(IOSTP)
-		{
-			if(ioerrlab && ioendlab && ioerrlab==ioendlab)
-				jumplab = ioerrlab;
-			else
-				skiplab = jumplab = newiolabel();
-		}
-		else	{
-			if(ioerrlab && ioendlab && ioerrlab!=ioendlab)
-			{
-				IOSTP = (expptr) mktmp(TYINT, ENULL);
-				skiplab = jumplab = newiolabel();
-			}
-			else
-				jumplab = (ioerrlab ? ioerrlab : ioendlab);
-		}
-	}
-	else if(iostmt == IOWRITE)
-	{
-		if(IOSTP && !ioerrlab)
-			skiplab = jumplab = newiolabel();
-		else
-			jumplab = ioerrlab;
-	}
-	else
-		jumplab = ioerrlab;
-
-	endbit = IOSTP!=NULL || ioendlab!=0;	/* for use in startrw() */
-	errbit = IOSTP!=NULL || ioerrlab!=0;
-	if (jumplab && !IOSTP)
-		IOSTP = (expptr) mktmp(TYINT, ENULL);
-
-	if(iostmt!=IOREAD && iostmt!=IOWRITE)
-	{
-		ios = io_stuff + iostmt;
-		io_fields = ios->fields;
-		ioblkp = io_structs[iostmt];
-		if(ioblkp == NULL)
-			io_structs[iostmt] = ioblkp =
-				autovar(1, ios->type, ENULL, "");
-		ioset(TYIOINT, XERR, ICON(errbit));
-	}
-
-	switch(iostmt)
-	{
-	case IOOPEN:
-		dofopen();
-		break;
-
-	case IOCLOSE:
-		dofclose();
-		break;
-
-	case IOINQUIRE:
-		dofinquire();
-		break;
-
-	case IOBACKSPACE:
-		dofmove("f_back");
-		break;
-
-	case IOREWIND:
-		dofmove("f_rew");
-		break;
-
-	case IOENDFILE:
-		dofmove("f_end");
-		break;
-
-	case IOREAD:
-	case IOWRITE:
-		startrw();
-		break;
-
-	default:
-		fatali("impossible iostmt %d", iostmt);
-	}
-	for(i = 1 ; i<=NIOS ; ++i)
-		if(i!=IOSIOSTAT && V(i)!=NULL)
-			frexpr(V(i));
-}
-
-
- int
-iocname(Void)
-{
-	register int i;
-	int found, mask;
-
-	found = 0;
-	mask = M(iostmt);
-	for(i = 1 ; i <= NIOS ; ++i)
-		if(!strcmp(ioc[i].iocname, token))
-			if(ioc[i].iotype & mask)
-				return(i);
-			else {
-				found = i;
-				break;
-				}
-	if(found) {
-		if (iostmt == IOOPEN && !strcmp(ioc[i].iocname, "name")) {
-			NOEXT("open with \"name=\" treated as \"file=\"");
-			for(i = 1; strcmp(ioc[i].iocname, "file"); i++);
-			return i;
-			}
-		errstr("invalid control %s for statement", ioc[found].iocname);
-		}
-	else
-		errstr("unknown iocontrol %s", token);
-	return(IOSBAD);
-}
-
-
- void
-#ifdef KR_headers
-ioclause(n, p)
-	register int n;
-	register expptr p;
-#else
-ioclause(register int n, register expptr p)
-#endif
-{
-	struct Ioclist *iocp;
-
-	++nioctl;
-	if(n == IOSBAD)
-		return;
-	if(n == IOSPOSITIONAL)
-		{
-		n = nioctl;
-		if (n == IOSFMT) {
-			if (iostmt == IOOPEN) {
-				n = IOSFILE;
-				NOEXT("file= specifier omitted from open");
-				}
-			else if (iostmt < IOREAD)
-				goto illegal;
-			}
-		else if(n > IOSFMT)
-			{
- illegal:
-			err("illegal positional iocontrol");
-			return;
-			}
-		}
-	else if (n == IOSNML)
-		n = IOSFMT;
-
-	if(p == NULL)
-	{
-		if(n == IOSUNIT)
-			p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT);
-		else if(n != IOSFMT)
-		{
-			err("illegal * iocontrol");
-			return;
-		}
-	}
-	if(n == IOSFMT)
-		ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED);
-
-	iocp = & ioc[n];
-	if(iocp->iocval == NULL)
-	{
-		if(n!=IOSFMT && ( n!=IOSUNIT || (p && p->headblock.vtype!=TYCHAR) ) )
-			p = fixtype(p);
-		else if (p && p->tag == TPRIM
-			   && p->primblock.namep->vclass == CLUNKNOWN) {
-			/* kludge made necessary by attempt to infer types
-			 * for untyped external parameters: given an error
-			 * in calling sequences, an integer argument might
-			 * tentatively be assumed TYCHAR; this would otherwise
-			 * be corrected too late in startrw after startrw
-			 * had decided this to be an internal file.
-			 */
-			vardcl(p->primblock.namep);
-			p->primblock.vtype = p->primblock.namep->vtype;
-			}
-		iocp->iocval = p;
-	}
-	else
-		errstr("iocontrol %s repeated", iocp->iocname);
-}
-
-/* io list item */
-
- void
-#ifdef KR_headers
-doio(list)
-	chainp list;
-#else
-doio(chainp list)
-#endif
-{
-	if(ioformatted == NAMEDIRECTED)
-	{
-		if(list)
-			err("no I/O list allowed in NAMELIST read/write");
-	}
-	else
-	{
-		doiolist(list);
-		ioroutine[0] = 'e';
-		if (skiplab)
-			jumplab = 0;
-		putiocall( call0(TYINT, ioroutine) );
-	}
-}
-
-
-
-
-
- LOCAL void
-#ifdef KR_headers
-doiolist(p0)
-	chainp p0;
-#else
-doiolist(chainp p0)
-#endif
-{
-	chainp p;
-	register tagptr q;
-	register expptr qe;
-	register Namep qn;
-	Addrp tp;
-	int range;
-	extern char *ohalign;
-
-	for (p = p0 ; p ; p = p->nextp)
-	{
-		q = (tagptr)p->datap;
-		if(q->tag == TIMPLDO)
-		{
-			exdo(range = (int)newlabel(), (Namep)0,
-				q->impldoblock.impdospec);
-			doiolist(q->impldoblock.datalist);
-			enddo(range);
-			free( (charptr) q);
-		}
-		else	{
-			if(q->tag==TPRIM && q->primblock.argsp==NULL
-			    && q->primblock.namep->vdim!=NULL)
-			{
-				vardcl(qn = q->primblock.namep);
-				if(qn->vdim->nelt) {
-					putio( fixtype(cpexpr(qn->vdim->nelt)),
-					    (expptr)mkscalar(qn) );
-					qn->vlastdim = 0;
-					}
-				else
-					err("attempt to i/o array of unknown size");
-			}
-			else if(q->tag==TPRIM && q->primblock.argsp==NULL &&
-			    (qe = (expptr) memversion(q->primblock.namep)) )
-				putio(ICON(1),qe);
-			else if (ISCONST(q) && q->constblock.vtype == TYCHAR) {
-				halign = 0;
-				putio(ICON(1), qe = fixtype(cpexpr(q)));
-				halign = ohalign;
-				}
-			else if(((qe = fixtype(cpexpr(q)))->tag==TADDR &&
-			    (qe->addrblock.uname_tag != UNAM_CONST ||
-			    !ISCOMPLEX(qe -> addrblock.vtype))) ||
-			    (qe -> tag == TCONST && !ISCOMPLEX(qe ->
-			    headblock.vtype))) {
-				if (qe -> tag == TCONST)
-					qe = (expptr) putconst((Constp)qe);
-				putio(ICON(1), qe);
-			}
-			else if(qe->headblock.vtype != TYERROR)
-			{
-				if(iostmt == IOWRITE)
-				{
-					expptr qvl;
-					qvl = NULL;
-					if( ISCHAR(qe) )
-					{
-						qvl = (expptr)
-						    cpexpr(qe->headblock.vleng);
-						tp = mktmp(qe->headblock.vtype,
-						    ICON(lencat(qe)));
-					}
-					else
-						tp = mktmp(qe->headblock.vtype,
-						    qe->headblock.vleng);
-					puteq( cpexpr((expptr)tp), qe);
-					if(qvl)	/* put right length on block */
-					{
-						frexpr(tp->vleng);
-						tp->vleng = qvl;
-					}
-					putio(ICON(1), (expptr)tp);
-				}
-				else
-					err("non-left side in READ list");
-			}
-			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
-#ifdef KR_headers
-putio(nelt, addr)
-	expptr nelt;
-	register expptr addr;
-#else
-putio(expptr nelt, register expptr addr)
-#endif
-{
-	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 = (char*)(ioformatted==FORMATTED ? "do_fio"
-			: !byterev ? "do_uio"
-			: ONEOF(type, M(TYCHAR)|M(TYINT1)|M(TYLOGICAL1))
-			? "do_ucio" : "do_unio");
-		q = c	? call3(TYINT, s, nelt, addr, (expptr)c)
-			: call2(TYINT, s, nelt, addr);
-		}
-	iocalladdr = TYCHAR;
-	putiocall(q);
-	iocalladdr = TYADDR;
-}
-
-
-
- void
-endio(Void)
-{
-	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
-#ifdef KR_headers
-putiocall(q)
-	register expptr q;
-#else
-putiocall(register expptr q)
-#endif
-{
-	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
-#ifdef KR_headers
-fmtname(np, q)
-	Namep np;
-	register Addrp q;
-#else
-fmtname(Namep np, register Addrp q)
-#endif
-{
-	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
-#ifdef KR_headers
-asg_addr(p)
-	union Expression *p;
-#else
-asg_addr(union Expression *p)
-#endif
-{
-	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;
-	}
-
- void
-startrw(Void)
-{
-	register expptr p;
-	register Namep np;
-	register Addrp unitp, fmtp, recp;
-	register expptr nump;
-	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(Void)
-{
-	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(Void)
-{
-	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(Void)
-{
-	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
-#ifdef KR_headers
-dofmove(subname)
-	char *subname;
-#else
-dofmove(char *subname)
-#endif
-{
-	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
-#ifdef KR_headers
-ioset(type, offset, p)
-	int type;
-	int offset;
-	register expptr p;
-#else
-ioset(int type, int offset, register expptr p)
-#endif
-{
-	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
-#ifdef KR_headers
-iosetc(offset, p)
-	int offset;
-	register expptr p;
-#else
-iosetc(int offset, register expptr p)
-#endif
-{
-	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
-#ifdef KR_headers
-ioseta(offset, p)
-	int offset;
-	register Addrp p;
-#else
-ioseta(int offset, register Addrp p)
-#endif
-{
-	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
-#ifdef KR_headers
-iosetip(i, offset)
-	int i;
-	int offset;
-#else
-iosetip(int i, int offset)
-#endif
-{
-	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
-#ifdef KR_headers
-iosetlc(i, offp, offl)
-	int i;
-	int offp;
-	int offl;
-#else
-iosetlc(int i, int offp, int offl)
-#endif
-{
-	register expptr p;
-	if( (p = V(i)) && p->headblock.vtype==TYCHAR)
-		ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) );
-	iosetc(offp, p);
-}
diff --git a/contrib/tools/f2c/src/iob.h b/contrib/tools/f2c/src/iob.h
deleted file mode 100644
index 065d813aae1..00000000000
--- a/contrib/tools/f2c/src/iob.h
+++ /dev/null
@@ -1,26 +0,0 @@
-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];
-void	def_start Argdcl((FILEP, char*, char*, char*));
-void	new_iob_data Argdcl((io_setup*, char*));
-void	other_undefs Argdcl((FILEP));
-char*	tostring Argdcl((char*, int));
diff --git a/contrib/tools/f2c/src/lex.c b/contrib/tools/f2c/src/lex.c
deleted file mode 100644
index b593113709c..00000000000
--- a/contrib/tools/f2c/src/lex.c
+++ /dev/null
@@ -1,1749 +0,0 @@
-/****************************************************************
-Copyright 1990, 1992 - 1997, 1999, 2000 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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 _WIN32
-#undef MSDOS
-#define MSDOS
-#endif
-
-#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) */
-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 char *shend;	/* reflects elbow room for #line lines */
-LOCAL int maxcont;
-LOCAL int nincl	= 0;	/* Current number of include files */
-LOCAL long firstline;
-LOCAL char *infname1, *infname2, *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 Argdcl((void));
-extern flag use_bs;
-static char *lastfile = "??", *lastfile0 = "?";
-static char fbuf[P1_FILENAME_MAX];
-static long lastline;
-static void putlineno(Void);
-
-
-/* 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  },
-	{ "byte",	SBYTE	},
-	{ "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 }
-};
-
-static void analyz Argdcl((void));
-static void crunch Argdcl((void));
-static int getcd Argdcl((char*, int));
-static int getcds Argdcl((void));
-static int getkwd Argdcl((void));
-static int gettok Argdcl((void));
-static void store_comment Argdcl((char*));
-LOCAL char *stbuf[3];
-
- int
-#ifdef KR_headers
-inilex(name)
-	char *name;
-#else
-inilex(char *name)
-#endif
-{
-	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 */
- void
-flline(Void)
-{
-	lexstate = RETEOS;
-}
-
-
-
- char *
-#ifdef KR_headers
-lexline(n)
-	int *n;
-#else
-lexline(int *n)
-#endif
-{
-	*n = (lastch - nextch) + 1;
-	return(nextch);
-}
-
-
-
-
- void
-#ifdef KR_headers
-doinclude(name)
-	char *name;
-#else
-doinclude(char *name)
-#endif
-{
-	FILEP fp;
-	struct Inclfile *t;
-	char *name0, *lastslash, *s, *s0, *temp;
-	int j, k;
-	chainp I;
-	extern chainp Iargs;
-
-	err_lineno = -1;
-	if(inclp)
-	{
-		inclp->incllno = thislin;
-		inclp->inclcode = code;
-		inclp->inclstno = nxtstno;
-		if(nextcd && (j = endcd - nextcd) > 0)
-			inclp->incllinp = copyn(inclp->incllen = j, 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;
-		name0 = name;
-		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 && (I = Iargs)) {
-			k = strlen(name0) + 2;
-			for(; I; I = I->nextp) {
-				j = strlen(s = I->datap);
-				name = Alloc(j + k);
-				strcpy(name, s);
-				switch(s[j-1]) {
-					case '/':
-#ifdef MSDOS
-					case ':':
-					case '\\':
-#endif
-						break;
-					default:
-						name[j++] = '/';
-					}
-				strcpy(name+j, name0);
-				if (fp = fopen(name, textread)) {
-					free(name0);
-					goto havefp;
-					}
-				free(name);
-				name = name0;
-				}
-			}
-		}
-	if (fp)
-	{
- havefp:
-		t = inclp;
-		inclp = ALLOC(Inclfile);
-		inclp->inclnext = t;
-		prevlin = thislin = lineno = 0;
-		infname = inclp->inclname = name;
-		infile = inclp->inclfp = fp;
-		lastline = 0;
-		putlineno();
-		lastline = 0;
-	}
-	else
-	{
-		fprintf(diagfile, "Cannot open file %s\n", name);
-		done(1);
-	}
-}
-
-
-
-
- LOCAL int
-popinclude(Void)
-{
-	struct Inclfile *t;
-	register char *p;
-	register int k;
-
-	if(infile != stdin)
-		clf(&infile, infname, 1);	/* Close the input file */
-	free(infname);
-
-	--nincl;
-	err_lineno = -1;
-	t = inclp->inclnext;
-	free( (charptr) inclp);
-	inclp = t;
-	if(inclp == NULL) {
-		infname = 0;
-		return(NO);
-		}
-
-	infile = inclp->inclfp;
-	infname = inclp->inclname;
-	lineno = prevlin = thislin = inclp->incllno;
-	code = inclp->inclcode;
-	stno = nxtstno = inclp->inclstno;
-	if(inclp->incllinp)
-	{
-		lastline = 0;
-		putlineno();
-		lastline = lineno;
-		endcd = nextcd = sbuf;
-		k = inclp->incllen;
-		p = inclp->incllinp;
-		while(--k >= 0)
-			*endcd++ = *p++;
-		free( (charptr) (inclp->incllinp) );
-	}
-	else
-		nextcd = NULL;
-	return(YES);
-}
-
-
- void
-#ifdef KR_headers
-p1_line_number(line_number)
-	long line_number;
-#else
-p1_line_number(long line_number)
-#endif
-{
-	if (lastfile != lastfile0) {
-		p1puts(P1_FILENAME, fbuf);
-		lastfile0 = lastfile;
-		}
-	fprintf(pass1_file, "%d: %ld\n", P1_SET_LINE, line_number);
-	}
-
- static void
-putlineno(Void)
-{
-	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;
-		}
-	}
-
- int
-yylex(Void)
-{
-	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;
-		}
-		if (tokno == 2 && stkey == SDO) {
-			intonly = 1;
-			retval = gettok();
-			intonly = 0;
-			}
-		else
-			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(Void)
-{
-	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(Void)
-{
-	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;
-	if (infname2) {
-		free(infname);
-		infname = infname2;
-		if (inclp)
-			inclp->inclname = infname;
-		}
-	infname2 = infname1;
-	infname1 = 0;
-	return(STINITIAL);
-}
-
- static void
-#ifdef KR_headers
-bang(a, b, c, d, e)
-	char *a;
-	char *b;
-	char *c;
-	register char *d;
-	register char *e;
-#else
-bang(char *a, char *b, char *c, register char *d, register char *e)
-#endif
-		/* save ! comments */
-{
-	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
-#ifdef KR_headers
-getcd(b, nocont)
-	register char *b;
-	int nocont;
-#else
-getcd(register char *b, int nocont)
-#endif
-{
-	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 & (Table_size-1)])
-	{
-		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 < shend)
-					*endcd++ = c;
-			++thislin;
-			*endcd = 0;
-			if (b[1] == ' ')
-				p = b + 2;
-			else if (!strncmp(b,"#line ",6))
-				p = b + 6;
-			else {
- bad_cpp:
-				lineno = thislin;
-				errstr("Bad # line: \"%s\"", b);
-				goto top;
-				}
-			if (*p < '1' || *p > '9')
-				goto bad_cpp;
-			L = *p - '0';
-			while((c = *++p) >= '0' && c <= '9')
-				L = 10*L + c - '0';
-			while(c == ' ')
-				c = *++p;
-			if (!c) {
-				/* accept "# 1234" */
-				thislin = L - 1;
-				goto top;
-				}
-			if (c != '"')
-				goto bad_cpp;
-			bend = p;
-			while(*++p != '"')
-				if (!*p)
-					goto bad_cpp;
-			*p = 0;
-			i = p - bend++;
-			thislin = L - 1;
-			if (!infname1 || strcmp(infname1, bend)) {
-				if (infname1)
-					free(infname1);
-				if (infname && !strcmp(infname, bend)) {
-					infname1 = 0;
-					goto top;
-					}
-				lastfile = 0;
-				infname1 = Alloc(i);
-				strcpy(infname1, bend);
-				if (!infname) {
-					infname = infname1;
-					infname1 = 0;
-					}
-				}
-			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 && c != '\r')
-					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 (!lastline)
-		lastline = thislin;
-	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);
-}
-
- LOCAL void
-#ifdef KR_headers
-adjtoklen(newlen)
-	int newlen;
-#else
-adjtoklen(int newlen)
-#endif
-{
-	while(maxtoklen < newlen)
-		maxtoklen = 2*maxtoklen + 2;
-	if (token = (char *)realloc(token, maxtoklen))
-		return;
-	fprintf(stderr, "adjtoklen: realloc(%d) failure!\n", maxtoklen);
-	exit(2);
-	}
-
-/* crunch -- deletes all space characters, folds the backslash chars and
-   Hollerith strings, quotes the Fortran strings */
-
- LOCAL void
-crunch(Void)
-{
-	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];
-					}
-				*++j = *i;
-				len++;
-			} /* for (;;) */
-
-			if ((len = j - sbuf) > maxtoklen)
-				adjtoklen(len);
-			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 > sbuf && j1[-1] == MYQUOTE)
-				--j1;
-			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 string must be preceded by a punctuation mark.
-   '*' is possible only as repetition factor in a data statement
-   not, in particular, in character*2h .
-   To avoid some confusion with missing commas in FORMAT statements,
-   treat a preceding string as a punctuation mark.
- */
-
-			if( !(*j0=='*'&&sbuf[0]=='d') && *j0!='/'
-			&& *j0!='(' && *j0!=',' && *j0!='=' && *j0!='.'
-			&& *j0 != MYQUOTE)
-				goto copychar;
-			nh0 = nh;
-			if(i+nh > lastch)
-			{
-				erri("%dH too big", nh);
-				nh = lastch - i;
-				nh0 = -1;
-			}
-			if (nh > maxtoklen)
-				adjtoklen(nh);
-			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(Void)
-{
-	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(Void)
-{
-	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);
-}
-
- void
-initkey(Void)
-{
-	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 + MAX_SHARPLINE_LEN);
-	send = sbuf + i;
-	shend = send + MAX_SHARPLINE_LEN;
-	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
-#ifdef KR_headers
-hexcheck(key)
-	int key;
-#else
-hexcheck(int key)
-#endif
-{
-	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(Void)
-{
-	int havdot, havexp, havdbl;
-	int radix, val;
-	struct Punctlist *pp;
-	struct Dotlist *pd;
-	register int ch;
-	static char	Exp_mi[] = "X**-Y treated as X**(-Y)",
-			Exp_pl[] = "X**+Y treated as X**(+Y)";
-
-	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 '/':
-					switch(*nextch) {
-					  case '/':
-						nextch++;
-						val = SCONCAT;
-						break;
-					  case '=':
-						goto sne;
-					  default:
-						if (new_dcl && parlev == 0)
-							val = SSLASHD;
-					  }
-					return val;
-				case '*':
-					if (*nextch == '*') {
-						nextch++;
-						if (noextflag
-						 && nextch <= lastch)
-						 	switch(*nextch) {
-							  case '-':
-								errext(Exp_mi);
-								break;
-							  case '+':
-								errext(Exp_pl);
-								}
-						return SPOWER;
-						}
-					break;
-				case '<':
-					switch(*nextch) {
-					  case '=':
-						nextch++;
-						val = SLE;
-						break;
-					  case '>':
- sne:
-						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 > MAXNAMELEN)
-		{
-			char buff[2*MAXNAMELEN+50];
-			if (toklen >= MAXNAMELEN+10)
-			    sprintf(buff,
-				"name %.*s... too long, truncated to %.*s",
-				MAXNAMELEN+6, token, MAXNAMELEN, token);
-			else
-			    sprintf(buff,
-				"name %s too long, truncated to %.*s",
-				token, MAXNAMELEN, token);
-			err(buff);
-			toklen = MAXNAMELEN;
-			token[MAXNAMELEN] = '\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( ! isdigit(* USC nextch) ) {
-			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;
-			}
-	}
-	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
-#ifdef KR_headers
-store_comment(str)
-	char *str;
-#else
-store_comment(char *str)
-#endif
-{
-	int len;
-	comment_buf *ncb;
-
-	if (nextcd == sbuf) {
-		flush_comments();
-		p1_comment(str);
-		return;
-		}
-	len = strlen(str) + 1;
-	if (cbnext + len > cblast) {
-		ncb = 0;
-		if (cbcur) {
-			cbcur->last = cbnext;
-			ncb = cbcur->next;
-			}
-		if (!ncb) {
-			ncb = (comment_buf *) Alloc(sizeof(comment_buf));
-			if (cbcur)
-				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(Void)
-{
-	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(Void)
-{
-	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);
-	}
-
- void
-endcheck(Void)
-{
-	if (nextch <= lastch)
-		warn("ignoring text after \"end\".");
-	lexstate = RETEOS;
-	}
diff --git a/contrib/tools/f2c/src/machdefs.h b/contrib/tools/f2c/src/machdefs.h
deleted file mode 100644
index 3ab8961f0a2..00000000000
--- a/contrib/tools/f2c/src/machdefs.h
+++ /dev/null
@@ -1,31 +0,0 @@
-#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/contrib/tools/f2c/src/main.c b/contrib/tools/f2c/src/main.c
deleted file mode 100644
index 977113dc308..00000000000
--- a/contrib/tools/f2c/src/main.c
+++ /dev/null
@@ -1,792 +0,0 @@
-/****************************************************************
-Copyright 1990-1996, 2000-2001 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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;
-
-int badargs;
-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;
-flag byterev = NO;
-int intr_omit;
-static int no_cd, no_i90;
-#ifdef TYQUAD
-flag use_tyquad = YES;
-#ifndef NO_LONG_LONG
-flag allow_i8c = YES;
-#endif
-#endif
-int tyreal = TYREAL;
-int tycomplex = TYCOMPLEX;
-
-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 dneg = NO;			/* f77 treatment of unary minus */
-int Ansi = YES;
-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 help, showver, 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 */
-int trapuv;
-chainp Iargs;
-
-#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 ("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 ("K", P_NO_ARGS, P_INT, &Ansi, NO),
-    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),
-    f2c_entry ("d", P_ONE_ARG, P_STRING, &outbuf, 0),
-    f2c_entry ("cd", P_NO_ARGS, P_INT, &no_cd, 1),
-    f2c_entry ("i90", P_NO_ARGS, P_INT, &no_i90, 2),
-    f2c_entry ("trapuv", P_NO_ARGS, P_INT, &trapuv, 1),
-#ifdef TYQUAD
-#ifndef NO_LONG_LONG
-    f2c_entry ("!i8const", P_NO_ARGS, P_INT, &allow_i8c, NO),
-#endif
-    f2c_entry ("!i8", P_NO_ARGS, P_INT, &use_tyquad, NO),
-#endif
-
-	/* options omitted from man pages */
-
-	/* -b ==> for unformatted I/O, call do_unio (for noncharacter  */
-	/* data of length > 1 byte) and do_ucio (for the rest) rather  */
-	/* than do_uio.  This permits modifying libI77 to byte-reverse */
-	/* numeric data. */
-
-    f2c_entry ("b", P_NO_ARGS, P_INT, &byterev, YES),
-
-	/* -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),
-
-	/* -Dnnn = debug level nnn */
-
-    f2c_entry ("D", P_ONE_ARG, P_INT, &debugflag, YES),
-
-	/* -dneg ==> under (default) -!R, imitate f77's bizarre	*/
-	/* treatment of unary minus of REAL expressions by	*/
-	/* promoting them to DOUBLE PRECISION . */
-
-    f2c_entry ("dneg", P_NO_ARGS, P_INT, &dneg, YES),
-
-	/* -?, --help, -v, --version */
-
-    f2c_entry ("?", P_NO_ARGS, P_INT, &help, YES),
-    f2c_entry ("-help", P_NO_ARGS, P_INT, &help, YES),
-
-    f2c_entry ("v", P_NO_ARGS, P_INT, &showver, YES),
-    f2c_entry ("-version", P_NO_ARGS, P_INT, &showver, YES)
-
-}; /* 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;
-
- void
-set_externs(Void)
-{
-    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(TYLOGICAL2);
-	goto checklong;
-	}
-    else
-	szleng = typesize[TYLONG];
-    if (useshortints) {
-	/* inqmask = M(TYLONG); */
-	/* used to disallow LOGICAL in INQUIRE under -I2 */
- checklong:
-	protorettypes[TYLOGICAL] = "shortlogical";
-	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";
-	}
-    else
-	dneg = 0;
-
-#ifndef NO_LONG_LONG
-    if (!use_tyquad)
-	allow_i8c = 0;
-#endif
-
-    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(Void)
-{
-	Extsym *ext;
-	if (ext1comm)
-		for(ext = extsymtab; ext < nextext; ext++)
-			if (ext->extstg == STGCOMMON && !ext->extinit)
-				return ext1comm;
-	return 0;
-	}
-
- static void
-#ifdef KR_headers
-write_typedefs(outfile)
-	FILE *outfile;
-#else
-write_typedefs(FILE *outfile)
-#endif
-{
-	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 = (char*)(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 = (char*)(i ? "VOID" : "doublereal"),
-				stl[i], ftn_types[st[i]]);
-	if (p)
-		nice_printf(outfile, "#endif\n\n");
-	}
-
- static void
-#ifdef KR_headers
-commonprotos(outfile)
-	register FILE *outfile;
-#else
-commonprotos(register FILE *outfile)
-#endif
-{
-	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);
-			}
-		}
-	}
-
- static int
-#ifdef KR_headers
-I_args(argc, a)
-	int argc;
-	char **a;
-#else
-I_args(int argc, char **a)
-#endif
-{
-	char **a0, **a1, **ae, *s;
-
-	ae = a + argc;
-	a0 = a;
-	for(a1 = ++a; a < ae; a++) {
-		if (!(s = *a))
-			break;
-		if (*s == '-' && s[1] == 'I' && s[2]
-		  && (s[3] || s[2] != '2' && s[2] != '4'))
-			Iargs = mkchain(s+2, Iargs);
-		else
-			*a1++ = s;
-		}
-	Iargs = revchain(Iargs);
-	*a1 = 0;
-	return a1 - a0;
-	}
-
- static void
-omit_non_f(Void)
-{
-	/* complain about ftn_files that do not end in .f or .F */
-
-	char *s, *s1;
-	int i, k;
-
-	for(i = k = 0; s = ftn_files[k]; k++) {
-		s1 = s + strlen(s);
-		if (s1 - s >= 3) {
-			s1 -= 2;
-			if (*s1 == '.') switch(s1[1]) {
-			  case 'f':
-			  case 'F':
-				ftn_files[i++] = s;
-				continue;
-			  }
-			}
-		fprintf(diagfile, "\"%s\" does not end in .f or .F\n", s);
-		}
-	if (i != k) {
-		fflush(diagfile);
-		if (!i)
-			exit(1);
-		ftn_files[i] = 0;
-		}
-	}
-
- static void
-show_version(Void)
-{
-	printf("f2c (Fortran to C Translator) version %s.\n", F2C_version);
-	}
-
- static void
-#ifdef KR_headers
-show_help(progname) char *progname;
-#else
-show_help(char *progname)
-#endif
-{
-	show_version();
-	if (!progname)
-		progname = "f2c";
-	printf("Usage: %s [ option ... ] [file ...]\n%s%s%s%s%s%s%s",
-	progname,
-	"For usage details, see the man page, f2c.1.\n",
-	"For technical details, see the f2c report.\n",
-	"Both are available from netlib, e.g.,\n",
-	"\thttps://www.netlib.org/f2c/f2c.1\n",
-	"\thttps://www.netlib.org/f2c/f2c.pdf\nor\n",
-	"\thttps://ampl.com/netlib/f2c/f2c.1\n",
-	"\thttps://ampl.com/netlib/f2c/f2c.pdf\n");
-	}
-
- int retcode = 0;
-
- int
-#ifdef KR_headers
-main(argc, argv)
-	int argc;
-	char **argv;
-#else
-main(int argc, char **argv)
-#endif
-{
-	int c2d, k;
-	FILE *c_output;
-	char *cdfilename;
-	static char stderrbuf[BUFSIZ];
-	extern char **dfltproc, *dflt1proc[];
-	extern char link_msg[];
-
-	diagfile = stderr;
-	setbuf(stderr, stderrbuf);	/* arrange for fast error msgs */
-
-	argkludge(&argc, &argv);		/* for _WIN32 */
-	argc = I_args(argc, argv);	/* extract -I args */
-	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 (badargs)
-		return 1;
-	if (help) {
-		show_help(argv[0]);
-		return 0;
-		}
-	if (showver && !ftn_files[0]) {
-		show_version();
-		return 0;
-		}
-	intr_omit = no_cd | no_i90;
-	if (keepsubs && checksubs) {
-		warn("-C suppresses -s\n");
-		keepsubs = 0;
-		}
-	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 = (char*)(Ansi == 1 ? "()" : "(...)");
-	else
-		dfltproc = dflt1proc;
-
-	outbuf_adjust();
-	set_externs();
-	fileinit();
-	read_Pfiles(ftn_files);
-	omit_non_f();
-
-	for(k = 0; ftn_files[k+1]; k++)
-		if (dofork(ftn_files[k]))
-			break;
-	filename0 = file_name = ftn_files[current_ftn_file = k];
-
-	set_tmp_names();
-	sigcatch(0);
-
-	c_file   = opf(c_functions, textwrite);
-	pass1_file=opf(p1_file, binwrite);
-	initkey();
-	if (file_name && *file_name) {
-		cdfilename = coutput;
-		if (debugflag != 1) {
-			coutput = c_name(file_name,'c');
-			cdfilename = copys(outbtail);
-			if (Castargs1 >= 2)
-				proto_fname = c_name(file_name,'P');
-			}
-		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 libf2c:\n\
-	%s\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 (trapuv)
-		nice_printf(c_output, "extern void _uninit_f2c(%s);\n%s\n\n",
-			Ansi ? "void*,int,long" : "", "extern double _0;");
-	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();
-		nerr = 1;
-		}
-	done(nerr ? 1 : 0);
-	/* NOT REACHED */ return 0;
-}
-
-
- FILEP
-#ifdef KR_headers
-opf(fn, mode)
-	char *fn;
-	char *mode;
-#else
-opf(char *fn, char *mode)
-#endif
-{
-	FILEP fp;
-	if( fp = fopen(fn, mode) )
-		return(fp);
-
-	fatalstr("cannot open intermediate file %s", fn);
-	/* NOT REACHED */ return 0;
-}
-
-
- void
-#ifdef KR_headers
-clf(p, what, quit)
-	FILEP *p;
-	char *what;
-	int quit;
-#else
-clf(FILEP *p, char *what, int quit)
-#endif
-{
-	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;
-}
-
-
- void
-#ifdef KR_headers
-done(k)
-	int k;
-#else
-done(int k)
-#endif
-{
-	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/contrib/tools/f2c/src/mem.c b/contrib/tools/f2c/src/mem.c
deleted file mode 100644
index 2f0aed327c7..00000000000
--- a/contrib/tools/f2c/src/mem.c
+++ /dev/null
@@ -1,272 +0,0 @@
-/****************************************************************
-Copyright 1990, 1991, 1994, 2000 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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
-
-#ifdef _WIN32
-#undef MSDOS
-#endif
-
- char *
-#ifdef KR_headers
-gmem(n, round)
-	int n;
-	int round;
-#else
-gmem(int n, int round)
-#endif
-{
-	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(Void)
-{
-	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 *
-#ifdef KR_headers
-mem(n, round)
-	int n;
-	int round;
-#else
-mem(int n, int round)
-#endif
-{
-	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 *
-#ifdef KR_headers
-tostring(s, n)
-	register char *s;
-	int n;
-#else
-tostring(register char *s, int n)
-#endif
-{
-	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 *
-#ifdef KR_headers
-cpstring(s)
-	register char *s;
-#else
-cpstring(register char *s)
-#endif
-{
-	return strcpy(mem(strlen(s)+1,0), s);
-	}
-
- void
-#ifdef KR_headers
-new_iob_data(ios, name)
-	register io_setup *ios;
-	char *name;
-#else
-new_iob_data(register io_setup *ios, char *name)
-#endif
-{
-	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 *
-#ifdef KR_headers
-string_num(pfx, n)
-	char *pfx;
-	long n;
-#else
-string_num(char *pfx, long n)
-#endif
-{
-	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
-#ifdef KR_headers
-def_start(outfile, s1, s2, post)
-	FILE *outfile;
-	char *s1;
-	char *s2;
-	char *post;
-#else
-def_start(FILE *outfile, char *s1, char *s2, char *post)
-#endif
-{
-	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
-#ifdef KR_headers
-other_undefs(outfile)
-	FILE *outfile;
-#else
-other_undefs(FILE *outfile)
-#endif
-{
-	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/contrib/tools/f2c/src/misc.c b/contrib/tools/f2c/src/misc.c
deleted file mode 100644
index bdb9bcb3e35..00000000000
--- a/contrib/tools/f2c/src/misc.c
+++ /dev/null
@@ -1,1398 +0,0 @@
-/****************************************************************
-Copyright 1990, 1992-1995, 2000-2001 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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 "limits.h"
-
- int
-#ifdef KR_headers
-oneof_stg(name, stg, mask)
-	Namep name;
-	int stg;
-	int mask;
-#else
-oneof_stg(Namep name, int stg, int mask)
-#endif
-{
-	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
-#ifdef KR_headers
-op_assign(opcode)
-	int opcode;
-#else
-op_assign(int opcode)
-#endif
-{
-    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 *
-#ifdef KR_headers
-Alloc(n)
-	int n;
-#else
-Alloc(int n)
-#endif
-		/* error-checking version of malloc */
-		/* ckalloc initializes memory to 0; Alloc does not */
-{
-	char errbuf[32];
-	register char *rv;
-
-	rv = (char*)malloc(n);
-	if (!rv) {
-		sprintf(errbuf, "malloc(%d) failure!", n);
-		Fatal(errbuf);
-		}
-	return rv;
-	}
-
- void
-#ifdef KR_headers
-cpn(n, a, b)
-	register int n;
-	register char *a;
-	register char *b;
-#else
-cpn(register int n, register char *a, register char *b)
-#endif
-{
-	while(--n >= 0)
-		*b++ = *a++;
-}
-
-
- int
-#ifdef KR_headers
-eqn(n, a, b)
-	register int n;
-	register char *a;
-	register char *b;
-#else
-eqn(register int n, register char *a, register char *b)
-#endif
-{
-	while(--n >= 0)
-		if(*a++ != *b++)
-			return(NO);
-	return(YES);
-}
-
-
-
-
-
-
- int
-#ifdef KR_headers
-cmpstr(a, b, la, lb)
-	register char *a;
-	register char *b;
-	ftnint la;
-	ftnint lb;
-#else
-cmpstr(register char *a, register char *b, ftnint la, ftnint lb)
-#endif
-	/* compare two strings */
-{
-	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
-#ifdef KR_headers
-hookup(x, y)
-	register chainp x;
-	register chainp y;
-#else
-hookup(register chainp x, register chainp y)
-#endif
-{
-	register chainp p;
-
-	if(x == NULL)
-		return(y);
-
-	for(p = x ; p->nextp ; p = p->nextp)
-		;
-	p->nextp = y;
-	return(x);
-}
-
-
-
- struct Listblock *
-#ifdef KR_headers
-mklist(p)
-	chainp p;
-#else
-mklist(chainp p)
-#endif
-{
-	register struct Listblock *q;
-
-	q = ALLOC(Listblock);
-	q->tag = TLIST;
-	q->listp = p;
-	return(q);
-}
-
-
- chainp
-#ifdef KR_headers
-mkchain(p, q)
-	register char * p;
-	register chainp q;
-#else
-mkchain(register char * p, register chainp q)
-#endif
-{
-	register chainp r;
-
-	if(chains)
-	{
-		r = chains;
-		chains = chains->nextp;
-	}
-	else
-		r = ALLOC(Chain);
-
-	r->datap = p;
-	r->nextp = q;
-	return(r);
-}
-
- chainp
-#ifdef KR_headers
-revchain(next)
-	register chainp next;
-#else
-revchain(register chainp next)
-#endif
-{
-	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 *
-#ifdef KR_headers
-addunder(s)
-	register char *s;
-#else
-addunder(register char *s)
-#endif
-{
-	register int c, i, j;
-	char *s0 = s;
-
-	i = j = 0;
-	while(c = *s++)
-		if (c == '_')
-			i++, j++;
-		else
-			i = 0;
-	if (!i) {
-		*s-- = 0;
-		*s = '_';
-		}
-	else if (j == 2)
-		s[-2] = 0;
-	return( s0 );
-	}
-
-
-/* copyn -- return a new copy of the input Fortran-string */
-
- char *
-#ifdef KR_headers
-copyn(n, s)
-	register int n;
-	register char *s;
-#else
-copyn(register int n, register char *s)
-#endif
-{
-	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 *
-#ifdef KR_headers
-copys(s)
-	char *s;
-#else
-copys(char *s)
-#endif
-{
-	return( copyn( strlen(s)+1 , s) );
-}
-
-
-
-/* convci -- Convert Fortran-string to integer; assumes that input is a
-   legal number, with no trailing blanks */
-
- ftnint
-#ifdef KR_headers
-convci(n, s)
-	register int n;
-	register char *s;
-#else
-convci(register int n, register char *s)
-#endif
-{
-	ftnint sum, t;
-	char buff[100], *s0;
-	int n0;
-
-	s0 = s;
-	n0 = n;
-	sum = 0;
-	while(n-- > 0) {
-		/* sum = 10*sum + (*s++ - '0'); */
-		t = *s++ - '0';
-		if (sum > LONG_MAX/10) {
- ovfl:
-			if (n0 > 60)
-				n0 = 60;
-			sprintf(buff, "integer constant %.*s truncated.",
-				n0, s0);
-			err(buff);
-			return LONG_MAX;
-			}
-		sum *= 10;
-		if (sum > LONG_MAX - t)
-			goto ovfl;
-		sum += t;
-		}
-	return(sum);
-	}
-
-/* convic - Convert Integer constant to string */
-
- char *
-#ifdef KR_headers
-convic(n)
-	ftnint n;
-#else
-convic(ftnint n)
-#endif
-{
-	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
-#ifdef KR_headers
-mkname(s)
-	register char *s;
-#else
-mkname(register char *s)
-#endif
-{
-	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 = 2;
-	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 *
-#ifdef KR_headers
-mklabel(l)
-	ftnint l;
-#else
-mklabel(ftnint l)
-#endif
-{
-	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 = (int)newlabel();
-	lp->blklevel = 0;
-	lp->labused = NO;
-	lp->fmtlabused = NO;
-	lp->labdefined = NO;
-	lp->labinacc = NO;
-	lp->labtype = LABUNKNOWN;
-	lp->fmtstring = 0;
-	return(lp);
-}
-
- long
-newlabel(Void)
-{
-	return ++lastlabno;
-}
-
-
-/* this label appears in a branch context */
-
- struct Labelblock *
-#ifdef KR_headers
-execlab(stateno)
-	ftnint stateno;
-#else
-execlab(ftnint stateno)
-#endif
-{
-	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 *
-#ifdef KR_headers
-mkext1(f, s)
-	char *f;
-	char *s;
-#else
-mkext1(char *f, char *s)
-#endif
-{
-	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++ );
-}
-
-
- Extsym *
-#ifdef KR_headers
-mkext(f, s)
-	char *f;
-	char *s;
-#else
-mkext(char *f, char *s)
-#endif
-{
-	Extsym *e = mkext1(f, s);
-	if (e->extstg == STGCOMMON)
-		errstr("%.52s cannot be a subprogram: it is a common block.",f);
-	return e;
-	}
-
- Addrp
-#ifdef KR_headers
-builtin(t, s, dbi)
-	int t;
-	char *s;
-	int dbi;
-#else
-builtin(int t, char *s, int dbi)
-#endif
-{
-	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);
-}
-
-
- void
-#ifdef KR_headers
-add_extern_to_list(addr, list_store)
-	Addrp addr;
-	chainp *list_store;
-#else
-add_extern_to_list(Addrp addr, chainp *list_store)
-#endif
-{
-    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 */
-
-
- void
-#ifdef KR_headers
-frchain(p)
-	register chainp *p;
-#else
-frchain(register chainp *p)
-#endif
-{
-	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
-#ifdef KR_headers
-frexchain(p)
-	register chainp *p;
-#else
-frexchain(register chainp *p)
-#endif
-{
-	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
-#ifdef KR_headers
-cpblock(n, p)
-	register int n;
-	register char *p;
-#else
-cpblock(register int n, register char *p)
-#endif
-{
-	register ptr q;
-
-	memcpy((char *)(q = ckalloc(n)), (char *)p, n);
-	return( (tagptr) q);
-}
-
-
-
- ftnint
-#ifdef KR_headers
-lmax(a, b)
-	ftnint a;
-	ftnint b;
-#else
-lmax(ftnint a, ftnint b)
-#endif
-{
-	return( a>b ? a : b);
-}
-
- ftnint
-#ifdef KR_headers
-lmin(a, b)
-	ftnint a;
-	ftnint b;
-#else
-lmin(ftnint a, ftnint b)
-#endif
-{
-	return(a < b ? a : b);
-}
-
-
-
- int
-#ifdef KR_headers
-maxtype(t1, t2)
-	int t1;
-	int t2;
-#else
-maxtype(int t1, int t2)
-#endif
-{
-	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 */
- int
-#ifdef KR_headers
-log_2(n)
-	ftnint n;
-#else
-log_2(ftnint n)
-#endif
-{
-	int k;
-
-	/* trick based on binary representation */
-
-	if(n<=0 || (n & (n-1))!=0)
-		return(-1);
-
-	for(k = 0 ;  n >>= 1  ; ++k)
-		;
-	return(k);
-}
-
-
- void
-frrpl(Void)
-{
-	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
-#ifdef KR_headers
-callk(type, name, args)
-	int type;
-	char *name;
-	chainp args;
-#else
-callk(int type, char *name, chainp args)
-#endif
-{
-	register expptr p;
-
-	p = mkexpr(OPCALL,
-		(expptr)builtin(callk_kludge ? callk_kludge : type, name, 0),
-		(expptr)args);
-	p->exprblock.vtype = type;
-	return(p);
-}
-
-
-
- expptr
-#ifdef KR_headers
-call4(type, name, arg1, arg2, arg3, arg4)
-	int type;
-	char *name;
-	expptr arg1;
-	expptr arg2;
-	expptr arg3;
-	expptr arg4;
-#else
-call4(int type, char *name, expptr arg1, expptr arg2, expptr arg3, expptr arg4)
-#endif
-{
-	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
-#ifdef KR_headers
-call3(type, name, arg1, arg2, arg3)
-	int type;
-	char *name;
-	expptr arg1;
-	expptr arg2;
-	expptr arg3;
-#else
-call3(int type, char *name, expptr arg1, expptr arg2, expptr arg3)
-#endif
-{
-	struct Listblock *args;
-	args = mklist( mkchain((char *)arg1,
-			mkchain((char *)arg2,
-				mkchain((char *)arg3, CHNULL) ) ) );
-	return( callk(type, name, (chainp)args) );
-}
-
-
-
-
-
- expptr
-#ifdef KR_headers
-call2(type, name, arg1, arg2)
-	int type;
-	char *name;
-	expptr arg1;
-	expptr arg2;
-#else
-call2(int type, char *name, expptr arg1, expptr arg2)
-#endif
-{
-	struct Listblock *args;
-
-	args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) );
-	return( callk(type,name, (chainp)args) );
-}
-
-
-
-
- expptr
-#ifdef KR_headers
-call1(type, name, arg)
-	int type;
-	char *name;
-	expptr arg;
-#else
-call1(int type, char *name, expptr arg)
-#endif
-{
-	return( callk(type,name, (chainp)mklist(mkchain((char *)arg,CHNULL)) ));
-}
-
-
- expptr
-#ifdef KR_headers
-call0(type, name)
-	int type;
-	char *name;
-#else
-call0(int type, char *name)
-#endif
-{
-	return( callk(type, name, CHNULL) );
-}
-
-
-
- struct Impldoblock *
-#ifdef KR_headers
-mkiodo(dospec, list)
-	chainp dospec;
-	chainp list;
-#else
-mkiodo(chainp dospec, chainp list)
-#endif
-{
-	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
-#ifdef KR_headers
-ckalloc(n)
-	register int n;
-#else
-ckalloc(register int n)
-#endif
-{
-	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;
-}
-
-
- int
-#ifdef KR_headers
-isaddr(p)
-	register expptr p;
-#else
-isaddr(register expptr p)
-#endif
-{
-	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);
-}
-
-
-
- int
-#ifdef KR_headers
-isstatic(p)
-	register expptr p;
-#else
-isstatic(register expptr p)
-#endif
-{
-	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 */
-
- int
-#ifdef KR_headers
-addressable(p) expptr p;
-#else
-addressable(expptr p)
-#endif
-{
-	if (p)
-		switch(p->tag) {
-		 case TCONST:
-			return(YES);
-
-		 case TADDR:
-			return( addressable(p->addrblock.memoffset) );
-		 }
-	return(NO);
-	}
-
-
-/* isnegative_const -- returns true if the constant is negative.  Returns
-   false for imaginary and nonnumeric constants */
-
- int
-#ifdef KR_headers
-isnegative_const(cp)
-	struct Constblock *cp;
-#else
-isnegative_const(struct Constblock *cp)
-#endif
-{
-    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 */
-
- void
-#ifdef KR_headers
-negate_const(cp)
-	Constp cp;
-#else
-negate_const(Constp cp)
-#endif
-{
-    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 */
-
- void
-#ifdef KR_headers
-ffilecopy(infp, outfp) FILE *infp, *outfp;
-#else
-ffilecopy(FILE *infp, FILE *outfp)
-#endif
-{
-	int c;
-	while (!feof(infp)) {
-		c = getc(infp);
-		if (!feof(infp))
-			putc(c, outfp);
-		}
-	}
-
-
-/* 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
-#ifdef KR_headers
-in_vector(str, keywds, n)
-	char *str;
-	char **keywds;
-	register int n;
-#else
-in_vector(char *str, char **keywds, register int n)
-#endif
-{
-	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
-#ifdef KR_headers
-is_negatable(Const)
-	Constp Const;
-#else
-is_negatable(Constp Const)
-#endif
-{
-    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 */
-
- void
-#ifdef KR_headers
-backup(fname, bname)
-	char *fname;
-	char *bname;
-#else
-backup(char *fname, char *bname)
-#endif
-{
-	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
-#ifdef KR_headers
-struct_eq(s1, s2)
-	chainp s1;
-	chainp s2;
-#else
-struct_eq(chainp s1, chainp s2)
-#endif
-{
-    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
-		||  !(d2 = v2->vdim)
-		||  !(cp2 = (Constp)d2->nelt) || cp2->tag != TCONST
-		||  cp1->Const.ci != cp2->Const.ci)
-			return NO;
-		}
-	else if (v2->vdim)
-		return NO;
-    } /* while s1 != CHNULL && s2 != CHNULL */
-
-    return s1 == CHNULL && s2 == CHNULL;
-} /* struct_eq */
-
- static int
-#ifdef KR_headers
-int_trunc(n0, s0) int n0; char *s0;
-#else
-int_trunc(int n0, char *s0)
-#endif
-{
-	char buff[100];
-
-	if (n0 > 60)
-		n0 = 60;
-	sprintf(buff, "integer constant %.*s truncated.", n0, s0);
-	err(buff);
-	return 1;
-	}
-
- tagptr
-#ifdef KR_headers
-mkintqcon(n, s) int n; char *s;
-#else
-mkintqcon(int n, char *s)
-#endif
-{
-#ifdef NO_LONG_LONG
-	return mkintcon(convci(n, s));
-#else
-#ifndef LLONG_MAX
-#ifdef LONGLONG_MAX
-#define LLONG_MAX LONGLONG_MAX
-#else
-#define LLONG_MAX 0x7fffffffffffffffLL
-#endif
-#endif
-	Constp p;
-	Llong sum, t;
-	char *s0;
-	int n0, warned = 0;
-
-	s0 = s;
-	n0 = n;
-	sum = 0;
-	while(n-- > 0) {
-		/* sum = 10*sum + (*s++ - '0'); */
-		t = *s++ - '0';
-		if (sum > LLONG_MAX/10) {
- ovfl:
-			warned = int_trunc(n0,s0);
-			sum = LLONG_MAX;
-			break;
-			}
-		sum *= 10;
-		if (sum > LLONG_MAX - t)
-			goto ovfl;
-		sum += t;
-		}
-	p = mkconst(tyint);
-	if (sum > LONG_MAX) {
-		if (allow_i8c) {
-			p->vtype = TYQUAD;
-			p->Const.cq = sum;
-			}
-		else {
-			p->Const.ci = LONG_MAX;
-			if (!warned)
-				int_trunc(n0,s0);
-			}
-		}
-	else
-		p->Const.ci = (ftnint) sum;
-	return (tagptr)p;
-#endif
-	}
diff --git a/contrib/tools/f2c/src/names.c b/contrib/tools/f2c/src/names.c
deleted file mode 100644
index 373f656cb73..00000000000
--- a/contrib/tools/f2c/src/names.c
+++ /dev/null
@@ -1,835 +0,0 @@
-/****************************************************************
-Copyright 1990, 1992 - 1996, 2000 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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 *
-#ifdef KR_headers
-c_type_decl(type, is_extern)
-	int type;
-	int is_extern;
-#else
-c_type_decl(int type, int is_extern)
-#endif
-{
-    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(Void)
-{ return "ret_val_len"; }
-
- char *
-#ifdef KR_headers
-new_arg_length(arg)
-	Namep arg;
-#else
-new_arg_length(Namep arg)
-#endif
-{
-	static char buf[64];
-	char *fmt = "%s_len", *s = arg->fvarname;
-	switch(*s) {
-	  case 'r':
-		if (!strcmp(s+1, "et_val"))
-			goto adjust_fmt;
-		break;
-	  case 'h':
-	  case 'i':
-		if (!s[1]) {
- adjust_fmt:
-			fmt = "%s_length"; /* avoid conflict with libF77 */
-			}
-	  }
-	sprintf (buf, fmt, s);
-	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
-#ifdef KR_headers
-declare_new_addr(addrp)
-	struct Addrblock *addrp;
-#else
-declare_new_addr(struct Addrblock *addrp)
-#endif
-{
-    extern chainp new_vars;
-
-    new_vars = mkchain((char *)cpexpr((expptr)addrp), new_vars);
-} /* declare_new_addr */
-
-
- void
-#ifdef KR_headers
-wr_nv_ident_help(outfile, addrp)
-	FILE *outfile;
-	struct Addrblock *addrp;
-#else
-wr_nv_ident_help(FILE *outfile, struct Addrblock *addrp)
-#endif
-{
-    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
-#ifdef KR_headers
-nv_type_help(addrp)
-	struct Addrblock *addrp;
-#else
-nv_type_help(struct Addrblock *addrp)
-#endif
-{
-    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 *
-#ifdef KR_headers
-lit_name(litp)
-	struct Literal *litp;
-#else
-lit_name(struct Literal *litp)
-#endif
-{
-	static char buf[CONST_IDENT_MAX];
-	ftnint val;
-	char *fmt;
-
-	if (litp == (struct Literal *) NULL)
-		return NULL;
-
-	switch (litp -> littype) {
-	case TYINT1:
-		val = litp -> litval.litival;
-		if (val >= 256 || val < -255)
-			sprintf (buf, "ci1_b%ld", litp -> litnum);
-		else if (val < 0)
-			sprintf (buf, "ci1_n%ld", -val);
-		else
-			sprintf(buf, "ci1__%ld", val);
-		break;
-        case TYSHORT:
-		val = litp -> litval.litival;
-		if (val >= 32768 || val <= -32769)
-			sprintf (buf, "cs_b%ld", 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%ld", litp -> litnum);
-		else if (val < 0)
-			sprintf (buf, "c_n%ld", -val);
-		else
-			sprintf (buf, "c__%ld", val);
-		break;
-	case TYLOGICAL1:
-		fmt = "cl1_%s";
-		goto spr_logical;
-	case TYLOGICAL2:
-		fmt = "cl2_%s";
-		goto spr_logical;
-	case TYLOGICAL:
-		fmt = "c_%s";
-	spr_logical:
-		sprintf (buf, fmt, (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%ld", litp -> litnum);
-    } /* switch */
-    return buf;
-} /* lit_name */
-
-
-
- char *
-#ifdef KR_headers
-comm_union_name(count)
-	int count;
-#else
-comm_union_name(int count)
-#endif
-{
-	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 */
-
- void
-#ifdef KR_headers
-wr_globals(outfile)
-	FILE *outfile;
-#else
-wr_globals(FILE *outfile)
-#endif
-{
-    struct Literal *litp, *lastlit;
-    extern int hsize;
-    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
-#ifdef KR_headers
-commlen(vl)
-	register chainp vl;
-#else
-commlen(register chainp vl)
-#endif
-{
-	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. */
-#ifdef KR_headers
-pad_common(c)
-	Extsym *c;
-#else
-pad_common(Extsym *c)
-#endif
-{
-	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
-
- void
-#ifdef KR_headers
-wr_common_decls(outfile)
-	FILE *outfile;
-#else
-wr_common_decls(FILE *outfile)
-#endif
-{
-    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 */
-
- void
-#ifdef KR_headers
-wr_struct(outfile, var_list)
-	FILE *outfile;
-	chainp var_list;
-#else
-wr_struct(FILE *outfile, chainp var_list)
-#endif
-{
-    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;
-
-	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 *
-#ifdef KR_headers
-user_label(stateno)
-	ftnint stateno;
-#else
-user_label(ftnint stateno)
-#endif
-{
-	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 *
-#ifdef KR_headers
-temp_name(starter, num, storage)
-	char *starter;
-	int num;
-	char *storage;
-#else
-temp_name(char *starter, int num, char *storage)
-#endif
-{
-    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 *
-#ifdef KR_headers
-equiv_name(memno, store)
-	int memno;
-	char *store;
-#else
-equiv_name(int memno, char *store)
-#endif
-{
-    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
-#ifdef KR_headers
-def_commons(of)
-	FILE *of;
-#else
-def_commons(FILE *of)
-#endif
-{
-	Extsym *ext;
-	int c, onefile, Union;
-	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(outbtail, "%scom.c", ext->cextname);
-			if (onefile)
-				fprintf(of, "/*>>>'%s'<<<*/\n",
-					outbtail);
-			else {
-				c_file = of = fopen(outbuf,textwrite);
-				if (!of)
-					fatalstr("can't open %s", outbuf);
-				}
-			fprintf(of, "#include \"f2c.h\"\n");
-			if (Ansi == 2)
-				fprintf(of,
-			 "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n\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 (Ansi == 2)
-				fprintf(of,
-			 "\n#ifdef __cplusplus\n}\n#endif\n");
-			if (onefile)
-				fprintf(of, "/*<<<%s>>>*/\n", outbtail);
-			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",
-	"addr", "address", "aerr", "alist", "asin", "asm", "atan",
-	"atan2", "aunit", "auto", "break", "c", "case", "catch", "cdecl",
-	"cerr", "char", "ciend", "cierr", "cifmt", "cilist", "cirec",
-	"ciunit", "class", "cllist", "complex", "const", "continue", "cos",
-	"cosh", "csta", "cunit", "d", "dabs", "default", "defined",
-	"delete", "dims", "dmax", "dmin", "do", "double",
-	"doublecomplex", "doublereal", "else", "entry", "enum", "exp",
-	"extern", "false", "far", "flag", "float", "for", "friend",
-	"ftnint", "ftnlen", "goto", "h", "huge", "i", "iciend", "icierr",
-	"icifmt", "icilist", "icirlen", "icirnum", "iciunit", "if",
-	"inacc", "inacclen", "inblank", "inblanklen", "include",
-	"indir", "indirlen", "inerr", "inex", "infile", "infilen",
-	"infmt", "infmtlen", "inform", "informlen", "inline", "inlist",
-	"inname", "innamed", "innamlen", "innrec", "innum", "inopen",
-	"inrecl", "inseq", "inseqlen", "int", "integer", "integer1",
-	"inunf", "inunflen", "inunit", "log", "logical", "logical1",
-	"long", "longint", "max", "min", "name", "near", "new", "nvars",
-	"oacc", "oblnk", "oerr", "ofm", "ofnm", "ofnmlen", "olist",
-	"operator", "orl", "osta", "ounit", "overload", "private",
-	"protected", "public", "r", "real", "register", "return",
-	"short", "shortint", "shortlogical", "signed", "sin", "sinh",
-	"sizeof", "sqrt", "static", "struct", "switch", "tan", "tanh",
-	"template", "this", "true", "try", "type", "typedef", "uinteger",
-	"ulongint", "union", "unsigned", "vars", "virtual", "void",
-	"volatile", "while", "z"
-	}; /* c_keywords */
-
-int n_keywords = sizeof(c_keywords)/sizeof(char *);
diff --git a/contrib/tools/f2c/src/names.h b/contrib/tools/f2c/src/names.h
deleted file mode 100644
index 16bcc0b4bad..00000000000
--- a/contrib/tools/f2c/src/names.h
+++ /dev/null
@@ -1,19 +0,0 @@
-#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*	c_type_decl Argdcl((int, int));
-void	declare_new_addr Argdcl((Addrp));
-char*	new_arg_length Argdcl((Namep));
-char*	new_func_length Argdcl((void));
-int	nv_type_help Argdcl((Addrp));
-char*	temp_name Argdcl((char*, int, char*));
-char*	user_label Argdcl((long int));
diff --git a/contrib/tools/f2c/src/niceprintf.c b/contrib/tools/f2c/src/niceprintf.c
deleted file mode 100644
index a32411c4e35..00000000000
--- a/contrib/tools/f2c/src/niceprintf.c
+++ /dev/null
@@ -1,445 +0,0 @@
-/****************************************************************
-Copyright 1990, 1991, 1993, 1994, 2000 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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 KR_headers
-#include "stdarg.h"
-#endif
-
-#define TOO_LONG_INDENT (2 * tab_size)
-#define MAX_INDENT 44
-#define MIN_INDENT 22
-static int last_was_newline = 0;
-int sharp_line = 0;
-int indent = 0;
-int in_comment = 0;
-int in_define = 0;
- extern int gflag1;
- extern char filename[];
-
- static void ind_printf Argdcl((int, FILE*, const char*, va_list));
-
- static void
-#ifdef KR_headers
-write_indent(fp, use_indent, extra_indent, start, end)
-	FILE *fp;
-	int use_indent;
-	int extra_indent;
-	char *start;
-	char *end;
-#else
-write_indent(FILE *fp, int use_indent, int extra_indent, char *start, char *end)
-#endif
-{
-    int ind, tab;
-
-    if (sharp_line) {
-	fprintf(fp, "#line %ld \"%s\"\n", lineno, filename);
-	sharp_line = 0;
-	}
-    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 */
-
-#ifdef KR_headers
-/*VARARGS2*/
-  void
- 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*/
-  void
- 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 SPRINTF(x,a,b,c,d,e,f,g) sprintf(x,a,b,c,d,e,f,g)
-
-#else /* if (!defined(KR_HEADERS)) */
-
-#define SPRINTF(x,a,b,c,d,e,f,g) vsprintf(x,a,ap)
-
-  void
- margin_printf(FILE *fp, const char *fmt, ...)
-{
-	va_list ap;
-	va_start(ap,fmt);
-	ind_printf(0, fp, fmt, ap);
-	va_end(ap);
-	}
-
-  void
- nice_printf(FILE *fp, const char *fmt, ...)
-{
-	va_list ap;
-	va_start(ap,fmt);
-	ind_printf(1, fp, fmt, ap);
-	va_end(ap);
-	}
-#endif
-
-#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(Void)
-{
-	next_slot = output_buf = Alloc(MAX_OUTPUT_SIZE);
-	memset(output_buf, 0, MAX_OUTPUT_SIZE);
-	}
-
- static char *
-#ifdef KR_headers
-adjust_pointer_in_string(pointer)
-	register char *pointer;
-#else
-adjust_pointer_in_string(register char *pointer)
-#endif
-{
-	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
-#ifdef KR_headers
-fwd_strcpy(t, s)
-	register char *t;
-	register char *s;
-#else
-fwd_strcpy(register char *t, register char *s)
-#endif
-{ 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])
-
-  static void
-#ifdef KR_headers
- 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;
-#else
- ind_printf (int use_indent, FILE *fp, const char *a, va_list ap)
-#endif
-{
-    extern int max_line_len;
-    extern FILEP c_file;
-    extern char tr_tab[];	/* in output.c */
-    register char *Tr = tr_tab;
-    int ch, cmax, 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;
-    } /* 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 = extra_indent;
-		if (use_indent)
-			cursor_pos += ind;
-		set_cursor = 0;
-		}
-	if (in_comment) {
-		cmax = max_line_len + 32;	/* let comments be wider */
-        	for (pointer = next_slot; *pointer && *pointer != '\n' &&
-				cursor_pos <= cmax; 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;
-			sharp_line = gflag1;
-			}
-		}
-	    else {
-		extra_indent = TOO_LONG_INDENT;
-		if (In_string && !string_start) {
-			if (Ansi == 1) {
-				fprintf(fp, gflag1 ? "\"\\\n" : "\"\n");
-				use_indent = 1;
-				last_was_newline = 1;
-				}
-			else {
-				fprintf(fp, "\\\n");
-				last_was_newline = 0;
-				}
-			In_string = in_string0;
-			}
-		else {
-			if (in_define/* | gflag1*/)
-				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);
-
-} /* ind_printf */
diff --git a/contrib/tools/f2c/src/niceprintf.h b/contrib/tools/f2c/src/niceprintf.h
deleted file mode 100644
index 24c65d4db0c..00000000000
--- a/contrib/tools/f2c/src/niceprintf.h
+++ /dev/null
@@ -1,16 +0,0 @@
-/* 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/contrib/tools/f2c/src/output.c b/contrib/tools/f2c/src/output.c
deleted file mode 100644
index c734ca94bcb..00000000000
--- a/contrib/tools/f2c/src/output.c
+++ /dev/null
@@ -1,1753 +0,0 @@
-/****************************************************************
-Copyright 1990-1996, 2000-2001 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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)" },
-	/* OPBITTEST 62 */	{ BINARY_OP,   0, "bit_test(%l,%r)" },
-	/* OPBITCLR 63 */	{ BINARY_OP,   0, "bit_clear(%l,%r)" },
-	/* OPBITSET 64 */	{ BINARY_OP,   0, "bit_set(%l,%r)" },
-#ifdef TYQUAD
-	/* OPQBITCLR 65 */	{ BINARY_OP,   0, "qbit_clear(%l,%r)" },
-	/* OPQBITSET 66 */	{ BINARY_OP,   0, "qbit_set(%l,%r)" },
-#endif
-
-/* 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)
-
-extern int dneg, trapuv;
-static char opeqable[sizeof(opcode_table)/sizeof(table_entry)];
-
-
-static void output_arg_list Argdcl((FILEP, struct Listblock*));
-static void output_binary Argdcl((FILEP, Exprp));
-static void output_list Argdcl((FILEP, struct Listblock*));
-static void output_literal Argdcl((FILEP, long, Constp));
-static void output_prim Argdcl((FILEP, struct Primblock*));
-static void output_unary Argdcl((FILEP, Exprp));
-
-
- void
-#ifdef KR_headers
-expr_out(fp, e)
-	FILE *fp;
-	expptr e;
-#else
-expr_out(FILE *fp, expptr e)
-#endif
-{
-	Namep var;
-	expptr leftp, rightp;
-	int opcode;
-
-    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:	if (!nerr)
-				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)
-      switch(e->exprblock.rightp->tag) {
-	case TEXPR:
-	opcode = e -> exprblock.rightp -> exprblock.opcode;
-
-	if (opeqable[opcode]) {
-	    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 || */
-	break;
-
-	case TNAME:
-	  if (trapuv) {
-		var = &e->exprblock.rightp->nameblock;
-		if (ISREAL(var->vtype)
-		 && var->vclass == CLVAR
-		 && ONEOF(var->vstg, M(STGAUTO)|M(STGBSS))
-		 && !var->vsave) {
-			expr_out(fp, e -> exprblock.leftp);
-			nice_printf(fp, " = _0 + ");
-			expr_out(fp, e->exprblock.rightp);
-			goto done;
-			}
-		}
-      } /* if e -> exprblock.opcode == OPASSIGN */
-
-
-/* Optimize on increment or decrement by 1 */
-
-    {
-	opcode = e -> exprblock.opcode;
-	leftp = e -> exprblock.leftp;
-	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);
-
- done:
-    free((char *)e);
-
-} /* expr_out */
-
-
- void
-#ifdef KR_headers
-out_and_free_statement(outfile, expr)
-	FILE *outfile;
-	expptr expr;
-#else
-out_and_free_statement(FILE *outfile, expptr expr)
-#endif
-{
-    if (expr)
-	expr_out (outfile, expr);
-
-    nice_printf (outfile, ";\n");
-} /* out_and_free_statement */
-
-
-
- int
-#ifdef KR_headers
-same_ident(left, right)
-	expptr left;
-	expptr right;
-#else
-same_ident(expptr left, expptr right)
-#endif
-{
-    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
-#ifdef KR_headers
-samefpconst(c1, c2, n)
-	register Constp c1;
-	register Constp c2;
-	register int n;
-#else
-samefpconst(register Constp c1, register Constp c2, register int n)
-#endif
-{
-	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
-#ifdef KR_headers
-sameconst(c1, c2)
-	register Constp c1;
-	register Constp c2;
-#else
-sameconst(register Constp c1, register Constp c2)
-#endif
-{
-	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
-#ifdef KR_headers
-same_expr(e1, e2)
-	expptr e1;
-	expptr e2;
-#else
-same_expr(expptr e1, expptr e2)
-#endif
-{
-    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
-#ifdef KR_headers
-out_name(fp, namep)
-	FILE *fp;
-	Namep namep;
-#else
-out_name(FILE *fp, Namep namep)
-#endif
-{
-    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 */
-
-
-#define cpd(n) cp->vstg ? cp->Const.cds[n] : dtos(cp->Const.cd[n])
-
- void
-#ifdef KR_headers
-out_const(fp, cp)
-	FILE *fp;
-	register Constp cp;
-#else
-out_const(FILE *fp, register Constp cp)
-#endif
-{
-    static char real_buf[50], imag_buf[50];
-    ftnint j;
-    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 TYQUAD0
-	case TYQUAD:
-#endif
-	    nice_printf (fp, "%ld", cp->Const.ci);	/* don't cast ci! */
-	    break;
-#ifndef NO_LONG_LONG
-	case TYQUAD:
-		if (cp->Const.cd[1] == 123.456)
-			nice_printf (fp, "%s", cp->Const.cds[0]);
-		else
-			nice_printf (fp, "%lld", cp->Const.cq);
-		break;
-#endif
-	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]);
-		}
-	    for(j = cp->Const.ccp1.blanks; j > 0; j--)
-		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
-#ifdef KR_headers
-out_args(fp, ep)
-	FILE *fp;
-	expptr ep;
-#else
-out_args(FILE *fp, expptr ep)
-#endif
-{
-	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
-#ifdef KR_headers
-out_addr(fp, addrp)
-	FILE *fp;
-	struct Addrblock *addrp;
-#else
-out_addr(FILE *fp, struct Addrblock *addrp)
-#endif
-{
-	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, 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
-#ifdef KR_headers
-output_literal(fp, memno, cp)
-	FILE *fp;
-	long memno;
-	Constp cp;
-#else
-output_literal(FILE *fp, long memno, Constp cp)
-#endif
-{
-    struct Literal *litp, *lastlit;
-
-    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
-#ifdef KR_headers
-output_prim(fp, primp)
-	FILE *fp;
-	struct Primblock *primp;
-#else
-output_prim(FILE *fp, struct Primblock *primp)
-#endif
-{
-    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
-#ifdef KR_headers
-output_arg_list(fp, listp)
-	FILE *fp;
-	struct Listblock *listp;
-#else
-output_arg_list(FILE *fp, struct Listblock *listp)
-#endif
-{
-    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
-#ifdef KR_headers
-output_unary(fp, e)
-	FILE *fp;
-	struct Exprblock *e;
-#else
-output_unary(FILE *fp, struct Exprblock *e)
-#endif
-{
-    if (e == NULL)
-	return;
-
-    switch (e -> opcode) {
-        case OPNEG:
-		if (e->vtype == TYREAL && dneg) {
-			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 *
-#ifdef KR_headers
-findconst(m)
-	register long m;
-#else
-findconst(register long m)
-#endif
-{
-	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
-#ifdef KR_headers
-opconv_fudge(fp, e)
-	FILE *fp;
-	struct Exprblock *e;
-#else
-opconv_fudge(FILE *fp, struct Exprblock *e)
-#endif
-{
-	/* special handling for conversions, ichar and character*1 */
-	register expptr lp;
-	register union Expression *Offset;
-	register char *cp;
-	int lt;
-	char buf[8], *s;
-	unsigned int k;
-	Namep np;
-	Addrp ap;
-
-	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, "*(unsigned char *)");
-				out_name(fp, (Namep)lp);
-				return 1;
-			case TCONST:
- tconst:
-				cp = lp->constblock.Const.ccp;
- tconst1:
-				k = *(unsigned char *)cp;
-				if (k < 128) { /* ASCII character */
-					sprintf(buf, chr_fmt[k], k);
-					nice_printf(fp, "'%s'", buf);
-					}
-				else
-					nice_printf(fp, "%d", k);
-				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, "*(unsigned char *)");
-					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;
-				nice_printf(fp, "*(unsigned char *)&");
-				return 0;
-			default:
-				badtag("opconv_fudge", lp->tag);
-			}
-		}
-	if (lt != e->vtype) {
-		s = c_type_decl(e->vtype, 0);
-		if (ISCOMPLEX(lt)) {
- tryagain:
-			np = (Namep)e->leftp;
-			switch(np->tag) {
-			  case TNAME:
-				nice_printf(fp, "(%s) %s%sr", s,
-					np->cvarname,
-					np->vstg == STGARG ? "->" : ".");
-				return 1;
-			  case TADDR:
-				ap = (Addrp)np;
-				switch(ap->uname_tag) {
-				  case UNAM_IDENT:
-					nice_printf(fp, "(%s) %s.r", s,
-						ap->user.ident);
-					return 1;
-				  case UNAM_NAME:
-					nice_printf(fp, "(%s) ", s);
-					out_addr(fp, ap);
-					nice_printf(fp, ".r");
-					return 1;
-				  case UNAM_REF:
-					nice_printf(fp, "(%s) %s_%s(",
-					 s, ap->user.name->cvarname,
-					 ap->cmplx_sub ? "subscr" : "ref");
-					out_args(fp, ap->memoffset);
-					nice_printf(fp, ").r");
-					return 1;
-				  default:
-					fatali(
-					 "Bad uname_tag %d in opconv_fudge",
-						ap->uname_tag);
-				  }
-			  case TEXPR:
-				e = (Exprp)np;
-				if (e->opcode == OPWHATSIN)
-					goto tryagain;
-			  default:
-				fatali("Unexpected tag %d in opconv_fudge",
-					np->tag);
-			  }
-			}
-		nice_printf(fp, "(%s) ", s);
-		}
-	return 0;
-	}
-
-
- static void
-#ifdef KR_headers
-output_binary(fp, e)
-	FILE *fp;
-	struct Exprblock *e;
-#else
-output_binary(FILE *fp, struct Exprblock *e)
-#endif
-{
-    char *format;
-    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 */
-
- void
-#ifdef KR_headers
-out_call(outfile, op, ftype, len, name, args)
-	FILE *outfile;
-	int op;
-	int ftype;
-	expptr len;
-	expptr name;
-	expptr args;
-#else
-out_call(FILE *outfile, int op, int ftype, expptr len, expptr name, expptr args)
-#endif
-{
-    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 */
-
-    /* prepare to cast procedure parameters -- set A if we know how */
-    np = name->tag == TEXPR && name->exprblock.opcode == OPWHATSIN
-	? (Namep)name->exprblock.leftp : (Namep)name;
-
-    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;
-    	}
-
-/* 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, "(");
-	expr_out (outfile, name);
-	nice_printf (outfile, ")");
-	}
-    else
-	expr_out(outfile, name);
-
-    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 (q->constblock.vtype == TYLONG)
-			nice_printf(outfile, "(ftnlen)%ld",
-				q->constblock.Const.ci);
-		else
-			out_const(outfile, &q->constblock);
-	    }
-
-/* 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 (q->headblock.vtype == TYREAL) {
-		if (forcereal) {
-			nice_printf(outfile, "(real)");
-			use_paren = 1;
-			}
-		}
-	    else if (!Ansi && ISINT(q->headblock.vtype)) {
-		nice_printf(outfile, "(ftnlen)");
-		use_paren = 1;
-		}
-	    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 *
-#ifdef KR_headers
-flconst(buf, x)
-	char *buf;
-	char *x;
-#else
-flconst(char *buf, char *x)
-#endif
-{
-	sprintf(buf, fl_fmt_string, x);
-	return buf;
-	}
-
- char *
-#ifdef KR_headers
-dtos(x)
-	double x;
-#else
-dtos(double x)
-#endif
-{
-	static char buf[64];
-#ifdef USE_DTOA
-	g_fmt(buf, x);
-#else
-	sprintf(buf, db_fmt_string, x);
-#endif
-	return strcpy(mem(strlen(buf)+1,0), 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(Void)
-{
-    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 = (char*)(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
-#ifdef KR_headers
-extern_out(fp, extsym)
-	FILE *fp;
-	Extsym *extsym;
-#else
-extern_out(FILE *fp, Extsym *extsym)
-#endif
-{
-    if (extsym == (Extsym *) NULL)
-	return;
-
-    nice_printf (fp, "%s", extsym->cextname);
-
-} /* extern_out */
-
-
-
- static void
-#ifdef KR_headers
-output_list(fp, listp)
-	FILE *fp;
-	struct Listblock *listp;
-#else
-output_list(FILE *fp, struct Listblock *listp)
-#endif
-{
-    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
-#ifdef KR_headers
-out_asgoto(outfile, expr)
-	FILE *outfile;
-	expptr expr;
-#else
-out_asgoto(FILE *outfile, expptr expr)
-#endif
-{
-    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
-#ifdef KR_headers
-out_if(outfile, expr)
-	FILE *outfile;
-	expptr expr;
-#else
-out_if(FILE *outfile, expptr expr)
-#endif
-{
-    nice_printf (outfile, "if (");
-    expr_out (outfile, expr);
-    nice_printf (outfile, ") {\n");
-    next_tab (outfile);
-} /* out_if */
-
- static void
-#ifdef KR_headers
-output_rbrace(outfile, s)
-	FILE *outfile;
-	char *s;
-#else
-output_rbrace(FILE *outfile, char *s)
-#endif
-{
-	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
-#ifdef KR_headers
-out_else(outfile)
-	FILE *outfile;
-#else
-out_else(FILE *outfile)
-#endif
-{
-    prev_tab (outfile);
-    output_rbrace(outfile, "} else {\n");
-    next_tab (outfile);
-} /* out_else */
-
- void
-#ifdef KR_headers
-elif_out(outfile, expr)
-	FILE *outfile;
-	expptr expr;
-#else
-elif_out(FILE *outfile, expptr expr)
-#endif
-{
-    prev_tab (outfile);
-    output_rbrace(outfile, "} else ");
-    out_if (outfile, expr);
-} /* elif_out */
-
- void
-#ifdef KR_headers
-endif_out(outfile)
-	FILE *outfile;
-#else
-endif_out(FILE *outfile)
-#endif
-{
-    prev_tab (outfile);
-    output_rbrace(outfile, "}\n");
-} /* endif_out */
-
- void
-#ifdef KR_headers
-end_else_out(outfile)
-	FILE *outfile;
-#else
-end_else_out(FILE *outfile)
-#endif
-{
-    prev_tab (outfile);
-    output_rbrace(outfile, "}\n");
-} /* end_else_out */
-
-
-
- void
-#ifdef KR_headers
-compgoto_out(outfile, index, labels)
-	FILE *outfile;
-	expptr index;
-	expptr labels;
-#else
-compgoto_out(FILE *outfile, expptr index, expptr labels)
-#endif
-{
-    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 {
-	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
-#ifdef KR_headers
-out_for(outfile, init, test, inc)
-	FILE *outfile;
-	expptr init;
-	expptr test;
-	expptr inc;
-#else
-out_for(FILE *outfile, expptr init, expptr test, expptr inc)
-#endif
-{
-    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
-#ifdef KR_headers
-out_end_for(outfile)
-	FILE *outfile;
-#else
-out_end_for(FILE *outfile)
-#endif
-{
-    prev_tab (outfile);
-    nice_printf (outfile, "}\n");
-} /* out_end_for */
diff --git a/contrib/tools/f2c/src/output.h b/contrib/tools/f2c/src/output.h
deleted file mode 100644
index 97e3a0ad09b..00000000000
--- a/contrib/tools/f2c/src/output.h
+++ /dev/null
@@ -1,64 +0,0 @@
-/* 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"
-
-
-/* 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	compgoto_out Argdcl((FILEP, tagptr, tagptr));
-void	endif_out Argdcl((FILEP));
-void	expr_out Argdcl((FILEP, tagptr));
-void	out_and_free_statement Argdcl((FILEP, tagptr));
-void	out_end_for Argdcl((FILEP));
-void	out_if Argdcl((FILEP, tagptr));
-void	out_name Argdcl((FILEP, Namep));
diff --git a/contrib/tools/f2c/src/p1defs.h b/contrib/tools/f2c/src/p1defs.h
deleted file mode 100644
index c76af229574..00000000000
--- a/contrib/tools/f2c/src/p1defs.h
+++ /dev/null
@@ -1,158 +0,0 @@
-#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 */
-
-void	p1_asgoto Argdcl((Addrp));
-void	p1_comment Argdcl((char*));
-void	p1_elif Argdcl((tagptr));
-void	p1_else Argdcl((void));
-void	p1_endif Argdcl((void));
-void	p1_expr Argdcl((tagptr));
-void	p1_for Argdcl((tagptr, tagptr, tagptr));
-void	p1_goto Argdcl((long int));
-void	p1_head Argdcl((int, char*));
-void	p1_if Argdcl((tagptr));
-void	p1_label Argdcl((long int));
-void	p1_line_number Argdcl((long int));
-void	p1_subr_ret Argdcl((tagptr));
-void	p1comp_goto Argdcl((tagptr, int, struct Labelblock**));
-void	p1else_end Argdcl((void));
-void	p1for_end Argdcl((void));
-void	p1put Argdcl((int));
-void	p1puts Argdcl((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/contrib/tools/f2c/src/p1output.c b/contrib/tools/f2c/src/p1output.c
deleted file mode 100644
index 5afc7473833..00000000000
--- a/contrib/tools/f2c/src/p1output.c
+++ /dev/null
@@ -1,728 +0,0 @@
-/****************************************************************
-Copyright 1990, 1991, 1993, 1994, 1999-2001 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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 Argdcl((Addrp));
-static void p1_big_addr Argdcl((Addrp));
-static void p1_binary Argdcl((Exprp));
-static void p1_const Argdcl((Constp));
-static void p1_list Argdcl((struct Listblock*));
-static void p1_literal Argdcl((long int));
-static void p1_name Argdcl((Namep));
-static void p1_unary Argdcl((Exprp));
-static void p1putd Argdcl((int, long int));
-static void p1putdd Argdcl((int, int, int));
-static void p1putddd Argdcl((int, int, int, int));
-static void p1putdds Argdcl((int, int, int, char*));
-static void p1putds Argdcl((int, int, char*));
-static void p1putn Argdcl((int, int, char*));
-
-
-/* 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
-#ifdef KR_headers
-p1_comment(str)
-	char *str;
-#else
-p1_comment(char *str)
-#endif
-{
-    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
-#ifdef KR_headers
-p1_name(namep)
-	Namep namep;
-#else
-p1_name(Namep namep)
-#endif
-{
-	p1putd (P1_NAME_POINTER, (long) namep);
-	namep->visused = 1;
-} /* p1_name */
-
-
-
- void
-#ifdef KR_headers
-p1_expr(expr)
-	expptr expr;
-#else
-p1_expr(expptr expr)
-#endif
-{
-/* 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
-#ifdef KR_headers
-p1_const(cp)
-	register Constp cp;
-#else
-p1_const(register Constp cp)
-#endif
-{
-	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 TYQUAD0
-	case TYQUAD:
-#endif
-	case TYLOGICAL:
-	case TYLOGICAL1:
-	case TYLOGICAL2:
-	    fprintf(pass1_file, "%d: %d %ld\n", P1_CONST, type, c->ci);
-	    break;
-#ifndef NO_LONG_LONG
-	case TYQUAD:
-	    fprintf(pass1_file, "%d: %d %llx\n", P1_CONST, type, c->cq);
-	    break;
-#endif
-	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))
-		err("p1_const:  bad vleng\n");
-	    else
-		fprintf(pass1_file, "%d: %d %lx\n", P1_CONST, type,
-			(unsigned long)cpexpr((expptr)cp));
-	    break;
-	default:
-	    erri ("p1_const:  bad constant type '%d'", type);
-	    break;
-    } /* switch */
-} /* p1_const */
-
-
- void
-#ifdef KR_headers
-p1_asgoto(addrp)
-	Addrp addrp;
-#else
-p1_asgoto(Addrp addrp)
-#endif
-{
-    p1put (P1_ASGOTO);
-    p1_addr (addrp);
-} /* p1_asgoto */
-
-
- void
-#ifdef KR_headers
-p1_goto(stateno)
-	ftnint stateno;
-#else
-p1_goto(ftnint stateno)
-#endif
-{
-    p1putd (P1_GOTO, stateno);
-} /* p1_goto */
-
-
- static void
-#ifdef KR_headers
-p1_addr(addrp)
-	register struct Addrblock *addrp;
-#else
-p1_addr(register struct Addrblock *addrp)
-#endif
-{
-    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
-#ifdef KR_headers
-p1_list(listp)
-	struct Listblock *listp;
-#else
-p1_list(struct Listblock *listp)
-#endif
-{
-    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
-#ifdef KR_headers
-p1_label(lab)
-	long lab;
-#else
-p1_label(long lab)
-#endif
-{
-	if (parstate < INDATA)
-		earlylabs = mkchain((char *)lab, earlylabs);
-	else
-		p1putd (P1_LABEL, lab);
-	}
-
-
-
- static void
-#ifdef KR_headers
-p1_literal(memno)
-	long memno;
-#else
-p1_literal(long memno)
-#endif
-{
-    p1putd (P1_LITERAL, memno);
-} /* p1_literal */
-
-
- void
-#ifdef KR_headers
-p1_if(expr)
-	expptr expr;
-#else
-p1_if(expptr expr)
-#endif
-{
-    p1put (P1_IF);
-    p1_expr (expr);
-} /* p1_if */
-
-
-
-
- void
-#ifdef KR_headers
-p1_elif(expr)
-	expptr expr;
-#else
-p1_elif(expptr expr)
-#endif
-{
-    p1put (P1_ELIF);
-    p1_expr (expr);
-} /* p1_elif */
-
-
-
-
- void
-p1_else(Void)
-{
-    p1put (P1_ELSE);
-} /* p1_else */
-
-
-
-
- void
-p1_endif(Void)
-{
-    p1put (P1_ENDIF);
-} /* p1_endif */
-
-
-
-
- void
-p1else_end(Void)
-{
-    p1put (P1_ENDELSE);
-} /* p1else_end */
-
-
- static void
-#ifdef KR_headers
-p1_big_addr(addrp)
-	Addrp addrp;
-#else
-p1_big_addr(Addrp addrp)
-#endif
-{
-    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
-#ifdef KR_headers
-p1_unary(e)
-	struct Exprblock *e;
-#else
-p1_unary(struct Exprblock *e)
-#endif
-{
-    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
-#ifdef KR_headers
-p1_binary(e)
-	struct Exprblock *e;
-#else
-p1_binary(struct Exprblock *e)
-#endif
-{
-    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
-#ifdef KR_headers
-p1_head(Class, name)
-	int Class;
-	char *name;
-#else
-p1_head(int Class, char *name)
-#endif
-{
-    p1putds (P1_HEAD, Class, (char*)(name ? name : ""));
-} /* p1_head */
-
-
- void
-#ifdef KR_headers
-p1_subr_ret(retexp)
-	expptr retexp;
-#else
-p1_subr_ret(expptr retexp)
-#endif
-{
-
-    p1put (P1_SUBR_RET);
-    p1_expr (cpexpr(retexp));
-} /* p1_subr_ret */
-
-
-
- void
-#ifdef KR_headers
-p1comp_goto(index, count, labels)
-	expptr index;
-	int count;
-	struct Labelblock **labels;
-#else
-p1comp_goto(expptr index, int count, struct Labelblock **labels)
-#endif
-{
-    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
-#ifdef KR_headers
-p1_for(init, test, inc)
-	expptr init;
-	expptr test;
-	expptr inc;
-#else
-p1_for(expptr init, expptr test, expptr inc)
-#endif
-{
-    p1put (P1_FOR);
-    p1_expr (init);
-    p1_expr (test);
-    p1_expr (inc);
-} /* p1_for */
-
-
- void
-p1for_end(Void)
-{
-    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
-#ifdef KR_headers
-p1puts(type, str)
-	int type;
-	char *str;
-#else
-p1puts(int type, char *str)
-#endif
-{
-    fprintf (pass1_file, "%d: %s\n", type, str);
-} /* p1puts */
-
-
-/* p1putd -- Put a typed integer into the Pass 1 intermediate file. */
-
- static void
-#ifdef KR_headers
-p1putd(type, value)
-	int type;
-	long value;
-#else
-p1putd(int type, long value)
-#endif
-{
-    fprintf (pass1_file, "%d: %ld\n", type, value);
-} /* p1_putd */
-
-
-/* p1putdd -- Put a typed pair of integers into the intermediate file. */
-
- static void
-#ifdef KR_headers
-p1putdd(type, v1, v2)
-	int type;
-	int v1;
-	int v2;
-#else
-p1putdd(int type, int v1, int v2)
-#endif
-{
-    fprintf (pass1_file, "%d: %d %d\n", type, v1, v2);
-} /* p1putdd */
-
-
-/* p1putddd -- Put a typed triple of integers into the intermediate file. */
-
- static void
-#ifdef KR_headers
-p1putddd(type, v1, v2, v3)
-	int type;
-	int v1;
-	int v2;
-	int v3;
-#else
-p1putddd(int type, int v1, int v2, int v3)
-#endif
-{
-    fprintf (pass1_file, "%d: %d %d %d\n", type, v1, v2, v3);
-} /* p1putddd */
-
- union dL {
-	double d;
-	long L[2];
-	};
-
- static void
-#ifdef KR_headers
-p1putn(type, count, str)
-	int type;
-	int count;
-	char *str;
-#else
-p1putn(int type, int count, char *str)
-#endif
-{
-    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
-#ifdef KR_headers
-p1put(type)
-	int type;
-#else
-p1put(int type)
-#endif
-{
-    fprintf (pass1_file, "%d:\n", type);
-} /* p1put */
-
-
-
- static void
-#ifdef KR_headers
-p1putds(type, i, str)
-	int type;
-	int i;
-	char *str;
-#else
-p1putds(int type, int i, char *str)
-#endif
-{
-    fprintf (pass1_file, "%d: %d %s\n", type, i, str);
-} /* p1putds */
-
-
- static void
-#ifdef KR_headers
-p1putdds(token, type, stg, str)
-	int token;
-	int type;
-	int stg;
-	char *str;
-#else
-p1putdds(int token, int type, int stg, char *str)
-#endif
-{
-    fprintf (pass1_file, "%d: %d %d %s\n", token, type, stg, str);
-} /* p1putdds */
diff --git a/contrib/tools/f2c/src/parse.h b/contrib/tools/f2c/src/parse.h
deleted file mode 100644
index 6de239944a9..00000000000
--- a/contrib/tools/f2c/src/parse.h
+++ /dev/null
@@ -1,47 +0,0 @@
-#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;
-
-#ifdef KR_headers
-#define Argdcl(x) ()
-#else
-#define Argdcl(x) x
-#endif
-int	arg_verify Argdcl((char**, arg_info*, int));
-void	init_store Argdcl((arg_info*, int));
-int	match_table Argdcl((char*, arg_info*, int, int, int*));
-int	parse_args Argdcl((int, char**, arg_info*, int, char**, int));
-
-#endif
diff --git a/contrib/tools/f2c/src/parse_args.c b/contrib/tools/f2c/src/parse_args.c
deleted file mode 100644
index dd7b78102ac..00000000000
--- a/contrib/tools/f2c/src/parse_args.c
+++ /dev/null
@@ -1,558 +0,0 @@
-/****************************************************************
-Copyright 1990, 1994-5, 2001 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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
-#ifdef KR_headers
-extern double atof();
-#else
-#include "stdlib.h"
-#include "string.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;
-
-
-static char *this_program = "";
-
-static int arg_parse Argdcl((char*, arg_info*));
-static char *lower_string Argdcl((char*, char*));
-static int match Argdcl((char*, char*, arg_info*, boolean));
-static int put_one_arg Argdcl((int, char*, char**, char*, char*));
-extern int badargs;
-
-
- boolean
-#ifdef KR_headers
-parse_args(argc, argv, table, entries, others, other_count)
-	int argc;
-	char **argv;
-	arg_info *table;
-	int entries;
-	char **others;
-	int other_count;
-#else
-parse_args(int argc, char **argv, arg_info *table, int entries, char **others, int other_count)
-#endif
-{
-    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);
-			badargs++;
-		    } /* else */
-		} /* if (others) */
-		argv0 = *++argv;
-		argc--;
-		use_prefix = TRUE;
-	    } 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
-#ifdef KR_headers
-arg_verify(argv, table, entries)
-	char **argv;
-	arg_info *table;
-	int entries;
-#else
-arg_verify(char **argv, arg_info *table, int entries)
-#endif
-{
-    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));
-	    badargs++;
-	} /* 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);
-		badargs++;
-	    } /* 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);
-		    badargs++;
-		} /* 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);
-		    badargs++;
-		    }
-	}
-
-/* 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);
-		badargs++;
-	    } /* 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
-#ifdef KR_headers
-match_table(norm_input, table, entries, use_prefix, length)
-	register char *norm_input;
-	arg_info *table;
-	int entries;
-	boolean use_prefix;
-	int *length;
-#else
-match_table(register char *norm_input, arg_info *table, int entries, boolean use_prefix, int *length)
-#endif
-{
-    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
-*/
-
- static int
-#ifdef KR_headers
-match(norm_input, low_input, entry, use_prefix)
-	char *norm_input;
-	char *low_input;
-	arg_info *entry;
-	boolean use_prefix;
-#else
-match(char *norm_input, char *low_input, arg_info *entry, boolean use_prefix)
-#endif
-{
-    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 */
-
-
- static char *
-#ifdef KR_headers
-lower_string(dest, src)
-	char *dest;
-	char *src;
-#else
-lower_string(char *dest, char *src)
-#endif
-{
-    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
-#ifdef KR_headers
-arg_parse(str, entry)
-	char *str;
-	arg_info *entry;
-#else
-arg_parse(char *str, arg_info *entry)
-#endif
-{
-    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 */
-
-
- static int
-#ifdef KR_headers
-put_one_arg(type, str, store, prefix, string)
-	int type;
-	char *str;
-	char **store;
-	char *prefix;
-	char *string;
-#else
-put_one_arg(int type, char *str, char **store, char *prefix, char *string)
-#endif
-{
-    int length = 0;
-    long L;
-
-    if (store) {
-	switch (type) {
-	    case P_STRING:
-	    case P_FILE:
-	    case P_OLD_FILE:
-	    case P_NEW_FILE:
-		if (str == NULL) {
-			fprintf(stderr, "%s: Missing argument after '%s%s'\n",
-				this_program, prefix, string);
-			length = 0;
-			badargs++;
-			}
-		else
-			length = strlen(*store = str);
-		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);
-		    badargs++;
-		    }
-		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);
-		    badargs++;
-		    }
-		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);
-		badargs++;
-		break;
-	} /* switch */
-    } /* if (store) */
-
-    return length;
-} /* put_one_arg */
-
-
- void
-#ifdef KR_headers
-init_store(table, entries)
-	arg_info *table;
-	int entries;
-#else
-init_store(arg_info *table, int entries)
-#endif
-{
-    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/contrib/tools/f2c/src/pccdefs.h b/contrib/tools/f2c/src/pccdefs.h
deleted file mode 100644
index bde81177a7b..00000000000
--- a/contrib/tools/f2c/src/pccdefs.h
+++ /dev/null
@@ -1,64 +0,0 @@
-/* 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/contrib/tools/f2c/src/pread.c b/contrib/tools/f2c/src/pread.c
deleted file mode 100644
index fc290779cb3..00000000000
--- a/contrib/tools/f2c/src/pread.c
+++ /dev/null
@@ -1,990 +0,0 @@
-/****************************************************************
-Copyright 1990, 1992, 1993, 1994, 2000 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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(Void)
-{
-	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
-#ifdef KR_headers
-badchar(c)
-	int c;
-#else
-badchar(int c)
-#endif
-{
-	fprintf(stderr,
-		"unexpected character 0x%.2x = '%c' on line %ld of %s\n",
-		c, c, Plineno, Pfname);
-	exit(2);
-	}
-
- static void
-bad_type(Void)
-{
-	fprintf(stderr,
-		"unexpected type \"%s\" on line %ld of %s\n",
-		Ptok, Plineno, Pfname);
-	exit(2);
-	}
-
- static void
-#ifdef KR_headers
-badflag(tname, option)
-	char *tname;
-	char *option;
-#else
-badflag(char *tname, char *option)
-#endif
-{
-	fprintf(stderr, "%s type from `f2c -%s` on line %ld of %s\n",
-		tname, option, Plineno, Pfname);
-	Pbad++;
-	}
-
- static void
-#ifdef KR_headers
-detected(msg)
-	char *msg;
-#else
-detected(char *msg)
-#endif
-{
-	fprintf(stderr,
-	"%sdetected on line %ld of %s\n", msg, Plineno, Pfname);
-	Pbad++;
-	}
-
-#if 0
- static void
-#ifdef KR_headers
-checklogical(k)
-	int k;
-#else
-checklogical(int k)
-#endif
-{
-	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
-#ifdef KR_headers
-checkreal(k)
-	int k;
-#else
-checkreal(int k)
-#endif
-{
-	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", (char*)(k ? "!R" : "R"));
-	}
-
- static void
-#ifdef KR_headers
-Pnotboth(e)
-	Extsym *e;
-#else
-Pnotboth(Extsym *e)
-#endif
-{
-	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
-#ifdef KR_headers
-numread(pf, n)
-	register FILE *pf;
-	int *n;
-#else
-numread(register FILE *pf, int *n)
-#endif
-{
-	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 Argdcl((int, Extsym*));
- static void Pbadret Argdcl((int ftype, Extsym *p));
-
- static int
-#ifdef KR_headers
-readref(pf, e, ftype)
-	register FILE *pf;
-	Extsym *e;
-	int ftype;
-#else
-readref(register FILE *pf, Extsym *e, int ftype)
-#endif
-{
-	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
-#ifdef KR_headers
-comlen(pf)
-	register FILE *pf;
-#else
-comlen(register FILE *pf)
-#endif
-{
-	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 = mkext1(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
-#ifdef KR_headers
-Ptoken(pf, canend)
-	FILE *pf;
-	int canend;
-#else
-Ptoken(FILE *pf, int canend)
-#endif
-{
-	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(Void)
-{
-	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
-#ifdef KR_headers
-wanted(i, what)
-	int i;
-	char *what;
-#else
-wanted(int i, char *what)
-#endif
-{
-	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
-#ifdef KR_headers
-Ptype(pf)
-	FILE *pf;
-#else
-Ptype(FILE *pf)
-#endif
-{
-	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 (!strncmp(Ptok+1, "nteger", 6)) {
-				if (!Ptok[7])
-					rv = TYLONG;
-				else if (Ptok[7] == '1' && !Ptok[8])
-					rv = TYINT1;
-				}
-			break;
-		case 'l':
-			if (!strncmp(Ptok+1, "ogical", 6)) {
-				if (!Ptok[7]) {
-					checklogical(1);
-					rv = TYLOGICAL;
-					}
-				else if (Ptok[7] == '1' && !Ptok[8])
-					rv = TYLOGICAL1;
-				}
-#ifdef TYQUAD
-			else if (!strcmp(Ptok+1,"ongint"))
-				rv = TYQUAD;
-#endif
-			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 = TYLOGICAL2;
-				}
-			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(Void)
-{
-	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
-#ifdef KR_headers
-Pbadmsg(msg, p)
-	char *msg;
-	Extsym *p;
-#else
-Pbadmsg(char *msg, Extsym *p)
-#endif
-{
-	Pbad++;
-	fprintf(stderr, "%s for %s (line %ld of %s):\n\t", msg,
-		p->fextname, Plineno, Pfname);
-	p->arginfo->nargs = -1;
-	}
-
- static void
-#ifdef KR_headers
-Pbadret(ftype, p)
-	int ftype;
-	Extsym *p;
-#else
-Pbadret(int ftype, Extsym *p)
-#endif
-{
-	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
-#ifdef KR_headers
-argverify(ftype, p)
-	int ftype;
-	Extsym *p;
-#else
-argverify(int ftype, Extsym *p)
-#endif
-{
-	Argtypes *at;
-	register Atype *aty;
-	int i, j, k;
-	register int *t, *te;
-	char buf1[32], buf2[32];
-
-	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, previously %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
-#ifdef KR_headers
-newarg(ftype, p)
-	int ftype;
-	Extsym *p;
-#else
-newarg(int ftype, Extsym *p)
-#endif
-{
-	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
-#ifdef KR_headers
-Pfile(fname)
-	char *fname;
-#else
-Pfile(char *fname)
-#endif
-{
-	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 = mkext1(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
-#ifdef KR_headers
-read_Pfiles(ffiles)
-	char **ffiles;
-#else
-read_Pfiles(char **ffiles)
-#endif
-{
-	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/contrib/tools/f2c/src/proc.c b/contrib/tools/f2c/src/proc.c
deleted file mode 100644
index 4d85be1e90f..00000000000
--- a/contrib/tools/f2c/src/proc.c
+++ /dev/null
@@ -1,1834 +0,0 @@
-/****************************************************************
-Copyright 1990, 1994-6, 2000-2001 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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"
-
-/* round a up to the nearest multiple of b:
-
-   a = b * floor ( (a + (b - 1)) / b )*/
-
-#undef roundup
-#define roundup(a,b)    ( b * ( (a+b-1)/b) )
-
-#define EXNULL (union Expression *)0
-
-static void dobss Argdcl((void));
-static void docomleng Argdcl((void));
-static void docommon Argdcl((void));
-static void doentry Argdcl((struct Entrypoint*));
-static void epicode Argdcl((void));
-static int nextarg Argdcl((int));
-static void retval Argdcl((int));
-
-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
-#ifdef KR_headers
-changedtype(q)
-	Namep q;
-#else
-changedtype(Namep q)
-#endif
-{
-	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
-#ifdef KR_headers
-unamstring(q, s)
-	register Addrp q;
-	register char *s;
-#else
-unamstring(register Addrp q, register char *s)
-#endif
-{
-	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(Void)	/* 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
-#ifdef KR_headers
-putentries(outfile)
-	FILE *outfile;
-#else
-putentries(FILE *outfile)
-#endif
-	/* put out wrappers for multiple entries */
-{
-	char base[MAXNAMELEN+4];
-	struct Entrypoint *e;
-	Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
-	chainp args, lengths;
-	int i, k, mt, nL, t, type;
-	extern char *dfltarg[], **dfltproc;
-
-	e = entries;
-	if (!e->enamep) /* only possible with erroneous input */
-		return;
-	nL = (nallargs + nallchargs) * sizeof(Namep *);
-	if (!nL)
-		nL = 8;
-	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) {
-			t = ((Namep)args->datap)->vtype;
-			nice_printf(outfile, ", %s", (np = *a)
-				? np->cvarname
-				: ((Namep)args->datap)->vclass == CLPROC
-				? dfltproc[((Namep)args->datap)->vimpltype
-					? (Castargs ? TYUNKNOWN : TYSUBR)
-					: t == TYREAL && forcedouble && !Castargs
-					? TYDREAL : t]
-				: dfltarg[((Namep)args->datap)->vtype]);
-			}
-		for(; a < Ae1; a++)
-			if (np = *a)
-				nice_printf(outfile, ", %s",
-					new_arg_length(np));
-			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
-#ifdef KR_headers
-entry_goto(outfile)
-	FILE *outfile;
-#else
-entry_goto(FILE *outfile)
-#endif
-{
-	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 */
-
- void
-newproc(Void)
-{
-	if(parstate != OUTSIDE)
-	{
-		execerr("missing end statement", CNULL);
-		endproc();
-	}
-
-	parstate = INSIDE;
-	procclass = CLMAIN;	/* default */
-}
-
- static void
-zap_changes(Void)
-{
-	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 */
-
- void
-endproc(Void)
-{
-	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. */
-
- void
-enddcl(Void)
-{
-	register struct Entrypoint *ep;
-	struct Entrypoint *ep0;
-	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 */
-
- void
-#ifdef KR_headers
-startproc(progname, Class)
-	Extsym *progname;
-	int Class;
-#else
-startproc(Extsym *progname, int Class)
-#endif
-{
-	register struct Entrypoint *p;
-
-	p = ALLOC(Entrypoint);
-	if(Class == CLMAIN) {
-		puthead(CNULL, CLMAIN);
-		if (progname)
-		    strcpy (main_alias, progname->cextname);
-	} else {
-		if (progname) {
-			/* Construct an empty subroutine with this name */
-			/* in case the name is needed to force loading */
-			/* of this block-data subprogram: the name can */
-			/* appear elsewhere in an external statement. */
-			entrypt(CLPROC, TYSUBR, (ftnint)0, progname, (chainp)0);
-			endproc();
-			newproc();
-			}
-		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 *
-#ifdef KR_headers
-newentry(v, substmsg)
-	register Namep v;
-	int substmsg;
-#else
-newentry(register Namep v, int substmsg)
-#endif
-{
-	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);
-}
-
- void
-#ifdef KR_headers
-entrypt(Class, type, length, entry, args)
-	int Class;
-	int type;
-	ftnint length;
-	Extsym *entry;
-	chainp args;
-#else
-entrypt(int Class, int type, ftnint length, Extsym *entry, chainp args)
-#endif
-{
-	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 void
-epicode(Void)
-{
-	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 void
-#ifdef KR_headers
-retval(t)
-	register int t;
-#else
-retval(register int t)
-#endif
-{
-	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 */
-
- void
-#ifdef KR_headers
-procode(outfile)
-	FILE *outfile;
-#else
-procode(FILE *outfile)
-#endif
-{
-	prolog(outfile, allargs);
-
-	if (nentry > 1)
-		entry_goto(outfile);
-	}
-
- static void
-#ifdef KR_headers
-bad_dimtype(q) Namep q;
-#else
-bad_dimtype(Namep q)
-#endif
-{
-	errstr("bad dimension type for %.70s", q->fvarname);
-	}
-
-/* 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
-#ifdef KR_headers
-dim_finish(v)
-	Namep v;
-#else
-dim_finish(Namep v)
-#endif
-{
-	register struct Dimblock *p;
-	register expptr q;
-	register int i, nd;
-
-	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))
-				bad_dimtype(v);
-			}
-	if (q = p->basexpr)
-		p->basexpr = make_int_expr(putx(fixtype(q)));
-	doin_setbound = 0;
-	}
-
- static void
-#ifdef KR_headers
-duparg(q)
-	Namep q;
-#else
-duparg(Namep q)
-#endif
-{ errstr("duplicate argument %.80s", q->fvarname); }
-
-/*
-   manipulate argument lists (allocate argument slot positions)
- * keep track of return types and labels
- */
-
- LOCAL void
-#ifdef KR_headers
-doentry(ep)
-	struct Entrypoint *ep;
-#else
-doentry(struct Entrypoint *ep)
-#endif
-{
-	register int type;
-	register Namep np;
-	chainp p, p1;
-	register Namep q;
-	Addrp 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 && !ep->arglist || procclass == CLBLOCK)
-		return;
-
-	/* Entry points in MAIN are an error, but we process them here */
-	/* to prevent faults elsewhere. */
-
-/* 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] = (int)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 int
-#ifdef KR_headers
-nextarg(type)
-	int type;
-#else
-nextarg(int type)
-#endif
-{
-	type = type;	/* shut up warning */
-	return(lastargslot++);
-	}
-
- LOCAL void
-#ifdef KR_headers
-dim_check(q)
-	Namep q;
-#else
-dim_check(Namep q)
-#endif
-{
-	register struct Dimblock *vdim = q->vdim;
-	register expptr nelt;
-
-	if(!(nelt = vdim->nelt) || !ISCONST(nelt))
-		dclerr("adjustable dimension on non-argument", q);
-	else if (!ONEOF(nelt->headblock.vtype, MSKINT|MSKREAL))
-		bad_dimtype(q);
-	else if (ISINT(nelt->headblock.vtype)
-			? nelt->constblock.Const.ci <= 0
-			: nelt->constblock.Const.cd[0] <= 0.)
-		dclerr("nonpositive dimension", q);
-	}
-
- LOCAL void
-dobss(Void)
-{
-	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 */
-		}
-
-}
-
-
- void
-donmlist(Void)
-{
-	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
-#ifdef KR_headers
-iarrlen(q)
-	register Namep q;
-#else
-iarrlen(register Namep q)
-#endif
-{
-	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);
-}
-
- void
-#ifdef KR_headers
-namelist(np)
-	Namep np;
-#else
-namelist(Namep np)
-#endif
-{
-	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 void
-docommon(Void)
-{
-    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)
-			if (comvar->vleng)
-				size = comvar->vleng->constblock.Const.ci;
-			else  {
-				dclerr("character*(*) in common", comvar);
-				size = 1;
-				}
-		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 */
-
- void
-#ifdef KR_headers
-copy_data(list)
-	chainp list;
-#else
-copy_data(chainp list)
-#endif
-{
-    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(struct Dimblock) + 2*sizeof(expptr)*(nd-1);
-	    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 void
-docomleng(Void)
-{
-	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 */
-
- void
-#ifdef KR_headers
-frtemp(p)
-	Addrp p;
-#else
-frtemp(Addrp p)
-#endif
-{
-	/* put block on chain of temps to be reclaimed */
-	holdtemps = mkchain((char *)p, holdtemps);
-}
-
- void
-freetemps(Void)
-{
-	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
-#ifdef KR_headers
-autovar(nelt0, t, lengp, name)
-	register int nelt0;
-	register int t;
-	expptr lengp;
-	char *name;
-#else
-autovar(register int nelt0, register int t, expptr lengp, char *name)
-#endif
-{
-	ftnint leng;
-	register Addrp q;
-	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
-#ifdef KR_headers
-mktmpn(nelt, type, lengp)
-	int nelt;
-	register int type;
-	expptr lengp;
-#else
-mktmpn(int nelt, register int type, expptr lengp)
-#endif
-{
-	ftnint leng;
-	chainp p, oldp;
-	register Addrp q;
-	extern int krparens;
-
-	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
- */
-	if (krparens == 2 && ONEOF(type,M(TYREAL)|M(TYCOMPLEX)))
-		type++;
-	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
-#ifdef KR_headers
-mktmp(type, lengp)
-	int type;
-	expptr lengp;
-#else
-mktmp(int type, expptr lengp)
-#endif
-{
-	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
-#ifdef KR_headers
-mktmp0(type, lengp)
-	int type;
-	expptr lengp;
-#else
-mktmp0(int type, expptr lengp)
-#endif
-{
-	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 *
-#ifdef KR_headers
-comblock(s)
-	register char *s;
-#else
-comblock(register char *s)
-#endif
-{
-	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 = mkext1(s0 = 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 = mkext1(s0,cbuf);
-		}
-	if(p->extstg == STGUNKNOWN)
-		p->extstg = STGCOMMON;
-	else if(p->extstg != STGCOMMON)
-	{
-		errstr("%.52s cannot be a common block: it is a subprogram.",
-			s0);
-		return(0);
-	}
-
-	return( p );
-}
-
-
-/* incomm -- add a new variable to a common declaration */
-
- void
-#ifdef KR_headers
-incomm(c, v)
-	Extsym *c;
-	Namep v;
-#else
-incomm(Extsym *c, Namep v)
-#endif
-{
-	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 */
-
- void
-#ifdef KR_headers
-settype(v, type, length)
-	register Namep v;
-	register int type;
-	register ftnint length;
-#else
-settype(register Namep v, register int type, register ftnint length)
-#endif
-{
-	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->vtype != type
-			&& (v->vimpltype || v->vinftype || v->vinfproc))
-	{
-		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;
-		v->vinftype = 0; /* 19960709 */
-		v->vinfproc = 0; /* 19960709 */
-
-		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 && v->vtype != lengtype(type, length)) {
- 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 */
-
- int
-#ifdef KR_headers
-lengtype(type, len)
-	register int type;
-	ftnint len;
-#else
-lengtype(register int type, ftnint len)
-#endif
-{
-	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;
-			}
-		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 */
-
- void
-#ifdef KR_headers
-setintr(v)
-	register Namep v;
-#else
-setintr(register Namep v)
-#endif
-{
-	int k;
-
-	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);
-		return;
-		}
-	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);
-}
-
-
-
-/* setext -- Set External declaration -- assume that unknowns will become
-   procedures */
-
- void
-#ifdef KR_headers
-setext(v)
-	register Namep v;
-#else
-setext(register Namep v)
-#endif
-{
-	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 */
-
- void
-#ifdef KR_headers
-setbound(v, nd, dims)
-	register Namep v;
-	int nd;
-	struct Dims *dims;
-#else
-setbound(Namep v, int nd, struct Dims *dims)
-#endif
-{
-	expptr q, q0, t;
-	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;
-
-	if (noextflag)
-		for(i = 0; i <= nd; i++)
-			if (((q = dims[i].lb) && !ISINT(q->headblock.vtype))
-			 || ((q = dims[i].ub) && !ISINT(q->headblock.vtype))) {
-				sprintf(buf, "dimension %d of %s is not an integer.",
-					i+1, v->fvarname);
-				errext(buf);
-				break;
-				}
-
-	for(i = 0; i <= nd; i++) {
-		if (((q = dims[i].lb) && !ISINT(q->headblock.vtype)))
-			dims[i].lb = mkconv(TYINT, q);
-		if (((q = dims[i].ub) && !ISINT(q->headblock.vtype)))
-			dims[i].ub = mkconv(TYINT, q);
-		}
-
-	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;
-	q0 = 0;
-	if(q == NULL)
-		q = q0 = ICON(1);
-
-	for(i = nd-1 ; i>=0 ; --i)
-	{
-		t = dims[i].lb;
-		if(t == NULL)
-			t = ICON(1);
-		if(p->dims[i].dimsize) {
-			if (q == q0) {
-				q0 = 0;
-				frexpr(q);
-				q = cpexpr(p->dims[i].dimsize);
-				}
-			else
-				q = mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q);
-			q = mkexpr(OPPLUS, t, 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;
-}
-
-
- void
-#ifdef KR_headers
-wr_abbrevs(outfile, function_head, vars)
-	FILE *outfile;
-	int function_head;
-	chainp vars;
-#else
-wr_abbrevs(FILE *outfile, int function_head, chainp vars)
-#endif
-{
-    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/contrib/tools/f2c/src/put.c b/contrib/tools/f2c/src/put.c
deleted file mode 100644
index 15c70cd8b3c..00000000000
--- a/contrib/tools/f2c/src/put.c
+++ /dev/null
@@ -1,458 +0,0 @@
-/****************************************************************
-Copyright 1990-1991, 1993-1994, 1996, 2000-2001 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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
-#define LIT_INTQ 4
-
-
-/*
-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 */
-	1,1,1,1,1  /* OPBITTEST, OPBITCLR, OPBITSET, OPQBIT{CLR,SET} */
-};
-
-
- void
-#ifdef KR_headers
-putexpr(p)
-	expptr p;
-#else
-putexpr(expptr p)
-#endif
-{
-/* Write the expression to the p1 file */
-
-	p = (expptr) putx (fixtype (p));
-	p1_expr (p);
-}
-
-
-
-
-
- expptr
-#ifdef KR_headers
-putassign(lp, rp)
-	expptr lp;
-	expptr rp;
-#else
-putassign(expptr lp, expptr rp)
-#endif
-{
-	return putx(fixexpr((Exprp)mkexpr(OPASSIGN, lp, rp)));
-}
-
-
-
-
- void
-#ifdef KR_headers
-puteq(lp, rp)
-	expptr lp;
-	expptr rp;
-#else
-puteq(expptr lp, expptr rp)
-#endif
-{
-	putexpr(mkexpr(OPASSIGN, lp, rp) );
-}
-
-
-
-
-/* put code for  a *= b */
-
- expptr
-#ifdef KR_headers
-putsteq(a, b)
-	Addrp a;
-	Addrp b;
-#else
-putsteq(Addrp a, Addrp b)
-#endif
-{
-	return putx( fixexpr((Exprp)
-		mkexpr(OPSTAREQ, cpexpr((expptr)a), cpexpr((expptr)b))));
-}
-
-
-
-
- Addrp
-#ifdef KR_headers
-mkfield(res, f, ty)
-	register Addrp res;
-	char *f;
-	int ty;
-#else
-mkfield(register Addrp res, char *f, int ty)
-#endif
-{
-    res -> vtype = ty;
-    res -> Field = f;
-    return res;
-} /* mkfield */
-
-
- Addrp
-#ifdef KR_headers
-realpart(p)
-	register Addrp p;
-#else
-realpart(register Addrp p)
-#endif
-{
-	register Addrp q;
-
-	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
-#ifdef KR_headers
-imagpart(p)
-	register Addrp p;
-#else
-imagpart(register Addrp p)
-#endif
-{
-	register Addrp q;
-
-	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 */
-
- int
-#ifdef KR_headers
-ncat(p)
-	register expptr p;
-#else
-ncat(register expptr p)
-#endif
-{
-	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
-#ifdef KR_headers
-lencat(p)
-	register expptr p;
-#else
-lencat(register expptr p)
-#endif
-{
-	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
-#ifdef KR_headers
-putconst(p)
-	register Constp p;
-#else
-putconst(register Constp p)
-#endif
-{
-	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 = (int)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;
-
-#ifndef NO_LONG_LONG
-	case TYQUAD:
-		litflavor = LIT_INTQ;
-		goto loop;
-#endif
-
-	case TYLOGICAL1:
-	case TYLOGICAL2:
-	case TYLOGICAL:
-	case TYLONG:
-	case TYSHORT:
-	case TYINT1:
-#ifdef TYQUAD0
-	case TYQUAD:
-#endif
-		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;
-#ifndef NO_LONG_LONG
-			case LIT_INTQ:
-				if(p->Const.cq == litp->litval.litqval)
-					goto ret;
-				break;
-#endif
-			}
-
-/* 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] = (char*)
-					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;
-#ifndef NO_LONG_LONG
-			case LIT_INTQ:
-				litp->litval.litqval = p->Const.cq;
-				break;
-#endif
-			} /* 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/contrib/tools/f2c/src/putpcc.c b/contrib/tools/f2c/src/putpcc.c
deleted file mode 100644
index 18a9df661b3..00000000000
--- a/contrib/tools/f2c/src/putpcc.c
+++ /dev/null
@@ -1,2169 +0,0 @@
-/****************************************************************
-Copyright 1990-1996, 2000-2001 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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"
-
-static Addrp intdouble Argdcl((Addrp));
-static Addrp putcx1 Argdcl((tagptr));
-static tagptr putaddr Argdcl((tagptr));
-static tagptr putcall Argdcl((tagptr, Addrp*));
-static tagptr putcat Argdcl((tagptr, tagptr));
-static Addrp putch1 Argdcl((tagptr));
-static tagptr putchcmp Argdcl((tagptr));
-static tagptr putcheq Argdcl((tagptr));
-static void putct1 Argdcl((tagptr, Addrp, Addrp, ptr));
-static tagptr putcxcmp Argdcl((tagptr));
-static Addrp putcxeq Argdcl((tagptr));
-static tagptr putmnmx Argdcl((tagptr));
-static tagptr putop Argdcl((tagptr));
-static tagptr putpower Argdcl((tagptr));
-static long p1_where;
-
-extern int init_ac[TYSUBR+1];
-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 */
-
- void
-#ifdef KR_headers
-puthead(s, Class)
-	char *s;
-	int Class;
-#else
-puthead(char *s, int Class)
-#endif
-{
-	if (headerdone == NO) {
-		if (Class == CLMAIN)
-			s = "MAIN__";
-		p1_head (Class, s);
-		headerdone = YES;
-		}
-}
-
- void
-#ifdef KR_headers
-putif(p, else_if_p)
-	register expptr p;
-	int else_if_p;
-#else
-putif(register expptr p, int else_if_p)
-#endif
-{
-	int k, n;
-
-	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) > p1_where) {
-				p1_if(p);
-				new_endif();
-				}
-			else
-				p1_elif(p);
-			}
-		else {
-			p = putx(p);
-			p1_if(p);
-			}
-		}
-	}
-
- void
-#ifdef KR_headers
-putout(p)
-	expptr p;
-#else
-putout(expptr p)
-#endif
-{
-	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). */
-}
-
-
- void
-#ifdef KR_headers
-putcmgo(index, nlab, labs)
-	expptr index;
-	int nlab;
-	struct Labelblock **labs;
-#else
-putcmgo(expptr index, int nlab, struct Labelblock **labs)
-#endif
-{
-	if(! ISINT(index->headblock.vtype) )
-	{
-		execerr("computed goto index must be integer", CNULL);
-		return;
-	}
-
-	p1comp_goto (index, nlab, labs);
-}
-
- static expptr
-#ifdef KR_headers
-krput(p)
-	register expptr p;
-#else
-krput(register expptr p)
-#endif
-{
-	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
-#ifdef KR_headers
-putx(p)
-	register expptr p;
-#else
-putx(register expptr p)
-#endif
-{
-	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:
-		case OPBITTEST:
-		case OPBITCLR:
-		case OPBITSET:
-#ifdef TYQUAD
-		case OPQBITSET:
-		case OPQBITCLR:
-#endif
-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
-#ifdef KR_headers
-putop(p)
-	expptr p;
-#else
-putop(expptr p)
-#endif
-{
-	expptr lp, tp;
-	int pt, lt, lt1;
-	int comma;
-	char *hsave;
-
-	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) {
-				if (ISCONST(p->exprblock.leftp)
-				 && ISNUMERIC(p->exprblock.vtype)) {
-					hsave = halign;
-					halign = 0;
-					p->exprblock.leftp = putx((expptr)
-						putconst((Constp)
-							p->exprblock.leftp));
-					halign = hsave;
-					}
-				else
-					p->exprblock.leftp =
-						putx(p->exprblock.leftp);
-				return p;
-				}
-			if (pt < lt && ONEOF(lt,MSKINT|MSKREAL))
-				break;
-			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);
-	lp = p->exprblock.leftp = putx(p->exprblock.leftp);
-	if (p -> exprblock.rightp) {
-		tp = p->exprblock.rightp = putx(p->exprblock.rightp);
-		if (tp && ISCONST(tp) && ISCONST(lp))
-			p = fold(p);
-		}
-	return p;
-}
-
- LOCAL expptr
-#ifdef KR_headers
-putpower(p)
-	expptr p;
-#else
-putpower(expptr p)
-#endif
-{
-	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 if (k == 3) {
-		putout(p);
-		p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1),
-		    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
-#ifdef KR_headers
-intdouble(p)
-	Addrp p;
-#else
-intdouble(Addrp p)
-#endif
-{
-	register Addrp t;
-
-	t = mktmp(TYDREAL, ENULL);
-	putout (putassign(cpexpr((expptr)t), (expptr)p));
-	return(t);
-}
-
-
-
-
-
-/* Complex-type variable assignment */
-
- LOCAL Addrp
-#ifdef KR_headers
-putcxeq(p)
-	register expptr p;
-#else
-putcxeq(register expptr p)
-#endif
-{
-	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
-#ifdef KR_headers
-putcxop(p)
-	expptr p;
-#else
-putcxop(expptr p)
-#endif
-{
-	return (expptr)putaddr((expptr)putcx1(p));
-}
-
-#define PAIR(x,y) mkexpr (OPCOMMA, (x), (y))
-
- LOCAL Addrp
-#ifdef KR_headers
-putcx1(p)
-	register expptr p;
-#else
-putcx1(register expptr p)
-#endif
-{
-	expptr q;
-	Addrp lp, rp;
-	register Addrp resp;
-	int opcode;
-	int ltype, rtype;
-	long ts, tskludge;
-
-	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));
-				}
-			}
-#ifdef TYQUAD
-		resp = mktmp(q->headblock.vtype == TYQUAD ? TYQUAD : tyint, ENULL);
-#else
-		resp = mktmp(tyint, ENULL);
-#endif
-		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(p->exprblock.vtype, ENULL);
-		/*first arg of above mktmp call was TYDREAL before 19950102 */
-		putout (putassign( cpexpr((expptr)resp), p));
-		return(resp);
-
-	case TERROR:
-		return NULL;
-
-	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 (!lp)
-			break;
-		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
-#ifdef KR_headers
-putcxcmp(p)
-	register expptr p;
-#else
-putcxcmp(register expptr p)
-#endif
-{
-	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
-#ifdef KR_headers
-putch1(p)
-	register expptr p;
-#else
-putch1(register expptr p)
-#endif
-{
-	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
-#ifdef KR_headers
-putchop(p)
-	expptr p;
-#else
-putchop(expptr p)
-#endif
-{
-	p = putaddr((expptr)putch1(p));
-	return (Addrp)p;
-}
-
-
-
-
- LOCAL expptr
-#ifdef KR_headers
-putcheq(p)
-	register expptr p;
-#else
-putcheq(register expptr p)
-#endif
-{
-	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
-#ifdef KR_headers
-putchcmp(p)
-	register expptr p;
-#else
-putchcmp(register expptr p)
-#endif
-{
-	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
-#ifdef KR_headers
-putcat(lhs0, rhs)
-	expptr lhs0;
-	register expptr rhs;
-#else
-putcat(expptr lhs0, register expptr rhs)
-#endif
-{
-	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 void
-#ifdef KR_headers
-putct1(q, length_var, string_var, ip)
-	register expptr q;
-	register Addrp length_var;
-	register Addrp string_var;
-	int *ip;
-#else
-putct1(register expptr q, register Addrp length_var, register Addrp string_var, int *ip)
-#endif
-{
-	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
-#ifdef KR_headers
-putaddr(p0)
-	expptr p0;
-#else
-putaddr(expptr p0)
-#endif
-{
-	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
-#ifdef KR_headers
-addrfix(e)
-	expptr e;
-#else
-addrfix(expptr e)
-#endif
-		/* fudge character string length if it's a TADDR */
-{
-	return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e;
-	}
-
- LOCAL int
-#ifdef KR_headers
-typekludge(ccall, q, at, j)
-	int ccall;
-	register expptr q;
-	Atype *at;
-	int j;
-#else
-typekludge(int ccall, register expptr q, Atype *at, int j)
-#endif
- /* 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 *
-#ifdef KR_headers
-Argtype(k, buf)
-	int k;
-	char *buf;
-#else
-Argtype(int k, char *buf)
-#endif
-{
-	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
-#ifdef KR_headers
-atype_squawk(at, msg)
-	Argtypes *at;
-	char *msg;
-#else
-atype_squawk(Argtypes *at, char *msg)
-#endif
-{
-	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
-#ifdef KR_headers
-bad_atypes(at, fname, i, j, k, here, prev)
-	Argtypes *at;
-	char *fname;
-	int i;
-	int j;
-	int k;
-	char *here;
-	char *prev;
-#else
-bad_atypes(Argtypes *at, char *fname, int i, int j, int k, char *here, char *prev)
-#endif
-{
-	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
-#ifdef KR_headers
-type_fixup(at, a, k)
-	Argtypes *at;
-	Atype *a;
-	int k;
-#else
-type_fixup(Argtypes *at,  Atype *a,  int k)
-#endif
-{
-	register struct Entrypoint *ep;
-	if (!infertypes)
-		return 0;
-	for(ep = entries; ep; ep = ep->entnextp)
-		if (ep->entryname && at == ep->entryname->arginfo) {
-			a->type = k % 100;
-			return proc_argchanges = 1;
-			}
-	return 0;
-	}
-
-
- void
-#ifdef KR_headers
-save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type, zap)
-	chainp arglist;
-	Argtypes **at0;
-	Argtypes **at1;
-	int ccall;
-	char *fname;
-	int stg;
-	int nchargs;
-	int type;
-	int zap;
-#else
-save_argtypes(chainp arglist, Argtypes **at0, Argtypes **at1, int ccall, char *fname, int stg, int nchargs, int type, int zap)
-#endif
-{
-	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};
-
-	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) {
-					t = init_ap[type];
-					goto newlist;
-					}
-				return;
-				}
-			j = atypes->type;
-			k = *t++;
-			if (j != k && j-400 != k) {
-				cp = 0;
-				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 - nchargs,
-						j, k, "here ", ", previously");
-				else
-					fprintf(stderr,
-					 "\targ %d: here %s, previously %s.\n",
-						i - nchargs, Argtype(k,buf1),
-						Argtype(j,buf2));
-				if (!cp)
-					break;
-				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;
-		}
-	}
-
- static char*
-#ifdef KR_headers
-get_argtypes(p, pat0, pat1) Exprp p; Argtypes ***pat0, ***pat1;
-#else
-get_argtypes(Exprp p, Argtypes ***pat0, Argtypes ***pat1)
-#endif
-{
-	Addrp a;
-	Argtypes **at0, **at1;
-	Namep np;
-	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");
-		}
-	*pat0 = at0;
-	*pat1 = at1;
-	return fname;
-	}
-
- void
-#ifdef KR_headers
-saveargtypes(p)
-	register Exprp p;
-#else
-saveargtypes(register Exprp p)
-#endif
-				/* for writing prototypes */
-{
-	Argtypes **at0, **at1;
-	chainp arglist;
-	expptr rp;
-	char *fname;
-
-	fname = get_argtypes(p, &at0, &at1);
-	rp = p->rightp;
-	arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0;
-	save_argtypes(arglist, at0, at1, p->opcode == OPCCALL,
-		fname, p->leftp->addrblock.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
-#ifdef KR_headers
-putcall(p0, temp)
-	expptr p0;
-	Addrp *temp;
-#else
-putcall(expptr p0, Addrp *temp)
-#endif
-{
-    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;
-    Argtypes *at, **at0, **at1;
-    Atype *At, *Ate;
-
-    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 */
-
-    if (!byvalue) {
-	get_argtypes(p, &at0, &at1);
-	At = Ate = 0;
-	if ((at = *at0) && at->nargs >= 0) {
-		At = at->atypes;
-		Ate = At + at->nargs;
-		At += init_ac[type];
-		}
-        for(cp = arglist ; cp ; cp = cp->nextp) {
-	    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)
-		&& (!At || At->type % 100 % TYSUBR == TYCHAR))
-		{
-		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;
-		}
-	    if (At && ++At == Ate)
-		At = 0;
-	    }
-	}
-    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) {
-		if (q->tag == TEXPR && q->exprblock.opcode == OPCONV) {
-			if (ISCOMPLEX(q->exprblock.leftp->headblock.vtype)
-			 && q->exprblock.leftp->tag == TEXPR)
-				q->exprblock.leftp = putcxop(q->exprblock.leftp);
-			else
-				q->exprblock.leftp = putx(q->exprblock.leftp);
-			}
-		else
-			cp -> datap = (char *) putx(q);
-		}
-	    else if (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;
-}
-
- static expptr
-#ifdef KR_headers
-foldminmax(op, type, p) int op; int type; chainp p;
-#else
-foldminmax(int op, int type, chainp p)
-#endif
-{
-	Constp c, c1;
-	ftnint i, i1;
-	double d, d1;
-	int dstg, d1stg;
-	char *s, *s1;
-
-	c = ALLOC(Constblock);
-	c->tag = TCONST;
-	c->vtype = type;
-	s = s1 = 0;
-
-	switch(type) {
-	  case TYREAL:
-	  case TYDREAL:
-		c1 = (Constp)p->datap;
-		d = ISINT(c1->vtype) ? (double)c1->Const.ci
-			: c1->vstg ? atof(c1->Const.cds[0]) : c1->Const.cd[0];
-		dstg = 0;
-		if (ISINT(c1->vtype))
-			d = (double)c1->Const.ci;
-		else if (dstg = c1->vstg)
-			d = atof(s = c1->Const.cds[0]);
-		else
-			d = c1->Const.cd[0];
-		while(p = p->nextp) {
-			c1 = (Constp)p->datap;
-			d1stg = 0;
-			if (ISINT(c1->vtype))
-				d1 = (double)c1->Const.ci;
-			else if (d1stg = c1->vstg)
-				d1 = atof(s1 = c1->Const.cds[0]);
-			else
-				d1 = c1->Const.cd[0];
-			if (op == OPMIN) {
-				if (d > d1)
-					goto d1copy;
-				}
-			else if (d < d1) {
- d1copy:
-				d = d1;
-				dstg = d1stg;
-				s = s1;
-				}
-			}
-		if (c->vstg = dstg)
-			c->Const.cds[0] = s;
-		else
-			c->Const.cd[0] = d;
-		break;
-	  default:
-		i = ((Constp)p->datap)->Const.ci;
-		while(p = p->nextp) {
-			i1 = ((Constp)p->datap)->Const.ci;
-			if (op == OPMIN) {
-				if (i > i1)
-					i = i1;
-				}
-			else if (i < i1)
-				i = i1;
-			}
-		c->Const.ci = i;
-		}
-	return (expptr)c;
-	}
-
-/* putmnmx -- Put min or max.   p   must point to an EXPR, not just a
-   CONST */
-
- LOCAL expptr
-#ifdef KR_headers
-putmnmx(p)
-	register expptr p;
-#else
-putmnmx(register expptr p)
-#endif
-{
-	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 );
-
-	/* for param statements, deal with constant expressions now */
-
-	for(p1 = p0;; p1 = p1->nextp) {
-		if (!p1) {
-			/* all constants */
-			p = foldminmax(op, type, p0);
-			frchain(&p0);
-			return p;
-			}
-		else if (!ISCONST(((expptr)p1->datap)))
-			break;
-		}
-
-	/* 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
-#ifdef KR_headers
-putwhile(p)
-	expptr p;
-#else
-putwhile(expptr p)
-#endif
-{
-	int k, n;
-
-	if (wh_next >= wh_last)
-		{
-		k = wh_last - wh_first;
-		n = k + 100;
-		wh_next = mem(n,0);
-		wh_last = wh_first + n;
-		if (k)
-			memcpy(wh_next, wh_first, k);
-		wh_first =  wh_next;
-		wh_next += k;
-		wh_last = wh_first + n;
-		}
-	if( !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) > p1_where;
-		p1put(P1_WHILE2START);
-		p1_expr(p);
-		}
-	}
-
- void
-#ifdef KR_headers
-westart(elseif) int elseif;
-#else
-westart(int elseif)
-#endif
-{
-	static int we[2] = { P1_WHILE1START, P1_ELSEIFSTART };
-	p1put(we[elseif]);
-	p1_where = ftell(pass1_file);
-	}
diff --git a/contrib/tools/f2c/src/sysdep.c b/contrib/tools/f2c/src/sysdep.c
deleted file mode 100644
index 3d7478d2f38..00000000000
--- a/contrib/tools/f2c/src/sysdep.c
+++ /dev/null
@@ -1,705 +0,0 @@
-/****************************************************************
-Copyright 1990 - 1994, 2000 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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"
-#include <stdlib.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[]	= "on Microsoft Windows system, link with libf2c.lib;\n\
-	on Linux or Unix systems, link with .../path/to/libf2c.a -lm\n\
-	or, if you install libf2c.a in a standard place, with -lf2c -lm\n\
-	-- in that order, at the end of the command line, as in\n\
-		cc *.o -lf2c -lm\n\
-	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,\n\n\
-		http://www.netlib.org/f2c/libf2c.zip";
-
-char *outbuf = "", *outbtail;
-
-#undef WANT_spawnvp
-#ifdef MSDOS
-#ifndef NO_spawnvp
-#define WANT_spawnvp
-#endif
-#endif
-
-#ifdef _WIN32
-#include <windows.h>	/* for GetVolumeInformation */
-#undef WANT_spawnvp
-#define WANT_spawnvp
-#undef  MSDOS
-#define MSDOS
-#endif
-
-#ifdef WANT_spawnvp
-#include <process.h>
-#ifndef _P_WAIT
-#define _P_WAIT P_WAIT	/* Symantec C/C++ */
-#endif
-static char **spargv, **pfname;
-#endif
-
-char *tmpdir = "";
-
-#ifdef __cplusplus
-#define Cextern extern "C"
-extern "C" {
- static void flovflo(int), killed(int);
- static int compare(const void *a, const void *b);
-}
-#else
-#define Cextern extern
-#endif
-
-Cextern int unlink Argdcl((const char *));
-Cextern int fork Argdcl((void)), getpid Argdcl((void)), wait Argdcl((int*));
-
- void
-#ifdef KR_headers
-Un_link_all(cdelete)
-	int cdelete;
-#else
-Un_link_all(int cdelete)
-#endif
-{
-	if (!debugflag) {
-		unlink(c_functions);
-		unlink(initfname);
-                unlink(initbname);
-		unlink(p1_file);
-                unlink(p1_bakfile);
-		unlink(sortfname);
-		unlink(blkdfname);
-		if (cdelete && coutput)
-			unlink(coutput);
-		}
-	}
-
-#ifndef NO_TEMPDIR
- static void
-rmtdir(Void)
-{
-	char *s;
-	if (*(s = tmpdir)) {
-		tmpdir = "";
-		rmdir(s);
-		}
-	}
-#endif /*NO_TEMPDIR*/
-
-#ifndef MSDOS
-#include "sysdep.hd"
-#ifndef NO_MKDTEMP
-#include <unistd.h> /* for mkdtemp */
-#endif
-#endif
-
- static void
-alloc_names(Void)
-{
-	int k = strlen(tmpdir) + 24;
-	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;
-	}
-
- void
-set_tmp_names(Void)
-{
-#ifdef MSDOS
-	char buf[64], *s, *t;
-#ifdef _WIN32
-	DWORD flags, maxlen, volser;
-	char volname[512], f2c[24], fsname[512], *name1;
-	int i;
-
-	if (debugflag == 1)
-		return;
-	i = sprintf(f2c, "%x", _getpid());
-	if (!GetVolumeInformation(NULL, volname, sizeof(volname), &volser, &maxlen,
-			&flags, fsname, sizeof(fsname))
-	 || maxlen < i+8) /* FAT16 */
-		strcpy(f2c, "f2c_");
-#else
-	static char f2c[] = "f2c_";
-	if (debugflag == 1)
-		return;
-#endif
-
-	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;
-		}
-	alloc_names();
-	sprintf(c_functions, "%s%sfunc", t, f2c);
-	sprintf(initfname, "%s%srd", t, f2c);
-	sprintf(blkdfname, "%s%sblkd", t, f2c);
-	sprintf(p1_file, "%s%sp1f", t, f2c);
-	sprintf(p1_bakfile, "%s%sp1fb", t, f2c);
-	sprintf(sortfname, "%s%ssort", t, f2c);
-#else /*!MSDOS*/
-	long pid;
-
-#define L_TDNAME 20
-#ifdef NO_MKDTEMP
-#ifdef NO_MKSTEMP
-#undef  L_TDNAME
-#define L_TDNAME L_tmpnam
-#endif
-#endif
-	static char tdbuf[L_TDNAME];
-
-	if (debugflag == 1)
-		return;
-	pid = getpid();
-	if (!*tmpdir) {
-#ifdef NO_TEMPDIR
-		tmpdir = "/tmp";
-#else
-#ifdef NO_MKDTEMP
-#ifdef NO_MKSTEMP
-		if (!(tmpdir = tmpnam(tdbuf))) {
-			fprintf(stderr, "tmpnam failed (for -T)\n");
-			exit(1);
-			}
-#else
-		int f;
-		strcpy(tdbuf, "/tmp/f2ctd_XXXXXX");
-		f = mkstemp(tdbuf);
-		if (f >= 0) {
-			close(f);
-			remove(tmpdir = tdbuf);
-			}
-		else {
-			fprintf(stderr, "mkstemp failed (for -T)\n");
-			exit(1);
-			}
-#endif /*NO_MKSTEMP*/
-		if (mkdir(tdbuf,0700)) {
-			fprintf(stderr, "mkdir failed (for -T)\n");
-			exit(1);
-			}
-#else /*!NO_MKDTEMP*/
-		strcpy(tdbuf, "/tmp/f2ctd_XXXXXX");
-		if (!(tmpdir = mkdtemp(tdbuf))) {
-			fprintf(stderr, "mkdtemp failed (for -T)\n");
-			exit(1);
-			}
-#endif /*NO_MKDTEMP*/
-		if (!debugflag)
-			atexit(rmtdir);
-#endif /*NO_TEMPDIR*/
-		}
-	alloc_names();
-        /* What follows is safe if tmpdir is really
-        a private diectory created by us -- otherwise
-        the file could be a sym link somewhere else....*/
-	sprintf(c_functions, "%s/f2c%ld_func", tmpdir, pid);
-	sprintf(initfname, "%s/f2c%ld_rd", tmpdir, pid);
-	sprintf(blkdfname, "%s/f2c%ld_blkd", tmpdir, pid);
-	sprintf(p1_file, "%s/f2c%ld_p1f", tmpdir, pid);
-	sprintf(p1_bakfile, "%s/f2c%ld_p1fb", tmpdir, pid);
-	sprintf(sortfname, "%s/f2c%ld_sort", tmpdir, pid);
-#endif /*MSDOS*/
-	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 *
-#ifdef KR_headers
-c_name(s, ft)
-	char *s;
-	int ft;
-#else
-c_name(char *s, int ft)
-#endif
-{
-	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");
-		}
-	strcpy(outbtail, b);
-	outbtail[s-b] = ft;
-	b = copys(outbuf);
-	return b;
-	}
-
- static void
-#ifdef KR_headers
-killed(sig)
-	int sig;
-#else
-killed(int sig)
-#endif
-{
-	sig = sig;	/* shut up warning */
-	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
-#ifdef KR_headers
-sig1catch(sig)
-	int sig;
-#else
-sig1catch(int sig)
-#endif
-{
-	sig = sig;	/* shut up warning */
-	if (signal(sig, SIG_IGN) != SIG_IGN)
-		signal(sig, killed);
-	}
-
- static void
-#ifdef KR_headers
-flovflo(sig)
-	int sig;
-#else
-flovflo(int sig)
-#endif
-{
-	sig = sig;	/* shut up warning */
-	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
-#ifdef KR_headers
-sigcatch(sig)
-	int sig;
-#else
-sigcatch(int sig)
-#endif
-{
-	sig = sig;	/* shut up warning */
-	sig1catch(SIGINT);
-#ifdef SIGQUIT
-	sig1catch(SIGQUIT);
-#endif
-#ifdef SIGHUP
-	sig1catch(SIGHUP);
-#endif
-	sig1catch(SIGTERM);
-	signal(SIGFPE, flovflo);  /* catch overflows */
-	}
-
-/* argkludge permits wild-card expansion and caching of the original or expanded */
-/* argv to kludge around the lack of fork() and exec() when necessary. */
-
- void
-#ifdef KR_headers
-argkludge(pargc, pargv) int *pargc; char ***pargv;
-#else
-argkludge(int *pargc, char ***pargv)
-#endif
-{
-#ifdef WANT_spawnvp
-	size_t L, L1;
-	int argc, i, nf;
-	char **a, **argv, *s, *t, *t0;
-
-	/* Assume wild-card expansion has been done by Microsoft's setargv.obj */
-
-	/* Count Fortran input files. */
-
-	L = argc = *pargc;
-	argv = *pargv;
-	for(i = nf = 0; i < argc; i++) {
-		L += L1 = strlen(s = argv[i]);
-		if (L1 > 2 && s[L1-2] == '.')
-			switch(s[L1-1]) {
-			  case 'f':
-			  case 'F':
-				nf++;
-			  }
-		}
-	if (nf <= 1)
-		return;
-
-	/* Cache inputs */
-
-	i = argc - nf + 2;
-	a = spargv = (char**)Alloc(i*sizeof(char*) + L);
-	t = (char*)(a + i);
-	for(i = 0; i < argc; i++) {
-		*a++ = t0 = t;
-		for(s = argv[i]; *t++ = *s; s++);
-		if (t-t0 > 3 && s[-2] == '.')
-			switch(s[-1]) {
-			  case 'f':
-			  case 'F':
-				--a;
-				t = t0;
-			  }
-		}
-	pfname = a++;
-	*a = 0;
-#endif
-	}
-
- int
-#ifdef KR_headers
-dofork(fname) char *fname;
-#else
-dofork(char *fname)
-#endif
-{
-	extern int retcode;
-#ifdef MSDOS
-#ifdef WANT_spawnvp
-	*pfname = fname;
-	retcode |= _spawnvp(_P_WAIT, spargv[0], (char const*const*)spargv);
-#else /*_WIN32*/
-	Fatal("Only one Fortran input file allowed under MS-DOS");
-#endif /*_WIN32*/
-#else
-	int pid, status, w;
-
-	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(Void)
-{
-	static char *str1fmt[6] =
-		{ "\\b", "\\t", "\\n", "\\f", "\\r", "\\013" };
-	register int i, j;
-	register char *s;
-
-	/* str_fmt */
-
-#ifdef non_ASCII
-	i = 0;
-#else
-	i = 127;
-#endif
-	s = Alloc(5*(Table_size - i));
-	for(; i < Table_size; i++) {
-		sprintf(str_fmt[i] = s, "\\%03o", i);
-		s += 5;
-		}
-#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] = (char*)(Ansi ? "\\v" : "\\13");
-	}
-
- void
-outbuf_adjust(Void)
-{
-	int n, n1;
-	char *s;
-
-	n = n1 = strlen(outbuf);
-	if (*outbuf && outbuf[n-1] != '/')
-		n1++;
-	s = Alloc(n+64);
-	outbtail = s + n1;
-	strcpy(s, outbuf);
-	if (n != n1)
-		strcpy(s+n, "/");
-	outbuf = s;
-	}
-
-
-/* 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
-
- int
-#ifdef KR_headers
-dsort(from, to)
-	char *from;
-	char *to;
-#else
-dsort(char *from, char *to)
-#endif
-{
-	char buf[200];
-	sprintf(buf, "sort <%s >%s", from, to);
-	return system(buf) >> 8;
-	}
-#else
-
- static int
-#ifdef KR_headers
- compare(a,b)
-  char *a, *b;
-#else
- compare(const void *a, const void *b)
-#endif
-{ return strcmp(*(char **)a, *(char **)b); }
-
- int
-#ifdef KR_headers
-dsort(from, to)
-	char *from;
-	char *to;
-#else
-dsort(char *from, char *to)
-#endif
-{
-	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/contrib/tools/f2c/src/sysdep.h b/contrib/tools/f2c/src/sysdep.h
deleted file mode 100644
index f9b7cbcee42..00000000000
--- a/contrib/tools/f2c/src/sysdep.h
+++ /dev/null
@@ -1,101 +0,0 @@
-/****************************************************************
-Copyright 1990, 1991, 1994 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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__
-#undef KR_headers
-#endif
-
-#ifndef KR_headers
-#ifndef ANSI_Libraries
-#define ANSI_Libraries
-#endif
-#ifndef ANSI_Prototypes
-#define ANSI_Prototypes
-#endif
-#endif
-
-#ifdef __BORLANDC__
-#define MSDOS
-#endif
-
-#ifdef __ZTC__	/* Zortech */
-#define MSDOS
-#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(), *realloc();
-void *memcpy(), *memset();
-#ifndef _SIZE_T
-typedef unsigned int size_t;
-#endif
-#ifndef atol
-    long atol();
-#endif
-
-#ifdef ANSI_Prototypes
-extern double atof(const char *);
-extern double strtod(const char*, char**);
-#else
-extern double atof(), strtod();
-#endif
-#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 Bits_per_Byte 8
-#define Table_size (1 << Bits_per_Byte)
diff --git a/contrib/tools/f2c/src/sysdep.hd b/contrib/tools/f2c/src/sysdep.hd
deleted file mode 100644
index e69de29bb2d..00000000000
--- a/contrib/tools/f2c/src/sysdep.hd
+++ /dev/null
diff --git a/contrib/tools/f2c/src/tokdefs.h b/contrib/tools/f2c/src/tokdefs.h
deleted file mode 100644
index 35e3d72bd7e..00000000000
--- a/contrib/tools/f2c/src/tokdefs.h
+++ /dev/null
@@ -1,100 +0,0 @@
-#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
-#define SBYTE 100
diff --git a/contrib/tools/f2c/src/usignal.h b/contrib/tools/f2c/src/usignal.h
deleted file mode 100644
index ba4ee6ad44c..00000000000
--- a/contrib/tools/f2c/src/usignal.h
+++ /dev/null
@@ -1,7 +0,0 @@
-#include <signal.h>
-#ifndef SIGHUP
-#define	SIGHUP	1	/* hangup */
-#endif
-#ifndef SIGQUIT
-#define	SIGQUIT	3	/* quit */
-#endif
diff --git a/contrib/tools/f2c/src/vax.c b/contrib/tools/f2c/src/vax.c
deleted file mode 100644
index 63a7d8c88ad..00000000000
--- a/contrib/tools/f2c/src/vax.c
+++ /dev/null
@@ -1,585 +0,0 @@
-/****************************************************************
-Copyright 1990, 1992-1994, 2001 by AT&T, Lucent Technologies 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,
-Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
-this software, including all implied warranties of
-merchantability and fitness.  In no event shall AT&T, Lucent 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 */
-
- void
-#ifdef KR_headers
-prconi(fp, n)
-	FILEP fp;
-	ftnint n;
-#else
-prconi(FILEP fp, ftnint n)
-#endif
-{
-	fprintf(fp, "\t%ld\n", n);
-}
-
-#ifndef NO_LONG_LONG
- void
-#ifdef KR_headers
-prconq(fp, n) FILEP fp; Llong n;
-#else
-prconq(FILEP fp, Llong n)
-#endif
-{
-	fprintf(fp, "\t%lld\n", n);
-	}
-#endif
-
-
-/* Put out a constant address */
-
- void
-#ifdef KR_headers
-prcona(fp, a)
-	FILEP fp;
-	ftnint a;
-#else
-prcona(FILEP fp, ftnint a)
-#endif
-{
-	fprintf(fp, "\tL%ld\n", a);
-}
-
-
- void
-#ifdef KR_headers
-prconr(fp, x, k)
-	FILEP fp;
-	Constp x;
-	int k;
-#else
-prconr(FILEP fp, Constp x, int k)
-#endif
-{
-	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 *
-#ifdef KR_headers
-memname(stg, mem)
-	int stg;
-	long mem;
-#else
-memname(int stg, long mem)
-#endif
-{
-	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);
-}
-
-extern void addrlit Argdcl((Addrp));
-
-/* make_int_expr -- takes an arbitrary expression, and replaces all
-   occurrences of arguments with indirection */
-
- expptr
-#ifdef KR_headers
-make_int_expr(e)
-	expptr e;
-#else
-make_int_expr(expptr e)
-#endif
-{
-    chainp listp;
-    Addrp ap;
-    expptr e1;
-
-    if (e != ENULL)
-	switch (e -> tag) {
-	    case TADDR:
-		if (e->addrblock.isarray) {
-			if (e1 = e->addrblock.memoffset)
-				e->addrblock.memoffset = make_int_expr(e1);
-			}
-		else if (e->addrblock.vstg == STGARG
-			|| e->addrblock.vstg == STGCOMMON
-				&& e->addrblock.uname_tag == UNAM_NAME
-				&& e->addrblock.user.name->vcommequiv)
-			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;
-	    case TLIST:
-		for(listp = e->listblock.listp; listp; listp = listp->nextp)
-			if ((ap = (Addrp)listp->datap)
-			 && ap->tag == TADDR
-			 && ap->uname_tag == UNAM_CONST)
-				addrlit(ap);
-		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
-#ifdef KR_headers
-prune_left_conv(e)
-	expptr e;
-#else
-prune_left_conv(expptr e)
-#endif
-{
-    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(Void)
-{
-	if (!wrote_comment) {
-		wrote_comment = 1;
-		nice_printf (comment_file, "/* Parameter adjustments */\n");
-		}
-	}
-
- static int *
-count_args(Void)
-{
-	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 Argdcl((expptr));
-
- static void
-#ifdef KR_headers
-aawalk(P)
-	struct Primblock *P;
-#else
-aawalk(struct Primblock *P)
-#endif
-{
-	chainp p;
-	expptr q;
-
-	if (P->argsp)
-		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
-#ifdef KR_headers
-afwalk(P)
-	struct Primblock *P;
-#else
-afwalk(struct Primblock *P)
-#endif
-{
-	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
-#ifdef KR_headers
-awalk(e)
-	expptr e;
-#else
-awalk(expptr e)
-#endif
-{
-	Namep np;
- top:
-	if (!e)
-		return;
-	switch(e->tag) {
-	  default:
-		badtag("awalk", e->tag);
-	  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
-#ifdef KR_headers
-argsort(p0)
-	chainp p0;
-#else
-argsort(chainp p0)
-#endif
-{
-	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;
-	}
-
- void
-#ifdef KR_headers
-prolog(outfile, p)
-	FILE *outfile;
-	register chainp p;
-#else
-prolog(FILE *outfile, register chainp p)
-#endif
-{
-	int addif, addif0, i, nd;
-	ftnint 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/contrib/tools/f2c/src/version.c b/contrib/tools/f2c/src/version.c
deleted file mode 100644
index f736fc7b4aa..00000000000
--- a/contrib/tools/f2c/src/version.c
+++ /dev/null
@@ -1,2 +0,0 @@
-char F2C_version[] = "20190311";
-char xxxvers[] = "\n@(#) FORTRAN 77 to C Translator, VERSION 20190311\n";