|
|
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.4 12/21/87 ! 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.