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

/* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */
/* marks in namelist input a la the Fortran 8X Draft published in  */
/* the May 1989 issue of Fortran Forum. */


extern char *f__fmtbuf;

#ifdef Allow_TYQUAD
static longint f__llx;
#endif

#ifdef KR_headers
extern double atof();
extern char *malloc(), *realloc();
int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)();
#else
#undef abs
#undef min
#undef max
#include "stdlib.h"
#endif

#include "fmt.h"
#include "lio.h"
#include "ctype.h"
#include "fp.h"
#ifdef __cplusplus
extern "C" {
#endif

#ifndef KR_headers
int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void),
  (*l_ungetc)(int,FILE*);
#endif

int l_eof;

#define isblnk(x) (f__ltab[x+1]&B)
#define issep(x) (f__ltab[x+1]&SX)
#define isapos(x) (f__ltab[x+1]&AX)
#define isexp(x) (f__ltab[x+1]&EX)
#define issign(x) (f__ltab[x+1]&SG)
#define iswhit(x) (f__ltab[x+1]&WH)
#define SX 1
#define B 2
#define AX 4
#define EX 8
#define SG 16
#define WH 32
char f__ltab[128+1] = {  /* offset one for EOF */
  0,
  0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
};

#ifdef ungetc
 static int
#ifdef KR_headers
un_getc(x,f__cf) int x; FILE *f__cf;
#else
un_getc(int x, FILE *f__cf)
#endif
{ return ungetc(x,f__cf); }
#else
#define un_getc ungetc
#ifdef KR_headers
 extern int ungetc();
#else
extern int ungetc(int, FILE*);  /* for systems with a buggy stdio.h */
#endif
#endif

 int
t_getc(Void)
{  int ch;
  if(f__curunit->uend) return(EOF);
  if((ch=getc(f__cf))!=EOF) return(ch);
  if(feof(f__cf))
         f__curunit->uend = l_eof = 1;
  return(EOF);
}
integer e_rsle(Void)
{
  int ch;
  if(f__curunit->uend) return(0);
  while((ch=t_getc())!='\n')
         if(ch == EOF) {
                if(feof(f__cf))
                       f__curunit->uend = l_eof = 1;
                return EOF;
                }
  return(0);
}

flag f__lquit;
int f__lcount,f__ltype,nml_read;
char *f__lchar;
double f__lx,f__ly;
#define ERR(x) if((n=(x))) return(n)
#define GETC(x) (x=(*l_getc)())
#define Ungetc(x,y) (*l_ungetc)(x,y)

 static int
