Bell 32V development

[unix-history] / usr / src / libI77 / lread.c

#include "fio.h"
#include "fmt.h"
#include "lio.h"
#include "ctype.h"
extern char *fmtbuf;
int (*lioproc)();

#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 SX 1
#define B 2
#define AX 4
#define EX 8
char ltab[128+1]        /* offset one for EOF */
{       0,
       0,0,AX,0,0,0,0,0,0,0,B,0,0,0,0,0,
       0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
       SX|B,0,AX,0,0,0,0,0,0,0,0,0,SX,0,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,
       AX,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
};

int l_first;
t_getc()
{       int ch;
       if(curunit->uend) return(EOF);
       if((ch=getc(cf))!=EOF) return(ch);
       if(feof(cf)) curunit->uend = 1;
       return(EOF);
}
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=t_getc())

l_read(number,ptr,len,type) ftnint *number,type; flex *ptr; ftnlen len;
{       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==NULL) 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 = (char *)ptr + len;
       }
       return(0);
}
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=NULL;
       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);
}
rd_int(x) double *x;
{       int ch,sign=0,i;
       double y;
       i=0;
       y=0;
       if(GETC(ch)=='-') sign = -1;
       else if(ch=='+') sign=0;
       else ungetc(ch,cf);
       while(isdigit(GETC(ch)))
       {       i++;
               y=10*y+ch-'0';
       }
       ungetc(ch,cf);
       if(sign) y = -y;
       *x = y;
       return(y!=0?i:sign);
}
l_C()
{       int ch;
       if(lcount>0) return(0);
       ltype=NULL;
       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);
               }
       }
       lcount = 1;
       ltype=TYLONG;
       fscanf(cf,"%lf",&lx);
       while(isblnk(GETC(ch)));
       if(ch!=',')
       {       ungetc(ch,cf);
               err(elist->cierr,112,"no comma");
       }
       while(isblnk(GETC(ch)));
       ungetc(ch,cf);
       fscanf(cf,"%lf",&ly);
       while(isblnk(GETC(ch)));
       if(ch!=')') err(elist->cierr,112,"no )");
       while(isblnk(GETC(ch)));
       ungetc(ch,cf);
       return(0);
}
l_L()
{
       int ch;
       if(lcount>0) return(0);
       ltype=NULL;
       while(isblnk(GETC(ch)));
       if(ch==',')
       {       lcount=1;
               return(0);
       }
       if(ch=='/')
       {       lquit=1;
               return(0);
       }
       if(isdigit(ch))
       {       ungetc(ch,cf);
               fscanf(cf,"%d",&lcount);
               if(GETC(ch)!='*')
                       if(!feof(cf)) err(elist->cierr,112,"no star")
                       else err(elist->cierr,(EOF),"lread");
       }
       else    ungetc(ch,cf);
       if(GETC(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)
               {       ungetc(ch,cf);
                       return(0);
               }
               else    err(elist->cierr,112,"logical");
       }
       ltype=TYLONG;
       while(!issep(GETC(ch)) && ch!='\n' && ch!=EOF);
       return(0);
}
#define BUFSIZE 128
l_CHAR()
{       int ch,size,i;
       char quote,*p;
       if(lcount>0) return(0);
       ltype=NULL;

       while(isblnk(GETC(ch)));
       if(ch==',')
       {       lcount=1;
               return(0);
       }
       if(ch=='/')
       {       lquit=1;
               return(0);
       }
       if(isdigit(ch))
       {       ungetc(ch,cf);
               fscanf(cf,"%d",&lcount);
               if(GETC(ch)!='*') err(elist->cierr,112,"no star");
       }
       else    ungetc(ch,cf);
       if(GETC(ch)=='\'' || ch=='"') quote=ch;
       else if(isblnk(ch) || issep(ch) || ch==EOF)
       {       ungetc(ch,cf);
               return(0);
       }
       else err(elist->cierr,112,"no quote");
       ltype=TYCHAR;
       if(lchar!=NULL) free(lchar);
       size=BUFSIZE;
       p=lchar=(char *)malloc(size);
       if(lchar==NULL) err(elist->cierr,113,"no space");
       for(i=0;;)
       {       while(GETC(ch)!=quote && ch!='\n'
                       && ch!=EOF && ++i<size) *p++ = ch;
               if(i==size)
               {
               newone:
                       lchar=(char *)realloc(lchar, 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
               {       ungetc(ch,cf);
                       *p++ = 0;
                       return(0);
               }
       }
}
s_rsle(a) cilist *a;
{
       int n;
       if(!init) f_init();
       if(n=c_le(a,READ)) return(n);
       reading=1;
       external=1;
       formatted=1;
       l_first=1;
       lioproc = l_read;
       lcount = 0;
       if(curunit->uwrt)
               return(nowreading(curunit));
       else    return(0);
}
t_sep()
{
       int ch;
       for(GETC(ch);isblnk(ch);GETC(ch));
       if(ch == EOF)
               if(feof(cf)) return(EOF);
               else return(errno);
       if(ch=='/')
       {       lquit=1;
               return(0);
       }
       if(ch==',') for(GETC(ch);isblnk(ch);GETC(ch));
       ungetc(ch,cf);
       return(0);
}
c_le(a,flag) 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(flag,SEQ,FMT,a->ciunit))
               err(a->cierr,102,"lio");
       cf=curunit->ufd;
       if(!curunit->ufmt) err(a->cierr,103,"lio")
       return(0);
}
do_lio(type,number,ptr,len) ftnint *number,*type; flex *ptr; ftnlen len;
{
       return((*lioproc)(number,ptr,len,*type));
}