Commit | Line | Data |
---|---|---|
648e85ce BJ |
1 | /* |
2 | * list directed read | |
3 | */ | |
4 | ||
5 | #include "fio.h" | |
6 | #include "lio.h" | |
7 | ||
8 | #define SP 1 | |
9 | #define B 2 | |
10 | #define AP 4 | |
11 | #define EX 8 | |
12 | #define D 16 | |
13 | #define EIN 32 | |
14 | #define isblnk(x) (ltab[x+1]&B) | |
15 | #define issep(x) (ltab[x+1]&SP) | |
16 | #define isapos(x) (ltab[x+1]&AP) | |
17 | #define isexp(x) (ltab[x+1]&EX) | |
18 | #define isdigit(x) (ltab[x+1]&D) | |
19 | #define endlinp(x) (ltab[x+1]&EIN) | |
20 | ||
21 | #define GETC(x) (x=(*getn)()) | |
22 | ||
23 | char *lrd = "list read"; | |
24 | char *lchar; | |
25 | double lx,ly; | |
26 | int ltype; | |
27 | int l_read(),t_getc(),ungetc(); | |
28 | ||
29 | char ltab[128+1] = | |
30 | { EIN, /* offset one for EOF */ | |
31 | /* 0- 15 */ 0,0,AP,0,0,0,0,0,0,B,SP|B|EIN,0,0,0,0,0, /* ^B,TAB,NEWLINE */ | |
32 | /* 16- 31 */ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, | |
33 | /* 32- 47 */ SP|B,0,AP,0,0,0,0,AP,0,0,0,0,SP,0,0,EIN, /* space,",',comma,/ */ | |
34 | /* 48- 63 */ D,D,D,D,D,D,D,D,D,D,0,0,0,0,0,0, /* digits 0-9 */ | |
35 | /* 64- 79 */ 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, /* D,E */ | |
36 | /* 80- 95 */ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, | |
37 | /* 96-111 */ 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, /* d,e */ | |
38 | /* 112-127 */ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 | |
39 | }; | |
40 | ||
41 | s_rsle(a) cilist *a; /* start read sequential list external */ | |
42 | { | |
43 | int n; | |
44 | reading = YES; | |
45 | if(n=c_le(a,READ)) return(n); | |
46 | l_first = YES; | |
47 | lquit = NO; | |
48 | lioproc = l_read; | |
49 | getn = t_getc; | |
50 | ungetn = ungetc; | |
51 | leof = curunit->uend; | |
52 | lcount = 0; | |
53 | if(curunit->uwrt) nowreading(curunit); | |
54 | return(OK); | |
55 | } | |
56 | ||
57 | t_getc() | |
58 | { int ch; | |
59 | if(curunit->uend) return(EOF); | |
60 | if((ch=getc(cf))!=EOF) return(ch); | |
61 | if(feof(cf)) | |
62 | { curunit->uend = YES; | |
63 | leof = EOF; | |
64 | } | |
65 | else clearerr(cf); | |
66 | return(EOF); | |
67 | } | |
68 | ||
69 | e_rsle() | |
70 | { | |
71 | int ch; | |
72 | if(curunit->uend) return(OK); | |
73 | while(!endlinp(GETC(ch))); | |
74 | return(OK); | |
75 | } | |
76 | ||
77 | l_read(number,ptr,len,type) ftnint *number,type; flex *ptr; ftnlen len; | |
78 | { int i,n,ch; | |
79 | double *yy; | |
80 | float *xx; | |
81 | for(i=0;i<*number;i++) | |
82 | { | |
83 | if(leof) err(endflag, EOF, lrd) | |
84 | if(l_first) | |
85 | { l_first = NO; | |
86 | while(isblnk(GETC(ch))); /* skip blanks */ | |
87 | (*ungetn)(ch,cf); | |
88 | } | |
89 | else if(lcount==0) /* repeat count == 0 ? */ | |
90 | { ERR(t_sep()); /* look for non-blank, allow 1 comma */ | |
91 | if(lquit) return(OK); /* slash found */ | |
92 | } | |
93 | switch((int)type) | |
94 | { | |
95 | case TYSHORT: | |
96 | case TYLONG: | |
97 | case TYREAL: | |
98 | case TYDREAL: | |
99 | ERR(l_R(1)); | |
100 | break; | |
101 | case TYCOMPLEX: | |
102 | case TYDCOMPLEX: | |
103 | ERR(l_C()); | |
104 | break; | |
105 | case TYLOGICAL: | |
106 | ERR(l_L()); | |
107 | break; | |
108 | case TYCHAR: | |
109 | ERR(l_CHAR()); | |
110 | break; | |
111 | } | |
112 | if(lquit) return(OK); | |
113 | if(leof) err(endflag,EOF,lrd) | |
114 | else if(external && ferror(cf)) err(errflag,errno,lrd) | |
115 | if(ltype) switch((int)type) | |
116 | { | |
117 | case TYSHORT: | |
118 | ptr->flshort=lx; | |
119 | break; | |
120 | case TYLOGICAL: | |
121 | case TYLONG: | |
122 | ptr->flint=lx; | |
123 | break; | |
124 | case TYREAL: | |
125 | ptr->flreal=lx; | |
126 | break; | |
127 | case TYDREAL: | |
128 | ptr->fldouble=lx; | |
129 | break; | |
130 | case TYCOMPLEX: | |
131 | xx=(float *)ptr; | |
132 | *xx++ = ly; | |
133 | *xx = lx; | |
134 | break; | |
135 | case TYDCOMPLEX: | |
136 | yy=(double *)ptr; | |
137 | *yy++ = ly; | |
138 | *yy = lx; | |
139 | break; | |
140 | case TYCHAR: | |
141 | b_char(lchar,(char *)ptr,len); | |
142 | break; | |
143 | } | |
144 | if(lcount>0) lcount--; | |
145 | ptr = (char *)ptr + len; | |
146 | } | |
147 | return(OK); | |
148 | } | |
149 | ||
150 | lr_comm() | |
151 | { int ch; | |
152 | if(lcount) return(lcount); | |
153 | ltype=NULL; | |
154 | while(isblnk(GETC(ch))); | |
155 | if(ch==',') | |
156 | { lcount=1; | |
157 | return(lcount); | |
158 | } | |
159 | (*ungetn)(ch,cf); | |
160 | if(ch=='/') | |
161 | { lquit = YES; | |
162 | return(lquit); | |
163 | } | |
164 | else | |
165 | return(OK); | |
166 | } | |
167 | ||
168 | get_repet() | |
169 | { char ch; | |
170 | double lc; | |
171 | if(isdigit(GETC(ch))) | |
172 | { (*ungetn)(ch,cf); | |
173 | rd_int(&lc); | |
174 | lcount = (int)lc; | |
175 | if(GETC(ch)!='*') | |
176 | if(leof) return(EOF); | |
177 | else return(109); | |
178 | } | |
179 | else | |
180 | { lcount = 1; | |
181 | (*ungetn)(ch,cf); | |
182 | } | |
183 | return(OK); | |
184 | } | |
185 | ||
186 | l_R(flg) int flg; | |
187 | { double a,b,c,d; | |
188 | int da,db,dc,dd; | |
189 | int i,ch,sign=0; | |
190 | a=b=c=d=0; | |
191 | da=db=dc=dd=0; | |
192 | if(flg && lr_comm()) return(OK); | |
193 | da=rd_int(&a); /* repeat count ? */ | |
194 | if(GETC(ch)=='*') | |
195 | { | |
196 | if (a <= 0.) return(122); | |
197 | lcount=(int)a; | |
198 | db=rd_int(&b); /* whole part of number */ | |
199 | } | |
200 | else | |
201 | { (*ungetn)(ch,cf); | |
202 | db=da; | |
203 | b=a; | |
204 | lcount=1; | |
205 | } | |
206 | if(GETC(ch)=='.' && isdigit(GETC(ch))) | |
207 | { (*ungetn)(ch,cf); | |
208 | dc=rd_int(&c); /* fractional part of number */ | |
209 | } | |
210 | else | |
211 | { (*ungetn)(ch,cf); | |
212 | dc=0; | |
213 | c=0.; | |
214 | } | |
215 | if(isexp(GETC(ch))) | |
216 | dd=rd_int(&d); /* exponent */ | |
217 | else if (ch == '+' || ch == '-') | |
218 | { (*ungetn)(ch,cf); | |
219 | dd=rd_int(&d); | |
220 | } | |
221 | else | |
222 | { (*ungetn)(ch,cf); | |
223 | dd=0; | |
224 | } | |
225 | if(db<0 || b<0) | |
226 | { sign=1; | |
227 | b = -b; | |
228 | } | |
229 | for(i=0;i<dc;i++) c/=10.; | |
230 | b=b+c; | |
231 | if (dd > 0) | |
232 | { for(i=0;i<d;i++) b *= 10.; | |
233 | for(i=0;i< -d;i++) b /= 10.; | |
234 | } | |
235 | lx=sign?-b:b; | |
236 | ltype=TYLONG; | |
237 | return(OK); | |
238 | } | |
239 | ||
240 | rd_int(x) double *x; | |
241 | { int ch,sign=0,i=0; | |
242 | double y=0.0; | |
243 | if(GETC(ch)=='-') sign = -1; | |
244 | else if(ch=='+') sign=0; | |
245 | else (*ungetn)(ch,cf); | |
246 | while(isdigit(GETC(ch))) | |
247 | { i++; | |
248 | y=10*y + ch-'0'; | |
249 | } | |
250 | (*ungetn)(ch,cf); | |
251 | if(sign) y = -y; | |
252 | *x = y; | |
253 | return(y==0.0?sign:i); /* 0:[+]&&y==0, -1:-&&y==0, >0:#digits&&y!=0 */ | |
254 | } | |
255 | ||
256 | l_C() | |
257 | { int ch,n; | |
258 | if(lr_comm()) return(OK); | |
259 | if(n=get_repet()) return(n); /* get repeat count */ | |
260 | if(GETC(ch)!='(') err(errflag,112,"no (") | |
261 | while(isblnk(GETC(ch))); | |
262 | (*ungetn)(ch,cf); | |
263 | l_R(0); /* get real part */ | |
264 | ly = lx; | |
265 | if(t_sep()) return(EOF); | |
266 | l_R(0); /* get imag part */ | |
267 | while(isblnk(GETC(ch))); | |
268 | if(ch!=')') err(errflag,112,"no )") | |
269 | ltype = TYCOMPLEX; | |
270 | return(OK); | |
271 | } | |
272 | ||
273 | l_L() | |
274 | { | |
275 | int ch,n; | |
276 | if(lr_comm()) return(OK); | |
277 | if(n=get_repet()) return(n); /* get repeat count */ | |
278 | if(GETC(ch)=='.') GETC(ch); | |
279 | switch(ch) | |
280 | { | |
281 | case 't': | |
282 | case 'T': | |
283 | lx=1; | |
284 | break; | |
285 | case 'f': | |
286 | case 'F': | |
287 | lx=0; | |
288 | break; | |
289 | default: | |
290 | if(isblnk(ch) || issep(ch)) | |
291 | { (*ungetn)(ch,cf); | |
292 | lx=0; | |
293 | return(OK); | |
294 | } | |
295 | else if(ch==EOF) return(EOF); | |
296 | else err(errflag,112,"logical not T or F"); | |
297 | } | |
298 | ltype=TYLOGICAL; | |
299 | while(!issep(GETC(ch)) && !isblnk(ch) && ch!='\n' && ch!=EOF); | |
300 | return(OK); | |
301 | } | |
302 | ||
303 | #define BUFSIZE 128 | |
304 | l_CHAR() | |
305 | { int ch,size,i,n; | |
306 | char quote,*p; | |
307 | if(lr_comm()) return(OK); | |
308 | if(n=get_repet()) return(n); /* get repeat count */ | |
309 | if(isapos(GETC(ch))) quote=ch; | |
310 | else if(isblnk(ch) || issep(ch) || ch==EOF || ch=='\n') | |
311 | { if(ch==EOF) return(EOF); | |
312 | (*ungetn)(ch,cf); | |
313 | return(OK); | |
314 | } | |
315 | else | |
316 | { quote = '\0'; /* to allow single word non-quoted */ | |
317 | (*ungetn)(ch,cf); | |
318 | } | |
319 | ltype=TYCHAR; | |
320 | if(lchar!=NULL) free(lchar); | |
321 | size=BUFSIZE-1; | |
322 | p=lchar=(char *)malloc(BUFSIZE); | |
323 | if(lchar==NULL) err(errflag,113,lrd) | |
324 | for(i=0;;) | |
325 | { while( ( (quote && GETC(ch)!=quote) || | |
326 | (!quote && !issep(GETC(ch)) && !isblnk(ch) ) ) | |
327 | && ch!='\n' && ch!=EOF && ++i<size ) | |
328 | *p++ = ch; | |
329 | if(i==size) | |
330 | { | |
331 | newone: | |
332 | size += BUFSIZE; | |
333 | lchar=(char *)realloc(lchar, size+1); | |
334 | if(lchar==NULL) err(errflag,113,lrd) | |
335 | p=lchar+i-1; | |
336 | *p++ = ch; | |
337 | } | |
338 | else if(ch==EOF) return(EOF); | |
339 | else if(ch=='\n') | |
340 | { if(*(p-1) == '\\') *(p-1) = ch; | |
341 | else if(!quote) | |
342 | { *p = '\0'; | |
343 | (*ungetn)(ch,cf); | |
344 | return(OK); | |
345 | } | |
346 | } | |
347 | else if(quote && GETC(ch)==quote) | |
348 | { if(++i<size) *p++ = ch; | |
349 | else goto newone; | |
350 | } | |
351 | else | |
352 | { (*ungetn)(ch,cf); | |
353 | *p = '\0'; | |
354 | return(OK); | |
355 | } | |
356 | } | |
357 | } | |
358 | ||
359 | t_sep() | |
360 | { | |
361 | int ch; | |
362 | while(isblnk(GETC(ch))); | |
363 | if(leof) return(EOF); | |
364 | if(ch=='/') | |
365 | { lquit = YES; | |
366 | (*ungetn)(ch,cf); | |
367 | return(OK); | |
368 | } | |
369 | if(issep(ch)) while(isblnk(GETC(ch))); | |
370 | if(leof) return(EOF); | |
371 | (*ungetn)(ch,cf); | |
372 | return(OK); | |
373 | } |