summaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
authorjoerg <joerg@FreeBSD.org>1999-02-03 17:23:49 +0000
committerjoerg <joerg@FreeBSD.org>1999-02-03 17:23:49 +0000
commit38d2602fc10af68938b30ae204bbdd4ea9fdb506 (patch)
tree2340d0a1cae271336fb29c80c560f5c3b9d2211b /lib
parent4176c26a7a1c550e3ef04ef8c9734bfc83ae9f11 (diff)
downloadFreeBSD-src-38d2602fc10af68938b30ae204bbdd4ea9fdb506.zip
FreeBSD-src-38d2602fc10af68938b30ae204bbdd4ea9fdb506.tar.gz
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>
Diffstat (limited to 'lib')
-rw-r--r--lib/libF77/Notice26
-rw-r--r--lib/libF77/README4
-rw-r--r--lib/libF77/Version.c6
-rw-r--r--lib/libF77/c_div.c24
-rw-r--r--lib/libF77/d_lg10.c6
-rw-r--r--lib/libF77/h_dnnt.c3
-rw-r--r--lib/libF77/h_nint.c3
-rw-r--r--lib/libF77/i_dnnt.c3
-rw-r--r--lib/libF77/i_nint.c3
-rw-r--r--lib/libF77/main.c18
-rw-r--r--lib/libF77/r_lg10.c6
-rw-r--r--lib/libF77/s_paus.c6
-rw-r--r--lib/libF77/signal1.h12
-rw-r--r--lib/libF77/signal_.c12
-rw-r--r--lib/libF77/z_div.c26
-rw-r--r--lib/libI77/Notice26
-rw-r--r--lib/libI77/Version.c50
-rw-r--r--lib/libI77/backspace.c91
-rw-r--r--lib/libI77/close.c9
-rw-r--r--lib/libI77/dfe.c47
-rw-r--r--lib/libI77/due.c4
-rw-r--r--lib/libI77/endfile.c116
-rw-r--r--lib/libI77/err.c78
-rw-r--r--lib/libI77/fio.h13
-rw-r--r--lib/libI77/fmt.c104
-rw-r--r--lib/libI77/fmt.h7
-rw-r--r--lib/libI77/iio.c30
-rw-r--r--lib/libI77/ilnw.c6
-rw-r--r--lib/libI77/inquire.c2
-rw-r--r--lib/libI77/lread.c85
-rw-r--r--lib/libI77/lwrite.c16
-rw-r--r--lib/libI77/open.c227
-rw-r--r--lib/libI77/rawio.h4
-rw-r--r--lib/libI77/rdfmt.c13
-rw-r--r--lib/libI77/rsfe.c3
-rw-r--r--lib/libI77/sfe.c17
-rw-r--r--lib/libI77/sue.c4
-rw-r--r--lib/libI77/util.c2
-rw-r--r--lib/libI77/wref.c15
-rw-r--r--lib/libI77/wrtfmt.c46
-rw-r--r--lib/libI77/wsfe.c59
-rw-r--r--lib/libI77/wsle.c14
-rw-r--r--lib/libI77/wsne.c2
43 files changed, 635 insertions, 613 deletions
diff --git a/lib/libF77/Notice b/lib/libF77/Notice
index 64af9f1..261b719 100644
--- a/lib/libF77/Notice
+++ b/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
-Bellcore or any of their entities not be used in advertising or
-publicity pertaining to distribution of the software without
-specific, written prior permission.
+documentation, and that the names of AT&T, Bell Laboratories,
+Lucent or Bellcore or any of their entities not be used in
+advertising or publicity pertaining to distribution of the
+software without specific, written prior permission.
-AT&T and Bellcore disclaim all warranties with regard to this
-software, including all implied warranties of merchantability
-and fitness. In no event shall AT&T or Bellcore be liable for
-any special, indirect or consequential damages or any damages
-whatsoever resulting from loss of use, data or profits, whether
-in an action of contract, negligence or other tortious action,
-arising out of or in connection with the use or performance of
-this software.
+AT&T, Lucent and Bellcore disclaim all warranties with regard to
+this software, including all implied warranties of
+merchantability and fitness. In no event shall AT&T, Lucent or
+Bellcore be liable for any special, indirect or consequential
+damages or any damages whatsoever resulting from loss of use,
+data or profits, whether in an action of contract, negligence or
+other tortious action, arising out of or in connection with the
+use or performance of this software.
****************************************************************/
diff --git a/lib/libF77/README b/lib/libF77/README
index 7668215..5e532ee 100644
--- a/lib/libF77/README
+++ b/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.
diff --git a/lib/libF77/Version.c b/lib/libF77/Version.c
index eb4fa2d..64de577 100644
--- a/lib/libF77/Version.c
+++ b/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.
*/
diff --git a/lib/libF77/c_div.c b/lib/libF77/c_div.c
index 57139a0..ac96307 100644
--- a/lib/libF77/c_div.c
+++ b/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 ai = a->i, ar = a->r, bi = b->i, br = b->r;
+ double abr, abi, cr;
- 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 ;
- den = bi * (1 + ratio*ratio);
- c->r = (ar*ratio + ai) / den;
- c->i = (ai*ratio - ar) / den;
+ ratio = (double)b->r / b->i ;
+ den = b->i * (1 + ratio*ratio);
+ cr = (a->r*ratio + a->i) / den;
+ c->i = (a->i*ratio - a->r) / den;
}
else
{
- ratio = (double)bi / br ;
- den = br * (1 + ratio*ratio);
- c->r = (ar + ai*ratio) / den;
- c->i = (ai - ar*ratio) / den;
+ ratio = (double)b->i / b->r ;
+ den = b->r * (1 + ratio*ratio);
+ cr = (a->r + a->i*ratio) / den;
+ c->i = (a->i - a->r*ratio) / den;
}
+ c->r = cr;
}
diff --git a/lib/libF77/d_lg10.c b/lib/libF77/d_lg10.c
index 3135881..f03ff00 100644
--- a/lib/libF77/d_lg10.c
+++ b/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) );
}
diff --git a/lib/libF77/h_dnnt.c b/lib/libF77/h_dnnt.c
index 9fbeb5c..6ffae98 100644
--- a/lib/libF77/h_dnnt.c
+++ b/lib/libF77/h_dnnt.c
@@ -9,6 +9,5 @@ shortint h_dnnt(x) doublereal *x;
shortint h_dnnt(doublereal *x)
#endif
{
-return( (*x)>=0 ?
- floor(*x + .5) : -floor(.5 - *x) );
+return (shortint)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x));
}
diff --git a/lib/libF77/h_nint.c b/lib/libF77/h_nint.c
index bf63df1..1cd87df 100644
--- a/lib/libF77/h_nint.c
+++ b/lib/libF77/h_nint.c
@@ -9,6 +9,5 @@ shortint h_nint(x) real *x;
shortint h_nint(real *x)
#endif
{
-return( (*x)>=0 ?
- floor(*x + .5) : -floor(.5 - *x) );
+return (shortint)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x));
}
diff --git a/lib/libF77/i_dnnt.c b/lib/libF77/i_dnnt.c
index 9d46c4b..b5d5006 100644
--- a/lib/libF77/i_dnnt.c
+++ b/lib/libF77/i_dnnt.c
@@ -9,6 +9,5 @@ integer i_dnnt(x) doublereal *x;
integer i_dnnt(doublereal *x)
#endif
{
-return( (*x)>=0 ?
- floor(*x + .5) : -floor(.5 - *x) );
+return (integer)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x));
}
diff --git a/lib/libF77/i_nint.c b/lib/libF77/i_nint.c
index ccde785..676f9b3 100644
--- a/lib/libF77/i_nint.c
+++ b/lib/libF77/i_nint.c
@@ -9,6 +9,5 @@ integer i_nint(x) real *x;
integer i_nint(real *x)
#endif
{
-return( (*x)>=0 ?
- floor(*x + .5) : -floor(.5 - *x) );
+return (integer)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x));
}
diff --git a/lib/libF77/main.c b/lib/libF77/main.c
index d6ff84a..9654805 100644
--- a/lib/libF77/main.c
+++ b/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
diff --git a/lib/libF77/r_lg10.c b/lib/libF77/r_lg10.c
index c40138e..4ea02f4 100644
--- a/lib/libF77/r_lg10.c
+++ b/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) );
}
diff --git a/lib/libF77/s_paus.c b/lib/libF77/s_paus.c
index 2501cb5a..796300b 100644
--- a/lib/libF77/s_paus.c
+++ b/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)
-{ n = n; /* shut up compiler warning */
+waitpause(Sigarg)
+{ Use_Sigarg;
return;
}
diff --git a/lib/libF77/signal1.h b/lib/libF77/signal1.h
index 8800a18..662cae4 100644
--- a/lib/libF77/signal1.h
+++ b/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
diff --git a/lib/libF77/signal_.c b/lib/libF77/signal_.c
index 9b31f5a..9f243d8 100644
--- a/lib/libF77/signal_.c
+++ b/lib/libF77/signal_.c
@@ -1,15 +1,11 @@
#include "f2c.h"
+#include "signal1.h"
+ ftnint
#ifdef KR_headers
-typedef VOID (*sig_pf)();
-extern sig_pf signal();
-#define signal1 signal
-
-ftnint signal_(sigp, proc) integer *sigp; sig_pf proc;
+signal_(sigp, proc) integer *sigp; sig_pf proc;
#else
-#include "signal1.h"
-
-ftnint signal_(integer *sigp, sig_pf proc)
+signal_(integer *sigp, sig_pf proc)
#endif
{
int sig;
diff --git a/lib/libF77/z_div.c b/lib/libF77/z_div.c
index ed7ee66..22153fa 100644
--- a/lib/libF77/z_div.c
+++ b/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 ai = a->i, ar = a->r, bi = b->i, br = b->r;
+ double abr, abi, cr;
- 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 ;
- den = bi * (1 + ratio*ratio);
- c->r = (ar*ratio + ai) / den;
- c->i = (ai*ratio - ar) / den;
+ ratio = b->r / b->i ;
+ den = b->i * (1 + ratio*ratio);
+ cr = (a->r*ratio + a->i) / den;
+ c->i = (a->i*ratio - a->r) / den;
}
else
{
- ratio = bi / br ;
- den = br * (1 + ratio*ratio);
- c->r = (ar + ai*ratio) / den;
- c->i = (ai - ar*ratio) / den;
+ ratio = b->i / b->r ;
+ den = b->r * (1 + ratio*ratio);
+ cr = (a->r + a->i*ratio) / den;
+ c->i = (a->i - a->r*ratio) / den;
}
+ c->r = cr;
}
diff --git a/lib/libI77/Notice b/lib/libI77/Notice
index 8db1d7b..261b719 100644
--- a/lib/libI77/Notice
+++ b/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
-Bellcore or any of their entities not be used in advertising or
-publicity pertaining to distribution of the software without
-specific, written prior permission.
+documentation, and that the names of AT&T, Bell Laboratories,
+Lucent or Bellcore or any of their entities not be used in
+advertising or publicity pertaining to distribution of the
+software without specific, written prior permission.
-AT&T and Bellcore disclaim all warranties with regard to this
-software, including all implied warranties of merchantability
-and fitness. In no event shall AT&T or Bellcore be liable for
-any special, indirect or consequential damages or any damages
-whatsoever resulting from loss of use, data or profits, whether
-in an action of contract, negligence or other tortious action,
-arising out of or in connection with the use or performance of
-this software.
+AT&T, Lucent and Bellcore disclaim all warranties with regard to
+this software, including all implied warranties of
+merchantability and fitness. In no event shall AT&T, Lucent or
+Bellcore be liable for any special, indirect or consequential
+damages or any damages whatsoever resulting from loss of use,
+data or profits, whether in an action of contract, negligence or
+other tortious action, arising out of or in connection with the
+use or performance of this software.
****************************************************************/
diff --git a/lib/libI77/Version.c b/lib/libI77/Version.c
index b73ae67..031c975 100644
--- a/lib/libI77/Version.c
+++ b/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? */
diff --git a/lib/libI77/backspace.c b/lib/libI77/backspace.c
index 3771cd9..c3fa545 100644
--- a/lib/libI77/backspace.c
+++ b/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;
-#ifdef MSDOS
- int j, k;
- long w, z;
-#endif
- long x, y;
- char buf[32];
+ long v, w, x, y, z;
+ uiolen n;
+ FILE *f;
+
+ f__curunit = b = &f__units[a->aunit]; /* curunit for error messages */
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);
- (void) fread((char *)&n,sizeof(int),1,b->ufd);
- (void) fseek(b->ufd,-(long)n-2*sizeof(int),SEEK_CUR);
+ { fseek(f,-(long)sizeof(uiolen),SEEK_CUR);
+ fread((char *)&n,sizeof(uiolen),1,f);
+ fseek(f,-(long)n-2*sizeof(uiolen),SEEK_CUR);
return(0);
}
-#ifdef MSDOS
- w = -1;
-#endif
- for(ndec = 1;; ndec = 0)
- {
- 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; )
- {
- 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;
- }
- if (--k <= 0)
- return 0;
- w = z;
- }
- fseek(b->ufd, w, SEEK_SET);
-#else
- fseek(b->ufd,(long)(i+1-n),SEEK_CUR);
-#endif
- return(0);
+ w = x = ftell(f);
+ z = 0;
+ loop:
+ while(x) {
+ x -= x < 64 ? x : 64;
+ fseek(f,x,SEEK_SET);
+ for(y = x; y < w; y++) {
+ if (getc(f) != '\n')
+ continue;
+ v = ftell(f);
+ if (v == w) {
+ if (z)
+ goto break2;
+ goto loop;
+ }
+ z = v;
+ }
+ err(a->aerr,(EOF),"backspace")
}
-#ifdef MSDOS
break2:
-#endif
- if(x==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);
- }
+ fseek(f, z, SEEK_SET);
+ return 0;
}
diff --git a/lib/libI77/close.c b/lib/libI77/close.c
index 29a7af5..5810059 100644
--- a/lib/libI77/close.c
+++ b/lib/libI77/close.c
@@ -31,11 +31,10 @@ integer f_clos(cllist *a)
b= &f__units[a->cunit];
if(b->ufd==NULL)
goto done;
+ if (b->uscrtch == 1)
+ goto Delete;
if (!a->csta)
- if (b->uscrtch == 1)
- goto Delete;
- else
- goto Keep;
+ goto Keep;
switch(*a->csta) {
default:
Keep:
@@ -51,8 +50,8 @@ integer f_clos(cllist *a)
case 'd':
case 'D':
Delete:
+ fclose(b->ufd);
if(b->ufnm) {
- fclose(b->ufd);
unlink(b->ufnm); /*SYSDEP*/
free(b->ufnm);
}
diff --git a/lib/libI77/dfe.c b/lib/libI77/dfe.c
index 51023d5..6963d5a 100644
--- a/lib/libI77/dfe.c
+++ b/lib/libI77/dfe.c
@@ -31,41 +31,30 @@ y_getc(Void)
}
err(f__elist->cierr,errno,"readingd");
}
-#ifdef KR_headers
-y_putc(c)
-#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);
-}
+
+ static int
y_rev(Void)
-{ /*what about work done?*/
- if(f__curunit->url==1 || f__recpos==f__curunit->url)
- return(0);
- while(f__recpos<f__curunit->url)
- (*f__putn)(' ');
- f__recpos=0;
+{
+ if (f__recpos < f__hiwater)
+ f__recpos = f__hiwater;
+ if (f__curunit->url > 1)
+ while(f__recpos < f__curunit->url)
+ (*f__putn)(' ');
+ 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();
- return(0);
+ en_fio();
+ return 0;
}
integer e_wdfe(Void)
{
diff --git a/lib/libI77/due.c b/lib/libI77/due.c
index 670b0f1..83f4dc0 100644
--- a/lib/libI77/due.c
+++ b/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;
diff --git a/lib/libI77/endfile.c b/lib/libI77/endfile.c
index f5990e3..d28b6c4 100644
--- a/lib/libI77/endfile.c
+++ b/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);
-#ifdef NON_UNIX_STDIO
- { FILE *tf;
- if (tf = fopen(nbuf, f__w_mode[0]))
- fclose(tf);
- }
-#else
- close(creat(nbuf, 0666));
-#endif
+ sprintf(nbuf,"fort.%ld",a->aunit);
+ if (tf = fopen(nbuf, f__w_mode[0]))
+ fclose(tf);
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
- tmpnam(nm);
-#else
- strcpy(nm,"tmp.FXXXXXX");
- mktemp(nm);
-#endif
-#ifdef NON_UNIX_STDIO
- if (!(bf = fopen(b->ufnm, f__r_mode[0]))) {
+ if (!(bf = fopen(b->ufnm, f__r_mode[0]))
+ || !(tf = tmpfile())) {
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)))
- goto bad1;
+ rewind(tf);
if (copy(tf, loc, bf))
goto bad1;
- if (f__w_mode[0] != f__w_mode[b->ufmt]) {
- if (!(bf = freopen(b->ufnm, f__w_mode[b->ufmt|2], bf)))
- goto bad1;
- fseek(bf, loc, SEEK_SET);
+ b->urw = 2;
+#ifdef NON_UNIX_STDIO
+ if (b->ufmt) {
+ 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;
diff --git a/lib/libI77/err.c b/lib/libI77/err.c
index 29747ff..e25d19f 100644
--- a/lib/libI77/err.c
+++ b/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;
- extern char *f__r_mode[];
+ int ufmt, urw;
+ extern char *f__r_mode[], *f__w_mode[];
+ if (x->urw & 1)
+ goto done;
if (!x->ufnm)
goto cantread;
- ufmt = x->ufmt;
- loc=ftell(x->ufd);
- if(freopen(x->ufnm,f__r_mode[ufmt],x->ufd) == NULL) {
+ ufmt = x->url ? 0 : x->ufmt;
+ loc = ftell(x->ufd);
+ 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);
+ errno = 126;
+ return 1;
+ }
}
- x->uwrt=0;
- (void) fseek(x->ufd,loc,SEEK_SET);
- return(0);
+ fseek(x->ufd,loc,SEEK_SET);
+ 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;
-#ifdef NON_UNIX_STDIO
- ufmt |= 2;
-#endif
+ ufmt = x->url ? 0 : x->ufmt;
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)))
-#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
+ freopen(x->ufnm, f__w_mode[ufmt |= 2], x->ufd)))
{
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
diff --git a/lib/libI77/fio.h b/lib/libI77/fio.h
index e8c693b..bb20dd2 100644
--- a/lib/libI77/fio.h
+++ b/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
diff --git a/lib/libI77/fmt.c b/lib/libI77/fmt.c
index 12792fc..364210c 100644
--- a/lib/libI77/fmt.c
+++ b/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->p3=d;
+ p->p2.i[0]=c;
+ p->p2.i[1]=d;
return(f__pc++);
}
#ifdef KR_headers
-char *f_list();
-char *gt_num(s,n) char *s; int *n;
+static char *f_list();
+static char *gt_num(s,n,n1) char *s; int *n, n1;
#else
-char *f_list(char*);
-char *gt_num(char *s, int *n)
+static char *f_list(char*);
+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,20 +217,24 @@ 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=='.')
- { s++;
- s=gt_num(s,&d);
- }
+ if(*s=='.') {
+ if (!(s=gt_num(s+1,&d,0)))
+ 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
- { s++;
- s=gt_num(s,&e);
+ else {
+ if (!(s=gt_num(s+1,&e,0)))
+ goto bad;
(void) op_gen(x==1?EE:GE,w,d,e);
- }
+ }
break;
case 'O':
case 'o':
@@ -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,25 +268,27 @@ 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=='.')
- { s++;
- s=gt_num(s,&d);
- }
+ if(*s=='.') {
+ if (!(s=gt_num(s+1,&d,0)))
+ goto bad;
+ }
else d=0;
(void) op_gen(F,w,d,0);
break;
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=='.')
- { s++;
- s=gt_num(s,&d);
- }
+ if(*s=='.') {
+ if (!(s=gt_num(s+1,&d,0)))
+ goto bad;
+ }
else d=0;
(void) op_gen(D,w,d,0);
break;
@@ -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++;
- s=gt_num(s,&d);
+ if (!(s=gt_num(s+1,&d,0)))
+ 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
diff --git a/lib/libI77/fmt.h b/lib/libI77/fmt.h
index 509746e..19065a2 100644
--- a/lib/libI77/fmt.h
+++ b/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;
diff --git a/lib/libI77/iio.c b/lib/libI77/iio.c
index 4c8eb9d..58b2a75 100644
--- a/lib/libI77/iio.c
+++ b/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__recpos++ < f__svic->icirlen)
+ if (f__icptr < f__icend && 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;
- n = en_fio();
+{ int 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)
- return(n);
+ if(f__svic->icirnum != 1
+ && (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;
}
diff --git a/lib/libI77/ilnw.c b/lib/libI77/ilnw.c
index b415686..aff38315 100644
--- a/lib/libI77/ilnw.c
+++ b/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
diff --git a/lib/libI77/inquire.c b/lib/libI77/inquire.c
index ec98b22..2949165 100644
--- a/lib/libI77/inquire.c
+++ b/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)
diff --git a/lib/libI77/lread.c b/lib/libI77/lread.c
index 76d84f7..6f537a7 100644
--- a/lib/libI77/lread.c
+++ b/lib/libI77/lread.c
@@ -1,15 +1,15 @@
#include "f2c.h"
#include "fio.h"
-#include "fmt.h"
-#include "lio.h"
-#include "ctype.h"
-#include "fp.h"
+
+/* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */
+/* marks in namelist input a la the Fortran 8X Draft published in */
+/* 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 @@ retry:
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 @@ retry:
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 @@ bad:
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)
- { (void) Ungetc(ch,f__cf);
- return(0);
- }
+ else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) {
+ Ungetc(ch,f__cf);
+ 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);
- quad_read = 0;
+ n = l_R(0,2);
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;
diff --git a/lib/libI77/lwrite.c b/lib/libI77/lwrite.c
index 5da7dfb..bf209f4 100644
--- a/lib/libI77/lwrite.c
+++ b/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);
}
diff --git a/lib/libI77/open.c b/lib/libI77/open.c
index 75386b9..4ef58af 100644
--- a/lib/libI77/open.c
+++ b/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
- int i, j;
+ unsigned int len;
+ char *nbuf, *s, *t, *te;
- i = open(s,O_RDONLY);
- if (i == -1)
- return 0;
- j = isatty(i);
- close(i);
- return j;
+ if (f__buf == f__buf0)
+ f__buflen = 1024;
+ while(f__buflen <= n)
+ f__buflen <<= 1;
+ len = (unsigned int)f__buflen;
+ if (len != f__buflen || !(nbuf = (char*)malloc(len)))
+ f__fatal(113, "malloc failure");
+ s = nbuf;
+ t = f__buf;
+ te = t + c;
+ while(t < te)
+ *s++ = *t++;
+ if (f__buf != f__buf0)
+ free(f__buf);
+ f__buf = nbuf;
+ }
+
+ int
+#ifdef KR_headers
+f__putbuf(c) int c;
#else
- struct stat x;
+f__putbuf(int c)
+#endif
+{
+ char *s, *se;
+ int n;
- if(stat(s, &x) == -1) return(0);
-#ifdef S_IFMT
- switch(x.st_mode&S_IFMT) {
- case S_IFREG:
- case S_IFDIR:
- return(0);
+ 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
-#ifdef S_ISREG
- /* POSIX version */
- if(S_ISREG(x.st_mode) || S_ISDIR(x.st_mode))
- return(0);
- else
-#else
- Help! How does stat work on this system?
-#endif
+x_putc(int c)
#endif
- return(1);
+{
+ 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
-}
+{
+ 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
- if(access(buf,0))
+#ifdef NON_POSIX_STDIO
+ 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
- tmpnam(buf);
-#else
+#ifdef NON_ANSI_STDIO
(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
- if(!access(buf,0))
+#ifdef NON_POSIX_STDIO
+ 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;
- b->uwrt = 0;
-#ifdef NON_UNIX_STDIO
- if ((s = a->oacc) && (*s == 'd' || *s == 'D'))
+ if ((s = a->oacc) && b->url)
ufmt = 0;
-#endif
- if(f__isdev(buf))
- { b->ufd = fopen(buf,f__r_mode[ufmt]);
- if(b->ufd==NULL) err(a->oerr,errno,buf)
- }
- 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;
- 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");
+ if(!(tf = fopen(buf, f__w_mode[ufmt|2]))) {
+ if (tf = fopen(buf, f__r_mode[ufmt]))
+ b->urw = 1;
+ else if (tf = fopen(buf, f__w_mode[ufmt])) {
+ b->uwrt = 1;
+ b->urw = 2;
}
- }
- b->useek=f__canseek(b->ufd);
+ else
+ err(a->oerr, errno, "open");
+ }
+ b->useek = f__canseek(b->ufd = tf);
#ifndef NON_UNIX_STDIO
- if((b->uinode=f__inode(buf,&b->udev))==-1)
- err(a->oerr,108,"open")
+ if((b->uinode = f__inode(buf,&b->udev)) == -1)
+ 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
diff --git a/lib/libI77/rawio.h b/lib/libI77/rawio.h
index 4cbd847..fd36a48 100644
--- a/lib/libI77/rawio.h
+++ b/lib/libI77/rawio.h
@@ -1,6 +1,4 @@
-#ifdef KR_headers
-extern FILE *fdopen();
-#else
+#ifndef KR_headers
#ifdef MSDOS
#include "io.h"
#ifndef WATCOM
diff --git a/lib/libI77/rdfmt.c b/lib/libI77/rdfmt.c
index 03b325e..3de3e49 100644
--- a/lib/libI77/rdfmt.c
+++ b/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));
- case H: return(rd_H(p->p1,*(char **)&p->p2));
+ return(rd_POS(p->p2.s));
+ case H: return(rd_H(p->p1,p->p2.s));
case SLASH: return((*f__donewrec)());
case TR:
case X: f__cursor += p->p1;
diff --git a/lib/libI77/rsfe.c b/lib/libI77/rsfe.c
index 41ff257..c6e7f95 100644
--- a/lib/libI77/rsfe.c
+++ b/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;
diff --git a/lib/libI77/sfe.c b/lib/libI77/sfe.c
index eea9078..cade56a 100644
--- a/lib/libI77/sfe.c
+++ b/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;
- n = en_fio();
- f__fmtbuf=NULL;
- if (!n && fflush(f__cf))
- err(f__elist->cierr, errno, "write end");
+ int n = en_fio();
+ f__fmtbuf = NULL;
return n;
-#else
- return(e_rsfe());
-#endif
}
diff --git a/lib/libI77/sue.c b/lib/libI77/sue.c
index b1b8bc3..d2a7c34 100644
--- a/lib/libI77/sue.c
+++ b/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");
diff --git a/lib/libI77/util.c b/lib/libI77/util.c
index 5275499..6468db0 100644
--- a/lib/libI77/util.c
+++ b/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
diff --git a/lib/libI77/wref.c b/lib/libI77/wref.c
index 5e4871d..2f3fce8 100644
--- a/lib/libI77/wref.c
+++ b/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
@@ -117,8 +118,8 @@ nogood:
/* accommodate 3 significant digits in exponent */
if (s[2]) {
#ifdef Pedantic
- if (!e0 && !s[3])
- e1 = 2;/* for(s -= 2, e1 = 2; s[0] = s[1]; s++);
+ if (!e0 && !s[3])
+ 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 */
diff --git a/lib/libI77/wrtfmt.c b/lib/libI77/wrtfmt.c
index f261ec3..477c40f 100644
--- a/lib/libI77/wrtfmt.c
+++ b/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");
-#ifndef NON_UNIX_STDIO
- 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(cursor + f__recpos < 0)
+ err(f__elist->cierr,110,"left off");
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));
- case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2,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.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));
}
}
diff --git a/lib/libI77/wsfe.c b/lib/libI77/wsfe.c
index 7c7f014..a74e2d5 100644
--- a/lib/libI77/wsfe.c
+++ b/lib/libI77/wsfe.c
@@ -4,49 +4,39 @@
#include "fmt.h"
extern int f__hiwater;
-#ifdef KR_headers
-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);
-}
+ int
x_wSL(Void)
{
- (*f__putn)('\n');
- f__recpos=0;
- f__cursor = 0;
- f__hiwater = 0;
- return(1);
+ int n = f__putbuf('\n');
+ f__hiwater = f__recpos = f__cursor = 0;
+ return(n == 0);
}
+
+ static int
xw_end(Void)
{
- if(f__nonl == 0)
- (*f__putn)('\n');
+ int 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;
diff --git a/lib/libI77/wsle.c b/lib/libI77/wsle.c
index 44b6972..4bb862f 100644
--- a/lib/libI77/wsle.c
+++ b/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);
}
diff --git a/lib/libI77/wsne.c b/lib/libI77/wsne.c
index 0febd52..ae3f817 100644
--- a/lib/libI77/wsne.c
+++ b/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))
OpenPOWER on IntegriCloud