diff options
Diffstat (limited to 'lib')
42 files changed, 626 insertions, 198 deletions
diff --git a/lib/libF77/F77_aloc.c b/lib/libF77/F77_aloc.c new file mode 100644 index 0000000..18a345f --- /dev/null +++ b/lib/libF77/F77_aloc.c @@ -0,0 +1,32 @@ +#include "f2c.h" +#undef abs +#undef min +#undef max +#include "stdio.h" + +static integer memfailure = 3; + +#ifdef KR_headers +extern char *malloc(); +extern void exit_(); + + char * +F77_aloc(Len, whence) integer Len; char *whence; +#else +#include "stdlib.h" +extern void exit_(integer*); + + char * +F77_aloc(integer Len, char *whence) +#endif +{ + char *rv; + unsigned int uLen = (unsigned int) Len; /* for K&R C */ + + if (!(rv = malloc(uLen))) { + fprintf(stderr, "malloc(%u) failure in %s\n", + uLen, whence); + exit_(&memfailure); + } + return rv; + } diff --git a/lib/libF77/README b/lib/libF77/README index b5b0b81..a575124 100644 --- a/lib/libF77/README +++ b/lib/libF77/README @@ -87,8 +87,10 @@ for use with INTEGER*8. To use it, you must modify f2c.h to declare longint appropriately; then add pow_qq.o to the POW = line in the makefile. -If you wish to allow the target of a (character string) concatenation -to be appear on its right-hand (at the cost of extra overhead for -all run-time concatenations), change "s_cat.o" to "s_catow.o" in -the makefile. Note that the Fortran 77 Standard explicitly forbids -the target of a concatenation from appearing on its right-hand side. +Following Fortran 90, s_cat.c and s_copy.c allow the target of a +(character string) assignment to be appear on its right-hand, at +the cost of some extra overhead for all run-time concatenations. +If you prefer the extra efficiency that comes with the Fortran 77 +requirement that the left-hand side of a character assignment not +be involved in the right-hand side, compile s_cat.c and s_copy.c +with -DNO_OVERWRITE . diff --git a/lib/libF77/Version.c b/lib/libF77/Version.c index bbc6110..df2434a 100644 --- a/lib/libF77/Version.c +++ b/lib/libF77/Version.c @@ -1,4 +1,4 @@ -static char junk[] = "\n@(#)LIBF77 VERSION 2.01 19 Sept. 1994\n"; +static char junk[] = "\n@(#)LIBF77 VERSION 2.01 6 Sept. 1995\n"; /* 2.00 11 June 1980. File version.c added to library. @@ -27,4 +27,15 @@ static char junk[] = "\n@(#)LIBF77 VERSION 2.01 19 Sept. 1994\n"; 2 June 1994: adjust so abnormal terminations invoke f_exit just once 16 Sept. 1994: s_cmp: treat characters as unsigned in comparisons. 19 Sept. 1994: s_paus: flush after end of PAUSE; add -DMSDOS + 12 Jan. 1995: pow_[dhiqrz][hiq]: adjust x**i to work on machines + that sign-extend right shifts when i is the most + negative integer. + 26 Jan. 1995: adjust s_cat.c, s_copy.c to permit the left-hand side + of character assignments to appear on the right-hand + side (unless compiled with -DNO_OVERWRITE). + 27 Jan. 1995: minor tweak to s_copy.c: copy forward whenever + possible (for better cache behavior). + 30 May 1995: added subroutine exit(rc) integer rc. Version not changed. + 29 Aug. 1995: add F77_aloc.c; use it in s_cat.c and system_.c. + 6 Sept. 1995: fix return type of system_ under -DKR_headers. */ diff --git a/lib/libF77/exit.c b/lib/libF77/exit.c new file mode 100644 index 0000000..da3ab5c --- /dev/null +++ b/lib/libF77/exit.c @@ -0,0 +1,37 @@ +/* This gives the effect of + + subroutine exit(rc) + integer*4 rc + stop + end + + * with the added side effect of supplying rc as the program's exit code. + */ + +#include "f2c.h" +#undef abs +#undef min +#undef max +#ifndef KR_headers +#include "stdlib.h" +#ifdef __cplusplus +extern "C" { +#endif +extern void f_exit(void); +#endif + + void +#ifdef KR_headers +exit_(rc) integer *rc; +#else +exit_(integer *rc) +#endif +{ +#ifdef NO_ONEXIT + f_exit(); +#endif + exit(*rc); + } +#ifdef __cplusplus +} +#endif diff --git a/lib/libF77/libF77.xsum b/lib/libF77/libF77.xsum index faf4a24..fe3fbfc 100644 --- a/lib/libF77/libF77.xsum +++ b/lib/libF77/libF77.xsum @@ -1,6 +1,7 @@ +F77_aloc.c fc8e8844 536 Notice 1211689a 1195 -README 1c4c3814 4053 -Version.c 10d0f4c6 1447 +README 1d306d9d 4130 +Version.c f329c4b2 2060 abort_.c eaf90dc0 239 c_abs.c ecce7a47 205 c_cos.c f2338a46 260 @@ -39,6 +40,7 @@ ef1asc_.c f14b3469 453 ef1cmc_.c 1e0b86e3 360 erf_.c 7a407d 158 erfc_.c fb488e22 163 +exit.c eaf1e4de 476 f2ch.add fed3bb7b 6056 getarg_.c edcf61f8 495 getenv_.c eaafcc11 975 @@ -67,16 +69,16 @@ l_ge.c 5b7cb55 267 l_gt.c ad1b388 266 l_le.c f5407149 267 l_lt.c f81a93f8 266 -main.c ec7fc5ad 2012 -makefile 1f2ebd87 3036 +main.c 1144a505 2064 +makefile e4156396 3063 pow_ci.c f593b0b9 345 pow_dd.c e451857d 209 -pow_di.c f5c04524 360 -pow_hh.c feb3b910 401 -pow_ii.c fe444c9b 395 -pow_qq.c fdf1dc33 395 -pow_ri.c ea06b62d 348 -pow_zi.c f21e1934 694 +pow_di.c 11a1842e 381 +pow_hh.c e0cb1b69 422 +pow_ii.c 17c60a01 421 +pow_qq.c ffbbdec9 449 +pow_ri.c eacf8350 369 +pow_zi.c fe9073e4 715 pow_zz.c f0e5f141 482 r_abs.c 1a4e3da 139 r_acos.c ca67f96 166 @@ -100,16 +102,15 @@ r_sinh.c f21a38b8 166 r_sqrt.c f24b8aa4 166 r_tan.c e60b7778 162 r_tanh.c f22ec5c 166 -s_cat.c e53641 408 -s_catow.c 538ae5a 1222 +s_cat.c 151033e2 1304 s_cmp.c ff4f2982 655 -s_copy.c f50c7ec9 397 +s_copy.c e10dd76f 957 s_paus.c e726a719 1552 s_rnge.c 1d6cada2 680 s_stop.c 1f5aaac8 511 sig_die.c e934624a 634 -signal_.c 1b0b75f3 327 -system_.c c910b8a 396 +signal_.c fde97f5f 395 +system_.c e4ed54ab 579 z_abs.c f71a28c1 201 z_cos.c 110bc444 269 z_div.c ff56b823 675 diff --git a/lib/libF77/main.c b/lib/libF77/main.c index 24c2f22..79f1943 100644 --- a/lib/libF77/main.c +++ b/lib/libF77/main.c @@ -10,15 +10,21 @@ #endif #ifndef KR_headers +#undef VOID #include "stdlib.h" #endif + +#ifndef VOID +#define VOID void +#endif + #ifdef __cplusplus extern "C" { #endif #ifdef NO__STDC #define ONEXIT onexit -extern void f_exit(); +extern VOID f_exit(); #else #ifndef KR_headers extern void f_exit(void); @@ -29,13 +35,13 @@ extern int atexit(void (*)(void)); #else #ifndef NO_ONEXIT #define ONEXIT onexit -extern void f_exit(); +extern VOID f_exit(); #endif #endif #endif #ifdef KR_headers -extern void f_init(), sig_die(); +extern VOID f_init(), sig_die(); extern int MAIN__(); #define Int /* int */ #else @@ -44,37 +50,37 @@ extern int MAIN__(void); #define Int int #endif -static void sigfdie(Int n) +static VOID sigfdie(Int n) { sig_die("Floating Exception", 1); } -static void sigidie(Int n) +static VOID sigidie(Int n) { sig_die("IOT Trap", 1); } #ifdef SIGQUIT -static void sigqdie(Int n) +static VOID sigqdie(Int n) { sig_die("Quit signal", 1); } #endif -static void sigindie(Int n) +static VOID sigindie(Int n) { sig_die("Interrupt", 0); } -static void sigtdie(Int n) +static VOID sigtdie(Int n) { sig_die("Killed", 0); } #ifdef SIGTRAP -static void sigtrdie(Int n) +static VOID sigtrdie(Int n) { sig_die("Trace trap", 1); } diff --git a/lib/libF77/makefile b/lib/libF77/makefile index 405128d..6e7cc68 100644 --- a/lib/libF77/makefile +++ b/lib/libF77/makefile @@ -18,9 +18,9 @@ CFLAGS = -O ld -r -x -o $*.xxx $*.o mv $*.xxx $*.o -MISC = Version.o main.o s_rnge.o abort_.o getarg_.o iargc_.o getenv_.o\ - signal_.o s_stop.o s_paus.o system_.o cabs.o\ - derf_.o derfc_.o erf_.o erfc_.o sig_die.o +MISC = F77_aloc.o Version.o main.o s_rnge.o abort_.o getarg_.o iargc_.o \ + getenv_.o signal_.o s_stop.o s_paus.o system_.o cabs.o\ + derf_.o derfc_.o erf_.o erfc_.o sig_die.o exit.o POW = pow_ci.o pow_dd.o pow_di.o pow_hh.o pow_ii.o pow_ri.o pow_zi.o pow_zz.o CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o @@ -58,12 +58,12 @@ clean: rm -f libF77.a *.o check: - xsum Notice README Version.c abort_.c c_abs.c c_cos.c c_div.c \ - c_exp.c c_log.c c_sin.c c_sqrt.c cabs.c d_abs.c d_acos.c \ + xsum Notice README F77_aloc.c Version.c abort_.c c_abs.c c_cos.c \ + c_div.c c_exp.c c_log.c c_sin.c c_sqrt.c cabs.c d_abs.c d_acos.c \ d_asin.c d_atan.c d_atn2.c d_cnjg.c d_cos.c d_cosh.c d_dim.c \ d_exp.c d_imag.c d_int.c d_lg10.c d_log.c d_mod.c d_nint.c \ d_prod.c d_sign.c d_sin.c d_sinh.c d_sqrt.c d_tan.c d_tanh.c \ - derf_.c derfc_.c ef1asc_.c ef1cmc_.c erf_.c erfc_.c f2ch.add \ + derf_.c derfc_.c ef1asc_.c ef1cmc_.c erf_.c erfc_.c exit.c f2ch.add \ getarg_.c getenv_.c h_abs.c h_dim.c h_dnnt.c h_indx.c h_len.c \ h_mod.c h_nint.c h_sign.c hl_ge.c hl_gt.c hl_le.c hl_lt.c \ i_abs.c i_dim.c i_dnnt.c i_indx.c i_len.c i_mod.c i_nint.c \ @@ -72,7 +72,7 @@ check: pow_zi.c pow_zz.c r_abs.c r_acos.c r_asin.c r_atan.c r_atn2.c \ r_cnjg.c r_cos.c r_cosh.c r_dim.c r_exp.c r_imag.c r_int.c r_lg10.c \ r_log.c r_mod.c r_nint.c r_sign.c r_sin.c r_sinh.c r_sqrt.c \ - r_tan.c r_tanh.c s_cat.c s_catow.c s_cmp.c s_copy.c s_paus.c s_rnge.c \ - s_stop.c sig_die.c signal_.c system_.c z_abs.c z_cos.c z_div.c \ - z_exp.c z_log.c z_sin.c z_sqrt.c >zap + r_tan.c r_tanh.c s_cat.c s_cmp.c s_copy.c \ + s_paus.c s_rnge.c s_stop.c sig_die.c signal_.c system_.c \ + z_abs.c z_cos.c z_div.c z_exp.c z_log.c z_sin.c z_sqrt.c >zap cmp zap libF77.xsum && rm zap || diff libF77.xsum zap diff --git a/lib/libF77/pow_di.c b/lib/libF77/pow_di.c index 7af69a7..affed62 100644 --- a/lib/libF77/pow_di.c +++ b/lib/libF77/pow_di.c @@ -8,6 +8,7 @@ double pow_di(doublereal *ap, integer *bp) { double pow, x; integer n; +unsigned long u; pow = 1; x = *ap; @@ -20,11 +21,11 @@ if(n != 0) n = -n; x = 1/x; } - for( ; ; ) + for(u = n; ; ) { - if(n & 01) + if(u & 01) pow *= x; - if(n >>= 1) + if(u >>= 1) x *= x; else break; diff --git a/lib/libF77/pow_hh.c b/lib/libF77/pow_hh.c index e1a503c..24a0197 100644 --- a/lib/libF77/pow_hh.c +++ b/lib/libF77/pow_hh.c @@ -7,6 +7,7 @@ shortint pow_hh(shortint *ap, shortint *bp) #endif { shortint pow, x, n; + unsigned u; x = *ap; n = *bp; @@ -18,11 +19,12 @@ shortint pow_hh(shortint *ap, shortint *bp) return x == 0 ? 1/x : 0; n = -n; } + u = n; for(pow = 1; ; ) { - if(n & 01) + if(u & 01) pow *= x; - if(n >>= 1) + if(u >>= 1) x *= x; else break; diff --git a/lib/libF77/pow_ii.c b/lib/libF77/pow_ii.c index e794877..84d1c7e 100644 --- a/lib/libF77/pow_ii.c +++ b/lib/libF77/pow_ii.c @@ -7,6 +7,7 @@ integer pow_ii(integer *ap, integer *bp) #endif { integer pow, x, n; + unsigned long u; x = *ap; n = *bp; @@ -18,11 +19,12 @@ integer pow_ii(integer *ap, integer *bp) return x == 0 ? 1/x : 0; n = -n; } + u = n; for(pow = 1; ; ) { - if(n & 01) + if(u & 01) pow *= x; - if(n >>= 1) + if(u >>= 1) x *= x; else break; diff --git a/lib/libF77/pow_qq.c b/lib/libF77/pow_qq.c index d80c40a9..3bc80e0 100644 --- a/lib/libF77/pow_qq.c +++ b/lib/libF77/pow_qq.c @@ -7,6 +7,7 @@ longint pow_qq(longint *ap, longint *bp) #endif { longint pow, x, n; + unsigned long long u; /* system-dependent */ x = *ap; n = *bp; @@ -18,11 +19,12 @@ longint pow_qq(longint *ap, longint *bp) return x == 0 ? 1/x : 0; n = -n; } + u = n; for(pow = 1; ; ) { - if(n & 01) + if(u & 01) pow *= x; - if(n >>= 1) + if(u >>= 1) x *= x; else break; diff --git a/lib/libF77/pow_ri.c b/lib/libF77/pow_ri.c index 3a3c4cf..6e5816b 100644 --- a/lib/libF77/pow_ri.c +++ b/lib/libF77/pow_ri.c @@ -8,6 +8,7 @@ double pow_ri(real *ap, integer *bp) { double pow, x; integer n; +unsigned long u; pow = 1; x = *ap; @@ -20,11 +21,11 @@ if(n != 0) n = -n; x = 1/x; } - for( ; ; ) + for(u = n; ; ) { - if(n & 01) + if(u & 01) pow *= x; - if(n >>= 1) + if(u >>= 1) x *= x; else break; diff --git a/lib/libF77/pow_zi.c b/lib/libF77/pow_zi.c index 8dd6006..167e6ac 100644 --- a/lib/libF77/pow_zi.c +++ b/lib/libF77/pow_zi.c @@ -9,6 +9,7 @@ void pow_zi(doublecomplex *p, doublecomplex *a, integer *b) /* p = a**b */ #endif { integer n; +unsigned long u; double t; doublecomplex x; static doublecomplex one = {1.0, 0.0}; @@ -30,15 +31,15 @@ else x.i = a->i; } -for( ; ; ) +for(u = n; ; ) { - if(n & 01) + if(u & 01) { t = p->r * x.r - p->i * x.i; p->i = p->r * x.i + p->i * x.r; p->r = t; } - if(n >>= 1) + if(u >>= 1) { t = x.r * x.r - x.i * x.i; x.i = 2 * x.r * x.i; diff --git a/lib/libF77/s_cat.c b/lib/libF77/s_cat.c index 7f55cd5..1d6fd24 100644 --- a/lib/libF77/s_cat.c +++ b/lib/libF77/s_cat.c @@ -1,25 +1,71 @@ +/* Unless compiled with -DNO_OVERWRITE, this variant of s_cat allows the + * target of a concatenation to appear on its right-hand side (contrary + * to the Fortran 77 Standard, but in accordance with Fortran 90). + */ + #include "f2c.h" +#ifndef NO_OVERWRITE +#include "stdio.h" +#undef abs +#ifdef KR_headers + extern char *F77_aloc(); + extern void free(); + extern void exit_(); +#else +#include "stdlib.h" + extern char *F77_aloc(ftnlen, char*); +#endif +#include "string.h" +#endif /* NO_OVERWRITE */ + VOID #ifdef KR_headers -VOID s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnlen rnp[], *np, ll; +s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnlen rnp[], *np, ll; #else -VOID s_cat(char *lp, char *rpp[], ftnlen rnp[], ftnlen *np, ftnlen ll) +s_cat(char *lp, char *rpp[], ftnlen rnp[], ftnlen *np, ftnlen ll) #endif { -ftnlen i, n, nc; -char *f__rp; + ftnlen i, nc; + char *rp; + ftnlen n = *np; +#ifndef NO_OVERWRITE + ftnlen L, m; + char *lp0, *lp1; -n = *np; -for(i = 0 ; i < n ; ++i) - { - nc = ll; - if(rnp[i] < nc) - nc = rnp[i]; - ll -= nc; - f__rp = rpp[i]; - while(--nc >= 0) - *lp++ = *f__rp++; + lp0 = 0; + lp1 = lp; + L = ll; + i = 0; + while(i < n) { + rp = rpp[i]; + m = rnp[i++]; + if (rp >= lp1 || rp + m <= lp) { + if ((L -= m) <= 0) { + n = i; + break; + } + lp1 += m; + continue; + } + lp0 = lp; + lp = lp1 = F77_aloc(L = ll, "s_cat"); + } +#endif /* NO_OVERWRITE */ + for(i = 0 ; i < n ; ++i) { + nc = ll; + if(rnp[i] < nc) + nc = rnp[i]; + ll -= nc; + rp = rpp[i]; + while(--nc >= 0) + *lp++ = *rp++; + } + while(--ll >= 0) + *lp++ = ' '; +#ifndef NO_OVERWRITE + if (lp0) { + memcpy(lp0, lp1, L); + free(lp1); + } +#endif } -while(--ll >= 0) - *lp++ = ' '; -} diff --git a/lib/libF77/s_copy.c b/lib/libF77/s_copy.c index 989f5dd..d167351 100644 --- a/lib/libF77/s_copy.c +++ b/lib/libF77/s_copy.c @@ -1,3 +1,9 @@ +/* Unless compiled with -DNO_OVERWRITE, this variant of s_copy allows the + * target of an assignment to appear on its right-hand side (contrary + * to the Fortran 77 Standard, but in accordance with Fortran 90), + * as in a(2:5) = a(4:7) . + */ + #include "f2c.h" /* assign strings: a = b */ @@ -8,20 +14,38 @@ VOID s_copy(a, b, la, lb) register char *a, *b; ftnlen la, lb; void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb) #endif { -register char *aend, *bend; + register char *aend, *bend; -aend = a + la; + aend = a + la; -if(la <= lb) - while(a < aend) - *a++ = *b++; + if(la <= lb) +#ifndef NO_OVERWRITE + if (a <= b || a >= b + la) +#endif + while(a < aend) + *a++ = *b++; +#ifndef NO_OVERWRITE + else + for(b += la; a < aend; ) + *--aend = *--b; +#endif -else - { - bend = b + lb; - while(b < bend) - *a++ = *b++; - while(a < aend) - *a++ = ' '; + else { + bend = b + lb; +#ifndef NO_OVERWRITE + if (a <= b || a >= bend) +#endif + while(b < bend) + *a++ = *b++; +#ifndef NO_OVERWRITE + else { + a += lb; + while(b < bend) + *--a = *--bend; + a += lb; + } +#endif + while(a < aend) + *a++ = ' '; + } } -} diff --git a/lib/libF77/signal_.c b/lib/libF77/signal_.c index 90ec7ea..8f06c91 100644 --- a/lib/libF77/signal_.c +++ b/lib/libF77/signal_.c @@ -1,19 +1,21 @@ #include "f2c.h" #ifdef KR_headers -typedef int (*sig_type)(); +typedef VOID (*sig_type)(); extern sig_type signal(); +typedef int (*sig_proc)(); ftnint signal_(sigp, proc) integer *sigp; sig_type proc; #else #include "signal.h" typedef void (*sig_type)(int); +typedef int (*sig_proc)(int); -ftnint signal_(integer *sigp, sig_type proc) +ftnint signal_(integer *sigp, sig_proc proc) #endif { int sig; sig = (int)*sigp; - return (ftnint)signal(sig, proc); + return (ftnint)signal(sig, (sig_type)proc); } diff --git a/lib/libF77/system_.c b/lib/libF77/system_.c index 6f8a71d..e6b3a02 100644 --- a/lib/libF77/system_.c +++ b/lib/libF77/system_.c @@ -3,22 +3,34 @@ #include "f2c.h" #ifdef KR_headers +extern char *F77_aloc(); + + integer system_(s, n) register char *s; ftnlen n; #else #undef abs #undef min #undef max #include "stdlib.h" +extern char *F77_aloc(ftnlen, char*); + + integer system_(register char *s, ftnlen n) #endif { -char buff[1000]; -register char *bp, *blast; + char buff0[256], *buff; + register char *bp, *blast; + integer rv; -blast = buff + (n < 1000 ? n : 1000); + buff = bp = n < sizeof(buff0) + ? buff0 : F77_aloc(n+1, "system_"); + blast = bp + n; -for(bp = buff ; bp<blast && *s!='\0' ; ) - *bp++ = *s++; -*bp = '\0'; -return system(buff); -} + while(bp < blast && *s) + *bp++ = *s++; + *bp = 0; + rv = system(buff); + if (buff != buff0) + free(buff); + return rv; + } diff --git a/lib/libI77/Notice b/lib/libI77/Notice index b0dba28..9715a19 100644 --- a/lib/libI77/Notice +++ b/lib/libI77/Notice @@ -1,5 +1,5 @@ /**************************************************************** -Copyright 1990 - 1994 by AT&T Bell Laboratories and Bellcore. +Copyright 1990 - 1995 by AT&T Bell Laboratories and Bellcore. Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby diff --git a/lib/libI77/README b/lib/libI77/README index 8b19130..6b0558d 100644 --- a/lib/libI77/README +++ b/lib/libI77/README @@ -147,6 +147,10 @@ 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. (Sept. 1995) When looking for the &name that starts namelist +input, lines whose first non-blank character is something other +than &, $, or ? are treated as comment lines and ignored, unless +rsne.c is compiled with -DNo_Namelist_Comments. Nonstandard extension (Feb. 1993) to open: for sequential files, ACCESS='APPEND' (or access='anything else starting with "A" or "a"') @@ -164,6 +168,12 @@ 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 . +If you want to be able to catch write failures (e.g., due to a +disk being full) with an ERR= specifier, compile dfe.c, due.c, +sfe.c, sue.c, and wsle.c with -DALWAYS_FLUSH. This will lead to +slower execution and more I/O, but should make ERR= work as +expected, provided fflush returns an error return when its +physical write fails. Carriage controls are meant to be interpreted by the UNIX col program (or a similar program). Sometimes it's convenient to use @@ -172,3 +182,9 @@ If you compile lwrite.c and wsfe.c with -DOMIT_BLANK_CC, formatted external output lines will have an initial ' ' quietly omitted, making use of the col program unnecessary with output that only has ' ' for carriage control. + +The Fortran 77 Standard leaves it up to the implementation whether +formatted writes of floating-point numbers of absolute value < 1 have +a zero before the decimal point. By default, libI77 omits such +superfluous zeros, but you can cause them to appear by compiling +lwrite.c, wref.c, and wrtfmt.c with -DWANT_LEAD_0 . diff --git a/lib/libI77/Version.c b/lib/libI77/Version.c index 3958b77..ebd3f0b 100644 --- a/lib/libI77/Version.c +++ b/lib/libI77/Version.c @@ -1,4 +1,4 @@ -static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 6 Octt. 1994\n"; +static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 19950907\n"; /* 2.01 $ format added @@ -198,3 +198,27 @@ wrtfmt.c: INTEGER*1, and (under -DAllow_TYQUAD) INTEGER*8 in NAMELISTs. */ /* 6 Oct. 1994: util.c: omit f__mvgbt, as it is never used. */ +/* 2 Nov. 1994: add #ifdef ALWAYS_FLUSH logic. */ +/* 26 Jan. 1995: wref.c: fix glitch in printing the exponent of 0 when + GOOD_SPRINTF_EXPONENT is not #defined. */ +/* 24 Feb. 1995: iio.c: z_getc: insert (unsigned char *) to allow + internal reading of characters with high-bit set + (on machines that sign-extend characters). */ +/* 14 March 1995: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). */ +/* 26 May 1995: 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. */ +/* 29 Aug. 1995: backspace.c: adjust MSDOS logic. */ +/* 6 Sept. 1995: 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). Adjust f_init calls + for people who don't use libF77's main(); now open and + namelist read statements invoke f_init if needed. */ +/* 7 Sept. 1995: Fix some bugs with -DAllow_TYQUAD (for integer*8). + Add -DNo_Namelist_Comments lines to rsne.c. */ diff --git a/lib/libI77/backspace.c b/lib/libI77/backspace.c index 4213424..3771cd9 100644 --- a/lib/libI77/backspace.c +++ b/lib/libI77/backspace.c @@ -50,14 +50,16 @@ integer f_back(alist *a) #ifdef MSDOS w = -1; #endif - for(ndec = 2;; ndec = 1) + for(ndec = 1;; ndec = 0) { - y = x=ftell(b->ufd); - if(x<sizeof(buf)) x=0; - else x -= sizeof(buf); + y = x = ftell(b->ufd); + if(x < sizeof(buf)) + x = 0; + else + x -= sizeof(buf); (void) fseek(b->ufd,x,SEEK_SET); n=fread(buf,1,(int)(y-x), b->ufd); - for(i=n-ndec;i>=0;i--) + for(i = n - ndec; --i >= 0; ) { if(buf[i]!='\n') continue; #ifdef MSDOS @@ -65,17 +67,17 @@ integer f_back(alist *a) if (buf[j] == '\n') k++; fseek(b->ufd,x,SEEK_SET); - do { + for(;;) if (getc(b->ufd) == '\n') { - --k; - if ((z = ftell(b->ufd)) >= y) { + if ((z = ftell(b->ufd)) >= y && ndec) { if (w == -1) goto break2; break; } + if (--k <= 0) + return 0; w = z; } - } while(k > 0); fseek(b->ufd, w, SEEK_SET); #else fseek(b->ufd,(long)(i+1-n),SEEK_CUR); diff --git a/lib/libI77/dfe.c b/lib/libI77/dfe.c index 669c3bd..86fbe8e 100644 --- a/lib/libI77/dfe.c +++ b/lib/libI77/dfe.c @@ -152,6 +152,5 @@ integer e_rdfe(Void) } integer e_wdfe(Void) { - (void) en_fio(); - return(0); + return en_fio(); } diff --git a/lib/libI77/due.c b/lib/libI77/due.c index 33ee02c..d5ade7a 100644 --- a/lib/libI77/due.c +++ b/lib/libI77/due.c @@ -60,5 +60,9 @@ integer e_rdue(Void) } integer e_wdue(Void) { +#ifdef ALWAYS_FLUSH + if (fflush(f__cf)) + err(f__elist->cierr,errno,"write end"); +#endif return(e_rdue()); } diff --git a/lib/libI77/fmt.h b/lib/libI77/fmt.h index d4810a1..e94bc1c 100644 --- a/lib/libI77/fmt.h +++ b/lib/libI77/fmt.h @@ -80,3 +80,17 @@ extern int f__scale; #define VAL(x) (x!='\n'?x:' ') #define PUT(x) (*f__putn)(x) extern int f__cursor; + +#undef TYQUAD +#ifndef Allow_TYQUAD +#undef longint +#define longint long +#else +#define TYQUAD 14 +#endif + +#ifdef KR_headers +extern char *f__icvt(); +#else +extern char *f__icvt(longint, int*, int*, int); +#endif diff --git a/lib/libI77/fmtlib.c b/lib/libI77/fmtlib.c index 37a4cc5..1c6801e 100644 --- a/lib/libI77/fmtlib.c +++ b/lib/libI77/fmtlib.c @@ -1,28 +1,39 @@ /* @(#)fmtlib.c 1.2 */ #define MAXINTLENGTH 23 + +#include "f2c.h" +#ifndef Allow_TYQUAD +#undef longint +#define longint long +#endif + #ifdef KR_headers -char *f__icvt(value,ndigit,sign, base) long value; int *ndigit,*sign; +char *f__icvt(value,ndigit,sign, base) longint value; int *ndigit,*sign; register int base; #else -char *f__icvt(long value, int *ndigit, int *sign, int base) +char *f__icvt(longint value, int *ndigit, int *sign, int base) #endif { static char buf[MAXINTLENGTH+1]; register int i; - if(value>0) *sign=0; - else if(value<0) - { value = -value; - *sign= 1; - } - else - { *sign=0; - *ndigit=1; - buf[MAXINTLENGTH]='0'; - return(&buf[MAXINTLENGTH]); - } - for(i=MAXINTLENGTH-1;value>0;i--) - { *(buf+i)=(int)(value%base)+'0'; + + if(value > 0) + *sign = 0; + else if (value < 0) { + value = -value; + *sign = 1; + } + else { + *sign = 0; + *ndigit = 1; + buf[MAXINTLENGTH-1] = '0'; + return &buf[MAXINTLENGTH-1]; + } + i = MAXINTLENGTH; + do { + buf[--i] = (value%base) + '0'; value /= base; + } + while(value > 0); + *ndigit = MAXINTLENGTH - i; + return &buf[i]; } - *ndigit=MAXINTLENGTH-1-i; - return(&buf[i+1]); -} diff --git a/lib/libI77/iio.c b/lib/libI77/iio.c index b747826..4c8eb9d 100644 --- a/lib/libI77/iio.c +++ b/lib/libI77/iio.c @@ -10,7 +10,7 @@ z_getc(Void) { if(f__recpos++ < f__svic->icirlen) { if(f__icptr >= f__icend) err(f__svic->iciend,(EOF),"endfile"); - return(*f__icptr++); + return(*(unsigned char *)f__icptr++); } return '\n'; } @@ -95,6 +95,10 @@ integer s_rsfi(icilist *a) z_wnew(Void) { + if (f__recpos < f__hiwater) { + f__icptr += f__hiwater - f__recpos; + f__recpos = f__hiwater; + } while(f__recpos++ < f__svic->icirlen) *f__icptr++ = ' '; f__recpos = 0; diff --git a/lib/libI77/libI77.xsum b/lib/libI77/libI77.xsum index 00a8cb4..c93a190 100644 --- a/lib/libI77/libI77.xsum +++ b/lib/libI77/libI77.xsum @@ -1,41 +1,41 @@ -Notice 15a21790 1184 -README 16b752be 7685 -Version.c 11b93284 9820 -backspace.c 198946cc 1759 +Notice fd29c05f 1184 +README ef678ce5 8578 +Version.c 367e2b0 11141 +backspace.c e29c7ec1 1794 close.c 175acd02 1336 -dfe.c 3c6b216 2903 +dfe.c 16facc04 2891 dolio.c 17595b24 404 -due.c 1bbe319b 1430 +due.c f05f7fa6 1519 endfile.c 12d875dc 3400 err.c fccb27de 6084 f2ch.add fed3bb7b 6056 fio.h e7e8a21c 2315 fmt.c e37e7c2a 7857 -fmt.h 1273f9e8 1628 -fmtlib.c e010030f 582 +fmt.h 7686340 1835 +fmtlib.c f79c9df4 704 fp.h 100fb355 665 -iio.c e04c6615 2258 +iio.c fedbf0b5 2374 ilnw.c fa459169 1049 inquire.c e1059667 2536 -lio.h ffc2e000 1550 -lread.c e220dbce 11416 -lwrite.c 1a82fbe7 4183 +lio.h a087b39 1564 +lread.c 4dfc73b 12130 +lwrite.c 19137b45 4565 makefile e8266f12 1972 -open.c fd6dc333 4485 +open.c 1ef408ec 4512 rawio.h b9d538d 688 -rdfmt.c 1d49cf1d 8344 +rdfmt.c 55975ac 8347 rewind.c 87b080b 408 -rsfe.c c949b09 1299 +rsfe.c 1d79e4a1 1415 rsli.c 1259dfec 1748 -rsne.c ee3a2728 10686 -sfe.c f8a8b265 638 -sue.c ff73457b 1740 +rsne.c f2e2cad1 11466 +sfe.c 45a6968 793 +sue.c ec169681 1803 typesize.c e5660590 319 uio.c fe44d524 1547 util.c f17978be 824 -wref.c 1d4e4539 4108 -wrtfmt.c f41b0c38 8075 +wref.c fbed7e10 4507 +wrtfmt.c 7a73318 8090 wsfe.c 250d1ef 1658 -wsle.c 2f94457 611 -wsne.c fd7a0e2f 438 -xwsne.c 7ac1479 1080 +wsle.c f74ea563 684 +wsne.c ea4dac25 412 +xwsne.c 16641f3c 1135 diff --git a/lib/libI77/lio.h b/lib/libI77/lio.h index 5af9fc4..0123172 100644 --- a/lib/libI77/lio.h +++ b/lib/libI77/lio.h @@ -23,6 +23,7 @@ #define TYLOGICAL1 12 #define TYLOGICAL2 13 #ifdef Allow_TYQUAD +#undef TYQUAD #define TYQUAD 14 #endif diff --git a/lib/libI77/lread.c b/lib/libI77/lread.c index 2da52d8..c14fd5b 100644 --- a/lib/libI77/lread.c +++ b/lib/libI77/lread.c @@ -6,6 +6,12 @@ #include "fp.h" extern char *f__fmtbuf; + +#ifdef Allow_TYQUAD +static longint f__llx; +static int quad_read; +#endif + #ifdef KR_headers extern double atof(); extern char *malloc(), *realloc(); @@ -102,6 +108,9 @@ l_R(int poststar) return(0); f__lcount = 1; } +#ifdef Allow_TYQUAD + f__llx = 0; +#endif f__ltype = 0; exp = 0; havestar = 0; @@ -184,6 +193,22 @@ bad: else sp[1] = 0; f__lx = atof(s); +#ifdef Allow_TYQUAD + if (quad_read && (se = sp - sp1 + exp) > 14 && se < 20) { + /* Assuming 64-bit longint and 32-bit long. */ + if (exp < 0) + sp += exp; + if (sp1 <= sp) { + f__llx = *sp1 - '0'; + while(++sp1 <= sp) + f__llx = 10*f__llx + (*sp1 - '0'); + } + while(--exp >= 0) + f__llx *= 10; + if (*s == '-') + f__llx = -f__llx; + } +#endif } else f__lx = 0.; @@ -280,6 +305,9 @@ l_C(Void) if(ch!=')') errfl(f__elist->cierr,112,"no )"); f__ly = f__lx; f__lx = lz; +#ifdef Allow_TYQUAD + f__llx = 0; +#endif nml_read = nml_save; return(0); } @@ -456,6 +484,8 @@ c_le(a) cilist *a; c_le(cilist *a) #endif { + if(!f__init) + f_init(); f__fmtbuf="list io"; if(a->ciunit>=MXUNIT || a->ciunit<0) err(a->cierr,101,"stler"); @@ -512,13 +542,19 @@ l_read(ftnint *number, char *ptr, ftnlen len, ftnint type) case TYINT1: case TYSHORT: case TYLONG: -#ifdef TYQUAD - case TYQUAD: -#endif case TYREAL: case TYDREAL: ERR(l_R(0)); break; +#ifdef TYQUAD + case TYQUAD: + quad_read = 1; + n = l_R(0); + quad_read = 0; + if (n) + return n; + break; +#endif case TYCOMPLEX: case TYDCOMPLEX: ERR(l_C()); @@ -560,9 +596,10 @@ l_read(ftnint *number, char *ptr, ftnlen len, ftnint type) case TYLONG: Ptr->flint=f__lx; break; -#ifdef TYQUAD +#ifdef Allow_TYQUAD case TYQUAD: - Ptr->fllongint = f__lx; + if (!(Ptr->fllongint = f__llx)) + Ptr->fllongint = f__lx; break; #endif case TYREAL: @@ -602,7 +639,6 @@ integer s_rsle(cilist *a) { int n; - if(!f__init) f_init(); if(n=c_le(a)) return(n); f__reading=1; f__external=1; @@ -613,6 +649,8 @@ integer s_rsle(cilist *a) l_eof = 0; if(f__curunit->uwrt && f__nowreading(f__curunit)) err(a->cierr,errno,"read start"); + if(f__curunit->uend) + err(f__elist->ciend,(EOF),"read start"); l_getc = t_getc; l_ungetc = un_getc; f__doend = xrd_SL; diff --git a/lib/libI77/lwrite.c b/lib/libI77/lwrite.c index ca038cc..5da7dfb 100644 --- a/lib/libI77/lwrite.c +++ b/lib/libI77/lwrite.c @@ -2,7 +2,9 @@ #include "fio.h" #include "fmt.h" #include "lio.h" + ftnint L_len; +int f__Aquote; static VOID donewrec(Void) @@ -23,20 +25,22 @@ t_putc(int c) } static VOID #ifdef KR_headers -lwrt_I(n) long n; +lwrt_I(n) longint n; #else -lwrt_I(long n) +lwrt_I(longint n) #endif { - char buf[LINTW],*p; -#ifdef USE_STRLEN - (void) sprintf(buf," %ld",n); - if(f__recpos+strlen(buf)>=L_len) -#else - if(f__recpos + sprintf(buf," %ld",n) >= L_len) -#endif + char *p; + int ndigit, sign; + + p = f__icvt(n, &ndigit, &sign, 10); + if(f__recpos + ndigit >= L_len) donewrec(); - for(p=buf;*p;PUT(*p++)); + PUT(' '); + if (sign) + PUT('-'); + while(*p) + PUT(*p++); } static VOID #ifdef KR_headers @@ -56,14 +60,42 @@ lwrt_A(p,len) char *p; ftnlen len; lwrt_A(char *p, ftnlen len) #endif { - int i; - if(f__recpos+len>=L_len) + int a; + char *p1, *pe; + + a = 0; + pe = p + len; + if (f__Aquote) { + a = 3; + if (len > 1 && p[len-1] == ' ') { + while(--len > 1 && p[len-1] == ' '); + pe = p + len; + } + p1 = p; + while(p1 < pe) + if (*p1++ == '\'') + a++; + } + if(f__recpos+len+a >= L_len) donewrec(); + if (a #ifndef OMIT_BLANK_CC - if (!f__recpos) - PUT(' '); + || !f__recpos #endif - for(i=0;i<len;i++) PUT(*p++); + ) + PUT(' '); + if (a) { + PUT('\''); + while(p < pe) { + if (*p == '\'') + PUT('\''); + PUT(*p++); + } + PUT('\''); + } + else + while(p < pe) + PUT(*p++); } static int @@ -107,10 +139,12 @@ l_g(char *buf, double n) } sprintf(b, LGFMT, n); switch(*b) { +#ifndef WANT_LEAD_0 case '0': while(b[0] = b[1]) b++; break; +#endif case 'i': case 'I': /* Infinity */ @@ -213,7 +247,7 @@ l_write(ftnint *number, char *ptr, ftnlen len, ftnint type) { #define Ptr ((flex *)ptr) int i; - long x; + longint x; double y,z; real *xx; doublereal *yy; @@ -228,7 +262,7 @@ l_write(ftnint *number, char *ptr, ftnlen len, ftnint type) case TYSHORT: x=Ptr->flshort; goto xint; -#ifdef TYQUAD +#ifdef Allow_TYQUAD case TYQUAD: x = Ptr->fllongint; goto xint; diff --git a/lib/libI77/open.c b/lib/libI77/open.c index 15d887a..75386b9 100644 --- a/lib/libI77/open.c +++ b/lib/libI77/open.c @@ -83,6 +83,8 @@ integer f_open(olist *a) #endif if(a->ounit>=MXUNIT || a->ounit<0) err(a->oerr,101,"open") + if (!f__init) + f_init(); f__curunit = b = &f__units[a->ounit]; if(b->ufd) { if(a->ofnm==0) diff --git a/lib/libI77/rdfmt.c b/lib/libI77/rdfmt.c index 9fd8545..eef745b 100644 --- a/lib/libI77/rdfmt.c +++ b/lib/libI77/rdfmt.c @@ -97,7 +97,7 @@ rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base; #else rd_I(Uint *n, int w, ftnlen len, register int base) #endif -{ long x; +{ longint x; int sign,ch; char s[84], *ps; ps=s; x=0; diff --git a/lib/libI77/rsfe.c b/lib/libI77/rsfe.c index 5d29bee..5ff0a33 100644 --- a/lib/libI77/rsfe.c +++ b/lib/libI77/rsfe.c @@ -6,7 +6,11 @@ xrd_SL(Void) { int ch; if(!f__curunit->uend) - while((ch=getc(f__cf))!='\n' && ch!=EOF); + while((ch=getc(f__cf))!='\n') + if (ch == EOF) { + f__curunit->uend = 1; + break; + } f__cursor=f__recpos=0; return(1); } @@ -69,5 +73,7 @@ integer s_rsfe(cilist *a) /* start */ f__cplus=0; if(f__curunit->uwrt && f__nowreading(f__curunit)) err(a->cierr,errno,"read start"); + if(f__curunit->uend) + err(f__elist->ciend,(EOF),"read start"); return(0); } diff --git a/lib/libI77/rsne.c b/lib/libI77/rsne.c index 66a1c02..ad7ad26 100644 --- a/lib/libI77/rsne.c +++ b/lib/libI77/rsne.c @@ -31,6 +31,7 @@ static hashtab *nl_cache; static n_nlcache; static hashentry **zot; + static int colonseen; extern ftnlen f__typesize[]; extern flag f__lquit; @@ -247,6 +248,7 @@ getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1) if (!x3) return 123; x2 /= x3; + colonseen = 1; } if (x2 < 0 || x2 >= extent) return 123; @@ -294,7 +296,7 @@ x_rsne(a) cilist *a; x_rsne(cilist *a) #endif { - int ch, got1, k, n, nd, quote; + int ch, got1, k, n, nd, quote, readall; Namelist *nl; static char where[] = "namelist read"; char buf[64]; @@ -316,6 +318,7 @@ x_rsne(cilist *a) top: for(;;) switch(GETC(ch)) { case EOF: + eof: err(a->ciend,(EOF),where0); case '&': case '$': @@ -328,7 +331,13 @@ x_rsne(cilist *a) default: if (ch <= ' ' && ch >= 0) continue; +#ifndef No_Namelist_Comments + while(GETC(ch) != '\n') + if (ch == EOF) + goto eof; +#else errfl(a->cierr, 115, where0); +#endif } have_amp: if (ch = getname(buf,sizeof(buf))) @@ -404,7 +413,7 @@ x_rsne(cilist *a) else size = f__typesize[type]; ivae = size; - iva = 0; + iva = readall = 0; if (ch == '(' /*)*/ ) { dn = dimens; if (!(dims = v->dims)) { @@ -426,6 +435,7 @@ x_rsne(cilist *a) nd = (int)dims[0]; nomax = span = dims[1]; ivae = iva + size*nomax; + colonseen = 0; if (k = getdimen(&ch, dn, size, nomax, &b)) errfl(a->cierr, k, where); no = dn->extent; @@ -447,6 +457,7 @@ x_rsne(cilist *a) } if (ch != ')') errfl(a->cierr, 115, where); + readall = 1 - colonseen; b -= b0; if (b < 0 || b >= nomax) errfl(a->cierr, 125, where); @@ -470,6 +481,8 @@ x_rsne(cilist *a) if (b1 < b0) goto delta_adj; } + if (readall) + goto delta_adj; for(; dn0 < dn; dn0++) { if (dn0->extent != *dims++ || dn0->stride != 1) break; @@ -513,8 +526,34 @@ x_rsne(cilist *a) return k; if (f__lquit == 1) return 0; + if (readall) { + iva += dn0->delta; + if (f__lcount > 0) { + no1 = (ivae - iva)/size; + if (no1 > f__lcount) + no1 = f__lcount; + iva += no1 * dn0->delta; + if (k = l_read(&no1, vaddr + iva, + size, type)) + return k; + } + } mustend: - if (GETC(ch) == '/' || ch == '$' || ch == '&') { + GETC(ch); + if (readall) + if (iva >= ivae) + readall = 0; + else for(;;) { + switch(ch) { + case ' ': + case '\t': + case '\n': + GETC(ch); + continue; + } + break; + } + if (ch == '/' || ch == '$' || ch == '&') { f__lquit = 1; return 0; } @@ -527,6 +566,8 @@ x_rsne(cilist *a) break; } Ungetc(ch,f__cf); + if (readall && !Alpha[ch & 0xff]) + goto readloop; if ((no -= no1) <= 0) break; for(dn1 = dn0; dn1 <= dn; dn1++) { diff --git a/lib/libI77/sfe.c b/lib/libI77/sfe.c index 6dea23a..eea9078 100644 --- a/lib/libI77/sfe.c +++ b/lib/libI77/sfe.c @@ -28,5 +28,15 @@ c_sfe(cilist *a) /* check */ return(0); } integer e_wsfe(Void) -{ return(e_rsfe()); +{ +#ifdef ALWAYS_FLUSH + int n; + 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 } diff --git a/lib/libI77/sue.c b/lib/libI77/sue.c index 21f30bf..b1b8bc3 100644 --- a/lib/libI77/sue.c +++ b/lib/libI77/sue.c @@ -65,11 +65,15 @@ integer s_wsue(cilist *a) } integer e_wsue(Void) { long loc; - (void) fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); + fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); +#ifdef ALWAYS_FLUSH + if (fflush(f__cf)) + err(f__elist->cierr, errno, "write end"); +#endif loc=ftell(f__cf); - (void) fseek(f__cf,f__recloc,SEEK_SET); - (void) fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); - (void) fseek(f__cf,loc,SEEK_SET); + fseek(f__cf,f__recloc,SEEK_SET); + fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); + fseek(f__cf,loc,SEEK_SET); return(0); } integer e_rsue(Void) diff --git a/lib/libI77/wref.c b/lib/libI77/wref.c index 1ef2c47..eda9a8f 100644 --- a/lib/libI77/wref.c +++ b/lib/libI77/wref.c @@ -23,6 +23,9 @@ wrt_E(ufloat *p, int w, int d, int e, ftnlen len) char buf[FMAX+EXPMAXDIGS+4], *s, *se; int d1, delta, e1, i, sign, signspace; double dd; +#ifdef WANT_LEAD_0 + int insert0 = 0; +#endif #ifndef VAX int e0 = e; #endif @@ -53,6 +56,13 @@ wrt_E(ufloat *p, int w, int d, int e, ftnlen len) } delta = w - (2 /* for the . and the d adjustment above */ + 2 /* for the E+ */ + signspace + d + e); +#ifdef WANT_LEAD_0 + if (f__scale <= 0 && delta > 0) { + delta--; + insert0 = 1; + } + else +#endif if (delta < 0) { nogood: while(--w >= 0) @@ -91,8 +101,13 @@ nogood: se = buf + d + 3; #ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */ if (f__scale != 1 && dd) -#endif sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); +#else + if (dd) + sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); + else + strcpy(se, "+00"); +#endif s = ++se; if (e < 2) { if (*s != '0') @@ -139,6 +154,10 @@ nogood: s = buf; i = f__scale; if (f__scale <= 0) { +#ifdef WANT_LEAD_0 + if (insert0) + PUT('0'); +#endif PUT('.'); for(; i < 0; ++i) PUT('0'); @@ -211,8 +230,10 @@ wrt_F(ufloat *p, int w, int d, ftnlen len) n = sprintf(b = buf, "%#.*f", d, x) + d1; #endif +#ifndef WANT_LEAD_0 if (buf[0] == '0' && d) { ++b; --n; } +#endif if (sign) { /* check for all zeros */ for(s = b;;) { @@ -229,9 +250,16 @@ wrt_F(ufloat *p, int w, int d, ftnlen len) if (sign || f__cplus) ++n; if (n > w) { - while(--w >= 0) - PUT('*'); - return 0; +#ifdef WANT_LEAD_0 + if (buf[0] == '0' && --n == w) + ++b; + else +#endif + { + while(--w >= 0) + PUT('*'); + return 0; + } } for(w -= n; --w >= 0; ) PUT(' '); diff --git a/lib/libI77/wrtfmt.c b/lib/libI77/wrtfmt.c index b08b7a8..545dcb9 100644 --- a/lib/libI77/wrtfmt.c +++ b/lib/libI77/wrtfmt.c @@ -1,12 +1,8 @@ #include "f2c.h" #include "fio.h" #include "fmt.h" + extern int f__cursor; -#ifdef KR_headers -extern char *f__icvt(); -#else -extern char *f__icvt(long, int*, int*, int); -#endif int f__hiwater; icilist *f__svic; char *f__icptr; @@ -151,7 +147,7 @@ wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base; wrt_I(Uint *n, int w, ftnlen len, register int base) #endif { int ndigit,sign,spare,i; - long x; + longint x; char *ans; if(len==sizeof(integer)) x=n->il; else if(len == sizeof(char)) x = n->ic; @@ -179,10 +175,13 @@ wrt_IM(n,w,m,len,base) Uint *n; ftnlen len; int base; wrt_IM(Uint *n, int w, int m, ftnlen len, int base) #endif { int ndigit,sign,spare,i,xsign; - long x; + longint x; char *ans; if(sizeof(integer)==len) x=n->il; else if(len == sizeof(char)) x = n->ic; +#ifdef Allow_TYQUAD + else if (len == sizeof(longint)) x = n->ili; +#endif else x=n->is; ans=f__icvt(x,&ndigit,&sign, base); if(sign || f__cplus) xsign=1; @@ -288,6 +287,9 @@ 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) diff --git a/lib/libI77/wsle.c b/lib/libI77/wsle.c index 470191b..44b6972 100644 --- a/lib/libI77/wsle.c +++ b/lib/libI77/wsle.c @@ -10,7 +10,6 @@ integer s_wsle(cilist *a) #endif { int n; - if(!f__init) f_init(); if(n=c_le(a)) return(n); f__reading=0; f__external=1; @@ -28,9 +27,14 @@ integer e_wsle(Void) { t_putc('\n'); f__recpos=0; +#ifdef ALWAYS_FLUSH + if (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); } diff --git a/lib/libI77/wsne.c b/lib/libI77/wsne.c index c3f0623..0febd52 100644 --- a/lib/libI77/wsne.c +++ b/lib/libI77/wsne.c @@ -11,8 +11,6 @@ s_wsne(cilist *a) { int n; - if(!f__init) - f_init(); if(n=c_le(a)) return(n); f__reading=0; diff --git a/lib/libI77/xwsne.c b/lib/libI77/xwsne.c index 49e6f0e..41c929b 100644 --- a/lib/libI77/xwsne.c +++ b/lib/libI77/xwsne.c @@ -3,6 +3,8 @@ #include "lio.h" #include "fmt.h" +extern int f__Aquote; + static VOID nl_donewrec(Void) { @@ -33,6 +35,7 @@ x_wsne(cilist *a) for(s = nl->name; *s; s++) PUT(*s); PUT(' '); + f__Aquote = 1; vd = nl->vars; vde = vd + nl->nvars; while(vd < vde) { @@ -64,5 +67,6 @@ x_wsne(cilist *a) else if (f__recpos+1 >= L_len) nl_donewrec(); } + f__Aquote = 0; PUT('/'); } diff --git a/lib/libf2c/Makefile b/lib/libf2c/Makefile index 63ad808..1777f5c 100644 --- a/lib/libf2c/Makefile +++ b/lib/libf2c/Makefile @@ -5,7 +5,7 @@ CFLAGS+= -DIEEE_drem -DNON_ANSI_RW_MODES -DNON_UNIX_STDIO MISC = Version.c main.c s_rnge.c abort_.c getarg_.c iargc_.c getenv_.c\ signal_.c s_stop.c s_paus.c system_.c cabs.c\ - derf_.c derfc_.c erf_.c erfc_.c sig_die.c + derf_.c derfc_.c erf_.c erfc_.c sig_die.c F77_aloc.c exit.c POW = pow_ci.c pow_dd.c pow_di.c pow_hh.c pow_ii.c pow_ri.c pow_zi.c pow_zz.c CX = c_abs.c c_cos.c c_div.c c_exp.c c_log.c c_sin.c c_sqrt.c DCX = z_cos.c z_div.c z_exp.c z_log.c z_sin.c z_sqrt.c |