summaryrefslogtreecommitdiffstats
path: root/contrib/libf2c/libI77/lread.c
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/libf2c/libI77/lread.c')
-rw-r--r--contrib/libf2c/libI77/lread.c845
1 files changed, 845 insertions, 0 deletions
diff --git a/contrib/libf2c/libI77/lread.c b/contrib/libf2c/libI77/lread.c
new file mode 100644
index 0000000..b926367
--- /dev/null
+++ b/contrib/libf2c/libI77/lread.c
@@ -0,0 +1,845 @@
+#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);
+}
OpenPOWER on IntegriCloud