1 #include "f2c.h"
2 #include "fio.h"
3
4 /* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */
5 /* marks in namelist input a la the Fortran 8X Draft published in */
6 /* the May 1989 issue of Fortran Forum. */
7
8
9 extern char *f__fmtbuf;
10
11 #ifdef Allow_TYQUAD
12 static longint f__llx;
13 #endif
14
15 #ifdef KR_headers
16 extern double atof();
17 extern char *malloc(), *realloc();
18 int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)();
19 #else
20 #undef abs
21 #undef min
22 #undef max
23 #include "stdlib.h"
24 #endif
25
26 #include "fmt.h"
27 #include "lio.h"
28 #include "ctype.h"
29 #include "fp.h"
30 #ifdef __cplusplus
31 extern "C" {
32 #endif
33
34 #ifndef KR_headers
35 int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void),
36 (*l_ungetc)(int,FILE*);
37 #endif
38
39 int l_eof;
40
41 #define isblnk(x) (f__ltab[x+1]&B)
42 #define issep(x) (f__ltab[x+1]&SX)
43 #define isapos(x) (f__ltab[x+1]&AX)
44 #define isexp(x) (f__ltab[x+1]&EX)
45 #define issign(x) (f__ltab[x+1]&SG)
46 #define iswhit(x) (f__ltab[x+1]&WH)
47 #define SX 1
48 #define B 2
49 #define AX 4
50 #define EX 8
51 #define SG 16
52 #define WH 32
53 char f__ltab[128+1] = { /* offset one for EOF */
54 0,
55 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
56 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
57 SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
58 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
59 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
60 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
61 AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
62 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
63 };
64
65 #ifdef ungetc
66 static int
67 #ifdef KR_headers
un_getc(x,f__cf)68 un_getc(x,f__cf) int x; FILE *f__cf;
69 #else
70 un_getc(int x, FILE *f__cf)
71 #endif
72 { return ungetc(x,f__cf); }
73 #else
74 #define un_getc ungetc
75 #ifdef KR_headers
76 extern int ungetc();
77 #endif
78 #endif
79
80 int
t_getc(Void)81 t_getc(Void)
82 { int ch;
83 if(f__curunit->uend) return(EOF);
84 if((ch=getc(f__cf))!=EOF) return(ch);
85 if(feof(f__cf))
86 f__curunit->uend = l_eof = 1;
87 return(EOF);
88 }
e_rsle(Void)89 integer e_rsle(Void)
90 {
91 int ch;
92 if(f__curunit->uend) return(0);
93 while((ch=t_getc())!='\n')
94 if (ch == EOF) {
95 if(feof(f__cf))
96 f__curunit->uend = l_eof = 1;
97 return EOF;
98 }
99 return(0);
100 }
101
102 flag f__lquit;
103 int f__lcount,f__ltype,nml_read;
104 char *f__lchar;
105 double f__lx,f__ly;
106 #define ERR(x) if(n=(x)) return(n)
107 #define GETC(x) (x=(*l_getc)())
108 #define Ungetc(x,y) (*l_ungetc)(x,y)
109
110 static int
111 #ifdef KR_headers
l_R(poststar,reqint)112 l_R(poststar, reqint) int poststar, reqint;
113 #else
114 l_R(int poststar, int reqint)
115 #endif
116 {
117 char s[FMAX+EXPMAXDIGS+4];
118 register int ch;
119 register char *sp, *spe, *sp1;
120 long e, exp;
121 int havenum, havestar, se;
122
123 if (!poststar) {
124 if (f__lcount > 0)
125 return(0);
126 f__lcount = 1;
127 }
128 #ifdef Allow_TYQUAD
129 f__llx = 0;
130 #endif
131 f__ltype = 0;
132 exp = 0;
133 havestar = 0;
134 retry:
135 sp1 = sp = s;
136 spe = sp + FMAX;
137 havenum = 0;
138
139 switch(GETC(ch)) {
140 case '-': *sp++ = ch; sp1++; spe++;
141 case '+':
142 GETC(ch);
143 }
144 while(ch == '0') {
145 ++havenum;
146 GETC(ch);
147 }
148 while(isdigit(ch)) {
149 if (sp < spe) *sp++ = ch;
150 else ++exp;
151 GETC(ch);
152 }
153 if (ch == '*' && !poststar) {
154 if (sp == sp1 || exp || *s == '-') {
155 errfl(f__elist->cierr,112,"bad repetition count");
156 }
157 poststar = havestar = 1;
158 *sp = 0;
159 f__lcount = atoi(s);
160 goto retry;
161 }
162 if (ch == '.') {
163 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
164 if (reqint)
165 errfl(f__elist->cierr,115,"invalid integer");
166 #endif
167 GETC(ch);
168 if (sp == sp1)
169 while(ch == '0') {
170 ++havenum;
171 --exp;
172 GETC(ch);
173 }
174 while(isdigit(ch)) {
175 if (sp < spe)
176 { *sp++ = ch; --exp; }
177 GETC(ch);
178 }
179 }
180 havenum += sp - sp1;
181 se = 0;
182 if (issign(ch))
183 goto signonly;
184 if (havenum && isexp(ch)) {
185 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
186 if (reqint)
187 errfl(f__elist->cierr,115,"invalid integer");
188 #endif
189 GETC(ch);
190 if (issign(ch)) {
191 signonly:
192 if (ch == '-') se = 1;
193 GETC(ch);
194 }
195 if (!isdigit(ch)) {
196 bad:
197 errfl(f__elist->cierr,112,"exponent field");
198 }
199
200 e = ch - '0';
201 while(isdigit(GETC(ch))) {
202 e = 10*e + ch - '0';
203 if (e > EXPMAX)
204 goto bad;
205 }
206 if (se)
207 exp -= e;
208 else
209 exp += e;
210 }
211 (void) Ungetc(ch, f__cf);
212 if (sp > sp1) {
213 ++havenum;
214 while(*--sp == '0')
215 ++exp;
216 if (exp)
217 sprintf(sp+1, "e%ld", exp);
218 else
219 sp[1] = 0;
220 f__lx = atof(s);
221 #ifdef Allow_TYQUAD
222 if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) {
223 /* Assuming 64-bit longint and 32-bit long. */
224 if (exp < 0)
225 sp += exp;
226 if (sp1 <= sp) {
227 f__llx = *sp1 - '0';
228 while(++sp1 <= sp)
229 f__llx = 10*f__llx + (*sp1 - '0');
230 }
231 while(--exp >= 0)
232 f__llx *= 10;
233 if (*s == '-')
234 f__llx = -f__llx;
235 }
236 #endif
237 }
238 else
239 f__lx = 0.;
240 if (havenum)
241 f__ltype = TYLONG;
242 else
243 switch(ch) {
244 case ',':
245 case '/':
246 break;
247 default:
248 if (havestar && ( ch == ' '
249 ||ch == '\t'
250 ||ch == '\n'))
251 break;
252 if (nml_read > 1) {
253 f__lquit = 2;
254 return 0;
255 }
256 errfl(f__elist->cierr,112,"invalid number");
257 }
258 return 0;
259 }
260
261 static int
262 #ifdef KR_headers
rd_count(ch)263 rd_count(ch) register int ch;
264 #else
265 rd_count(register int ch)
266 #endif
267 {
268 if (ch < '0' || ch > '9')
269 return 1;
270 f__lcount = ch - '0';
271 while(GETC(ch) >= '0' && ch <= '9')
272 f__lcount = 10*f__lcount + ch - '0';
273 Ungetc(ch,f__cf);
274 return f__lcount <= 0;
275 }
276
277 static int
l_C(Void)278 l_C(Void)
279 { int ch, nml_save;
280 double lz;
281 if(f__lcount>0) return(0);
282 f__ltype=0;
283 GETC(ch);
284 if(ch!='(')
285 {
286 if (nml_read > 1 && (ch < '0' || ch > '9')) {
287 Ungetc(ch,f__cf);
288 f__lquit = 2;
289 return 0;
290 }
291 if (rd_count(ch))
292 if(!f__cf || !feof(f__cf))
293 errfl(f__elist->cierr,112,"complex format");
294 else
295 err(f__elist->cierr,(EOF),"lread");
296 if(GETC(ch)!='*')
297 {
298 if(!f__cf || !feof(f__cf))
299 errfl(f__elist->cierr,112,"no star");
300 else
301 err(f__elist->cierr,(EOF),"lread");
302 }
303 if(GETC(ch)!='(')
304 { Ungetc(ch,f__cf);
305 return(0);
306 }
307 }
308 else
309 f__lcount = 1;
310 while(iswhit(GETC(ch)));
311 Ungetc(ch,f__cf);
312 nml_save = nml_read;
313 nml_read = 0;
314 if (ch = l_R(1,0))
315 return ch;
316 if (!f__ltype)
317 errfl(f__elist->cierr,112,"no real part");
318 lz = f__lx;
319 while(iswhit(GETC(ch)));
320 if(ch!=',')
321 { (void) Ungetc(ch,f__cf);
322 errfl(f__elist->cierr,112,"no comma");
323 }
324 while(iswhit(GETC(ch)));
325 (void) Ungetc(ch,f__cf);
326 if (ch = l_R(1,0))
327 return ch;
328 if (!f__ltype)
329 errfl(f__elist->cierr,112,"no imaginary part");
330 while(iswhit(GETC(ch)));
331 if(ch!=')') errfl(f__elist->cierr,112,"no )");
332 f__ly = f__lx;
333 f__lx = lz;
334 #ifdef Allow_TYQUAD
335 f__llx = 0;
336 #endif
337 nml_read = nml_save;
338 return(0);
339 }
340
341 static char nmLbuf[256], *nmL_next;
342 static int (*nmL_getc_save)(Void);
343 #ifdef KR_headers
344 static int (*nmL_ungetc_save)(/* int, FILE* */);
345 #else
346 static int (*nmL_ungetc_save)(int, FILE*);
347 #endif
348
349 static int
nmL_getc(Void)350 nmL_getc(Void)
351 {
352 int rv;
353 if (rv = *nmL_next++)
354 return rv;
355 l_getc = nmL_getc_save;
356 l_ungetc = nmL_ungetc_save;
357 return (*l_getc)();
358 }
359
360 static int
361 #ifdef KR_headers
nmL_ungetc(x,f)362 nmL_ungetc(x, f) int x; FILE *f;
363 #else
364 nmL_ungetc(int x, FILE *f)
365 #endif
366 {
367 f = f; /* banish non-use warning */
368 return *--nmL_next = x;
369 }
370
371 static int
372 #ifdef KR_headers
Lfinish(ch,dot,rvp)373 Lfinish(ch, dot, rvp) int ch, dot, *rvp;
374 #else
375 Lfinish(int ch, int dot, int *rvp)
376 #endif
377 {
378 char *s, *se;
379 static char what[] = "namelist input";
380
381 s = nmLbuf + 2;
382 se = nmLbuf + sizeof(nmLbuf) - 1;
383 *s++ = ch;
384 while(!issep(GETC(ch)) && ch!=EOF) {
385 if (s >= se) {
386 nmLbuf_ovfl:
387 return *rvp = err__fl(f__elist->cierr,131,what);
388 }
389 *s++ = ch;
390 if (ch != '=')
391 continue;
392 if (dot)
393 return *rvp = err__fl(f__elist->cierr,112,what);
394 got_eq:
395 *s = 0;
396 nmL_getc_save = l_getc;
397 l_getc = nmL_getc;
398 nmL_ungetc_save = l_ungetc;
399 l_ungetc = nmL_ungetc;
400 nmLbuf[1] = *(nmL_next = nmLbuf) = ',';
401 *rvp = f__lcount = 0;
402 return 1;
403 }
404 if (dot)
405 goto done;
406 for(;;) {
407 if (s >= se)
408 goto nmLbuf_ovfl;
409 *s++ = ch;
410 if (!isblnk(ch))
411 break;
412 if (GETC(ch) == EOF)
413 goto done;
414 }
415 if (ch == '=')
416 goto got_eq;
417 done:
418 Ungetc(ch, f__cf);
419 return 0;
420 }
421
422 static int
l_L(Void)423 l_L(Void)
424 {
425 int ch, rv, sawdot;
426
427 if(f__lcount>0)
428 return(0);
429 f__lcount = 1;
430 f__ltype=0;
431 GETC(ch);
432 if(isdigit(ch))
433 {
434 rd_count(ch);
435 if(GETC(ch)!='*')
436 if(!f__cf || !feof(f__cf))
437 errfl(f__elist->cierr,112,"no star");
438 else
439 err(f__elist->cierr,(EOF),"lread");
440 GETC(ch);
441 }
442 sawdot = 0;
443 if(ch == '.') {
444 sawdot = 1;
445 GETC(ch);
446 }
447 switch(ch)
448 {
449 case 't':
450 case 'T':
451 if (nml_read && Lfinish(ch, sawdot, &rv))
452 return rv;
453 f__lx=1;
454 break;
455 case 'f':
456 case 'F':
457 if (nml_read && Lfinish(ch, sawdot, &rv))
458 return rv;
459 f__lx=0;
460 break;
461 default:
462 if(isblnk(ch) || issep(ch) || ch==EOF)
463 { (void) Ungetc(ch,f__cf);
464 return(0);
465 }
466 if (nml_read > 1) {
467 Ungetc(ch,f__cf);
468 f__lquit = 2;
469 return 0;
470 }
471 errfl(f__elist->cierr,112,"logical");
472 }
473 f__ltype=TYLONG;
474 while(!issep(GETC(ch)) && ch!=EOF);
475 Ungetc(ch, f__cf);
476 return(0);
477 }
478
479 #define BUFSIZE 128
480
481 static int
l_CHAR(Void)482 l_CHAR(Void)
483 { int ch,size,i;
484 static char rafail[] = "realloc failure";
485 char quote,*p;
486 if(f__lcount>0) return(0);
487 f__ltype=0;
488 if(f__lchar!=NULL) free(f__lchar);
489 size=BUFSIZE;
490 p=f__lchar = (char *)malloc((unsigned int)size);
491 if(f__lchar == NULL)
492 errfl(f__elist->cierr,113,"no space");
493
494 GETC(ch);
495 if(isdigit(ch)) {
496 /* allow Fortran 8x-style unquoted string... */
497 /* either find a repetition count or the string */
498 f__lcount = ch - '0';
499 *p++ = ch;
500 for(i = 1;;) {
501 switch(GETC(ch)) {
502 case '*':
503 if (f__lcount == 0) {
504 f__lcount = 1;
505 #ifndef F8X_NML_ELIDE_QUOTES
506 if (nml_read)
507 goto no_quote;
508 #endif
509 goto noquote;
510 }
511 p = f__lchar;
512 goto have_lcount;
513 case ',':
514 case ' ':
515 case '\t':
516 case '\n':
517 case '/':
518 Ungetc(ch,f__cf);
519 /* no break */
520 case EOF:
521 f__lcount = 1;
522 f__ltype = TYCHAR;
523 return *p = 0;
524 }
525 if (!isdigit(ch)) {
526 f__lcount = 1;
527 #ifndef F8X_NML_ELIDE_QUOTES
528 if (nml_read) {
529 no_quote:
530 errfl(f__elist->cierr,112,
531 "undelimited character string");
532 }
533 #endif
534 goto noquote;
535 }
536 *p++ = ch;
537 f__lcount = 10*f__lcount + ch - '0';
538 if (++i == size) {
539 f__lchar = (char *)realloc(f__lchar,
540 (unsigned int)(size += BUFSIZE));
541 if(f__lchar == NULL)
542 errfl(f__elist->cierr,113,rafail);
543 p = f__lchar + i;
544 }
545 }
546 }
547 else (void) Ungetc(ch,f__cf);
548 have_lcount:
549 if(GETC(ch)=='\'' || ch=='"') quote=ch;
550 else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) {
551 Ungetc(ch,f__cf);
552 return 0;
553 }
554 #ifndef F8X_NML_ELIDE_QUOTES
555 else if (nml_read > 1) {
556 Ungetc(ch,f__cf);
557 f__lquit = 2;
558 return 0;
559 }
560 #endif
561 else {
562 /* Fortran 8x-style unquoted string */
563 *p++ = ch;
564 for(i = 1;;) {
565 switch(GETC(ch)) {
566 case ',':
567 case ' ':
568 case '\t':
569 case '\n':
570 case '/':
571 Ungetc(ch,f__cf);
572 /* no break */
573 case EOF:
574 f__ltype = TYCHAR;
575 return *p = 0;
576 }
577 noquote:
578 *p++ = ch;
579 if (++i == size) {
580 f__lchar = (char *)realloc(f__lchar,
581 (unsigned int)(size += BUFSIZE));
582 if(f__lchar == NULL)
583 errfl(f__elist->cierr,113,rafail);
584 p = f__lchar + i;
585 }
586 }
587 }
588 f__ltype=TYCHAR;
589 for(i=0;;)
590 { while(GETC(ch)!=quote && ch!='\n'
591 && ch!=EOF && ++i<size) *p++ = ch;
592 if(i==size)
593 {
594 newone:
595 f__lchar= (char *)realloc(f__lchar,
596 (unsigned int)(size += BUFSIZE));
597 if(f__lchar == NULL)
598 errfl(f__elist->cierr,113,rafail);
599 p=f__lchar+i-1;
600 *p++ = ch;
601 }
602 else if(ch==EOF) return(EOF);
603 else if(ch=='\n')
604 { if(*(p-1) != '\\') continue;
605 i--;
606 p--;
607 if(++i<size) *p++ = ch;
608 else goto newone;
609 }
610 else if(GETC(ch)==quote)
611 { if(++i<size) *p++ = ch;
612 else goto newone;
613 }
614 else
615 { (void) Ungetc(ch,f__cf);
616 *p = 0;
617 return(0);
618 }
619 }
620 }
621
622 int
623 #ifdef KR_headers
c_le(a)624 c_le(a) cilist *a;
625 #else
626 c_le(cilist *a)
627 #endif
628 {
629 if(!f__init)
630 f_init();
631 f__fmtbuf="list io";
632 f__curunit = &f__units[a->ciunit];
633 if(a->ciunit>=MXUNIT || a->ciunit<0)
634 err(a->cierr,101,"stler");
635 f__scale=f__recpos=0;
636 f__elist=a;
637 if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
638 err(a->cierr,102,"lio");
639 f__cf=f__curunit->ufd;
640 if(!f__curunit->ufmt) err(a->cierr,103,"lio")
641 return(0);
642 }
643
644 int
645 #ifdef KR_headers
l_read(number,ptr,len,type)646 l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
647 #else
648 l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
649 #endif
650 {
651 #define Ptr ((flex *)ptr)
652 int i,n,ch;
653 doublereal *yy;
654 real *xx;
655 for(i=0;i<*number;i++)
656 {
657 if(f__lquit) return(0);
658 if(l_eof)
659 err(f__elist->ciend, EOF, "list in")
660 if(f__lcount == 0) {
661 f__ltype = 0;
662 for(;;) {
663 GETC(ch);
664 switch(ch) {
665 case EOF:
666 err(f__elist->ciend,(EOF),"list in")
667 case ' ':
668 case '\t':
669 case '\n':
670 continue;
671 case '/':
672 f__lquit = 1;
673 goto loopend;
674 case ',':
675 f__lcount = 1;
676 goto loopend;
677 default:
678 (void) Ungetc(ch, f__cf);
679 goto rddata;
680 }
681 }
682 }
683 rddata:
684 switch((int)type)
685 {
686 case TYINT1:
687 case TYSHORT:
688 case TYLONG:
689 #ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
690 ERR(l_R(0,1));
691 break;
692 #endif
693 case TYREAL:
694 case TYDREAL:
695 ERR(l_R(0,0));
696 break;
697 #ifdef TYQUAD
698 case TYQUAD:
699 n = l_R(0,2);
700 if (n)
701 return n;
702 break;
703 #endif
704 case TYCOMPLEX:
705 case TYDCOMPLEX:
706 ERR(l_C());
707 break;
708 case TYLOGICAL1:
709 case TYLOGICAL2:
710 case TYLOGICAL:
711 ERR(l_L());
712 break;
713 case TYCHAR:
714 ERR(l_CHAR());
715 break;
716 }
717 while (GETC(ch) == ' ' || ch == '\t');
718 if (ch != ',' || f__lcount > 1)
719 Ungetc(ch,f__cf);
720 loopend:
721 if(f__lquit) return(0);
722 if(f__cf && ferror(f__cf)) {
723 clearerr(f__cf);
724 errfl(f__elist->cierr,errno,"list in");
725 }
726 if(f__ltype==0) goto bump;
727 switch((int)type)
728 {
729 case TYINT1:
730 case TYLOGICAL1:
731 Ptr->flchar = (char)f__lx;
732 break;
733 case TYLOGICAL2:
734 case TYSHORT:
735 Ptr->flshort = (short)f__lx;
736 break;
737 case TYLOGICAL:
738 case TYLONG:
739 Ptr->flint = (ftnint)f__lx;
740 break;
741 #ifdef Allow_TYQUAD
742 case TYQUAD:
743 if (!(Ptr->fllongint = f__llx))
744 Ptr->fllongint = f__lx;
745 break;
746 #endif
747 case TYREAL:
748 Ptr->flreal=f__lx;
749 break;
750 case TYDREAL:
751 Ptr->fldouble=f__lx;
752 break;
753 case TYCOMPLEX:
754 xx=(real *)ptr;
755 *xx++ = f__lx;
756 *xx = f__ly;
757 break;
758 case TYDCOMPLEX:
759 yy=(doublereal *)ptr;
760 *yy++ = f__lx;
761 *yy = f__ly;
762 break;
763 case TYCHAR:
764 b_char(f__lchar,ptr,len);
765 break;
766 }
767 bump:
768 if(f__lcount>0) f__lcount--;
769 ptr += len;
770 if (nml_read)
771 nml_read++;
772 }
773 return(0);
774 #undef Ptr
775 }
776 #ifdef KR_headers
s_rsle(a)777 integer s_rsle(a) cilist *a;
778 #else
779 integer s_rsle(cilist *a)
780 #endif
781 {
782 int n;
783
784 f__reading=1;
785 f__external=1;
786 f__formatted=1;
787 if(n=c_le(a)) return(n);
788 f__lioproc = l_read;
789 f__lquit = 0;
790 f__lcount = 0;
791 l_eof = 0;
792 if(f__curunit->uwrt && f__nowreading(f__curunit))
793 err(a->cierr,errno,"read start");
794 if(f__curunit->uend)
795 err(f__elist->ciend,(EOF),"read start");
796 l_getc = t_getc;
797 l_ungetc = un_getc;
798 f__doend = xrd_SL;
799 return(0);
800 }
801 #ifdef __cplusplus
802 }
803 #endif
804