int
l_C()
{ int ch;
if(lcount>0) return(0);
ltype=0;
for(GETC(ch);isblnk(ch);GETC(ch));
if(ch==',')
{ lcount=1;
return(0);
}
if(ch=='/')
{ lquit=1;
return(0);
}
if(ch!='(')
{ if(fscanf(cf,"%d",&lcount)!=1) {
if(!feof(cf)) err(elist->cierr,112,"no rep")
else err(elist->cierr,(EOF),"lread");
}
if(GETC(ch)!='*')
{ ungetc(ch,cf);
if(!feof(cf)) err(elist->cierr,112,"no star")
else err(elist->cierr,(EOF),"lread");
}
if(GETC(ch)!='(')
{ ungetc(ch,cf);
return(0);
}
}
static int
getrec(void) /* get next record from file */
{
int eatline;
register struct field *f;
while (ipb.chr != EOF) {
if (blnkeq) { /* beware of nbsynch() */
while (isblnk(ipb.chr))
resetinp();
if (ipb.chr == EOF)
return(0);
}
eatline = (!igneol && ipb.chr != '\n');
clearrec(); /* start with fresh record */
for (f = inpfmt; f != NULL; f = f->next)
if (getfield(f) == -1)
break;
if (f == NULL) {
advinp(); /* got one! */
return(1);
}
resetinp(); /* eat false start */
if (eatline) { /* eat rest of line */
while (ipb.chr != '\n') {
if (ipb.chr == EOF)
return(0);
resetinp();
}
resetinp();
}
}
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);
}
static void
nbsynch(void) /* non-blank starting synch character */
{
if (inpfmt == NULL || (inpfmt->type & F_TYP) != T_LIT)
return;
while (isblnk(*inpfmt->f.sl))
inpfmt->f.sl++;
if (!*inpfmt->f.sl)
inpfmt = inpfmt->next;
}
int
l_R()
{ double a,b,c,d;
int i,ch,sign=0,da,db,dc;
a=b=c=d=0;
da=db=dc=0;
if(lcount>0) return(0);
ltype=0;
for(GETC(ch);isblnk(ch);GETC(ch));
if(ch==',')
{ lcount=1;
return(0);
}
if(ch=='/')
{ lquit=1;
return(0);
}
ungetc(ch,cf);
da=rd_int(&a);
if(da== -1) sign=da;
if(GETC(ch)!='*')
{ ungetc(ch,cf);
db=1;
b=a;
a=1;
}
else
db=rd_int(&b);
if(GETC(ch)!='.')
{ dc=c=0;
ungetc(ch,cf);
}
else dc=rd_int(&c);
if(isexp(GETC(ch))) db=rd_int(&d);
else
{ ungetc(ch,cf);
d=0;
}
lcount=a;
if(!db && !dc)
return(0);
if(db && b<0)
{ sign=1;
b = -b;
}
for(i=0;i<dc;i++) c/=10;
b=b+c;
for(i=0;i<d;i++) b *= 10;
for(i=0;i< -d;i++) b /= 10;
if(sign) b = -b;
ltype=TYLONG;
lx=b;
return(0);
}
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_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);
}
}
}
static int
l_read(ftnint *number,flex *ptr,ftnlen len,ftnint type)
{ int i,n,ch;
double *yy;
float *xx;
for(i=0;i<*number;i++)
{
if(curunit->uend) err(elist->ciend, EOF, "list in")
if(l_first)
{ l_first=0;
for(GETC(ch);isblnk(ch);GETC(ch));
ungetc(ch,cf);
}
else if(lcount==0)
{ ERR(t_sep());
if(lquit) return(0);
}
switch((int)type)
{
case TYSHORT:
case TYLONG:
case TYREAL:
case TYDREAL:
ERR(l_R());
break;
case TYCOMPLEX:
case TYDCOMPLEX:
ERR(l_C());
break;
case TYLOGICAL:
ERR(l_L());
break;
case TYCHAR:
ERR(l_CHAR());
break;
}
if(lquit) return(0);
if(feof(cf)) err(elist->ciend,(EOF),"list in")
else if(ferror(cf))
{ clearerr(cf);
err(elist->cierr,errno,"list in")
}
if(ltype==0) goto bump;
switch((int)type)
{
case TYSHORT:
ptr->flshort=lx;
break;
case TYLOGICAL:
case TYLONG:
ptr->flint=lx;
break;
case TYREAL:
ptr->flreal=lx;
break;
case TYDREAL:
ptr->fldouble=lx;
break;
case TYCOMPLEX:
xx=(float *)ptr;
*xx++ = lx;
*xx = ly;
break;
case TYDCOMPLEX:
yy=(double *)ptr;
*yy++ = lx;
*yy = ly;
break;
case TYCHAR:
b_char(lchar,(char *)ptr,len);
break;
}
bump:
if(lcount>0) lcount--;
ptr = (flex *)((char *)ptr + len);
}
return(0);
}
static int
getfield( /* get next field */
register struct field *f
)
{
static char buf[RMAXWORD+1]; /* no recursion! */
int delim, inword;
double d;
char *np;
register char *cp;
switch (f->type & F_TYP) {
case T_LIT:
cp = f->f.sl;
do {
if (blnkeq && isblnk(*cp)) {
if (!isblnk(ipb.chr))
return(-1);
do
cp++;
while (isblnk(*cp));
do
scaninp();
while (isblnk(ipb.chr));
} else if (*cp == ipb.chr) {
cp++;
scaninp();
} else
return(-1);
} while (*cp);
return(0);
case T_STR:
if (f->next == NULL || (f->next->type & F_TYP) != T_LIT)
delim = EOF;
else
delim = f->next->f.sl[0];
cp = buf;
do {
if (ipb.chr == EOF || ipb.chr == '\n')
inword = 0;
else if (blnkeq && delim != EOF)
inword = isblnk(delim) ?
!isblnk(ipb.chr)
: ipb.chr != delim;
else
inword = cp-buf < (f->type & F_WID);
if (inword) {
*cp++ = ipb.chr;
scaninp();
}
} while (inword && cp < &buf[RMAXWORD]);
*cp = '\0';
if (f->f.sv->val == NULL)
f->f.sv->val = savqstr(buf); /* first setting */
else if (strcmp(f->f.sv->val, buf))
return(-1); /* doesn't match! */
return(0);
case T_NUM:
if (f->next == NULL || (f->next->type & F_TYP) != T_LIT)
delim = EOF;
else
delim = f->next->f.sl[0];
np = NULL;
cp = buf;
do {
if (!((np==NULL&&isblnk(ipb.chr)) || isnum(ipb.chr)))
inword = 0;
else if (blnkeq && delim != EOF)
inword = isblnk(delim) ?
!isblnk(ipb.chr)
: ipb.chr != delim;
else
inword = cp-buf < (f->type & F_WID);
if (inword) {
if (np==NULL && !isblnk(ipb.chr))
np = cp;
*cp++ = ipb.chr;
scaninp();
}
} while (inword && cp < &buf[RMAXWORD]);
*cp = '\0';
d = np==NULL ? 0. : atof(np);
if (!vardefined(f->f.nv))
varset(f->f.nv, '=', d); /* first setting */
else if ((d = (varvalue(f->f.nv)-d)/(d==0.?1.:d)) > .001
|| d < -.001)
return(-1); /* doesn't match! */
return(0);
}
return -1; /* pro forma return */
}
