xref: /original-bsd/usr.bin/f77/libI77/rdfmt.c (revision f3455753)
1 /*-
2  * Copyright (c) 1980 The Regents of the University of California.
3  * All rights reserved.
4  *
5  * %sccs.include.proprietary.c%
6  */
7 
8 #ifndef lint
9 static char sccsid[] = "@(#)rdfmt.c	5.2 (Berkeley) 04/12/91";
10 #endif /* not lint */
11 
12 /*
13  * formatted read routines
14  */
15 
16 #include "fio.h"
17 #include "format.h"
18 
19 extern char *s_init;
20 extern int low_case[256];
21 extern int used_data;
22 
rd_ed(p,ptr,len)23 rd_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len;
24 {	int n;
25 	if(cursor && (n=rd_mvcur())) return(n);
26 	switch(p->op)
27 	{
28 	case I:
29 	case IM:
30 		n = (rd_I(ptr,p->p1,len));
31 		break;
32 	case L:
33 		n = (rd_L(ptr,p->p1,len));
34 		break;
35 	case A:
36 		n = (rd_AW(ptr,len,len));
37 		break;
38 	case AW:
39 		n = (rd_AW(ptr,p->p1,len));
40 		break;
41 	case E:
42 	case EE:
43 	case D:
44 	case DE:
45 	case G:
46 	case GE:
47 	case F:
48 		n = (rd_F(ptr,p->p1,p->p2,len));
49 		break;
50 	default:
51 		return(errno=F_ERFMT);
52 	}
53 	if (n < 0)
54 	{
55 		if(feof(cf)) return(EOF);
56 		n = errno;
57 		clearerr(cf);
58 	}
59 	return(n);
60 }
61 
rd_ned(p,ptr)62 rd_ned(p,ptr) char *ptr; struct syl *p;
63 {
64 	switch(p->op)
65 	{
66 #ifndef	KOSHER
67 	case APOS:					/* NOT STANDARD F77 */
68 		return(rd_POS(&s_init[p->p1]));
69 	case H:						/* NOT STANDARD F77 */
70 		return(rd_H(p->p1,&s_init[p->p2]));
71 #endif
72 	case SLASH:
73 		return((*donewrec)());
74 	case TR:
75 	case X:
76 		cursor += p->p1;
77 		/* tab = (p->op==TR); This voids '..,tl6,1x,..' sequences */
78 		tab = YES;
79 		return(OK);
80 	case T:
81 		if(p->p1) cursor = p->p1 - recpos - 1;
82 #ifndef KOSHER
83 		else cursor = 8*p->p2 - recpos%8;	/* NOT STANDARD FORT */
84 #endif
85 		tab = YES;
86 		return(OK);
87 	case TL:
88 		cursor -= p->p1;
89 		if ((recpos + cursor) < 0) cursor = -recpos;	/* ANSI req'd */
90 		tab = YES;
91 		return(OK);
92 	default:
93 		return(errno=F_ERFMT);
94 	}
95 }
96 
97 LOCAL
rd_mvcur()98 rd_mvcur()
99 {	int n;
100 	if(tab) return((*dotab)());
101 	if (cursor < 0) return(errno=F_ERSEEK);
102 	while(cursor--) if((n=(*getn)()) < 0) return(n);
103 	return(cursor=0);
104 }
105 
106 LOCAL
rd_I(n,w,len)107 rd_I(n,w,len) ftnlen len; uint *n;
108 {	long x=0;
109 	int i,sign=0,ch,c,sign_ok=YES;
110 	for(i=0;i<w;i++)
111 	{
112 		if((ch=(*getn)())<0) return(ch);
113 		switch(ch)
114 		{
115 		case ',': goto done;
116 		case '-': sign=1;		/* and fall thru */
117 		case '+': if(sign_ok == NO) return(errno=F_ERRICHR);
118 			  sign_ok = NO;
119 			  break;
120 		case ' ':
121 			if(cblank) x *= radix;
122 			break;
123 		case '\n':  if(cblank) {
124 				x *= radix;
125 				break;
126 			    } else {
127 				goto done;
128 			    }
129 		default:
130 			sign_ok = NO;
131 			if( (c = ch-'0')>=0 && c<radix )
132 			{	x = (x * radix) + c;
133 				break;
134 			}
135 			else if( (c = low_case[ch]-'a'+10)>=0 && c<radix )
136 			{	x = (x * radix) + c;
137 				break;
138 			}
139 			return(errno=F_ERRICHR);
140 		}
141 	}
142 done:
143 	if(sign) x = -x;
144 	if(len==sizeof(short)) n->is=x;
145 	else n->il=x;
146 	return(OK);
147 }
148 
149 LOCAL
rd_L(n,w,len)150 rd_L(n,w,len) uint *n; ftnlen len;
151 {	int ch,i,v = -1, period=0;
152 	for(i=0;i<w;i++)
153 	{	if((ch=(*getn)()) < 0) return(ch);
154 		if((ch=low_case[ch])=='t' && v==-1) v=1;
155 		else if(ch=='f' && v==-1) v=0;
156 		else if(ch=='.' && !period) period++;
157 		else if(ch==' ' || ch=='\t') ;
158 		else if(ch==',') break;
159 		else if(v==-1) return(errno=F_ERLOGIF);
160 	}
161 	if(v==-1) return(errno=F_ERLOGIF);
162 	if(len==sizeof(short)) n->is=v;
163 	else n->il=v;
164 	return(OK);
165 }
166 
167 LOCAL
rd_F(p,w,d,len)168 rd_F(p,w,d,len) ftnlen len; ufloat *p;
169 {	double x,y;
170 	int i,sx,sz,ch,dot,ny,z,sawz,mode, sign_ok=YES;
171 	x=y=0;
172 	sawz=z=ny=dot=sx=sz=0;
173 	/* modes:	0 in initial blanks,
174 			2 blanks plus sign
175 			3 found a digit
176 	 */
177 	mode = 0;
178 
179 	for(i=0;i<w;)
180 	{	i++;
181 		if((ch=(*getn)())<0) return(ch);
182 
183 		if(ch==' ') {	/* blank */
184 			if(cblank && (mode==2)) x *= 10;
185 		} else if(ch<='9' && ch>='0') { /* digit */
186 			mode = 2;
187 			x=10*x+ch-'0';
188 		} else if(ch=='.') {
189 			break;
190 		} else if(ch=='e' || ch=='d' || ch=='E' || ch=='D') {
191 			goto exponent;
192 		} else if(ch=='+' || ch=='-') {
193 			if(mode==0) {  /* sign before digits */
194 				if(ch=='-') sx=1;
195 				mode = 1;
196 			} else if(mode==1) {  /* two signs before digits */
197 				return(errno=F_ERRFCHR);
198 			} else { /* sign after digits, weird but standard!
199 				    	means exponent without 'e' or 'd' */
200 				    goto exponent;
201 			}
202 		} else if(ch==',') {
203 			goto done;
204 		} else if(ch=='\n') {
205 			if(cblank && (mode==2)) x *= 10;
206 		} else {
207 			return(errno=F_ERRFCHR);
208 		}
209 	}
210 	/* get here if out of characters to scan or found a period */
211 	if(ch=='.') dot=1;
212 	while(i<w)
213 	{	i++;
214 		if((ch=(*getn)())<0) return(ch);
215 
216 		if(ch<='9' && ch>='0') {
217 			y=10*y+ch-'0';
218 			ny++;
219 		} else if(ch==' ' || ch=='\n') {
220 			if(cblank) {
221 				y*= 10;
222 				ny++;
223 			}
224 		} else if(ch==',') {
225 			goto done;
226 		} else if(ch=='d' || ch=='e' || ch=='+' || ch=='-' || ch=='D' || ch=='E') {
227 			break;
228 		} else {
229 			return(errno=F_ERRFCHR);
230 		}
231 	}
232 	/*	now for the exponent.
233 	 *	mode=3 means seen digit or sign of exponent.
234 	 *	either out of characters to scan or
235 	 *		ch is '+', '-', 'd', or 'e'.
236 	 */
237 exponent:
238 	if(ch=='-' || ch=='+') {
239 		if(ch=='-') sz=1;
240 		mode = 3;
241 	} else {
242 		mode = 2;
243 	}
244 
245 	while(i<w)
246 	{	i++;
247 		sawz=1;
248 		if((ch=(*getn)())<0) return(ch);
249 
250 		if(ch<='9' && ch>='0') {
251 			mode = 3;
252 			z=10*z+ch-'0';
253 		} else if(ch=='+' || ch=='-') {
254 			if(mode==3 ) return(errno=F_ERRFCHR);
255 			mode = 3;
256 			if(ch=='-') sz=1;
257 		} else if(ch == ' ' || ch=='\n') {
258 			if(cblank) z *=10;
259 		} else if(ch==',') {
260 			break;
261 		} else {
262 			return(errno=F_ERRFCHR);
263 		}
264 	}
265 done:
266 	if(!dot)
267 		for(i=0;i<d;i++) x /= 10;
268 	for(i=0;i<ny;i++) y /= 10;
269 	x=x+y;
270 	if(sz)
271 		for(i=0;i<z;i++) x /=10;
272 	else	for(i=0;i<z;i++) x *= 10;
273 	if(sx) x = -x;
274 	if(!sawz)
275 	{
276 		for(i=scale;i>0;i--) x /= 10;
277 		for(i=scale;i<0;i++) x *= 10;
278 	}
279 	if(len==sizeof(float)) p->pf=x;
280 	else p->pd=x;
281 	return(OK);
282 }
283 
284 LOCAL
rd_AW(p,w,len)285 rd_AW(p,w,len) char *p; ftnlen len;
286 {	int i,ch;
287 	if(w >= len)
288 	{
289 		for(i=0;i<w-len;i++) GET(ch);
290 		for(i=0;i<len;i++)
291 		{	GET(ch);
292 			*p++=VAL(ch);
293 		}
294 	}
295 	else
296 	{
297 		for(i=0;i<w;i++)
298 		{	GET(ch);
299 			*p++=VAL(ch);
300 		}
301 		for(i=0;i<len-w;i++) *p++=' ';
302 	}
303 	return(OK);
304 }
305 
306 /* THIS IS NOT ALLOWED IN THE NEW STANDARD 'CAUSE IT'S WEIRD */
307 LOCAL
rd_H(n,s)308 rd_H(n,s) char *s;
309 {	int i,ch = 0;
310 
311 	used_data = YES;
312 	for(i=0;i<n;i++)
313 	{	if (ch != '\n')
314 			GET(ch);
315 		if (ch == '\n')
316 			*s++ = ' ';
317 		else
318 			*s++ = ch;
319 	}
320 	return(OK);
321 }
322 
323 LOCAL
rd_POS(s)324 rd_POS(s) char *s;
325 {	char quote;
326 	int ch = 0;
327 
328 	used_data = YES;
329 	quote = *s++;
330 	while(*s)
331 	{	if(*s==quote && *(s+1)!=quote)
332 			break;
333 		if (ch != '\n')
334 			GET(ch);
335 		if (ch == '\n')
336 			*s++ = ' ';
337 		else
338 			*s++ = ch;
339 	}
340 	return(OK);
341 }
342