[unix-history] / usr / src / libI77 / lread.c

#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;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));
}
Commit	Line	Data
519f7756 TL	1	#include "fio.h"
	2	#include "fmt.h"
	3	#include "lio.h"
	4	#include "ctype.h"
	5	extern char *fmtbuf;
	6	int (*lioproc)();
	7
	8	#define isblnk(x) (ltab[x+1]&B)
	9	#define issep(x) (ltab[x+1]&SX)
	10	#define isapos(x) (ltab[x+1]&AX)
	11	#define isexp(x) (ltab[x+1]&EX)
	12	#define SX 1
	13	#define B 2
	14	#define AX 4
	15	#define EX 8
	16	char ltab[128+1] /* offset one for EOF */
	17	{ 0,
	18	0,0,AX,0,0,0,0,0,0,0,B,0,0,0,0,0,
	19	0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
	20	SX\|B,0,AX,0,0,0,0,0,0,0,0,0,SX,0,0,SX,
	21	0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
	22	0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
	23	AX,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
	24	0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
	25	0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
	26	};
	27
	28	int l_first;
	29	t_getc()
	30	{ int ch;
	31	if(curunit->uend) return(EOF);
	32	if((ch=getc(cf))!=EOF) return(ch);
	33	if(feof(cf)) curunit->uend = 1;
	34	return(EOF);
	35	}
	36	e_rsle()
	37	{
	38	int ch;
	39	if(curunit->uend) return(0);
	40	while((ch=t_getc())!='\n' && ch!=EOF);
	41	return(0);
	42	}
	43
	44	flag lquit;
	45	int lcount,ltype;
	46	char *lchar;
	47	double lx,ly;
	48	#define ERR(x) if(n=(x)) return(n)
	49	#define GETC(x) (x=t_getc())
	50
	51	l_read(number,ptr,len,type) ftnint number,type; flex ptr; ftnlen len;
	52	{ int i,n,ch;
	53	double *yy;
	54	float *xx;
	55	for(i=0;i<*number;i++)
	56	{
	57	if(curunit->uend) err(elist->ciend, EOF, "list in")
	58	if(l_first)
	59	{ l_first=0;
	60	for(GETC(ch);isblnk(ch);GETC(ch));
	61	ungetc(ch,cf);
	62	}
	63	else if(lcount==0)
	64	{ ERR(t_sep());
65	if(lquit) return(0);
66	}
67	switch((int)type)
68	{
69	case TYSHORT:
70	case TYLONG:
71	case TYREAL:
72	case TYDREAL:
73	ERR(l_R());
74	break;
75	case TYCOMPLEX:
76	case TYDCOMPLEX:
77	ERR(l_C());
78	break;
79	case TYLOGICAL:
80	ERR(l_L());
81	break;
82	case TYCHAR:
83	ERR(l_CHAR());
84	break;
85	}
86	if(lquit) return(0);
87	if(feof(cf)) err(elist->ciend,(EOF),"list in")
88	else if(ferror(cf))
89	{ clearerr(cf);
90	err(elist->cierr,errno,"list in")
91	}
92	if(ltype==NULL) goto bump;
93	switch((int)type)
94	{
95	case TYSHORT:
96	ptr->flshort=lx;
97	break;
98	case TYLOGICAL:
99	case TYLONG:
100	ptr->flint=lx;
101	break;
102	case TYREAL:
103	ptr->flreal=lx;
104	break;
105	case TYDREAL:
106	ptr->fldouble=lx;
107	break;
108	case TYCOMPLEX:
109	xx=(float *)ptr;
110	*xx++ = lx;
111	*xx = ly;
112	break;
113	case TYDCOMPLEX:
114	yy=(double *)ptr;
115	*yy++ = lx;
116	*yy = ly;
117	break;
118	case TYCHAR:
119	b_char(lchar,(char *)ptr,len);
120	break;
121	}
122	bump:
123	if(lcount>0) lcount--;
124	ptr = (char *)ptr + len;
125	}
126	return(0);
127	}
128	l_R()
129	{ double a,b,c,d;
130	int i,ch,sign=0,da,db,dc;
131	a=b=c=d=0;
132	da=db=dc=0;
133	if(lcount>0) return(0);
134	ltype=NULL;
135	for(GETC(ch);isblnk(ch);GETC(ch));
136	if(ch==',')
137	{ lcount=1;
138	return(0);
139	}
140	if(ch=='/')
141	{ lquit=1;
142	return(0);
143	}
144	ungetc(ch,cf);
145	da=rd_int(&a);
146	if(da== -1) sign=da;
147	if(GETC(ch)!='*')
148	{ ungetc(ch,cf);
149	db=1;
150	b=a;
151	a=1;
152	}
153	else
154	db=rd_int(&b);
155	if(GETC(ch)!='.')
156	{ dc=c=0;
157	ungetc(ch,cf);
158	}
159	else dc=rd_int(&c);
160	if(isexp(GETC(ch))) db=rd_int(&d);
161	else
162	{ ungetc(ch,cf);
163	d=0;
164	}
165	lcount=a;
166	if(!db && !dc)
167	return(0);
168	if(db && b<0)
169	{ sign=1;
170	b = -b;
171	}
172	for(i=0;i<dc;i++) c/=10;
173	b=b+c;
174	for(i=0;i<d;i++) b *= 10;
175	for(i=0;i< -d;i++) b /= 10;
176	if(sign) b = -b;
177	ltype=TYLONG;
178	lx=b;
179	return(0);
180	}
181	rd_int(x) double *x;
182	{ int ch,sign=0,i;
183	double y;
184	i=0;
185	y=0;
186	if(GETC(ch)=='-') sign = -1;
187	else if(ch=='+') sign=0;
188	else ungetc(ch,cf);
189	while(isdigit(GETC(ch)))
190	{ i++;
191	y=10*y+ch-'0';
192	}
193	ungetc(ch,cf);
194	if(sign) y = -y;
195	*x = y;
196	return(y!=0?i:sign);
197	}
198	l_C()
199	{ int ch;
200	if(lcount>0) return(0);
201	ltype=NULL;
202	for(GETC(ch);isblnk(ch);GETC(ch));
203	if(ch==',')
204	{ lcount=1;
205	return(0);
206	}
207	if(ch=='/')
208	{ lquit=1;
209	return(0);
210	}
211	if(ch!='(')
212	{ if(fscanf(cf,"%d",&lcount)!=1)
213	if(!feof(cf)) err(elist->cierr,112,"no rep")
214	else err(elist->cierr,(EOF),"lread");
215	if(GETC(ch)!='*')
216	{ ungetc(ch,cf);
217	if(!feof(cf)) err(elist->cierr,112,"no star")
218	else err(elist->cierr,(EOF),"lread");
219	}
220	if(GETC(ch)!='(')
221	{ ungetc(ch,cf);
222	return(0);
223	}
224	}
225	lcount = 1;
226	ltype=TYLONG;
227	fscanf(cf,"%lf",&lx);
228	while(isblnk(GETC(ch)));
229	if(ch!=',')
230	{ ungetc(ch,cf);
231	err(elist->cierr,112,"no comma");
232	}
233	while(isblnk(GETC(ch)));
234	ungetc(ch,cf);
235	fscanf(cf,"%lf",&ly);
236	while(isblnk(GETC(ch)));
237	if(ch!=')') err(elist->cierr,112,"no )");
238	while(isblnk(GETC(ch)));
239	ungetc(ch,cf);
240	return(0);
241	}
242	l_L()
243	{
244	int ch;
245	if(lcount>0) return(0);
246	ltype=NULL;
247	while(isblnk(GETC(ch)));
248	if(ch==',')
249	{ lcount=1;
250	return(0);
251	}
252	if(ch=='/')
253	{ lquit=1;
254	return(0);
255	}
256	if(isdigit(ch))
257	{ ungetc(ch,cf);
258	fscanf(cf,"%d",&lcount);
259	if(GETC(ch)!='*')
260	if(!feof(cf)) err(elist->cierr,112,"no star")
261	else err(elist->cierr,(EOF),"lread");
262	}
263	else ungetc(ch,cf);
264	if(GETC(ch)=='.') GETC(ch);
265	switch(ch)
266	{
267	case 't':
268	case 'T':
269	lx=1;
270	break;
271	case 'f':
272	case 'F':
273	lx=0;
274	break;
275	default:
276	if(isblnk(ch) \|\| issep(ch) \|\| ch==EOF)
277	{ ungetc(ch,cf);
278	return(0);
279	}
280	else err(elist->cierr,112,"logical");
281	}
282	ltype=TYLONG;
283	while(!issep(GETC(ch)) && ch!='\n' && ch!=EOF);
284	return(0);
285	}
286	#define BUFSIZE 128
287	l_CHAR()
288	{ int ch,size,i;
289	char quote,*p;
290	if(lcount>0) return(0);
291	ltype=NULL;
292
293	while(isblnk(GETC(ch)));
294	if(ch==',')
295	{ lcount=1;
296	return(0);
297	}
298	if(ch=='/')
299	{ lquit=1;
300	return(0);
301	}
302	if(isdigit(ch))
303	{ ungetc(ch,cf);
304	fscanf(cf,"%d",&lcount);
305	if(GETC(ch)!='*') err(elist->cierr,112,"no star");
306	}
307	else ungetc(ch,cf);
308	if(GETC(ch)=='\'' \|\| ch=='"') quote=ch;
309	else if(isblnk(ch) \|\| issep(ch) \|\| ch==EOF)
310	{ ungetc(ch,cf);
311	return(0);
312	}
313	else err(elist->cierr,112,"no quote");
314	ltype=TYCHAR;
315	if(lchar!=NULL) free(lchar);
316	size=BUFSIZE;
317	p=lchar=(char *)malloc(size);
318	if(lchar==NULL) err(elist->cierr,113,"no space");
319	for(i=0;;)
320	{ while(GETC(ch)!=quote && ch!='\n'
321	&& ch!=EOF && ++i<size) *p++ = ch;
322	if(i==size)
323	{
324	newone:
325	lchar=(char *)realloc(lchar, size += BUFSIZE);
326	p=lchar+i-1;
327	*p++ = ch;
328	}
329	else if(ch==EOF) return(EOF);
330	else if(ch=='\n')
331	{ if(*(p-1) != '\\') continue;
332	i--;
333	p--;
334	if(++i<size) *p++ = ch;
335	else goto newone;
336	}
337	else if(GETC(ch)==quote)
338	{ if(++i<size) *p++ = ch;
339	else goto newone;
340	}
341	else
342	{ ungetc(ch,cf);
343	*p++ = 0;
344	return(0);
345	}
346	}
347	}
348	s_rsle(a) cilist *a;
349	{
350	int n;
351	if(!init) f_init();
352	if(n=c_le(a,READ)) return(n);
353	reading=1;
354	external=1;
355	formatted=1;
356	l_first=1;
357	lioproc = l_read;
358	lcount = 0;
359	if(curunit->uwrt)
360	return(nowreading(curunit));
361	else return(0);
362	}
363	t_sep()
364	{
365	int ch;
366	for(GETC(ch);isblnk(ch);GETC(ch));
367	if(ch == EOF)
368	if(feof(cf)) return(EOF);
369	else return(errno);
370	if(ch=='/')
371	{ lquit=1;
372	return(0);
373	}
374	if(ch==',') for(GETC(ch);isblnk(ch);GETC(ch));
375	ungetc(ch,cf);
376	return(0);
377	}
378	c_le(a,flag) cilist *a;
379	{
380	fmtbuf="list io";
381	if(a->ciunit>=MXUNIT \|\| a->ciunit<0)
382	err(a->cierr,101,"stler");
383	scale=recpos=0;
384	elist=a;
385	curunit = &units[a->ciunit];
386	if(curunit->ufd==NULL && fk_open(flag,SEQ,FMT,a->ciunit))
387	err(a->cierr,102,"lio");
388	cf=curunit->ufd;
389	if(!curunit->ufmt) err(a->cierr,103,"lio")
390	return(0);
391	}
392	do_lio(type,number,ptr,len) ftnint number,type; flex *ptr; ftnlen len;
393	{
394	return((lioproc)(number,ptr,len,type));
395	}