![[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 [CSRG BSD Unix] / 40BSD / lib / libI77|
Return to lread.c CVS log | Up to [CSRG BSD Unix] / 40BSD / lib / libI77 |
1.1 root 1: #include "fio.h"
2: #include "fmt.h"
3: #include "lio.h"
4: #include "ctype.h"
5: extern char *fmtbuf;
6: extern char *malloc(), *realloc();
7: int (*lioproc)();
8:
9: #define isblnk(x) (ltab[x+1]&B)
10: #define issep(x) (ltab[x+1]&SX)
11: #define isapos(x) (ltab[x+1]&AX)
12: #define isexp(x) (ltab[x+1]&EX)
13: #define issign(x) (ltab[x+1]&SG)
14: #define SX 1
15: #define B 2
16: #define AX 4
17: #define EX 8
18: #define SG 16
19: char ltab[128+1] = { /* offset one for EOF */
20: 0,
21: 0,0,AX,0,0,0,0,0,0,0,SX,0,0,0,0,0,
22: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
23: SX|B,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
24: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
25: 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
26: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
27: AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
28: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
29: };
30:
31: char l_comma, l_first;
32: t_getc()
33: { int ch;
34: if(curunit->uend) return(EOF);
35: if((ch=getc(cf))!=EOF) return(ch);
36: if(feof(cf)) curunit->uend = 1;
37: return(EOF);
38: }
39: e_rsle()
40: {
41: int ch;
42: if(curunit->uend) return(0);
43: while((ch=t_getc())!='\n' && ch!=EOF);
44: return(0);
45: }
46:
47: flag lquit;
48: int lcount,ltype;
49: char *lchar;
50: double lx,ly;
51: #define ERR(x) if(n=(x)) return(n)
52: #define GETC(x) (x=t_getc())
53:
54: l_read(number,ptr,len,type) ftnint *number,type; flex *ptr; ftnlen len;
55: { int i,n,ch;
56: double *yy;
57: float *xx;
58: for(i=0;i<*number;i++)
59: {
60: if(lquit) return(0);
61: if(curunit->uend) err(elist->ciend, EOF, "list in")
62: if(lcount == 0) {
63: ltype = NULL;
64: if(!l_first) l_comma = 0;
65: else l_first = 0;
66: for(;;) {
67: GETC(ch);
68: switch(ch) {
69: case EOF:
70: goto loopend;
71: case ' ':
72: case '\n':
73: continue;
74: case '/':
75: lquit = 1;
76: goto loopend;
77: case ',':
78: if(l_comma) {
79: lcount = 1;
80: (void) ungetc(ch, cf);
81: goto loopend;
82: }
83: l_comma = 1;
84: continue;
85: default:
86: (void) ungetc(ch, cf);
87: goto rddata;
88: }
89: }
90: }
91: rddata:
92: switch((int)type)
93: {
94: case TYSHORT:
95: case TYLONG:
96: case TYREAL:
97: case TYDREAL:
98: ERR(l_R());
99: break;
100: case TYCOMPLEX:
101: case TYDCOMPLEX:
102: ERR(l_C());
103: break;
104: case TYLOGICAL:
105: ERR(l_L());
106: break;
107: case TYCHAR:
108: ERR(l_CHAR());
109: break;
110: }
111: loopend:
112: if(lquit) return(0);
113: if(feof(cf)) err(elist->ciend,(EOF),"list in")
114: else if(ferror(cf))
115: { clearerr(cf);
116: err(elist->cierr,errno,"list in")
117: }
118: if(ltype==NULL) goto bump;
119: switch((int)type)
120: {
121: case TYSHORT:
122: ptr->flshort=lx;
123: break;
124: case TYLOGICAL:
125: case TYLONG:
126: ptr->flint=lx;
127: break;
128: case TYREAL:
129: ptr->flreal=lx;
130: break;
131: case TYDREAL:
132: ptr->fldouble=lx;
133: break;
134: case TYCOMPLEX:
135: xx=(float *)ptr;
136: *xx++ = lx;
137: *xx = ly;
138: break;
139: case TYDCOMPLEX:
140: yy=(double *)ptr;
141: *yy++ = lx;
142: *yy = ly;
143: break;
144: case TYCHAR:
145: b_char(lchar,(char *)ptr,len);
146: break;
147: }
148: bump:
149: if(lcount>0) lcount--;
150: ptr = (flex *)((char *)ptr + len);
151: }
152: return(0);
153: }
154: l_R()
155: { double a,b,c,d;
156: int i,ch,sign=0,da,db,dc;
157: int poststar = 0;
158: a=b=c=d=0;
159: da=db=dc=0;
160: if(lcount>0) return(0);
161: ltype=NULL;
162: da=rd_int(&a);
163: if(da== -1) sign=da;
164: if(GETC(ch)!='*')
165: { (void) ungetc(ch,cf);
166: db=1;
167: b=a;
168: a=1;
169: }
170: else
171: db=rd_int(&b);
172: if(db > 0) poststar = 1;
173: if(GETC(ch)!='.')
174: { dc=c=0;
175: (void) ungetc(ch,cf);
176: }
177: else dc=rd_int(&c);
178: if(dc > 0) poststar = 1;
179: if(isexp(GETC(ch))) db=rd_int(&d);
180: else if(issign(ch))
181: { (void) ungetc(ch, cf);
182: db = rd_int(&d);
183: }
184: else
185: { (void) ungetc(ch,cf);
186: db = 0;
187: d=0;
188: }
189: if(db > 0) poststar = 1;
190: lcount=a;
191: if(poststar == 0)
192: return(0);
193: if(db && b<0)
194: { sign=1;
195: b = -b;
196: }
197: for(i=0;i<dc;i++) c/=10;
198: b=b+c;
199: for(i=0;i<d;i++) b *= 10;
200: for(i=0;i< -d;i++) b /= 10;
201: if(sign) b = -b;
202: ltype=TYLONG;
203: lx=b;
204: return(0);
205: }
206: rd_int(x) double *x;
207: { int ch,sign=0,i;
208: double y;
209: i=0;
210: y=0;
211: if(GETC(ch)=='-') sign = -1;
212: else if(ch=='+') sign=0;
213: else (void) ungetc(ch,cf);
214: while(isdigit(GETC(ch)))
215: { i++;
216: y=10*y+ch-'0';
217: }
218: (void) ungetc(ch,cf);
219: if(sign) y = -y;
220: *x = y;
221: return(y!=0?i:sign);
222: }
223: l_C()
224: { int ch;
225: if(lcount>0) return(0);
226: ltype=NULL;
227: GETC(ch);
228: if(ch!='(')
229: { if(fscanf(cf,"%d",&lcount)!=1)
230: if(!feof(cf)) err(elist->cierr,112,"complex format")
231: else err(elist->cierr,(EOF),"lread");
232: if(GETC(ch)!='*')
233: { (void) ungetc(ch,cf);
234: if(!feof(cf)) err(elist->cierr,112,"no star")
235: else err(elist->cierr,(EOF),"lread");
236: }
237: if(GETC(ch)!='(')
238: { (void) ungetc(ch,cf);
239: return(0);
240: }
241: }
242: lcount = 1;
243: ltype=TYLONG;
244: (void) fscanf(cf,"%lf",&lx);
245: while(isblnk(GETC(ch)) || (ch == '\n'));
246: if(ch!=',')
247: { (void) ungetc(ch,cf);
248: err(elist->cierr,112,"no comma");
249: }
250: while(isblnk(GETC(ch)));
251: (void) ungetc(ch,cf);
252: (void) fscanf(cf,"%lf",&ly);
253: while(isblnk(GETC(ch)));
254: if(ch!=')') err(elist->cierr,112,"no )");
255: while(isblnk(GETC(ch)));
256: if(ch != '\n') (void) ungetc(ch,cf);
257: return(0);
258: }
259: l_L()
260: {
261: int ch;
262: if(lcount>0) return(0);
263: ltype=NULL;
264: GETC(ch);
265: if(isdigit(ch))
266: { (void) ungetc(ch,cf);
267: (void) fscanf(cf,"%d",&lcount);
268: if(GETC(ch)!='*')
269: if(!feof(cf)) err(elist->cierr,112,"no star")
270: else err(elist->cierr,(EOF),"lread");
271: }
272: else (void) ungetc(ch,cf);
273: if(GETC(ch)=='.') GETC(ch);
274: switch(ch)
275: {
276: case 't':
277: case 'T':
278: lx=1;
279: break;
280: case 'f':
281: case 'F':
282: lx=0;
283: break;
284: default:
285: if(isblnk(ch) || issep(ch) || ch==EOF)
286: { (void) ungetc(ch,cf);
287: return(0);
288: }
289: else err(elist->cierr,112,"logical");
290: }
291: ltype=TYLONG;
292: lcount = 1;
293: while(!issep(GETC(ch)) && ch!=EOF);
294: (void) ungetc(ch, cf);
295: return(0);
296: }
297: #define BUFSIZE 128
298: l_CHAR()
299: { int ch,size,i;
300: char quote,*p;
301: if(lcount>0) return(0);
302: ltype=NULL;
303:
304: GETC(ch);
305: if(isdigit(ch))
306: { (void) ungetc(ch,cf);
307: (void) fscanf(cf,"%d",&lcount);
308: if(GETC(ch)!='*') err(elist->cierr,112,"no star");
309: }
310: else (void) ungetc(ch,cf);
311: if(GETC(ch)=='\'' || ch=='"') quote=ch;
312: else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
313: { (void) ungetc(ch,cf);
314: return(0);
315: }
316: else err(elist->cierr,112,"no quote");
317: ltype=TYCHAR;
318: if(lchar!=NULL) free(lchar);
319: size=BUFSIZE;
320: p=lchar=malloc((unsigned int)size);
321: if(lchar==NULL) err(elist->cierr,113,"no space");
322: for(i=0;;)
323: { while(GETC(ch)!=quote && ch!='\n'
324: && ch!=EOF && ++i<size) *p++ = ch;
325: if(i==size)
326: {
327: newone:
328: lchar= realloc(lchar, (unsigned int)(size += BUFSIZE));
329: p=lchar+i-1;
330: *p++ = ch;
331: }
332: else if(ch==EOF) return(EOF);
333: else if(ch=='\n')
334: { if(*(p-1) != '\\') continue;
335: i--;
336: p--;
337: if(++i<size) *p++ = ch;
338: else goto newone;
339: }
340: else if(GETC(ch)==quote)
341: { if(++i<size) *p++ = ch;
342: else goto newone;
343: }
344: else
345: { (void) ungetc(ch,cf);
346: *p++ = 0;
347: return(0);
348: }
349: }
350: }
351: s_rsle(a) cilist *a;
352: {
353: int n;
354: if(!init) f_init();
355: if(n=c_le(a)) return(n);
356: reading=1;
357: external=1;
358: formatted=1;
359: l_first=1;
360: l_comma = 1;
361: lioproc = l_read;
362: lquit = 0;
363: lcount = 0;
364: if(curunit->uwrt)
365: return(nowreading(curunit));
366: else return(0);
367: }
368: c_le(a) cilist *a;
369: {
370: fmtbuf="list io";
371: if(a->ciunit>=MXUNIT || a->ciunit<0)
372: err(a->cierr,101,"stler");
373: scale=recpos=0;
374: elist=a;
375: curunit = &units[a->ciunit];
376: if(curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
377: err(a->cierr,102,"lio");
378: cf=curunit->ufd;
379: if(!curunit->ufmt) err(a->cierr,103,"lio")
380: return(0);
381: }
382: do_lio(type,number,ptr,len) ftnint *number,*type; flex *ptr; ftnlen len;
383: {
384: return((*lioproc)(number,ptr,len,*type));
385: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.