mirror of
https://git.hardenedbsd.org/hardenedbsd/HardenedBSD.git
synced 2024-12-21 08:24:10 +01:00
846 lines
15 KiB
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);
|
|
}
|