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

extern int f__cursor;
#ifdef KR_headers
extern double atof();
#else
#undef abs
#undef min
#undef max
#include "stdlib.h"
#endif

static int
#ifdef KR_headers
rd_Z(n, w, len) Uint *n;
ftnlen len;
#else
rd_Z(Uint *n, int w, ftnlen len)
#endif
{
  long x[9];
  char *s, *s0, *s1, *se, *t;
  int ch, i, w1, w2;
  static char hex[256];
  static int one = 1;
  int bad = 0;

  if(!hex['0'])
  {
    s = "0123456789";
    while(ch = *s++)
      hex[ch] = ch - '0' + 1;
    s = "ABCDEF";
    while(ch = *s++)
      hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11;
  }
  s = s0 = (char *)x;
  s1 = (char *)&x[4];
  se = (char *)&x[8];
  if(len > 4 * sizeof(long))
    return errno = 117;
  while(w)
  {
    GET(ch);
    if(ch == ',' || ch == '\n')
      break;
    w--;
    if(ch > ' ')
    {
      if(!hex[ch & 0xff])
        bad++;
      *s++ = ch;
      if(s == se)
      {
        /* discard excess characters */
        for(t = s0, s = s1; t < s1;)
          *t++ = *s++;
        s = s1;
      }
    }
  }
  if(bad)
    return errno = 115;
  w = (int)len;
  w1 = s - s0;
  w2 = w1 + 1 >> 1;
  t = (char *)n;
  if(*(char *)&one)
  {
    /* little endian */
    t += w - 1;
    i = -1;
  }
  else
    i = 1;
  for(; w > w2; t += i, --w)
    * t = 0;
  if(!w)
    return 0;
  if(w < w2)
    s0 = s - (w << 1);
  else if(w1 & 1)
  {
    *t = hex[*s0++ & 0xff] - 1;
    if(!--w)
      return 0;
    t += i;
  }
  do
  {
    *t = hex[*s0 & 0xff] - 1 << 4 | hex[s0[1] & 0xff] - 1;
    t += i;
    s0 += 2;
  }
  while(--w);
  return 0;
}

static int
#ifdef KR_headers
rd_I(n, w, len, base) Uint *n;
int w;
ftnlen len;
register int base;
#else
rd_I(Uint *n, int w, ftnlen len, register int base)
#endif
{
  long x;
  int sign, ch;
  char s[84], *ps;
  ps = s;
  x = 0;
  while(w)
  {
    GET(ch);
    if(ch == ',' || ch == '\n') break;
    *ps = ch;
    ps++;
    w--;
  }
  *ps = '\0';
  ps = s;
  while(*ps == ' ') ps++;
  if(*ps == '-')
  {
    sign = 1;
    ps++;
  }
  else
  {
    sign = 0;
    if(*ps == '+') ps++;
  }
loop:
  while(*ps >= '0' && *ps <= '9')
  {
    x = x * base + (*ps - '0');
    ps++;
  }
  if(*ps == ' ')
  {
    if(f__cblank) x *= base;
    ps++;
    goto loop;
  }
  if(sign) x = -x;
  if(len == sizeof(integer)) n->il = x;
  else if(len == sizeof(char)) n->ic = (char)x;
#ifdef Allow_TYQUAD
  else if(len == sizeof(longint)) n->ili = x;
#endif
  else n->is = (short)x;
  if(*ps) return(errno = 115);
  else return(0);
}
static int
#ifdef KR_headers
rd_L(n, w, len) ftnint *n;
ftnlen len;
#else
rd_L(ftnint *n, int w, ftnlen len)
#endif
{
  int ch, lv;
  char s[84], *ps;
  ps = s;
  while(w)
  {
    GET(ch);
    if(ch == ',' || ch == '\n') break;
    *ps = ch;
    ps++;
    w--;
  }
  *ps = '\0';
  ps = s;
  while(*ps == ' ') ps++;
  if(*ps == '.') ps++;
  if(*ps == 't' || *ps == 'T')
    lv = 1;
  else if(*ps == 'f' || *ps == 'F')
    lv = 0;
  else return(errno = 116);
  switch(len)
  {
  case sizeof(char):
    *(char *)n = (char)lv;
    break;
  case sizeof(short):
    *(short *)n = (short)lv;
    break;
  default:
    *n = lv;
  }
  return 0;
}

