source: trunk/gcc/libf2c/libI77/lwrite.c@ 2772

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

ftnint L_len;
int f__Aquote;

static void
donewrec (void)
{
  if (f__recpos)
    (*f__donewrec) ();
}

static void
lwrt_I (longint n)
{
  char *p;
  int ndigit, sign;

  p = f__icvt (n, &ndigit, &sign, 10);
  if (f__recpos + ndigit >= L_len)
    donewrec ();
  PUT (' ');
  if (sign)
    PUT ('-');
  while (*p)
    PUT (*p++);
}
static void
lwrt_L (ftnint n, ftnlen len)
{
  if (f__recpos + LLOGW >= L_len)
    donewrec ();
  wrt_L ((Uint *) & n, LLOGW, len);
}
static void
lwrt_A (char *p, ftnlen len)
{
  int a;
  char *p1, *pe;

  a = 0;
  pe = p + len;
  if (f__Aquote)
    {
      a = 3;
      if (len > 1 && p[len - 1] == ' ')
        {
          while (--len > 1 && p[len - 1] == ' ');
          pe = p + len;
        }
      p1 = p;
      while (p1 < pe)
        if (*p1++ == '\'')
          a++;
    }
  if (f__recpos + len + a >= L_len)
    donewrec ();
  if (a
#ifndef OMIT_BLANK_CC
      || !f__recpos
#endif
    )
    PUT (' ');
  if (a)
    {
      PUT ('\'');
      while (p < pe)
        {
          if (*p == '\'')
            PUT ('\'');
          PUT (*p++);
        }
      PUT ('\'');
    }
  else
    while (p < pe)
      PUT (*p++);
}

static int
l_g (char *buf, double n)
{
#ifdef Old_list_output
  doublereal absn;
  char *fmt;

  absn = n;
  if (absn < 0)
    absn = -absn;
  fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
#ifdef USE_STRLEN
  sprintf (buf, fmt, n);
  return strlen (buf);
#else
  return sprintf (buf, fmt, n);
#endif

#else
  register char *b, c, c1;

  b = buf;
  *b++ = ' ';
  if (n < 0)
    {
      *b++ = '-';
      n = -n;
    }
  else
    *b++ = ' ';
  if (n == 0)
    {
      *b++ = '0';
      *b++ = '.';
      *b = 0;
      goto f__ret;
    }
  sprintf (b, LGFMT, n);
  switch (*b)
    {
#ifndef WANT_LEAD_0
    case '0':
      while (b[0] = b[1])
        b++;
      break;
#endif
    case 'i':
    case 'I':
      /* Infinity */
    case 'n':
    case 'N':
      /* NaN */
      while (*++b);
      break;

    default:
      /* Fortran 77 insists on having a decimal point... */
      for (;; b++)
        switch (*b)
          {
          case 0:
            *b++ = '.';
            *b = 0;
            goto f__ret;
          case '.':
            while (*++b);
            goto f__ret;
          case 'E':
            for (c1 = '.', c = 'E'; (*b = c1); c1 = c, c = *++b);
            goto f__ret;
          }
    }
f__ret:
  return b - buf;
#endif
}

static void
l_put (register char *s)
{
  register void (*pn) (int) = f__putn;
  register int c;

  while ((c = *s++))
    (*pn) (c);
}

static void
lwrt_F (double n)
{
  char buf[LEFBL];

  if (f__recpos + l_g (buf, n) >= L_len)
    donewrec ();
  l_put (buf);
}
static void
lwrt_C (double a, double b)
{
  char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
  int al, bl;

  al = l_g (bufa, a);
  for (ba = bufa; *ba == ' '; ba++)
    --al;
  bl = l_g (bufb, b) + 1;       /* intentionally high by 1 */
  for (bb = bufb; *bb == ' '; bb++)
    --bl;
  if (f__recpos + al + bl + 3 >= L_len)
    donewrec ();
#ifdef OMIT_BLANK_CC
  else
#endif
    PUT (' ');
  PUT ('(');
  l_put (ba);
  PUT (',');
  if (f__recpos + bl >= L_len)
    {
      (*f__donewrec) ();
#ifndef OMIT_BLANK_CC
      PUT (' ');
#endif
    }
  l_put (bb);
  PUT (')');
}

int
l_write (ftnint * number, char *ptr, ftnlen len, ftnint type)
{
#define Ptr ((flex *)ptr)
  int i;
  longint x;
  double y, z;
  real *xx;
  doublereal *yy;
  for (i = 0; i < *number; i++)
    {
      switch ((int) type)
        {
        default:
          f__fatal (204, "unknown type in lio");
        case TYINT1:
          x = Ptr->flchar;
          goto xint;
        case TYSHORT:
          x = Ptr->flshort;
          goto xint;
#ifdef Allow_TYQUAD
        case TYQUAD:
          x = Ptr->fllongint;
          goto xint;
#endif
        case TYLONG:
          x = Ptr->flint;
        xint:lwrt_I (x);
          break;
        case TYREAL:
          y = Ptr->flreal;
          goto xfloat;
        case TYDREAL:
          y = Ptr->fldouble;
        xfloat:lwrt_F (y);
          break;
        case TYCOMPLEX:
          xx = &Ptr->flreal;
          y = *xx++;
          z = *xx;
          goto xcomplex;
        case TYDCOMPLEX:
          yy = &Ptr->fldouble;
          y = *yy++;
          z = *yy;
        xcomplex:
          lwrt_C (y, z);
          break;
        case TYLOGICAL1:
          x = Ptr->flchar;
          goto xlog;
        case TYLOGICAL2:
          x = Ptr->flshort;
          goto xlog;
        case TYLOGICAL:
          x = Ptr->flint;
        xlog:lwrt_L (Ptr->flint, len);
          break;
        case TYCHAR:
          lwrt_A (ptr, len);
          break;
        }
      ptr += len;
    }
  return (0);
}