| #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); |
| } |