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