Update to the most recent version. Among other things, this also solves

the function naming problem for complex double function i've recently
aksed for in -committers.  (The recently committed rev 1.5 of proc.c
was actually also part of this update.)

Should the mailing lists come to an agreement that f2c better belongs
into the ports, this could be done nevertheless.  For the time being,
we've at least got a current version now.

Thanks, Steve!

Submitted by:	Steve Kargl <sgk@troutmask.apl.washington.edu>

lib/libF77/Notice

@@ -1,23 +1,23 @@
 /****************************************************************
-Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
+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 or
+documentation, and that the names of AT&T, Bell Laboratories,
-Bellcore or any of their entities not be used in advertising or
+Lucent or Bellcore or any of their entities not be used in
-publicity pertaining to distribution of the software without
+advertising or publicity pertaining to distribution of the
-specific, written prior permission.
+software without specific, written prior permission.
 
-AT&T and Bellcore disclaim all warranties with regard to this
+AT&T, Lucent and Bellcore disclaim all warranties with regard to
-software, including all implied warranties of merchantability
+this software, including all implied warranties of
-and fitness.  In no event shall AT&T or Bellcore be liable for
+merchantability and fitness.  In no event shall AT&T, Lucent or
-any special, indirect or consequential damages or any damages
+Bellcore be liable for any special, indirect or consequential
-whatsoever resulting from loss of use, data or profits, whether
+damages or any damages whatsoever resulting from loss of use,
-in an action of contract, negligence or other tortious action,
+data or profits, whether in an action of contract, negligence or
-arising out of or in connection with the use or performance of
+other tortious action, arising out of or in connection with the
-this software.
+use or performance of this software.
 ****************************************************************/
 

lib/libF77/README

@@ -106,3 +106,7 @@ one-line shell script
 or (on some systems)
 
 	exec /usr/bin/ar lts $1 >/dev/null
+
+If your compiler complains about the signal calls in main.c, s_paus.c,
+and signal_.c, you may need to adjust signal1.h suitably.  See the
+comments in signal1.h.

lib/libF77/Version.c

@@ -1,4 +1,4 @@
-static char junk[] = "\n@(#)LIBF77 VERSION 19970226\n";
+static char junk[] = "\n@(#)LIBF77 VERSION 19970919\n";
 
 /*
 2.00	11 June 1980.  File version.c added to library.
@@ -46,4 +46,8 @@ static char junk[] = "\n@(#)LIBF77 VERSION 19970226\n";
 			to permit aliasing it with input arguments.
 			(For now, at least, this is just for possible
 			benefit of g77.)
+	4 April 1997: [cz]_div.c: tweaks invisible on most systems (that may
+			affect systems using gratuitous extra precision).
+	19 Sept. 1997: [de]time_.c (Unix systems only): change return
+			type to double.
 */

lib/libF77/c_div.c

@@ -10,28 +10,28 @@ void c_div(complex *c, complex *a, complex *b)
 #endif
 {
 	double ratio, den;
-	double abr, abi;
+	double abr, abi, cr;
-	double ai = a->i, ar = a->r, bi = b->i, br = b->r;
 
-	if( (abr = br) < 0.)
+	if( (abr = b->r) < 0.)
 		abr = - abr;
-	if( (abi = bi) < 0.)
+	if( (abi = b->i) < 0.)
 		abi = - abi;
 	if( abr <= abi )
 		{
 		if(abi == 0)
 			sig_die("complex division by zero", 1);
-		ratio = (double)br / bi ;
+		ratio = (double)b->r / b->i ;
-		den = bi * (1 + ratio*ratio);
+		den = b->i * (1 + ratio*ratio);
-		c->r = (ar*ratio + ai) / den;
+		cr = (a->r*ratio + a->i) / den;
-		c->i = (ai*ratio - ar) / den;
+		c->i = (a->i*ratio - a->r) / den;
 		}
 
 	else
 		{
-		ratio = (double)bi / br ;
+		ratio = (double)b->i / b->r ;
-		den = br * (1 + ratio*ratio);
+		den = b->r * (1 + ratio*ratio);
-		c->r = (ar + ai*ratio) / den;
+		cr = (a->r + a->i*ratio) / den;
-		c->i = (ai - ar*ratio) / den;
+		c->i = (a->i - a->r*ratio) / den;
 		}
+	c->r = cr;
 	}

lib/libF77/d_lg10.c

@@ -1,7 +1,9 @@
 #include "f2c.h"
 
+#define log10e 0.43429448190325182765
+
 #ifdef KR_headers
-double log10();
+double log();
 double d_lg10(x) doublereal *x;
 #else
 #undef abs
@@ -9,5 +11,5 @@ double d_lg10(x) doublereal *x;
 double d_lg10(doublereal *x)
 #endif
 {
-return( log10(*x) );
+return( log10e * log(*x) );
 }

lib/libF77/h_dnnt.c

@@ -9,6 +9,5 @@ shortint h_dnnt(x) doublereal *x;
 shortint h_dnnt(doublereal *x)
 #endif
 {
-return( (*x)>=0 ?
+return (shortint)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x));
-	floor(*x + .5) : -floor(.5 - *x) );
 }

lib/libF77/h_nint.c

@@ -9,6 +9,5 @@ shortint h_nint(x) real *x;
 shortint h_nint(real *x)
 #endif
 {
-return( (*x)>=0 ?
+return (shortint)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x));
-	floor(*x + .5) : -floor(.5 - *x) );
 }

lib/libF77/i_dnnt.c

@@ -9,6 +9,5 @@ integer i_dnnt(x) doublereal *x;
 integer i_dnnt(doublereal *x)
 #endif
 {
-return( (*x)>=0 ?
+return (integer)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x));
-	floor(*x + .5) : -floor(.5 - *x) );
 }

lib/libF77/i_nint.c

@@ -9,6 +9,5 @@ integer i_nint(x) real *x;
 integer i_nint(real *x)
 #endif
 {
-return( (*x)>=0 ?
+return (integer)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x));
-	floor(*x + .5) : -floor(.5 - *x) );
 }

lib/libF77/main.c

@@ -50,38 +50,44 @@ extern int MAIN__(void);
 #define Int int
 #endif
 
-static VOID sigfdie(Int n)
+static VOID sigfdie(Sigarg)
 {
+Use_Sigarg;
 sig_die("Floating Exception", 1);
 }
 
 
-static VOID sigidie(Int n)
+static VOID sigidie(Sigarg)
 {
+Use_Sigarg;
 sig_die("IOT Trap", 1);
 }
 
 #ifdef SIGQUIT
-static VOID sigqdie(Int n)
+static VOID sigqdie(Sigarg)
 {
+Use_Sigarg;
 sig_die("Quit signal", 1);
 }
 #endif
 
 
-static VOID sigindie(Int n)
+static VOID sigindie(Sigarg)
 {
+Use_Sigarg;
 sig_die("Interrupt", 0);
 }
 
-static VOID sigtdie(Int n)
+static VOID sigtdie(Sigarg)
 {
+Use_Sigarg;
 sig_die("Killed", 0);
 }
 
 #ifdef SIGTRAP
-static VOID sigtrdie(Int n)
+static VOID sigtrdie(Sigarg)
 {
+Use_Sigarg;
 sig_die("Trace trap", 1);
 }
 #endif

lib/libF77/r_lg10.c

@@ -1,7 +1,9 @@
 #include "f2c.h"
 
+#define log10e 0.43429448190325182765
+
 #ifdef KR_headers
-float log10f();
+double log();
 double r_lg10(x) real *x;
 #else
 #undef abs
@@ -9,5 +11,5 @@ double r_lg10(x) real *x;
 double r_lg10(real *x)
 #endif
 {
-return( log10f(*x) );
+return( log10e * log(*x) );
 }

lib/libF77/s_paus.c

@@ -2,6 +2,7 @@
 #include "f2c.h"
 #define PAUSESIG 15
 
+#include "signal1.h"
 #ifdef KR_headers
 #define Void /* void */
 #define Int /* int */
@@ -12,7 +13,6 @@
 #undef min
 #undef max
 #include "stdlib.h"
