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
 282   if (!Alpha['a'])
 283     nl_init ();
 284   f__reading = 1;
 285   f__formatted = 1;
 286   got1 = 0;
 287 top:
 288   for (;;)
 289     switch (GETC (ch))
 290       {
 291       case EOF:
 292       eof:
 293         err (a->ciend, (EOF), where0);
 294       case '&':
 295       case '$':
 296         goto have_amp;
 297 #ifndef No_Namelist_Questions
 298       case '?':
 299         print_ne (a);
 300         continue;
 301 #endif
 302       default:
 303         if (ch <= ' ' && ch >= 0)
 304           continue;
 305 #ifndef No_Namelist_Comments
 306         while (GETC (ch) != '\n')
 307           if (ch == EOF)
 308             goto eof;
 309 #else
 310         errfl (a->cierr, 115, where0);
 311 #endif
 312       }
 313 have_amp:
 314   if ((ch = getname (buf, sizeof (buf))))
 315     return ch;
 316   nl = (Namelist *) a->cifmt;
 317   if (strcmp (buf, nl->name))
 318 #ifdef No_Bad_Namelist_Skip
 319     errfl (a->cierr, 118, where0);
 320 #else
 321     {
 322       fprintf (stderr,
 323                "Skipping namelist \"%s\": seeking namelist \"%s\".\n",
 324                buf, nl->name);
 325       fflush (stderr);
 326       for (;;)
 327         switch (GETC (ch))
 328           {
 329           case EOF:
 330             err (a->ciend, EOF, where0);
 331           case '/':
 332           case '&':
 333           case '$':
 334             if (f__external)
 335               e_rsle ();
 336             else
 337               z_rnew ();
 338             goto top;
 339           case '"':
 340           case '\'':
 341             quote = ch;
 342           more_quoted:
 343             while (GETC (ch) != quote)
 344               if (ch == EOF)
 345                 err (a->ciend, EOF, where0);
 346             if (GETC (ch) == quote)
 347               goto more_quoted;
 348             Ungetc (ch, f__cf);
 349           default:
 350             continue;
 351           }
 352     }
 353 #endif
 354   ht = mk_hashtab (nl);
 355   if (!ht)
 356     errfl (f__elist->cierr, 113, where0);
 357   for (;;)
 358     {
 359       for (;;)
 360         switch (GETC (ch))
 361           {
 362           case EOF:
 363             if (got1)
 364               return 0;
 365             err (a->ciend, EOF, where0);
 366           case '/':
 367           case '$':
 368           case '&':
 369             return 0;
 370           default:
 371             if ((ch <= ' ' && ch >= 0) || ch == ',')
 372               continue;
 373             Ungetc (ch, f__cf);
 374             if ((ch = getname (buf, sizeof (buf))))
 375               return ch;
 376             goto havename;
 377           }
 378     havename:
 379       v = hash (ht, buf);
 380       if (!v)
 381         errfl (a->cierr, 119, where);
 382       while (GETC (ch) <= ' ' && ch >= 0);
 383       vaddr = v->addr;
 384       type = v->type;
 385       if (type < 0)
 386         {
 387           size = -type;
 388           type = TYCHAR;
 389         }
 390       else
 391         size = f__typesize[type];
 392       ivae = size;
 393       iva = readall = 0;
 394       if (ch == '(' /*) */ )
 395         {
 396           dn = dimens;
 397           if (!(dims = v->dims))
 398             {
 399               if (type != TYCHAR)
 400                 errfl (a->cierr, 122, where);
 401               if ((k = getdimen (&ch, dn, (ftnlen) size, (ftnlen) size, &b)))
 402                 errfl (a->cierr, k, where);
 403               if (ch != ')')
 404                 errfl (a->cierr, 115, where);
 405               b1 = dn->extent;
 406               if (--b < 0 || b + b1 > size)
 407                 return 124;
 408               iva += b;
 409               size = b1;
 410               while (GETC (ch) <= ' ' && ch >= 0);
 411               goto scalar;
 412             }
 413           nd = (int) dims[0];
 414           nomax = span = dims[1];
 415           ivae = iva + size * nomax;
 416           colonseen = 0;
 417           if ((k = getdimen (&ch, dn, size, nomax, &b)))
 418             errfl (a->cierr, k, where);
 419           no = dn->extent;
 420           b0 = dims[2];
 421           dims1 = dims += 3;
 422           ex = 1;
 423           for (n = 1; n++ < nd; dims++)
 424             {
 425               if (ch != ',')
 426                 errfl (a->cierr, 115, where);
 427               dn1 = dn + 1;
 428               span /= *dims;
 429               if ((k = getdimen (&ch, dn1, dn->delta ** dims, span, &b1)))
 430                 errfl (a->cierr, k, where);
 431               ex *= *dims;
 432               b += b1 * ex;
 433               no *= dn1->extent;
 434               dn = dn1;
 435             }
 436           if (ch != ')')
 437             errfl (a->cierr, 115, where);
 438           readall = 1 - colonseen;
 439           b -= b0;
 440           if (b < 0 || b >= nomax)
 441             errfl (a->cierr, 125, where);
 442           iva += size * b;
 443           dims = dims1;
 444           while (GETC (ch) <= ' ' && ch >= 0);
 445           no1 = 1;
 446           dn0 = dimens;
 447           if (type == TYCHAR && ch == '(' /*) */ )
 448             {
 449               if ((k = getdimen (&ch, &substr, size, size, &b)))
 450                 errfl (a->cierr, k, where);
 451               if (ch != ')')
 452                 errfl (a->cierr, 115, where);
 453               b1 = substr.extent;
 454               if (--b < 0 || b + b1 > size)
 455                 return 124;
 456               iva += b;
 457               b0 = size;
 458               size = b1;
 459               while (GETC (ch) <= ' ' && ch >= 0);
 460               if (b1 < b0)
 461                 goto delta_adj;
 462             }
 463           if (readall)
 464             goto delta_adj;
 465           for (; dn0 < dn; dn0++)
 466             {
 467               if (dn0->extent != *dims++ || dn0->stride != 1)
 468                 break;
 469               no1 *= dn0->extent;
 470             }
 471           if (dn0 == dimens && dimens[0].stride == 1)
 472             {
 473               no1 = dimens[0].extent;
 474               dn0++;
 475             }
 476         delta_adj:
 477           ex = 0;
 478           for (dn1 = dn0; dn1 <= dn; dn1++)
 479             ex += (dn1->extent - 1) * (dn1->delta *= dn1->stride);
 480           for (dn1 = dn; dn1 > dn0; dn1--)
 481             {
 482               ex -= (dn1->extent - 1) * dn1->delta;
 483               dn1->delta -= ex;
 484             }
 485         }
 486       else if ((dims = v->dims))
 487         {
 488           no = no1 = dims[1];
 489           ivae = iva + no * size;
 490         }
 491       else
 492       scalar:
 493         no = no1 = 1;
 494       if (ch != '=')
 495         errfl (a->cierr, 115, where);
 496       got1 = nml_read = 1;
 497       f__lcount = 0;
 498     readloop:
 499       for (;;)
 500         {
 501           if (iva >= ivae || iva < 0)
 502             {
 503               f__lquit = 1;
 504               goto mustend;
 505             }
 506           else if (iva + no1 * size > ivae)
 507             no1 = (ivae - iva) / size;
 508           f__lquit = 0;
 509           if ((k = l_read (&no1, vaddr + iva, size, type)))
 510             return k;
 511           if (f__lquit == 1)
 512             return 0;
 513           if (readall)
 514             {
 515               iva += dn0->delta;
 516               if (f__lcount > 0)
 517                 {
 518                   ftnint no2 = (ivae - iva) / size;
 519                   if (no2 > f__lcount)
 520                     no2 = f__lcount;
 521                   if ((k = l_read (&no2, vaddr + iva, size, type)))
 522                     return k;
 523                   iva += no2 * dn0->delta;
 524                 }
 525             }
 526         mustend:
 527           GETC (ch);
 528           if (readall)
 529             {
 530               if (iva >= ivae)
 531                 readall = 0;
 532               else
 533                 for (;;)
 534                   {
 535                     switch (ch)
 536                       {
 537                       case ' ':
 538                       case '\t':
 539                       case '\n':
 540                         GETC (ch);
 541                         continue;
 542                       }
 543                     break;
 544                   }
 545             }
 546           if (ch == '/' || ch == '$' || ch == '&')
 547             {
 548               f__lquit = 1;
 549               return 0;
 550             }
 551           else if (f__lquit)
 552             {
 553               while (ch <= ' ' && ch >= 0)
 554                 GETC (ch);
 555               Ungetc (ch, f__cf);
 556               if (!Alpha[ch & 0xff] && ch >= 0)
 557                 errfl (a->cierr, 125, where);
 558               break;
 559             }
 560           Ungetc (ch, f__cf);
 561           if (readall && !Alpha[ch & 0xff])
 562             goto readloop;
 563           if ((no -= no1) <= 0)
 564             break;
 565           for (dn1 = dn0; dn1 <= dn; dn1++)
 566             {
 567               if (++dn1->curval < dn1->extent)
 568                 {
 569                   iva += dn1->delta;
 570                   goto readloop;
 571                 }
 572               dn1->curval = 0;
 573             }
 574           break;
 575         }
 576     }
 577 }
 578
 579 integer
 580 s_rsne (cilist * a)
 581 {
 582   extern int l_eof;
 583   int n;
 584
 585   f__external = 1;
 586   l_eof = 0;
 587   if ((n = c_le (a)))
 588     return n;
 589   if (f__curunit->uwrt && f__nowreading (f__curunit))
 590     err (a->cierr, errno, where0);
 591   l_getc = t_getc;
 592   l_ungetc = un_getc;
 593   f__doend = xrd_SL;
 594   n = x_rsne (a);
 595   nml_read = 0;
 596   if (n)
 597     return n;
 598   return e_rsle ();
 599 }