```   1: /*
2:  * Copyright (c) 1980 Regents of the University of California.
4:  * specifies the terms and conditions for redistribution.
5:  *
7:  */
8:
9: /*
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;
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;
53:     formatted = LISTDIRECTED;
54:     fmtbuf = "ext list io";
56:     l_first = YES;
57:     lquit = NO;
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: }
```

#### Defined functions

e_rsle defined in line 81; never used
get_repet defined in line 194; used 3 times
l_C defined in line 295; used 1 times
l_CHAR defined in line 348; used 1 times
l_L defined in line 314; used 1 times
l_R defined in line 213; used 3 times
l_read defined in line 89; used 2 times
lr_comm defined in line 175; used 4 times
nullfld defined in line 422; used 4 times
rd_int defined in line 278; used 7 times
s_rsle defined in line 49; never used
t_getc defined in line 68; used 2 times
t_sep defined in line 405; used 2 times

#### Defined variables

lchar defined in line 32; used 9 times
lrd defined in line 31; used 7 times
ltab defined in line 37; used 6 times
ltype defined in line 34; used 7 times
lx defined in line 33; used 13 times
ly defined in line 33; used 3 times

#### Defined macros

AP defined in line 18; used 4 times
B defined in line 17; used 4 times
BUFSIZE defined in line 347; used 3 times
D defined in line 20; used 11 times
• in line 26, 42(10)
EIN defined in line 21; used 4 times
EX defined in line 19; used 5 times
GETC defined in line 29; used 26 times
SP defined in line 16; used 5 times
endlinp defined in line 27; used 4 times
isapos defined in line 24; used 1 times
isblnk defined in line 22; used 6 times
isdigit defined in line 26; used 3 times
isexp defined in line 25; used 1 times
issep defined in line 23; used 7 times
 Last modified: 1987-02-18 Generated: 2016-12-26 Generated by src2html V0.67 page hit count: 2443