-#include "signal1.h"
 #ifdef __cplusplus
 extern "C" {
 #endif
@@ -22,8 +22,8 @@ extern int getpid(void), isatty(int), pause(void);
 extern VOID f_exit(Void);
 
  static VOID
-waitpause(Int n)
+waitpause(Sigarg)
-{	n = n; /* shut up compiler warning */
+{	Use_Sigarg;
 	return;
 	}
 

lib/libF77/signal1.h

@@ -12,8 +12,12 @@
 #ifdef KR_headers
 #define Sigarg_t
 #else
+#ifdef __cplusplus
+#define Sigarg_t ...
+#else
 #define Sigarg_t int
 #endif
+#endif
 #endif /*Sigarg_t*/
 
 #ifdef USE_SIG_PF	/* compile with -DUSE_SIG_PF under IRIX */
@@ -23,3 +27,11 @@ typedef Sigret_t (*sig_pf)(Sigarg_t);
 #endif
 
 #define signal1(a,b) signal(a,(sig_pf)b)
+
+#ifdef __cplusplus
+#define Sigarg ...
+#define Use_Sigarg
+#else
+#define Sigarg Int n
+#define Use_Sigarg n = n	/* shut up compiler warning */
+#endif

lib/libF77/signal_.c

@@ -1,15 +1,11 @@
 #include "f2c.h"
-
-#ifdef KR_headers
-typedef VOID (*sig_pf)();
-extern sig_pf signal();
-#define signal1 signal
-
-ftnint signal_(sigp, proc) integer *sigp; sig_pf proc;
-#else
 #include "signal1.h"
 
-ftnint signal_(integer *sigp, sig_pf proc)
+ ftnint
+#ifdef KR_headers
+signal_(sigp, proc) integer *sigp; sig_pf proc;
+#else
+signal_(integer *sigp, sig_pf proc)
 #endif
 {
 	int sig;

lib/libF77/z_div.c

@@ -1,7 +1,7 @@
 #include "f2c.h"
 
 #ifdef KR_headers
-extern void sig_die();
+extern VOID sig_die();
 VOID z_div(c, a, b) doublecomplex *a, *b, *c;
 #else
 extern void sig_die(char*, int);
@@ -9,28 +9,28 @@ void z_div(doublecomplex *c, doublecomplex *a, doublecomplex *b)
 #endif
 {
 	double ratio, den;
-	double abr, abi;
+	double abr, abi, cr;
-	double ai = a->i, ar = a->r, bi = b->i, br = b->r;
 
-	if( (abr = br) < 0.)
+	if( (abr = b->r) < 0.)
 		abr = - abr;
-	if( (abi = bi) < 0.)
+	if( (abi = b->i) < 0.)
 		abi = - abi;
 	if( abr <= abi )
 		{
 		if(abi == 0)
 			sig_die("complex division by zero", 1);
-		ratio = br / bi ;
+		ratio = b->r / b->i ;
-		den = bi * (1 + ratio*ratio);
+		den = b->i * (1 + ratio*ratio);
-		c->r = (ar*ratio + ai) / den;
+		cr = (a->r*ratio + a->i) / den;
-		c->i = (ai*ratio - ar) / den;
+		c->i = (a->i*ratio - a->r) / den;
 		}
 
 	else
 		{
-		ratio = bi / br ;
+		ratio = b->i / b->r ;
-		den = br * (1 + ratio*ratio);
+		den = b->r * (1 + ratio*ratio);
-		c->r = (ar + ai*ratio) / den;
+		cr = (a->r + a->i*ratio) / den;
-		c->i = (ai - ar*ratio) / den;
+		c->i = (a->i - a->r*ratio) / den;
 		}
+	c->r = cr;
 	}

lib/libI77/Notice

@@ -1,23 +1,23 @@
 /****************************************************************
-Copyright 1990 - 1997 by AT&T Bell Laboratories and Bellcore.
+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 or
+documentation, and that the names of AT&T, Bell Laboratories,
-Bellcore or any of their entities not be used in advertising or
+Lucent or Bellcore or any of their entities not be used in
-publicity pertaining to distribution of the software without
+advertising or publicity pertaining to distribution of the
-specific, written prior permission.
+software without specific, written prior permission.
 
-AT&T and Bellcore disclaim all warranties with regard to this
+AT&T, Lucent and Bellcore disclaim all warranties with regard to
-software, including all implied warranties of merchantability
+this software, including all implied warranties of
-and fitness.  In no event shall AT&T or Bellcore be liable for
+merchantability and fitness.  In no event shall AT&T, Lucent or
-any special, indirect or consequential damages or any damages
+Bellcore be liable for any special, indirect or consequential
-whatsoever resulting from loss of use, data or profits, whether
+damages or any damages whatsoever resulting from loss of use,
-in an action of contract, negligence or other tortious action,
+data or profits, whether in an action of contract, negligence or
-arising out of or in connection with the use or performance of
+other tortious action, arising out of or in connection with the
-this software.
+use or performance of this software.
 ****************************************************************/
 

lib/libI77/Version.c

@@ -1,4 +1,4 @@
-static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 19970226\n";
+static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 19980907\n";
 
 /*
 2.01	$ format added
@@ -242,3 +242,51 @@ wrtfmt.c:
 		 ftell_.c: change param "unit" to "Unit" for -DKR_headers. */
 /* 26 Feb. 1997: ftell_.c: on systems that define SEEK_SET, etc., use
 		 SEEK_SET, SEEK_CUR, SEEK_END for *whence = 0, 1, 2. */
+/* 7 Apr. 1997:	 fmt.c: adjust to complain at missing numbers in formats
+		 (but still treat missing ".nnn" as ".0"). */
+/* 11 Apr. 1997: err.c: attempt to make stderr line buffered rather
+		 than fully buffered.  (Buffering is needed for format
+		 items T and TR.) */
+/* 27 May 1997:  ftell_.c: fix typo (that caused the third argument to be
+		 treated as 2 on some systems). */
+/* 5 Aug. 1997:  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; compile
+		 with -DF8X_NML_ELIDE_QUOTES to get the old behavior.
+		 wrtfmt.o: wrt_G: tweak to print the right number of 0's
+		 for zero under G format. */
+/* 16 Aug. 1997: 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). */
+/* 16 Sept. 1997: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). */
+/* 19 Jan. 1998: 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). */
+/* 4 March 1998: open.c: fix glitch in comparing file names under
+		-DNON_UNIX_STDIO */
+/* 17 March 1998: 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. */
+/* 5 April 1998: wsfe.c: make $ format item work: this was lost in the
+		 changes of 17 March 1998. */
+/* 28 May 1998:	 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. */
+/* 17 June 1998: lread.c: unless compiled with
+		 ALLOW_FLOAT_IN_INTEGER_LIST_INPUT #defined, treat
+		 floating-point numbers (containing either a decimal point
+		 or an exponent field) as errors when they appear as list
+		 input for integer data. */
+/* 7 Sept. 1998: move e_wdfe from sfe.c to dfe.c, where it was originally.
+		 Why did it ever move to sfe.c? */

lib/libI77/backspace.c

@@ -6,18 +6,15 @@ integer f_back(a) alist *a;
 integer f_back(alist *a)
 #endif
 {	unit *b;
-	int i, n, ndec;
+	long v, w, x, y, z;
-#ifdef MSDOS
+	uiolen n;
-	int j, k;
+	FILE *f;
-	long w, z;
+
-#endif
+	f__curunit = b = &f__units[a->aunit];	/* curunit for error messages */
-	long x, y;
-	char buf[32];
 	if(a->aunit >= MXUNIT || a->aunit < 0)
 		err(a->aerr,101,"backspace")
-	b= &f__units[a->aunit];
 	if(b->useek==0) err(a->aerr,106,"backspace")
-	if(b->ufd==NULL) {
+	if((f = b->ufd) == NULL) {
 		fk_open(1, 1, a->aunit);
 		return(0);
 		}
@@ -32,67 +29,41 @@ integer f_back(alist *a)
 		}
 	if(b->url>0)
 	{
-		x=ftell(b->ufd);
+		x=ftell(f);
 		y = x % b->url;
 		if(y == 0) x--;
 		x /= b->url;
 		x *= b->url;
-		(void) fseek(b->ufd,x,SEEK_SET);
+		(void) fseek(f,x,SEEK_SET);
 		return(0);
 	}
 
 	if(b->ufmt==0)
-	{	(void) fseek(b->ufd,-(long)sizeof(int),SEEK_CUR);
+	{	fseek(f,-(long)sizeof(uiolen),SEEK_CUR);
-		(void) fread((char *)&n,sizeof(int),1,b->ufd);
+		fread((char *)&n,sizeof(uiolen),1,f);
-		(void) fseek(b->ufd,-(long)n-2*sizeof(int),SEEK_CUR);
+		fseek(f,-(long)n-2*sizeof(uiolen),SEEK_CUR);
 		return(0);
 	}
-#ifdef MSDOS
+	w = x = ftell(f);
-	w = -1;
+	z = 0;
-#endif
+ loop:
-	for(ndec = 1;; ndec = 0)
+	while(x) {
-	{
+		x -= x < 64 ? x : 64;
-		y = x = ftell(b->ufd);
+		fseek(f,x,SEEK_SET);
-		if(x < sizeof(buf))
+		for(y = x; y < w; y++) {
-			x = 0;
+			if (getc(f) != '\n')
-		else
+				continue;
-			x -= sizeof(buf);
+			v = ftell(f);
-		(void) fseek(b->ufd,x,SEEK_SET);
+			if (v == w) {
-		n=fread(buf,1,(int)(y-x), b->ufd);
+				if (z)
-		for(i = n - ndec; --i >= 0; )
-		{
-			if(buf[i]!='\n') continue;
-#ifdef MSDOS
-			for(j = k = 0; j <= i; j++)
-				if (buf[j] == '\n')
-					k++;
-			fseek(b->ufd,x,SEEK_SET);
-			for(;;)
-				if (getc(b->ufd) == '\n') {
-					if ((z = ftell(b->ufd)) >= y && ndec) {
-						if (w == -1)
 					goto break2;
-						break;
+				goto loop;
 				}
-					if (--k <= 0)
+			z = v;
-						return 0;
-					w = z;
 			}
-			fseek(b->ufd, w, SEEK_SET);
+		err(a->aerr,(EOF),"backspace")
-#else
-			fseek(b->ufd,(long)(i+1-n),SEEK_CUR);
-#endif
-			return(0);
 		}
-#ifdef MSDOS
  break2:
-#endif
+	fseek(f, z, SEEK_SET);
-		if(x==0)
+	return 0;
-			{
-			(void) fseek(b->ufd, 0L, SEEK_SET);
-			return(0);
-			}
-		else if(n<=0) err(a->aerr,(EOF),"backspace")
-		(void) fseek(b->ufd, x, SEEK_SET);
-	}
 }

lib/libI77/close.c

@@ -31,10 +31,9 @@ integer f_clos(cllist *a)
 	b= &f__units[a->cunit];
 	if(b->ufd==NULL)
 		goto done;
-	if (!a->csta)
 	if (b->uscrtch == 1)
 		goto Delete;
-		else
+	if (!a->csta)
 		goto Keep;
 	switch(*a->csta) {
 		default:
@@ -51,8 +50,8 @@ integer f_clos(cllist *a)
 		case 'd':
 		case 'D':
 		Delete:
-			if(b->ufnm) {
 			fclose(b->ufd);
+			if(b->ufnm) {
 				unlink(b->ufnm); /*SYSDEP*/
 				free(b->ufnm);
 				}

lib/libI77/dfe.c

@@ -31,41 +31,30 @@ y_getc(Void)
 	}
 	err(f__elist->cierr,errno,"readingd");
 }
-#ifdef KR_headers
+
-y_putc(c)
+ static int
-#else
-y_putc(int c)
-#endif
-{
-	f__recpos++;
-	if(f__recpos <= f__curunit->url || f__curunit->url==1)
-		putc(c,f__cf);
-	else
-		err(f__elist->cierr,110,"dout");
-	return(0);
-}
 y_rev(Void)
-{	/*what about work done?*/
+{
-	if(f__curunit->url==1 || f__recpos==f__curunit->url)
+	if (f__recpos < f__hiwater)
-		return(0);
+		f__recpos = f__hiwater;
-	while(f__recpos<f__curunit->url)
+	if (f__curunit->url > 1)
+		while(f__recpos < f__curunit->url)
 			(*f__putn)(' ');
-	f__recpos=0;
+	if (f__recpos)
+		f__putbuf(0);
+	f__recpos = 0;
 	return(0);
 }
+
+ static int
 y_err(Void)
 {
 	err(f__elist->cierr, 110, "dfe");
 }
 
+ static int
 y_newrec(Void)
 {
-	if(f__curunit->url == 1 || f__recpos == f__curunit->url) {
-		f__hiwater = f__recpos = f__cursor = 0;
-		return(1);
-	}
-	if(f__hiwater > f__recpos)
-		f__recpos = f__hiwater;
 	y_rev();
 	f__hiwater = f__cursor = 0;
 	return(1);
@@ -81,9 +70,9 @@ c_dfe(cilist *a)
 	f__formatted=f__external=1;
 	f__elist=a;
 	f__cursor=f__scale=f__recpos=0;
+	f__curunit = &f__units[a->ciunit];
 	if(a->ciunit>MXUNIT || a->ciunit<0)
 		err(a->cierr,101,"startchk");
-	f__curunit = &f__units[a->ciunit];
 	if(f__curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit))
 		err(a->cierr,104,"dfe");
 	f__cf=f__curunit->ufd;
@@ -130,7 +119,7 @@ integer s_wdfe(cilist *a)
 	if(n=c_dfe(a)) return(n);
 	if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
 		err(a->cierr,errno,"startwrt");
-	f__putn = y_putc;
+	f__putn = x_putc;
 	f__doed = w_ed;
 	f__doned= w_ned;
 	f__dorevert = y_err;
@@ -143,8 +132,8 @@ integer s_wdfe(cilist *a)
 }
 integer e_rdfe(Void)
 {
-	(void) en_fio();
+	en_fio();
-	return(0);
+	return 0;
 }
 integer e_wdfe(Void)
 {

lib/libI77/due.c

@@ -8,11 +8,11 @@ c_due(cilist *a)
 #endif
 {
 	if(!f__init) f_init();
-	if(a->ciunit>=MXUNIT || a->ciunit<0)
-		err(a->cierr,101,"startio");
 	f__sequential=f__formatted=f__recpos=0;
 	f__external=1;
 	f__curunit = &f__units[a->ciunit];
+	if(a->ciunit>=MXUNIT || a->ciunit<0)
+		err(a->cierr,101,"startio");
 	f__elist=a;
 	if(f__curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due");
 	f__cf=f__curunit->ufd;

lib/libI77/endfile.c

@@ -1,12 +1,9 @@
 #include "f2c.h"
 #include "fio.h"
-#ifndef NON_UNIX_STDIO
-#include "sys/types.h"
-#endif
-#include "rawio.h"
 
 #ifdef KR_headers
 extern char *strcpy();
+extern FILE *tmpfile();
 #else
 #undef abs
 #undef min
@@ -15,19 +12,7 @@ extern char *strcpy();
 #include "string.h"
 #endif
 
-#ifdef NON_UNIX_STDIO
-#ifndef unlink
-#define unlink remove
-#endif
-#else
-#ifdef MSDOS
-#include "io.h"
-#endif
-#endif
-
-#ifdef NON_UNIX_STDIO
 extern char *f__r_mode[], *f__w_mode[];
-#endif
 
 #ifdef KR_headers
 integer f_end(a) alist *a;
@@ -36,19 +21,15 @@ integer f_end(alist *a)
 #endif
 {
 	unit *b;
+	FILE *tf;
+
 	if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile");
 	b = &f__units[a->aunit];
 	if(b->ufd==NULL) {
 		char nbuf[10];
-		(void) sprintf(nbuf,"fort.%ld",a->aunit);
+		sprintf(nbuf,"fort.%ld",a->aunit);
-#ifdef NON_UNIX_STDIO
-		{ FILE *tf;
 		if (tf = fopen(nbuf, f__w_mode[0]))
 			fclose(tf);
-			}
-#else
-		close(creat(nbuf, 0666));
-#endif
 		return(0);
 		}
 	b->uend=1;
@@ -56,14 +37,13 @@ integer f_end(alist *a)
 }
 
  static int
-#ifdef NON_UNIX_STDIO
 #ifdef KR_headers
-copy(from, len, to) char *from, *to; register long len;
+copy(from, len, to) FILE *from, *to; register long len;
 #else
 copy(FILE *from, register long len, FILE *to)
 #endif
 {
-	int k, len1;
+	int len1;
 	char buf[BUFSIZ];
 
 	while(fread(buf, len1 = len > BUFSIZ ? BUFSIZ : (int)len, 1, from)) {
@@ -74,36 +54,6 @@ copy(FILE *from, register long len, FILE *to)
 		}
 	return 0;
 	}
-#else
-#ifdef KR_headers
-copy(from, len, to) char *from, *to; register long len;
-#else
-copy(char *from, register long len, char *to)
-#endif
-{
-	register int n;
-	int k, rc = 0, tmp;
-	char buf[BUFSIZ];
-
-	if ((k = open(from, O_RDONLY)) < 0)
-		return 1;
-	if ((tmp = creat(to,0666)) < 0)
-		return 1;
-	while((n = read(k, buf, len > BUFSIZ ? BUFSIZ : (int)len)) > 0) {
-		if (write(tmp, buf, n) != n)
-			{ rc = 1; break; }
-		if ((len -= n) <= 0)
-			break;
-		}
-	close(k);
-	close(tmp);
-	return n < 0 ? 1 : rc;
-	}
-#endif
-
-#ifndef L_tmpnam
-#define L_tmpnam 16
-#endif
 
  int
 #ifdef KR_headers
@@ -112,14 +62,9 @@ t_runc(a) alist *a;
 t_runc(alist *a)
 #endif
 {
-	char nm[L_tmpnam+12];	/* extra space in case L_tmpnam is tiny */
 	long loc, len;
 	unit *b;
-#ifdef NON_UNIX_STDIO
 	FILE *bf, *tf;
-#else
-	FILE *bf;
-#endif
 	int rc = 0;
 
 	b = &f__units[a->aunit];
@@ -130,36 +75,20 @@ t_runc(alist *a)
 	len=ftell(bf);
 	if (loc >= len || b->useek == 0 || b->ufnm == NULL)
 		return(0);
-#ifdef NON_UNIX_STDIO
 	fclose(b->ufd);
-#else
-	rewind(b->ufd);	/* empty buffer */
-#endif
 	if (!loc) {
-#ifdef NON_UNIX_STDIO
 		if (!(bf = fopen(b->ufnm, f__w_mode[b->ufmt])))
-#else
-		if (close(creat(b->ufnm,0666)))
-#endif
 			rc = 1;
 		if (b->uwrt)
 			b->uwrt = 1;
 		goto done;
 		}
-#ifdef _POSIX_SOURCE
+	if (!(bf = fopen(b->ufnm, f__r_mode[0]))
-	tmpnam(nm);
+	 || !(tf = tmpfile())) {
-#else
-	strcpy(nm,"tmp.FXXXXXX");
-	mktemp(nm);
-#endif
-#ifdef NON_UNIX_STDIO
-	if (!(bf = fopen(b->ufnm, f__r_mode[0]))) {
  bad:
 		rc = 1;
 		goto done;
 		}
-	if (!(tf = fopen(nm, f__w_mode[0])))
-		goto bad;
 	if (copy(bf, loc, tf)) {
  bad1:
 		rc = 1;
@@ -167,28 +96,23 @@ t_runc(alist *a)
 		}
 	if (!(bf = freopen(b->ufnm, f__w_mode[0], bf)))
 		goto bad1;
-	if (!(tf = freopen(nm, f__r_mode[0], tf)))
+	rewind(tf);
-		goto bad1;
 	if (copy(tf, loc, bf))
 		goto bad1;
-	if (f__w_mode[0] != f__w_mode[b->ufmt]) {
+	b->urw = 2;
-	 	if (!(bf = freopen(b->ufnm, f__w_mode[b->ufmt|2], bf)))
+#ifdef NON_UNIX_STDIO
-			goto bad1;
+	if (b->ufmt) {
-		fseek(bf, loc, SEEK_SET);
+		fclose(bf);
+		if (!(bf = fopen(b->ufnm, f__w_mode[3])))
+			goto bad;
+		fseek(bf,0L,SEEK_END);
+		b->urw = 3;
 		}
+#endif
 done1:
 	fclose(tf);
-	unlink(nm);
 done:
 	f__cf = b->ufd = bf;
-#else
-	if (copy(b->ufnm, loc, nm)
-	 || copy(nm, loc, b->ufnm))
-		rc = 1;
-	unlink(nm);
-	fseek(b->ufd, loc, SEEK_SET);
-done:
-#endif
 	if (rc)
 		err(a->aerr,111,"endfile");
 	return 0;

lib/libI77/err.c

@@ -1,12 +1,10 @@
 #ifndef NON_UNIX_STDIO
+#define _INCLUDE_POSIX_SOURCE	/* for HP-UX */
+#define _INCLUDE_XOPEN_SOURCE	/* for HP-UX */
 #include "sys/types.h"
 #include "sys/stat.h"
 #endif
 #include "f2c.h"
-#include "fio.h"
-#include "fmt.h"	/* for struct syl */
-#include "rawio.h"	/* for fcntl.h, fdopen */
-#ifdef NON_UNIX_STDIO
 #ifdef KR_headers
 extern char *malloc();
 #else
@@ -15,7 +13,8 @@ extern char *malloc();
 #undef max
 #include "stdlib.h"
 #endif
-#endif
+#include "fio.h"
+#include "fmt.h"	/* for struct syl */
 
 /*global definitions*/
 unit f__units[MXUNIT];	/*unit table*/
@@ -29,9 +28,11 @@ flag f__external;	/*1 if external io, 0 if internal */
 #ifdef KR_headers
 int (*f__doed)(),(*f__doned)();
 int (*f__doend)(),(*f__donewrec)(),(*f__dorevert)();
-int (*f__getn)(),(*f__putn)();	/*for formatted io*/
+int (*f__getn)();	/* for formatted input */
+void (*f__putn)();	/* for formatted output */
 #else
-int (*f__getn)(void),(*f__putn)(int);	/*for formatted io*/
+int (*f__getn)(void);	/* for formatted input */
+void (*f__putn)(int);	/* for formatted output */
 int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*);
 int (*f__dorevert)(void),(*f__donewrec)(void),(*f__doend)(void);
 #endif
@@ -171,11 +172,6 @@ f_init(Void)
 	p= &f__units[0];
 	p->ufd=stderr;
 	p->useek=f__canseek(stderr);
-#ifdef NON_UNIX_STDIO
-	setbuf(stderr, (char *)malloc(BUFSIZ));
-#else
-	stderr->_flag &= ~_IONBF;
-#endif
 	p->ufmt=1;
 	p->uwrt=1;
 	p = &f__units[5];
@@ -196,21 +192,29 @@ f__nowreading(unit *x)
 #endif
 {
 	long loc;
-	int ufmt;
+	int ufmt, urw;
-	extern char *f__r_mode[];
+	extern char *f__r_mode[], *f__w_mode[];
 
+	if (x->urw & 1)
+		goto done;
 	if (!x->ufnm)
 		goto cantread;
-	ufmt = x->ufmt;
+	ufmt = x->url ? 0 : x->ufmt;
-	loc=ftell(x->ufd);
+	loc = ftell(x->ufd);
-	if(freopen(x->ufnm,f__r_mode[ufmt],x->ufd) == NULL) {
+	urw = 3;
+	if (!freopen(x->ufnm, f__w_mode[ufmt|2], x->ufd)) {
+		urw = 1;
+		if(!freopen(x->ufnm, f__r_mode[ufmt], x->ufd)) {
  cantread:
 			errno = 126;
-		return(1);
+			return 1;
 			}
-	x->uwrt=0;
+		}
-	(void) fseek(x->ufd,loc,SEEK_SET);
+	fseek(x->ufd,loc,SEEK_SET);
-	return(0);
+	x->urw = urw;
+ done:
+	x->uwrt = 0;
+	return 0;
 }
 #ifdef KR_headers
 f__nowwriting(x) unit *x;
@@ -221,46 +225,34 @@ f__nowwriting(unit *x)
 	long loc;
 	int ufmt;
 	extern char *f__w_mode[];
-#ifndef NON_UNIX_STDIO
-	int k;
-#endif
 
+	if (x->urw & 2)
+		goto done;
 	if (!x->ufnm)
 		goto cantwrite;
-	ufmt = x->ufmt;
+	ufmt = x->url ? 0 : x->ufmt;
-#ifdef NON_UNIX_STDIO
-	ufmt |= 2;
-#endif
 	if (x->uwrt == 3) { /* just did write, rewind */
-#ifdef NON_UNIX_STDIO
 		if (!(f__cf = x->ufd =
 				freopen(x->ufnm,f__w_mode[ufmt],x->ufd)))
-#else
-		if (close(creat(x->ufnm,0666)))
-#endif
 			goto cantwrite;
+		x->urw = 2;
 		}
 	else {
 		loc=ftell(x->ufd);
-#ifdef NON_UNIX_STDIO
 		if (!(f__cf = x->ufd =
-			freopen(x->ufnm, f__w_mode[ufmt], x->ufd)))
+			freopen(x->ufnm, f__w_mode[ufmt |= 2], x->ufd)))
-#else
-		if (fclose(x->ufd) < 0
-		|| (k = x->uwrt == 2 ? creat(x->ufnm,0666)
-				     : open(x->ufnm,O_WRONLY)) < 0
-		|| (f__cf = x->ufd = fdopen(k,f__w_mode[ufmt])) == NULL)
-#endif
 			{
 			x->ufd = NULL;
  cantwrite:
 			errno = 127;
 			return(1);
 			}
-		(void) fseek(x->ufd,loc,SEEK_SET);
+		x->urw = 3;
+		fseek(x->ufd,loc,SEEK_SET);
 		}
+ done:
 	x->uwrt = 1;
-	return(0);
+	return 0;
 }
 
  int

lib/libI77/fio.h

@@ -34,7 +34,7 @@ typedef struct
 	int url;	/*0=sequential*/
 	flag useek;	/*true=can backspace, use dir, ...*/
 	flag ufmt;
-	flag uprnt;
+	flag urw;	/* (1 for can read) | (2 for can write) */
 	flag ublnk;
 	flag uend;
 	flag uwrt;	/*last io was write*/
@@ -47,17 +47,21 @@ extern flag f__reading,f__external,f__sequential,f__formatted;
 #undef Void
 #ifdef KR_headers
 #define Void /*void*/
-extern int (*f__getn)(),(*f__putn)();	/*for formatted io*/
+extern int (*f__getn)();	/* for formatted input */
+extern void (*f__putn)();	/* for formatted output */
+extern void x_putc();
 extern long f__inode();
 extern VOID sig_die();
 extern int (*f__donewrec)(), t_putc(), x_wSL();
-extern int c_sfe(), err__fl(), xrd_SL();
+extern int c_sfe(), err__fl(), xrd_SL(), f__putbuf();
 #else
 #define Void void
 #ifdef __cplusplus
 extern "C" {
 #endif
-extern int (*f__getn)(void),(*f__putn)(int);	/*for formatted io*/
+extern int (*f__getn)(void);	/* for formatted input */
+extern void (*f__putn)(int);	/* for formatted output */
+extern void x_putc(int);
 extern long f__inode(char*,int*);
 extern void sig_die(char*,int);
 extern void f__fatal(int,char*);
@@ -72,6 +76,7 @@ extern int c_sfe(cilist*), z_rnew(void);
 extern int isatty(int);
 extern int err__fl(int,int,char*);
 extern int xrd_SL(void);
+extern int f__putbuf(int);
 #ifdef __cplusplus
 	}
 #endif

lib/libI77/fmt.c

@@ -18,9 +18,10 @@
 	/* special quote character for stu */
 extern int f__cursor,f__scale;
 extern flag f__cblank,f__cplus;	/*blanks in I and compulsory plus*/
-struct syl f__syl[SYLMX];
+static struct syl f__syl[SYLMX];
 int f__parenlvl,f__pc,f__revloc;
 
+ static
 #ifdef KR_headers
 char *ap_end(s) char *s;
 #else
@@ -39,6 +40,7 @@ char *ap_end(char *s)
 	f__fatal(100, "bad string");
 	/*NOTREACHED*/ return 0;
 }
+ static
 #ifdef KR_headers
 op_gen(a,b,c,d)
 #else
@@ -51,16 +53,16 @@ op_gen(int a, int b, int c, int d)
 	}
 	p->op=a;
 	p->p1=b;
-	p->p2=c;
+	p->p2.i[0]=c;
-	p->p3=d;
+	p->p2.i[1]=d;
 	return(f__pc++);
 }
 #ifdef KR_headers
-char *f_list();
+static char *f_list();
-char *gt_num(s,n) char *s; int *n;
+static char *gt_num(s,n,n1) char *s; int *n, n1;
 #else
-char *f_list(char*);
+static char *f_list(char*);
-char *gt_num(char *s, int *n)
+static char *gt_num(char *s, int *n, int n1)
 #endif
 {	int m=0,f__cnt=0;
 	char c;
@@ -74,10 +76,16 @@ char *gt_num(char *s, int *n)
 		f__cnt++;
 		s++;
 	}
-	if(f__cnt==0) *n=1;
+	if(f__cnt==0) {
+		if (!n1)
+			s = 0;
+		*n=n1;
+		}
 	else *n=m;
 	return(s);
 }
+
+ static
 #ifdef KR_headers
 char *f_s(s,curloc) char *s;
 #else
@@ -98,6 +106,8 @@ char *f_s(char *s, int curloc)
 	skip(s);
 	return(s);
 }
+
+ static
 #ifdef KR_headers
 ne_d(s,p) char *s,**p;
 #else
@@ -135,7 +145,10 @@ ne_d(char *s, char **p)
 	case '+':	s++;	/*OUTRAGEOUS CODING TRICK*/
 	case '0': case '1': case '2': case '3': case '4':
 	case '5': case '6': case '7': case '8': case '9':
-		s=gt_num(s,&n);
+		if (!(s=gt_num(s,&n,0))) {
+ bad:			*p = 0;
+			return 1;
+			}
 		switch(*s)
 		{
 		default:
@@ -147,7 +160,7 @@ ne_d(char *s, char **p)
 		case 'H':
 		case 'h':
 			sp = &f__syl[op_gen(H,n,0,0)];
-			*(char **)&sp->p2 = s + 1;
+			sp->p2.s = s + 1;
 			s+=n;
 			break;
 		}
@@ -156,7 +169,7 @@ ne_d(char *s, char **p)
 	case '"':
 	case '\'':
 		sp = &f__syl[op_gen(APOS,0,0,0)];
-		*(char **)&sp->p2 = s;
+		sp->p2.s = s;
 		if((*p = ap_end(s)) == NULL)
 			return(0);
 		return(1);
@@ -171,7 +184,8 @@ ne_d(char *s, char **p)
 			s++;
 		}
 		else x=T;
-		s=gt_num(s+1,&n);
+		if (!(s=gt_num(s+1,&n,0)))
+			goto bad;
 		s--;
 		(void) op_gen(x,n,0,0);
 		break;
@@ -184,6 +198,8 @@ ne_d(char *s, char **p)
 	*p=s;
 	return(1);
 }
+
+ static
 #ifdef KR_headers
 e_d(s,p) char *s,**p;
 #else
@@ -191,7 +207,7 @@ e_d(char *s, char **p)
 #endif
 {	int i,im,n,w,d,e,found=0,x=0;
 	char *sv=s;
-	s=gt_num(s,&n);
+	s=gt_num(s,&n,1);
 	(void) op_gen(STACK,n,0,0);
 	switch(*s++)
 	{
@@ -201,18 +217,22 @@ e_d(char *s, char **p)
 	case 'G':
 	case 'g':
 		found=1;
-		s=gt_num(s,&w);
+		if (!(s=gt_num(s,&w,0))) {
+ bad:
+			*p = 0;
+			return 1;
+			}
 		if(w==0) break;
-		if(*s=='.')
+		if(*s=='.') {
-		{	s++;
+			if (!(s=gt_num(s+1,&d,0)))
-			s=gt_num(s,&d);
+				goto bad;
 			}
 		else d=0;
 		if(*s!='E' && *s != 'e')
 			(void) op_gen(x==1?E:G,w,d,0);	/* default is Ew.dE2 */
-		else
+		else {
-		{	s++;
+			if (!(s=gt_num(s+1,&e,0)))
-			s=gt_num(s,&e);
+				goto bad;
 			(void) op_gen(x==1?EE:GE,w,d,e);
 			}
 		break;
@@ -229,7 +249,8 @@ e_d(char *s, char **p)
 	case 'L':
 	case 'l':
 		found=1;
-		s=gt_num(s,&w);
+		if (!(s=gt_num(s,&w,0)))
+			goto bad;
 		if(w==0) break;
 		(void) op_gen(L,w,0,0);
 		break;
@@ -238,7 +259,7 @@ e_d(char *s, char **p)
 		found=1;
 		skip(s);
 		if(*s>='0' && *s<='9')
-		{	s=gt_num(s,&w);
+		{	s=gt_num(s,&w,1);
 			if(w==0) break;
 			(void) op_gen(AW,w,0,0);
 			break;
@@ -247,12 +268,13 @@ e_d(char *s, char **p)
 		break;
 	case 'F':
 	case 'f':
+		if (!(s=gt_num(s,&w,0)))
+			goto bad;
 		found=1;
-		s=gt_num(s,&w);
 		if(w==0) break;
-		if(*s=='.')
+		if(*s=='.') {
-		{	s++;
+			if (!(s=gt_num(s+1,&d,0)))
-			s=gt_num(s,&d);
+				goto bad;
 			}
 		else d=0;
 		(void) op_gen(F,w,d,0);
@@ -260,11 +282,12 @@ e_d(char *s, char **p)
 	case 'D':
 	case 'd':
 		found=1;
-		s=gt_num(s,&w);
+		if (!(s=gt_num(s,&w,0)))
+			goto bad;
 		if(w==0) break;
-		if(*s=='.')
+		if(*s=='.') {
-		{	s++;
+			if (!(s=gt_num(s+1,&d,0)))
-			s=gt_num(s,&d);
+				goto bad;
 			}
 		else d=0;
 		(void) op_gen(D,w,d,0);
@@ -274,15 +297,16 @@ e_d(char *s, char **p)
 		i = I;
 		im = IM;
  finish_I:
+		if (!(s=gt_num(s,&w,0)))
+			goto bad;
 		found=1;
-		s=gt_num(s,&w);
 		if(w==0) break;
 		if(*s!='.')
 		{	(void) op_gen(i,w,0,0);
 			break;
 		}
-		s++;
+		if (!(s=gt_num(s+1,&d,0)))
-		s=gt_num(s,&d);
+			goto bad;
 		(void) op_gen(im,w,d,0);
 		break;
 	}
@@ -294,6 +318,7 @@ e_d(char *s, char **p)
 	*p=s;
 	return(1);
 }
+ static
 #ifdef KR_headers
 char *i_tem(s) char *s;
 #else
@@ -304,10 +329,12 @@ char *i_tem(char *s)
 	if(*s==')') return(s);
 	if(ne_d(s,&t)) return(t);
 	if(e_d(s,&t)) return(t);
-	s=gt_num(s,&n);
+	s=gt_num(s,&n,1);
 	if((curloc=op_gen(STACK,n,0,0))<0) return(NULL);
 	return(f_s(s,curloc));
 }
+
+ static
 #ifdef KR_headers
 char *f_list(s) char *s;
 #else
@@ -349,6 +376,7 @@ pars_f(char *s)
 int f__cnt[STKSZ],f__ret[STKSZ],f__cp,f__rp;
 flag f__workdone, f__nonl;
 
+ static
 #ifdef KR_headers
 type_f(n)
 #else

lib/libI77/fmt.h

@@ -1,6 +1,8 @@
 struct syl
-{	int op,p1,p2,p3;
+{	int op;
-};
+	int p1;
+	union { int i[2]; char *s;} p2;
+	};
 #define RET1 1
 #define REVERT 2
 #define GOTO 3
@@ -37,7 +39,6 @@ struct syl
 #define OM 34
 #define Z 35
 #define ZM 36
-extern struct syl f__syl[];
 extern int f__pc,f__parenlvl,f__revloc;
 typedef union
 {	real pf;

lib/libI77/iio.c

@@ -14,17 +14,16 @@ z_getc(Void)
 		}
 	return '\n';
 }
+
+ void
 #ifdef KR_headers
 z_putc(c)
 #else
 z_putc(int c)
 #endif
 {
-	if(f__icptr >= f__icend) err(f__svic->icierr,110,"inwrite");
+	if (f__icptr < f__icend && f__recpos++ < f__svic->icirlen)
-	if(f__recpos++ < f__svic->icirlen)
 		*f__icptr++ = c;
-	else	err(f__svic->icierr,110,"recend");
-	return 0;
 }
 z_rnew(Void)
 {
@@ -50,11 +49,12 @@ c_si(icilist *a)
 {
 	f__elist = (cilist *)a;
 	f__fmtbuf=a->icifmt;
+	f__curunit = 0;
+	f__sequential=f__formatted=1;
+	f__external=0;
 	if(pars_f(f__fmtbuf)<0)
 		err(a->icierr,100,"startint");
 	fmt_bg();
-	f__sequential=f__formatted=1;
-	f__external=0;
 	f__cblank=f__cplus=f__scale=0;
 	f__svic=a;
 	f__icnum=f__recpos=0;
@@ -62,7 +62,6 @@ c_si(icilist *a)
 	f__hiwater = 0;
 	f__icptr = a->iciunit;
 	f__icend = f__icptr + a->icirlen*a->icirnum;
-	f__curunit = 0;
 	f__cf = 0;
 	return(0);
 }
@@ -124,8 +123,7 @@ integer s_wsfi(icilist *a)
 	return(0);
 }
 integer e_rsfi(Void)
-{	int n;
+{	int n = en_fio();
-	n = en_fio();
 	f__fmtbuf = NULL;
 	return(n);
 }
@@ -134,9 +132,17 @@ integer e_wsfi(Void)
 	int n;
 	n = en_fio();
 	f__fmtbuf = NULL;
-	if(f__icnum >= f__svic->icirnum)
+	if(f__svic->icirnum != 1
-		return(n);
+	 && (f__icnum >  f__svic->icirnum
+	 || (f__icnum == f__svic->icirnum && (f__recpos | f__hiwater))))
+		err(f__svic->icierr,110,"inwrite");
+	if (f__recpos < f__hiwater)
+		f__recpos = f__hiwater;
+	if (f__recpos >= f__svic->icirlen)
+		err(f__svic->icierr,110,"recend");
+	if (!f__recpos && f__icnum)
+		return n;
 	while(f__recpos++ < f__svic->icirlen)
 		*f__icptr++ = ' ';
-	return(n);
+	return n;
 }

lib/libI77/ilnw.c

@@ -6,9 +6,9 @@ extern char *f__icend;
 extern icilist *f__svic;
 extern int f__icnum;
 #ifdef KR_headers
-extern int z_putc();
+extern void z_putc();
 #else
-extern int z_putc(int);
+extern void z_putc(int);
 #endif
 
  static int
@@ -19,7 +19,7 @@ z_wSL(Void)
 	return z_rnew();
 	}
 
- VOID
+ static void
 #ifdef KR_headers
 c_liw(a) icilist *a;
 #else

lib/libI77/inquire.c

@@ -1,5 +1,6 @@
 #include "f2c.h"
 #include "fio.h"
+#include "string.h"
 #ifdef KR_headers
 integer f_inqu(a) inlist *a;
 #else
@@ -7,7 +8,6 @@ integer f_inqu(a) inlist *a;
 #undef abs
 #undef min
 #undef max
-#include "string.h"
 #include "io.h"
 #endif
 integer f_inqu(inlist *a)

lib/libI77/lread.c

@@ -1,15 +1,15 @@
 #include "f2c.h"
 #include "fio.h"
-#include "fmt.h"
+
-#include "lio.h"
+/* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */
-#include "ctype.h"
+/* marks in namelist input a la the Fortran 8X Draft published in  */
-#include "fp.h"
+/* the May 1989 issue of Fortran Forum. */
+
 
 extern char *f__fmtbuf;
 
 #ifdef Allow_TYQUAD
 static longint f__llx;
-static int quad_read;
 #endif
 
 #ifdef KR_headers
@@ -24,6 +24,12 @@ int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)();
 int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void),
 	(*l_ungetc)(int,FILE*);
 #endif
+
+#include "fmt.h"
+#include "lio.h"
+#include "ctype.h"
+#include "fp.h"
+
 int l_eof;
 
 #define isblnk(x) (f__ltab[x+1]&B)
@@ -96,10 +102,11 @@ double f__lx,f__ly;
 #define GETC(x) (x=(*l_getc)())
 #define Ungetc(x,y) (*l_ungetc)(x,y)
 
+ static int
 #ifdef KR_headers
-l_R(poststar) int poststar;
+l_R(poststar, reqint) int poststar, reqint;
 #else
-l_R(int poststar)
+l_R(int poststar, int reqint)
 #endif
 {
 	char s[FMAX+EXPMAXDIGS+4];
@@ -148,6 +155,10 @@ l_R(int poststar)
 		goto retry;
 		}
 	if (ch == '.') {
+#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
+		if (reqint)
+			errfl(f__elist->cierr,115,"invalid integer");
+#endif
 		GETC(ch);
 		if (sp == sp1)
 			while(ch == '0') {
@@ -166,6 +177,10 @@ l_R(int poststar)
 	if (issign(ch))
 		goto signonly;
 	if (havenum && isexp(ch)) {
+#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
+		if (reqint)
+			errfl(f__elist->cierr,115,"invalid integer");
+#endif
 		GETC(ch);
 		if (issign(ch)) {
 signonly:
@@ -199,7 +214,7 @@ l_R(int poststar)
 			sp[1] = 0;
 		f__lx = atof(s);
 #ifdef Allow_TYQUAD
-		if (quad_read && (se = sp - sp1 + exp) > 14 && se < 20) {
+		if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) {
 			/* Assuming 64-bit longint and 32-bit long. */
 			if (exp < 0)
 				sp += exp;
@@ -254,6 +269,7 @@ rd_count(register int ch)
 	return f__lcount <= 0;
 	}
 
+ static int
 l_C(Void)
 {	int ch, nml_save;
 	double lz;
@@ -290,7 +306,7 @@ l_C(Void)
 	Ungetc(ch,f__cf);
 	nml_save = nml_read;
 	nml_read = 0;
-	if (ch = l_R(1))
+	if (ch = l_R(1,0))
 		return ch;
 	if (!f__ltype)
 		errfl(f__elist->cierr,112,"no real part");
@@ -302,7 +318,7 @@ l_C(Void)
 	}
 	while(iswhit(GETC(ch)));
 	(void) Ungetc(ch,f__cf);
-	if (ch = l_R(1))
+	if (ch = l_R(1,0))
 		return ch;
 	if (!f__ltype)
 		errfl(f__elist->cierr,112,"no imaginary part");
@@ -316,6 +332,8 @@ l_C(Void)
 	nml_read = nml_save;
 	return(0);
 }
+
+ static int
 l_L(Void)
 {
 	int ch;
@@ -361,7 +379,10 @@ l_L(Void)
 	(void) Ungetc(ch, f__cf);
 	return(0);
 }
+
 #define BUFSIZE	128
+
+ static int
 l_CHAR(Void)
 {	int ch,size,i;
 	static char rafail[] = "realloc failure";
@@ -385,6 +406,10 @@ l_CHAR(Void)
 				case '*':
 					if (f__lcount == 0) {
 						f__lcount = 1;
+#ifndef F8X_NML_ELIDE_QUOTES
+						if (nml_read)
+							goto no_quote;
+#endif
 						goto noquote;
 						}
 					p = f__lchar;
@@ -403,12 +428,19 @@ l_CHAR(Void)
 				}
 			if (!isdigit(ch)) {
 				f__lcount = 1;
+#ifndef F8X_NML_ELIDE_QUOTES
+				if (nml_read) {
+ no_quote:
+					errfl(f__elist->cierr,112,
+						"undelimited character string");
+					}
+#endif
 				goto noquote;
 				}
 			*p++ = ch;
 			f__lcount = 10*f__lcount + ch - '0';
 			if (++i == size) {
-				f__lchar = (char *)reallocf(f__lchar,
+				f__lchar = (char *)realloc(f__lchar,
 					(unsigned int)(size += BUFSIZE));
 				if(f__lchar == NULL)
 					errfl(f__elist->cierr,113,rafail);
@@ -419,10 +451,17 @@ l_CHAR(Void)
 	else	(void) Ungetc(ch,f__cf);
  have_lcount:
 	if(GETC(ch)=='\'' || ch=='"') quote=ch;
-	else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
+	else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) {
-	{	(void) Ungetc(ch,f__cf);
+		Ungetc(ch,f__cf);
-		return(0);
+		return 0;
 		}
+#ifndef F8X_NML_ELIDE_QUOTES
+	else if (nml_read > 1) {
+		Ungetc(ch,f__cf);
+		f__lquit = 2;
+		return 0;
+		}
+#endif
 	else {
 		/* Fortran 8x-style unquoted string */
 		*p++ = ch;
@@ -492,11 +531,11 @@ c_le(cilist *a)
 	if(!f__init)
 		f_init();
 	f__fmtbuf="list io";
+	f__curunit = &f__units[a->ciunit];
 	if(a->ciunit>=MXUNIT || a->ciunit<0)
 		err(a->cierr,101,"stler");
 	f__scale=f__recpos=0;
 	f__elist=a;
-	f__curunit = &f__units[a->ciunit];
 	if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
 		err(a->cierr,102,"lio");
 	f__cf=f__curunit->ufd;
@@ -547,15 +586,17 @@ l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
 		case TYINT1:
 		case TYSHORT:
 		case TYLONG:
+#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
+			ERR(l_R(0,1));
+			break;
+#endif
 		case TYREAL:
 		case TYDREAL:
-			ERR(l_R(0));
+			ERR(l_R(0,0));
 			break;
 #ifdef TYQUAD
 		case TYQUAD:
-			quad_read = 1;
+			n = l_R(0,2);
-			n = l_R(0);
-			quad_read = 0;
 			if (n)
 				return n;
 			break;
@@ -595,7 +636,7 @@ l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
 			break;
 		case TYLOGICAL:
 		case TYLONG:
-			Ptr->flint=f__lx;
+			Ptr->flint = (ftnint)f__lx;
 			break;
 #ifdef Allow_TYQUAD
 		case TYQUAD:
@@ -640,10 +681,10 @@ integer s_rsle(cilist *a)
 {
 	int n;
 
-	if(n=c_le(a)) return(n);
 	f__reading=1;
 	f__external=1;
 	f__formatted=1;
+	if(n=c_le(a)) return(n);
 	f__lioproc = l_read;
 	f__lquit = 0;
 	f__lcount = 0;

lib/libI77/lwrite.c

@@ -13,16 +13,6 @@ donewrec(Void)
 		(*f__donewrec)();
 	}
 
-#ifdef KR_headers
-t_putc(c)
-#else
-t_putc(int c)
-#endif
-{
-	f__recpos++;
-	putc(c,f__cf);
-	return(0);
-}
  static VOID
 #ifdef KR_headers
 lwrt_I(n) longint n;
@@ -184,10 +174,12 @@ l_put(register char *s)
 #endif
 {
 #ifdef KR_headers
-	register int c, (*pn)() = f__putn;
+	register void (*pn)() = f__putn;
 #else
-	register int c, (*pn)(int) = f__putn;
+	register void (*pn)(int) = f__putn;
 #endif
+	register int c;
+
 	while(c = *s++)
 		(*pn)(c);
 	}

lib/libI77/open.c

@@ -1,14 +1,19 @@
-#ifndef NON_UNIX_STDIO
-#include "sys/types.h"
-#include "sys/stat.h"
-#endif
 #include "f2c.h"
 #include "fio.h"
 #include "string.h"
-#include "rawio.h"
+#ifndef NON_POSIX_STDIO
+#ifdef MSDOS
+#include "io.h"
+#else
+#include "unistd.h"	/* for access */
+#endif
+#endif
 
 #ifdef KR_headers
-extern char *malloc(), *mktemp();
+extern char *malloc();
+#ifdef NON_ANSI_STDIO
+extern char *mktemp();
+#endif
 extern integer f_clos();
 #else
 #undef abs
@@ -27,44 +32,96 @@ char *f__r_mode[2] = {"rb", "r"};
 char *f__w_mode[4] = {"wb", "w", "r+b", "r+"};
 #endif
 
+ static char f__buf0[400], *f__buf = f__buf0;
+ int f__buflen = (int)sizeof(f__buf0);
+
+ static void
 #ifdef KR_headers
-f__isdev(s) char *s;
+f__bufadj(n, c) int n, c;
 #else
-f__isdev(char *s)
+f__bufadj(int n, int c)
 #endif
 {
-#ifdef NON_UNIX_STDIO
+	unsigned int len;
-	int i, j;
+	char *nbuf, *s, *t, *te;
 
-	i = open(s,O_RDONLY);
+	if (f__buf == f__buf0)
-	if (i == -1)
+		f__buflen = 1024;
-		return 0;
+	while(f__buflen <= n)
-	j = isatty(i);
+		f__buflen <<= 1;
-	close(i);
+	len = (unsigned int)f__buflen;
-	return j;
+	if (len != f__buflen || !(nbuf = (char*)malloc(len)))
-#else
+		f__fatal(113, "malloc failure");
-	struct stat x;
+	s = nbuf;
-
+	t = f__buf;
-	if(stat(s, &x) == -1) return(0);
+	te = t + c;
-#ifdef S_IFMT
+	while(t < te)
-	switch(x.st_mode&S_IFMT) {
+		*s++ = *t++;
-		case S_IFREG:
+	if (f__buf != f__buf0)
-		case S_IFDIR:
+		free(f__buf);
-			return(0);
+	f__buf = nbuf;
 	}
+
+ int
+#ifdef KR_headers
+f__putbuf(c) int c;
 #else
-#ifdef S_ISREG
+f__putbuf(int c)
-	/* POSIX version */
+#endif
-	if(S_ISREG(x.st_mode) || S_ISDIR(x.st_mode))
+{
-		return(0);
+	char *s, *se;
-	else
+	int n;
+
+	if (f__hiwater > f__recpos)
+		f__recpos = f__hiwater;
+	n = f__recpos + 1;
+	if (n >= f__buflen)
+		f__bufadj(n, f__recpos);
+	s = f__buf;
+	se = s + f__recpos;
+	if (c)
+		*se++ = c;
+	*se = 0;
+	for(;;) {
+		fputs(s, f__cf);
+		s += strlen(s);
+		if (s >= se)
+			break;	/* normally happens the first time */
+		putc(*s++, f__cf);
+		}
+	return 0;
+	}
+
+ void
+#ifdef KR_headers
+x_putc(c)
 #else
-	Help! How does stat work on this system?
+x_putc(int c)
 #endif
+{
+	if (f__recpos >= f__buflen)
+		f__bufadj(f__recpos, f__buflen);
+	f__buf[f__recpos++] = c;
+	}
+
+#define opnerr(f,m,s) {if(f) errno= m; else opn_err(m,s,a); return(m);}
+
+ static void
+#ifdef KR_headers
+opn_err(m, s, a) int m; char *s; olist *a;
+#else
+opn_err(int m, char *s, olist *a)
 #endif
-		return(1);
+{
-#endif
+	if (a->ofnm) {
-}
+		/* supply file name to error message */
+		if (a->ofnmlen >= f__buflen)
+			f__bufadj((int)a->ofnmlen, 0);
+		g_char(a->ofnm, a->ofnmlen, f__curunit->ufnm = f__buf);
+		}
+	f__fatal(m, s);
+	}
+
 #ifdef KR_headers
 integer f_open(a) olist *a;
 #else
@@ -75,11 +132,9 @@ integer f_open(olist *a)
 	char buf[256], *s;
 	cllist x;
 	int ufmt;
-#ifdef NON_UNIX_STDIO
 	FILE *tf;
-#else
+#ifndef NON_UNIX_STDIO
 	int n;
-	struct stat stb;
 #endif
 	if(a->ounit>=MXUNIT || a->ounit<0)
 		err(a->oerr,101,"open")
@@ -96,7 +151,7 @@ integer f_open(olist *a)
 #ifdef NON_UNIX_STDIO
 		if (b->ufnm
 		 && strlen(b->ufnm) == a->ofnmlen
-		 && !strncmp(b->ufnm, b->ufnm, (unsigned)a->ofnmlen))
+		 && !strncmp(b->ufnm, a->ofnm, (unsigned)a->ofnmlen))
 			goto same;
 #else
 		g_char(a->ofnm,a->ofnmlen,buf);
@@ -125,97 +180,93 @@ integer f_open(olist *a)
 	if (a->ofnm) {
 		g_char(a->ofnm,a->ofnmlen,buf);
 		if (!buf[0])
-			err(a->oerr,107,"open")
+			opnerr(a->oerr,107,"open")
 		}
 	else
 		sprintf(buf, "fort.%ld", a->ounit);
 	b->uscrtch = 0;
+	b->uend=0;
+	b->uwrt = 0;
+	b->ufd = 0;
+	b->urw = 3;
 	switch(a->osta ? *a->osta : 'u')
 	{
 	case 'o':
 	case 'O':
-#ifdef NON_UNIX_STDIO
+#ifdef NON_POSIX_STDIO
-		if(access(buf,0))
+		if (!(tf = fopen(buf,"r")))
+			opnerr(a->oerr,errno,"open")
+		fclose(tf);
 #else
-		if(stat(buf,&stb))
+		if (access(buf,0))
+			opnerr(a->oerr,errno,"open")
 #endif
-			err(a->oerr,errno,"open")
 		break;
 	 case 's':
 	 case 'S':
 		b->uscrtch=1;
-#ifdef _POSIX_SOURCE
+#ifdef NON_ANSI_STDIO
-		tmpnam(buf);
-#else
 		(void) strcpy(buf,"tmp.FXXXXXX");
 		(void) mktemp(buf);
-#endif
 		goto replace;
+#else
+		if (!(b->ufd = tmpfile()))
+			opnerr(a->oerr,errno,"open")
+		b->ufnm = 0;
+#ifndef NON_UNIX_STDIO
+		b->uinode = b->udev = -1;
+#endif
+		b->useek = 1;
+		return 0;
+#endif
+
 	case 'n':
 	case 'N':
-#ifdef NON_UNIX_STDIO
+#ifdef NON_POSIX_STDIO
-		if(!access(buf,0))
+		if ((tf = fopen(buf,"r")) || (tf = fopen(buf,"a"))) {
+			fclose(tf);
+			opnerr(a->oerr,128,"open")
+			}
 #else
-		if(!stat(buf,&stb))
+		if (!access(buf,0))
+			opnerr(a->oerr,128,"open")
 #endif
-			err(a->oerr,128,"open")
 		/* no break */
 	case 'r':	/* Fortran 90 replace option */
 	case 'R':
+#ifdef NON_ANSI_STDIO
  replace:
-#ifdef NON_UNIX_STDIO
+#endif
 		if (tf = fopen(buf,f__w_mode[0]))
 			fclose(tf);
-#else
-		(void) close(creat(buf, 0666));
-#endif
 	}
 
 	b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1));
-	if(b->ufnm==NULL) err(a->oerr,113,"no space");
+	if(b->ufnm==NULL) opnerr(a->oerr,113,"no space");
 	(void) strcpy(b->ufnm,buf);
-	b->uend=0;
+	if ((s = a->oacc) && b->url)
-	b->uwrt = 0;
-#ifdef NON_UNIX_STDIO
-	if ((s = a->oacc) && (*s == 'd' || *s == 'D'))
 		ufmt = 0;
-#endif
+	if(!(tf = fopen(buf, f__w_mode[ufmt|2]))) {
-	if(f__isdev(buf))
+		if (tf = fopen(buf, f__r_mode[ufmt]))
-	{	b->ufd = fopen(buf,f__r_mode[ufmt]);
+			b->urw = 1;
-		if(b->ufd==NULL) err(a->oerr,errno,buf)
+		else if (tf = fopen(buf, f__w_mode[ufmt])) {
-	}
-	else {
-		if(!(b->ufd = fopen(buf, f__r_mode[ufmt]))) {
-#ifdef NON_UNIX_STDIO
-			if (b->ufd = fopen(buf, f__w_mode[ufmt|2]))
-				b->uwrt = 2;
-			else if (b->ufd = fopen(buf, f__w_mode[ufmt]))
 			b->uwrt = 1;
+			b->urw = 2;
+			}
 		else
-#else
-			if ((n = open(buf,O_WRONLY)) >= 0)
-				b->uwrt = 2;
-			else {
-				n = creat(buf, 0666);
-				b->uwrt = 1;
-				}
-			if (n < 0
-			|| (b->ufd = fdopen(n, f__w_mode[ufmt])) == NULL)
-#endif
 			err(a->oerr, errno, "open");
 		}
-	}
+	b->useek = f__canseek(b->ufd = tf);
-	b->useek=f__canseek(b->ufd);
 #ifndef NON_UNIX_STDIO
-	if((b->uinode=f__inode(buf,&b->udev))==-1)
+	if((b->uinode = f__inode(buf,&b->udev)) == -1)
-		err(a->oerr,108,"open")
+		opnerr(a->oerr,108,"open")
 #endif
 	if(b->useek)
 		if (a->orl)
 			rewind(b->ufd);
 		else if ((s = a->oacc) && (*s == 'a' || *s == 'A')
 			&& fseek(b->ufd, 0L, SEEK_END))
-				err(a->oerr,129,"open");
+				opnerr(a->oerr,129,"open");
 	return(0);
 }
 #ifdef KR_headers

lib/libI77/rawio.h

@@ -1,6 +1,4 @@
-#ifdef KR_headers
+#ifndef KR_headers
-extern FILE *fdopen();
-#else
 #ifdef MSDOS
 #include "io.h"
 #ifndef WATCOM

lib/libI77/rdfmt.c

@@ -1,8 +1,5 @@
 #include "f2c.h"
 #include "fio.h"
-#include "fmt.h"
-#include "fp.h"
-#include "ctype.h"
 
 extern int f__cursor;
 #ifdef KR_headers
@@ -14,6 +11,10 @@ extern double atof();
 #include "stdlib.h"
 #endif
 
+#include "fmt.h"
+#include "fp.h"
+#include "ctype.h"
+
  static int
 #ifdef KR_headers
 rd_Z(n,w,len) Uint *n; ftnlen len;
@@ -432,7 +433,7 @@ rd_ed(struct syl *p, char *ptr, ftnlen len)
 	case D:
 	case G:
 	case GE:
-	case F:	ch = rd_F((ufloat *)ptr,p->p1,p->p2,len);
+	case F:	ch = rd_F((ufloat *)ptr,p->p1,p->p2.i[0],len);
 		break;
 
 		/* Z and ZM assume 8-bit bytes. */
@@ -459,8 +460,8 @@ rd_ned(struct syl *p)
 	default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op);
 		sig_die(f__fmtbuf, 1);
 	case APOS:
-		return(rd_POS(*(char **)&p->p2));
+		return(rd_POS(p->p2.s));
-	case H:	return(rd_H(p->p1,*(char **)&p->p2));
+	case H:	return(rd_H(p->p1,p->p2.s));
 	case SLASH: return((*f__donewrec)());
 	case TR:
 	case X:	f__cursor += p->p1;

lib/libI77/rsfe.c

@@ -50,16 +50,15 @@ integer s_rsfe(cilist *a) /* start */
 #endif
 {	int n;
 	if(!f__init) f_init();
-	if(n=c_sfe(a)) return(n);
 	f__reading=1;
 	f__sequential=1;
 	f__formatted=1;
 	f__external=1;
+	if(n=c_sfe(a)) return(n);
 	f__elist=a;
 	f__cursor=f__recpos=0;
 	f__scale=0;
 	f__fmtbuf=a->cifmt;
-	f__curunit= &f__units[a->ciunit];
 	f__cf=f__curunit->ufd;
 	if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio");
 	f__getn= x_getc;

lib/libI77/sfe.c

@@ -7,10 +7,6 @@ extern char *f__fmtbuf;
 integer e_rsfe(Void)
 {	int n;
 	n=en_fio();
-	if (f__cf == stdout)
-		fflush(stdout);
-	else if (f__cf == stderr)
-		fflush(stderr);
 	f__fmtbuf=NULL;
 	return(n);
 }
@@ -20,23 +16,16 @@ c_sfe(a) cilist *a; /* check */
 c_sfe(cilist *a) /* check */
 #endif
 {	unit *p;
+	f__curunit = p = &f__units[a->ciunit];
 	if(a->ciunit >= MXUNIT || a->ciunit<0)
 		err(a->cierr,101,"startio");
-	p = &f__units[a->ciunit];
 	if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe")
 	if(!p->ufmt) err(a->cierr,102,"sfe")
 	return(0);
 }
 integer e_wsfe(Void)
 {
-#ifdef ALWAYS_FLUSH
+	int n = en_fio();
-	int n;
+	f__fmtbuf = NULL;
-	n = en_fio();
-	f__fmtbuf=NULL;
-	if (!n && fflush(f__cf))
-		err(f__elist->cierr, errno, "write end");
 	return n;
-#else
-	return(e_rsfe());
-#endif
 }

lib/libI77/sue.c

@@ -9,11 +9,11 @@ c_sue(a) cilist *a;
 c_sue(cilist *a)
 #endif
 {
-	if(a->ciunit >= MXUNIT || a->ciunit < 0)
-		err(a->cierr,101,"startio");
 	f__external=f__sequential=1;
 	f__formatted=0;
 	f__curunit = &f__units[a->ciunit];
+	if(a->ciunit >= MXUNIT || a->ciunit < 0)
+		err(a->cierr,101,"startio");
 	f__elist=a;
 	if(f__curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit))
 		err(a->cierr,114,"sue");

lib/libI77/util.c

@@ -1,4 +1,6 @@
 #ifndef NON_UNIX_STDIO
+#define _INCLUDE_POSIX_SOURCE	/* for HP-UX */
+#define _INCLUDE_XOPEN_SOURCE	/* for HP-UX */
 #include "sys/types.h"
 #include "sys/stat.h"
 #endif

lib/libI77/wref.c

@@ -1,10 +1,5 @@
 #include "f2c.h"
 #include "fio.h"
-#include "fmt.h"
-#include "fp.h"
-#ifndef VAX
-#include "ctype.h"
-#endif
 
 #ifndef KR_headers
 #undef abs
@@ -14,6 +9,12 @@
 #include "string.h"
 #endif
 
+#include "fmt.h"
+#include "fp.h"
+#ifndef VAX
+#include "ctype.h"
+#endif
+
 #ifdef KR_headers
 wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
 #else
@@ -118,7 +119,7 @@ wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
 	if (s[2]) {
 #ifdef Pedantic
 		if (!e0 && !s[3])
-		    e1 = 2;/* for(s -= 2, e1 = 2; s[0] = s[1]; s++);
+			for(s -= 2, e1 = 2; s[0] = s[1]; s++);
 
 	/* Pedantic gives the behavior that Fortran 77 specifies,	*/
 	/* i.e., requires that E be specified for exponent fields	*/

lib/libI77/wrtfmt.c

@@ -40,43 +40,23 @@ mv_cur(Void)	/* shouldn't use fseek because it insists on calling fflush */
 		}
 		return(0);
 	}
-	if(cursor > 0) {
+	if (cursor > 0) {
 		if(f__hiwater <= f__recpos)
 			for(;cursor>0;cursor--) (*f__putn)(' ');
 		else if(f__hiwater <= f__recpos + cursor) {
-#ifndef NON_UNIX_STDIO
-			if(f__cf->_ptr + f__hiwater - f__recpos < buf_end(f__cf))
-				f__cf->_ptr += f__hiwater - f__recpos;
-			else
-#endif
-				(void) fseek(f__cf, (long) (f__hiwater - f__recpos), SEEK_CUR);
 			cursor -= f__hiwater - f__recpos;
 			f__recpos = f__hiwater;
 			for(; cursor > 0; cursor--)
 				(*f__putn)(' ');
 		}
 		else {
-#ifndef NON_UNIX_STDIO
-			if(f__cf->_ptr + cursor < buf_end(f__cf))
-				f__cf->_ptr += cursor;
-			else
-#endif
-				(void) fseek(f__cf, (long)cursor, SEEK_CUR);
 			f__recpos += cursor;
 		}
 	}
-	if(cursor<0)
+	else if (cursor < 0)
 	{
-		if(cursor+f__recpos<0) err(f__elist->cierr,110,"left off");
+		if(cursor + f__recpos < 0)
-#ifndef NON_UNIX_STDIO
+			err(f__elist->cierr,110,"left off");
-		if(f__cf->_ptr + cursor >= f__cf->_base)
-			f__cf->_ptr += cursor;
-		else
-#endif
-		if(f__curunit && f__curunit->useek)
-			(void) fseek(f__cf,(long)cursor,SEEK_CUR);
-		else
-			err(f__elist->cierr,106,"fmt");
 		if(f__hiwater < f__recpos)
 			f__hiwater = f__recpos;
 		f__recpos += cursor;
@@ -292,9 +272,7 @@ wrt_G(ufloat *p, int w, int d, int e, ftnlen len)
 	if(x<.1) {
 		if (x != 0.)
 			return(wrt_E(p,w,d,e,len));
-#ifdef WANT_LEAD_0
 		i = 1;
-#endif
 		goto have_i;
 		}
 	for(;i<=d;i++,up*=10)
@@ -328,7 +306,7 @@ w_ed(struct syl *p, char *ptr, ftnlen len)
 		sig_die(f__fmtbuf, 1);
 	case I:	return(wrt_I((Uint *)ptr,p->p1,len, 10));
 	case IM:
-		return(wrt_IM((Uint *)ptr,p->p1,p->p2,len,10));
+		return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,10));
 
 		/* O and OM don't work right for character, double, complex, */
 		/* or doublecomplex, and they differ from Fortran 90 in */
@@ -336,7 +314,7 @@ w_ed(struct syl *p, char *ptr, ftnlen len)
 
 	case O:	return(wrt_I((Uint *)ptr, p->p1, len, 8));
 	case OM:
-		return(wrt_IM((Uint *)ptr,p->p1,p->p2,len,8));
+		return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,8));
 	case L:	return(wrt_L((Uint *)ptr,p->p1, len));
 	case A: return(wrt_A(ptr,len));
 	case AW:
@@ -344,17 +322,17 @@ w_ed(struct syl *p, char *ptr, ftnlen len)
 	case D:
 	case E:
 	case EE:
-		return(wrt_E((ufloat *)ptr,p->p1,p->p2,p->p3,len));
+		return(wrt_E((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len));
 	case G:
 	case GE:
-		return(wrt_G((ufloat *)ptr,p->p1,p->p2,p->p3,len));
+		return(wrt_G((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len));
-	case F:	return(wrt_F((ufloat *)ptr,p->p1,p->p2,len));
+	case F:	return(wrt_F((ufloat *)ptr,p->p1,p->p2.i[0],len));
 
 		/* Z and ZM assume 8-bit bytes. */
 
 	case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len));
 	case ZM:
-		return(wrt_Z((Uint *)ptr,p->p1,p->p2,len));
+		return(wrt_Z((Uint *)ptr,p->p1,p->p2.i[0],len));
 	}
 }
 #ifdef KR_headers
@@ -380,8 +358,8 @@ w_ned(struct syl *p)
 		f__cursor += p->p1;
 		return(1);
 	case APOS:
-		return(wrt_AP(*(char **)&p->p2));
+		return(wrt_AP(p->p2.s));
 	case H:
-		return(wrt_H(p->p1,*(char **)&p->p2));
+		return(wrt_H(p->p1,p->p2.s));
 	}
 }

