freebsd-dev/contrib/libf2c/libI77/fmt.c

#include "config.h"
#include "f2c.h"
#include "fio.h"
#include "fmt.h"
#define skip(s) while(*s==' ') s++
#ifdef interdata
#define SYLMX 300
#endif
#ifdef pdp11
#define SYLMX 300
#endif
#ifdef vax
#define SYLMX 300
#endif
#ifndef SYLMX
#define SYLMX 300
#endif
#define GLITCH '\2'
	/* special quote character for stu */
extern int f__cursor, f__scale;
extern flag f__cblank, f__cplus;	/*blanks in I and compulsory plus */
static struct syl f__syl[SYLMX];
int f__parenlvl, f__pc, f__revloc;

static char *
ap_end (char *s)
{
  char quote;
  quote = *s++;
  for (; *s; s++)
    {
      if (*s != quote)
	continue;
      if (*++s != quote)
	return (s);
    }
  if (f__elist->cierr)
    {
      errno = 100;
      return (NULL);
    }
  f__fatal (100, "bad string");
   /*NOTREACHED*/ return 0;
}

static int
op_gen (int a, int b, int c, int d)
{
  struct syl *p = &f__syl[f__pc];
  if (f__pc >= SYLMX)
    {
      fprintf (stderr, "format too complicated:\n");
      sig_die (f__fmtbuf, 1);
    }
  p->op = a;
  p->p1 = b;
  p->p2.i[0] = c;
  p->p2.i[1] = d;
  return (f__pc++);
}
static char *f_list (char *);
static char *
gt_num (char *s, int *n, int n1)
{
  int m = 0, f__cnt = 0;
  char c;
  for (c = *s;; c = *s)
    {
      if (c == ' ')
	{
	  s++;
	  continue;
	}
      if (c > '9' || c < '0')
	break;
      m = 10 * m + c - '0';
      f__cnt++;
      s++;
    }
  if (f__cnt == 0)
    {
      if (!n1)
	s = 0;
      *n = n1;
    }
  else
    *n = m;
  return (s);
}

static char *
f_s (char *s, int curloc)
{
  skip (s);
  if (*s++ != '(')
    {
      return (NULL);
    }
  if (f__parenlvl++ == 1)
    f__revloc = curloc;
  if (op_gen (RET1, curloc, 0, 0) < 0 || (s = f_list (s)) == NULL)
    {
      return (NULL);
    }
  return (s);
}

static int
ne_d (char *s, char **p)
{
  int n, x, sign = 0;
  struct syl *sp;
  switch (*s)
    {
    default:
      return (0);
    case ':':
      (void) op_gen (COLON, 0, 0, 0);
      break;
    case '$':
      (void) op_gen (NONL, 0, 0, 0);
      break;
    case 'B':
    case 'b':
      if (*++s == 'z' || *s == 'Z')
	(void) op_gen (BZ, 0, 0, 0);
      else
	(void) op_gen (BN, 0, 0, 0);
      break;
    case 'S':
    case 's':
      if (*(s + 1) == 's' || *(s + 1) == 'S')
	{
	  x = SS;
	  s++;
	}
      else if (*(s + 1) == 'p' || *(s + 1) == 'P')
	{
	  x = SP;
	  s++;
	}
      else
	x = S;
      (void) op_gen (x, 0, 0, 0);
      break;
    case '/':
      (void) op_gen (SLASH, 0, 0, 0);
      break;
    case '-':
      sign = 1;
    case '+':
      s++;			/*OUTRAGEOUS CODING TRICK */
    case '0':
    case '1':
    case '2':
    case '3':
    case '4':
    case '5':
    case '6':
    case '7':
    case '8':
    case '9':
      if (!(s = gt_num (s, &n, 0)))
	{
	bad:*p = 0;
	  return 1;
	}
      switch (*s)
	{
	default:
	  return (0);
	case 'P':
	case 'p':
	  if (sign)
	    n = -n;
	  (void) op_gen (P, n, 0, 0);
	  break;
	case 'X':
	case 'x':
	  (void) op_gen (X, n, 0, 0);
	  break;
	case 'H':
	case 'h':
	  sp = &f__syl[op_gen (H, n, 0, 0)];
	  sp->p2.s = s + 1;
	  s += n;
	  break;
	}
      break;
    case GLITCH:
    case '"':
    case '\'':
      sp = &f__syl[op_gen (APOS, 0, 0, 0)];
      sp->p2.s = s;
      if ((*p = ap_end (s)) == NULL)
	return (0);
      return (1);
    case 'T':
    case 't':
      if (*(s + 1) == 'l' || *(s + 1) == 'L')
	{
	  x = TL;
	  s++;
	}
      else if (*(s + 1) == 'r' || *(s + 1) == 'R')
	{
	  x = TR;
	  s++;
	}
      else
	x = T;
      if (!(s = gt_num (s + 1, &n, 0)))
	goto bad;
      s--;
      (void) op_gen (x, n, 0, 0);
      break;
    case 'X':
    case 'x':
      (void) op_gen (X, 1, 0, 0);
      break;
    case 'P':
    case 'p':
      (void) op_gen (P, 1, 0, 0);
      break;
    }
  s++;
  *p = s;
  return (1);
}

