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