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