|
|
1.1 root 1: /*
2: * formatted read routines
3: */
4:
5: #include "fio.h"
6: #include "fmt.h"
7:
8: #define isdigit(c) (c>='0' && c<='9')
9: #define isalpha(c) (c>='a' && c<='z')
10:
11: rd_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len;
12: { int n;
13: if(cursor && (n=rd_mvcur())) return(n);
14: switch(p->op)
15: {
16: case I:
17: case IM:
18: n = (rd_I(ptr,p->p1,len));
19: break;
20: case L:
21: n = (rd_L(ptr,p->p1));
22: break;
23: case A:
24: p->p1 = len; /* cheap trick */
25: case AW:
26: n = (rd_AW(ptr,p->p1,len));
27: break;
28: case E:
29: case EE:
30: case D:
31: case DE:
32: case G:
33: case GE:
34: case F:
35: n = (rd_F(ptr,p->p1,p->p2,len));
36: break;
37: default:
38: return(errno=100);
39: }
40: if (n < 0)
41: {
42: if(feof(cf)) return(EOF);
43: n = errno;
44: clearerr(cf);
45: }
46: return(n);
47: }
48:
49: rd_ned(p,ptr) char *ptr; struct syl *p;
50: {
51: switch(p->op)
52: {
53: /* case APOS:
54: /* return(rd_POS(p->p1));
55: /* case H:
56: /* return(rd_H(p->p1,p->p2)); */
57: case SLASH:
58: return((*donewrec)());
59: case TR:
60: case X:
61: cursor += p->p1;
62: tab = (p->op==TR);
63: return(OK);
64: case T:
65: if(p->p1) cursor = p->p1 - recpos - 1;
66: #ifndef KOSHER
67: else cursor = 8*p->p2 - recpos%8; /* NOT STANDARD FORT */
68: #endif
69: tab = YES;
70: return(OK);
71: case TL:
72: cursor -= p->p1;
73: tab = YES;
74: return(OK);
75: default:
76: return(errno=100);
77: }
78: }
79:
80: rd_mvcur()
81: { int n;
82: if(tab) return((*dotab)());
83: while(cursor--) if((n=(*getn)()) < 0) return(n);
84: return(cursor=0);
85: }
86:
87: rd_I(n,w,len) ftnlen len; uint *n;
88: { long x=0;
89: int i,sign=0,ch,c;
90: for(i=0;i<w;i++)
91: {
92: if((ch=(*getn)())<0) return(ch);
93: switch(ch=lcase(ch))
94: {
95: case ',': goto done;
96: case '+': break;
97: case '-':
98: sign=1;
99: break;
100: case ' ':
101: if(cblank) x *= radix;
102: break;
103: case '\n': goto done;
104: default:
105: if(isdigit(ch))
106: { if ((c=(ch-'0')) < radix)
107: { x = (x * radix) + c;
108: break;
109: }
110: }
111: else if(isalpha(ch))
112: { if ((c=(ch-'a'+10)) < radix)
113: { x = (x * radix) + c;
114: break;
115: }
116: }
117: return(errno=115);
118: }
119: }
120: done:
121: if(sign) x = -x;
122: if(len==sizeof(short)) n->is=x;
123: else n->il=x;
124: return(OK);
125: }
126:
127: rd_L(n,w) ftnint *n;
128: { int ch,i,v = -1;
129: for(i=0;i<w;i++)
130: { if((ch=(*getn)()) < 0) return(ch);
131: if((ch=lcase(ch))=='t' && v==-1) v=1;
132: else if(ch=='f' && v==-1) v=0;
133: else if(ch==',') break;
134: }
135: if(v==-1) return(errno=116);
136: *n=v;
137: return(OK);
138: }
139:
140: rd_F(p,w,d,len) ftnlen len; ufloat *p;
141: { double x,y;
142: int i,sx,sz,ch,dot,ny,z,sawz;
143: x=y=0;
144: sawz=z=ny=dot=sx=sz=0;
145: for(i=0;i<w;)
146: { i++;
147: if((ch=(*getn)())<0) return(ch);
148: ch=lcase(ch);
149: if(ch==' ' && !cblank || ch=='+') continue;
150: else if(ch=='-') sx=1;
151: else if(ch<='9' && ch>='0')
152: x=10*x+ch-'0';
153: else if(ch=='e' || ch=='d' || ch=='.')
154: break;
155: else if(cblank && ch==' ') x*=10;
156: else if(ch==',')
157: { i=w;
158: break;
159: }
160: else if(ch!='\n') return(errno=115);
161: }
162: if(ch=='.') dot=1;
163: while(i<w && ch!='e' && ch!='d' && ch!='+' && ch!='-')
164: { i++;
165: if((ch=(*getn)())<0) return(ch);
166: ch = lcase(ch);
167: if(ch<='9' && ch>='0')
168: y=10*y+ch-'0';
169: else if(cblank && ch==' ')
170: y *= 10;
171: else if(ch==',') {i=w; break;}
172: else if(ch==' ') continue;
173: else continue;
174: ny++;
175: }
176: if(ch=='-') sz=1;
177: while(i<w)
178: { i++;
179: sawz=1;
180: if((ch=(*getn)())<0) return(ch);
181: ch = lcase(ch);
182: if(ch=='-') sz=1;
183: else if(ch<='9' && ch>='0')
184: z=10*z+ch-'0';
185: else if(cblank && ch==' ')
186: z *= 10;
187: else if(ch==',') break;
188: else if(ch==' ') continue;
189: else if(ch=='+') continue;
190: else if(ch!='\n') return(errno=115);
191: }
192: if(!dot)
193: for(i=0;i<d;i++) x /= 10;
194: for(i=0;i<ny;i++) y /= 10;
195: x=x+y;
196: if(sz)
197: for(i=0;i<z;i++) x /=10;
198: else for(i=0;i<z;i++) x *= 10;
199: if(sx) x = -x;
200: if(!sawz)
201: {
202: for(i=scale;i>0;i--) x /= 10;
203: for(i=scale;i<0;i++) x *= 10;
204: }
205: if(len==sizeof(float)) p->pf=x;
206: else p->pd=x;
207: return(OK);
208: }
209:
210: rd_AW(p,w,len) char *p; ftnlen len;
211: { int i,ch;
212: if(w >= len)
213: {
214: for(i=0;i<w-len;i++) GET(ch);
215: for(i=0;i<len;i++)
216: { GET(ch);
217: *p++=VAL(ch);
218: }
219: }
220: else
221: {
222: for(i=0;i<w;i++)
223: { GET(ch);
224: *p++=VAL(ch);
225: }
226: for(i=0;i<len-w;i++) *p++=' ';
227: }
228: return(OK);
229: }
230:
231: /* THIS IS NOT ALLOWED IN THE NEW STANDARD 'CAUSE IT'S WEIRD */
232: /*rd_H(n,s) char *s;
233: /*{ int i,ch;
234: /* for(i=0;i<n;i++)
235: /* if((ch=(*getn)())<0) return(ch);
236: /* else if(ch=='\n') for(;i<n;i++) *s++ = ' ';
237: /* else *s++ = ch;
238: /* return(OK);
239: /*}
240: */
241: /*rd_POS(s) char *s;
242: /*{ char quote;
243: /* int ch;
244: /* quote= *s++;
245: /* for(;*s;s++)
246: /* if(*s==quote && *(s+1)!=quote) break;
247: /* else if((ch=(*getn)())<0) return(ch);
248: /* else *s = ch=='\n'?' ':ch;
249: /* return(OK);
250: /*}
251: */
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.