libf2c/libI77/rsne.c

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