contrib/libf2c/libI77/rdfmt.c

   1 #include "config.h"
   2 #include <ctype.h>
   3 #include "f2c.h"
   4 #include "fio.h"
   5
   6 extern 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
  15 static int
  16 rd_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
  96 static int
  97 rd_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;
 150 have_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
 170 static int
 171 rd_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;
 187 retry:
 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
 231 static int
 232 rd_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     }
 431 done:
 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     }
 442 zero:
 443   if (len == sizeof (real))
 444     p->pf = x;
 445   else
 446     p->pd = x;
 447   return (0);
 448 }
 449
 450
 451 static int
 452 rd_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 }
 462 static int
 463 rd_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 }
 486 static int
 487 rd_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 }
 497 static int
 498 rd_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
 513 int
 514 rd_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
 588 int
 589 rd_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 }