--- /dev/null
+/*
+ * 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);
+}
--- /dev/null
+/*
+ * 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);
+}