static int
e_d (char *s, char **p)
{
  int i, im, n, w, d, e, found = 0, x = 0;
  char *sv = s;
  s = gt_num (s, &n, 1);
  (void) op_gen (STACK, n, 0, 0);
  switch (*s++)
    {
    default:
      break;
    case 'E':
    case 'e':
      x = 1;
    case 'G':
    case 'g':
      found = 1;
      if (!(s = gt_num (s, &w, 0)))
	{
	bad:
	  *p = 0;
	  return 1;
	}
      if (w == 0)
	break;
      if (*s == '.')
	{
	  if (!(s = gt_num (s + 1, &d, 0)))
	    goto bad;
	}
      else
	d = 0;
      if (*s != 'E' && *s != 'e')
	(void) op_gen (x == 1 ? E : G, w, d, 0);	/* default is Ew.dE2 */
      else
	{
	  if (!(s = gt_num (s + 1, &e, 0)))
	    goto bad;
	  (void) op_gen (x == 1 ? EE : GE, w, d, e);
	}
      break;
    case 'O':
    case 'o':
      i = O;
      im = OM;
      goto finish_I;
    case 'Z':
    case 'z':
      i = Z;
      im = ZM;
      goto finish_I;
    case 'L':
    case 'l':
      found = 1;
      if (!(s = gt_num (s, &w, 0)))
	goto bad;
      if (w == 0)
	break;
      (void) op_gen (L, w, 0, 0);
      break;
    case 'A':
    case 'a':
      found = 1;
      skip (s);
      if (*s >= '0' && *s <= '9')
	{
	  s = gt_num (s, &w, 1);
	  if (w == 0)
	    break;
	  (void) op_gen (AW, w, 0, 0);
	  break;
	}
      (void) op_gen (A, 0, 0, 0);
      break;
    case 'F':
    case 'f':
      if (!(s = gt_num (s, &w, 0)))
	goto bad;
      found = 1;
      if (w == 0)
	break;
      if (*s == '.')
	{
	  if (!(s = gt_num (s + 1, &d, 0)))
	    goto bad;
	}
      else
	d = 0;
      (void) op_gen (F, w, d, 0);
      break;
    case 'D':
    case 'd':
      found = 1;
      if (!(s = gt_num (s, &w, 0)))
	goto bad;
      if (w == 0)
	break;
      if (*s == '.')
	{
	  if (!(s = gt_num (s + 1, &d, 0)))
	    goto bad;
	}
      else
	d = 0;
      (void) op_gen (D, w, d, 0);
      break;
    case 'I':
    case 'i':
      i = I;
      im = IM;
    finish_I:
      if (!(s = gt_num (s, &w, 0)))
	goto bad;
      found = 1;
      if (w == 0)
	break;
      if (*s != '.')
	{
	  (void) op_gen (i, w, 0, 0);
	  break;
	}
      if (!(s = gt_num (s + 1, &d, 0)))
	goto bad;
      (void) op_gen (im, w, d, 0);
      break;
    }
  if (found == 0)
    {
      f__pc--;			/*unSTACK */
      *p = sv;
      return (0);
    }
  *p = s;
  return (1);
}
static char *
i_tem (char *s)
{
  char *t;
  int n, curloc;
  if (*s == ')')
    return (s);
  if (ne_d (s, &t))
    return (t);
  if (e_d (s, &t))
    return (t);
  s = gt_num (s, &n, 1);
  if ((curloc = op_gen (STACK, n, 0, 0)) < 0)
    return (NULL);
  return (f_s (s, curloc));
}

static char *
f_list (char *s)
{
  for (; *s != 0;)
    {
      skip (s);
      if ((s = i_tem (s)) == NULL)
	return (NULL);
      skip (s);
      if (*s == ',')
	s++;
      else if (*s == ')')
	{
	  if (--f__parenlvl == 0)
	    {
	      (void) op_gen (REVERT, f__revloc, 0, 0);
	      return (++s);
	    }
	  (void) op_gen (GOTO, 0, 0, 0);
	  return (++s);
	}
    }
  return (NULL);
}

