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[] = "@(#)rsnmle.c 5.5 (Berkeley) 04/12/91";
10 #endif /* not lint */
11
12 /*
13 * name-list read
14 */
15
16 #include "fio.h"
17 #include "lio.h"
18 #include "nmlio.h"
19 #include <ctype.h>
20
21 LOCAL char *nml_rd;
22
23 static int ch;
24 LOCAL nameflag;
25 LOCAL char var_name[VL+1];
26
27 #define SP 1
28 #define B 2
29 #define AP 4
30 #define EX 8
31 #define INTG 16
32 #define RL 32
33 #define LGC 64
34 #define IRL (INTG | RL | LGC )
35 #define isblnk(x) (ltab[x+1]&B) /* space, tab, newline */
36 #define issep(x) (ltab[x+1]&SP) /* space, tab, newline, comma */
37 #define isapos(x) (ltab[x+1]&AP) /* apost., quote mark */
38 #define isexp(x) (ltab[x+1]&EX) /* d, e, D, E */
39 #define isint(x) (ltab[x+1]&INTG) /* 0-9, plus, minus */
40 #define isrl(x) (ltab[x+1]&RL) /* 0-9, plus, minus, period */
41 #define islgc(x) (ltab[x+1]&LGC) /* 0-9, period, t, f, T, F */
42
43 #define GETC (ch=t_getc())
44 #define UNGETC() ungetc(ch,cf)
45
46 LOCAL char *lchar;
47 LOCAL double lx,ly;
48 LOCAL int ltype;
49 int t_getc(), ungetc();
50
51 LOCAL char ltab[128+1] =
52 { 0, /* offset one for EOF */
53 /* 0- 15 */ 0,0,0,0,0,0,0,0,0,SP|B,SP|B,0,0,0,0,0, /* TAB,NEWLINE */
54 /* 16- 31 */ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
55 /* 32- 47 */ SP|B,0,AP,0,0,0,0,AP,0,0,0,RL|INTG,SP,RL|INTG,RL|LGC,0, /* space,",',comma,., */
56 /* 48- 63 */ IRL,IRL,IRL,IRL,IRL,IRL,IRL,IRL,IRL,IRL,0,0,0,0,0,0, /* digits */
57 /* 64- 79 */ 0,0,0,0,EX,EX,LGC,0,0,0,0,0,0,0,0,0, /* D,E,F */
58 /* 80- 95 */ 0,0,0,0,LGC,0,0,0,0,0,0,0,0,0,0,0, /* T */
59 /* 96-111 */ 0,0,0,0,EX,EX,LGC,0,0,0,0,0,0,0,0,0, /* d,e,f */
60 /* 112-127 */ 0,0,0,0,LGC,0,0,0,0,0,0,0,0,0,0,0 /* t */
61 };
62
s_rsne(a)63 s_rsne(a) namelist_arglist *a;
64 {
65 int n;
66 struct namelistentry *entry;
67 int nelem, vlen, vtype;
68 char *nmlist_nm, *addr;
69
70 nml_rd = "namelist read";
71 reading = YES;
72 formatted = NAMELIST;
73 fmtbuf = "ext namelist io";
74 if(n=c_le(a,READ)) return(n);
75 getn = t_getc;
76 ungetn = ungetc;
77 leof = curunit->uend;
78 if(curunit->uwrt && ! nowreading(curunit)) err(errflag, errno, nml_rd)
79
80 /* look for " &namelistname " */
81 nmlist_nm = a->namelist->namelistname;
82 while(isblnk(GETC)) ;
83 /* check for "&end" (like IBM) or "$end" (like DEC) */
84 if(ch != '&' && ch != '$') goto rderr;
85 /* save it - write out using the same character as used on input */
86 namelistkey_ = ch;
87 while( *nmlist_nm )
88 if( GETC != *nmlist_nm++ )
89 {
90 nml_rd = "incorrect namelist name";
91 goto rderr;
92 }
93 if(!isblnk(GETC)) goto rderr;
94 while(isblnk(GETC)) ;
95 if(leof) goto rderr;
96 UNGETC();
97
98 while( GETC != namelistkey_ )
99 {
100 UNGETC();
101 /* get variable name */
102 if(!nameflag && rd_name(var_name)) goto rderr;
103
104 entry = a->namelist->names;
105 /* loop through namelist entries looking for this variable name */
106 while( entry->varname[0] != 0 )
107 {
108 if( strcmp(entry->varname, var_name) == 0 ) goto got_name;
109 entry++;
110 }
111 nml_rd = "incorrect variable name";
112 goto rderr;
113 got_name:
114 if( n = get_pars( entry, &addr, &nelem, &vlen, &vtype ))
115 goto rderr_n;
116 while(isblnk(GETC)) ;
117 if(ch != '=') goto rderr;
118
119 nameflag = NO;
120 if(n = l_read( nelem, addr, vlen, vtype )) goto rderr_n;
121 while(isblnk(GETC));
122 if(ch == ',') while(isblnk(GETC));
123 UNGETC();
124 if(leof) goto rderr;
125 }
126 /* check for 'end' after '&' or '$'*/
127 if(GETC!='e' || GETC!='n' || GETC!='d' )
128 goto rderr;
129 /* flush to next input record */
130 flush:
131 while(GETC != '\n' && ch != EOF);
132 return(ch == EOF ? EOF : OK);
133
134 rderr:
135 if(leof)
136 n = EOF;
137 else
138 n = F_ERNMLIST;
139 rderr_n:
140 if(n == EOF ) err(endflag,EOF,nml_rd);
141 /* flush after error in case restart I/O */
142 if(ch != '\n') while(GETC != '\n' && ch != EOF) ;
143 err(errflag,n,nml_rd)
144 }
145
146 #define MAXSUBS 7
147
148 LOCAL
get_pars(entry,addr,nelem,vlen,vtype)149 get_pars( entry, addr, nelem, vlen, vtype )
150 struct namelistentry *entry;
151 char **addr; /* beginning address to read into */
152 int *nelem, /* number of elements to read */
153 *vlen, /* length of elements */
154 *vtype; /* type of elements */
155 {
156 int offset, i, n,
157 *dimptr, /* points to dimensioning info */
158 ndim, /* number of dimensions */
159 baseoffset, /* offset of corner element */
160 *span, /* subscript span for each dimension */
161 subs[MAXSUBS], /* actual subscripts */
162 subcnt = -1; /* number of actual subscripts */
163
164
165 /* get element size and base address */
166 *vlen = entry->typelen;
167 *addr = entry->varaddr;
168
169 /* get type */
170 switch ( *vtype = entry->type ) {
171 case TYSHORT:
172 case TYLONG:
173 case TYREAL:
174 case TYDREAL:
175 case TYCOMPLEX:
176 case TYDCOMPLEX:
177 case TYLOGICAL:
178 case TYCHAR:
179 break;
180 default:
181 fatal(F_ERSYS,"unknown type in rsnmle");
182 }
183
184 /* get number of elements */
185 dimptr = entry->dimp;
186 if( dimptr==NULL )
187 { /* scalar */
188 *nelem = 1;
189 return(OK);
190 }
191
192 if( GETC != '(' )
193 { /* entire array */
194 *nelem = dimptr[1];
195 UNGETC();
196 return(OK);
197 }
198
199 /* get element length, number of dimensions, base, span vector */
200 ndim = dimptr[0];
201 if(ndim<=0 || ndim>MAXSUBS) fatal(F_ERSYS,"illegal dimensions");
202 baseoffset = dimptr[2];
203 span = dimptr+3;
204
205 /* get subscripts from input data */
206 while(ch!=')') {
207 if( ++subcnt > MAXSUBS-1 ) return F_ERNMLIST;
208 if(n=get_int(&subs[subcnt])) return n;
209 GETC;
210 if(leof) return EOF;
211 if(ch != ',' && ch != ')') return F_ERNMLIST;
212 }
213 if( ++subcnt != ndim ) return F_ERNMLIST;
214
215 offset = subs[ndim-1];
216 for( i = ndim-2; i>=0; i-- )
217 offset = subs[i] + span[i]*offset;
218 offset -= baseoffset;
219 *nelem = dimptr[1] - offset;
220 if( offset < 0 || offset >= dimptr[1] )
221 return F_ERNMLIST;
222 *addr = *addr + (*vlen)*offset;
223 return OK;
224 }
225
226 LOCAL
get_int(subval)227 get_int(subval)
228 int *subval;
229 {
230 int sign=0, value=0, cnt=0;
231
232 /* look for sign */
233 if(GETC == '-') sign = -1;
234 else if(ch == '+') ;
235 else UNGETC();
236 if(ch == EOF) return(EOF);
237
238 while(isdigit(GETC))
239 {
240 value = 10*value + ch-'0';
241 cnt++;
242 }
243 UNGETC();
244 if(ch == EOF) return EOF;
245 if(cnt == 0 ) return F_ERNMLIST;
246 if(sign== -1) value = -value;
247 *subval = value;
248 return OK;
249 }
250
251 LOCAL
rd_name(ptr)252 rd_name(ptr)
253 char *ptr;
254 {
255 /* read a variable name from the input stream */
256 char *init = ptr-1;
257
258 if(!isalpha(GETC)) {
259 UNGETC();
260 return(ERROR);
261 }
262 *ptr++ = ch;
263 while(isalnum(GETC))
264 {
265 if(ptr-init > VL ) return(ERROR);
266 *ptr++ = ch;
267 }
268 *ptr = '\0';
269 UNGETC();
270 return(OK);
271 }
272
273 LOCAL
t_getc()274 t_getc()
275 { int ch;
276 static newline = YES;
277 rd:
278 if(curunit->uend) {
279 leof = EOF;
280 return(EOF);
281 }
282 if((ch=getc(cf))!=EOF)
283 {
284 if(ch == '\n') newline = YES;
285 else if(newline==YES)
286 { /* skip first character on each line for namelist */
287 newline = NO;
288 goto rd;
289 }
290 return(ch);
291 }
292 if(feof(cf))
293 { curunit->uend = YES;
294 leof = EOF;
295 }
296 else clearerr(cf);
297 return(EOF);
298 }
299
300 LOCAL
l_read(number,ptr,len,type)301 l_read(number,ptr,len,type) ftnint number,type; flex *ptr; ftnlen len;
302 { int i,n;
303 double *yy;
304 float *xx;
305
306 lcount = 0;
307 for(i=0;i<number;i++)
308 {
309 if(leof) return EOF;
310 if(lcount==0)
311 {
312 ltype = NULL;
313 if(i!=0)
314 { /* skip to comma */
315 while(isblnk(GETC));
316 if(leof) return(EOF);
317 if(ch == namelistkey_)
318 { UNGETC();
319 return(OK);
320 }
321 if(ch != ',' ) return(F_ERNMLIST);
322 }
323 while(isblnk(GETC));
324 if(leof) return(EOF);
325 UNGETC();
326 if(i!=0 && ch == namelistkey_) return(OK);
327
328 switch((int)type)
329 {
330 case TYSHORT:
331 case TYLONG:
332 if(!isint(ch)) return(OK);
333 ERRNM(l_R(1));
334 break;
335 case TYREAL:
336 case TYDREAL:
337 if(!isrl(ch)) return(OK);
338 ERRNM(l_R(1));
339 break;
340 case TYCOMPLEX:
341 case TYDCOMPLEX:
342 if(!isdigit(ch) && ch!='(') return(OK);
343 ERRNM(l_C());
344 break;
345 case TYLOGICAL:
346 if(!islgc(ch)) return(OK);
347 ERRNM(l_L());
348 if(nameflag) return(OK);
349 break;
350 case TYCHAR:
351 if(!isdigit(ch) && !isapos(ch)) return(OK);
352 ERRNM(l_CHAR());
353 break;
354 }
355
356 if(leof) return(EOF);
357 /* peek at next character -
358 should be separator or namelistkey_ */
359 GETC; UNGETC();
360 if(!issep(ch) && (ch != namelistkey_))
361 return( leof?EOF:F_ERNMLIST );
362 }
363
364 if(!ltype) return(F_ERNMLIST);
365 switch((int)type)
366 {
367 case TYSHORT:
368 ptr->flshort=lx;
369 break;
370 case TYLOGICAL:
371 if(len == sizeof(short))
372 ptr->flshort = lx;
373 else
374 ptr->flint = lx;
375 break;
376 case TYLONG:
377 ptr->flint=lx;
378 break;
379 case TYREAL:
380 ptr->flreal=lx;
381 break;
382 case TYDREAL:
383 ptr->fldouble=lx;
384 break;
385 case TYCOMPLEX:
386 xx=(float *)ptr;
387 *xx++ = ly;
388 *xx = lx;
389 break;
390 case TYDCOMPLEX:
391 yy=(double *)ptr;
392 *yy++ = ly;
393 *yy = lx;
394 break;
395 case TYCHAR:
396 b_char(lchar,(char *)ptr,len);
397 break;
398 }
399 if(lcount>0) lcount--;
400 ptr = (flex *)((char *)ptr + len);
401 }
402 if(lcount>0) return F_ERNMLIST;
403 return(OK);
404 }
405
406 LOCAL
get_repet()407 get_repet()
408 {
409 double lc;
410 if(isdigit(GETC))
411 { UNGETC();
412 rd_int(&lc);
413 lcount = (int)lc;
414 if(GETC!='*')
415 if(leof) return(EOF);
416 else return(F_ERREPT);
417 }
418 else
419 { lcount = 1;
420 UNGETC();
421 }
422 return(OK);
423 }
424
425 LOCAL
l_R(flg)426 l_R(flg) int flg;
427 { double a,b,c,d;
428 int da,db,dc,dd;
429 int i,sign=0;
430 a=b=c=d=0;
431 da=db=dc=dd=0;
432
433 if( flg ) /* real */
434 {
435 da=rd_int(&a); /* repeat count ? */
436 if(GETC=='*')
437 {
438 if (a <= 0.) return(F_ERNREP);
439 lcount=(int)a;
440 db=rd_int(&b); /* whole part of number */
441 }
442 else
443 { UNGETC();
444 db=da;
445 b=a;
446 lcount=1;
447 }
448 }
449 else /* complex */
450 {
451 db=rd_int(&b);
452 }
453
454 if(GETC=='.' && isdigit(GETC))
455 { UNGETC();
456 dc=rd_int(&c); /* fractional part of number */
457 }
458 else
459 { UNGETC();
460 dc=0;
461 c=0.;
462 }
463 if(isexp(GETC))
464 dd=rd_int(&d); /* exponent */
465 else if (ch == '+' || ch == '-')
466 { UNGETC();
467 dd=rd_int(&d);
468 }
469 else
470 { UNGETC();
471 dd=0;
472 }
473 if(db<0 || b<0)
474 { sign=1;
475 b = -b;
476 }
477 for(i=0;i<dc;i++) c/=10.;
478 b=b+c;
479 if (dd > 0)
480 { for(i=0;i<d;i++) b *= 10.;
481 for(i=0;i< -d;i++) b /= 10.;
482 }
483 lx=sign?-b:b;
484 ltype=TYLONG;
485 return(OK);
486 }
487
488 LOCAL
rd_int(x)489 rd_int(x) double *x;
490 { int sign=0,i=0;
491 double y=0.0;
492 if(GETC=='-') sign = -1;
493 else if(ch=='+') sign=0;
494 else UNGETC();
495 while(isdigit(GETC))
496 { i++;
497 y=10*y + ch-'0';
498 }
499 UNGETC();
500 if(sign) y = -y;
501 *x = y;
502 return(y==0.0?sign:i); /* 0:[+]&&y==0, -1:-&&y==0, >0:#digits&&y!=0 */
503 }
504
505 LOCAL
l_C()506 l_C()
507 { int n;
508 if(n=get_repet()) return(n); /* get repeat count */
509 if(GETC!='(') err(errflag,F_ERNMLIST,"no (")
510 while(isblnk(GETC));
511 UNGETC();
512 l_R(0); /* get real part */
513 ly = lx;
514 while(isblnk(GETC)); /* get comma */
515 if(leof) return(EOF);
516 if(ch!=',') return(F_ERNMLIST);
517 while(isblnk(GETC));
518 UNGETC();
519 if(leof) return(EOF);
520 l_R(0); /* get imag part */
521 while(isblnk(GETC));
522 if(ch!=')') err(errflag,F_ERNMLIST,"no )")
523 ltype = TYCOMPLEX;
524 return(OK);
525 }
526
527 LOCAL
l_L()528 l_L()
529 {
530 int n, keychar=ch, scanned=NO;
531 if(ch=='f' || ch=='F' || ch=='t' || ch=='T')
532 {
533 scanned=YES;
534 if(rd_name(var_name))
535 return(leof?EOF:F_ERNMLIST);
536 while(isblnk(GETC));
537 UNGETC();
538 if(ch == '=' || ch == '(')
539 { /* found a name, not a value */
540 nameflag = YES;
541 return(OK);
542 }
543 }
544 else
545 {
546 if(n=get_repet()) return(n); /* get repeat count */
547 if(GETC=='.') GETC;
548 keychar = ch;
549 }
550 switch(keychar)
551 {
552 case 't':
553 case 'T':
554 lx=1;
555 break;
556 case 'f':
557 case 'F':
558 lx=0;
559 break;
560 default:
561 if(ch==EOF) return(EOF);
562 else err(errflag,F_ERNMLIST,"logical not T or F");
563 }
564 ltype=TYLOGICAL;
565 if(scanned==NO)
566 {
567 while(!issep(GETC) && ch!=EOF) ;
568 UNGETC();
569 }
570 if(ch == EOF ) return(EOF);
571 return(OK);
572 }
573
574 #define BUFSIZE 128
575 LOCAL
l_CHAR()576 l_CHAR()
577 { int size,i,n;
578 char quote,*p;
579 if(n=get_repet()) return(n); /* get repeat count */
580 if(isapos(GETC)) quote=ch;
581 else if(ch == EOF) return EOF;
582 else return F_ERNMLIST;
583 ltype=TYCHAR;
584 if(lchar!=NULL) free(lchar);
585 size=BUFSIZE-1;
586 p=lchar=(char *)malloc(BUFSIZE);
587 if(lchar==NULL) return (F_ERSPACE);
588 for(i=0;;)
589 { while( GETC!=quote && ch!='\n' && ch!=EOF && ++i<size )
590 *p++ = ch;
591 if(i==size)
592 {
593 newone:
594 size += BUFSIZE;
595 lchar=(char *)realloc(lchar, size+1);
596 if(lchar==NULL) return( F_ERSPACE );
597 p=lchar+i-1;
598 *p++ = ch;
599 }
600 else if(ch==EOF) return(EOF);
601 else if(ch=='\n')
602 { if(*(p-1) == '\\') *(p-1) = ch;
603 }
604 else if(GETC==quote)
605 { if(++i<size) *p++ = ch;
606 else goto newone;
607 }
608 else
609 { UNGETC();
610 *p = '\0';
611 return(OK);
612 }
613 }
614 }
615