Commit | Line | Data |
---|---|---|
914b7558 BJ |
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 | } |