#ifdef KR_headers
l_R(poststar, reqint) int poststar, reqint;
#else
l_R(int poststar, int reqint)
#endif
{
  char s[FMAX+EXPMAXDIGS+4];
  register int ch;
  register char *sp, *spe, *sp1;
  long e, exp;
  int havenum, havestar, se;

  if(!poststar) {
         if(f__lcount > 0)
                return(0);
         f__lcount = 1;
         }
#ifdef Allow_TYQUAD
  f__llx = 0;
#endif
  f__ltype = 0;
  exp = 0;
  havestar = 0;
retry:
  sp1 = sp = s;
  spe = sp + FMAX;
  havenum = 0;

  switch(GETC(ch)) {
         case '-': *sp++ = ch; sp1++; spe++;
         case '+':
                GETC(ch);
         }
  while(ch == '0') {
         ++havenum;
         GETC(ch);
         }
  while(isdigit(ch)) {
         if(sp < spe) *sp++ = ch;
         else ++exp;
         GETC(ch);
         }
  if(ch == '*' && !poststar) {
         if(sp == sp1 || exp || *s == '-') {
                errfl(f__elist->cierr,112,"bad repetition count");
                }
         poststar = havestar = 1;
         *sp = 0;
         f__lcount = atoi(s);
         goto retry;
         }
  if(ch == '.') {
#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
         if(reqint)
                errfl(f__elist->cierr,115,"invalid integer");
#endif
         GETC(ch);
         if(sp == sp1)
                while(ch == '0') {
                       ++havenum;
                       --exp;
                       GETC(ch);
                       }
         while(isdigit(ch)) {
                if(sp < spe)
                       { *sp++ = ch; --exp; }
                GETC(ch);
                }
         }
  havenum += sp - sp1;
  se = 0;
  if(issign(ch))
         goto signonly;
  if(havenum && isexp(ch)) {
#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
         if(reqint)
                errfl(f__elist->cierr,115,"invalid integer");
#endif
         GETC(ch);
         if(issign(ch)) {
signonly:
                if(ch == '-') se = 1;
                GETC(ch);
                }
         if(!isdigit(ch)) {
bad:
                errfl(f__elist->cierr,112,"exponent field");
                }

         e = ch - '0';
         while(isdigit(GETC(ch))) {
                e = 10*e + ch - '0';
                if(e > EXPMAX)
                       goto bad;
                }
         if(se)
                exp -= e;
         else
                exp += e;
         }
  (void) Ungetc(ch, f__cf);
  if(sp > sp1) {
         ++havenum;
         while(*--sp == '0')
                ++exp;
         if(exp)
                sprintf(sp+1, "e%ld", exp);
         else
                sp[1] = 0;
         f__lx = atof(s);
#ifdef Allow_TYQUAD
         if(reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) {
                /* Assuming 64-bit longint and 32-bit long. */
                if(exp < 0)
                       sp += exp;
                if(sp1 <= sp) {
                       f__llx = *sp1 - '0';
                       while(++sp1 <= sp)
                              f__llx = 10*f__llx + (*sp1 - '0');
                       }
                while(--exp >= 0)
                       f__llx *= 10;
                if(*s == '-')
                       f__llx = -f__llx;
                }
#endif
         }
  else
         f__lx = 0.;
  if(havenum)
         f__ltype = TYLONG;
  else
         switch(ch) {
                case ',':
                case '/':
                       break;
                default:
                       if(havestar && ( ch == ' '
                                     ||ch == '\t'
                                     ||ch == '\n'))
                              break;
                       if(nml_read > 1) {
                              f__lquit = 2;
                              return 0;
                              }
                       errfl(f__elist->cierr,112,"invalid number");
                }
  return 0;
  }

 static int
#ifdef KR_headers
rd_count(ch) register int ch;
#else
rd_count(register int ch)
#endif
{
  if(ch < '0' || ch > '9')
         return 1;
  f__lcount = ch - '0';
  while(GETC(ch) >= '0' && ch <= '9')
         f__lcount = 10*f__lcount + ch - '0';
  Ungetc(ch,f__cf);
  return f__lcount <= 0;
  }

 static int
l_C(Void)
{  int ch, nml_save;
  double lz;
  if(f__lcount>0) return(0);
  f__ltype=0;
  GETC(ch);
  if(ch!='(')
  {
         if(nml_read > 1 && (ch < '0' || ch > '9')) {
                Ungetc(ch,f__cf);
                f__lquit = 2;
                return 0;
                }
         if(rd_count(ch)) {
                if(!f__cf || !feof(f__cf))
                       errfl(f__elist->cierr,112,"complex format");
                else
                       err(f__elist->cierr,(EOF),"lread");
         }
         if(GETC(ch)!='*')
         {
                if(!f__cf || !feof(f__cf))
                       errfl(f__elist->cierr,112,"no star");
                else
                       err(f__elist->cierr,(EOF),"lread");
         }
         if(GETC(ch)!='(')
         {       Ungetc(ch,f__cf);
                return(0);
         }
  }
  else
         f__lcount = 1;
  while(iswhit(GETC(ch)));
  Ungetc(ch,f__cf);
  nml_save = nml_read;
  nml_read = 0;
  if((ch = l_R(1,0)))
         return ch;
  if(!f__ltype)
         errfl(f__elist->cierr,112,"no real part");
  lz = f__lx;
  while(iswhit(GETC(ch)));
  if(ch!=',')
  {       (void) Ungetc(ch,f__cf);
         errfl(f__elist->cierr,112,"no comma");
  }
  while(iswhit(GETC(ch)));
  (void) Ungetc(ch,f__cf);
  if((ch = l_R(1,0)))
         return ch;
  if(!f__ltype)
         errfl(f__elist->cierr,112,"no imaginary part");
  while(iswhit(GETC(ch)));
  if(ch!=')') errfl(f__elist->cierr,112,"no )");
  f__ly = f__lx;
  f__lx = lz;
#ifdef Allow_TYQUAD
  f__llx = 0;
#endif
  nml_read = nml_save;
  return(0);
}

 static char nmLbuf[256], *nmL_next;
 static int (*nmL_getc_save)(Void);