lib/libI77/wsfe.c

@@ -4,49 +4,39 @@
 #include "fmt.h"
 extern int f__hiwater;
 
-#ifdef KR_headers
+ int
-x_putc(c)
-#else
-x_putc(int c)
-#endif
-{
-	/* this uses \n as an indicator of record-end */
-	if(c == '\n' && f__recpos < f__hiwater) {	/* fseek calls fflush, a loss */
-#ifndef NON_UNIX_STDIO
-		if(f__cf->_ptr + f__hiwater - f__recpos < buf_end(f__cf))
-			f__cf->_ptr += f__hiwater - f__recpos;
-		else
-#endif
-			(void) fseek(f__cf, (long)(f__hiwater - f__recpos), SEEK_CUR);
-	}
-#ifdef OMIT_BLANK_CC
-	if (!f__recpos++ && c == ' ')
-		return c;
-#else
-	f__recpos++;
-#endif
-	return putc(c,f__cf);
-}
 x_wSL(Void)
 {
-	(*f__putn)('\n');
+	int n = f__putbuf('\n');
-	f__recpos=0;
+	f__hiwater = f__recpos = f__cursor = 0;
-	f__cursor = 0;
+	return(n == 0);
-	f__hiwater = 0;
-	return(1);
 }
+
+ static int
 xw_end(Void)
 {
-	if(f__nonl == 0)
+	int n;
-		(*f__putn)('\n');
+
+	if(f__nonl) {
+		f__putbuf(n = 0);
+		fflush(f__cf);
+		}
+	else
+		n = f__putbuf('\n');
 	f__hiwater = f__recpos = f__cursor = 0;
-	return(0);
+	return n;
 }
