Research V7 development

Work on file usr/src/libI77/fmt.c
Work on file usr/src/libI77/fmt.h
Work on file usr/src/libI77/iio.c
Work on file usr/src/libI77/fmtlib.c
Work on file usr/src/libI77/lread.c
Work on file usr/src/libI77/rdfmt.c
Work on file usr/src/libI77/rewind.c
Work on file usr/src/libI77/wrtfmt.c
Work on file usr/src/libI77/wsfe.c

Synthesized-from: v7

diff --git a/usr/src/libI77/fmt.c b/usr/src/libI77/fmt.c
new file mode 100644 (file)
index 0000000..3cfc103
--- /dev/null
+++ b/usr/src/libI77/fmt.c
@@ -0,0 +1,392 @@
+#include "fio.h"
+#include "fmt.h"
+#define skip(s) while(*s==' ') s++
+#ifdef interdata
+#define SYLMX 300
+#endif
+#ifdef pdp11
+#define SYLMX 300
+#endif
+#ifdef vax
+#define SYLMX 300
+#endif
+#define GLITCH '\2'
+       /* special quote character for stu */
+extern int cursor,scale;
+extern flag cblank,cplus;      /*blanks in I and compulsory plus*/
+struct syl syl[SYLMX];
+int parenlvl,pc,revloc;
+char *f_s(),*f_list(),*i_tem(),*gt_num();
+pars_f(s) char *s;
+{
+       parenlvl=revloc=pc=0;
+       if((s=f_s(s,0))==NULL)
+       {
+               return(-1);
+       }
+       return(0);
+}
+char *f_s(s,curloc) char *s;
+{
+       skip(s);
+       if(*s++!='(')
+       {
+               return(NULL);
+       }
+       if(parenlvl++ ==1) revloc=curloc;
+       if(op_gen(RET,curloc,0,0)<0 ||
+               (s=f_list(s))==NULL)
+       {
+               return(NULL);
+       }
+       skip(s);
+       return(s);
+}
+char *f_list(s) char *s;
+{
+       for(;*s!=0;)
+       {       skip(s);
+               if((s=i_tem(s))==NULL) return(NULL);
+               skip(s);
+               if(*s==',') s++;
+               else if(*s==')')
+               {       if(--parenlvl==0)
+                       {
+                               op_gen(REVERT,revloc,0,0);
+                               return(++s);
+                       }
+                       op_gen(GOTO,0,0,0);
+                       return(++s);
+               }
+       }
+       return(NULL);
+}
+char *i_tem(s) char *s;
+{      char *t;
+       int n,curloc;
+       if(*s==')') return(s);
+       if(ne_d(s,&t)) return(t);
+       if(e_d(s,&t)) return(t);
+       s=gt_num(s,&n);
+       if((curloc=op_gen(STACK,n,0,0))<0) return(NULL);
+       return(f_s(s,curloc));
+}
+ne_d(s,p) char *s,**p;
+{      int n,x,sign=0;
+       char *ap_end();
+       switch(*s)
+       {
+       default: return(0);
+       case ':': op_gen(COLON,0,0,0); break;
+       case 'b':
+               if(*++s=='z') op_gen(BZ,0,0,0);
+               else op_gen(BN,0,0,0);
+               break;
+       case 's':
+               if(*(s+1)=='s')
+               {       x=SS;
+                       s++;
+               }
+               else if(*(s+1)=='p')
+               {       x=SP;
+                       s++;
+               }
+               else x=S;
+               op_gen(x,0,0,0);
+               break;
+       case '/': op_gen(SLASH,0,0,0); break;
+       case '-': sign=1; s++;  /*OUTRAGEOUS CODING TRICK*/
+       case '0': case '1': case '2': case '3': case '4':
+       case '5': case '6': case '7': case '8': case '9':
+               s=gt_num(s,&n);
+               switch(*s)
+               {
+               default: return(0);
+               case 'p': if(sign) n= -n; op_gen(P,n,0,0); break;
+               case 'x': op_gen(X,n,0,0); break;
+               case 'H':
+               case 'h': op_gen(H,n,(int)(s+1),0);
+                       s+=n;
+                       break;
+               }
+               break;
+       case GLITCH:
+       case '"':
+       case '\'': op_gen(APOS,(int)s,0,0);
+               *p=ap_end(s);
+               return(1);
+       case 't':
+               if(*(s+1)=='l')
+               {       x=TL;
+                       s++;
+               }
+               else if(*(s+1)=='r')
+               {       x=TR;
+                       s++;
+               }
+               else x=T;
+               s=gt_num(s+1,&n);
+               op_gen(x,n,0,0);
+               break;
+       case 'x': op_gen(X,1,0,0); break;
+       case 'p': op_gen(P,1,0,0); break;
+       }
+       s++;
+       *p=s;
+       return(1);
+}
+e_d(s,p) char *s,**p;
+{      int n,w,d,e,found=0,x=0;
+       char *sv=s;
+       s=gt_num(s,&n);
+       op_gen(STACK,n,0,0);
+       switch(*s++)
+       {
+       default: break;
+       case 'e':       x=1;
+       case 'g':
+               found=1;
+               s=gt_num(s,&w);
+               if(w==0) break;
+               if(*s=='.')
+               {       s++;
+                       s=gt_num(s,&d);
+               }
+               else d=0;
+               if(*s!='E')
+                       op_gen(x==1?E:G,w,d,0);
+               else
+               {       s++;
+                       s=gt_num(s,&e);
+                       op_gen(x==1?EE:GE,w,d,e);
+               }
+               break;
+       case 'o':
+               found = 1;
+               s = gt_num(s, &w);
+               if(w==0) break;
+               op_gen(O, w, 0, 0);
+               break;
+       case 'l':
+               found=1;
+               s=gt_num(s,&w);
+               if(w==0) break;
+               op_gen(L,w,0,0);
+               break;
+       case 'a':
+               found=1;
+               skip(s);
+               if(*s>='0' && *s<='9')
+               {       s=gt_num(s,&w);
+                       if(w==0) break;
+                       op_gen(AW,w,0,0);
+                       break;
+               }
+               op_gen(A,0,0,0);
+               break;
+       case 'f':
+               found=1;
+               s=gt_num(s,&w);
+               if(w==0) break;
+               if(*s=='.')
+               {       s++;
+                       s=gt_num(s,&d);
+               }
+               else d=0;
+               op_gen(F,w,d,0);
+               break;
+       case 'd':
+               found=1;
+               s=gt_num(s,&w);
+               if(w==0) break;
+               if(*s=='.')
+               {       s++;
+                       s=gt_num(s,&d);
+               }
+               else d=0;
+               op_gen(D,w,d,0);
+               break;
+       case 'i':
+               found=1;
+               s=gt_num(s,&w);
+               if(w==0) break;
+               if(*s!='.')
+               {       op_gen(I,w,0,0);
+                       break;
+               }
+               s++;
+               s=gt_num(s,&d);
+               op_gen(IM,w,d,0);
+               break;
+       }
+       if(found==0)
+       {       pc--; /*unSTACK*/
+               *p=sv;
+               return(0);
+       }
+       *p=s;
+       return(1);
+}
+op_gen(a,b,c,d)
+{      struct syl *p= &syl[pc];
+       if(pc>=SYLMX)
+       {       fprintf(stderr,"format too complicated:\n%s\n",
+                       fmtbuf);
+               abort();
+       }
+       p->op=a;
+       p->p1=b;
+       p->p2=c;
+       p->p3=d;
+       return(pc++);
+}
+char *gt_num(s,n) char *s; int *n;
+{      int m=0,cnt=0;
+       char c;
+       for(c= *s;;c = *s)
+       {       if(c==' ')
+               {       s++;
+                       continue;
+               }
+               if(c>'9' || c<'0') break;
+               m=10*m+c-'0';
+               cnt++;
+               s++;
+       }
+       if(cnt==0) *n=1;
+       else *n=m;
+       return(s);
+}
+#define STKSZ 10
+int cnt[STKSZ],ret[STKSZ],cp,rp;
+flag workdone;
+en_fio()
+{      ftnint one=1;
+       return(do_fio(&one,NULL,0l));
+}
+do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
+{      struct syl *p;
+       int n,i;
+       for(i=0;i<*number;i++,ptr+=len)
+       {
+loop:  switch(type_f((p= &syl[pc])->op))
+       {
+       default:
+               fprintf(stderr,"unknown code in do_fio: %d\n%s\n",
+                       p->op,fmtbuf);
+               err(elist->cierr,100,"do_fio");
+       case NED:
+               if((*doned)(p,ptr))
+               {       pc++;
+                       goto loop;
+               }
+               pc++;
+               continue;
+       case ED:
+               if(cnt[cp]<=0)
+               {       cp--;
+                       pc++;
+                       goto loop;
+               }
+               if(ptr==NULL)
+                       return((*doend)());
+               cnt[cp]--;
+               workdone=1;
+               if((n=(*doed)(p,ptr,len))>0) err(elist->cierr,errno,"fmt");
+               if(n<0) err(elist->ciend,(EOF),"fmt");
+               continue;
+       case STACK:
+               cnt[++cp]=p->p1;
+               pc++;
+               goto loop;
+       case RET:
+               ret[++rp]=p->p1;
+               pc++;
+               goto loop;
+       case GOTO:
+               if(--cnt[cp]<=0)
+               {       cp--;
+                       rp--;
+                       pc++;
+                       goto loop;
+               }
+               pc=1+ret[rp--];
+               goto loop;
+       case REVERT:
+               rp=cp=0;
+               pc = p->p1;
+               if(ptr==NULL)
+                       return((*doend)());
+               if(!workdone) return(0);
+               if((n=(*dorevert)()) != 0) return(n);
+               goto loop;
+       case COLON:
+               if(ptr==NULL)
+                       return((*doend)());
+               pc++;
+               goto loop;
+       case S:
+       case SS:
+               cplus=0;
+               pc++;
+               goto loop;
+       case SP:
+               cplus = 1;
+               pc++;
+               goto loop;
+       case P: scale=p->p1;
+               pc++;
+               goto loop;
+       case BN:
+               cblank=0;
+               pc++;
+               goto loop;
+       case BZ:
+               cblank=1;
+               pc++;
+               goto loop;
+       }
+       }
+       return(0);
+}
+fmt_bg()
+{
+       workdone=cp=rp=pc=cursor=0;
+       cnt[0]=ret[0]=0;
+}
+type_f(n)
+{
+       switch(n)
+       {
+       default:
+               return(n);
+       case RET:
+               return(RET);
+       case REVERT: return(REVERT);
+       case GOTO: return(GOTO);
+       case STACK: return(STACK);
+       case X:
+       case SLASH:
+       case APOS: case H:
+       case T: case TL: case TR:
+               return(NED);
+       case F:
+       case I:
+       case IM:
+       case A: case AW:
+       case O:
+       case L:
+       case E: case EE: case D:
+       case G: case GE:
+               return(ED);
+       }
+}
+char *ap_end(s) char *s;
+{      char quote;
+       quote= *s++;
+       for(;*s;s++)
+       {       if(*s!=quote) continue;
+               if(*++s!=quote) return(s);
+       }
+       err(elist->cierr,100,"bad string");
+}

