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

#define MAX_NL_CACHE 3  /* maximum number of namelist hash tables to cache */
#define MAXDIM 20 /* maximum number of subscripts */

struct dimen
{
  ftnlen extent;
  ftnlen curval;
  ftnlen delta;
  ftnlen stride;
};
typedef struct dimen dimen;

struct hashentry
{
  struct hashentry *next;
  char *name;
  Vardesc *vd;
};
typedef struct hashentry hashentry;

struct hashtab
{
  struct hashtab *next;
  Namelist *nl;
  int htsize;
  hashentry *tab[1];
};
typedef struct hashtab hashtab;

static hashtab *nl_cache;
static n_nlcache;
static hashentry **zot;
extern ftnlen f__typesize[];

extern flag f__lquit;
extern int f__lcount, nml_read;
extern t_getc(Void);

#ifdef KR_headers
extern char *malloc(), *memset();

#ifdef ungetc
static int
un_getc(x, f__cf) int x;
FILE *f__cf;
{
  return ungetc(x, f__cf);
}
#else
#define un_getc ungetc
extern int ungetc();
#endif

#else
#undef abs
#undef min
#undef max
#include "stdlib.h"
#include "string.h"

#ifdef ungetc
static int
un_getc(int x, FILE *f__cf)
{
  return ungetc(x, f__cf);
}
#else
#define un_getc ungetc
#endif
#endif

static Vardesc *
#ifdef KR_headers
hash(ht, s) hashtab *ht;
register char *s;
#else
hash(hashtab *ht, register char *s)
#endif
{
  register int c, x;
  register hashentry *h;
  char *s0 = s;

  for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
    x += c;
  for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next)
    if(!strcmp(s0, h->name))
      return h->vd;
  return 0;
}

hashtab *
#ifdef KR_headers
mk_hashtab(nl) Namelist *nl;
#else
mk_hashtab(Namelist *nl)
#endif
{
  int nht, nv;
  hashtab *ht;
  Vardesc *v, **vd, **vde;
  hashentry *he;

  hashtab **x, **x0, *y;
  for(x = &nl_cache; y = *x; x0 = x, x = &y->next)
    if(nl == y->nl)
      return y;
  if(n_nlcache >= MAX_NL_CACHE)
  {
    /* discard least recently used namelist hash table */
    y = *x0;
    free((char *)y->next);
    y->next = 0;
  }
  else
    n_nlcache++;
  nv = nl->nvars;
  if(nv >= 0x4000)
    nht = 0x7fff;
  else
  {
    for(nht = 1; nht < nv; nht <<= 1);
    nht += nht - 1;
  }
  ht = (hashtab *)malloc(sizeof(hashtab) + (nht - 1) * sizeof(hashentry *)
                         + nv * sizeof(hashentry));
  if(!ht)
    return 0;
  he = (hashentry *)&ht->tab[nht];
  ht->nl = nl;
  ht->htsize = nht;
  ht->next = nl_cache;
  nl_cache = ht;
  memset((char *)ht->tab, 0, nht * sizeof(hashentry *));
  vd = nl->vars;
  vde = vd + nv;
  while(vd < vde)
  {
    v = *vd++;
    if(!hash(ht, v->name))
    {
      he->next = *zot;
      *zot = he;
      he->name = v->name;
      he->vd = v;
      he++;
    }
  }
  return ht;
}

static char Alpha[256], Alphanum[256];

static VOID
nl_init(Void)
{
  register char *s;
  register int c;

  if(!f__init)
    f_init();
  for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++;)
    Alpha[c]
      = Alphanum[c]
        = Alpha[c + 'a' - 'A']
          = Alphanum[c + 'a' - 'A']
            = c;
  for(s = "0123456789_"; c = *s++;)
    Alphanum[c] = c;
}

#define GETC(x) (x=(*l_getc)())
#define Ungetc(x,y) (*l_ungetc)(x,y)

static int
#ifdef KR_headers
getname(s, slen) register char *s;
int slen;
#else
getname(register char *s, int slen)
#endif
{
  register char *se = s + slen - 1;
  register int ch;

  GETC(ch);
  if(!(*s++ = Alpha[ch & 0xff]))
  {
    if(ch != EOF)
      ch = 115;
    errfl(f__elist->cierr, ch, "namelist read");
  }
  while(*s = Alphanum[GETC(ch) & 0xff])
    if(s < se)
      s++;
  if(ch == EOF)
    err(f__elist->cierr, EOF, "namelist read");
  if(ch > ' ')
    Ungetc(ch, f__cf);
  return *s = 0;
}

