libf2c/libI77/fmt.c

   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 */
  20 extern int f__cursor, f__scale;
  21 extern flag f__cblank, f__cplus;        /*blanks in I and compulsory plus */
  22 static struct syl f__syl[SYLMX];
  23 int f__parenlvl, f__pc, f__revloc;
  24
  25 static char *
  26 ap_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
  46 static int
  47 op_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 }
  61 static char *f_list (char *);
  62 static char *
  63 gt_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
  91 static char *
  92 f_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
 108 static int
 109 ne_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
 231 static int
 232 e_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 }
 366 static char *
 367 i_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
 383 static char *
 384 f_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
 408 int
 409 pars_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
 446 int f__cnt[STKSZ], f__ret[STKSZ], f__cp, f__rp;
 447 flag f__workdone, f__nonl;
 448
 449 static int
 450 type_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 }
 490 integer
 491 do_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
 590 int
 591 en_fio (void)
 592 {
 593   ftnint one = 1;
 594   return (do_fio (&one, (char *) NULL, (ftnint) 0));
 595 }
 596
 597 void
 598 fmt_bg (void)
 599 {
 600   f__workdone = f__cp = f__rp = f__pc = f__cursor = 0;
 601   f__cnt[0] = f__ret[0] = 0;
 602 }