diff --git a/usr/src/libI77/fmt.h b/usr/src/libI77/fmt.h
new file mode 100644 (file)
index 0000000..0f1b498
--- /dev/null
+++ b/usr/src/libI77/fmt.h
@@ -0,0 +1,56 @@
+struct syl
+{      int op,p1,p2,p3;
+};
+#define RET 1
+#define REVERT 2
+#define GOTO 3
+#define X 4
+#define SLASH 5
+#define STACK 6
+#define I 7
+#define ED 8
+#define NED 9
+#define IM 10
+#define APOS 11
+#define H 12
+#define TL 13
+#define TR 14
+#define T 15
+#define COLON 16
+#define S 17
+#define SP 18
+#define SS 19
+#define P 20
+#define BN 21
+#define BZ 22
+#define F 23
+#define E 24
+#define EE 25
+#define D 26
+#define G 27
+#define GE 28
+#define L 29
+#define A 30
+#define AW 31
+#define O 32
+extern struct syl syl[];
+extern int pc,parenlvl,revloc;
+extern int (*doed)(),(*doned)();
+extern int (*dorevert)(),(*donewrec)(),(*doend)();
+extern flag cblank,cplus,workdone;
+extern int dummy();
+extern char *fmtbuf;
+extern int scale;
+typedef union
+{      float pf;
+       double pd;
+} ufloat;
+typedef union
+{      short is;
+       char ic;
+       long il;
+} uint;
+#define GET(x) if((x=(*getn)())<0) return(x)
+#define VAL(x) (x!='\n'?x:' ')
+#define PUT(x) (*putn)(x)
+extern int cursor;

