This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Fortran, committed] Update run-time library to libf2c-20001205.
- To: gcc-patches at gcc dot gnu dot org
- Subject: [Fortran, committed] Update run-time library to libf2c-20001205.
- From: Toon Moene <toon at moene dot indiv dot nluug dot nl>
- Date: Sat, 09 Dec 2000 16:35:49 +0100
- Organization: Moene Computational Physics, Maartensdijk, The Netherlands
L.S.,
I applied the following patch - with thanks to David M. Gay, maintainer
of f2c - that, among other things, solves
g77.f-torture/execute/20001201.f:
Update to Netlib version 20001205.
Thanks go to David M. Gay for these updates.
* libF77/Version.c: Update version information.
* libF77/z_log.c: Improve accuracy of real(log(z)) for
z near (+-1,eps) with |eps| small.
* libF77/s_cat.c: Adjust call when ftnint and ftnlen are
of different size.
* libF77/dtime_.c, libF77/etime_.c: Use floating point divide.
* libI77/Version.c: Update version information.
* libI77/rsne.c, libI77/xwsne.c: Adjust code for when ftnint
and ftnlen differ in size.
* libI77/lread.c: Fix reading of namelist logical values
followed
by <name>= where <name> starts with T or F.
Bootstrapped on i686-pc-gnu-linux and bootstrapped and make -k check'd
on alphaev6-unknown-gnu-linux.
--
Toon Moene - mailto:toon@moene.indiv.nluug.nl - phoneto: +31 346 214290
Saturnushof 14, 3738 XG Maartensdijk, The Netherlands
Maintainer, GNU Fortran 77: http://gcc.gnu.org/onlinedocs/g77_news.html
Join GNU Fortran 95: http://g95.sourceforge.net/ (under construction)
*** libF77/Version.c.orig Sat Dec 9 12:08:23 2000
--- libF77/Version.c Sat Dec 9 13:13:33 2000
***************
*** 1,3 ****
! static char junk[] = "\n@(#)LIBF77 VERSION 19991115\n";
/*
--- 1,3 ----
! static char junk[] = "\n@(#)LIBF77 VERSION 20000929\n";
/*
*************** char __G77_LIBF77_VERSION__[] = "0.5.26
*** 70,73 ****
--- 70,84 ----
15 Nov. 1999: s_rnge.c: add casts for the case of
sizeof(ftnint) == sizeof(int) < sizeof(long).
+ 10 March 2000: z_log.c: improve accuracy of Real(log(z)) for, e.g.,
+ z near (+-1,eps) with |eps| small. For the old
+ evaluation, compile with -DPre20000310 .
+ 20 April 2000: s_cat.c: tweak argument types to accord with
+ calls by f2c when ftnint and ftnlen are of
+ different sizes (different numbers of bits).
+ 4 July 2000: adjustments to permit compilation by C++ compilers;
+ VERSION string remains unchanged. NOT APPLIED FOR G77.
+ 29 Sept. 2000: 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.
*/
*** libF77/dtime_.c.orig Mon May 3 10:35:11 1999
--- libF77/dtime_.c Sat Dec 9 12:46:48 2000
*************** dtime_(float *tarray)
*** 46,51 ****
times(&t);
! tarray[0] = (t.tms_utime - t0.tms_utime) / Hz;
! tarray[1] = (t.tms_stime - t0.tms_stime) / Hz;
t0 = t;
return tarray[0] + tarray[1];
--- 46,51 ----
times(&t);
! tarray[0] = (double)(t.tms_utime - t0.tms_utime) / Hz;
! tarray[1] = (double)(t.tms_stime - t0.tms_stime) / Hz;
t0 = t;
return tarray[0] + tarray[1];
*** libF77/etime_.c.orig Mon May 3 10:35:12 1999
--- libF77/etime_.c Sat Dec 9 12:49:31 2000
*************** etime_(float *tarray)
*** 42,46 ****
times(&t);
! return (tarray[0] = t.tms_utime/Hz) + (tarray[1] = t.tms_stime/Hz);
#endif
}
--- 42,47 ----
times(&t);
! return (tarray[0] = (double)t.tms_utime/Hz)
! + (tarray[1] = (double)t.tms_stime/Hz);
#endif
}
*** libF77/s_cat.c.orig Sat Sep 4 17:09:17 1999
--- libF77/s_cat.c Sat Dec 9 12:43:28 2000
***************
*** 23,29 ****
VOID
#ifdef KR_headers
! s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnlen rnp[], *np, ll;
#else
! s_cat(char *lp, char *rpp[], ftnlen rnp[], ftnlen *np, ftnlen ll)
#endif
{
--- 23,29 ----
VOID
#ifdef KR_headers
! s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnint rnp[], *np; ftnlen ll;
#else
! s_cat(char *lp, char *rpp[], ftnint rnp[], ftnint *np, ftnlen ll)
#endif
{
*** libF77/z_log.c.orig Mon May 3 10:35:17 1999
--- libF77/z_log.c Sat Dec 9 13:14:08 2000
*************** void z_log(doublecomplex *r, doublecompl
*** 11,16 ****
--- 11,63 ----
#endif
{
+ double s, s0, t, t2, u, v;
double zi = z->i, zr = z->r;
+
r->i = atan2(zi, zr);
+ #ifdef Pre20000310
r->r = log( f__cabs( zr, zi ) );
+ #else
+ if (zi < 0)
+ zi = -zi;
+ if (zr < 0)
+ zr = -zr;
+ if (zr < zi) {
+ t = zi;
+ zi = zr;
+ zr = t;
+ }
+ t = zi/zr;
+ s = zr * sqrt(1 + t*t);
+ /* now s = f__cabs(zi,zr), and zr = |zr| >= |zi| = zi */
+ if ((t = s - 1) < 0)
+ t = -t;
+ if (t > .01)
+ r->r = log(s);
+ else {
+
+ #ifdef Comment
+
+ log(1+x) = x - x^2/2 + x^3/3 - x^4/4 + - ...
+
+ = x(1 - x/2 + x^2/3 -+...)
+
+ [sqrt(y^2 + z^2) - 1] * [sqrt(y^2 + z^2) + 1] = y^2 + z^2 - 1, so
+
+ sqrt(y^2 + z^2) - 1 = (y^2 + z^2 - 1) / [sqrt(y^2 + z^2) + 1]
+
+ #endif /*Comment*/
+
+ t = ((zr*zr - 1.) + zi*zi) / (s + 1);
+ t2 = t*t;
+ s = 1. - 0.5*t;
+ u = v = 1;
+ do {
+ s0 = s;
+ u *= t2;
+ v += 2;
+ s += u/v - t*u/(v+1);
+ } while(s > s0);
+ r->r = s*t;
+ }
+ #endif
}
*** libI77/Version.c.orig Sat Dec 9 12:08:23 2000
--- libI77/Version.c Sat Dec 9 13:13:09 2000
***************
*** 1,3 ****
! static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 19991115\n";
/*
--- 1,3 ----
! static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 20001205\n";
/*
*************** wrtfmt.c:
*** 315,318 ****
--- 315,327 ----
/* any data in buffers should the program fault. It also */
/* makes the program run more slowly. */
+ /* 20 April 2000: rsne.c, xwsne.c: tweaks that only matter if ftnint and */
+ /* ftnlen are of different fundamental types (different numbers */
+ /* of bits). Since these files will not compile when this */
+ /* change matters, the above VERSION string remains unchanged. */
+ /* 4 July 2000: adjustments to permit compilation by C++ compilers; */
+ /* VERSION string remains unchanged. NOT APPLIED FOR G77 */
+ /* 5 Dec. 2000: lread.c: under namelist input, when reading a logical array, */
+ /* treat Tstuff= and Fstuff= as new assignments rather than as */
+ /* logical constants. */
*** libI77/lread.c.orig Wed Mar 17 09:21:19 1999
--- libI77/lread.c Sat Dec 9 13:12:28 2000
*************** l_C(Void)
*** 340,348 ****
}
static int
l_L(Void)
{
! int ch;
! if(f__lcount>0) return(0);
f__lcount = 1;
f__ltype=0;
--- 340,430 ----
}
+ static char nmLbuf[256], *nmL_next;
+ static int (*nmL_getc_save)(Void);
+ #ifdef KR_headers
+ static int (*nmL_ungetc_save)(/* int, FILE* */);
+ #else
+ static int (*nmL_ungetc_save)(int, FILE*);
+ #endif
+
+ static int
+ nmL_getc(Void)
+ {
+ int rv;
+ if (rv = *nmL_next++)
+ return rv;
+ l_getc = nmL_getc_save;
+ l_ungetc = nmL_ungetc_save;
+ return (*l_getc)();
+ }
+
+ static int
+ #ifdef KR_headers
+ nmL_ungetc(x, f) int x; FILE *f;
+ #else
+ nmL_ungetc(int x, FILE *f)
+ #endif
+ {
+ f = f; /* banish non-use warning */
+ return *--nmL_next = x;
+ }
+
+ static int
+ #ifdef KR_headers
+ Lfinish(ch, dot, rvp) int ch, dot, *rvp;
+ #else
+ Lfinish(int ch, int dot, int *rvp)
+ #endif
+ {
+ char *s, *se;
+ static char what[] = "namelist input";
+
+ s = nmLbuf + 2;
+ se = nmLbuf + sizeof(nmLbuf) - 1;
+ *s++ = ch;
+ while(!issep(GETC(ch)) && ch!=EOF) {
+ if (s >= se) {
+ nmLbuf_ovfl:
+ return *rvp = err__fl(f__elist->cierr,131,what);
+ }
+ *s++ = ch;
+ if (ch != '=')
+ continue;
+ if (dot)
+ return *rvp = err__fl(f__elist->cierr,112,what);
+ got_eq:
+ *s = 0;
+ nmL_getc_save = l_getc;
+ l_getc = nmL_getc;
+ nmL_ungetc_save = l_ungetc;
+ l_ungetc = nmL_ungetc;
+ nmLbuf[1] = *(nmL_next = nmLbuf) = ',';
+ *rvp = f__lcount = 0;
+ return 1;
+ }
+ if (dot)
+ goto done;
+ for(;;) {
+ if (s >= se)
+ goto nmLbuf_ovfl;
+ *s++ = ch;
+ if (!isblnk(ch))
+ break;
+ if (GETC(ch) == EOF)
+ goto done;
+ }
+ if (ch == '=')
+ goto got_eq;
+ done:
+ Ungetc(ch, f__cf);
+ return 0;
+ }
+
static int
l_L(Void)
{
! int ch, rv, sawdot;
! if(f__lcount>0)
! return(0);
f__lcount = 1;
f__ltype=0;
*************** l_L(Void)
*** 358,370 ****
GETC(ch);
}
! if(ch == '.') GETC(ch);
switch(ch)
{
case 't':
case 'T':
f__lx=1;
break;
case 'f':
case 'F':
f__lx=0;
break;
--- 440,460 ----
GETC(ch);
}
! sawdot = 0;
! if(ch == '.') {
! sawdot = 1;
! GETC(ch);
! }
switch(ch)
{
case 't':
case 'T':
+ if (nml_read && Lfinish(ch, sawdot, &rv))
+ return rv;
f__lx=1;
break;
case 'f':
case 'F':
+ if (nml_read && Lfinish(ch, sawdot, &rv))
+ return rv;
f__lx=0;
break;
*** libI77/rsne.c.orig Mon Jun 28 20:38:42 1999
--- libI77/rsne.c Sat Dec 9 12:56:32 2000
*************** x_rsne(cilist *a)
*** 303,308 ****
dimen *dn, *dn0, *dn1;
ftnlen *dims, *dims1;
! ftnlen b, b0, b1, ex, no, no1, nomax, size, span;
! ftnint type;
char *vaddr;
long iva, ivae;
--- 303,308 ----
dimen *dn, *dn0, *dn1;
ftnlen *dims, *dims1;
! ftnlen b, b0, b1, ex, no, nomax, size, span;
! ftnint no1, type;
char *vaddr;
long iva, ivae;
*************** x_rsne(cilist *a)
*** 339,343 ****
}
have_amp:
! if (ch = getname(buf,(int) sizeof(buf)))
return ch;
nl = (Namelist *)a->cifmt;
--- 339,343 ----
}
have_amp:
! if (ch = getname(buf,sizeof(buf)))
return ch;
nl = (Namelist *)a->cifmt;
*************** x_rsne(cilist *a)
*** 394,398 ****
continue;
Ungetc(ch,f__cf);
! if (ch = getname(buf,(int) sizeof(buf)))
return ch;
goto havename;
--- 394,398 ----
continue;
Ungetc(ch,f__cf);
! if (ch = getname(buf,sizeof(buf)))
return ch;
goto havename;
*** libI77/xwsne.c.orig Sat Sep 4 17:09:18 1999
--- libI77/xwsne.c Sat Dec 9 12:59:36 2000
*************** x_wsne(cilist *a)
*** 25,32 ****
char *s;
Vardesc *v, **vd, **vde;
! ftnint *number, type;
ftnlen *dims;
ftnlen size;
- static ftnint one = 1;
extern ftnlen f__typesize[];
--- 25,31 ----
char *s;
Vardesc *v, **vd, **vde;
! ftnint number, type;
ftnlen *dims;
ftnlen size;
extern ftnlen f__typesize[];
*************** x_wsne(cilist *a)
*** 50,54 ****
PUT(' ');
PUT('=');
! number = (dims = v->dims) ? dims + 1 : &one;
type = v->type;
if (type < 0) {
--- 49,53 ----
PUT(' ');
PUT('=');
! number = (dims = v->dims) ? dims[1] : 1;
type = v->type;
if (type < 0) {
*************** x_wsne(cilist *a)
*** 58,62 ****
else
size = f__typesize[type];
! l_write(number, v->addr, size, type);
if (vd < vde) {
if (f__recpos+2 >= L_len)
--- 57,61 ----
else
size = f__typesize[type];
! l_write(&number, v->addr, size, type);
if (vd < vde) {
if (f__recpos+2 >= L_len)