static int
#ifdef KR_headers
getnum(chp, val) int *chp;
ftnlen *val;
#else
getnum(int *chp, ftnlen *val)
#endif
{
  register int ch, sign;
  register ftnlen x;

  while(GETC(ch) <= ' ' && ch >= 0);
  if(ch == '-')
  {
    sign = 1;
    GETC(ch);
  }
  else
  {
    sign = 0;
    if(ch == '+')
      GETC(ch);
  }
  x = ch - '0';
  if(x < 0 || x > 9)
    return 115;
  while(GETC(ch) >= '0' && ch <= '9')
    x = 10 * x + ch - '0';
  while(ch <= ' ' && ch >= 0)
    GETC(ch);
  if(ch == EOF)
    return EOF;
  *val = sign ? -x : x;
  *chp = ch;
  return 0;
}

static int
#ifdef KR_headers
getdimen(chp, d, delta, extent, x1)
int *chp;
dimen *d;
ftnlen delta, extent, *x1;
#else
getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1)
#endif
{
  register int k;
  ftnlen x2, x3;

  if(k = getnum(chp, x1))
    return k;
  x3 = 1;
  if(*chp == ':')
  {
    if(k = getnum(chp, &x2))
      return k;
    x2 -= *x1;
    if(*chp == ':')
    {
      if(k = getnum(chp, &x3))
        return k;
      if(!x3)
        return 123;
      x2 /= x3;
    }
    if(x2 < 0 || x2 >= extent)
      return 123;
    d->extent = x2 + 1;
  }
  else
    d->extent = 1;
  d->curval = 0;
  d->delta = delta;
  d->stride = x3;
  return 0;
}

#ifndef No_Namelist_Questions
static Void
#ifdef KR_headers
print_ne(a) cilist *a;
#else
print_ne(cilist *a)
#endif
{
  flag intext = f__external;
  int rpsave = f__recpos;
  FILE *cfsave = f__cf;
  unit *usave = f__curunit;
  cilist t;
  t = *a;
  t.ciunit = 6;
  s_wsne(&t);
  fflush(f__cf);
  f__external = intext;
  f__reading = 1;
  f__recpos = rpsave;
  f__cf = cfsave;
  f__curunit = usave;
  f__elist = a;
}
#endif

static char where0[] = "namelist read start ";

