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

#include "fio.h"
#include "fmt.h"
#include "lio.h"
#include "ctype.h"
extern char *fmtbuf;
extern char *malloc(), *realloc();
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,SX,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
};

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