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