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