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 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 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 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 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 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 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 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 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 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 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 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 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