![[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 / old1|
Return to lread.c CVS log | Up to [Research Unix] / researchv10dc / libI77 / old1 |
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: l_eof = f__curunit->uend = 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: err(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: err(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: err(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: err(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: err(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: err(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: err(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: err(f__elist->cierr,112,"no imaginary part");
276: while(iswhit(GETC(ch)));
277: if(ch!=')') err(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: err(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 err(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=malloc((unsigned int)size);
332: if(f__lchar==NULL) err(f__elist->cierr,113,"no space");
333:
334: GETC(ch);
335: if(isdigit(ch)) {
336: /* allow Fortran 8x-style unquoted string... */
337: /* either find a repetition count or the string */
338: f__lcount = ch - '0';
339: *p++ = ch;
340: for(i = 1;;) {
341: switch(GETC(ch)) {
342: case '*':
343: if (f__lcount == 0) {
344: f__lcount = 1;
345: goto noquote;
346: }
347: p = f__lchar;
348: goto have_lcount;
349: case ',':
350: case ' ':
351: case '\t':
352: case '\n':
353: case '/':
354: Ungetc(ch,f__cf);
355: /* no break */
356: case EOF:
357: f__lcount = 1;
358: f__ltype = TYCHAR;
359: return *p = 0;
360: }
361: if (!isdigit(ch)) {
362: f__lcount = 1;
363: goto noquote;
364: }
365: *p++ = ch;
366: f__lcount = 10*f__lcount + ch - '0';
367: if (++i == size) {
368: f__lchar = realloc(f__lchar,
369: (unsigned int)(size += BUFSIZE));
370: p = f__lchar + i;
371: }
372: }
373: }
374: else (void) Ungetc(ch,f__cf);
375: have_lcount:
376: if(GETC(ch)=='\'' || ch=='"') quote=ch;
377: else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
378: { (void) Ungetc(ch,f__cf);
379: return(0);
380: }
381: else {
382: /* Fortran 8x-style unquoted string */
383: *p++ = ch;
384: for(i = 1;;) {
385: switch(GETC(ch)) {
386: case ',':
387: case ' ':
388: case '\t':
389: case '\n':
390: case '/':
391: Ungetc(ch,f__cf);
392: /* no break */
393: case EOF:
394: f__ltype = TYCHAR;
395: return *p = 0;
396: }
397: noquote:
398: *p++ = ch;
399: if (++i == size) {
400: f__lchar = realloc(f__lchar,
401: (unsigned int)(size += BUFSIZE));
402: p = f__lchar + i;
403: }
404: }
405: }
406: f__ltype=TYCHAR;
407: for(i=0;;)
408: { while(GETC(ch)!=quote && ch!='\n'
409: && ch!=EOF && ++i<size) *p++ = ch;
410: if(i==size)
411: {
412: newone:
413: f__lchar= realloc(f__lchar, (unsigned int)(size += BUFSIZE));
414: p=f__lchar+i-1;
415: *p++ = ch;
416: }
417: else if(ch==EOF) return(EOF);
418: else if(ch=='\n')
419: { if(*(p-1) != '\\') continue;
420: i--;
421: p--;
422: if(++i<size) *p++ = ch;
423: else goto newone;
424: }
425: else if(GETC(ch)==quote)
426: { if(++i<size) *p++ = ch;
427: else goto newone;
428: }
429: else
430: { (void) Ungetc(ch,f__cf);
431: *p = 0;
432: return(0);
433: }
434: }
435: }
436: #ifdef KR_headers
437: c_le(a) cilist *a;
438: #else
439: c_le(cilist *a)
440: #endif
441: {
442: f__fmtbuf="list io";
443: if(a->ciunit>=MXUNIT || a->ciunit<0)
444: err(a->cierr,101,"stler");
445: f__scale=f__recpos=0;
446: f__elist=a;
447: f__curunit = &f__units[a->ciunit];
448: if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
449: err(a->cierr,102,"lio");
450: f__cf=f__curunit->ufd;
451: if(!f__curunit->ufmt) err(a->cierr,103,"lio")
452: return(0);
453: }
454: #ifdef KR_headers
455: l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
456: #else
457: l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
458: #endif
459: {
460: #define Ptr ((flex *)ptr)
461: int i,n,ch;
462: doublereal *yy;
463: real *xx;
464: for(i=0;i<*number;i++)
465: {
466: if(f__lquit) return(0);
467: if(l_eof)
468: err(f__elist->ciend, EOF, "list in")
469: if(f__lcount == 0) {
470: f__ltype = 0;
471: for(;;) {
472: GETC(ch);
473: switch(ch) {
474: case EOF:
475: goto loopend;
476: case ' ':
477: case '\t':
478: case '\n':
479: continue;
480: case '/':
481: f__lquit = 1;
482: goto loopend;
483: case ',':
484: f__lcount = 1;
485: goto loopend;
486: default:
487: (void) Ungetc(ch, f__cf);
488: goto rddata;
489: }
490: }
491: }
492: rddata:
493: switch((int)type)
494: {
495: case TYINT1:
496: case TYSHORT:
497: case TYLONG:
498: #ifdef TYQUAD
499: case TYQUAD:
500: #endif
501: case TYREAL:
502: case TYDREAL:
503: ERR(l_R(0));
504: break;
505: case TYCOMPLEX:
506: case TYDCOMPLEX:
507: ERR(l_C());
508: break;
509: case TYLOGICAL1:
510: case TYLOGICAL2:
511: case TYLOGICAL:
512: ERR(l_L());
513: break;
514: case TYCHAR:
515: ERR(l_CHAR());
516: break;
517: }
518: while (GETC(ch) == ' ' || ch == '\t');
519: if (ch != ',' || f__lcount > 1)
520: Ungetc(ch,f__cf);
521: loopend:
522: if(f__lquit) return(0);
523: if(f__cf) {
524: if (feof(f__cf))
525: err(f__elist->ciend,(EOF),"list in")
526: else if(ferror(f__cf)) {
527: clearerr(f__cf);
528: err(f__elist->cierr,errno,"list in")
529: }
530: }
531: if(f__ltype==0) goto bump;
532: switch((int)type)
533: {
534: case TYINT1:
535: case TYLOGICAL1:
536: Ptr->flchar = f__lx;
537: break;
538: case TYLOGICAL2:
539: case TYSHORT:
540: Ptr->flshort=f__lx;
541: break;
542: case TYLOGICAL:
543: case TYLONG:
544: Ptr->flint=f__lx;
545: break;
546: #ifdef TYQUAD
547: case TYQUAD:
548: Ptr->fllongint = f__lx;
549: break;
550: #endif
551: case TYREAL:
552: Ptr->flreal=f__lx;
553: break;
554: case TYDREAL:
555: Ptr->fldouble=f__lx;
556: break;
557: case TYCOMPLEX:
558: xx=(real *)ptr;
559: *xx++ = f__lx;
560: *xx = f__ly;
561: break;
562: case TYDCOMPLEX:
563: yy=(doublereal *)ptr;
564: *yy++ = f__lx;
565: *yy = f__ly;
566: break;
567: case TYCHAR:
568: b_char(f__lchar,ptr,len);
569: break;
570: }
571: bump:
572: if(f__lcount>0) f__lcount--;
573: ptr += len;
574: if (nml_read)
575: nml_read++;
576: }
577: return(0);
578: #undef Ptr
579: }
580: #ifdef KR_headers
581: integer s_rsle(a) cilist *a;
582: #else
583: integer s_rsle(cilist *a)
584: #endif
585: {
586: int n;
587:
588: if(!f__init) f_init();
589: if(n=c_le(a)) return(n);
590: f__reading=1;
591: f__external=1;
592: f__formatted=1;
593: f__lioproc = l_read;
594: f__lquit = 0;
595: f__lcount = 0;
596: l_eof = 0;
597: if(f__curunit->uwrt && f__nowreading(f__curunit))
598: err(a->cierr,errno,"read start");
599: l_getc = t_getc;
600: l_ungetc = un_getc;
601: return(0);
602: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.