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

#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,0,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,AX,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,
	0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
	AX,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(lquit) return(0);
		if(curunit->uend) err(elist->ciend, EOF, "list in")
		if(l_first)
		{	l_first=0;
			lcount = count_sep();
			if(lquit) return(0);
		}
		else if(lcount==0) {
			lcount = count_sep();
			if(lcount > 0) lcount--;
			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 = (flex *)((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;
	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;
	GETC(ch);
	if(ch!='(')
	{	if(fscanf(cf,"%d",&lcount)!=1)
			if(!feof(cf)) err(elist->cierr,112,"complex format")
			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)) || (ch == '\n'));
	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)));
	if(ch != '\n') ungetc(ch,cf);
	return(0);
}
l_L()
{
	int ch;
	if(lcount>0) return(0);
	ltype=NULL;
	GETC(ch);
	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 || ch == '\n')
		{	ungetc(ch,cf);
			return(0);
		}
		else	err(elist->cierr,112,"logical");
	}
	ltype=TYLONG;
	lcount = 1;
	while(!issep(GETC(ch)) && ch!='\n' && ch!=EOF);
	ungetc(ch, cf);
	return(0);
}
#define BUFSIZE	128
l_CHAR()
{	int ch,size,i;
	char quote,*p;
	if(lcount>0) return(0);
	ltype=NULL;

	GETC(ch);
	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;
	lquit = 0;
	lcount = 0;
	if(curunit->uwrt)
		return(nowreading(curunit));
	else	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));
}

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