diff --git a/usr/src/libI77/fmtlib.c b/usr/src/libI77/fmtlib.c
new file mode 100644 (file)
index 0000000..d745c66
--- /dev/null
+++ b/usr/src/libI77/fmtlib.c
@@ -0,0 +1,23 @@
+#define MAXINTLENGTH 12
+char *icvt(value,ndigit,sign, base) long value; int *ndigit,*sign;
+register int base;
+{      static char buf[MAXINTLENGTH+1];
+       register int i;
+       if(value>0) *sign=0;
+       else if(value<0)
+       {       value = -value;
+               *sign= 1;
+       }
+       else
+       {       *sign=0;
+               *ndigit=1;
+               buf[MAXINTLENGTH]='0';
+               return(&buf[MAXINTLENGTH]);
+       }
+       for(i=MAXINTLENGTH-1;value>0;i--)
+       {       *(buf+i)=(int)(value%base)+'0';
+               value /= base;
+       }
+       *ndigit=MAXINTLENGTH-1-i;
+       return(&buf[i+1]);
+}

diff --git a/usr/src/libI77/iio.c b/usr/src/libI77/iio.c
new file mode 100644 (file)
index 0000000..5e93b16
--- /dev/null
+++ b/usr/src/libI77/iio.c
@@ -0,0 +1,90 @@
+#include "fio.h"
+#include "fmt.h"
+char *icptr,*icend;
+icilist *svic;
+extern int rd_ed(),rd_ned(),w_ed(),w_ned(),y_err();
+extern int z_wnew();
+int icnum,icpos;
+z_getc()
+{
+       if(icptr >= icend) err(svic->iciend,(EOF),"endfile");
+       if(icpos++ < svic->icirlen)
+               return(*icptr++);
+       else    err(svic->icierr,110,"recend");
+}
+z_putc(c)
+{
+       if(icptr >= icend) err(svic->icierr,110,"inwrite");
+       if(icpos++ < svic->icirlen)
+               *icptr++ = c;
+       else    err(svic->icierr,110,"recend");
+       return(0);
+}
+z_rnew()
+{
+       icptr = svic->iciunit + (++icnum)*svic->icirlen;
+       icpos = 0;
+}
+s_rsfi(a) icilist *a;
+{      int n;
+       if(n=c_si(a)) return(n);
+       reading=1;
+       doed=rd_ed;
+       doned=rd_ned;
+       getn=z_getc;
+       dorevert = donewrec = y_err;
+       doend = z_rnew;
+       return(0);
+}
+s_wsfi(a) icilist *a;
+{      int n;
+       if(n=c_si(a)) return(n);
+       reading=0;
+       doed=w_ed;
+       doned=w_ned;
+       putn=z_putc;
+       dorevert = donewrec = y_err;
+       doend = z_wnew;
+       return(0);
+}
+c_si(a) icilist *a;
+{
+       fmtbuf=a->icifmt;
+       if(pars_f(fmtbuf)<0)
+               err(a->icierr,100,"startint");
+       fmt_bg();
+       sequential=formatted=1;
+       external=0;
+       cblank=cplus=scale=0;
+       svic=a;
+       icnum=icpos=0;
+       icptr=svic->iciunit;
+       icend=icptr+svic->icirlen*svic->icirnum;
+       return(0);
+}
+z_wnew()
+{
+       while(icpos++ < svic->icirlen)
+               *icptr++ = ' ';
+       icpos = 0;
+       icnum++;
+}
+e_rsfi()
+{      int n;
+       n = en_fio();
+       fmtbuf = NULL;
+       return(n);
+}
+e_wsfi()
+{
+       int n;
+       n = en_fio();
+       fmtbuf = NULL;
+       while(icpos++ < svic->icirlen)
+               *icptr++ = ' ';
+       return(n);
+}
+y_err()
+{
+       err(elist->cierr, 110, "iio");
+}

