From 519f775613582a302f92ed37ae4e0a3b18c7f351 Mon Sep 17 00:00:00 2001 From: Tom London Date: Fri, 19 Jan 1979 01:02:19 -0500 Subject: [PATCH] Bell 32V development Work on file usr/src/libI77/lread.c Co-Authored-By: John Reiser Synthesized-from: 32v --- usr/src/libI77/lread.c | 395 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 395 insertions(+) create mode 100644 usr/src/libI77/lread.c diff --git a/usr/src/libI77/lread.c b/usr/src/libI77/lread.c new file mode 100644 index 0000000000..c08a6c2a82 --- /dev/null +++ b/usr/src/libI77/lread.c @@ -0,0 +1,395 @@ +#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;i0) 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 && ++iuwrt) + 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)); +} -- 2.20.1