5 /* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */
6 /* marks in namelist input a la the Fortran 8X Draft published in */
7 /* the May 1989 issue of Fortran Forum. */
10 extern char *f__fmtbuf;
14 static longint f__llx;
20 extern char *malloc(), *realloc();
21 int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)();
34 int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void),
35 (*l_ungetc)(int,FILE*);
40 #define isblnk(x) (f__ltab[x+1]&B)
41 #define issep(x) (f__ltab[x+1]&SX)
42 #define isapos(x) (f__ltab[x+1]&AX)
43 #define isexp(x) (f__ltab[x+1]&EX)
44 #define issign(x) (f__ltab[x+1]&SG)
45 #define iswhit(x) (f__ltab[x+1]&WH)
52 char f__ltab[128+1] = { /* offset one for EOF */
54 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
55 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
56 SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
57 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
58 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
59 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
60 AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
61 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
67 un_getc(x,f__cf) int x; FILE *f__cf;
69 un_getc(int x, FILE *f__cf)
71 { return ungetc(x,f__cf); }
73 #define un_getc ungetc
77 extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */
83 if(f__curunit->uend) return(EOF);
84 if((ch=getc(f__cf))!=EOF) return(ch);
86 f__curunit->uend = l_eof = 1;
93 if(f__curunit->uend) return(0);
94 while((ch=t_getc())!='\n')
97 f__curunit->uend = l_eof = 1;
104 int f__lcount,f__ltype,nml_read;
107 #define ERR(x) if(n=(x)) {f__init &= ~2; return(n);}
108 #define GETC(x) (x=(*l_getc)())
109 #define Ungetc(x,y) (*l_ungetc)(x,y)
113 l_R(poststar, reqint) int poststar, reqint;
115 l_R(int poststar, int reqint)
118 char s[FMAX+EXPMAXDIGS+4];
120 register char *sp, *spe, *sp1;
122 int havenum, havestar, se;
141 case '-': *sp++ = ch; sp1++; spe++;
150 if (sp < spe) *sp++ = ch;
154 if (ch == '*' && !poststar) {
155 if (sp == sp1 || exp || *s == '-') {
156 errfl(f__elist->cierr,112,"bad repetition count");
158 poststar = havestar = 1;
164 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
166 errfl(f__elist->cierr,115,"invalid integer");
177 { *sp++ = ch; --exp; }
185 if (havenum && isexp(ch)) {
186 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
188 errfl(f__elist->cierr,115,"invalid integer");
193 if (ch == '-') se = 1;
198 errfl(f__elist->cierr,112,"exponent field");
202 while(isdigit(GETC(ch))) {
212 (void) Ungetc(ch, f__cf);
218 sprintf(sp+1, "e%ld", exp);
223 if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) {
224 /* Assuming 64-bit longint and 32-bit long. */
230 f__llx = 10*f__llx + (*sp1 - '0');
249 if (havestar && ( ch == ' '
257 errfl(f__elist->cierr,112,"invalid number");
264 rd_count(ch) register int ch;
266 rd_count(register int ch)
269 if (ch < '0' || ch > '9')
271 f__lcount = ch - '0';
272 while(GETC(ch) >= '0' && ch <= '9')
273 f__lcount = 10*f__lcount + ch - '0';
275 return f__lcount <= 0;
282 if(f__lcount>0) return(0);
287 if (nml_read > 1 && (ch < '0' || ch > '9')) {
293 if(!f__cf || !feof(f__cf))
294 errfl(f__elist->cierr,112,"complex format");
296 err(f__elist->cierr,(EOF),"lread");
299 if(!f__cf || !feof(f__cf))
300 errfl(f__elist->cierr,112,"no star");
302 err(f__elist->cierr,(EOF),"lread");
311 while(iswhit(GETC(ch)));
318 errfl(f__elist->cierr,112,"no real part");
320 while(iswhit(GETC(ch)));
322 { (void) Ungetc(ch,f__cf);
323 errfl(f__elist->cierr,112,"no comma");
325 while(iswhit(GETC(ch)));
326 (void) Ungetc(ch,f__cf);
330 errfl(f__elist->cierr,112,"no imaginary part");
331 while(iswhit(GETC(ch)));
332 if(ch!=')') errfl(f__elist->cierr,112,"no )");
346 if(f__lcount>0) return(0);
354 if(!f__cf || !feof(f__cf))
355 errfl(f__elist->cierr,112,"no star");
357 err(f__elist->cierr,(EOF),"lread");
360 if(ch == '.') GETC(ch);
372 if(isblnk(ch) || issep(ch) || ch==EOF)
373 { (void) Ungetc(ch,f__cf);
381 errfl(f__elist->cierr,112,"logical");
384 while(!issep(GETC(ch)) && ch!=EOF);
385 (void) Ungetc(ch, f__cf);
394 static char rafail[] = "realloc failure";
396 if(f__lcount>0) return(0);
398 if(f__lchar!=NULL) free(f__lchar);
400 p=f__lchar = (char *)malloc((unsigned int)size);
402 errfl(f__elist->cierr,113,"no space");
406 /* allow Fortran 8x-style unquoted string... */
407 /* either find a repetition count or the string */
408 f__lcount = ch - '0';
413 if (f__lcount == 0) {
415 #ifndef F8X_NML_ELIDE_QUOTES
437 #ifndef F8X_NML_ELIDE_QUOTES
440 errfl(f__elist->cierr,112,
441 "undelimited character string");
447 f__lcount = 10*f__lcount + ch - '0';
449 f__lchar = (char *)realloc(f__lchar,
450 (unsigned int)(size += BUFSIZE));
452 errfl(f__elist->cierr,113,rafail);
457 else (void) Ungetc(ch,f__cf);
459 if(GETC(ch)=='\'' || ch=='"') quote=ch;
460 else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) {
464 #ifndef F8X_NML_ELIDE_QUOTES
465 else if (nml_read > 1) {
472 /* Fortran 8x-style unquoted string */
490 f__lchar = (char *)realloc(f__lchar,
491 (unsigned int)(size += BUFSIZE));
493 errfl(f__elist->cierr,113,rafail);
500 { while(GETC(ch)!=quote && ch!='\n'
501 && ch!=EOF && ++i<size) *p++ = ch;
505 f__lchar= (char *)realloc(f__lchar,
506 (unsigned int)(size += BUFSIZE));
508 errfl(f__elist->cierr,113,rafail);
512 else if(ch==EOF) return(EOF);
514 { if(*(p-1) != '\\') continue;
517 if(++i<size) *p++ = ch;
520 else if(GETC(ch)==quote)
521 { if(++i<size) *p++ = ch;
525 { (void) Ungetc(ch,f__cf);
537 if(f__init != 1) f_init();
540 f__curunit = &f__units[a->ciunit];
542 if(a->ciunit>=MXUNIT || a->ciunit<0)
543 err(a->cierr,101,"stler");
544 f__scale=f__recpos=0;
546 if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
547 err(a->cierr,102,"lio");
548 f__cf=f__curunit->ufd;
549 if(!f__curunit->ufmt) err(a->cierr,103,"lio");
553 l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
555 l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
558 #define Ptr ((flex *)ptr)
562 for(i=0;i<*number;i++)
564 if(f__lquit) return(0);
566 err(f__elist->ciend, EOF, "list in");
573 err(f__elist->ciend,(EOF),"list in");
585 (void) Ungetc(ch, f__cf);
596 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
624 while (GETC(ch) == ' ' || ch == '\t');
625 if (ch != ',' || f__lcount > 1)
628 if(f__lquit) return(0);
629 if(f__cf && ferror(f__cf)) {
631 errfl(f__elist->cierr,errno,"list in");
633 if(f__ltype==0) goto bump;
638 Ptr->flchar = (char)f__lx;
642 Ptr->flshort = (short)f__lx;
646 Ptr->flint = (ftnint)f__lx;
650 if (!(Ptr->fllongint = f__llx))
651 Ptr->fllongint = f__lx;
666 yy=(doublereal *)ptr;
671 b_char(f__lchar,ptr,len);
675 if(f__lcount>0) f__lcount--;
684 integer s_rsle(a) cilist *a;
686 integer s_rsle(cilist *a)
694 if(n=c_le(a)) return(n);
699 if(f__curunit->uwrt && f__nowreading(f__curunit))
700 err(a->cierr,errno,"read start");
702 err(f__elist->ciend,(EOF),"read start");