diff --git a/usr/src/libI77/lread.c b/usr/src/libI77/lread.c
new file mode 100644 (file)
index 0000000..2e220f6
--- /dev/null
+++ b/usr/src/libI77/lread.c
@@ -0,0 +1,401 @@
+#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 issign(x) (ltab[x+1]&SG)
+#define SX 1
+#define B 2
+#define AX 4
+#define EX 8
+#define SG 16
+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,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,
+       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 if(issign(ch))
+       {       ungetc(ch, cf);
+               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));
+}

diff --git a/usr/src/libI77/rdfmt.c b/usr/src/libI77/rdfmt.c
new file mode 100644 (file)
index 0000000..9bdd49c
--- /dev/null
+++ b/usr/src/libI77/rdfmt.c
@@ -0,0 +1,221 @@
+#include "fio.h"
+#include "fmt.h"
+extern int cursor;
+rd_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len;
+{      int ch;
+       for(;cursor>0;cursor--) if((ch=(*getn)())<0) return(ch);
+       if(cursor<0)
+       {       if(recpos+cursor < 0) err(elist->cierr,110,"fmt")
+               if(curunit->useek) fseek(cf,(long) cursor,1);
+               else err(elist->cierr,106,"fmt");
+               cursor=0;
+       }
+       switch(p->op)
+       {
+       default: fprintf(stderr,"rd_ed, unexpected code: %d\n%s\n",
+                       p->op,fmtbuf);
+               abort();
+       case I: ch = (rd_I(ptr,p->p1,len, 10));
+               break;
+       case IM: ch = (rd_I(ptr,p->p1,len, 10));
+               break;
+       case O: ch = (rd_I(ptr, p->p1, len, 8));
+               break;
+       case L: ch = (rd_L(ptr,p->p1));
+               break;
+       case A: ch = (rd_A(ptr,len));
+               break;
+       case AW:
+               ch = (rd_AW(ptr,p->p1,len));
+               break;
+       case E: case EE:
+       case D:
+       case G:
+       case GE:
+       case F: ch = (rd_F(ptr,p->p1,p->p2,len));
+               break;
+       }
+       if(ch == 0) return(ch);
+       else if(feof(cf)) return(EOF);
+       clearerr(cf);
+       return(errno);
+}
+rd_ned(p,ptr) char *ptr; struct syl *p;
+{
+       switch(p->op)
+       {
+       default: fprintf(stderr,"rd_ned, unexpected code: %d\n%s\n",
+                       p->op,fmtbuf);
+               abort();
+       case APOS:
+               return(rd_POS(p->p1));
+       case H: return(rd_H(p->p1,p->p2));
+       case SLASH: return((*donewrec)());
+       case TR:
+       case X: cursor += p->p1;
+               return(1);
+       case T: cursor=p->p1-recpos;
+               return(1);
+       case TL: cursor -= p->p1;
+               return(1);
+       }
+}
+rd_I(n,w,len, base) ftnlen len; uint *n; register int base;
+{      long x=0;
+       int i,sign=0,ch;
+       for(i=0;i<w;i++)
+       {
+               if((ch=(*getn)())<0) return(ch);
+               switch(ch)
+               {
+               default:
+                       return(errno=115);
+               case ',': goto done;
+               case '+': break;
+               case '-':
+                       sign=1;
+                       break;
+               case '\n':
+               case ' ':
+                       if(cblank) x *= base;
+                       break;
+               case '0': case '1': case '2': case '3': case '4':
+               case '5': case '6': case '7': case '8': case '9':
+                       x=base*x+ch-'0';
+                       break;
+               }
+       }
+done:
+       if(sign) x = -x;
+       if(len==sizeof(short)) n->is=x;
+       else if(len == sizeof(char)) n->ic = x;
+       else n->il=x;
+       return(0);
+}
+rd_L(n,w) ftnint *n;
+{      int ch,i,v = -1;
+       for(i=0;i<w;i++)
+       {       if((ch=(*getn)())<0) return(ch);
+               if(ch=='t' && v==-1) v=1;
+               else if(ch=='f' && v==-1) v=0;
+               else if(ch==',') return(0);
+       }
+       if(v==-1)
+       {       errno=116;
+               return(1);
+       }
+       *n=v;
+       return(0);
+}
+rd_F(p,w,d,len) ftnlen len; ufloat *p;
+{      double x,y;
+       int i,sx,sz,ch,dot,ny,z,sawz;
+       x=y=0;
+       sawz=z=ny=dot=sx=sz=0;
+       for(i=0;i<w;)
+       {       i++;
+               if((ch=(*getn)())<0) return(ch);
+               else if(ch == ' ' && !cblank || ch == '+' && x == 0
+                       || ch == '\n' && !cblank) continue;
+               else if(ch=='-' && x==0) sx=1;
+               else if(ch == '+' || ch == '-') goto expon;
+               else if(ch<='9' && ch>='0')
+                       x=10*x+ch-'0';
+               else if(ch=='e' || ch=='d' || ch=='.')
+                       break;
+               else if(cblank && (ch==' ' || ch== '\n')) x*=10;
+               else if(ch==',')
+               {       i=w;
+                       break;
+               }
+               else return(errno = 115);
+       }
+       if(ch=='.') dot=1;
+       while(i<w && ch!='e' && ch!='d' && ch!='+' && ch!='-')
+       {       i++;
+               if((ch=(*getn)())<0) return(ch);
+               else if(ch<='9' && ch>='0')
+                       y=10*y+ch-'0';
+               else if(cblank && (ch==' ' || ch == '\n'))
+                       y *= 10;
+               else if(ch==',') {i=w; break;}
+               else if(ch==' ') continue;
+               else continue;
+               ny++;
+       }
+expon:
+       if(ch=='-') sz=1;
+       while(i<w)
+       {       i++;
+               sawz=1;
+               if((ch=(*getn)())<0) return(ch);
+               else if(ch=='-') sz=1;
+               else if(ch<='9' && ch>='0')
+                       z=10*z+ch-'0';
+               else if(cblank && (ch==' ' || ch == '\n'))
+                       z *= 10;
+               else if(ch==',') break;
+               else if(ch==' ') continue;
+               else if(ch=='+') continue;
+               else if(ch!='\n') return(errno=115);
+       }
+       if(!dot)
+               for(i=0;i<d;i++) x /= 10;
+       for(i=0;i<ny;i++) y /= 10;
+       x=x+y;
+       if(sz)
+               for(i=0;i<z;i++) x /=10;
+       else    for(i=0;i<z;i++) x *= 10;
+       if(sx) x = -x;
+       if(!sawz)
+       {
+               for(i=scale;i>0;i--) x /= 10;
+               for(i=scale;i<0;i++) x *= 10;
+       }
+       if(len==sizeof(float)) p->pf=x;
+       else p->pd=x;
+       return(0);
+}
+rd_A(p,len) char *p; ftnlen len;
+{      int i,ch;
+       for(i=0;i<len;i++)
+       {       GET(ch);
+               *p++=VAL(ch);
+       }
+       return(0);
+}
+rd_AW(p,w,len) char *p; ftnlen len;
+{      int i,ch;
+       if(w>=len)
+       {       for(i=0;i<w-len;i++)
+                       GET(ch);
+               for(i=0;i<len;i++)
+               {       GET(ch);
+                       *p++=VAL(ch);
+               }
+               return(0);
+       }
+       for(i=0;i<w;i++)
+       {       GET(ch);
+               *p++=VAL(ch);
+       }
+       for(i=0;i<len-w;i++) *p++=' ';
+       return(0);
+}
+rd_H(n,s) char *s;
+{      int i,ch;
+       for(i=0;i<n;i++)
+               if((ch=(*getn)())<0) return(ch);
+               else *s++ = ch=='\n'?' ':ch;
+       return(1);
+}
+rd_POS(s) char *s;
+{      char quote;
+       int ch;
+       quote= *s++;
+       for(;*s;s++)
+               if(*s==quote && *(s+1)!=quote) break;
+               else if((ch=(*getn)())<0) return(ch);
+               else *s = ch=='\n'?' ':ch;
+       return(1);
+}

