BSD 4 development

Work on file usr/src/lib/libI77uc/lread.c
Work on file usr/src/lib/libI77uc/wrtfmt.c

Synthesized-from: CSRG//cd1/4.0

diff --git a/usr/src/lib/libI77uc/lread.c b/usr/src/lib/libI77uc/lread.c
new file mode 100644 (file)
index 0000000..3578c50
--- /dev/null
+++ b/usr/src/lib/libI77uc/lread.c
@@ -0,0 +1,373 @@
+/*
+ * list directed read
+ */
+
+#include "fio.h"
+#include "lio.h"
+
+#define SP 1
+#define B  2
+#define AP 4
+#define EX 8
+#define D 16
+#define EIN 32
+#define isblnk(x)      (ltab[x+1]&B)
+#define issep(x)       (ltab[x+1]&SP)
+#define isapos(x)      (ltab[x+1]&AP)
+#define isexp(x)       (ltab[x+1]&EX)
+#define isdigit(x)     (ltab[x+1]&D)
+#define endlinp(x)     (ltab[x+1]&EIN)
+
+#define GETC(x) (x=(*getn)())
+
+char *lrd = "list read";
+char *lchar;
+double lx,ly;
+int ltype;
+int l_read(),t_getc(),ungetc();
+
+char ltab[128+1] =
+{              EIN, /* offset one for EOF */
+/*   0- 15 */  0,0,AP,0,0,0,0,0,0,B,SP|B|EIN,0,0,0,0,0, /* ^B,TAB,NEWLINE */
+/*  16- 31 */  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+/*  32- 47 */  SP|B,0,AP,0,0,0,0,AP,0,0,0,0,SP,0,0,EIN, /* space,",',comma,/ */
+/*  48- 63 */  D,D,D,D,D,D,D,D,D,D,0,0,0,0,0,0,        /* digits 0-9 */
+/*  64- 79 */  0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,      /* D,E */
+/*  80- 95 */  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+/*  96-111 */  0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,      /* d,e */
+/* 112-127 */  0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
+};
+
+s_rsle(a) cilist *a;   /* start read sequential list external */
+{
+       int n;
+       reading = YES;
+       if(n=c_le(a,READ)) return(n);
+       l_first = YES;
+       lquit = NO;
+       lioproc = l_read;
+       getn = t_getc;
+       ungetn = ungetc;
+       leof = curunit->uend;
+       lcount = 0;
+       if(curunit->uwrt) nowreading(curunit);
+       return(OK);
+}
+
+t_getc()
+{      int ch;
+       if(curunit->uend) return(EOF);
+       if((ch=getc(cf))!=EOF) return(ch);
+       if(feof(cf))
+       {       curunit->uend = YES;
+               leof = EOF;
+       }
+       else clearerr(cf);
+       return(EOF);
+}
+
+e_rsle()
+{
+       int ch;
+       if(curunit->uend) return(OK);
+       while(!endlinp(GETC(ch)));
+       return(OK);
+}
+
+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(leof) err(endflag, EOF, lrd)
+               if(l_first)
+               {       l_first = NO;
+                       while(isblnk(GETC(ch)));        /* skip blanks */
+                       (*ungetn)(ch,cf);
+               }
+               else if(lcount==0)              /* repeat count == 0 ? */
+               {       ERR(t_sep());  /* look for non-blank, allow 1 comma */
+                       if(lquit) return(OK);   /* slash found */
+               }
+               switch((int)type)
+               {
+               case TYSHORT:
+               case TYLONG:
+               case TYREAL:
+               case TYDREAL:
+                       ERR(l_R(1));
+                       break;
+               case TYCOMPLEX:
+               case TYDCOMPLEX:
+                       ERR(l_C());
+                       break;
+               case TYLOGICAL:
+                       ERR(l_L());
+                       break;
+               case TYCHAR:
+                       ERR(l_CHAR());
+                       break;
+               }
+               if(lquit) return(OK);
+               if(leof) err(endflag,EOF,lrd)
+               else if(external && ferror(cf)) err(errflag,errno,lrd)
+               if(ltype) 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++ = ly;
+                       *xx = lx;
+                       break;
+               case TYDCOMPLEX:
+                       yy=(double *)ptr;
+                       *yy++ = ly;
+                       *yy = lx;
+                       break;
+               case TYCHAR:
+                       b_char(lchar,(char *)ptr,len);
+                       break;
+               }
+               if(lcount>0) lcount--;
+               ptr = (char *)ptr + len;
+       }
+       return(OK);
+}
+
+lr_comm()
+{      int ch;
+       if(lcount) return(lcount);
+       ltype=NULL;
+       while(isblnk(GETC(ch)));
+       if(ch==',')
+       {       lcount=1;
+               return(lcount);
+       }
+       (*ungetn)(ch,cf);
+       if(ch=='/')
+       {       lquit = YES;
+               return(lquit);
+       }
+       else
+               return(OK);
+}
+
+get_repet()
+{      char ch;
+       double lc;
+       if(isdigit(GETC(ch)))
+       {       (*ungetn)(ch,cf);
+               rd_int(&lc);
+               lcount = (int)lc;
+               if(GETC(ch)!='*')
+                       if(leof) return(EOF);
+                       else return(109);
+       }
+       else
+       {       lcount = 1;
+               (*ungetn)(ch,cf);
+       }
+       return(OK);
+}
+
+l_R(flg) int flg;
+{      double a,b,c,d;
+       int da,db,dc,dd;
+       int i,ch,sign=0;
+       a=b=c=d=0;
+       da=db=dc=dd=0;
+       if(flg && lr_comm()) return(OK);
+       da=rd_int(&a);  /* repeat count ? */
+       if(GETC(ch)=='*')
+       {
+               if (a <= 0.) return(122);
+               lcount=(int)a;
+               db=rd_int(&b);  /* whole part of number */
+       }
+       else
+       {       (*ungetn)(ch,cf);
+               db=da;
+               b=a;
+               lcount=1;
+       }
+       if(GETC(ch)=='.' && isdigit(GETC(ch)))
+       {       (*ungetn)(ch,cf);
+               dc=rd_int(&c);  /* fractional part of number */
+       }
+       else
+       {       (*ungetn)(ch,cf);
+               dc=0;
+               c=0.;
+       }
+       if(isexp(GETC(ch)))
+               dd=rd_int(&d);  /* exponent */
+       else if (ch == '+' || ch == '-')
+       {       (*ungetn)(ch,cf);
+               dd=rd_int(&d);
+       }
+       else
+       {       (*ungetn)(ch,cf);
+               dd=0;
+       }
+       if(db<0 || b<0)
+       {       sign=1;
+               b = -b;
+       }
+       for(i=0;i<dc;i++) c/=10.;
+       b=b+c;
+       if (dd > 0)
+       {       for(i=0;i<d;i++) b *= 10.;
+               for(i=0;i< -d;i++) b /= 10.;
+       }
+       lx=sign?-b:b;
+       ltype=TYLONG;
+       return(OK);
+}
+
+rd_int(x) double *x;
+{      int ch,sign=0,i=0;
+       double y=0.0;
+       if(GETC(ch)=='-') sign = -1;
+       else if(ch=='+') sign=0;
+       else (*ungetn)(ch,cf);
+       while(isdigit(GETC(ch)))
+       {       i++;
+               y=10*y + ch-'0';
+       }
+       (*ungetn)(ch,cf);
+       if(sign) y = -y;
+       *x = y;
+       return(y==0.0?sign:i); /* 0:[+]&&y==0, -1:-&&y==0, >0:#digits&&y!=0 */
+}
+
+l_C()
+{      int ch,n;
+       if(lr_comm()) return(OK);
+       if(n=get_repet()) return(n);            /* get repeat count */
+       if(GETC(ch)!='(') err(errflag,112,"no (")
+       while(isblnk(GETC(ch)));
+       (*ungetn)(ch,cf);
+       l_R(0);         /* get real part */
+       ly = lx;
+       if(t_sep()) return(EOF);
+       l_R(0);         /* get imag part */
+       while(isblnk(GETC(ch)));
+       if(ch!=')') err(errflag,112,"no )")
+       ltype = TYCOMPLEX;
+       return(OK);
+}
+
+l_L()
+{
+       int ch,n;
+       if(lr_comm()) return(OK);
+       if(n=get_repet()) return(n);            /* get repeat count */
+       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))
+               {       (*ungetn)(ch,cf);
+                       lx=0;
+                       return(OK);
+               }
+               else if(ch==EOF) return(EOF);
+               else    err(errflag,112,"logical not T or F");
+       }
+       ltype=TYLOGICAL;
+       while(!issep(GETC(ch)) && !isblnk(ch) && ch!='\n' && ch!=EOF);
+       return(OK);
+}
+
+#define BUFSIZE        128
+l_CHAR()
+{      int ch,size,i,n;
+       char quote,*p;
+       if(lr_comm()) return(OK);
+       if(n=get_repet()) return(n);            /* get repeat count */
+       if(isapos(GETC(ch))) quote=ch;
+       else if(isblnk(ch) || issep(ch) || ch==EOF || ch=='\n')
+       {       if(ch==EOF) return(EOF);
+               (*ungetn)(ch,cf);
+               return(OK);
+       }
+       else
+       {       quote = '\0';   /* to allow single word non-quoted */
+               (*ungetn)(ch,cf);
+       }
+       ltype=TYCHAR;
+       if(lchar!=NULL) free(lchar);
+       size=BUFSIZE-1;
+       p=lchar=(char *)malloc(BUFSIZE);
+       if(lchar==NULL) err(errflag,113,lrd)
+       for(i=0;;)
+       {       while( ( (quote && GETC(ch)!=quote) ||
+                       (!quote && !issep(GETC(ch)) && !isblnk(ch) ) )
+                       && ch!='\n' && ch!=EOF && ++i<size )
+                               *p++ = ch;
+               if(i==size)
+               {
+               newone:
+                       size += BUFSIZE;
+                       lchar=(char *)realloc(lchar, size+1);
+                       if(lchar==NULL) err(errflag,113,lrd)
+                       p=lchar+i-1;
+                       *p++ = ch;
+               }
+               else if(ch==EOF) return(EOF);
+               else if(ch=='\n')
+               {       if(*(p-1) == '\\') *(p-1) = ch;
+                       else if(!quote)
+                       {       *p = '\0';
+                               (*ungetn)(ch,cf);
+                               return(OK);
+                       }
+               }
+               else if(quote && GETC(ch)==quote)
+               {       if(++i<size) *p++ = ch;
+                       else goto newone;
+               }
+               else
+               {       (*ungetn)(ch,cf);
+                       *p = '\0';
+                       return(OK);
+               }
+       }
+}
+
+t_sep()
+{
+       int ch;
+       while(isblnk(GETC(ch)));
+       if(leof) return(EOF);
+       if(ch=='/')
+       {       lquit = YES;
+               (*ungetn)(ch,cf);
+               return(OK);
+       }
+       if(issep(ch)) while(isblnk(GETC(ch)));
+       if(leof) return(EOF);
+       (*ungetn)(ch,cf);
+       return(OK);
+}

