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