#include "ctype.h"

static int
#ifdef KR_headers
rd_F(p, w, d, len) ufloat *p;
ftnlen len;
#else
rd_F(ufloat *p, int w, int d, ftnlen len)
#endif
{
  char s[FMAX + EXPMAXDIGS + 4];
  register int ch;
  register char *sp, *spe, *sp1;
  double x;
  int scale1, se;
  long e, exp;

  sp1 = sp = s;
  spe = sp + FMAX;
  exp = -d;
  x = 0.;

  do
  {
    GET(ch);
    w--;
  }
  while(ch == ' ' && w);
  switch(ch)
  {
  case '-':
    *sp++ = ch;
    sp1++;
    spe++;
  case '+':
    if(!w) goto zero;
    --w;
    GET(ch);
  }
  while(ch == ' ')
  {
blankdrop:
    if(!w--) goto zero;
    GET(ch);
  }
  while(ch == '0')
  {
    if(!w--) goto zero;
    GET(ch);
  }
  if(ch == ' ' && f__cblank)
    goto blankdrop;
  scale1 = f__scale;
  while(isdigit(ch))
  {
digloop1:
    if(sp < spe) *sp++ = ch;
    else ++exp;
digloop1e:
    if(!w--) goto done;
    GET(ch);
  }
  if(ch == ' ')
  {
    if(f__cblank)
    {
      ch = '0';
      goto digloop1;
    }
    goto digloop1e;
  }
  if(ch == '.')
  {
    exp += d;
    if(!w--) goto done;
    GET(ch);
    if(sp == sp1)    /* no digits yet */
    {
      while(ch == '0')
      {
skip01:
        --exp;
skip0:
        if(!w--) goto done;
        GET(ch);
      }
      if(ch == ' ')
      {
        if(f__cblank) goto skip01;
        goto skip0;
      }
    }
    while(isdigit(ch))
    {
digloop2:
      if(sp < spe)
      {
        *sp++ = ch;
        --exp;
      }
digloop2e:
      if(!w--) goto done;
      GET(ch);
    }
    if(ch == ' ')
    {
      if(f__cblank)
      {
        ch = '0';
        goto digloop2;
      }
      goto digloop2e;
    }
  }
  switch(ch)
  {
  default:
    break;
  case '-':
    se = 1;
    goto signonly;
  case '+':
    se = 0;
    goto signonly;
  case 'e':
  case 'E':
  case 'd':
  case 'D':
    if(!w--)
      goto bad;
    GET(ch);
    while(ch == ' ')
    {
      if(!w--)
        goto bad;
      GET(ch);
    }
    se = 0;
    switch(ch)
    {
    case '-':
      se = 1;
    case '+':
signonly:
      if(!w--)
        goto bad;
      GET(ch);
    }
    while(ch == ' ')
    {
      if(!w--)
        goto bad;
      GET(ch);
    }
    if(!isdigit(ch))
      goto bad;

    e = ch - '0';
    for(;;)
    {
      if(!w--)
      {
        ch = '\n';
        break;
      }
      GET(ch);
      if(!isdigit(ch))
      {
        if(ch == ' ')
        {
          if(f__cblank)
            ch = '0';
          else continue;
        }
        else
          break;
      }
      e = 10 * e + ch - '0';
      if(e > EXPMAX && sp > sp1)
        goto bad;
    }
    if(se)
      exp -= e;
    else
      exp += e;
    scale1 = 0;
  }
  switch(ch)
  {
  case '\n':
  case ',':
    break;
  default:
bad:
    return (errno = 115);
  }
done:
  if(sp > sp1)
  {
    while(*--sp == '0')
      ++exp;
    if(exp -= scale1)
      sprintf(sp + 1, "e%ld", exp);
    else
      sp[1] = 0;
    x = atof(s);
  }
zero:
  if(len == sizeof(real))
    p->pf = x;
  else
    p->pd = x;
  return(0);
}


