From 648e85ce04420927ca679c9b189bda3ffeed4074 Mon Sep 17 00:00:00 2001
From: Bill Joy <wnj@ucbvax.Berkeley.EDU>
Date: Fri, 31 Oct 1980 04:19:37 -0800
Subject: [PATCH] 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
---
 usr/src/lib/libI77uc/lread.c  | 373 ++++++++++++++++++++++++++++++++++
 usr/src/lib/libI77uc/wrtfmt.c | 270 ++++++++++++++++++++++++
 2 files changed, 643 insertions(+)
 create mode 100644 usr/src/lib/libI77uc/lread.c
 create mode 100644 usr/src/lib/libI77uc/wrtfmt.c

diff --git a/usr/src/lib/libI77uc/lread.c b/usr/src/lib/libI77uc/lread.c
new file mode 100644
index 0000000000..3578c50983
--- /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
index 0000000000..4036b0de9b
--- /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);
+}
-- 
2.20.1