libf2c/libI77/wrtfmt.c

#include "config.h"
#include "f2c.h"
#include "fio.h"
#include "fmt.h"

extern icilist *f__svic;
extern char *f__icptr;

static int
mv_cur (void)			/* shouldn't use fseek because it insists on calling fflush */
		/* instead we know too much about stdio */
{
  int cursor = f__cursor;
  f__cursor = 0;
  if (f__external == 0)
    {
      if (cursor < 0)
	{
	  if (f__hiwater < f__recpos)
	    f__hiwater = f__recpos;
	  f__recpos += cursor;
	  f__icptr += cursor;
	  if (f__recpos < 0)
	    err (f__elist->cierr, 110, "left off");
	}
      else if (cursor > 0)
	{
	  if (f__recpos + cursor >= f__svic->icirlen)
	    err (f__elist->cierr, 110, "recend");
	  if (f__hiwater <= f__recpos)
	    for (; cursor > 0; cursor--)
	      (*f__putn) (' ');
	  else if (f__hiwater <= f__recpos + cursor)
	    {
	      cursor -= f__hiwater - f__recpos;
	      f__icptr += f__hiwater - f__recpos;
	      f__recpos = f__hiwater;
	      for (; cursor > 0; cursor--)
		(*f__putn) (' ');
	    }
	  else
	    {
	      f__icptr += cursor;
	      f__recpos += cursor;
	    }
	}
      return (0);
    }
  if (cursor > 0)
    {
      if (f__hiwater <= f__recpos)
	for (; cursor > 0; cursor--)
	  (*f__putn) (' ');
      else if (f__hiwater <= f__recpos + cursor)
	{
	  cursor -= f__hiwater - f__recpos;
	  f__recpos = f__hiwater;
	  for (; cursor > 0; cursor--)
	    (*f__putn) (' ');
	}
      else
	{
	  f__recpos += cursor;
	}
    }
  else if (cursor < 0)
    {
      if (cursor + f__recpos < 0)
	err (f__elist->cierr, 110, "left off");
      if (f__hiwater < f__recpos)
	f__hiwater = f__recpos;
      f__recpos += cursor;
    }
  return (0);
}

static int
wrt_Z (Uint * n, int w, int minlen, ftnlen len)
{
  register char *s, *se;
  register int i, w1;
  static int one = 1;
  static char hex[] = "0123456789ABCDEF";
  s = (char *) n;
  --len;
  if (*(char *) &one)
    {
      /* little endian */
      se = s;
      s += len;
      i = -1;
    }
  else
    {
      se = s + len;
      i = 1;
    }
  for (;; s += i)
    if (s == se || *s)
      break;
  w1 = (i * (se - s) << 1) + 1;
  if (*s & 0xf0)
    w1++;
  if (w1 > w)
    for (i = 0; i < w; i++)
      (*f__putn) ('*');
  else
    {
      if ((minlen -= w1) > 0)
	w1 += minlen;
      while (--w >= w1)
	(*f__putn) (' ');
      while (--minlen >= 0)
	(*f__putn) ('0');
      if (!(*s & 0xf0))
	{
	  (*f__putn) (hex[*s & 0xf]);
	  if (s == se)
	    return 0;
	  s += i;
	}
      for (;; s += i)
	{
	  (*f__putn) (hex[*s >> 4 & 0xf]);
	  (*f__putn) (hex[*s & 0xf]);
	  if (s == se)
	    break;
	}
    }
  return 0;
}

static int
wrt_I (Uint * n, int w, ftnlen len, register int base)
{
  int ndigit, sign, spare, i;
  longint x;
  char *ans;
  if (len == sizeof (integer))
    x = n->il;
  else if (len == sizeof (char))
    x = n->ic;
#ifdef Allow_TYQUAD
  else if (len == sizeof (longint))
    x = n->ili;
#endif
  else
    x = n->is;
  ans = f__icvt (x, &ndigit, &sign, base);
  spare = w - ndigit;
  if (sign || f__cplus)
    spare--;
  if (spare < 0)
    for (i = 0; i < w; i++)
      (*f__putn) ('*');
  else
    {
      for (i = 0; i < spare; i++)
	(*f__putn) (' ');
      if (sign)
	(*f__putn) ('-');
      else if (f__cplus)
	(*f__putn) ('+');
      for (i = 0; i < ndigit; i++)
	(*f__putn) (*ans++);
    }
  return (0);
}
static int
wrt_IM (Uint * n, int w, int m, ftnlen len, int base)
{
  int ndigit, sign, spare, i, xsign;
  longint x;
  char *ans;
  if (sizeof (integer) == len)
    x = n->il;
  else if (len == sizeof (char))
    x = n->ic;
#ifdef Allow_TYQUAD
  else if (len == sizeof (longint))
    x = n->ili;
#endif
  else
    x = n->is;
  ans = f__icvt (x, &ndigit, &sign, base);
  if (sign || f__cplus)
    xsign = 1;
  else
    xsign = 0;
  if (ndigit + xsign > w || m + xsign > w)
    {
      for (i = 0; i < w; i++)
	(*f__putn) ('*');
      return (0);
    }
  if (x == 0 && m == 0)
    {
      for (i = 0; i < w; i++)
	(*f__putn) (' ');
      return (0);
    }
  if (ndigit >= m)
    spare = w - ndigit - xsign;
  else
    spare = w - m - xsign;
  for (i = 0; i < spare; i++)
    (*f__putn) (' ');
  if (sign)
    (*f__putn) ('-');
  else if (f__cplus)
    (*f__putn) ('+');
  for (i = 0; i < m - ndigit; i++)
    (*f__putn) ('0');
  for (i = 0; i < ndigit; i++)
    (*f__putn) (*ans++);
  return (0);
}
static int
wrt_AP (char *s)
{
  char quote;
  int i;

  if (f__cursor && (i = mv_cur ()))
    return i;
  quote = *s++;
  for (; *s; s++)
    {
      if (*s != quote)
	(*f__putn) (*s);
      else if (*++s == quote)
	(*f__putn) (*s);
      else
	return (1);
    }
  return (1);
}
static int
wrt_H (int a, char *s)
{
  int i;

  if (f__cursor && (i = mv_cur ()))
    return i;
  while (a--)
    (*f__putn) (*s++);
  return (1);
}