static int
#ifdef KR_headers
rd_A(p, len) char *p;
ftnlen len;
#else
rd_A(char *p, ftnlen len)
#endif
{
  int i, ch;
  for(i = 0; i < len; i++)
  {
    GET(ch);
    *p++ = VAL(ch);
  }
  return(0);
}
static int
#ifdef KR_headers
rd_AW(p, w, len) char *p;
ftnlen len;
#else
rd_AW(char *p, int w, ftnlen len)
#endif
{
  int i, ch;
  if(w >= len)
  {
    for(i = 0; i < w - len; i++)
      GET(ch);
    for(i = 0; i < len; i++)
    {
      GET(ch);
      *p++ = VAL(ch);
    }
    return(0);
  }
  for(i = 0; i < w; i++)
  {
    GET(ch);
    *p++ = VAL(ch);
  }
  for(i = 0; i < len - w; i++) *p++ = ' ';
  return(0);
}
static int
#ifdef KR_headers
rd_H(n, s) char *s;
#else
rd_H(int n, char *s)
#endif
{
  int i, ch;
  for(i = 0; i < n; i++)
    if((ch = (*f__getn)()) < 0) return(ch);
    else *s++ = ch == '\n' ? ' ' : ch;
  return(1);
}
static int
#ifdef KR_headers
rd_POS(s) char *s;
#else
rd_POS(char *s)
#endif
{
  char quote;
  int ch;
  quote = *s++;
  for(; *s; s++)
    if(*s == quote && *(s + 1) != quote) break;
    else if((ch = (*f__getn)()) < 0) return(ch);
    else *s = ch == '\n' ? ' ' : ch;
  return(1);
}
#ifdef KR_headers
rd_ed(p, ptr, len) struct f__syl *p;
char *ptr;
ftnlen len;
#else
rd_ed(struct f__syl *p, char *ptr, ftnlen len)
#endif
{
  int ch;
  for(; f__cursor > 0; f__cursor--) if((ch = (*f__getn)()) < 0) return(ch);
  if(f__cursor < 0)
  {
    if(f__recpos + f__cursor < 0)  /*err(elist->cierr,110,"fmt")*/
      f__cursor = -f__recpos; /* is this in the standard? */
    if(f__external == 0)
    {
      extern char *f__icptr;
      f__icptr += f__cursor;
    }
    else if(f__curunit && f__curunit->useek)
      (void) fseek(f__cf, (long) f__cursor, SEEK_CUR);
    else
      err(f__elist->cierr, 106, "fmt");
    f__recpos += f__cursor;
    f__cursor = 0;
  }
  switch(p->op)
  {
  default:
    fprintf(stderr, "rd_ed, unexpected code: %d\n", p->op);
    sig_die(f__fmtbuf, 1);
  case IM:
  case I:
    ch = rd_I((Uint *)ptr, p->p1, len, 10);
    break;

  /* 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 OM:
  case O:
    ch = rd_I((Uint *)ptr, p->p1, len, 8);
    break;
  case L:
    ch = rd_L((ftnint *)ptr, p->p1, len);
    break;
  case A:
    ch = rd_A(ptr, len);
    break;
  case AW:
    ch = rd_AW(ptr, p->p1, len);
    break;
  case E:
  case EE:
  case D:
  case G:
  case GE:
  case F:
    ch = rd_F((ufloat *)ptr, p->p1, p->p2, len);
    break;

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

  case ZM:
  case Z:
    ch = rd_Z((Uint *)ptr, p->p1, len);
    break;
  }
  if(ch == 0) return(ch);
  else if(ch == EOF) return(EOF);
  if(f__cf)
    clearerr(f__cf);
  return(errno);
}
#ifdef KR_headers
rd_ned(p) struct f__syl *p;
#else
rd_ned(struct f__syl *p)
#endif
{
  switch(p->op)
  {
  default:
    fprintf(stderr, "rd_ned, unexpected code: %d\n", p->op);
    sig_die(f__fmtbuf, 1);
  case APOS:
    return(rd_POS(*(char **)&p->p2));
  case H:
    return(rd_H(p->p1, *(char **)&p->p2));
  case SLASH:
    return((*f__donewrec)());
  case TR:
  case X:
    f__cursor += p->p1;
    return(1);
  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);
  }
}