+
+ static int
 xw_rev(Void)
 {
-	if(f__workdone) (*f__putn)('\n');
+	int n = 0;
+	if(f__workdone) {
+		n = f__putbuf('\n');
+		f__workdone = 0;
+		}
 	f__hiwater = f__recpos = f__cursor = 0;
-	return(f__workdone=0);
+	return n;
 }
 
 #ifdef KR_headers
@@ -56,17 +46,16 @@ integer s_wsfe(cilist *a)	/*start*/
 #endif
 {	int n;
 	if(!f__init) f_init();
-	if(n=c_sfe(a)) return(n);
 	f__reading=0;
 	f__sequential=1;
 	f__formatted=1;
 	f__external=1;
+	if(n=c_sfe(a)) return(n);
 	f__elist=a;
 	f__hiwater = f__cursor=f__recpos=0;
 	f__nonl = 0;
 	f__scale=0;
 	f__fmtbuf=a->cifmt;
-	f__curunit = &f__units[a->ciunit];
 	f__cf=f__curunit->ufd;
 	if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio");
 	f__putn= x_putc;

lib/libI77/wsle.c

@@ -2,6 +2,7 @@
 #include "fio.h"
 #include "fmt.h"
 #include "lio.h"
+#include "string.h"
 
 #ifdef KR_headers
 integer s_wsle(a) cilist *a;
@@ -14,7 +15,7 @@ integer s_wsle(cilist *a)
 	f__reading=0;
 	f__external=1;
 	f__formatted=1;
-	f__putn = t_putc;
+	f__putn = x_putc;
 	f__lioproc = l_write;
 	L_len = LINE;
 	f__donewrec = x_wSL;
@@ -25,16 +26,11 @@ integer s_wsle(cilist *a)
 
 integer e_wsle(Void)
 {
-	t_putc('\n');
+	int n = f__putbuf('\n');
 	f__recpos=0;
 #ifdef ALWAYS_FLUSH
-	if (fflush(f__cf))
+	if (!n && fflush(f__cf))
 		err(f__elist->cierr, errno, "write end");
-#else
-	if (f__cf == stdout)
-		fflush(stdout);
-	else if (f__cf == stderr)
-		fflush(stderr);
 #endif
-	return(0);
+	return(n);
 	}

lib/libI77/wsne.c

@@ -16,7 +16,7 @@ s_wsne(cilist *a)
 	f__reading=0;
 	f__external=1;
 	f__formatted=1;
-	f__putn = t_putc;
+	f__putn = x_putc;
 	L_len = LINE;
 	f__donewrec = x_wSL;
 	if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))