#ifdef KR_headers
 static int (*nmL_ungetc_save)(/* int, FILE* */);
#else
 static int (*nmL_ungetc_save)(int, FILE*);
#endif

 static int
nmL_getc(Void)
{
  int rv;
  if((rv = *nmL_next++))
         return rv;
  l_getc = nmL_getc_save;
  l_ungetc = nmL_ungetc_save;
  return (*l_getc)();
  }

 static int
#ifdef KR_headers
nmL_ungetc(x, f) int x; FILE *f;
#else
nmL_ungetc(int x, FILE *f)
#endif
{
  f = f;       /* banish non-use warning */
  return *--nmL_next = x;
  }

 static int
#ifdef KR_headers
Lfinish(ch, dot, rvp) int ch, dot, *rvp;
#else
Lfinish(int ch, int dot, int *rvp)
#endif
{
  char *s, *se;
  static char what[] = "namelist input";

  s = nmLbuf + 2;
  se = nmLbuf + sizeof(nmLbuf) - 1;
  *s++ = ch;
  while(!issep(GETC(ch)) && ch!=EOF) {
         if(s >= se) {
 nmLbuf_ovfl:
                return *rvp = err__fl(f__elist->cierr,131,what);
                }
         *s++ = ch;
         if(ch != '=')
                continue;
         if(dot)
                return *rvp = err__fl(f__elist->cierr,112,what);
 got_eq:
         *s = 0;
         nmL_getc_save = l_getc;
         l_getc = nmL_getc;
         nmL_ungetc_save = l_ungetc;
         l_ungetc = nmL_ungetc;
         nmLbuf[1] = *(nmL_next = nmLbuf) = ',';
         *rvp = f__lcount = 0;
         return 1;
         }
  if(dot)
         goto done;
  for(;;) {
         if(s >= se)
                goto nmLbuf_ovfl;
         *s++ = ch;
         if(!isblnk(ch))
                break;
         if(GETC(ch) == EOF)
                goto done;
         }
  if(ch == '=')
         goto got_eq;
 done:
  Ungetc(ch, f__cf);
  return 0;
  }

 static int
l_L(Void)
{
  int ch, rv, sawdot;

  if(f__lcount>0)
         return(0);
  f__lcount = 1;
  f__ltype=0;
  GETC(ch);
  if(isdigit(ch))
  {
         rd_count(ch);
         if(GETC(ch)!='*') {
                if(!f__cf || !feof(f__cf))
                       errfl(f__elist->cierr,112,"no star");
                else
                       err(f__elist->cierr,(EOF),"lread");
         }
         GETC(ch);
  }
  sawdot = 0;
  if(ch == '.') {
         sawdot = 1;
         GETC(ch);
         }
  switch(ch)
  {
  case 't':
  case 'T':
         if(nml_read && Lfinish(ch, sawdot, &rv))
                return rv;
         f__lx=1;
         break;
  case 'f':
  case 'F':
         if(nml_read && Lfinish(ch, sawdot, &rv))
                return rv;
         f__lx=0;
         break;
  default:
         if(isblnk(ch) || issep(ch) || ch==EOF)
         {       (void) Ungetc(ch,f__cf);
                return(0);
         }
         if(nml_read > 1) {
                Ungetc(ch,f__cf);
                f__lquit = 2;
                return 0;
                }
         errfl(f__elist->cierr,112,"logical");
  }
  f__ltype=TYLONG;
  while(!issep(GETC(ch)) && ch!=EOF);
  Ungetc(ch, f__cf);
  return(0);
}

#define BUFSIZE  128

 static int
