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