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