#ifdef KR_headers
x_rsne(a) cilist *a;
#else
x_rsne(cilist *a)
#endif
{
  int ch, got1, k, n, nd, quote;
  Namelist *nl;
  static char where[] = "namelist read";
  char buf[64];
  hashtab *ht;
  Vardesc *v;
  dimen *dn, *dn0, *dn1;
  ftnlen *dims, *dims1;
  ftnlen b, b0, b1, ex, no, no1, nomax, size, span;
  ftnint type;
  char *vaddr;
  long iva, ivae;
  dimen dimens[MAXDIM], substr;

  if(!Alpha['a'])
    nl_init();
  f__reading = 1;
  f__formatted = 1;
  got1 = 0;
top:
  for(;;) switch(GETC(ch))
    {
    case EOF:
      err(a->ciend, (EOF), where0);
    case '&':
    case '$':
      goto have_amp;
#ifndef No_Namelist_Questions
    case '?':
      print_ne(a);
      continue;
#endif
    default:
      if(ch <= ' ' && ch >= 0)
        continue;
      errfl(a->cierr, 115, where0);
    }
have_amp:
  if(ch = getname(buf, sizeof(buf)))
    return ch;
  nl = (Namelist *)a->cifmt;
  if(strcmp(buf, nl->name))
#ifdef No_Bad_Namelist_Skip
    errfl(a->cierr, 118, where0);
#else
  {
    fprintf(stderr,
            "Skipping namelist \"%s\": seeking namelist \"%s\".\n",
            buf, nl->name);
    fflush(stderr);
    for(;;) switch(GETC(ch))
      {
      case EOF:
        err(a->ciend, EOF, where0);
      case '/':
      case '&':
      case '$':
        if(f__external)
          e_rsle();
        else
          z_rnew();
        goto top;
      case '"':
      case '\'':
        quote = ch;
more_quoted:
        while(GETC(ch) != quote)
          if(ch == EOF)
            err(a->ciend, EOF, where0);
        if(GETC(ch) == quote)
          goto more_quoted;
        Ungetc(ch, f__cf);
      default:
        continue;
      }
  }
#endif
  ht = mk_hashtab(nl);
  if(!ht)
    errfl(f__elist->cierr, 113, where0);
  for(;;)
  {
    for(;;) switch(GETC(ch))
      {
      case EOF:
        if(got1)
          return 0;
        err(a->ciend, EOF, where0);
      case '/':
      case '$':
      case '&':
        return 0;
      default:
        if(ch <= ' ' && ch >= 0 || ch == ',')
          continue;
        Ungetc(ch, f__cf);
        if(ch = getname(buf, sizeof(buf)))
          return ch;
        goto havename;
      }
havename:
    v = hash(ht, buf);
    if(!v)
      errfl(a->cierr, 119, where);
    while(GETC(ch) <= ' ' && ch >= 0);
    vaddr = v->addr;
    type = v->type;
    if(type < 0)
    {
      size = -type;
      type = TYCHAR;
    }
    else
      size = f__typesize[type];
    ivae = size;
    iva = 0;
    if(ch == '(' /*)*/)
    {
      dn = dimens;
      if(!(dims = v->dims))
      {
        if(type != TYCHAR)
          errfl(a->cierr, 122, where);
        if(k = getdimen(&ch, dn, (ftnlen)size,
                        (ftnlen)size, &b))
          errfl(a->cierr, k, where);
        if(ch != ')')
          errfl(a->cierr, 115, where);
        b1 = dn->extent;
        if(--b < 0 || b + b1 > size)
          return 124;
        iva += b;
        size = b1;
        while(GETC(ch) <= ' ' && ch >= 0);
        goto scalar;
      }
      nd = (int)dims[0];
      nomax = span = dims[1];
      ivae = iva + size * nomax;
      if(k = getdimen(&ch, dn, size, nomax, &b))
        errfl(a->cierr, k, where);
      no = dn->extent;
      b0 = dims[2];
      dims1 = dims += 3;
      ex = 1;
      for(n = 1; n++ < nd; dims++)
      {
        if(ch != ',')
          errfl(a->cierr, 115, where);
        dn1 = dn + 1;
        span /= *dims;
        if(k = getdimen(&ch, dn1, dn->delta**dims,
                        span, &b1))
          errfl(a->cierr, k, where);
        ex *= *dims;
        b += b1 * ex;
        no *= dn1->extent;
        dn = dn1;
      }
      if(ch != ')')
        errfl(a->cierr, 115, where);
      b -= b0;
      if(b < 0 || b >= nomax)
        errfl(a->cierr, 125, where);
      iva += size * b;
      dims = dims1;
      while(GETC(ch) <= ' ' && ch >= 0);
      no1 = 1;
      dn0 = dimens;
      if(type == TYCHAR && ch == '(' /*)*/)
      {
        if(k = getdimen(&ch, &substr, size, size, &b))
          errfl(a->cierr, k, where);
        if(ch != ')')
          errfl(a->cierr, 115, where);
        b1 = substr.extent;
        if(--b < 0 || b + b1 > size)
          return 124;
        iva += b;
        b0 = size;
        size = b1;
        while(GETC(ch) <= ' ' && ch >= 0);
        if(b1 < b0)
          goto delta_adj;
      }
      for(; dn0 < dn; dn0++)
      {
        if(dn0->extent != *dims++ || dn0->stride != 1)
          break;
        no1 *= dn0->extent;
      }
      if(dn0 == dimens && dimens[0].stride == 1)
      {
        no1 = dimens[0].extent;
        dn0++;
      }
delta_adj:
      ex = 0;
      for(dn1 = dn0; dn1 <= dn; dn1++)
        ex += (dn1->extent - 1)
              * (dn1->delta *= dn1->stride);
      for(dn1 = dn; dn1 > dn0; dn1--)
      {
        ex -= (dn1->extent - 1) * dn1->delta;
        dn1->delta -= ex;
      }
    }
    else if(dims = v->dims)
    {
      no = no1 = dims[1];
      ivae = iva + no * size;
    }
    else
scalar:
      no = no1 = 1;
    if(ch != '=')
      errfl(a->cierr, 115, where);
    got1 = nml_read = 1;
    f__lcount = 0;
readloop:
    for(;;)
    {
      if(iva >= ivae || iva < 0)
      {
        f__lquit = 1;
        goto mustend;
      }
      else if(iva + no1 * size > ivae)
        no1 = (ivae - iva) / size;
      f__lquit = 0;
      if(k = l_read(&no1, vaddr + iva, size, type))
        return k;
      if(f__lquit == 1)
        return 0;
mustend:
      if(GETC(ch) == '/' || ch == '$' || ch == '&')
      {
        f__lquit = 1;
        return 0;
      }
      else if(f__lquit)
      {
        while(ch <= ' ' && ch >= 0)
          GETC(ch);
        Ungetc(ch, f__cf);
        if(!Alpha[ch & 0xff] && ch >= 0)
          errfl(a->cierr, 125, where);
        break;
      }
      Ungetc(ch, f__cf);
      if((no -= no1) <= 0)
        break;
      for(dn1 = dn0; dn1 <= dn; dn1++)
      {
        if(++dn1->curval < dn1->extent)
        {
          iva += dn1->delta;
          goto readloop;
        }
        dn1->curval = 0;
      }
      break;
    }
  }
}

integer
#ifdef KR_headers
s_rsne(a) cilist *a;
#else
s_rsne(cilist *a)
#endif
{
  extern int l_eof;
  int n;

  f__external = 1;
  l_eof = 0;
  if(n = c_le(a))
    return n;
  if(f__curunit->uwrt && f__nowreading(f__curunit))
    err(a->cierr, errno, where0);
  l_getc = t_getc;
  l_ungetc = un_getc;
  f__doend = xrd_SL;
  if(n = x_rsne(a))
    return n;
  return e_rsle();
}