usr.bin/f2c/Notice

@@ -1,23 +1,23 @@
 /****************************************************************
-Copyright 1990 - 1997 by AT&T Bell Laboratories and Bellcore.
+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 or
+documentation, and that the names of AT&T, Bell Laboratories,
-Bellcore or any of their entities not be used in advertising or
+Lucent or Bellcore or any of their entities not be used in
-publicity pertaining to distribution of the software without
+advertising or publicity pertaining to distribution of the
-specific, written prior permission.
+software without specific, written prior permission.
 
-AT&T and Bellcore disclaim all warranties with regard to this
+AT&T, Lucent and Bellcore disclaim all warranties with regard to
-software, including all implied warranties of merchantability
+this software, including all implied warranties of
-and fitness.  In no event shall AT&T or Bellcore be liable for
+merchantability and fitness.  In no event shall AT&T, Lucent or
-any special, indirect or consequential damages or any damages
+Bellcore be liable for any special, indirect or consequential
-whatsoever resulting from loss of use, data or profits, whether
+damages or any damages whatsoever resulting from loss of use,
-in an action of contract, negligence or other tortious action,
+data or profits, whether in an action of contract, negligence or
-arising out of or in connection with the use or performance of
+other tortious action, arising out of or in connection with the
-this software.
+use or performance of this software.
 ****************************************************************/
 

