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