![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lread.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Power 6/32 Unix Tahoe 4.2BSD] / cci / usr / src / usr.lib / libsI77|
Return to lread.c CVS log | Up to [Power 6/32 Unix Tahoe 4.2BSD] / cci / usr / src / usr.lib / libsI77 |
1.1 root 1: /*
2: char id_lread[] = "@(#)lread.c 1.2";
3: *
4: * list directed read
5: */
6:
7: #include "fio.h"
8: #include "lio.h"
9:
10: #define SP 1
11: #define B 2
12: #define AP 4
13: #define EX 8
14: #define D 16
15: #define EIN 32
16: #define isblnk(x) (ltab[x+1]&B)
17: #define issep(x) (ltab[x+1]&SP)
18: #define isapos(x) (ltab[x+1]&AP)
19: #define isexp(x) (ltab[x+1]&EX)
20: #define isdigit(x) (ltab[x+1]&D)
21: #define endlinp(x) (ltab[x+1]&EIN)
22:
23: #define GETC(x) (x=(*getn)())
24:
25: char *lrd = "list read";
26: char *lchar;
27: double lx,ly;
28: int ltype;
29: int l_read(),t_getc(),ungetc();
30:
31: char ltab[128+1] =
32: { EIN, /* offset one for EOF */
33: /* 0- 15 */ 0,0,AP,0,0,0,0,0,0,B,SP|B|EIN,0,0,0,0,0, /* ^B,TAB,NEWLINE */
34: /* 16- 31 */ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
35: /* 32- 47 */ SP|B,0,AP,0,0,0,0,AP,0,0,0,0,SP,0,0,EIN, /* space,",',comma,/ */
36: /* 48- 63 */ D,D,D,D,D,D,D,D,D,D,0,0,0,0,0,0, /* digits 0-9 */
37: /* 64- 79 */ 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, /* D,E */
38: /* 80- 95 */ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
39: /* 96-111 */ 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, /* d,e */
40: /* 112-127 */ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
41: };
42:
43: s_rsle(a) cilist *a; /* start read sequential list external */
44: {
45: int n;
46: reading = YES;
47: if(n=c_le(a,READ)) return(n);
48: l_first = YES;
49: lquit = NO;
50: lioproc = l_read;
51: getn = t_getc;
52: ungetn = ungetc;
53: leof = curunit->uend;
54: lcount = 0;
55: if(curunit->uwrt) nowreading(curunit);
56: return(OK);
57: }
58:
59: t_getc()
60: { int ch;
61: if(curunit->uend) return(EOF);
62: if((ch=getc(cf))!=EOF) return(ch);
63: if(feof(cf))
64: { curunit->uend = YES;
65: leof = EOF;
66: }
67: else clearerr(cf);
68: return(EOF);
69: }
70:
71: e_rsle()
72: {
73: int ch;
74: if(curunit->uend) return(OK);
75: while(!endlinp(GETC(ch)));
76: return(OK);
77: }
78:
79: l_read(number,ptr,len,type) ftnint *number,type; flex *ptr; ftnlen len;
80: { int i,n,ch;
81: double *yy;
82: float *xx;
83: for(i=0;i<*number;i++)
84: {
85: if(leof) err(endflag, EOF, lrd)
86: if(l_first)
87: { l_first = NO;
88: while(isblnk(GETC(ch))); /* skip blanks */
89: (*ungetn)(ch,cf);
90: }
91: else if(lcount==0) /* repeat count == 0 ? */
92: { ERR(t_sep()); /* look for non-blank, allow 1 comma */
93: if(lquit) return(OK); /* slash found */
94: }
95: switch((int)type)
96: {
97: case TYSHORT:
98: case TYLONG:
99: case TYREAL:
100: case TYDREAL:
101: ERR(l_R(1));
102: break;
103: case TYCOMPLEX:
104: case TYDCOMPLEX:
105: ERR(l_C());
106: break;
107: case TYLOGICAL:
108: ERR(l_L());
109: break;
110: case TYCHAR:
111: ERR(l_CHAR());
112: break;
113: }
114: if(lquit) return(OK);
115: if(leof) err(endflag,EOF,lrd)
116: else if(external && ferror(cf)) err(errflag,errno,lrd)
117: if(ltype) switch((int)type)
118: {
119: case TYSHORT:
120: ptr->flshort=lx;
121: break;
122: case TYLOGICAL:
123: case TYLONG:
124: ptr->flint=lx;
125: break;
126: case TYREAL:
127: ptr->flreal=lx;
128: break;
129: case TYDREAL:
130: ptr->fldouble=lx;
131: break;
132: case TYCOMPLEX:
133: xx=(float *)ptr;
134: *xx++ = ly;
135: *xx = lx;
136: break;
137: case TYDCOMPLEX:
138: yy=(double *)ptr;
139: *yy++ = ly;
140: *yy = lx;
141: break;
142: case TYCHAR:
143: b_char(lchar,(char *)ptr,len);
144: break;
145: }
146: if(lcount>0) lcount--;
147: ptr = (char *)ptr + len;
148: }
149: return(OK);
150: }
151:
152: lr_comm()
153: { int ch;
154: if(lcount) return(lcount);
155: ltype=NULL;
156: while(isblnk(GETC(ch)));
157: if(ch==',')
158: { lcount=1;
159: return(lcount);
160: }
161: (*ungetn)(ch,cf);
162: if(ch=='/')
163: { lquit = YES;
164: return(lquit);
165: }
166: else
167: return(OK);
168: }
169:
170: get_repet()
171: { char ch;
172: double lc;
173: if(isdigit(GETC(ch)))
174: { (*ungetn)(ch,cf);
175: rd_int(&lc);
176: lcount = (int)lc;
177: if(GETC(ch)!='*')
178: if(leof) return(EOF);
179: else return(F_ERREPT);
180: }
181: else
182: { lcount = 1;
183: (*ungetn)(ch,cf);
184: }
185: return(OK);
186: }
187:
188: l_R(flg) int flg;
189: { double a,b,c,d;
190: int da,db,dc,dd;
191: int i,ch,sign=0;
192: a=b=c=d=0;
193: da=db=dc=dd=0;
194: if(flg && lr_comm()) return(OK);
195: da=rd_int(&a); /* repeat count ? */
196: if(GETC(ch)=='*')
197: {
198: if (a <= 0.) return(F_ERNREP);
199: lcount=(int)a;
200: db=rd_int(&b); /* whole part of number */
201: }
202: else
203: { (*ungetn)(ch,cf);
204: db=da;
205: b=a;
206: lcount=1;
207: }
208: if(GETC(ch)=='.' && isdigit(GETC(ch)))
209: { (*ungetn)(ch,cf);
210: dc=rd_int(&c); /* fractional part of number */
211: }
212: else
213: { (*ungetn)(ch,cf);
214: dc=0;
215: c=0.;
216: }
217: if(isexp(GETC(ch)))
218: dd=rd_int(&d); /* exponent */
219: else if (ch == '+' || ch == '-')
220: { (*ungetn)(ch,cf);
221: dd=rd_int(&d);
222: }
223: else
224: { (*ungetn)(ch,cf);
225: dd=0;
226: }
227: if(db<0 || b<0)
228: { sign=1;
229: b = -b;
230: }
231: for(i=0;i<dc;i++) c/=10.;
232: b=b+c;
233: if (dd > 0)
234: { for(i=0;i<d;i++) b *= 10.;
235: for(i=0;i< -d;i++) b /= 10.;
236: }
237: lx=sign?-b:b;
238: ltype=TYLONG;
239: return(OK);
240: }
241:
242: rd_int(x) double *x;
243: { int ch,sign=0,i=0;
244: double y=0.0;
245: if(GETC(ch)=='-') sign = -1;
246: else if(ch=='+') sign=0;
247: else (*ungetn)(ch,cf);
248: while(isdigit(GETC(ch)))
249: { i++;
250: y=10*y + ch-'0';
251: }
252: (*ungetn)(ch,cf);
253: if(sign) y = -y;
254: *x = y;
255: return(y==0.0?sign:i); /* 0:[+]&&y==0, -1:-&&y==0, >0:#digits&&y!=0 */
256: }
257:
258: l_C()
259: { int ch,n;
260: if(lr_comm()) return(OK);
261: if(n=get_repet()) return(n); /* get repeat count */
262: if(GETC(ch)!='(') err(errflag,F_ERLIO,"no (")
263: while(isblnk(GETC(ch)));
264: (*ungetn)(ch,cf);
265: l_R(0); /* get real part */
266: ly = lx;
267: if(t_sep()) return(EOF);
268: l_R(0); /* get imag part */
269: while(isblnk(GETC(ch)));
270: if(ch!=')') err(errflag,F_ERLIO,"no )")
271: ltype = TYCOMPLEX;
272: return(OK);
273: }
274:
275: l_L()
276: {
277: int ch,n;
278: if(lr_comm()) return(OK);
279: if(n=get_repet()) return(n); /* get repeat count */
280: if(GETC(ch)=='.') GETC(ch);
281: switch(ch)
282: {
283: case 't':
284: case 'T':
285: lx=1;
286: break;
287: case 'f':
288: case 'F':
289: lx=0;
290: break;
291: default:
292: if(isblnk(ch) || issep(ch))
293: { (*ungetn)(ch,cf);
294: lx=0;
295: return(OK);
296: }
297: else if(ch==EOF) return(EOF);
298: else err(errflag,F_ERLIO,"logical not T or F");
299: }
300: ltype=TYLOGICAL;
301: while(!issep(GETC(ch)) && !isblnk(ch) && ch!='\n' && ch!=EOF);
302: return(OK);
303: }
304:
305: #define BUFSIZE 128
306: l_CHAR()
307: { int ch,size,i,n;
308: char quote,*p;
309: if(lr_comm()) return(OK);
310: if(n=get_repet()) return(n); /* get repeat count */
311: if(isapos(GETC(ch))) quote=ch;
312: else if(isblnk(ch) || issep(ch) || ch==EOF || ch=='\n')
313: { if(ch==EOF) return(EOF);
314: (*ungetn)(ch,cf);
315: return(OK);
316: }
317: else
318: { quote = '\0'; /* to allow single word non-quoted */
319: (*ungetn)(ch,cf);
320: }
321: ltype=TYCHAR;
322: if(lchar!=NULL) free(lchar);
323: size=BUFSIZE-1;
324: p=lchar=(char *)malloc(BUFSIZE);
325: if(lchar==NULL) err(errflag,F_ERSPACE,lrd)
326: for(i=0;;)
327: { while( ( (quote && GETC(ch)!=quote) ||
328: (!quote && !issep(GETC(ch)) && !isblnk(ch) ) )
329: && ch!='\n' && ch!=EOF && ++i<size )
330: *p++ = ch;
331: if(i==size)
332: {
333: newone:
334: size += BUFSIZE;
335: lchar=(char *)realloc(lchar, size+1);
336: if(lchar==NULL) err(errflag,F_ERSPACE,lrd)
337: p=lchar+i-1;
338: *p++ = ch;
339: }
340: else if(ch==EOF) return(EOF);
341: else if(ch=='\n')
342: { if(*(p-1) == '\\') *(p-1) = ch;
343: else if(!quote)
344: { *p = '\0';
345: (*ungetn)(ch,cf);
346: return(OK);
347: }
348: }
349: else if(quote && GETC(ch)==quote)
350: { if(++i<size) *p++ = ch;
351: else goto newone;
352: }
353: else
354: { (*ungetn)(ch,cf);
355: *p = '\0';
356: return(OK);
357: }
358: }
359: }
360:
361: t_sep()
362: {
363: int ch;
364: while(isblnk(GETC(ch)));
365: if(leof) return(EOF);
366: if(ch=='/')
367: { lquit = YES;
368: (*ungetn)(ch,cf);
369: return(OK);
370: }
371: if(issep(ch)) while(isblnk(GETC(ch)));
372: if(leof) return(EOF);
373: (*ungetn)(ch,cf);
374: return(OK);
375: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.