usr.bin/f2c/README

@@ -32,16 +32,17 @@ details, ask netlib@netlib.bell-labs.com 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 yours is such a
+render this less of a problem than hitherto).  If your system permits
-system, you may either modify the makefile appropriately (remove
+use of a user-supplied malloc, you may wish to change the MALLOC =
-"malloc.o" from the "OBJECTS =" assignment), or simply execute
+line in the makefile to "MALLOC = malloc.o", or to type
-	cc -c -DCRAY malloc.c
+	make MALLOC=malloc.o
-before typing "make".  Still other systems have a -lmalloc that
+instead of
-provides performance competitive with that from malloc.c; you may
+	make
-wish to compare the two on your system.  In general, if f2c faults
+Still other systems have a -lmalloc that provides performance
-when you first try to run it, try compiling malloc.c with -DCRAY;
+competitive with that from malloc.c; you may wish to compare the two
-this is necessary with at least one version of Linux (but not with
+on your system.  If your system does not permit user-supplied malloc
-others).
+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
@@ -157,6 +158,11 @@ 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@bell-labs.com .  The old index file
 (now called "readme" due to unfortunate changes in netlib conventions:

usr.bin/f2c/format.c

@@ -328,7 +328,7 @@ do_p1_comment(infile, outfile)
 do_p1_comment(FILE *infile, FILE *outfile)
 #endif
 {
-    extern int c_output_line_length, in_comment;
+    extern int in_comment;
 
     char storage[COMMENT_BUFFER_SIZE + 1];
     int length;
@@ -340,9 +340,6 @@ do_p1_comment(FILE *infile, FILE *outfile)
 
     gflag1 = sharp_line = 0;
     in_comment = 1;
-    if (length > c_output_line_length - 6)
-	margin_printf(outfile, "/*%s*/\n", storage);
-    else
     margin_printf(outfile, length ? "/* %s */\n" : "\n", storage);
     in_comment = 0;
     gflag1 = sharp_line = gflag;
@@ -2428,6 +2425,8 @@ proto(FILE *outfile,  Argtypes *at,  char *fname)
 			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]);
 			}

