source: trunk/gcc/libf2c/libI77/fmt.c@ 3830

Last change on this file since 3830 was 1392, checked in by bird, 22 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: 10.0 KB
Line 
1#include "config.h"
2#include "f2c.h"
3#include "fio.h"
4#include "fmt.h"
5#define skip(s) while(*s==' ') s++
6#ifdef interdata
7#define SYLMX 300
8#endif
9#ifdef pdp11
10#define SYLMX 300
11#endif
12#ifdef vax
13#define SYLMX 300
14#endif
15#ifndef SYLMX
16#define SYLMX 300
17#endif
18#define GLITCH '\2'
19 /* special quote character for stu */
20extern int f__cursor, f__scale;
21extern flag f__cblank, f__cplus; /*blanks in I and compulsory plus */
22static struct syl f__syl[SYLMX];
23int f__parenlvl, f__pc, f__revloc;
24
25static char *
26ap_end (char *s)
27{
28 char quote;
29 quote = *s++;
30 for (; *s; s++)
31 {
32 if (*s != quote)
33 continue;
34 if (*++s != quote)
35 return (s);
36 }
37 if (f__elist->cierr)
38 {
39 errno = 100;
40 return (NULL);
41 }
42 f__fatal (100, "bad string");
43 /*NOTREACHED*/ return 0;
44}
45
46static int
47op_gen (int a, int b, int c, int d)
48{
49 struct syl *p = &f__syl[f__pc];
50 if (f__pc >= SYLMX)
51 {
52 fprintf (stderr, "format too complicated:\n");
53 sig_die (f__fmtbuf, 1);
54 }
55 p->op = a;
56 p->p1 = b;
57 p->p2.i[0] = c;
58 p->p2.i[1] = d;
59 return (f__pc++);
60}
61static char *f_list (char *);
62static char *
63gt_num (char *s, int *n, int n1)
64{
65 int m = 0, f__cnt = 0;
66 char c;
67 for (c = *s;; c = *s)
68 {
69 if (c == ' ')
70 {
71 s++;
72 continue;
73 }
74 if (c > '9' || c < '0')
75 break;
76 m = 10 * m + c - '0';
77 f__cnt++;
78 s++;
79 }
80 if (f__cnt == 0)
81 {
82 if (!n1)
83 s = 0;
84 *n = n1;
85 }
86 else
87 *n = m;
88 return (s);
89}
90
91static char *
92f_s (char *s, int curloc)
93{
94 skip (s);
95 if (*s++ != '(')
96 {
97 return (NULL);
98 }
99 if (f__parenlvl++ == 1)
100 f__revloc = curloc;
101 if (op_gen (RET1, curloc, 0, 0) < 0 || (s = f_list (s)) == NULL)
102 {
103 return (NULL);
104 }
105 return (s);
106}
107
108static int
109ne_d (char *s, char **p)
110{
111 int n, x, sign = 0;
112 struct syl *sp;
113 switch (*s)
114 {
115 default:
116 return (0);
117 case ':':
118 (void) op_gen (COLON, 0, 0, 0);
119 break;
120 case '$':
121 (void) op_gen (NONL, 0, 0, 0);
122 break;
123 case 'B':
124 case 'b':
125 if (*++s == 'z' || *s == 'Z')
126 (void) op_gen (BZ, 0, 0, 0);
127 else
128 (void) op_gen (BN, 0, 0, 0);
129 break;
130 case 'S':
131 case 's':
132 if (*(s + 1) == 's' || *(s + 1) == 'S')
133 {
134 x = SS;
135 s++;
136 }
137 else if (*(s + 1) == 'p' || *(s + 1) == 'P')
138 {
139 x = SP;
140 s++;
141 }
142 else
143 x = S;
144 (void) op_gen (x, 0, 0, 0);
145 break;
146 case '/':
147 (void) op_gen (SLASH, 0, 0, 0);
148 break;
149 case '-':
150 sign = 1;
151 case '+':
152 s++; /*OUTRAGEOUS CODING TRICK */
153 case '0':
154 case '1':
155 case '2':
156 case '3':
157 case '4':
158 case '5':
159 case '6':
160 case '7':
161 case '8':
162 case '9':
163 if (!(s = gt_num (s, &n, 0)))
164 {
165 bad:*p = 0;
166 return 1;
167 }
168 switch (*s)
169 {
170 default:
171 return (0);
172 case 'P':
173 case 'p':
174 if (sign)
175 n = -n;
176 (void) op_gen (P, n, 0, 0);
177 break;
178 case 'X':
179 case 'x':
180 (void) op_gen (X, n, 0, 0);
181 break;
182 case 'H':
183 case 'h':
184 sp = &f__syl[op_gen (H, n, 0, 0)];
185 sp->p2.s = s + 1;
186 s += n;
187 break;
188 }
189 break;
190 case GLITCH:
191 case '"':
192 case '\'':
193 sp = &f__syl[op_gen (APOS, 0, 0, 0)];
194 sp->p2.s = s;
195 if ((*p = ap_end (s)) == NULL)
196 return (0);
197 return (1);
198 case 'T':
199 case 't':
200 if (*(s + 1) == 'l' || *(s + 1) == 'L')
201 {
202 x = TL;
203 s++;
204 }
205 else if (*(s + 1) == 'r' || *(s + 1) == 'R')
206 {
207 x = TR;
208 s++;
209 }
210 else
211 x = T;
212 if (!(s = gt_num (s + 1, &n, 0)))
213 goto bad;
214 s--;
215 (void) op_gen (x, n, 0, 0);
216 break;
217 case 'X':
218 case 'x':
219 (void) op_gen (X, 1, 0, 0);
220 break;
221 case 'P':
222 case 'p':
223 (void) op_gen (P, 1, 0, 0);
224 break;
225 }
226 s++;
227 *p = s;
228 return (1);
229}
230
231static int
232e_d (char *s, char **p)
233{
234 int i, im, n, w, d, e, found = 0, x = 0;
235 char *sv = s;
236 s = gt_num (s, &n, 1);
237 (void) op_gen (STACK, n, 0, 0);
238 switch (*s++)
239 {
240 default:
241 break;
242 case 'E':
243 case 'e':
244 x = 1;
245 case 'G':
246 case 'g':
247 found = 1;
248 if (!(s = gt_num (s, &w, 0)))
249 {
250 bad:
251 *p = 0;
252 return 1;
253 }
254 if (w == 0)
255 break;
256 if (*s == '.')
257 {
258 if (!(s = gt_num (s + 1, &d, 0)))
259 goto bad;
260 }
261 else
262 d = 0;
263 if (*s != 'E' && *s != 'e')
264 (void) op_gen (x == 1 ? E : G, w, d, 0); /* default is Ew.dE2 */
265 else
266 {
267 if (!(s = gt_num (s + 1, &e, 0)))
268 goto bad;
269 (void) op_gen (x == 1 ? EE : GE, w, d, e);
270 }
271 break;
272 case 'O':
273 case 'o':
274 i = O;
275 im = OM;
276 goto finish_I;
277 case 'Z':
278 case 'z':
279 i = Z;
280 im = ZM;
281 goto finish_I;
282 case 'L':
283 case 'l':
284 found = 1;
285 if (!(s = gt_num (s, &w, 0)))
286 goto bad;
287 if (w == 0)
288 break;
289 (void) op_gen (L, w, 0, 0);
290 break;
291 case 'A':
292 case 'a':
293 found = 1;
294 skip (s);
295 if (*s >= '0' && *s <= '9')
296 {
297 s = gt_num (s, &w, 1);
298 if (w == 0)
299 break;
300 (void) op_gen (AW, w, 0, 0);
301 break;
302 }
303 (void) op_gen (A, 0, 0, 0);
304 break;
305 case 'F':
306 case 'f':
307 if (!(s = gt_num (s, &w, 0)))
308 goto bad;
309 found = 1;
310 if (w == 0)
311 break;
312 if (*s == '.')
313 {
314 if (!(s = gt_num (s + 1, &d, 0)))
315 goto bad;
316 }
317 else
318 d = 0;
319 (void) op_gen (F, w, d, 0);
320 break;
321 case 'D':
322 case 'd':
323 found = 1;
324 if (!(s = gt_num (s, &w, 0)))
325 goto bad;
326 if (w == 0)
327 break;
328 if (*s == '.')
329 {
330 if (!(s = gt_num (s + 1, &d, 0)))
331 goto bad;
332 }
333 else
334 d = 0;
335 (void) op_gen (D, w, d, 0);
336 break;
337 case 'I':
338 case 'i':
339 i = I;
340 im = IM;
341 finish_I:
342 if (!(s = gt_num (s, &w, 0)))
343 goto bad;
344 found = 1;
345 if (w == 0)
346 break;
347 if (*s != '.')
348 {
349 (void) op_gen (i, w, 0, 0);
350 break;
351 }
352 if (!(s = gt_num (s + 1, &d, 0)))
353 goto bad;
354 (void) op_gen (im, w, d, 0);
355 break;
356 }
357 if (found == 0)
358 {
359 f__pc--; /*unSTACK */
360 *p = sv;
361 return (0);
362 }
363 *p = s;
364 return (1);
365}
366static char *
367i_tem (char *s)
368{
369 char *t;
370 int n, curloc;
371 if (*s == ')')
372 return (s);
373 if (ne_d (s, &t))
374 return (t);
375 if (e_d (s, &t))
376 return (t);
377 s = gt_num (s, &n, 1);
378 if ((curloc = op_gen (STACK, n, 0, 0)) < 0)
379 return (NULL);
380 return (f_s (s, curloc));
381}
382
383static char *
384f_list (char *s)
385{
386 for (; *s != 0;)
387 {
388 skip (s);
389 if ((s = i_tem (s)) == NULL)
390 return (NULL);
391 skip (s);
392 if (*s == ',')
393 s++;
394 else if (*s == ')')
395 {
396 if (--f__parenlvl == 0)
397 {
398 (void) op_gen (REVERT, f__revloc, 0, 0);
399 return (++s);
400 }
401 (void) op_gen (GOTO, 0, 0, 0);
402 return (++s);
403 }
404 }
405 return (NULL);
406}
407
408int
409pars_f (char *s)
410{
411 char *e;
412
413 f__parenlvl = f__revloc = f__pc = 0;
414 if ((e = f_s (s, 0)) == NULL)
415 {
416 /* Try and delimit the format string. Parens within
417 hollerith and quoted strings have to match for this
418 to work, but it's probably adequate for most needs.
419 Note that this is needed because a valid CHARACTER
420 variable passed for FMT= can contain '(I)garbage',
421 where `garbage' is billions and billions of junk
422 characters, and it's up to the run-time library to
423 know where the format string ends by counting parens.
424 Meanwhile, still treat NUL byte as "hard stop", since
425 f2c still appends that at end of FORMAT-statement
426 strings. */
427
428 int level = 0;
429
430 for (f__fmtlen = 0;
431 ((*s != ')') || (--level > 0))
432 && (*s != '\0') && (f__fmtlen < 80); ++s, ++f__fmtlen)
433 {
434 if (*s == '(')
435 ++level;
436 }
437 if (*s == ')')
438 ++f__fmtlen;
439 return (-1);
440 }
441 f__fmtlen = e - s;
442 return (0);
443}
444
445#define STKSZ 10
446int f__cnt[STKSZ], f__ret[STKSZ], f__cp, f__rp;
447flag f__workdone, f__nonl;
448
449static int
450type_f (int n)
451{
452 switch (n)
453 {
454 default:
455 return (n);
456 case RET1:
457 return (RET1);
458 case REVERT:
459 return (REVERT);
460 case GOTO:
461 return (GOTO);
462 case STACK:
463 return (STACK);
464 case X:
465 case SLASH:
466 case APOS:
467 case H:
468 case T:
469 case TL:
470 case TR:
471 return (NED);
472 case F:
473 case I:
474 case IM:
475 case A:
476 case AW:
477 case O:
478 case OM:
479 case L:
480 case E:
481 case EE:
482 case D:
483 case G:
484 case GE:
485 case Z:
486 case ZM:
487 return (ED);
488 }
489}
490integer
491do_fio (ftnint * number, char *ptr, ftnlen len)
492{
493 struct syl *p;
494 int n, i;
495 for (i = 0; i < *number; i++, ptr += len)
496 {
497 loop:switch (type_f ((p = &f__syl[f__pc])->op))
498 {
499 default:
500 fprintf (stderr, "unknown code in do_fio: %d\n%.*s\n",
501 p->op, f__fmtlen, f__fmtbuf);
502 err (f__elist->cierr, 100, "do_fio");
503 case NED:
504 if ((*f__doned) (p))
505 {
506 f__pc++;
507 goto loop;
508 }
509 f__pc++;
510 continue;
511 case ED:
512 if (f__cnt[f__cp] <= 0)
513 {
514 f__cp--;
515 f__pc++;
516 goto loop;
517 }
518 if (ptr == NULL)
519 return ((*f__doend) ());
520 f__cnt[f__cp]--;
521 f__workdone = 1;
522 if ((n = (*f__doed) (p, ptr, len)) > 0)
523 errfl (f__elist->cierr, errno, "fmt");
524 if (n < 0)
525 err (f__elist->ciend, (EOF), "fmt");
526 continue;
527 case STACK:
528 f__cnt[++f__cp] = p->p1;
529 f__pc++;
530 goto loop;
531 case RET1:
532 f__ret[++f__rp] = p->p1;
533 f__pc++;
534 goto loop;
535 case GOTO:
536 if (--f__cnt[f__cp] <= 0)
537 {
538 f__cp--;
539 f__rp--;
540 f__pc++;
541 goto loop;
542 }
543 f__pc = 1 + f__ret[f__rp--];
544 goto loop;
545 case REVERT:
546 f__rp = f__cp = 0;
547 f__pc = p->p1;
548 if (ptr == NULL)
549 return ((*f__doend) ());
550 if (!f__workdone)
551 return (0);
552 if ((n = (*f__dorevert) ()) != 0)
553 return (n);
554 goto loop;
555 case COLON:
556 if (ptr == NULL)
557 return ((*f__doend) ());
558 f__pc++;
559 goto loop;
560 case NONL:
561 f__nonl = 1;
562 f__pc++;
563 goto loop;
564 case S:
565 case SS:
566 f__cplus = 0;
567 f__pc++;
568 goto loop;
569 case SP:
570 f__cplus = 1;
571 f__pc++;
572 goto loop;
573 case P:
574 f__scale = p->p1;
575 f__pc++;
576 goto loop;
577 case BN:
578 f__cblank = 0;
579 f__pc++;
580 goto loop;
581 case BZ:
582 f__cblank = 1;
583 f__pc++;
584 goto loop;
585 }
586 }
587 return (0);
588}
589
590int
591en_fio (void)
592{
593 ftnint one = 1;
594 return (do_fio (&one, (char *) NULL, (ftnint) 0));
595}
596
597void
598fmt_bg (void)
599{
600 f__workdone = f__cp = f__rp = f__pc = f__cursor = 0;
601 f__cnt[0] = f__ret[0] = 0;
602}
Note: See TracBrowser for help on using the repository browser.