source: branches/libc-0.6/src/gcc/libf2c/libI77/rdfmt.c

Last change on this file was 1392, checked in by bird, 21 years ago

This commit was generated by cvs2svn to compensate for changes in r1391,
which included commits to RCS files with non-trunk default branches.

  • Property cvs2svn:cvs-rev set to 1.1.1.2
  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 9.5 KB
Line 
1#include "config.h"
2#include <ctype.h>
3#include "f2c.h"
4#include "fio.h"
5
6extern int f__cursor;
7#undef abs
8#undef min
9#undef max
10#include <stdlib.h>
11
12#include "fmt.h"
13#include "fp.h"
14
15static int
16rd_Z (Uint * n, int w, ftnlen len)
17{
18 long x[9];
19 char *s, *s0, *s1, *se, *t;
20 int ch, i, w1, w2;
21 static char hex[256];
22 static int one = 1;
23 int bad = 0;
24
25 if (!hex['0'])
26 {
27 s = "0123456789";
28 while ((ch = *s++))
29 hex[ch] = ch - '0' + 1;
30 s = "ABCDEF";
31 while ((ch = *s++))
32 hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11;
33 }
34 s = s0 = (char *) x;
35 s1 = (char *) &x[4];
36 se = (char *) &x[8];
37 if (len > 4 * (ftnlen) sizeof (long))
38 return errno = 117;
39 while (w)
40 {
41 GET (ch);
42 if (ch == ',' || ch == '\n')
43 break;
44 w--;
45 if (ch > ' ')
46 {
47 if (!hex[ch & 0xff])
48 bad++;
49 *s++ = ch;
50 if (s == se)
51 {
52 /* discard excess characters */
53 for (t = s0, s = s1; t < s1;)
54 *t++ = *s++;
55 s = s1;
56 }
57 }
58 }
59 if (bad)
60 return errno = 115;
61 w = (int) len;
62 w1 = s - s0;
63 w2 = (w1 + 1) >> 1;
64 t = (char *) n;
65 if (*(char *) &one)
66 {
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 {
81 *t = hex[*s0++ & 0xff] - 1;
82 if (!--w)
83 return 0;
84 t += i;
85 }
86 do
87 {
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
96static int
97rd_I (Uint * n, int w, ftnlen len, register int base)
98{
99 int ch, sign;
100 longint x = 0;
101
102 if (w <= 0)
103 goto have_x;
104 for (;;)
105 {
106 GET (ch);
107 if (ch != ' ')
108 break;
109 if (!--w)
110 goto have_x;
111 }
112 sign = 0;
113 switch (ch)
114 {
115 case ',':
116 case '\n':
117 w = 0;
118 goto have_x;
119 case '-':
120 sign = 1;
121 case '+':
122 break;
123 default:
124 if (ch >= '0' && ch <= '9')
125 {
126 x = ch - '0';
127 break;
128 }
129 goto have_x;
130 }
131 while (--w)
132 {
133 GET (ch);
134 if (ch >= '0' && ch <= '9')
135 {
136 x = x * base + ch - '0';
137 continue;
138 }
139 if (ch != ' ')
140 {
141 if (ch == '\n' || ch == ',')
142 w = 0;
143 break;
144 }
145 if (f__cblank)
146 x *= base;
147 }
148 if (sign)
149 x = -x;
150have_x:
151 if (len == sizeof (integer))
152 n->il = x;
153 else if (len == sizeof (char))
154 n->ic = (char) x;
155#ifdef Allow_TYQUAD
156 else if (len == sizeof (longint))
157 n->ili = x;
158#endif
159 else
160 n->is = (short) x;
161 if (w)
162 {
163 while (--w)
164 GET (ch);
165 return errno = 115;
166 }
167 return 0;
168}
169
170static int
171rd_L (ftnint * n, int w, ftnlen len)
172{
173 int ch, dot, lv;
174
175 if (w <= 0)
176 goto bad;
177 for (;;)
178 {
179 GET (ch);
180 --w;
181 if (ch != ' ')
182 break;
183 if (!w)
184 goto bad;
185 }
186 dot = 0;
187retry:
188 switch (ch)
189 {
190 case '.':
191 if (dot++ || !w)
192 goto bad;
193 GET (ch);
194 --w;
195 goto retry;
196 case 't':
197 case 'T':
198 lv = 1;
199 break;
200 case 'f':
201 case 'F':
202 lv = 0;
203 break;
204 default:
205 bad:
206 for (; w > 0; --w)
207 GET (ch);
208 /* no break */
209 case ',':
210 case '\n':
211 return errno = 116;
212 }
213 /* The switch statement that was here
214 didn't cut it: It broke down for targets
215 where sizeof(char) == sizeof(short). */
216 if (len == sizeof (char))
217 *(char *) n = (char) lv;
218 else if (len == sizeof (short))
219 *(short *) n = (short) lv;
220 else
221 *n = lv;
222 while (w-- > 0)
223 {
224 GET (ch);
225 if (ch == ',' || ch == '\n')
226 break;
227 }
228 return 0;
229}
230
231static int
232rd_F (ufloat * p, int w, int d, ftnlen len)
233{
234 char s[FMAX + EXPMAXDIGS + 4];
235 register int ch;
236 register char *sp, *spe, *sp1;
237 double x;
238 int scale1, se;
239 long e, exp;
240
241 sp1 = sp = s;
242 spe = sp + FMAX;
243 exp = -d;
244 x = 0.;
245
246 do
247 {
248 GET (ch);
249 w--;
250 }
251 while (ch == ' ' && w);
252 switch (ch)
253 {
254 case '-':
255 *sp++ = ch;
256 sp1++;
257 spe++;
258 case '+':
259 if (!w)
260 goto zero;
261 --w;
262 GET (ch);
263 }
264 while (ch == ' ')
265 {
266 blankdrop:
267 if (!w--)
268 goto zero;
269 GET (ch);
270 }
271 while (ch == '0')
272 {
273 if (!w--)
274 goto zero;
275 GET (ch);
276 }
277 if (ch == ' ' && f__cblank)
278 goto blankdrop;
279 scale1 = f__scale;
280 while (isdigit (ch))
281 {
282 digloop1:
283 if (sp < spe)
284 *sp++ = ch;
285 else
286 ++exp;
287 digloop1e:
288 if (!w--)
289 goto done;
290 GET (ch);
291 }
292 if (ch == ' ')
293 {
294 if (f__cblank)
295 {
296 ch = '0';
297 goto digloop1;
298 }
299 goto digloop1e;
300 }
301 if (ch == '.')
302 {
303 exp += d;
304 if (!w--)
305 goto done;
306 GET (ch);
307 if (sp == sp1)
308 { /* no digits yet */
309 while (ch == '0')
310 {
311 skip01:
312 --exp;
313 skip0:
314 if (!w--)
315 goto done;
316 GET (ch);
317 }
318 if (ch == ' ')
319 {
320 if (f__cblank)
321 goto skip01;
322 goto skip0;
323 }
324 }
325 while (isdigit (ch))
326 {
327 digloop2:
328 if (sp < spe)
329 {
330 *sp++ = ch;
331 --exp;
332 }
333 digloop2e:
334 if (!w--)
335 goto done;
336 GET (ch);
337 }
338 if (ch == ' ')
339 {
340 if (f__cblank)
341 {
342 ch = '0';
343 goto digloop2;
344 }
345 goto digloop2e;
346 }
347 }
348 switch (ch)
349 {
350 default:
351 break;
352 case '-':
353 se = 1;
354 goto signonly;
355 case '+':
356 se = 0;
357 goto signonly;
358 case 'e':
359 case 'E':
360 case 'd':
361 case 'D':
362 if (!w--)
363 goto bad;
364 GET (ch);
365 while (ch == ' ')
366 {
367 if (!w--)
368 goto bad;
369 GET (ch);
370 }
371 se = 0;
372 switch (ch)
373 {
374 case '-':
375 se = 1;
376 case '+':
377 signonly:
378 if (!w--)
379 goto bad;
380 GET (ch);
381 }
382 while (ch == ' ')
383 {
384 if (!w--)
385 goto bad;
386 GET (ch);
387 }
388 if (!isdigit (ch))
389 goto bad;
390
391 e = ch - '0';
392 for (;;)
393 {
394 if (!w--)
395 {
396 ch = '\n';
397 break;
398 }
399 GET (ch);
400 if (!isdigit (ch))
401 {
402 if (ch == ' ')
403 {
404 if (f__cblank)
405 ch = '0';
406 else
407 continue;
408 }
409 else
410 break;
411 }
412 e = 10 * e + ch - '0';
413 if (e > EXPMAX && sp > sp1)
414 goto bad;
415 }
416 if (se)
417 exp -= e;
418 else
419 exp += e;
420 scale1 = 0;
421 }
422 switch (ch)
423 {
424 case '\n':
425 case ',':
426 break;
427 default:
428 bad:
429 return (errno = 115);
430 }
431done:
432 if (sp > sp1)
433 {
434 while (*--sp == '0')
435 ++exp;
436 if (exp -= scale1)
437 sprintf (sp + 1, "e%ld", exp);
438 else
439 sp[1] = 0;
440 x = atof (s);
441 }
442zero:
443 if (len == sizeof (real))
444 p->pf = x;
445 else
446 p->pd = x;
447 return (0);
448}
449
450
451static int
452rd_A (char *p, ftnlen len)
453{
454 int i, ch;
455 for (i = 0; i < len; i++)
456 {
457 GET (ch);
458 *p++ = VAL (ch);
459 }
460 return (0);
461}
462static int
463rd_AW (char *p, int w, ftnlen len)
464{
465 int i, ch;
466 if (w >= len)
467 {
468 for (i = 0; i < w - len; i++)
469 GET (ch);
470 for (i = 0; i < len; i++)
471 {
472 GET (ch);
473 *p++ = VAL (ch);
474 }
475 return (0);
476 }
477 for (i = 0; i < w; i++)
478 {
479 GET (ch);
480 *p++ = VAL (ch);
481 }
482 for (i = 0; i < len - w; i++)
483 *p++ = ' ';
484 return (0);
485}
486static int
487rd_H (int n, char *s)
488{
489 int i, ch;
490 for (i = 0; i < n; i++)
491 if ((ch = (*f__getn) ()) < 0)
492 return (ch);
493 else
494 *s++ = ch == '\n' ? ' ' : ch;
495 return (1);
496}
497static int
498rd_POS (char *s)
499{
500 char quote;
501 int ch;
502 quote = *s++;
503 for (; *s; s++)
504 if (*s == quote && *(s + 1) != quote)
505 break;
506 else if ((ch = (*f__getn) ()) < 0)
507 return (ch);
508 else
509 *s = ch == '\n' ? ' ' : ch;
510 return (1);
511}
512
513int
514rd_ed (struct syl * p, char *ptr, ftnlen len)
515{
516 int ch;
517 for (; f__cursor > 0; f__cursor--)
518 if ((ch = (*f__getn) ()) < 0)
519 return (ch);
520 if (f__cursor < 0)
521 {
522 if (f__recpos + f__cursor < 0) /*err(elist->cierr,110,"fmt") */
523 f__cursor = -f__recpos; /* is this in the standard? */
524 if (f__external == 0)
525 {
526 extern char *f__icptr;
527 f__icptr += f__cursor;
528 }
529 else if (f__curunit && f__curunit->useek)
530 FSEEK (f__cf, (off_t) f__cursor, SEEK_CUR);
531 else
532 err (f__elist->cierr, 106, "fmt");
533 f__recpos += f__cursor;
534 f__cursor = 0;
535 }
536 switch (p->op)
537 {
538 default:
539 fprintf (stderr, "rd_ed, unexpected code: %d\n", p->op);
540 sig_die (f__fmtbuf, 1);
541 case IM:
542 case I:
543 ch = rd_I ((Uint *) ptr, p->p1, len, 10);
544 break;
545
546 /* O and OM don't work right for character, double, complex, */
547 /* or doublecomplex, and they differ from Fortran 90 in */
548 /* showing a minus sign for negative values. */
549
550 case OM:
551 case O:
552 ch = rd_I ((Uint *) ptr, p->p1, len, 8);
553 break;
554 case L:
555 ch = rd_L ((ftnint *) ptr, p->p1, len);
556 break;
557 case A:
558 ch = rd_A (ptr, len);
559 break;
560 case AW:
561 ch = rd_AW (ptr, p->p1, len);
562 break;
563 case E:
564 case EE:
565 case D:
566 case G:
567 case GE:
568 case F:
569 ch = rd_F ((ufloat *) ptr, p->p1, p->p2.i[0], len);
570 break;
571
572 /* Z and ZM assume 8-bit bytes. */
573
574 case ZM:
575 case Z:
576 ch = rd_Z ((Uint *) ptr, p->p1, len);
577 break;
578 }
579 if (ch == 0)
580 return (ch);
581 else if (ch == EOF)
582 return (EOF);
583 if (f__cf)
584 clearerr (f__cf);
585 return (errno);
586}
587
588int
589rd_ned (struct syl * p)
590{
591 switch (p->op)
592 {
593 default:
594 fprintf (stderr, "rd_ned, unexpected code: %d\n", p->op);
595 sig_die (f__fmtbuf, 1);
596 case APOS:
597 return (rd_POS (p->p2.s));
598 case H:
599 return (rd_H (p->p1, p->p2.s));
600 case SLASH:
601 return ((*f__donewrec) ());
602 case TR:
603 case X:
604 f__cursor += p->p1;
605 return (1);
606 case T:
607 f__cursor = p->p1 - f__recpos - 1;
608 return (1);
609 case TL:
610 f__cursor -= p->p1;
611 if (f__cursor < -f__recpos) /* TL1000, 1X */
612 f__cursor = -f__recpos;
613 return (1);
614 }
615}
Note: See TracBrowser for help on using the repository browser.