usr.bin/f2c/formatdata.c

@@ -927,6 +927,63 @@ Len(long L, int type)
 	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)
@@ -939,12 +996,13 @@ wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm)
 #endif
 {
 	struct Equivblock *eqv;
-	int btype, curtype, dtype, filltype, filltype1, j, k, wasblank, xtype;
+	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, L1, dL, dloc, loc, loc0;
+	ftnint L, L0, L1, L2, dL, dloc, loc, loc0;
 	union Constant Const;
 	char imag_buf[50], real_buf[50];
 	int szshort = typesize[TYSHORT];
@@ -978,8 +1036,10 @@ wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm)
 
 	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
@@ -1007,6 +1067,10 @@ wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm)
 			if (basetype[(int)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)
@@ -1015,9 +1079,9 @@ wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm)
 			 && btype <= type_choice[loc/szshort % 4])
 				break;
 			dtype = (int)cp->nextp->datap;
-			loc = dloc + dtype == TYBLANK
+			loc = dloc + (dtype == TYBLANK
 					? (ftnint)cp->nextp->nextp->datap
-					: typesize[dtype];
+					: typesize[dtype]);
 			}
 		}
 	sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL));
@@ -1069,19 +1133,19 @@ wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm)
 			loc0 = dloc;
 			}
 		if (L > 0) {
-			if (xtype == TYCHAR)
+			filltype = fill_type(L, loc, xtype);
-				filltype = TYCHAR;
-			else {
-				filltype = L % szshort ? TYCHAR
-						: type_choice[L/szshort % 4];
-				filltype1 = loc % szshort ? TYCHAR
-						: type_choice[loc/szshort % 4];
-				if (typesize[filltype] > typesize[filltype1])
-					filltype = filltype1;
-				}
 			L1 = L / typesize[filltype];
-			nice_printf(outfile, "%s fill_%d[%ld];\n",
+			if (!xfilled && (L2 = get_fill(dloc, loc, &t0, &t1,
-				typename[filltype], ++k, L1);
+							&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) {
@@ -1097,6 +1161,7 @@ wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm)
 		? extsymtab[memno].cextname
 		: equiv_name(eqvmemno, CNULL));
 	loc = 0;
+	xfilled &= 2;
 	for(v = values; ; v = v->nextp) {
 		cp = (chainp)v->datap;
 		if (!cp)
@@ -1106,8 +1171,19 @@ wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm)
 			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)

usr.bin/f2c/gram.dcl

@@ -243,7 +243,7 @@ datavar:	  lhs
 		  np = pp -> namep;
 		  vardcl(np);
 		  if ((pp->fcharp || pp->lcharp)
-		   && (np->vtype != TYCHAR || np->vdim))
+		   && (np->vtype != TYCHAR || np->vdim && !pp->argsp))
 			sserr(np);
 		  if(np->vstg == STGCOMMON)
 			extsymtab[np->vardesc.varno].extinit = YES;

