Commit b93be35b by Dave Love

backspace.c, [...]: Update to Netlib version of 1998-06-18.

1998-06-23  Dave Love  <d.love@dl.ac.uk>
* libI77/backspace.c, libI77/dfe.c, libI77/due.c, libI77/iio.c,
libI77/lread.c, libI77/ sfe.c, libI77/sue.c, libI77/wsfe.c: Update
to Netlib version of 1998-06-18.

From-SVN: r20678
parent d2f8cffa
...@@ -2392,7 +2392,7 @@ Tue Aug 1 09:25:56 EDT 1995 ...@@ -2392,7 +2392,7 @@ Tue Aug 1 09:25:56 EDT 1995
Permit real (or double precision) parameters in dimension expressions. Permit real (or double precision) parameters in dimension expressions.
Mon Aug 7 08:04:00 EDT 1995 Mon Aug 7 08:04:00 EDT 1995
Append "_eqv" rather than just "_" to names that appear in Append "_eqv" rather than just "_" to names that that appear in
EQUIVALENCE statements as well as structs in f2c.h (to avoid a EQUIVALENCE statements as well as structs in f2c.h (to avoid a
conflict when these names also name common blocks). conflict when these names also name common blocks).
...@@ -2902,3 +2902,28 @@ character variables in data statements. ...@@ -2902,3 +2902,28 @@ character variables in data statements.
Sun Apr 5 19:26:50 EDT 1998 Sun Apr 5 19:26:50 EDT 1998
libi77: wsfe.c: make $ format item work: this was lost in the changes libi77: wsfe.c: make $ format item work: this was lost in the changes
of 17 March 1998. of 17 March 1998.
Sat May 16 19:08:51 EDT 1998
Adjust output of ftnlen constants: rather than appending L,
prepend (ftnlen). This should make the resulting C more portable,
e.g., to systems (such as DEC Alpha Unix systems) on which long
may be longer than ftnlen.
Adjust -r so it also casts REAL expressions passed to intrinsic
functions to REAL.
Wed May 27 16:02:35 EDT 1998
libf2c.zip: tweak description of compiling libf2c for INTEGER*8
to accord with makefile.u rather than libF77/makefile.
Thu May 28 22:45:59 EDT 1998
libi77: 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.
libf2c.zip: above, plus tweaks to PC makefiles: for some purposes,
it's still best to compile with -DMSDOS (even for use with NT).
Thu Jun 18 01:22:52 EDT 1998
libi77: lread.c: modified so floating-point numbers (containing
either a decimal point or an exponent field) are treated as errors
when they appear as list input for integer data. Compile lread.c with
-DALLOW_FLOAT_IN_INTEGER_LIST_INPUT to restore the old behavior.
...@@ -11,11 +11,11 @@ integer f_back(alist *a) ...@@ -11,11 +11,11 @@ integer f_back(alist *a)
uiolen n; uiolen n;
FILE *f; FILE *f;
f__curunit = b = &f__units[a->aunit]; /* curunit for error messages */
if (f__init & 2) if (f__init & 2)
f__fatal (131, "I/O recursion"); f__fatal (131, "I/O recursion");
if(a->aunit >= MXUNIT || a->aunit < 0) if(a->aunit >= MXUNIT || a->aunit < 0)
err(a->aerr,101,"backspace"); err(a->aerr,101,"backspace");
f__curunit = b = &f__units[a->aunit]; /* curunit for error messages */
if(b->useek==0) err(a->aerr,106,"backspace"); if(b->useek==0) err(a->aerr,106,"backspace");
if((f = b->ufd) == NULL) { if((f = b->ufd) == NULL) {
fk_open(1, 1, a->aunit); fk_open(1, 1, a->aunit);
......
...@@ -70,9 +70,9 @@ c_dfe(cilist *a) ...@@ -70,9 +70,9 @@ c_dfe(cilist *a)
f__formatted=f__external=1; f__formatted=f__external=1;
f__elist=a; f__elist=a;
f__cursor=f__scale=f__recpos=0; f__cursor=f__scale=f__recpos=0;
f__curunit = &f__units[a->ciunit];
if(a->ciunit>MXUNIT || a->ciunit<0) if(a->ciunit>MXUNIT || a->ciunit<0)
err(a->cierr,101,"startchk"); err(a->cierr,101,"startchk");
f__curunit = &f__units[a->ciunit];
if(f__curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit)) if(f__curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit))
err(a->cierr,104,"dfe"); err(a->cierr,104,"dfe");
f__cf=f__curunit->ufd; f__cf=f__curunit->ufd;
......
...@@ -14,6 +14,8 @@ c_due(cilist *a) ...@@ -14,6 +14,8 @@ c_due(cilist *a)
f__sequential=f__formatted=f__recpos=0; f__sequential=f__formatted=f__recpos=0;
f__external=1; f__external=1;
f__curunit = &f__units[a->ciunit]; f__curunit = &f__units[a->ciunit];
if(a->ciunit>=MXUNIT || a->ciunit<0)
err(a->cierr,101,"startio");
f__elist=a; f__elist=a;
if(f__curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due"); if(f__curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due");
f__cf=f__curunit->ufd; f__cf=f__curunit->ufd;
......
...@@ -52,11 +52,12 @@ c_si(icilist *a) ...@@ -52,11 +52,12 @@ c_si(icilist *a)
f__init |= 2; f__init |= 2;
f__elist = (cilist *)a; f__elist = (cilist *)a;
f__fmtbuf=a->icifmt; f__fmtbuf=a->icifmt;
f__curunit = 0;
f__sequential=f__formatted=1;
f__external=0;
if(pars_f(f__fmtbuf)<0) if(pars_f(f__fmtbuf)<0)
err(a->icierr,100,"startint"); err(a->icierr,100,"startint");
fmt_bg(); fmt_bg();
f__sequential=f__formatted=1;
f__external=0;
f__cblank=f__cplus=f__scale=0; f__cblank=f__cplus=f__scale=0;
f__svic=a; f__svic=a;
f__icnum=f__recpos=0; f__icnum=f__recpos=0;
...@@ -64,7 +65,6 @@ c_si(icilist *a) ...@@ -64,7 +65,6 @@ c_si(icilist *a)
f__hiwater = 0; f__hiwater = 0;
f__icptr = a->iciunit; f__icptr = a->iciunit;
f__icend = f__icptr + a->icirlen*a->icirnum; f__icend = f__icptr + a->icirlen*a->icirnum;
f__curunit = 0;
f__cf = 0; f__cf = 0;
return(0); return(0);
} }
......
...@@ -105,10 +105,11 @@ double f__lx,f__ly; ...@@ -105,10 +105,11 @@ double f__lx,f__ly;
#define GETC(x) (x=(*l_getc)()) #define GETC(x) (x=(*l_getc)())
#define Ungetc(x,y) (*l_ungetc)(x,y) #define Ungetc(x,y) (*l_ungetc)(x,y)
static int
#ifdef KR_headers #ifdef KR_headers
l_R(poststar) int poststar; l_R(poststar, reqint) int poststar, reqint;
#else #else
l_R(int poststar) l_R(int poststar, int reqint)
#endif #endif
{ {
char s[FMAX+EXPMAXDIGS+4]; char s[FMAX+EXPMAXDIGS+4];
...@@ -157,6 +158,10 @@ retry: ...@@ -157,6 +158,10 @@ retry:
goto retry; goto retry;
} }
if (ch == '.') { if (ch == '.') {
#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
if (reqint)
errfl(f__elist->cierr,115,"invalid integer");
#endif
GETC(ch); GETC(ch);
if (sp == sp1) if (sp == sp1)
while(ch == '0') { while(ch == '0') {
...@@ -175,6 +180,10 @@ retry: ...@@ -175,6 +180,10 @@ retry:
if (issign(ch)) if (issign(ch))
goto signonly; goto signonly;
if (havenum && isexp(ch)) { if (havenum && isexp(ch)) {
#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
if (reqint)
errfl(f__elist->cierr,115,"invalid integer");
#endif
GETC(ch); GETC(ch);
if (issign(ch)) { if (issign(ch)) {
signonly: signonly:
...@@ -208,7 +217,7 @@ bad: ...@@ -208,7 +217,7 @@ bad:
sp[1] = 0; sp[1] = 0;
f__lx = atof(s); f__lx = atof(s);
#ifdef Allow_TYQUAD #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. */ /* Assuming 64-bit longint and 32-bit long. */
if (exp < 0) if (exp < 0)
sp += exp; sp += exp;
...@@ -263,6 +272,7 @@ rd_count(register int ch) ...@@ -263,6 +272,7 @@ rd_count(register int ch)
return f__lcount <= 0; return f__lcount <= 0;
} }
static int
l_C(Void) l_C(Void)
{ int ch, nml_save; { int ch, nml_save;
double lz; double lz;
...@@ -299,7 +309,7 @@ l_C(Void) ...@@ -299,7 +309,7 @@ l_C(Void)
Ungetc(ch,f__cf); Ungetc(ch,f__cf);
nml_save = nml_read; nml_save = nml_read;
nml_read = 0; nml_read = 0;
if (ch = l_R(1)) if (ch = l_R(1,0))
return ch; return ch;
if (!f__ltype) if (!f__ltype)
errfl(f__elist->cierr,112,"no real part"); errfl(f__elist->cierr,112,"no real part");
...@@ -311,7 +321,7 @@ l_C(Void) ...@@ -311,7 +321,7 @@ l_C(Void)
} }
while(iswhit(GETC(ch))); while(iswhit(GETC(ch)));
(void) Ungetc(ch,f__cf); (void) Ungetc(ch,f__cf);
if (ch = l_R(1)) if (ch = l_R(1,0))
return ch; return ch;
if (!f__ltype) if (!f__ltype)
errfl(f__elist->cierr,112,"no imaginary part"); errfl(f__elist->cierr,112,"no imaginary part");
...@@ -325,6 +335,8 @@ l_C(Void) ...@@ -325,6 +335,8 @@ l_C(Void)
nml_read = nml_save; nml_read = nml_save;
return(0); return(0);
} }
static int
l_L(Void) l_L(Void)
{ {
int ch; int ch;
...@@ -370,7 +382,10 @@ l_L(Void) ...@@ -370,7 +382,10 @@ l_L(Void)
(void) Ungetc(ch, f__cf); (void) Ungetc(ch, f__cf);
return(0); return(0);
} }
#define BUFSIZE 128 #define BUFSIZE 128
static int
l_CHAR(Void) l_CHAR(Void)
{ int ch,size,i; { int ch,size,i;
static char rafail[] = "realloc failure"; static char rafail[] = "realloc failure";
...@@ -519,12 +534,12 @@ c_le(cilist *a) ...@@ -519,12 +534,12 @@ c_le(cilist *a)
if(f__init != 1) f_init(); if(f__init != 1) f_init();
f__init = 3; f__init = 3;
f__fmtbuf="list io"; f__fmtbuf="list io";
f__curunit = &f__units[a->ciunit];
f__fmtlen=7; f__fmtlen=7;
if(a->ciunit>=MXUNIT || a->ciunit<0) if(a->ciunit>=MXUNIT || a->ciunit<0)
err(a->cierr,101,"stler"); err(a->cierr,101,"stler");
f__scale=f__recpos=0; f__scale=f__recpos=0;
f__elist=a; f__elist=a;
f__curunit = &f__units[a->ciunit];
if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
err(a->cierr,102,"lio"); err(a->cierr,102,"lio");
f__cf=f__curunit->ufd; f__cf=f__curunit->ufd;
...@@ -575,16 +590,19 @@ l_read(ftnint *number, char *ptr, ftnlen len, ftnint type) ...@@ -575,16 +590,19 @@ l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
case TYINT1: case TYINT1:
case TYSHORT: case TYSHORT:
case TYLONG: case TYLONG:
#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
ERR(l_R(0,1));
break;
#endif
case TYREAL: case TYREAL:
case TYDREAL: case TYDREAL:
ERR(l_R(0)); ERR(l_R(0,0));
break; break;
#ifdef TYQUAD #ifdef TYQUAD
case TYQUAD: case TYQUAD:
quad_read = 1; n = l_R(0,2);
n = l_R(0); if (n)
quad_read = 0; return n;
ERR(n);
break; break;
#endif #endif
case TYCOMPLEX: case TYCOMPLEX:
...@@ -667,10 +685,10 @@ integer s_rsle(cilist *a) ...@@ -667,10 +685,10 @@ integer s_rsle(cilist *a)
{ {
int n; int n;
if(n=c_le(a)) return(n);
f__reading=1; f__reading=1;
f__external=1; f__external=1;
f__formatted=1; f__formatted=1;
if(n=c_le(a)) return(n);
f__lioproc = l_read; f__lioproc = l_read;
f__lquit = 0; f__lquit = 0;
f__lcount = 0; f__lcount = 0;
......
...@@ -51,16 +51,15 @@ integer s_rsfe(cilist *a) /* start */ ...@@ -51,16 +51,15 @@ integer s_rsfe(cilist *a) /* start */
{ int n; { int n;
if(f__init != 1) f_init(); if(f__init != 1) f_init();
f__init = 3; f__init = 3;
if(n=c_sfe(a)) return(n);
f__reading=1; f__reading=1;
f__sequential=1; f__sequential=1;
f__formatted=1; f__formatted=1;
f__external=1; f__external=1;
if(n=c_sfe(a)) return(n);
f__elist=a; f__elist=a;
f__cursor=f__recpos=0; f__cursor=f__recpos=0;
f__scale=0; f__scale=0;
f__fmtbuf=a->cifmt; f__fmtbuf=a->cifmt;
f__curunit= &f__units[a->ciunit];
f__cf=f__curunit->ufd; f__cf=f__curunit->ufd;
if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio");
f__getn= x_getc; f__getn= x_getc;
......
...@@ -9,11 +9,11 @@ c_sue(a) cilist *a; ...@@ -9,11 +9,11 @@ c_sue(a) cilist *a;
c_sue(cilist *a) c_sue(cilist *a)
#endif #endif
{ {
if(a->ciunit >= MXUNIT || a->ciunit < 0)
err(a->cierr,101,"startio");
f__external=f__sequential=1; f__external=f__sequential=1;
f__formatted=0; f__formatted=0;
f__curunit = &f__units[a->ciunit]; f__curunit = &f__units[a->ciunit];
if(a->ciunit >= MXUNIT || a->ciunit < 0)
err(a->cierr,101,"startio");
f__elist=a; f__elist=a;
if(f__curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit)) if(f__curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit))
err(a->cierr,114,"sue"); err(a->cierr,114,"sue");
......
...@@ -47,17 +47,16 @@ integer s_wsfe(cilist *a) /*start*/ ...@@ -47,17 +47,16 @@ integer s_wsfe(cilist *a) /*start*/
{ int n; { int n;
if(f__init != 1) f_init(); if(f__init != 1) f_init();
f__init = 3; f__init = 3;
if(n=c_sfe(a)) return(n);
f__reading=0; f__reading=0;
f__sequential=1; f__sequential=1;
f__formatted=1; f__formatted=1;
f__external=1; f__external=1;
if(n=c_sfe(a)) return(n);
f__elist=a; f__elist=a;
f__hiwater = f__cursor=f__recpos=0; f__hiwater = f__cursor=f__recpos=0;
f__nonl = 0; f__nonl = 0;
f__scale=0; f__scale=0;
f__fmtbuf=a->cifmt; f__fmtbuf=a->cifmt;
f__curunit = &f__units[a->ciunit];
f__cf=f__curunit->ufd; f__cf=f__curunit->ufd;
if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio");
f__putn= x_putc; f__putn= x_putc;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment