patch: list-directed float output in libg2c.a

[Alex Achenbach]

This is a patch for libg2c.a that enables type-dependent output
precision in list-directed output of REAL and COMPLEX data.
In short, with this patch applied, WRITE(n, *) now writes
    REAL*4 types with FLT_DIG digits,
    REAL*8 types with DBL_DIG digits,
    COMPLEX*8 types with FLT_DIG digits each component,
    COMPLEX*16 types with DBL_DIG digits each component.
The original behaviour was to always write 9 digits, which
usually is too much for single precision and too few for
double precision.

I only tested this with Old_list_output undefined, though
I implemented changes for both cases.
The patch was applied to egcs-1.1.1 release.

Alex Achenbach

------------------------------------------------------------------
diff -ur egcs-1.1.1/libf2c/libI77/lio.h egcs-1.1.1-xela/libf2c/libI77/lio.h
--- egcs-1.1.1/libf2c/libI77/lio.h	Sun Feb  1 02:37:07 1998
+++ egcs-1.1.1-xela/libf2c/libI77/lio.h	Fri Mar  5 00:23:09 1999
@@ -33,13 +33,17 @@
 #ifdef Old_list_output
 #define	LLOW	1.0
 #define	LHIGH	1.e9
-#define	LEFMT	" %# .8E"
-#define	LFFMT	" %# .9g"
+/* xela: %.*E instead of %.8G */
+#define	LEFMT	" %# .*E"
+/* xela: %.*G instead of %.9G */
+#define	LFFMT	" %# .*g"
 #else
-#define	LGFMT	"%.9G"
+/* xela: %.*G instead of %.9G */
+#define	LGFMT	"%.*G"
 #endif
 /* LEFBL 20 should suffice; 24 overcomes a NeXT bug. */
-#define	LEFBL	24
+/* xela: now with precision argument, will be added */
+#define	LEFBL(p)  (15+(p))
 
 typedef union
 {
diff -ur egcs-1.1.1/libf2c/libI77/lwrite.c egcs-1.1.1-xela/libf2c/libI77/lwrite.c
--- egcs-1.1.1/libf2c/libI77/lwrite.c	Tue May 19 12:51:11 1998
+++ egcs-1.1.1-xela/libf2c/libI77/lwrite.c	Fri Mar  5 01:17:25 1999
@@ -2,6 +2,8 @@
 #include "fio.h"
 #include "fmt.h"
 #include "lio.h"
+/* xela: need float/double precisions; FIXME: float.h ?? */
+#include <float.h>
 
 ftnint L_len;
 int f__Aquote;
@@ -88,11 +90,13 @@
 			PUT(*p++);
 }
 
+/* xela: new parameter prec is decimal precision of G output;
+         buf must now be LEFBL(prec) chars big! */
  static int
 #ifdef KR_headers
-l_g(buf, n) char *buf; double n;
+l_g(buf, n, prec) char *buf; double n; int prec;
 #else
-l_g(char *buf, double n)
+l_g(char *buf, double n, int prec)
 #endif
 {
 #ifdef Old_list_output
@@ -102,12 +106,16 @@
 	absn = n;
 	if (absn < 0)
 		absn = -absn;
-	fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
+	if (LLOW <= absn && absn < LHIGH) {
+	    fmt = LFFMT;
+	} else {
+	    fmt = LEFMT; --prec;    /* xela: 1 less for E output */
+	}
 #ifdef USE_STRLEN
-	sprintf(buf, fmt, n);
+	sprintf(buf, fmt, prec, n);
 	return strlen(buf);
 #else
-	return sprintf(buf, fmt, n);
+	return sprintf(buf, fmt, prec, n);
 #endif
 
 #else
@@ -127,7 +135,7 @@
 		*b = 0;
 		goto f__ret;
 		}
-	sprintf(b, LGFMT, n);
+	sprintf(b, LGFMT, prec, n);
 	switch(*b) {
 #ifndef WANT_LEAD_0
 		case '0':
@@ -191,26 +199,42 @@
 lwrt_F(double n)
 #endif
 {
-	char buf[LEFBL];
+	char buf[LEFBL(FLT_DIG)];
 
-	if(f__recpos + l_g(buf,n) >= L_len)
+	if(f__recpos + l_g(buf,n,FLT_DIG) >= L_len)
 		donewrec();
 	l_put(buf);
 }
+/* xela: double version */
  static VOID
 #ifdef KR_headers
-lwrt_C(a,b) double a,b;
+lwrt_DF(n) double n;
 #else
-lwrt_C(double a, double b)
+lwrt_DF(double n)
+#endif
+{
+	char buf[LEFBL(DBL_DIG)];
+
+	if(f__recpos + l_g(buf,n,DBL_DIG) >= L_len)
+		donewrec();
+	l_put(buf);
+}
+
+/* xela: common part of lwrt_C() and lwrt_DC() */
+static VOID
+#ifdef KR_headers
+l_cplx(bufa, bufb, a, b, prec) char *bufa,*bufb; double a, b; int prec;
+#else
+l_cplx(char *bufa, char *bufb, double a, double b, int prec)
 #endif
 {
-	char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
+	char *ba, *bb;
 	int al, bl;
 
-	al = l_g(bufa, a);
+	al = l_g(bufa, a, prec);
 	for(ba = bufa; *ba == ' '; ba++)
 		--al;
-	bl = l_g(bufb, b) + 1;	/* intentionally high by 1 */
+	bl = l_g(bufb, b, prec) + 1;	/* intentionally high by 1 */
 	for(bb = bufb; *bb == ' '; bb++)
 		--bl;
 	if(f__recpos + al + bl + 3 >= L_len)
@@ -231,6 +255,29 @@
 	l_put(bb);
 	PUT(')');
 }
+
+ static VOID
+#ifdef KR_headers
+lwrt_C(a,b) double a,b;
+#else
+lwrt_C(double a, double b)
+#endif
+{
+	char bufa[LEFBL(FLT_DIG)], bufb[LEFBL(FLT_DIG)];
+	l_cplx(bufa, bufb, a, b, FLT_DIG);
+}
+/* xela: double version */
+ static VOID
+#ifdef KR_headers
+lwrt_DC(a,b) double a,b;
+#else
+lwrt_DC(double a, double b)
+#endif
+{
+	char bufa[LEFBL(DBL_DIG)], bufb[LEFBL(DBL_DIG)];
+	l_cplx(bufa, bufb, a, b, DBL_DIG);
+}
+
 #ifdef KR_headers
 l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
 #else
@@ -265,22 +312,23 @@
 			break;
 		case TYREAL:
 			y=Ptr->flreal;
-			goto xfloat;
+		    	lwrt_F(y);
+			break;
 		case TYDREAL:
 			y=Ptr->fldouble;
-		xfloat: lwrt_F(y);
+		    	lwrt_DF(y);
 			break;
 		case TYCOMPLEX:
 			xx= &Ptr->flreal;
 			y = *xx++;
 			z = *xx;
-			goto xcomplex;
+			lwrt_C(y,z);
+			break;
 		case TYDCOMPLEX:
 			yy = &Ptr->fldouble;
 			y= *yy++;
 			z = *yy;
-		xcomplex:
-			lwrt_C(y,z);
+			lwrt_DC(y,z);
 			break;
 		case TYLOGICAL1:
 			x = Ptr->flchar;
------------------------------------------------------------------