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