usr.bin/f2c/intr.c

@@ -1,5 +1,5 @@
 /****************************************************************
-Copyright 1990, 1992, 1994-6 by AT&T, Lucent Technologies and Bellcore.
+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
@@ -52,6 +52,7 @@ LOCAL struct Intrblock
 "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 },

usr.bin/f2c/lex.c

@@ -1642,12 +1642,15 @@ store_comment(char *str)
 		}
 	len = strlen(str) + 1;
 	if (cbnext + len > cblast) {
-		if (!cbcur || !(ncb = cbcur->next)) {
+		ncb = 0;
-			ncb = (comment_buf *) Alloc(sizeof(comment_buf));
 		if (cbcur) {
 			cbcur->last = cbnext;
-				cbcur->next = ncb;
+			ncb = cbcur->next;
 			}
+		if (!ncb) {
+			ncb = (comment_buf *) Alloc(sizeof(comment_buf));
+			if (cbcur)
+				cbcur->next = ncb;
 			else {
 				cbfirst = ncb;
 				cbinit = ncb->buf;

usr.bin/f2c/malloc.c

@@ -162,4 +162,21 @@ realloc(Char *f, Unsigned size)
 		memcpy(q, f, s1);
 	return q;
 	}
+
+/* The following (calloc) should really be in a separate file, */
+/* but defining it here sometimes avoids confusion on systems */
+/* that do not provide calloc in its own file. */
+
+ Char *
+#ifdef KR_headers
+calloc(n, m) Unsigned m, n;
+#else
+calloc(Unsigned n, Unsigned m)
+#endif
+{
+	Char *rv = malloc(n *= m);
+	if (n && rv)
+		memset(rv, 0, n);
+	return rv;
+	}
 #endif

usr.bin/f2c/niceprintf.c

@@ -229,7 +229,7 @@ fwd_strcpy(register char *t, register char *s)
     extern FILEP c_file;
     extern char tr_tab[];	/* in output.c */
     register char *Tr = tr_tab;
-    int ch, inc, ind;
+    int ch, cmax, inc, ind;
     static int extra_indent, last_indent, set_cursor = 1;
 
     cursor_pos += indent - last_indent;
@@ -250,13 +250,17 @@ fwd_strcpy(register char *t, register char *s)
 		ind = indent <= MAX_INDENT
 			? indent
 			: MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT);
-		cursor_pos = ind + extra_indent;
+		cursor_pos = extra_indent;
+		if (use_indent)
+			cursor_pos += ind;
 		set_cursor = 0;
 		}
-	if (in_comment)
+	if (in_comment) {
+		cmax = max_line_len + 32;	/* let comments be wider */
         	for (pointer = next_slot; *pointer && *pointer != '\n' &&
-				cursor_pos <= max_line_len; pointer++)
+				cursor_pos <= cmax; pointer++)
 			cursor_pos++;
+		}
 	else
           for (pointer = next_slot; *pointer && *pointer != '\n' &&
 		cursor_pos <= max_line_len; pointer++) {

usr.bin/f2c/output.c

@@ -443,8 +443,6 @@ out_name(FILE *fp, Namep namep)
 } /* out_name */
 
 
-static char *Longfmt = "%ld";
-
 #define cpd(n) cp->vstg ? cp->Const.cds[n] : dtos(cp->Const.cd[n])
 
  void
@@ -469,7 +467,7 @@ out_const(FILE *fp, register Constp cp)
 #ifdef TYQUAD
 	case TYQUAD:
 #endif
-	    nice_printf (fp, Longfmt, cp->Const.ci);	/* don't cast ci! */
+	    nice_printf (fp, "%ld", cp->Const.ci);	/* don't cast ci! */
 	    break;
 	case TYREAL:
 	    nice_printf(fp, "%s", flconst(real_buf, cpd(0)));
@@ -1315,10 +1313,11 @@ out_call(FILE *outfile, int op, int ftype, expptr len, expptr name, expptr args)
 /* Might be a Constant expression, e.g. string length, character constants */
 
 	else if (q -> tag == TCONST) {
-	    if (tyioint == TYLONG)
+		if (q->constblock.vtype == TYLONG)
-	   	Longfmt = "%ldL";
+			nice_printf(outfile, "(ftnlen)%ld",
+				q->constblock.Const.ci);
+		else
 			out_const(outfile, &q->constblock);
-	    Longfmt = "%ld";
 	    }
 
 /* Must be some other kind of expression, or register var, or constant.
@@ -1329,7 +1328,10 @@ out_call(FILE *outfile, int op, int ftype, expptr len, expptr name, expptr args)
 	    int use_paren = q -> tag == TEXPR &&
 		    op_precedence (q -> exprblock.opcode) <=
 		    op_precedence (OPCOMMA);
-
+	    if (q->headblock.vtype == TYREAL && forcereal) {
+		nice_printf(outfile, "(real)");
+		use_paren = 1;
+		}
 	    if (use_paren) nice_printf (outfile, "(");
 	    expr_out (outfile, q);
 	    if (use_paren) nice_printf (outfile, ")");

usr.bin/f2c/putpcc.c

@@ -559,6 +559,10 @@ putpower(expptr p)
 /* 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),

usr.bin/f2c/version.c

@@ -1,2 +1,2 @@
-char F2C_version[] = "19970219";
+char F2C_version[] = "19980913";
-char xxxvers[] = "\n@(#) FORTRAN 77 to C Translator, VERSION 19970219\n";
+char xxxvers[] = "\n@(#) FORTRAN 77 to C Translator, VERSION 19980913\n";