int
wrt_L (Uint * n, int len, ftnlen sz)
{
  int i;
  longint x;
#ifdef Allow_TYQUAD
  if (sizeof (longint) == sz)
    x = n->ili;
  else
#endif
  if (sizeof (short ) == sz)
    x = n->is;
  else if (sizeof (char) == sz)
    x = n->ic;
  else if (sizeof (integer) == sz)
    x = n->il;

  for (i = 0; i < len - 1; i++)
    (*f__putn) (' ');
  if (x)
    (*f__putn) ('T');
  else
    (*f__putn) ('F');
  return (0);
}
static int
wrt_A (char *p, ftnlen len)
{
  while (len-- > 0)
    (*f__putn) (*p++);
  return (0);
}
static int
wrt_AW (char *p, int w, ftnlen len)
{
  while (w > len)
    {
      w--;
      (*f__putn) (' ');
    }
  while (w-- > 0)
    (*f__putn) (*p++);
  return (0);
}

static int
wrt_G (ufloat * p, int w, int d, int e, ftnlen len)
{
  double up = 1, x;
  int i = 0, oldscale, n, j;
  x = len == sizeof (real) ? p->pf : p->pd;
  if (x < 0)
    x = -x;
  if (x < .1)
    {
      if (x != 0.)
	return (wrt_E (p, w, d, e, len));
      i = 1;
      goto have_i;
    }
  for (; i <= d; i++, up *= 10)
    {
      if (x >= up)
	continue;
    have_i:
      oldscale = f__scale;
      f__scale = 0;
      if (e == 0)
	n = 4;
      else
	n = e + 2;
      i = wrt_F (p, w - n, d - i, len);
      for (j = 0; j < n; j++)
	(*f__putn) (' ');
      f__scale = oldscale;
      return (i);
    }
  return (wrt_E (p, w, d, e, len));
}

int
w_ed (struct syl * p, char *ptr, ftnlen len)
{
  int i;

  if (f__cursor && (i = mv_cur ()))
    return i;
  switch (p->op)
    {
    default:
      fprintf (stderr, "w_ed, unexpected code: %d\n", p->op);
      sig_die (f__fmtbuf, 1);
    case I:
      return (wrt_I ((Uint *) ptr, p->p1, len, 10));
    case IM:
      return (wrt_IM ((Uint *) ptr, p->p1, p->p2.i[0], len, 10));

      /* O and OM don't work right for character, double, complex, */
      /* or doublecomplex, and they differ from Fortran 90 in */
      /* showing a minus sign for negative values. */

    case O:
      return (wrt_I ((Uint *) ptr, p->p1, len, 8));
    case OM:
      return (wrt_IM ((Uint *) ptr, p->p1, p->p2.i[0], len, 8));
    case L:
      return (wrt_L ((Uint *) ptr, p->p1, len));
    case A:
      return (wrt_A (ptr, len));
    case AW:
      return (wrt_AW (ptr, p->p1, len));
    case D:
    case E:
    case EE:
      return (wrt_E ((ufloat *) ptr, p->p1, p->p2.i[0], p->p2.i[1], len));
    case G:
    case GE:
      return (wrt_G ((ufloat *) ptr, p->p1, p->p2.i[0], p->p2.i[1], len));
    case F:
      return (wrt_F ((ufloat *) ptr, p->p1, p->p2.i[0], len));

      /* Z and ZM assume 8-bit bytes. */

    case Z:
      return (wrt_Z ((Uint *) ptr, p->p1, 0, len));
    case ZM:
      return (wrt_Z ((Uint *) ptr, p->p1, p->p2.i[0], len));
    }
}

int
w_ned (struct syl * p)
{
  switch (p->op)
    {
    default:
      fprintf (stderr, "w_ned, unexpected code: %d\n", p->op);
      sig_die (f__fmtbuf, 1);
    case SLASH:
      return ((*f__donewrec) ());
    case T:
      f__cursor = p->p1 - f__recpos - 1;
      return (1);
    case TL:
      f__cursor -= p->p1;
      if (f__cursor < -f__recpos)	/* TL1000, 1X */
	f__cursor = -f__recpos;
      return (1);
    case TR:
    case X:
      f__cursor += p->p1;
      return (1);
    case APOS:
      return (wrt_AP (p->p2.s));
    case H:
      return (wrt_H (p->p1, p->p2.s));
    }
}