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