int
pars_f (char *s)
{
  char *e;

  f__parenlvl = f__revloc = f__pc = 0;
  if ((e = f_s (s, 0)) == NULL)
    {
      /* Try and delimit the format string.  Parens within
         hollerith and quoted strings have to match for this
         to work, but it's probably adequate for most needs.
         Note that this is needed because a valid CHARACTER
         variable passed for FMT= can contain '(I)garbage',
         where `garbage' is billions and billions of junk
         characters, and it's up to the run-time library to
         know where the format string ends by counting parens.
         Meanwhile, still treat NUL byte as "hard stop", since
         f2c still appends that at end of FORMAT-statement
         strings.  */

      int level = 0;

      for (f__fmtlen = 0;
	   ((*s != ')') || (--level > 0))
	   && (*s != '\0') && (f__fmtlen < 80); ++s, ++f__fmtlen)
	{
	  if (*s == '(')
	    ++level;
	}
      if (*s == ')')
	++f__fmtlen;
      return (-1);
    }
  f__fmtlen = e - s;
  return (0);
}

#define STKSZ 10
int f__cnt[STKSZ], f__ret[STKSZ], f__cp, f__rp;
flag f__workdone, f__nonl;

static int
type_f (int n)
{
  switch (n)
    {
    default:
      return (n);
    case RET1:
      return (RET1);
    case REVERT:
      return (REVERT);
    case GOTO:
      return (GOTO);
    case STACK:
      return (STACK);
    case X:
    case SLASH:
    case APOS:
    case H:
    case T:
    case TL:
    case TR:
      return (NED);
    case F:
    case I:
    case IM:
    case A:
    case AW:
    case O:
    case OM:
    case L:
    case E:
    case EE:
    case D:
    case G:
    case GE:
    case Z:
    case ZM:
      return (ED);
    }
}
integer
do_fio (ftnint * number, char *ptr, ftnlen len)
{
  struct syl *p;
  int n, i;
  for (i = 0; i < *number; i++, ptr += len)
    {
    loop:switch (type_f ((p = &f__syl[f__pc])->op))
	{
	default:
	  fprintf (stderr, "unknown code in do_fio: %d\n%.*s\n",
		   p->op, f__fmtlen, f__fmtbuf);
	  err (f__elist->cierr, 100, "do_fio");
	case NED:
	  if ((*f__doned) (p))
	    {
	      f__pc++;
	      goto loop;
	    }
	  f__pc++;
	  continue;
	case ED:
	  if (f__cnt[f__cp] <= 0)
	    {
	      f__cp--;
	      f__pc++;
	      goto loop;
	    }
	  if (ptr == NULL)
	    return ((*f__doend) ());
	  f__cnt[f__cp]--;
	  f__workdone = 1;
	  if ((n = (*f__doed) (p, ptr, len)) > 0)
	    errfl (f__elist->cierr, errno, "fmt");
	  if (n < 0)
	    err (f__elist->ciend, (EOF), "fmt");
	  continue;
	case STACK:
	  f__cnt[++f__cp] = p->p1;
	  f__pc++;
	  goto loop;
	case RET1:
	  f__ret[++f__rp] = p->p1;
	  f__pc++;
	  goto loop;
	case GOTO:
	  if (--f__cnt[f__cp] <= 0)
	    {
	      f__cp--;
	      f__rp--;
	      f__pc++;
	      goto loop;
	    }
	  f__pc = 1 + f__ret[f__rp--];
	  goto loop;
	case REVERT:
	  f__rp = f__cp = 0;
	  f__pc = p->p1;
	  if (ptr == NULL)
	    return ((*f__doend) ());
	  if (!f__workdone)
	    return (0);
	  if ((n = (*f__dorevert) ()) != 0)
	    return (n);
	  goto loop;
	case COLON:
	  if (ptr == NULL)
	    return ((*f__doend) ());
	  f__pc++;
	  goto loop;
	case NONL:
	  f__nonl = 1;
	  f__pc++;
	  goto loop;
	case S:
	case SS:
	  f__cplus = 0;
	  f__pc++;
	  goto loop;
	case SP:
	  f__cplus = 1;
	  f__pc++;
	  goto loop;
	case P:
	  f__scale = p->p1;
	  f__pc++;
	  goto loop;
	case BN:
	  f__cblank = 0;
	  f__pc++;
	  goto loop;
	case BZ:
	  f__cblank = 1;
	  f__pc++;
	  goto loop;
	}
    }
  return (0);
}

int
en_fio (void)
{
  ftnint one = 1;
  return (do_fio (&one, (char *) NULL, (ftnint) 0));
}

void
fmt_bg (void)
{
  f__workdone = f__cp = f__rp = f__pc = f__cursor = 0;
  f__cnt[0] = f__ret[0] = 0;
}