1#include "f2c.h" 2#include "fio.h" 3#include "lio.h" 4 5#define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */ 6#define MAXDIM 20 /* maximum number of subscripts */ 7 8 struct dimen { 9 ftnlen extent; 10 ftnlen curval; 11 ftnlen delta; 12 ftnlen stride; 13 }; 14 typedef struct dimen dimen; 15 16 struct hashentry { 17 struct hashentry *next; 18 char *name; 19 Vardesc *vd; 20 }; 21 typedef struct hashentry hashentry; 22 23 struct hashtab { 24 struct hashtab *next; 25 Namelist *nl; 26 int htsize; 27 hashentry *tab[1]; 28 }; 29 typedef struct hashtab hashtab; 30 31 static hashtab *nl_cache; 32 static int n_nlcache; 33 static hashentry **zot; 34 static int colonseen; 35 extern ftnlen f__typesize[]; 36 37 extern flag f__lquit; 38 extern int f__lcount, nml_read; 39 extern t_getc(Void); 40 41#ifdef KR_headers 42 extern char *malloc(), *memset(); 43 44#ifdef ungetc 45 static int 46un_getc(x,f__cf) int x; FILE *f__cf; 47{ return ungetc(x,f__cf); } 48#else 49#define un_getc ungetc 50 extern int ungetc(); 51#endif 52 53#else 54#undef abs 55#undef min 56#undef max 57#include <stdlib.h> 58#include <string.h> 59 60#ifdef ungetc 61 static int 62un_getc(int x, FILE *f__cf) 63{ return ungetc(x,f__cf); } 64#else 65#define un_getc ungetc 66extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ 67#endif 68#endif 69 70 static Vardesc * 71#ifdef KR_headers 72hash(ht, s) hashtab *ht; register char *s; 73#else 74hash(hashtab *ht, register char *s) 75#endif 76{ 77 register int c, x; 78 register hashentry *h; 79 char *s0 = s; 80 81 for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1) 82 x += c; 83 for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next) 84 if (!strcmp(s0, h->name)) 85 return h->vd; 86 return 0; 87 } 88 89 hashtab * 90#ifdef KR_headers 91mk_hashtab(nl) Namelist *nl; 92#else 93mk_hashtab(Namelist *nl) 94#endif 95{ 96 int nht, nv; 97 hashtab *ht; 98 Vardesc *v, **vd, **vde; 99 hashentry *he; 100 101 hashtab **x, **x0, *y; 102 for(x = &nl_cache; y = *x; x0 = x, x = &y->next) 103 if (nl == y->nl) 104 return y; 105 if (n_nlcache >= MAX_NL_CACHE) { 106 /* discard least recently used namelist hash table */ 107 y = *x0; 108 free((char *)y->next); 109 y->next = 0; 110 } 111 else 112 n_nlcache++; 113 nv = nl->nvars; 114 if (nv >= 0x4000) 115 nht = 0x7fff; 116 else { 117 for(nht = 1; nht < nv; nht <<= 1); 118 nht += nht - 1; 119 } 120 ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *) 121 + nv*sizeof(hashentry)); 122 if (!ht) 123 return 0; 124 he = (hashentry *)&ht->tab[nht]; 125 ht->nl = nl; 126 ht->htsize = nht; 127 ht->next = nl_cache; 128 nl_cache = ht; 129 memset((char *)ht->tab, 0, nht*sizeof(hashentry *)); 130 vd = nl->vars; 131 vde = vd + nv; 132 while(vd < vde) { 133 v = *vd++; 134 if (!hash(ht, v->name)) { 135 he->next = *zot; 136 *zot = he; 137 he->name = v->name; 138 he->vd = v; 139 he++; 140 } 141 } 142 return ht; 143 } 144 145static char Alpha[256], Alphanum[256]; 146 147 static VOID 148nl_init(Void) { 149 register char *s; 150 register int c; 151 152 for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; ) 153 Alpha[c] 154 = Alphanum[c] 155 = Alpha[c + 'a' - 'A'] 156 = Alphanum[c + 'a' - 'A'] 157 = c; 158 for(s = "0123456789_"; c = *s++; ) 159 Alphanum[c] = c; 160 } 161 162#define GETC(x) (x=(*l_getc)()) 163#define Ungetc(x,y) (*l_ungetc)(x,y) 164 165 static int 166#ifdef KR_headers 167getname(s, slen) register char *s; int slen; 168#else 169getname(register char *s, int slen) 170#endif 171{ 172 register char *se = s + slen - 1; 173 register int ch; 174 175 GETC(ch); 176 if (!(*s++ = Alpha[ch & 0xff])) { 177 if (ch != EOF) 178 ch = 115; 179 errfl(f__elist->cierr, ch, "namelist read"); 180 } 181 while(*s = Alphanum[GETC(ch) & 0xff]) 182 if (s < se) 183 s++; 184 if (ch == EOF) 185 err(f__elist->cierr, EOF, "namelist read"); 186 if (ch > ' ') 187 Ungetc(ch,f__cf); 188 return *s = 0; 189 } 190 191 static int 192#ifdef KR_headers 193getnum(chp, val) int *chp; ftnlen *val; 194#else 195getnum(int *chp, ftnlen *val) 196#endif 197{ 198 register int ch, sign; 199 register ftnlen x; 200 201 while(GETC(ch) <= ' ' && ch >= 0); 202 if (ch == '-') { 203 sign = 1; 204 GETC(ch); 205 } 206 else { 207 sign = 0; 208 if (ch == '+') 209 GETC(ch); 210 } 211 x = ch - '0'; 212 if (x < 0 || x > 9) 213 return 115; 214 while(GETC(ch) >= '0' && ch <= '9') 215 x = 10*x + ch - '0'; 216 while(ch <= ' ' && ch >= 0) 217 GETC(ch); 218 if (ch == EOF) 219 return EOF; 220 *val = sign ? -x : x; 221 *chp = ch; 222 return 0; 223 } 224 225 static int 226#ifdef KR_headers 227getdimen(chp, d, delta, extent, x1) 228 int *chp; dimen *d; ftnlen delta, extent, *x1; 229#else 230getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1) 231#endif 232{ 233 register int k; 234 ftnlen x2, x3; 235 236 if (k = getnum(chp, x1)) 237 return k; 238 x3 = 1; 239 if (*chp == ':') { 240 if (k = getnum(chp, &x2)) 241 return k; 242 x2 -= *x1; 243 if (*chp == ':') { 244 if (k = getnum(chp, &x3)) 245 return k; 246 if (!x3) 247 return 123; 248 x2 /= x3; 249 colonseen = 1; 250 } 251 if (x2 < 0 || x2 >= extent) 252 return 123; 253 d->extent = x2 + 1; 254 } 255 else 256 d->extent = 1; 257 d->curval = 0; 258 d->delta = delta; 259 d->stride = x3; 260 return 0; 261 } 262 263#ifndef No_Namelist_Questions 264 static Void 265#ifdef KR_headers 266print_ne(a) cilist *a; 267#else 268print_ne(cilist *a) 269#endif 270{ 271 flag intext = f__external; 272 int rpsave = f__recpos; 273 FILE *cfsave = f__cf; 274 unit *usave = f__curunit; 275 cilist t; 276 t = *a; 277 t.ciunit = 6; 278 s_wsne(&t); 279 fflush(f__cf); 280 f__external = intext; 281 f__reading = 1; 282 f__recpos = rpsave; 283 f__cf = cfsave; 284 f__curunit = usave; 285 f__elist = a; 286 } 287#endif 288 289 static char where0[] = "namelist read start "; 290 291#ifdef KR_headers 292x_rsne(a) cilist *a; 293#else 294x_rsne(cilist *a) 295#endif 296{ 297 int ch, got1, k, n, nd, quote, readall; 298 Namelist *nl; 299 static char where[] = "namelist read"; 300 char buf[64]; 301 hashtab *ht; 302 Vardesc *v; 303 dimen *dn, *dn0, *dn1; 304 ftnlen *dims, *dims1; 305 ftnlen b, b0, b1, ex, no, no1, nomax, size, span; 306 ftnint type; 307 char *vaddr; 308 long iva, ivae; 309 dimen dimens[MAXDIM], substr; 310 311 if (!Alpha['a']) 312 nl_init(); 313 f__reading=1; 314 f__formatted=1; 315 got1 = 0; 316 top: 317 for(;;) switch(GETC(ch)) { 318 case EOF: 319 eof: 320 err(a->ciend,(EOF),where0); 321 case '&': 322 case '$': 323 goto have_amp; 324#ifndef No_Namelist_Questions 325 case '?': 326 print_ne(a); 327 continue; 328#endif 329 default: 330 if (ch <= ' ' && ch >= 0) 331 continue; 332#ifndef No_Namelist_Comments 333 while(GETC(ch) != '\n') 334 if (ch == EOF) 335 goto eof; 336#else 337 errfl(a->cierr, 115, where0); 338#endif 339 } 340 have_amp: 341 if (ch = getname(buf,(int) sizeof(buf))) 342 return ch; 343 nl = (Namelist *)a->cifmt; 344 if (strcmp(buf, nl->name)) 345#ifdef No_Bad_Namelist_Skip 346 errfl(a->cierr, 118, where0); 347#else 348 { 349 fprintf(stderr, 350 "Skipping namelist \"%s\": seeking namelist \"%s\".\n", 351 buf, nl->name); 352 fflush(stderr); 353 for(;;) switch(GETC(ch)) { 354 case EOF: 355 err(a->ciend, EOF, where0); 356 case '/': 357 case '&': 358 case '$': 359 if (f__external) 360 e_rsle(); 361 else 362 z_rnew(); 363 goto top; 364 case '"': 365 case '\'': 366 quote = ch; 367 more_quoted: 368 while(GETC(ch) != quote) 369 if (ch == EOF) 370 err(a->ciend, EOF, where0); 371 if (GETC(ch) == quote) 372 goto more_quoted; 373 Ungetc(ch,f__cf); 374 default: 375 continue; 376 } 377 } 378#endif 379 ht = mk_hashtab(nl); 380 if (!ht) 381 errfl(f__elist->cierr, 113, where0); 382 for(;;) { 383 for(;;) switch(GETC(ch)) { 384 case EOF: 385 if (got1) 386 return 0; 387 err(a->ciend, EOF, where0); 388 case '/': 389 case '$': 390 case '&': 391 return 0; 392 default: 393 if (ch <= ' ' && ch >= 0 || ch == ',') 394 continue; 395 Ungetc(ch,f__cf); 396 if (ch = getname(buf,(int) sizeof(buf))) 397 return ch; 398 goto havename; 399 } 400 havename: 401 v = hash(ht,buf); 402 if (!v) 403 errfl(a->cierr, 119, where); 404 while(GETC(ch) <= ' ' && ch >= 0); 405 vaddr = v->addr; 406 type = v->type; 407 if (type < 0) { 408 size = -type; 409 type = TYCHAR; 410 } 411 else 412 size = f__typesize[type]; 413 ivae = size; 414 iva = readall = 0; 415 if (ch == '(' /*)*/ ) { 416 dn = dimens; 417 if (!(dims = v->dims)) { 418 if (type != TYCHAR) 419 errfl(a->cierr, 122, where); 420 if (k = getdimen(&ch, dn, (ftnlen)size, 421 (ftnlen)size, &b)) 422 errfl(a->cierr, k, where); 423 if (ch != ')') 424 errfl(a->cierr, 115, where); 425 b1 = dn->extent; 426 if (--b < 0 || b + b1 > size) 427 return 124; 428 iva += b; 429 size = b1; 430 while(GETC(ch) <= ' ' && ch >= 0); 431 goto scalar; 432 } 433 nd = (int)dims[0]; 434 nomax = span = dims[1]; 435 ivae = iva + size*nomax; 436 colonseen = 0; 437 if (k = getdimen(&ch, dn, size, nomax, &b)) 438 errfl(a->cierr, k, where); 439 no = dn->extent; 440 b0 = dims[2]; 441 dims1 = dims += 3; 442 ex = 1; 443 for(n = 1; n++ < nd; dims++) { 444 if (ch != ',') 445 errfl(a->cierr, 115, where); 446 dn1 = dn + 1; 447 span /= *dims; 448 if (k = getdimen(&ch, dn1, dn->delta**dims, 449 span, &b1)) 450 errfl(a->cierr, k, where); 451 ex *= *dims; 452 b += b1*ex; 453 no *= dn1->extent; 454 dn = dn1; 455 } 456 if (ch != ')') 457 errfl(a->cierr, 115, where); 458 readall = 1 - colonseen; 459 b -= b0; 460 if (b < 0 || b >= nomax) 461 errfl(a->cierr, 125, where); 462 iva += size * b; 463 dims = dims1; 464 while(GETC(ch) <= ' ' && ch >= 0); 465 no1 = 1; 466 dn0 = dimens; 467 if (type == TYCHAR && ch == '(' /*)*/) { 468 if (k = getdimen(&ch, &substr, size, size, &b)) 469 errfl(a->cierr, k, where); 470 if (ch != ')') 471 errfl(a->cierr, 115, where); 472 b1 = substr.extent; 473 if (--b < 0 || b + b1 > size) 474 return 124; 475 iva += b; 476 b0 = size; 477 size = b1; 478 while(GETC(ch) <= ' ' && ch >= 0); 479 if (b1 < b0) 480 goto delta_adj; 481 } 482 if (readall) 483 goto delta_adj; 484 for(; dn0 < dn; dn0++) { 485 if (dn0->extent != *dims++ || dn0->stride != 1) 486 break; 487 no1 *= dn0->extent; 488 } 489 if (dn0 == dimens && dimens[0].stride == 1) { 490 no1 = dimens[0].extent; 491 dn0++; 492 } 493 delta_adj: 494 ex = 0; 495 for(dn1 = dn0; dn1 <= dn; dn1++) 496 ex += (dn1->extent-1) 497 * (dn1->delta *= dn1->stride); 498 for(dn1 = dn; dn1 > dn0; dn1--) { 499 ex -= (dn1->extent - 1) * dn1->delta; 500 dn1->delta -= ex; 501 } 502 } 503 else if (dims = v->dims) { 504 no = no1 = dims[1]; 505 ivae = iva + no*size; 506 } 507 else 508 scalar: 509 no = no1 = 1; 510 if (ch != '=') 511 errfl(a->cierr, 115, where); 512 got1 = nml_read = 1; 513 f__lcount = 0; 514 readloop: 515 for(;;) { 516 if (iva >= ivae || iva < 0) { 517 f__lquit = 1; 518 goto mustend; 519 } 520 else if (iva + no1*size > ivae) 521 no1 = (ivae - iva)/size; 522 f__lquit = 0; 523 if (k = l_read(&no1, vaddr + iva, size, type)) 524 return k; 525 if (f__lquit == 1) 526 return 0; 527 if (readall) { 528 iva += dn0->delta; 529 if (f__lcount > 0) { 530 no1 = (ivae - iva)/size; 531 if (no1 > f__lcount) 532 no1 = f__lcount; 533 if (k = l_read(&no1, vaddr + iva, 534 size, type)) 535 return k; 536 iva += no1 * dn0->delta; 537 } 538 } 539 mustend: 540 GETC(ch); 541 if (readall) 542 if (iva >= ivae) 543 readall = 0; 544 else for(;;) { 545 switch(ch) { 546 case ' ': 547 case '\t': 548 case '\n': 549 GETC(ch); 550 continue; 551 } 552 break; 553 } 554 if (ch == '/' || ch == '$' || ch == '&') { 555 f__lquit = 1; 556 return 0; 557 } 558 else if (f__lquit) { 559 while(ch <= ' ' && ch >= 0) 560 GETC(ch); 561 Ungetc(ch,f__cf); 562 if (!Alpha[ch & 0xff] && ch >= 0) 563 errfl(a->cierr, 125, where); 564 break; 565 } 566 Ungetc(ch,f__cf); 567 if (readall && !Alpha[ch & 0xff]) 568 goto readloop; 569 if ((no -= no1) <= 0) 570 break; 571 for(dn1 = dn0; dn1 <= dn; dn1++) { 572 if (++dn1->curval < dn1->extent) { 573 iva += dn1->delta; 574 goto readloop; 575 } 576 dn1->curval = 0; 577 } 578 break; 579 } 580 } 581 } 582 583 integer 584#ifdef KR_headers 585s_rsne(a) cilist *a; 586#else 587s_rsne(cilist *a) 588#endif 589{ 590 extern int l_eof; 591 int n; 592 593 f__external=1; 594 l_eof = 0; 595 if(n = c_le(a)) 596 return n; 597 if(f__curunit->uwrt && f__nowreading(f__curunit)) 598 err(a->cierr,errno,where0); 599 l_getc = t_getc; 600 l_ungetc = un_getc; 601 f__doend = xrd_SL; 602 n = x_rsne(a); 603 nml_read = 0; 604 if (n) 605 return n; 606 return e_rsle(); 607 } 608