6 /* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */
7 /* marks in namelist input a la the Fortran 8X Draft published in */
8 /* the May 1989 issue of Fortran Forum. */
11 extern char *f__fmtbuf;
15 static longint f__llx;
27 int (*f__lioproc) (ftnint *, char *, ftnlen, ftnint), (*l_getc) (void),
28 (*l_ungetc) (int, FILE *);
32 #define isblnk(x) (f__ltab[x+1]&B)
33 #define issep(x) (f__ltab[x+1]&SX)
34 #define isapos(x) (f__ltab[x+1]&AX)
35 #define isexp(x) (f__ltab[x+1]&EX)
36 #define issign(x) (f__ltab[x+1]&SG)
37 #define iswhit(x) (f__ltab[x+1]&WH)
44 char f__ltab[128 + 1] = { /* offset one for EOF */
46 0, 0, AX, 0, 0, 0, 0, 0, 0, WH | B, SX | WH, 0, 0, 0, 0, 0,
47 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
48 SX | B | WH, 0, AX, 0, 0, 0, 0, AX, 0, 0, 0, SG, SX, SG, 0, SX,
49 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
50 0, 0, 0, 0, EX, EX, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
51 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
52 AX, 0, 0, 0, EX, EX, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
53 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
58 un_getc (int x, FILE * f__cf)
60 return ungetc (x, f__cf);
63 #define un_getc ungetc
64 extern int ungetc (int, FILE *); /* for systems with a buggy stdio.h */
73 if ((ch = getc (f__cf)) != EOF)
76 f__curunit->uend = l_eof = 1;
87 while ((ch = t_getc ()) != '\n')
91 f__curunit->uend = l_eof = 1;
98 int f__lcount, f__ltype, nml_read;
101 #define ERR(x) if((n=(x))) {f__init &= ~2; return(n);}
102 #define GETC(x) (x=(*l_getc)())
103 #define Ungetc(x,y) (*l_ungetc)(x,y)
106 l_R (int poststar, int reqint)
108 char s[FMAX + EXPMAXDIGS + 4];
110 register char *sp, *spe, *sp1;
112 int havenum, havestar, se;
153 if (ch == '*' && !poststar)
155 if (sp == sp1 || exp || *s == '-')
157 errfl (f__elist->cierr, 112, "bad repetition count");
159 poststar = havestar = 1;
161 f__lcount = atoi (s);
166 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
168 errfl (f__elist->cierr, 115, "invalid integer");
192 if (havenum && isexp (ch))
194 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
196 errfl (f__elist->cierr, 115, "invalid integer");
209 errfl (f__elist->cierr, 112, "exponent field");
213 while (isdigit (GETC (ch)))
215 e = 10 * e + ch - '0';
224 (void) Ungetc (ch, f__cf);
231 sprintf (sp + 1, "e%ld", exp);
236 if (reqint & 2 && (se = sp - sp1 + exp) > 14 && se < 20)
238 /* Assuming 64-bit longint and 32-bit long. */
245 f__llx = 10 * f__llx + (*sp1 - '0');
265 if (havestar && (ch == ' ' || ch == '\t' || ch == '\n'))
272 errfl (f__elist->cierr, 112, "invalid number");
278 rd_count (register int ch)
280 if (ch < '0' || ch > '9')
282 f__lcount = ch - '0';
283 while (GETC (ch) >= '0' && ch <= '9')
284 f__lcount = 10 * f__lcount + ch - '0';
286 return f__lcount <= 0;
300 if (nml_read > 1 && (ch < '0' || ch > '9'))
308 if (!f__cf || !feof (f__cf))
309 errfl (f__elist->cierr, 112, "complex format");
311 err (f__elist->cierr, (EOF), "lread");
313 if (GETC (ch) != '*')
315 if (!f__cf || !feof (f__cf))
316 errfl (f__elist->cierr, 112, "no star");
318 err (f__elist->cierr, (EOF), "lread");
320 if (GETC (ch) != '(')
328 while (iswhit (GETC (ch)));
332 if ((ch = l_R (1, 0)))
335 errfl (f__elist->cierr, 112, "no real part");
337 while (iswhit (GETC (ch)));
340 (void) Ungetc (ch, f__cf);
341 errfl (f__elist->cierr, 112, "no comma");
343 while (iswhit (GETC (ch)));
344 (void) Ungetc (ch, f__cf);
345 if ((ch = l_R (1, 0)))
348 errfl (f__elist->cierr, 112, "no imaginary part");
349 while (iswhit (GETC (ch)));
351 errfl (f__elist->cierr, 112, "no )");
361 static char nmLbuf[256], *nmL_next;
362 static int (*nmL_getc_save) (void);
363 static int (*nmL_ungetc_save) (int, FILE *);
369 if ((rv = *nmL_next++))
371 l_getc = nmL_getc_save;
372 l_ungetc = nmL_ungetc_save;
377 nmL_ungetc (int x, FILE * f)
379 f = f; /* banish non-use warning */
380 return *--nmL_next = x;
384 Lfinish (int ch, int dot, int *rvp)
387 static char what[] = "namelist input";
390 se = nmLbuf + sizeof (nmLbuf) - 1;
392 while (!issep (GETC (ch)) && ch != EOF)
397 return *rvp = err__fl (f__elist->cierr, 131, what);
403 return *rvp = err__fl (f__elist->cierr, 112, what);
406 nmL_getc_save = l_getc;
408 nmL_ungetc_save = l_ungetc;
409 l_ungetc = nmL_ungetc;
410 nmLbuf[1] = *(nmL_next = nmLbuf) = ',';
411 *rvp = f__lcount = 0;
423 if (GETC (ch) == EOF)
445 if (GETC (ch) != '*')
447 if (!f__cf || !feof (f__cf))
448 errfl (f__elist->cierr, 112, "no star");
450 err (f__elist->cierr, (EOF), "lread");
464 if (nml_read && Lfinish (ch, sawdot, &rv))
470 if (nml_read && Lfinish (ch, sawdot, &rv))
475 if (isblnk (ch) || issep (ch) || ch == EOF)
477 (void) Ungetc (ch, f__cf);
486 errfl (f__elist->cierr, 112, "logical");
489 while (!issep (GETC (ch)) && ch != EOF);
490 (void) Ungetc (ch, f__cf);
500 static char rafail[] = "realloc failure";
505 if (f__lchar != NULL)
508 p = f__lchar = (char *) malloc ((unsigned int) size);
509 if (f__lchar == NULL)
510 errfl (f__elist->cierr, 113, "no space");
515 /* allow Fortran 8x-style unquoted string... */
516 /* either find a repetition count or the string */
517 f__lcount = ch - '0';
527 #ifndef F8X_NML_ELIDE_QUOTES
550 #ifndef F8X_NML_ELIDE_QUOTES
554 errfl (f__elist->cierr, 112,
555 "undelimited character string");
561 f__lcount = 10 * f__lcount + ch - '0';
564 f__lchar = (char *) realloc (f__lchar,
565 (unsigned int) (size += BUFSIZE));
566 if (f__lchar == NULL)
567 errfl (f__elist->cierr, 113, rafail);
573 (void) Ungetc (ch, f__cf);
575 if (GETC (ch) == '\'' || ch == '"')
577 else if (isblnk (ch) || (issep (ch) && ch != '\n') || ch == EOF)
582 #ifndef F8X_NML_ELIDE_QUOTES
583 else if (nml_read > 1)
592 /* Fortran 8x-style unquoted string */
613 f__lchar = (char *) realloc (f__lchar,
614 (unsigned int) (size += BUFSIZE));
615 if (f__lchar == NULL)
616 errfl (f__elist->cierr, 113, rafail);
624 while (GETC (ch) != quote && ch != '\n' && ch != EOF && ++i < size)
629 f__lchar = (char *) realloc (f__lchar,
630 (unsigned int) (size += BUFSIZE));
631 if (f__lchar == NULL)
632 errfl (f__elist->cierr, 113, rafail);
633 p = f__lchar + i - 1;
640 if (*(p - 1) != '\\')
649 else if (GETC (ch) == quote)
658 (void) Ungetc (ch, f__cf);
671 f__fmtbuf = "list io";
672 f__curunit = &f__units[a->ciunit];
674 if (a->ciunit >= MXUNIT || a->ciunit < 0)
675 err (a->cierr, 101, "stler");
676 f__scale = f__recpos = 0;
678 if (f__curunit->ufd == NULL && fk_open (SEQ, FMT, a->ciunit))
679 err (a->cierr, 102, "lio");
680 f__cf = f__curunit->ufd;
681 if (!f__curunit->ufmt)
682 err (a->cierr, 103, "lio");
687 l_read (ftnint * number, char *ptr, ftnlen len, ftnint type)
689 #define Ptr ((flex *)ptr)
693 for (i = 0; i < *number; i++)
698 err (f__elist->ciend, EOF, "list in");
708 err (f__elist->ciend, (EOF), "list in");
720 (void) Ungetc (ch, f__cf);
731 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
759 while (GETC (ch) == ' ' || ch == '\t');
760 if (ch != ',' || f__lcount > 1)
765 if (f__cf && ferror (f__cf))
768 errfl (f__elist->cierr, errno, "list in");
776 Ptr->flchar = (char) f__lx;
780 Ptr->flshort = (short) f__lx;
784 Ptr->flint = (ftnint) f__lx;
788 if (!(Ptr->fllongint = f__llx))
789 Ptr->fllongint = f__lx;
796 Ptr->fldouble = f__lx;
804 yy = (doublereal *) ptr;
809 b_char (f__lchar, ptr, len);
837 if (f__curunit->uwrt && f__nowreading (f__curunit))
838 err (a->cierr, errno, "read start");
839 if (f__curunit->uend)
840 err (f__elist->ciend, (EOF), "read start");