diff --git a/usr/src/libI77/rewind.c b/usr/src/libI77/rewind.c
new file mode 100644 (file)
index 0000000..3d76887
--- /dev/null
+++ b/usr/src/libI77/rewind.c
@@ -0,0 +1,16 @@
+#include "fio.h"
+f_rew(a) alist *a;
+{
+       unit *b;
+       if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"rewind");
+       b = &units[a->aunit];
+       if(b->ufd == NULL) return(0);
+       if(!b->useek) err(a->aerr,106,"rewind")
+       if(b->uwrt)
+       {       nowreading(b);
+               t_runc(b);
+       }
+       rewind(b->ufd);
+       b->uend=0;
+       return(0);
+}

diff --git a/usr/src/libI77/wrtfmt.c b/usr/src/libI77/wrtfmt.c
new file mode 100644 (file)
index 0000000..5334378
--- /dev/null
+++ b/usr/src/libI77/wrtfmt.c
@@ -0,0 +1,255 @@
+#include "fio.h"
+#include "fmt.h"
+extern int cursor;
+mv_cur()
+{      /*buggy, could move off front of record*/
+       for(;cursor>0;cursor--) (*putn)(' ');
+       if(cursor<0)
+       {
+               if(cursor+recpos<0) err(elist->cierr,110,"left off");
+               if(curunit->useek) fseek(cf,(long)cursor,1);
+               else err(elist->cierr,106,"fmt");
+               cursor=0;
+       }
+       return(0);
+}
+w_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len;
+{
+       if(mv_cur()) return(mv_cur());
+       switch(p->op)
+       {
+       default:
+               fprintf(stderr,"w_ed, unexpected code: %d\n%s\n",
+                       p->op,fmtbuf);
+               abort();
+       case I: return(wrt_I(ptr,p->p1,len, 10));
+       case IM:
+               return(wrt_IM(ptr,p->p1,p->p2,len));
+       case O: return(wrt_I(ptr, p->p1, len, 8));
+       case L: return(wrt_L(ptr,p->p1));
+       case A: return(wrt_A(ptr,len));
+       case AW:
+               return(wrt_AW(ptr,p->p1,len));
+       case D:
+       case E:
+       case EE:
+               return(wrt_E(ptr,p->p1,p->p2,p->p3,len));
+       case G:
+       case GE:
+               return(wrt_G(ptr,p->p1,p->p2,p->p3,len));
+       case F: return(wrt_F(ptr,p->p1,p->p2,len));
+       }
+}
+w_ned(p,ptr) char *ptr; struct syl *p;
+{
+       switch(p->op)
+       {
+       default: fprintf(stderr,"w_ned, unexpected code: %d\n%s\n",
+                       p->op,fmtbuf);
+               abort();
+       case SLASH:
+               return((*donewrec)());
+       case T: cursor = p->p1-recpos;
+               return(1);
+       case TL: cursor -= p->p1;
+               return(1);
+       case TR:
+       case X:
+               cursor += p->p1;
+               return(1);
+       case APOS:
+               return(wrt_AP(p->p1));
+       case H:
+               return(wrt_H(p->p1,p->p2));
+       }
+}
+wrt_I(n,w,len, base) uint *n; ftnlen len; register int base;
+{      int ndigit,sign,spare,i;
+       long x;
+       char *ans;
+       if(len==sizeof(short)) x=n->is;
+       else if(len == sizeof(char)) x = n->ic;
+       else x=n->il;
+       ans=icvt(x,&ndigit,&sign, base);
+       spare=w-ndigit;
+       if(sign || cplus) spare--;
+       if(spare<0)
+               for(i=0;i<len;i++) (*putn)('*');
+       else
+       {       for(i=0;i<spare;i++) (*putn)(' ');
+               if(sign) (*putn)('-');
+               else if(cplus) (*putn)('+');
+               for(i=0;i<ndigit;i++) (*putn)(*ans++);
+       }
+       return(0);
+}
+wrt_IM(n,w,m,len) uint *n; ftnlen len;
+{      int ndigit,sign,spare,i,xsign;
+       long x;
+       char *ans;
+       if(sizeof(short)==len) x=n->is;
+       else if(len == sizeof(char)) x = n->ic;
+       else x=n->il;
+       ans=icvt(x,&ndigit,&sign);
+       if(sign || cplus) xsign=1;
+       else xsign=0;
+       if(ndigit+xsign>w || m+xsign>w)
+       {       for(i=0;i<w;i++) (*putn)('*');
+               return(0);
+       }
+       if(x==0 && m==0)
+       {       for(i=0;i<w;i++) (*putn)(' ');
+               return(0);
+       }
+       if(ndigit>=m)
+               spare=w-ndigit-xsign;
+       else
+               spare=w-m-xsign;
+       for(i=0;i<spare;i++) (*putn)(' ');
+       if(sign) (*putn)('-');
+       else if(cplus) (*putn)('+');
+       for(i=0;i<m-ndigit;i++) (*putn)('0');
+       for(i=0;i<ndigit;i++) (*putn)(*ans++);
+       return(0);
+}
+wrt_AP(n)
+{      char *s,quote;
+       if(mv_cur()) return(mv_cur());
+       s=(char *)n;
+       quote = *s++;
+       for(;*s;s++)
+       {       if(*s!=quote) (*putn)(*s);
+               else if(*++s==quote) (*putn)(*s);
+               else return(1);
+       }
+       return(1);
+}
+wrt_H(a,b)
+{      char *s=(char *)b;
+       if(mv_cur()) return(mv_cur());
+       while(a--) (*putn)(*s++);
+       return(1);
+}
+wrt_L(n,len) ftnint *n;
+{      int i;
+       for(i=0;i<len-1;i++)
+               (*putn)(' ');
+       if(*n) (*putn)('t');
+       else (*putn)('f');
+       return(0);
+}
+wrt_A(p,len) char *p; ftnlen len;
+{
+       while(len-- > 0) (*putn)(*p++);
+       return(0);
+}
+wrt_AW(p,w,len) char * p; ftnlen len;
+{
+       while(w>len)
+       {       w--;
+               (*putn)(' ');
+       }
+       while(w-- > 0)
+               (*putn)(*p++);
+       return(0);
+}
+wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
+{      char *s;
+       int dp,sign,i,delta;
+       char *ecvt();
+       if(scale>0) d++;
+       s=ecvt( (len==sizeof(float)?p->pf:p->pd) ,d,&dp,&sign);
+       if(sign || cplus) delta=6;
+       else delta=5;
+       if(w<delta+d)
+       {       for(i=0;i<w;i++) (*putn)('*');
+               return(0);
+       }
+       for(i=0;i<w-(delta+d);i++) (*putn)(' ');
+       if(sign) (*putn)('-');
+       else if(cplus) (*putn)('+');
+       if(scale<0 && scale > -d)
+       {
+               (*putn)('.');
+               for(i=0;i<-scale;i++)
+                       (*putn)('0');
+               for(i=0;i<d+scale;i++)
+                       (*putn)(*s++);
+       }
+       else if(scale>0 && scale<d+2)
+       {       for(i=0;i<scale;i++)
+                       (*putn)(*s++);
+               (*putn)('.');
+               for(i=0;i<d-scale;i++)
+                       (*putn)(*s++);
+       }
+       else
+       {       (*putn)('.');
+               for(i=0;i<d;i++) (*putn)(*s++);
+       }
+       if(p->pf != 0) dp -= scale;
+       else    dp = 0;
+       if(dp < 100 && dp > -100) (*putn)('e');
+       if(dp<0)
+       {       (*putn)('-');
+               dp = -dp;
+       }
+       else    (*putn)('+');
+       if(e>=3 || dp >= 100)
+       {       (*putn)(dp/100 + '0');
+               dp = dp % 100;
+       }
+       if(e!=1) (*putn)(dp/10+'0');
+       (*putn)(dp%10+'0');
+       return(0);
+}
+wrt_G(p,w,d,e,len) ufloat *p; ftnlen len;
+{      double up = 1,x;
+       int i,oldscale=scale,n,j;
+       x= len==sizeof(float)?p->pf:p->pd;
+       if(x < 0 ) x = -x;
+       if(x<.1) return(wrt_E(p,w,d,e,len));
+       for(i=0;i<=d;i++,up*=10)
+       {       if(x>up) continue;
+               scale=0;
+               if(e==0) n=4;
+               else    n=e+2;
+               i=wrt_F(p,w-n,d-i,len);
+               for(j=0;j<n;j++) (*putn)(' ');
+               scale=oldscale;
+               return(i);
+       }
+       return(wrt_E(p,w,d,e,len));
+}
+wrt_F(p,w,d,len) ufloat *p; ftnlen len;
+{      int i,delta,dp,sign,n;
+       double x;
+       char *s,*fcvt();
+       x= (len==sizeof(float)?p->pf:p->pd);
+       if(scale)
+       {       if(scale>0)
+                       for(i=0;i<scale;i++) x*=10;
+               else    for(i=0;i<-scale;i++) x/=10;
+       }
+       s=fcvt(x,d,&dp,&sign);
+       if(-dp>=d) sign=0;
+       if(sign || cplus) delta=2;
+       else delta=1;
+       n= w - (d+delta+(dp>0?dp:0));
+       if(n<0)
+       {
+               for(i=0;i<w;i++) PUT('*');
+               return(0);
+       }
+       for(i=0;i<n;i++) PUT(' ');
+       if(sign) PUT('-');
+       else if(cplus) PUT('+');
+       for(i=0;i<dp;i++) PUT(*s++);
+       PUT('.');
+       for(i=0;i< -dp && i<d;i++) PUT('0');
+       for(;i<d;i++)
+       {       if(*s) PUT(*s++);
+               else PUT('0');
+       }
+       return(0);
+}

