freebsd-skq/contrib/libf2c/libI77/lread.c

846 lines
15 KiB
C

#include "config.h"
#include <ctype.h>
#include "f2c.h"
#include "fio.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;
extern int f__fmtlen;
#ifdef Allow_TYQUAD
static longint f__llx;
#endif
#undef abs
#undef min
#undef max
#include <stdlib.h>
#include "fmt.h"
#include "lio.h"
#include "fp.h"
int (*f__lioproc) (ftnint *, char *, ftnlen, ftnint), (*l_getc) (void),
(*l_ungetc) (int, FILE *);
int l_eof;
#define isblnk(x) (f__ltab[x+1]&B)
#define issep(x) (f__ltab[x+1]&SX)
#define isapos(x) (f__ltab[x+1]&AX)
#define isexp(x) (f__ltab[x+1]&EX)
#define issign(x) (f__ltab[x+1]&SG)
#define iswhit(x) (f__ltab[x+1]&WH)
#define SX 1
#define B 2
#define AX 4
#define EX 8
#define SG 16
#define WH 32
char f__ltab[128 + 1] = { /* offset one for EOF */
0,
0, 0, AX, 0, 0, 0, 0, 0, 0, WH | B, SX | WH, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
SX | B | WH, 0, AX, 0, 0, 0, 0, AX, 0, 0, 0, SG, SX, SG, 0, SX,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, EX, EX, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
AX, 0, 0, 0, EX, EX, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
};
#ifdef ungetc
static int
un_getc (int x, FILE * f__cf)
{
return ungetc (x, f__cf);
}
#else
#define un_getc ungetc
extern int ungetc (int, FILE *); /* for systems with a buggy stdio.h */
#endif
int
t_getc (void)
{
int ch;
if (f__curunit->uend)
return (EOF);
if ((ch = getc (f__cf)) != EOF)
return (ch);
if (feof (f__cf))
f__curunit->uend = l_eof = 1;
return (EOF);
}
integer
e_rsle (void)
{
int ch;
f__init = 1;
if (f__curunit->uend)
return (0);
while ((ch = t_getc ()) != '\n')
if (ch == EOF)
{
if (feof (f__cf))
f__curunit->uend = l_eof = 1;
return EOF;
}
return (0);
}
flag f__lquit;
int f__lcount, f__ltype, nml_read;
char *f__lchar;
double f__lx, f__ly;
#define ERR(x) if((n=(x))) {f__init &= ~2; return(n);}
#define GETC(x) (x=(*l_getc)())
#define Ungetc(x,y) (*l_ungetc)(x,y)
static int
l_R (int poststar, int reqint)
{
char s[FMAX + EXPMAXDIGS + 4];
register int ch;
register char *sp, *spe, *sp1;
long e, exp;
int havenum, havestar, se;
if (!poststar)
{
if (f__lcount > 0)
return (0);
f__lcount = 1;
}
#ifdef Allow_TYQUAD
f__llx = 0;
#endif
f__ltype = 0;
exp = 0;
havestar = 0;
retry:
sp1 = sp = s;
spe = sp + FMAX;
havenum = 0;
switch (GETC (ch))
{
case '-':
*sp++ = ch;
sp1++;
spe++;
case '+':
GETC (ch);
}
while (ch == '0')
{
++havenum;
GETC (ch);
}
while (isdigit (ch))
{
if (sp < spe)
*sp++ = ch;
else
++exp;
GETC (ch);
}
if (ch == '*' && !poststar)
{
if (sp == sp1 || exp || *s == '-')
{
errfl (f__elist->cierr, 112, "bad repetition count");
}
poststar = havestar = 1;
*sp = 0;
f__lcount = atoi (s);
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')
{
++havenum;
--exp;
GETC (ch);
}
while (isdigit (ch))
{
if (sp < spe)
{
*sp++ = ch;
--exp;
}
GETC (ch);
}
}
havenum += sp - sp1;
se = 0;
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:
if (ch == '-')
se = 1;
GETC (ch);
}
if (!isdigit (ch))
{
bad:
errfl (f__elist->cierr, 112, "exponent field");
}
e = ch - '0';
while (isdigit (GETC (ch)))
{
e = 10 * e + ch - '0';
if (e > EXPMAX)
goto bad;
}
if (se)
exp -= e;
else
exp += e;
}
(void) Ungetc (ch, f__cf);
if (sp > sp1)
{
++havenum;
while (*--sp == '0')
++exp;
if (exp)
sprintf (sp + 1, "e%ld", exp);
else
sp[1] = 0;
f__lx = atof (s);
#ifdef Allow_TYQUAD
if (reqint & 2 && (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.;
if (havenum)
f__ltype = TYLONG;
else
switch (ch)
{
case ',':
case '/':
break;
default:
if (havestar && (ch == ' ' || ch == '\t' || ch == '\n'))
break;
if (nml_read > 1)
{
f__lquit = 2;
return 0;
}
errfl (f__elist->cierr, 112, "invalid number");
}
return 0;
}
static int
rd_count (register int ch)
{
if (ch < '0' || ch > '9')
return 1;
f__lcount = ch - '0';
while (GETC (ch) >= '0' && ch <= '9')
f__lcount = 10 * f__lcount + ch - '0';
Ungetc (ch, f__cf);
return f__lcount <= 0;
}
static int
l_C (void)
{
int ch, nml_save;
double lz;
if (f__lcount > 0)
return (0);
f__ltype = 0;
GETC (ch);
if (ch != '(')
{
if (nml_read > 1 && (ch < '0' || ch > '9'))
{
Ungetc (ch, f__cf);
f__lquit = 2;
return 0;
}
if (rd_count (ch))
{
if (!f__cf || !feof (f__cf))
errfl (f__elist->cierr, 112, "complex format");
else
err (f__elist->cierr, (EOF), "lread");
}
if (GETC (ch) != '*')
{
if (!f__cf || !feof (f__cf))
errfl (f__elist->cierr, 112, "no star");
else
err (f__elist->cierr, (EOF), "lread");
}
if (GETC (ch) != '(')
{
Ungetc (ch, f__cf);
return (0);
}
}
else
f__lcount = 1;
while (iswhit (GETC (ch)));
Ungetc (ch, f__cf);
nml_save = nml_read;
nml_read = 0;
if ((ch = l_R (1, 0)))
return ch;
if (!f__ltype)
errfl (f__elist->cierr, 112, "no real part");
lz = f__lx;
while (iswhit (GETC (ch)));
if (ch != ',')
{
(void) Ungetc (ch, f__cf);
errfl (f__elist->cierr, 112, "no comma");
}
while (iswhit (GETC (ch)));
(void) Ungetc (ch, f__cf);
if ((ch = l_R (1, 0)))
return ch;
if (!f__ltype)
errfl (f__elist->cierr, 112, "no imaginary part");
while (iswhit (GETC (ch)));
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);
}
static char nmLbuf[256], *nmL_next;
static int (*nmL_getc_save) (void);
static int (*nmL_ungetc_save) (int, FILE *);
static int
nmL_getc (void)
{
int rv;
if ((rv = *nmL_next++))
return rv;
l_getc = nmL_getc_save;
l_ungetc = nmL_ungetc_save;
return (*l_getc) ();
}
static int
nmL_ungetc (int x, FILE * f)
{
f = f; /* banish non-use warning */
return *--nmL_next = x;
}
static int
Lfinish (int ch, int dot, int *rvp)
{
char *s, *se;
static char what[] = "namelist input";
s = nmLbuf + 2;
se = nmLbuf + sizeof (nmLbuf) - 1;
*s++ = ch;
while (!issep (GETC (ch)) && ch != EOF)
{
if (s >= se)
{
nmLbuf_ovfl:
return *rvp = err__fl (f__elist->cierr, 131, what);
}
*s++ = ch;
if (ch != '=')
continue;
if (dot)
return *rvp = err__fl (f__elist->cierr, 112, what);
got_eq:
*s = 0;
nmL_getc_save = l_getc;
l_getc = nmL_getc;
nmL_ungetc_save = l_ungetc;
l_ungetc = nmL_ungetc;
nmLbuf[1] = *(nmL_next = nmLbuf) = ',';
*rvp = f__lcount = 0;
return 1;
}
if (dot)
goto done;
for (;;)
{
if (s >= se)
goto nmLbuf_ovfl;
*s++ = ch;
if (!isblnk (ch))
break;
if (GETC (ch) == EOF)
goto done;
}
if (ch == '=')
goto got_eq;
done:
Ungetc (ch, f__cf);
return 0;
}
static int
l_L (void)
{
int ch, rv, sawdot;
if (f__lcount > 0)
return (0);
f__lcount = 1;
f__ltype = 0;
GETC (ch);
if (isdigit (ch))
{
rd_count (ch);
if (GETC (ch) != '*')
{
if (!f__cf || !feof (f__cf))
errfl (f__elist->cierr, 112, "no star");
else
err (f__elist->cierr, (EOF), "lread");
}
GETC (ch);
}
sawdot = 0;
if (ch == '.')
{
sawdot = 1;
GETC (ch);
}
switch (ch)
{
case 't':
case 'T':
if (nml_read && Lfinish (ch, sawdot, &rv))
return rv;
f__lx = 1;
break;
case 'f':
case 'F':
if (nml_read && Lfinish (ch, sawdot, &rv))
return rv;
f__lx = 0;
break;
default:
if (isblnk (ch) || issep (ch) || ch == EOF)
{
(void) Ungetc (ch, f__cf);
return (0);
}
if (nml_read > 1)
{
Ungetc (ch, f__cf);
f__lquit = 2;
return 0;
}
errfl (f__elist->cierr, 112, "logical");
}
f__ltype = TYLONG;
while (!issep (GETC (ch)) && ch != EOF);
(void) Ungetc (ch, f__cf);
return (0);
}
#define BUFSIZE 128
static int
l_CHAR (void)
{
int ch, size, i;
static char rafail[] = "realloc failure";
char quote, *p;
if (f__lcount > 0)
return (0);
f__ltype = 0;
if (f__lchar != NULL)
free (f__lchar);
size = BUFSIZE;
p = f__lchar = (char *) malloc ((unsigned int) size);
if (f__lchar == NULL)
errfl (f__elist->cierr, 113, "no space");
GETC (ch);
if (isdigit (ch))
{
/* allow Fortran 8x-style unquoted string... */
/* either find a repetition count or the string */
f__lcount = ch - '0';
*p++ = ch;
for (i = 1;;)
{
switch (GETC (ch))
{
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;
goto have_lcount;
case ',':
case ' ':
case '\t':
case '\n':
case '/':
Ungetc (ch, f__cf);
/* no break */
case EOF:
f__lcount = 1;
f__ltype = TYCHAR;
return *p = 0;
}
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 *) realloc (f__lchar,
(unsigned int) (size += BUFSIZE));
if (f__lchar == NULL)
errfl (f__elist->cierr, 113, rafail);
p = f__lchar + i;
}
}
}
else
(void) Ungetc (ch, f__cf);
have_lcount:
if (GETC (ch) == '\'' || ch == '"')
quote = ch;
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;
for (i = 1;;)
{
switch (GETC (ch))
{
case ',':
case ' ':
case '\t':
case '\n':
case '/':
Ungetc (ch, f__cf);
/* no break */
case EOF:
f__ltype = TYCHAR;
return *p = 0;
}
noquote:
*p++ = ch;
if (++i == size)
{
f__lchar = (char *) realloc (f__lchar,
(unsigned int) (size += BUFSIZE));
if (f__lchar == NULL)
errfl (f__elist->cierr, 113, rafail);
p = f__lchar + i;
}
}
}
f__ltype = TYCHAR;
for (i = 0;;)
{
while (GETC (ch) != quote && ch != '\n' && ch != EOF && ++i < size)
*p++ = ch;
if (i == size)
{
newone:
f__lchar = (char *) realloc (f__lchar,
(unsigned int) (size += BUFSIZE));
if (f__lchar == NULL)
errfl (f__elist->cierr, 113, rafail);
p = f__lchar + i - 1;
*p++ = ch;
}
else if (ch == EOF)
return (EOF);
else if (ch == '\n')
{
if (*(p - 1) != '\\')
continue;
i--;
p--;
if (++i < size)
*p++ = ch;
else
goto newone;
}
else if (GETC (ch) == quote)
{
if (++i < size)
*p++ = ch;
else
goto newone;
}
else
{
(void) Ungetc (ch, f__cf);
*p = 0;
return (0);
}
}
}
int
c_le (cilist * a)
{
if (f__init != 1)
f_init ();
f__init = 3;
f__fmtbuf = "list io";
f__curunit = &f__units[a->ciunit];
f__fmtlen = 7;
if (a->ciunit >= MXUNIT || a->ciunit < 0)
err (a->cierr, 101, "stler");
f__scale = f__recpos = 0;
f__elist = a;
if (f__curunit->ufd == NULL && fk_open (SEQ, FMT, a->ciunit))
err (a->cierr, 102, "lio");
f__cf = f__curunit->ufd;
if (!f__curunit->ufmt)
err (a->cierr, 103, "lio");
return (0);
}
int
l_read (ftnint * number, char *ptr, ftnlen len, ftnint type)
{
#define Ptr ((flex *)ptr)
int i, n, ch;
doublereal *yy;
real *xx;
for (i = 0; i < *number; i++)
{
if (f__lquit)
return (0);
if (l_eof)
err (f__elist->ciend, EOF, "list in");
if (f__lcount == 0)
{
f__ltype = 0;
for (;;)
{
GETC (ch);
switch (ch)
{
case EOF:
err (f__elist->ciend, (EOF), "list in");
case ' ':
case '\t':
case '\n':
continue;
case '/':
f__lquit = 1;
goto loopend;
case ',':
f__lcount = 1;
goto loopend;
default:
(void) Ungetc (ch, f__cf);
goto rddata;
}
}
}
rddata:
switch ((int) 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, 0));
break;
#ifdef TYQUAD
case TYQUAD:
n = l_R (0, 2);
if (n)
return n;
break;
#endif
case TYCOMPLEX:
case TYDCOMPLEX:
ERR (l_C ());
break;
case TYLOGICAL1:
case TYLOGICAL2:
case TYLOGICAL:
ERR (l_L ());
break;
case TYCHAR:
ERR (l_CHAR ());
break;
}
while (GETC (ch) == ' ' || ch == '\t');
if (ch != ',' || f__lcount > 1)
Ungetc (ch, f__cf);
loopend:
if (f__lquit)
return (0);
if (f__cf && ferror (f__cf))
{
clearerr (f__cf);
errfl (f__elist->cierr, errno, "list in");
}
if (f__ltype == 0)
goto bump;
switch ((int) type)
{
case TYINT1:
case TYLOGICAL1:
Ptr->flchar = (char) f__lx;
break;
case TYLOGICAL2:
case TYSHORT:
Ptr->flshort = (short) f__lx;
break;
case TYLOGICAL:
case TYLONG:
Ptr->flint = (ftnint) f__lx;
break;
#ifdef Allow_TYQUAD
case TYQUAD:
if (!(Ptr->fllongint = f__llx))
Ptr->fllongint = f__lx;
break;
#endif
case TYREAL:
Ptr->flreal = f__lx;
break;
case TYDREAL:
Ptr->fldouble = f__lx;
break;
case TYCOMPLEX:
xx = (real *) ptr;
*xx++ = f__lx;
*xx = f__ly;
break;
case TYDCOMPLEX:
yy = (doublereal *) ptr;
*yy++ = f__lx;
*yy = f__ly;
break;
case TYCHAR:
b_char (f__lchar, ptr, len);
break;
}
bump:
if (f__lcount > 0)
f__lcount--;
ptr += len;
if (nml_read)
nml_read++;
}
return (0);
#undef Ptr
}
integer
s_rsle (cilist * a)
{
int 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;
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;
return (0);
}