Commit | Line | Data |
---|---|---|
bae7117f WH |
1 | #include "f2c.h" |
2 | #include "fio.h" | |
3 | #include "fmt.h" | |
4 | #include "fp.h" | |
5 | ||
6 | extern int f__cursor; | |
7 | #ifdef KR_headers | |
8 | extern double atof(); | |
9 | #else | |
10 | #undef abs | |
11 | #undef min | |
12 | #undef max | |
13 | #include "stdlib.h" | |
14 | #endif | |
15 | ||
16 | static int | |
17 | #ifdef KR_headers | |
18 | rd_Z(n,w,len) Uint *n; ftnlen len; | |
19 | #else | |
20 | rd_Z(Uint *n, int w, ftnlen len) | |
21 | #endif | |
22 | { | |
23 | long x[9]; | |
24 | char *s, *s0, *s1, *se, *t; | |
25 | int ch, i, w1, w2; | |
26 | static char hex[256]; | |
27 | static int one = 1; | |
28 | int bad = 0; | |
29 | ||
30 | if (!hex['0']) { | |
31 | s = "0123456789"; | |
32 | while(ch = *s++) | |
33 | hex[ch] = ch - '0' + 1; | |
34 | s = "ABCDEF"; | |
35 | while(ch = *s++) | |
36 | hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11; | |
37 | } | |
38 | s = s0 = (char *)x; | |
39 | s1 = (char *)&x[4]; | |
40 | se = (char *)&x[8]; | |
41 | if (len > 4*sizeof(long)) | |
42 | return errno = 117; | |
43 | while (w) { | |
44 | GET(ch); | |
45 | if (ch==',' || ch=='\n') | |
46 | break; | |
47 | w--; | |
48 | if (ch > ' ') { | |
49 | if (!hex[ch & 0xff]) | |
50 | bad++; | |
51 | *s++ = ch; | |
52 | if (s == se) { | |
53 | /* discard excess characters */ | |
54 | for(t = s0, s = s1; t < s1;) | |
55 | *t++ = *s++; | |
56 | s = s1; | |
57 | } | |
58 | } | |
59 | } | |
60 | if (bad) | |
61 | return errno = 115; | |
62 | w = (int)len; | |
63 | w1 = s - s0; | |
64 | w2 = w1+1 >> 1; | |
65 | t = (char *)n; | |
66 | if (*(char *)&one) { | |
67 | /* little endian */ | |
68 | t += w - 1; | |
69 | i = -1; | |
70 | } | |
71 | else | |
72 | i = 1; | |
73 | for(; w > w2; t += i, --w) | |
74 | *t = 0; | |
75 | if (!w) | |
76 | return 0; | |
77 | if (w < w2) | |
78 | s0 = s - (w << 1); | |
79 | else if (w1 & 1) { | |
80 | *t = hex[*s0++ & 0xff] - 1; | |
81 | if (!--w) | |
82 | return 0; | |
83 | t += i; | |
84 | } | |
85 | do { | |
86 | *t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1; | |
87 | t += i; | |
88 | s0 += 2; | |
89 | } | |
90 | while(--w); | |
91 | return 0; | |
92 | } | |
93 | ||
94 | static int | |
95 | #ifdef KR_headers | |
96 | rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base; | |
97 | #else | |
98 | rd_I(Uint *n, int w, ftnlen len, register int base) | |
99 | #endif | |
100 | { long x; | |
101 | int sign,ch; | |
102 | char s[84], *ps; | |
103 | ps=s; x=0; | |
104 | while (w) | |
105 | { | |
106 | GET(ch); | |
107 | if (ch==',' || ch=='\n') break; | |
108 | *ps=ch; ps++; w--; | |
109 | } | |
110 | *ps='\0'; | |
111 | ps=s; | |
112 | while (*ps==' ') ps++; | |
113 | if (*ps=='-') { sign=1; ps++; } | |
114 | else { sign=0; if (*ps=='+') ps++; } | |
115 | loop: while (*ps>='0' && *ps<='9') { x=x*base+(*ps-'0'); ps++; } | |
116 | if (*ps==' ') {if (f__cblank) x *= base; ps++; goto loop;} | |
117 | if(sign) x = -x; | |
118 | if(len==sizeof(integer)) n->il=x; | |
119 | else if(len == sizeof(char)) n->ic = (char)x; | |
120 | #ifdef Allow_TYQUAD | |
121 | else if (len == sizeof(longint)) n->ili = x; | |
122 | #endif | |
123 | else n->is = (short)x; | |
124 | if (*ps) return(errno=115); else return(0); | |
125 | } | |
126 | static int | |
127 | #ifdef KR_headers | |
128 | rd_L(n,w,len) ftnint *n; ftnlen len; | |
129 | #else | |
130 | rd_L(ftnint *n, int w, ftnlen len) | |
131 | #endif | |
132 | { int ch, lv; | |
133 | char s[84], *ps; | |
134 | ps=s; | |
135 | while (w) { | |
136 | GET(ch); | |
137 | if (ch==','||ch=='\n') break; | |
138 | *ps=ch; | |
139 | ps++; w--; | |
140 | } | |
141 | *ps='\0'; | |
142 | ps=s; while (*ps==' ') ps++; | |
143 | if (*ps=='.') ps++; | |
144 | if (*ps=='t' || *ps == 'T') | |
145 | lv = 1; | |
146 | else if (*ps == 'f' || *ps == 'F') | |
147 | lv = 0; | |
148 | else return(errno=116); | |
149 | switch(len) { | |
150 | case sizeof(char): *(char *)n = (char)lv; break; | |
151 | case sizeof(short): *(short *)n = (short)lv; break; | |
152 | default: *n = lv; | |
153 | } | |
154 | return 0; | |
155 | } | |
156 | ||
157 | #include "ctype.h" | |
158 | ||
159 | static int | |
160 | #ifdef KR_headers | |
161 | rd_F(p, w, d, len) ufloat *p; ftnlen len; | |
162 | #else | |
163 | rd_F(ufloat *p, int w, int d, ftnlen len) | |
164 | #endif | |
165 | { | |
166 | char s[FMAX+EXPMAXDIGS+4]; | |
167 | register int ch; | |
168 | register char *sp, *spe, *sp1; | |
169 | double x; | |
170 | int scale1, se; | |
171 | long e, exp; | |
172 | ||
173 | sp1 = sp = s; | |
174 | spe = sp + FMAX; | |
175 | exp = -d; | |
176 | x = 0.; | |
177 | ||
178 | do { | |
179 | GET(ch); | |
180 | w--; | |
181 | } while (ch == ' ' && w); | |
182 | switch(ch) { | |
183 | case '-': *sp++ = ch; sp1++; spe++; | |
184 | case '+': | |
185 | if (!w) goto zero; | |
186 | --w; | |
187 | GET(ch); | |
188 | } | |
189 | while(ch == ' ') { | |
190 | blankdrop: | |
191 | if (!w--) goto zero; GET(ch); } | |
192 | while(ch == '0') | |
193 | { if (!w--) goto zero; GET(ch); } | |
194 | if (ch == ' ' && f__cblank) | |
195 | goto blankdrop; | |
196 | scale1 = f__scale; | |
197 | while(isdigit(ch)) { | |
198 | digloop1: | |
199 | if (sp < spe) *sp++ = ch; | |
200 | else ++exp; | |
201 | digloop1e: | |
202 | if (!w--) goto done; | |
203 | GET(ch); | |
204 | } | |
205 | if (ch == ' ') { | |
206 | if (f__cblank) | |
207 | { ch = '0'; goto digloop1; } | |
208 | goto digloop1e; | |
209 | } | |
210 | if (ch == '.') { | |
211 | exp += d; | |
212 | if (!w--) goto done; | |
213 | GET(ch); | |
214 | if (sp == sp1) { /* no digits yet */ | |
215 | while(ch == '0') { | |
216 | skip01: | |
217 | --exp; | |
218 | skip0: | |
219 | if (!w--) goto done; | |
220 | GET(ch); | |
221 | } | |
222 | if (ch == ' ') { | |
223 | if (f__cblank) goto skip01; | |
224 | goto skip0; | |
225 | } | |
226 | } | |
227 | while(isdigit(ch)) { | |
228 | digloop2: | |
229 | if (sp < spe) | |
230 | { *sp++ = ch; --exp; } | |
231 | digloop2e: | |
232 | if (!w--) goto done; | |
233 | GET(ch); | |
234 | } | |
235 | if (ch == ' ') { | |
236 | if (f__cblank) | |
237 | { ch = '0'; goto digloop2; } | |
238 | goto digloop2e; | |
239 | } | |
240 | } | |
241 | switch(ch) { | |
242 | default: | |
243 | break; | |
244 | case '-': se = 1; goto signonly; | |
245 | case '+': se = 0; goto signonly; | |
246 | case 'e': | |
247 | case 'E': | |
248 | case 'd': | |
249 | case 'D': | |
250 | if (!w--) | |
251 | goto bad; | |
252 | GET(ch); | |
253 | while(ch == ' ') { | |
254 | if (!w--) | |
255 | goto bad; | |
256 | GET(ch); | |
257 | } | |
258 | se = 0; | |
259 | switch(ch) { | |
260 | case '-': se = 1; | |
261 | case '+': | |
262 | signonly: | |
263 | if (!w--) | |
264 | goto bad; | |
265 | GET(ch); | |
266 | } | |
267 | while(ch == ' ') { | |
268 | if (!w--) | |
269 | goto bad; | |
270 | GET(ch); | |
271 | } | |
272 | if (!isdigit(ch)) | |
273 | goto bad; | |
274 | ||
275 | e = ch - '0'; | |
276 | for(;;) { | |
277 | if (!w--) | |
278 | { ch = '\n'; break; } | |
279 | GET(ch); | |
280 | if (!isdigit(ch)) { | |
281 | if (ch == ' ') { | |
282 | if (f__cblank) | |
283 | ch = '0'; | |
284 | else continue; | |
285 | } | |
286 | else | |
287 | break; | |
288 | } | |
289 | e = 10*e + ch - '0'; | |
290 | if (e > EXPMAX && sp > sp1) | |
291 | goto bad; | |
292 | } | |
293 | if (se) | |
294 | exp -= e; | |
295 | else | |
296 | exp += e; | |
297 | scale1 = 0; | |
298 | } | |
299 | switch(ch) { | |
300 | case '\n': | |
301 | case ',': | |
302 | break; | |
303 | default: | |
304 | bad: | |
305 | return (errno = 115); | |
306 | } | |
307 | done: | |
308 | if (sp > sp1) { | |
309 | while(*--sp == '0') | |
310 | ++exp; | |
311 | if (exp -= scale1) | |
312 | sprintf(sp+1, "e%ld", exp); | |
313 | else | |
314 | sp[1] = 0; | |
315 | x = atof(s); | |
316 | } | |
317 | zero: | |
318 | if (len == sizeof(real)) | |
319 | p->pf = x; | |
320 | else | |
321 | p->pd = x; | |
322 | return(0); | |
323 | } | |
324 | ||
325 | ||
326 | static int | |
327 | #ifdef KR_headers | |
328 | rd_A(p,len) char *p; ftnlen len; | |
329 | #else | |
330 | rd_A(char *p, ftnlen len) | |
331 | #endif | |
332 | { int i,ch; | |
333 | for(i=0;i<len;i++) | |
334 | { GET(ch); | |
335 | *p++=VAL(ch); | |
336 | } | |
337 | return(0); | |
338 | } | |
339 | static int | |
340 | #ifdef KR_headers | |
341 | rd_AW(p,w,len) char *p; ftnlen len; | |
342 | #else | |
343 | rd_AW(char *p, int w, ftnlen len) | |
344 | #endif | |
345 | { int i,ch; | |
346 | if(w>=len) | |
347 | { for(i=0;i<w-len;i++) | |
348 | GET(ch); | |
349 | for(i=0;i<len;i++) | |
350 | { GET(ch); | |
351 | *p++=VAL(ch); | |
352 | } | |
353 | return(0); | |
354 | } | |
355 | for(i=0;i<w;i++) | |
356 | { GET(ch); | |
357 | *p++=VAL(ch); | |
358 | } | |
359 | for(i=0;i<len-w;i++) *p++=' '; | |
360 | return(0); | |
361 | } | |
362 | static int | |
363 | #ifdef KR_headers | |
364 | rd_H(n,s) char *s; | |
365 | #else | |
366 | rd_H(int n, char *s) | |
367 | #endif | |
368 | { int i,ch; | |
369 | for(i=0;i<n;i++) | |
370 | if((ch=(*f__getn)())<0) return(ch); | |
371 | else *s++ = ch=='\n'?' ':ch; | |
372 | return(1); | |
373 | } | |
374 | static int | |
375 | #ifdef KR_headers | |
376 | rd_POS(s) char *s; | |
377 | #else | |
378 | rd_POS(char *s) | |
379 | #endif | |
380 | { char quote; | |
381 | int ch; | |
382 | quote= *s++; | |
383 | for(;*s;s++) | |
384 | if(*s==quote && *(s+1)!=quote) break; | |
385 | else if((ch=(*f__getn)())<0) return(ch); | |
386 | else *s = ch=='\n'?' ':ch; | |
387 | return(1); | |
388 | } | |
389 | #ifdef KR_headers | |
390 | rd_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len; | |
391 | #else | |
392 | rd_ed(struct syl *p, char *ptr, ftnlen len) | |
393 | #endif | |
394 | { int ch; | |
395 | for(;f__cursor>0;f__cursor--) if((ch=(*f__getn)())<0) return(ch); | |
396 | if(f__cursor<0) | |
397 | { if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/ | |
398 | f__cursor = -f__recpos; /* is this in the standard? */ | |
399 | if(f__external == 0) { | |
400 | extern char *f__icptr; | |
401 | f__icptr += f__cursor; | |
402 | } | |
403 | else if(f__curunit && f__curunit->useek) | |
404 | (void) fseek(f__cf,(long) f__cursor,SEEK_CUR); | |
405 | else | |
406 | err(f__elist->cierr,106,"fmt"); | |
407 | f__recpos += f__cursor; | |
408 | f__cursor=0; | |
409 | } | |
410 | switch(p->op) | |
411 | { | |
412 | default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op); | |
413 | sig_die(f__fmtbuf, 1); | |
414 | case IM: | |
415 | case I: ch = rd_I((Uint *)ptr,p->p1,len, 10); | |
416 | break; | |
417 | ||
418 | /* O and OM don't work right for character, double, complex, */ | |
419 | /* or doublecomplex, and they differ from Fortran 90 in */ | |
420 | /* showing a minus sign for negative values. */ | |
421 | ||
422 | case OM: | |
423 | case O: ch = rd_I((Uint *)ptr, p->p1, len, 8); | |
424 | break; | |
425 | case L: ch = rd_L((ftnint *)ptr,p->p1,len); | |
426 | break; | |
427 | case A: ch = rd_A(ptr,len); | |
428 | break; | |
429 | case AW: | |
430 | ch = rd_AW(ptr,p->p1,len); | |
431 | break; | |
432 | case E: case EE: | |
433 | case D: | |
434 | case G: | |
435 | case GE: | |
436 | case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2,len); | |
437 | break; | |
438 | ||
439 | /* Z and ZM assume 8-bit bytes. */ | |
440 | ||
441 | case ZM: | |
442 | case Z: | |
443 | ch = rd_Z((Uint *)ptr, p->p1, len); | |
444 | break; | |
445 | } | |
446 | if(ch == 0) return(ch); | |
447 | else if(ch == EOF) return(EOF); | |
448 | if (f__cf) | |
449 | clearerr(f__cf); | |
450 | return(errno); | |
451 | } | |
452 | #ifdef KR_headers | |
453 | rd_ned(p) struct syl *p; | |
454 | #else | |
455 | rd_ned(struct syl *p) | |
456 | #endif | |
457 | { | |
458 | switch(p->op) | |
459 | { | |
460 | default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op); | |
461 | sig_die(f__fmtbuf, 1); | |
462 | case APOS: | |
463 | return(rd_POS(*(char **)&p->p2)); | |
464 | case H: return(rd_H(p->p1,*(char **)&p->p2)); | |
465 | case SLASH: return((*f__donewrec)()); | |
466 | case TR: | |
467 | case X: f__cursor += p->p1; | |
468 | return(1); | |
469 | case T: f__cursor=p->p1-f__recpos - 1; | |
470 | return(1); | |
471 | case TL: f__cursor -= p->p1; | |
472 | if(f__cursor < -f__recpos) /* TL1000, 1X */ | |
473 | f__cursor = -f__recpos; | |
474 | return(1); | |
475 | } | |
476 | } |