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