l_CHAR(Void)
{  int ch,size,i;
  static char rafail[] = "realloc failure";
  char quote,*p;
  if(f__lcount>0) return(0);
  f__ltype=0;
  if(f__lchar!=NULL) free(f__lchar);
  size=BUFSIZE;
  p=f__lchar = (char *)malloc((unsigned int)size);
  if(f__lchar == NULL)
         errfl(f__elist->cierr,113,"no space");

  GETC(ch);
  if(isdigit(ch)) {
         /* allow Fortran 8x-style unquoted string...       */
         /* either find a repetition count or the string       */
         f__lcount = ch - '0';
         *p++ = ch;
         for(i = 1;;) {
                switch(GETC(ch)) {
                       case '*':
                              if(f__lcount == 0) {
                                     f__lcount = 1;
#ifndef F8X_NML_ELIDE_QUOTES
                                     if(nml_read)
                                            goto no_quote;
#endif
                                     goto noquote;
                                     }
                              p = f__lchar;
                              goto have_lcount;
                       case ',':
                       case ' ':
                       case '\t':
                       case '\n':
                       case '/':
                              Ungetc(ch,f__cf);
                              /* no break */
                       case EOF:
                              f__lcount = 1;
                              f__ltype = TYCHAR;
                              return *p = 0;
                       }
                if(!isdigit(ch)) {
                       f__lcount = 1;
#ifndef F8X_NML_ELIDE_QUOTES
                       if(nml_read) {
 no_quote:
                              errfl(f__elist->cierr,112,
                                     "undelimited character string");
                              }
#endif
                       goto noquote;
                       }
                *p++ = ch;
                f__lcount = 10*f__lcount + ch - '0';
                if(++i == size) {
                       f__lchar = (char *)realloc(f__lchar,
                              (unsigned int)(size += BUFSIZE));
                       if(f__lchar == NULL)
                              errfl(f__elist->cierr,113,rafail);
                       p = f__lchar + i;
                       }
                }
         }
  else       (void) Ungetc(ch,f__cf);
 have_lcount:
  if(GETC(ch)=='\'' || ch=='"') quote=ch;
  else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) {
         Ungetc(ch,f__cf);
         return 0;
         }
#ifndef F8X_NML_ELIDE_QUOTES
  else if(nml_read > 1) {
         Ungetc(ch,f__cf);
         f__lquit = 2;
         return 0;
         }
#endif
  else {
         /* Fortran 8x-style unquoted string */
         *p++ = ch;
         for(i = 1;;) {
                switch(GETC(ch)) {
                       case ',':
                       case ' ':
                       case '\t':
                       case '\n':
                       case '/':
                              Ungetc(ch,f__cf);
                              /* no break */
                       case EOF:
                              f__ltype = TYCHAR;
                              return *p = 0;
                       }
 noquote:
                *p++ = ch;
                if(++i == size) {
                       f__lchar = (char *)realloc(f__lchar,
                              (unsigned int)(size += BUFSIZE));
                       if(f__lchar == NULL)
                              errfl(f__elist->cierr,113,rafail);
                       p = f__lchar + i;
                       }
                }
         }
  f__ltype=TYCHAR;
  for(i=0;;)
  {       while(GETC(ch)!=quote && ch!='\n'
                && ch!=EOF && ++i<size) *p++ = ch;
         if(i==size)
         {
         newone:
                f__lchar= (char *)realloc(f__lchar,
                              (unsigned int)(size += BUFSIZE));
                if(f__lchar == NULL)
                       errfl(f__elist->cierr,113,rafail);
                p=f__lchar+i-1;
                *p++ = ch;
         }
         else if(ch==EOF) return(EOF);
         else if(ch=='\n')
         {       if(*(p-1) != '\\') continue;
                i--;
                p--;
                if(++i<size) *p++ = ch;
                else goto newone;
         }
         else if(GETC(ch)==quote)
         {       if(++i<size) *p++ = ch;
                else goto newone;
         }
         else
         {       (void) Ungetc(ch,f__cf);
                *p = 0;
                return(0);
         }
  }
}

 int
#ifdef KR_headers
c_le(a) cilist *a;
#else
c_le(cilist *a)
#endif
{
  if(!f__init)
         f_init();
  f__fmtbuf="list io";
  f__curunit = &f__units[a->ciunit];
  if(a->ciunit>=MXUNIT || a->ciunit<0)
         err(a->cierr,101,"stler");
  f__scale=f__recpos=0;
  f__elist=a;
  if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
         err(a->cierr,102,"lio");
  f__cf=f__curunit->ufd;
  if(!f__curunit->ufmt) err(a->cierr,103,"lio")
  return(0);
}

 int
