lread.c   [plain text]

#include "config.h"
#include <ctype.h>
#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;
extern int f__fmtlen;

#ifdef Allow_TYQUAD
static longint f__llx;
static int quad_read;
#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 "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

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;
	f__init = 1;
	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)) {f__init &= ~2; 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);
	(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);
		}
	}
}
#ifdef KR_headers
c_le(a) cilist *a;
#else
c_le(cilist *a)
#endif
{
	if(f__init != 1) f_init();
	f__init = 3;
	f__fmtbuf="list io";
	f__curunit = &f__units[a->ciunit];
	f__fmtlen=7;
	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);
}
#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);
}