#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 ENABLE_QREAL
static int	l_QR _ANSI_ARGS_((int poststar, int reqint));
static _omQReal_t f__qr;
#endif /* ENABLE_QREAL */

#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"

#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)) != 0 ) return(n)
#define GETC(x) (x=(*l_getc)())
#define Ungetc(x,y) (*l_ungetc)(x,y)

#ifdef ENABLE_QREAL
static char *qBuf = NULL;
static int qBufLen = 0;

static int
#ifdef KR_headers
l_QR(poststar, reqint) int poststar, reqint;
#else
l_QR(int poststar, int reqint)
#endif
{
    int n = 0;
    int ch;
    char *start = NULL;
    char *scp = NULL;
    mpf_t fVal;

    if (poststar == 0) {
	if (f__lcount > 0) {
	    return 0;
	}
	f__lcount = 1;
    }

    if (qBuf == NULL || qBufLen == 0) {
	qBufLen = 4096;
	qBuf = (char *)malloc(sizeof(char) * qBufLen);
	if (qBuf == NULL) {
	    f__fatal(113, "malloc failure");
	}
    }

    while (1) {
	GETC(ch);
	if (ch == ' ' || ch == '\t' || ch == '\n' ||
	    ch == '/' || ch == ',') {
	    break;
	}
	if (n >= qBufLen) {
	    qBufLen += 4096;
	    qBuf = (char *)realloc(qBuf, sizeof(char) * qBufLen);
	    if (qBuf == NULL) {
		f__fatal(113, "relloc failure");
	    }
	}
	qBuf[n] = ch;
	n++;
	if (n >= INT_MAX) {
	    f__fatal(113, "too long number");
	}
    }
    qBuf[n] = '\0';
    (void) Ungetc(ch, f__cf);

    start = strchr(qBuf, '*');
    if (start != NULL) {
	char *dum = NULL;
	int cnt = -INT_MAX;

	*start = '\0';

	cnt = strtoul(qBuf, &dum, 10);
	if (dum == qBuf) {
	    errfl(f__elist->cierr, 112, "bad repetition count");	    
	}
	f__lcount = cnt;
	start++;
	n = strlen(start);
    } else {
	start = qBuf;
    }
    scp = start;

    while (*scp != '\0') {
	if (*scp == 'Q' || *scp == 'q' ||
	    *scp == 'D' || *scp == 'd' ||
	    *scp == 'F' || *scp == 'f' ||
	    *scp == 'G' || *scp == 'g') {
	    *scp = 'e';
	}
	scp++;
    }

    if (mpf_init_set_str(fVal, start, 10) != 0) {
	mpf_clear(fVal);
	errfl(f__elist->cierr, 112, "invalid number");
    }

    mpf2QR(&fVal, &f__qr);
    mpf_clear(fVal);
    f__ltype = TYQREAL;

    return 0;
}
#endif /* ENABLE_QREAL */

 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))!=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))!=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 int
l_L(Void)
{
	int ch;
	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);
	}
	if(ch == '.') GETC(ch);
	switch(ch)
	{
	case 't':
	case 'T':
		f__lx=1;
		break;
	case 'f':
	case 'F':
		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);
	(void) 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;
	ch = 0;
	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)
		{
#ifdef ENABLE_QREAL
		case TYQREAL: {
		    ERR(l_QR(0, sizeOfQRealT / sizeof(int)));
		    break;
		}
#endif /* ENABLE_QREAL */
		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)
		{
#ifdef ENABLE_QREAL
		case TYQREAL: {
		    void *qPtr = (void *)ptr;
		    memcpy(qPtr, &f__qr, sizeOfQRealT);
		    break;
		}
#endif /* ENABLE_QREAL */
		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)) != 0) 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);
}