ack/lang/fortran/lib/libI77/lread.c

527 lines
8.8 KiB
C
Raw Permalink Normal View History

1991-10-07 16:59:33 +00:00
#include "f2c.h"
#include "fio.h"
#include "fmt.h"
#include "lio.h"
#include "ctype.h"
#include "fp.h"
extern char *fmtbuf;
extern char *malloc(), *realloc();
int (*lioproc)(), (*l_getc)(), (*l_ungetc)();
int l_eof;
#define isblnk(x) (ltab[x+1]&B)
#define issep(x) (ltab[x+1]&SX)
#define isapos(x) (ltab[x+1]&AX)
#define isexp(x) (ltab[x+1]&EX)
#define issign(x) (ltab[x+1]&SG)
#define iswhit(x) (ltab[x+1]&WH)
#define SX 1
#define B 2
#define AX 4
#define EX 8
#define SG 16
#define WH 32
char 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
};
t_getc()
{ int ch;
if(curunit->uend) return(EOF);
if((ch=getc(cf))!=EOF) return(ch);
if(feof(cf))
l_eof = curunit->uend = 1;
return(EOF);
}
integer e_rsle()
{
int ch;
if(curunit->uend) return(0);
while((ch=t_getc())!='\n' && ch!=EOF);
return(0);
}
flag lquit;
int lcount,ltype;
char *lchar;
double lx,ly;
#define ERR(x) if(n=(x)) return(n)
#define GETC(x) (x=(*l_getc)())
#define Ungetc(x,y) (*l_ungetc)(x,y)
l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
{
#define Ptr ((flex *)ptr)
int i,n,ch;
doublereal *yy;
real *xx;
for(i=0;i<*number;i++)
{
if(lquit) return(0);
if(l_eof)
err(elist->ciend, EOF, "list in")
if(lcount == 0) {
ltype = 0;
for(;;) {
GETC(ch);
switch(ch) {
case EOF:
goto loopend;
case ' ':
case '\t':
case '\n':
continue;
case '/':
lquit = 1;
goto loopend;
case ',':
lcount = 1;
goto loopend;
default:
(void) Ungetc(ch, cf);
goto rddata;
}
}
}
rddata:
switch((int)type)
{
case TYSHORT:
case TYLONG:
case TYREAL:
case TYDREAL:
ERR(l_R(0));
break;
case TYCOMPLEX:
case TYDCOMPLEX:
ERR(l_C());
break;
case TYLOGICAL:
ERR(l_L());
break;
case TYCHAR:
ERR(l_CHAR());
break;
}
while (GETC(ch) == ' ' || ch == '\t');
if (ch != ',')
Ungetc(ch,cf);
loopend:
if(lquit) return(0);
if(cf) {
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=(real *)ptr;
*xx++ = lx;
*xx = ly;
break;
case TYDCOMPLEX:
yy=(doublereal *)ptr;
*yy++ = lx;
*yy = ly;
break;
case TYCHAR:
b_char(lchar,ptr,len);
break;
}
bump:
if(lcount>0) lcount--;
ptr += len;
}
return(0);
#undef Ptr
}
l_R(poststar)
int poststar;
{
char s[FMAX+EXPMAXDIGS+4];
register int ch;
register char *sp, *spe, *sp1;
long e, exp;
double atof();
int havenum, se;
if (!poststar) {
if (lcount > 0)
return(0);
lcount = 1;
}
ltype = 0;
exp = 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 == '-') {
err(elist->cierr,112,"bad repetition count")
}
poststar = 1;
*sp = 0;
lcount = atoi(s);
goto retry;
}
if (ch == '.') {
GETC(ch);
if (sp == sp1)
while(ch == '0') {
++havenum;
--exp;
GETC(ch);
}
while(isdigit(ch)) {
if (sp < spe)
{ *sp++ = ch; --exp; }
GETC(ch);
}
}
se = 0;
if (issign(ch))
goto signonly;
if (isexp(ch)) {
GETC(ch);
if (issign(ch)) {
signonly:
if (ch == '-') se = 1;
GETC(ch);
}
if (!isdigit(ch)) {
bad:
err(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, cf);
if (sp > sp1) {
++havenum;
while(*--sp == '0')
++exp;
if (exp)
sprintf(sp+1, "e%ld", exp);
else
sp[1] = 0;
lx = atof(s);
}
else
lx = 0.;
if (havenum)
ltype = TYLONG;
else
switch(ch) {
case ',':
case '/':
break;
default:
err(elist->cierr,112,"invalid number")
}
return 0;
}
static int
rd_count(ch)
register int ch;
{
if (ch < '0' || ch > '9')
return 1;
lcount = ch - '0';
while(GETC(ch) >= '0' && ch <= '9')
lcount = 10*lcount + ch - '0';
Ungetc(ch,cf);
return 0;
}
l_C()
{ int ch;
double lz;
if(lcount>0) return(0);
ltype=0;
GETC(ch);
if(ch!='(')
{
if (rd_count(ch))
if(!cf || !feof(cf))
err(elist->cierr,112,"complex format")
else
err(elist->cierr,(EOF),"lread");
if(GETC(ch)!='*')
{
if(!cf || !feof(cf))
err(elist->cierr,112,"no star")
else
err(elist->cierr,(EOF),"lread");
}
if(GETC(ch)!='(')
{ (void) Ungetc(ch,cf);
return(0);
}
}
else
lcount = 1;
while(iswhit(GETC(ch)));
(void) Ungetc(ch,cf);
if (ch = l_R(1))
return ch;
if (!ltype)
err(elist->cierr,112,"no real part");
lz = lx;
while(iswhit(GETC(ch)));
if(ch!=',')
{ (void) Ungetc(ch,cf);
err(elist->cierr,112,"no comma");
}
while(iswhit(GETC(ch)));
(void) Ungetc(ch,cf);
if (ch = l_R(1))
return ch;
if (!ltype)
err(elist->cierr,112,"no imaginary part");
while(iswhit(GETC(ch)));
if(ch!=')') err(elist->cierr,112,"no )");
ly = lx;
lx = lz;
return(0);
}
l_L()
{
int ch;
if(lcount>0) return(0);
ltype=0;
GETC(ch);
if(isdigit(ch))
{
rd_count(ch);
if(GETC(ch)!='*')
if(!cf || !feof(cf))
err(elist->cierr,112,"no star")
else
err(elist->cierr,(EOF),"lread");
GETC(ch);
}
if(ch == '.') GETC(ch);
switch(ch)
{
case 't':
case 'T':
lx=1;
break;
case 'f':
case 'F':
lx=0;
break;
default:
if(isblnk(ch) || issep(ch) || ch==EOF)
{ (void) Ungetc(ch,cf);
return(0);
}
else err(elist->cierr,112,"logical");
}
ltype=TYLONG;
lcount = 1;
while(!issep(GETC(ch)) && ch!=EOF);
(void) Ungetc(ch, cf);
return(0);
}
#define BUFSIZE 128
l_CHAR()
{ int ch,size,i;
char quote,*p;
if(lcount>0) return(0);
ltype=0;
if(lchar!=NULL) free(lchar);
size=BUFSIZE;
p=lchar=malloc((unsigned int)size);
if(lchar==NULL) err(elist->cierr,113,"no space");
GETC(ch);
if(isdigit(ch)) {
/* allow Fortran 8x-style unquoted string... */
/* either find a repetition count or the string */
lcount = ch - '0';
*p++ = ch;
for(i = 1;;) {
switch(GETC(ch)) {
case '*':
if (lcount == 0) {
lcount = 1;
goto noquote;
}
p = lchar;
goto have_lcount;
case ',':
case ' ':
case '\t':
case '\n':
case '/':
Ungetc(ch,cf);
/* no break */
case EOF:
lcount = 1;
ltype = TYCHAR;
return *p = 0;
}
if (!isdigit(ch)) {
lcount = 1;
goto noquote;
}
*p++ = ch;
lcount = 10*lcount + ch - '0';
if (++i == size) {
lchar = realloc(lchar,
(unsigned int)(size += BUFSIZE));
p = lchar + i;
}
}
}
else (void) Ungetc(ch,cf);
have_lcount:
if(GETC(ch)=='\'' || ch=='"') quote=ch;
else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
{ (void) Ungetc(ch,cf);
return(0);
}
else {
/* Fortran 8x-style unquoted string */
*p++ = ch;
for(i = 1;;) {
switch(GETC(ch)) {
case ',':
case ' ':
case '\t':
case '\n':
case '/':
Ungetc(ch,cf);
/* no break */
case EOF:
ltype = TYCHAR;
return *p = 0;
}
noquote:
*p++ = ch;
if (++i == size) {
lchar = realloc(lchar,
(unsigned int)(size += BUFSIZE));
p = lchar + i;
}
}
}
ltype=TYCHAR;
for(i=0;;)
{ while(GETC(ch)!=quote && ch!='\n'
&& ch!=EOF && ++i<size) *p++ = ch;
if(i==size)
{
newone:
lchar= realloc(lchar, (unsigned int)(size += BUFSIZE));
p=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,cf);
*p = 0;
return(0);
}
}
}
integer s_rsle(a) cilist *a;
{
int n;
extern int ungetc();
if(!init) f_init();
if(n=c_le(a)) return(n);
reading=1;
external=1;
formatted=1;
lioproc = l_read;
lquit = 0;
lcount = 0;
l_eof = 0;
if(curunit->uwrt && nowreading(curunit))
err(a->cierr,errno,"read start");
l_getc = t_getc;
l_ungetc = ungetc;
return(0);
}
c_le(a) cilist *a;
{
fmtbuf="list io";
if(a->ciunit>=MXUNIT || a->ciunit<0)
err(a->cierr,101,"stler");
scale=recpos=0;
elist=a;
curunit = &units[a->ciunit];
if(curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
err(a->cierr,102,"lio");
cf=curunit->ufd;
if(!curunit->ufmt) err(a->cierr,103,"lio")
return(0);
}