diff --git a/usr/src/libI77/wsfe.c b/usr/src/libI77/wsfe.c
new file mode 100644 (file)
index 0000000..5b64244
--- /dev/null
+++ b/usr/src/libI77/wsfe.c
@@ -0,0 +1,68 @@
+/*write sequential formatted external*/
+#include "fio.h"
+#include "fmt.h"
+extern int x_putc(),w_ed(),w_ned();
+extern int xw_end(),xw_rev(),x_wSL();
+s_wsfe(a) cilist *a;   /*start*/
+{      int n;
+       if(!init) f_init();
+       if(n=c_sfe(a,WRITE)) return(n);
+       reading=0;
+       sequential=1;
+       formatted=1;
+       external=1;
+       elist=a;
+       cursor=recpos=0;
+       scale=0;
+       fmtbuf=a->cifmt;
+       if(pars_f(fmtbuf)<0) err(a->cierr,100,"startio");
+       curunit = &units[a->ciunit];
+       cf=curunit->ufd;
+       putn= x_putc;
+       doed= w_ed;
+       doned= w_ned;
+       doend=xw_end;
+       dorevert=xw_rev;
+       donewrec=x_wSL;
+       fmt_bg();
+       cplus=0;
+       cblank=curunit->ublnk;
+       if(!curunit->uwrt) nowwriting(curunit);
+       return(0);
+}
+x_putc(c)
+{
+       recpos++;
+       putc(c,cf);
+}
+pr_put(c)
+{      static flag new = 1;
+       recpos++;
+       if(c=='\n')
+       {       new=1;
+               putc(c,cf);
+       }
+       else if(new==1)
+       {       new=0;
+               if(c=='0') putc('\n',cf);
+               else if(c=='1') putc('\f',cf);
+       }
+       else putc(c,cf);
+}
+x_wSL()
+{
+       recpos=0;
+       cursor = 0;
+       (*putn)('\n');
+       return(1);
+}
+xw_end()
+{
+       (*putn)('\n');
+       return(0);
+}
+xw_rev()
+{
+       if(workdone) (*putn)('\n');
+       return(workdone=0);
+}