diff --git a/usr/src/lib/libI77uc/wrtfmt.c b/usr/src/lib/libI77uc/wrtfmt.c
new file mode 100644 (file)
index 0000000..4036b0d
--- /dev/null
+++ b/usr/src/lib/libI77uc/wrtfmt.c
@@ -0,0 +1,270 @@
+/*
+ * formatted write routines
+ */
+
+#include "fio.h"
+#include "fmt.h"
+
+extern char *icvt();
+
+#define abs(x) (x<0?-x:x)
+
+w_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len;
+{      int n;
+       if(cursor && (n=wr_mvcur())) return(n);
+       switch(p->op)
+       {
+       case I:
+       case IM:
+               return(wrt_IM(ptr,p->p1,p->p2,len));
+       case L:
+               return(wrt_L(ptr,p->p1));
+       case A:
+               p->p1 = len;    /* cheap trick */
+       case AW:
+               return(wrt_AW(ptr,p->p1,len));
+       case D:
+       case DE:
+       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));
+       default:
+               return(errno=100);
+       }
+}
+
+w_ned(p,ptr) char *ptr; struct syl *p;
+{
+       switch(p->op)
+       {
+       case SLASH:
+               return((*donewrec)());
+       case T:
+               if(p->p1) cursor = p->p1 - recpos - 1;
+#ifndef KOSHER
+               else cursor = 8*p->p2 - recpos%8;       /* NOT STANDARD FORT */
+#endif
+               tab = YES;
+               return(OK);
+       case TL:
+               cursor -= p->p1;
+               tab = YES;
+               return(OK);
+       case TR:
+       case X:
+               cursor += p->p1;
+               tab = (p->op == TR);
+               return(OK);
+       case APOS:
+               return(wrt_AP(p->p1));
+       case H:
+               return(wrt_H(p->p1,p->p2));
+       default:
+               return(errno=100);
+       }
+}
+
+wr_mvcur()
+{      int n;
+       if(tab) return((*dotab)());
+       while(cursor--) PUT(' ')
+       return(cursor=0);
+}
+
+wrt_IM(ui,w,m,len) uint *ui; ftnlen len;
+{      int ndigit,sign,spare,i,xsign,n;
+       long x;
+       char *ans;
+       if(sizeof(short)==len) x=ui->is;
+/*     else if(len == sizeof(char)) x = ui->ic; */
+       else x=ui->il;
+       if(x==0 && m==0)
+       {       for(i=0;i<w;i++) PUT(' ')
+               return(OK);
+       }
+       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++) PUT('*')
+               return(OK);
+       }
+       if(ndigit>=m)
+               spare=w-ndigit-xsign;
+       else
+               spare=w-m-xsign;
+       for(i=0;i<spare;i++) PUT(' ')
+       if(sign) PUT('-')
+       else if(cplus) PUT('+')
+       for(i=0;i<m-ndigit;i++) PUT('0')
+       for(i=0;i<ndigit;i++) PUT(*ans++)
+       return(OK);
+}
+
+wrt_AP(p)
+{      char *s,quote;
+       int n;
+       if(cursor && (n=wr_mvcur())) return(n);
+       s=(char *)p;
+       quote = *s++;
+       for(; *s; s++)
+       {       if(*s!=quote) PUT(*s)
+               else if(*++s==quote) PUT(*s)
+               else return(OK);
+       }
+       return(OK);
+}
+
+wrt_H(a,b)
+{      char *s=(char *)b;
+       int n;
+       if(cursor && (n=wr_mvcur())) return(n);
+       while(a--) PUT(*s++)
+       return(OK);
+}
+
+wrt_L(l,len) ftnint *l;
+{      int i,n;
+       for(i=0;i<len-1;i++) PUT(' ')
+       if(*l) PUT('t')
+       else PUT('f')
+       return(OK);
+}
+
+wrt_AW(p,w,len) char * p; ftnlen len;
+{      int n;
+       while(w>len)
+       {       w--;
+               PUT(' ')
+       }
+       while(w-- > 0)
+               PUT(*p++)
+       return(OK);
+}
+
+wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
+{      char *s,ex[4],expch;
+       int dd,dp,sign,i,delta,pad,n;
+       char *ecvt();
+       expch=(len==sizeof(float)?'e':'d');
+       if((len==sizeof(float)?p->pf:p->pd)==0.0)
+       {
+               wrt_F(p,w-(e+2),d,len);
+               PUT(expch)
+               PUT('+')
+/*             for(i=0;i<(e-1);i++)PUT(' ')
+deleted                PUT('0')
+ */
+/* added */    for(i=0;i<e;i++) PUT('0')
+               return(OK);
+       }
+       dd = d + scale;
+       s=ecvt( (len==sizeof(float)?(double)p->pf:p->pd) ,dd,&dp,&sign);
+       delta = 3+e;
+       if(sign||cplus) delta++;
+       pad=w-(delta+d)-(scale>0? scale:0);
+       if(pad<0)
+       {       for(i=0;i<w;i++) PUT('*')
+               return(OK);
+       }
+       for(i=0;i<(pad-(scale<=0?1:0));i++) PUT(' ')
+       if(sign) PUT('-')
+       else if(cplus) PUT('+')
+       if(scale<=0 && pad) PUT('0')
+       if(scale<0 && scale > -d)
+       {
+               PUT('.')
+               for(i=0;i<-scale;i++)
+                       PUT('0')
+               for(i=0;i<d+scale;i++)
+                       PUT(*s++)
+       }
+       else
+       {
+               if(scale>0)
+                       for(i=0;i<scale;i++)
+                               PUT(*s++)
+               PUT('.')
+               for(i=0;i<d;i++)
+                       PUT(*s++)
+       }
+       dp -= scale;
+       sprintf(ex,"%d",abs(dp));
+       if((pad=strlen(ex))>e)
+       {       if(pad>(++e))
+               {       PUT(expch)
+                       for(i=0;i<e;i++) PUT('*')
+                       return(OK);
+               }
+       }
+       else PUT(expch)
+       PUT(dp<0?'-':'+')
+       for(i=0;i<(e-pad);i++) PUT('0')  /* was ' ' */
+       s= &ex[0];
+       while(*s) PUT(*s++)
+       return(OK);
+}
+
+wrt_G(p,w,d,e,len) ufloat *p; ftnlen len;
+{      double uplim = 1.0, x;
+       int i,oldscale,n,j,ne;
+       x=(len==sizeof(float)?(double)p->pf:p->pd);
+       i=d;
+       if(x==0.0) goto zero;
+       x = abs(x);
+       if(x>=0.1)
+       {
+               for(i=0; i<=d; i++, uplim*=10.0)
+               {       if(x>uplim) continue;
+zero:                  oldscale=scale;
+                       scale=0;
+                       ne = e+2;
+                       if(n = wrt_F(p,w-ne,d-i,len)) return(n);
+                       for(j=0; j<ne; j++) PUT(' ')
+                       scale=oldscale;
+                       return(OK);
+               }
+               /* falling off the bottom implies E format */
+       }
+       return(wrt_E(p,w,d,e,len));
+}
+
+wrt_F(p,w,d,len) ufloat *p; ftnlen len;
+{      int i,delta,dp,sign,n,nf;
+       double x;
+       char *s,*fcvt();
+       x= (len==sizeof(float)?(double)p->pf:p->pd);
+       if(scale && x!=0.0)
+       {       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; ?? */
+       delta=1;
+       if(sign || cplus) delta++;
+       nf = w - (d + delta + (dp>0?dp:0));
+       if(nf<0)
+       {
+               for(i=0;i<w;i++) PUT('*')
+               return(OK);
+       }
+       if(nf>0) for(i=0; i<(nf-(dp<=0?1:0)); i++) PUT(' ')
+       if(sign) PUT('-')
+       else if(cplus) PUT('+')
+       if(dp>0) for(i=0;i<dp;i++) PUT(*s++)
+       else if(nf>0) PUT('0')
+       PUT('.')
+       for(i=0; i< -dp && i<d; i++) PUT('0')
+       for(;i<d;i++)
+       {       if(x==0.0) PUT(' ')     /* exactly zero */
+               else if(*s) PUT(*s++)
+               else PUT('0')
+       }
+       return(OK);
+}