#ifdef KR_headers
l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
#else
l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
#endif
{
#define Ptr ((flex *)ptr)
  int i,n,ch;
  doublereal *yy;
  real *xx;
  for(i=0;i<*number;i++)
  {
         if(f__lquit) return(0);
         if(l_eof)
                err(f__elist->ciend, EOF, "list in")
         if(f__lcount == 0) {
                f__ltype = 0;
                for(;;)  {
                       GETC(ch);
                       switch(ch) {
                       case EOF:
                              err(f__elist->ciend,(EOF),"list in")
                       case ' ':
                       case '\t':
                       case '\n':
                              continue;
                       case '/':
                              f__lquit = 1;
                              goto loopend;
                       case ',':
                              f__lcount = 1;
                              goto loopend;
                       default:
                              (void) Ungetc(ch, f__cf);
                              goto rddata;
                       }
                }
         }
  rddata:
         switch((int)type)
         {
         case TYINT1:
         case TYSHORT:
         case TYLONG:
#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT
                ERR(l_R(0,1));
                break;
#endif
         case TYREAL:
         case TYDREAL:
                ERR(l_R(0,0));
                break;
#ifdef TYQUAD
         case TYQUAD:
                n = l_R(0,2);
                if(n)
                       return n;
                break;
#endif
         case TYCOMPLEX:
         case TYDCOMPLEX:
                ERR(l_C());
                break;
         case TYLOGICAL1:
         case TYLOGICAL2:
         case TYLOGICAL:
                ERR(l_L());
                break;
         case TYCHAR:
                ERR(l_CHAR());
                break;
         }
  while(GETC(ch) == ' ' || ch == '\t');
  if(ch != ',' || f__lcount > 1)
         Ungetc(ch,f__cf);
  loopend:
         if(f__lquit) return(0);
         if(f__cf && ferror(f__cf)) {
                clearerr(f__cf);
                errfl(f__elist->cierr,errno,"list in");
                }
         if(f__ltype==0) goto bump;
         switch((int)type)
         {
         case TYINT1:
         case TYLOGICAL1:
                Ptr->flchar = (char)f__lx;
                break;
         case TYLOGICAL2:
         case TYSHORT:
                Ptr->flshort = (short)f__lx;
                break;
         case TYLOGICAL:
         case TYLONG:
                Ptr->flint = (ftnint)f__lx;
                break;
#ifdef Allow_TYQUAD
         case TYQUAD:
                if(!(Ptr->fllongint = f__llx))
                       Ptr->fllongint = f__lx;
                break;
#endif
         case TYREAL:
                Ptr->flreal=f__lx;
                break;
         case TYDREAL:
                Ptr->fldouble=f__lx;
                break;
         case TYCOMPLEX:
                xx=(real *)ptr;
                *xx++ = f__lx;
                *xx = f__ly;
                break;
         case TYDCOMPLEX:
                yy=(doublereal *)ptr;
                *yy++ = f__lx;
                *yy = f__ly;
                break;
         case TYCHAR:
                b_char(f__lchar,ptr,len);
                break;
         }
  bump:
         if(f__lcount>0) f__lcount--;
         ptr += len;
         if(nml_read)
                nml_read++;
  }
  return(0);
#undef Ptr
}
#ifdef KR_headers
integer s_rsle(a) cilist *a;
#else
integer s_rsle(cilist *a)
#endif
{
  int n;

  f__reading=1;
  f__external=1;
  f__formatted=1;
  if((n=c_le(a))) return(n);
  f__lioproc = l_read;
  f__lquit = 0;
  f__lcount = 0;
  l_eof = 0;
  if(f__curunit->uwrt && f__nowreading(f__curunit))
         err(a->cierr,errno,"read start");
  if(f__curunit->uend)
         err(f__elist->ciend,(EOF),"read start");
  l_getc = t_getc;
  l_ungetc = un_getc;
  f__doend = xrd_SL;
  return(0);
}
#ifdef __cplusplus
}
#endif
