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