1 #include "f2c.h"
2 #include "fio.h"
3
4 extern int f__cursor;
5 #ifdef KR_headers
6 extern double atof();
7 #else
8 #undef abs
9 #undef min
10 #undef max
11 #include "stdlib.h"
12 #endif
13
14 #include "fmt.h"
15 #include "fp.h"
16 #include "ctype.h"
17
18 static int
19 #ifdef KR_headers
rd_Z(n,w,len)20 rd_Z(n,w,len) Uint *n; ftnlen len;
21 #else
22 rd_Z(Uint *n, int w, ftnlen len)
23 #endif
24 {
25 long x[9];
26 char *s, *s0, *s1, *se, *t;
27 int ch, i, w1, w2;
28 static char hex[256];
29 static int one = 1;
30 int bad = 0;
31
32 if (!hex['0']) {
33 s = "0123456789";
34 while(ch = *s++)
35 hex[ch] = ch - '0' + 1;
36 s = "ABCDEF";
37 while(ch = *s++)
38 hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11;
39 }
40 s = s0 = (char *)x;
41 s1 = (char *)&x[4];
42 se = (char *)&x[8];
43 if (len > 4*sizeof(long))
44 return errno = 117;
45 while (w) {
46 GET(ch);
47 if (ch==',' || ch=='\n')
48 break;
49 w--;
50 if (ch > ' ') {
51 if (!hex[ch & 0xff])
52 bad++;
53 *s++ = ch;
54 if (s == se) {
55 /* discard excess characters */
56 for(t = s0, s = s1; t < s1;)
57 *t++ = *s++;
58 s = s1;
59 }
60 }
61 }
62 if (bad)
63 return errno = 115;
64 w = (int)len;
65 w1 = s - s0;
66 w2 = w1+1 >> 1;
67 t = (char *)n;
68 if (*(char *)&one) {
69 /* little endian */
70 t += w - 1;
71 i = -1;
72 }
73 else
74 i = 1;
75 for(; w > w2; t += i, --w)
76 *t = 0;
77 if (!w)
78 return 0;
79 if (w < w2)
80 s0 = s - (w << 1);
81 else if (w1 & 1) {
82 *t = hex[*s0++ & 0xff] - 1;
83 if (!--w)
84 return 0;
85 t += i;
86 }
87 do {
88 *t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1;
89 t += i;
90 s0 += 2;
91 }
92 while(--w);
93 return 0;
94 }
95
96 static int
97 #ifdef KR_headers
rd_I(n,w,len,base)98 rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base;
99 #else
100 rd_I(Uint *n, int w, ftnlen len, register int base)
101 #endif
102 { longint x;
103 int sign,ch;
104 char s[84], *ps;
105 ps=s; x=0;
106 while (w)
107 {
108 GET(ch);
109 if (ch==',' || ch=='\n') break;
110 *ps=ch; ps++; w--;
111 }
112 *ps='\0';
113 ps=s;
114 while (*ps==' ') ps++;
115 if (*ps=='-') { sign=1; ps++; }
116 else { sign=0; if (*ps=='+') ps++; }
117 loop: while (*ps>='0' && *ps<='9') { x=x*base+(*ps-'0'); ps++; }
118 if (*ps==' ') {if (f__cblank) x *= base; ps++; goto loop;}
119 if(sign) x = -x;
120 if(len==sizeof(integer)) n->il=x;
121 else if(len == sizeof(char)) n->ic = (char)x;
122 #ifdef Allow_TYQUAD
123 else if (len == sizeof(longint)) n->ili = x;
124 #endif
125 else n->is = (short)x;
126 if (*ps) return(errno=115); else return(0);
127 }
128 static int
129 #ifdef KR_headers
rd_L(n,w,len)130 rd_L(n,w,len) ftnint *n; ftnlen len;
131 #else
132 rd_L(ftnint *n, int w, ftnlen len)
133 #endif
134 { int ch, lv;
135 char s[84], *ps;
136 ps=s;
137 while (w) {
138 GET(ch);
139 if (ch==','||ch=='\n') break;
140 *ps=ch;
141 ps++; w--;
142 }
143 *ps='\0';
144 ps=s; while (*ps==' ') ps++;
145 if (*ps=='.') ps++;
146 if (*ps=='t' || *ps == 'T')
147 lv = 1;
148 else if (*ps == 'f' || *ps == 'F')
149 lv = 0;
150 else return(errno=116);
151 switch(len) {
152 case sizeof(char): *(char *)n = (char)lv; break;
153 case sizeof(short): *(short *)n = (short)lv; break;
154 default: *n = lv;
155 }
156 return 0;
157 }
158
159 static int
160 #ifdef KR_headers
rd_F(p,w,d,len)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
rd_A(p,len)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
rd_AW(p,w,len)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
rd_H(n,s)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
rd_POS(s)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
rd_ed(struct syl * p,char * ptr,ftnlen len)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.i[0],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
rd_ned(struct syl * p)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(p->p2.s));
464 case H: return(rd_H(p->p1,p->p2.s));
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 }
477