lang/fortran/lib/libI77/rsne.c

   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  extern char *malloc(), *memset();
   9
  10  struct dimen {
  11         ftnlen extent;
  12         ftnlen curval;
  13         ftnlen delta;
  14         ftnlen stride;
  15         };
  16  typedef struct dimen dimen;
  17
  18  struct hashentry {
  19         struct hashentry *next;
  20         char *name;
  21         Vardesc *vd;
  22         };
  23  typedef struct hashentry hashentry;
  24
  25  struct hashtab {
  26         struct hashtab *next;
  27         Namelist *nl;
  28         int htsize;
  29         hashentry *tab[1];
  30         };
  31  typedef struct hashtab hashtab;
  32
  33  static hashtab *nl_cache;
  34  static n_nlcache;
  35  static hashentry **zot;
  36  extern ftnlen typesize[];
  37
  38  extern flag lquit;
  39  extern int lcount;
  40  extern int (*l_getc)(), (*l_ungetc)(), t_getc(), ungetc();
  41
  42  static Vardesc *
  43 hash(ht, s)
  44  hashtab *ht;
  45  register char *s;
  46 {
  47         register int c, x;
  48         register hashentry *h;
  49         char *s0 = s;
  50
  51         for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
  52                 x += c;
  53         for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next)
  54                 if (!strcmp(s0, h->name))
  55                         return h->vd;
  56         return 0;
  57         }
  58
  59  hashtab *
  60 mk_hashtab(nl)
  61  Namelist *nl;
  62 {
  63         int nht, nv;
  64         hashtab *ht;
  65         Vardesc *v, **vd, **vde;
  66         hashentry *he;
  67
  68         hashtab **x, **x0, *y;
  69         for(x = &nl_cache; y = *x; x0 = x, x = &y->next)
  70                 if (nl == y->nl)
  71                         return y;
  72         if (n_nlcache >= MAX_NL_CACHE) {
  73                 /* discard least recently used namelist hash table */
  74                 y = *x0;
  75                 free((char *)y->next);
  76                 y->next = 0;
  77                 }
  78         else
  79                 n_nlcache++;
  80         nv = nl->nvars;
  81         if (nv >= 0x4000)
  82                 nht = 0x7fff;
  83         else {
  84                 for(nht = 1; nht < nv; nht <<= 1);
  85                 nht += nht - 1;
  86                 }
  87         ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *)
  88                                 + nv*sizeof(hashentry));
  89         if (!ht)
  90                 return 0;
  91         he = (hashentry *)&ht->tab[nht];
  92         ht->nl = nl;
  93         ht->htsize = nht;
  94         ht->next = nl_cache;
  95         nl_cache = ht;
  96         memset((char *)ht->tab, 0, nht*sizeof(hashentry *));
  97         vd = nl->vars;
  98         vde = vd + nv;
  99         while(vd < vde) {
 100                 v = *vd++;
 101                 if (!hash(ht, v->name)) {
 102                         he->next = *zot;
 103                         *zot = he;
 104                         he->name = v->name;
 105                         he->vd = v;
 106                         he++;
 107                         }
 108                 }
 109         return ht;
 110         }
 111
 112 static char Alpha[256], Alphanum[256];
 113
 114  static void
 115 nl_init() {
 116         register char *s;
 117         register int c;
 118
 119         if(!init)
 120                 f_init();
 121         for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; )
 122                 Alpha[c]
 123                 = Alphanum[c]
 124                 = Alpha[c + 'a' - 'A']
 125                 = Alphanum[c + 'a' - 'A']
 126                 = c;
 127         for(s = "0123456789_"; c = *s++; )
 128                 Alphanum[c] = c;
 129         }
 130
 131 #define GETC(x) (x=(*l_getc)())
 132 #define Ungetc(x,y) (*l_ungetc)(x,y)
 133
 134  static int
 135 getname(s, slen)
 136  register char *s;
 137  int slen;
 138 {
 139         register char *se = s + slen - 1;
 140         register int ch;
 141
 142         GETC(ch);
 143         if (!(*s++ = Alpha[ch & 0xff])) {
 144                 if (ch != EOF)
 145                         ch = 115;
 146                 err(elist->cierr, ch, "namelist read");
 147                 }
 148         while(*s = Alphanum[GETC(ch) & 0xff])
 149                 if (s < se)
 150                         s++;
 151         if (ch == EOF)
 152                 err(elist->cierr, ch == EOF ? -1 : 115, "namelist read");
 153         if (ch > ' ')
 154                 Ungetc(ch,cf);
 155         return *s = 0;
 156         }
 157
 158  static int
 159 getnum(chp, val)
 160  int *chp;
 161  ftnlen *val;
 162 {
 163         register int ch, sign;
 164         register ftnlen x;
 165
 166         while(GETC(ch) <= ' ' && ch >= 0);
 167         if (ch == '-') {
 168                 sign = 1;
 169                 GETC(ch);
 170                 }
 171         else {
 172                 sign = 0;
 173                 if (ch == '+')
 174                         GETC(ch);
 175                 }
 176         x = ch - '0';
 177         if (x < 0 || x > 9)
 178                 return 115;
 179         while(GETC(ch) >= '0' && ch <= '9')
 180                 x = 10*x + ch - '0';
 181         while(ch <= ' ' && ch >= 0)
 182                 GETC(ch);
 183         if (ch == EOF)
 184                 return EOF;
 185         *val = sign ? -x : x;
 186         *chp = ch;
 187         return 0;
 188         }
 189
 190  static int
 191 getdimen(chp, d, delta, extent, x1)
 192  int *chp;
 193  dimen *d;
 194  ftnlen delta, extent, *x1;
 195 {
 196         register int k;
 197         ftnlen x2, x3;
 198
 199         if (k = getnum(chp, x1))
 200                 return k;
 201         x3 = 1;
 202         if (*chp == ':') {
 203                 if (k = getnum(chp, &x2))
 204                         return k;
 205                 x2 -= *x1;
 206                 if (*chp == ':') {
 207                         if (k = getnum(chp, &x3))
 208                                 return k;
 209                         if (!x3)
 210                                 return 123;
 211                         x2 /= x3;
 212                         }
 213                 if (x2 < 0 || x2 >= extent)
 214                         return 123;
 215                 d->extent = x2 + 1;
 216                 }
 217         else
 218                 d->extent = 1;
 219         d->curval = 0;
 220         d->delta = delta;
 221         d->stride = x3;
 222         return 0;
 223         }
 224
 225  static char where0[] = "namelist read start ";
 226
 227 x_rsne(a)
 228  cilist *a;
 229 {
 230         int ch, got1, k, n, nd;
 231         Namelist *nl;
 232         static char where[] = "namelist read";
 233         char buf[64];
 234         hashtab *ht;
 235         Vardesc *v;
 236         dimen *dn, *dn0, *dn1;
 237         ftnlen *dims, *dims1;
 238         ftnlen b, b0, b1, ex, no, no1, nomax, size, span;
 239         ftnint type;
 240         char *vaddr;
 241         long iva, ivae;
 242         dimen dimens[MAXDIM], substr;
 243
 244         if (!Alpha['a'])
 245                 nl_init();
 246         reading=1;
 247         formatted=1;
 248         lquit = 0;
 249         lcount = 0;
 250         got1 = 0;
 251         for(;;) switch(GETC(ch)) {
 252                 case EOF:
 253                         err(a->ciend,(EOF),where0);
 254                 case '&':
 255                 case '$':
 256                         goto have_amp;
 257                 default:
 258                         if (ch <= ' ' && ch >= 0)
 259                                 continue;
 260                         err(a->cierr, 115, where0);
 261                 }
 262  have_amp:
 263         if (ch = getname(buf,sizeof(buf)))
 264                 return ch;
 265         nl = (Namelist *)a->cifmt;
 266         if (strcmp(buf, nl->name))
 267                 err(a->cierr, 118, where0);
 268         ht = mk_hashtab(nl);
 269         if (!ht)
 270                 err(elist->cierr, 113, where0);
 271         for(;;) {
 272                 for(;;) switch(GETC(ch)) {
 273                         case EOF:
 274                                 if (got1)
 275                                         return 0;
 276                                 err(a->ciend,(EOF),where0);
 277                         case '/':
 278                         case '$':
 279                                 return 0;
 280                         default:
 281                                 if (ch <= ' ' && ch >= 0 || ch == ',')
 282                                         continue;
 283                                 Ungetc(ch,cf);
 284                                 if (ch = getname(buf,sizeof(buf)))
 285                                         return ch;
 286                                 goto havename;
 287                         }
 288  havename:
 289                 v = hash(ht,buf);
 290                 if (!v)
 291                         err(a->cierr, 119, where);
 292                 while(GETC(ch) <= ' ' && ch >= 0);
 293                 vaddr = v->addr;
 294                 type = v->type;
 295                 if (type < 0) {
 296                         size = -type;
 297                         type = TYCHAR;
 298                         }
 299                 else
 300                         size = typesize[type];
 301                 ivae = size;
 302                 iva = 0;
 303                 if (ch == '(' /*)*/ ) {
 304                         dn = dimens;
 305                         if (!(dims = v->dims)) {
 306                                 if (type != TYCHAR)
 307                                         err(a->cierr, 122, where);
 308                                 if (k = getdimen(&ch, dn, (ftnlen)size,
 309                                                 (ftnlen)size, &b))
 310                                         err(a->cierr, k, where);
 311                                 if (ch != ')')
 312                                         err(a->cierr, 115, where);
 313                                 b1 = dn->extent;
 314                                 if (--b < 0 || b + b1 > size)
 315                                         return 124;
 316                                 iva += b;
 317                                 size = b1;
 318                                 while(GETC(ch) <= ' ' && ch >= 0);
 319                                 goto scalar;
 320                                 }
 321                         nd = dims[0];
 322                         nomax = span = dims[1];
 323                         ivae = iva + size*nomax;
 324                         if (k = getdimen(&ch, dn, size, nomax, &b))
 325                                 err(a->cierr, k, where);
 326                         no = dn->extent;
 327                         b0 = dims[2];
 328                         dims1 = dims += 3;
 329                         ex = 1;
 330                         for(n = 1; n++ < nd; dims++) {
 331                                 if (ch != ',')
 332                                         err(a->cierr, 115, where);
 333                                 dn1 = dn + 1;
 334                                 span /= *dims;
 335                                 if (k = getdimen(&ch, dn1, dn->delta**dims,
 336                                                 span, &b1))
 337                                         err(a->cierr, k, where);
 338                                 ex *= *dims;
 339                                 b += b1*ex;
 340                                 no *= dn1->extent;
 341                                 dn = dn1;
 342                                 }
 343                         if (ch != ')')
 344                                 err(a->cierr, 115, where);
 345                         b -= b0;
 346                         if (b < 0 || b >= nomax)
 347                                 err(a->cierr, 125, where);
 348                         iva += size * b;
 349                         dims = dims1;
 350                         while(GETC(ch) <= ' ' && ch >= 0);
 351                         no1 = 1;
 352                         dn0 = dimens;
 353                         if (type == TYCHAR && ch == '(' /*)*/) {
 354                                 if (k = getdimen(&ch, &substr, size, size, &b))
 355                                         err(a->cierr, k, where);
 356                                 if (ch != ')')
 357                                         err(a->cierr, 115, where);
 358                                 b1 = substr.extent;
 359                                 if (--b < 0 || b + b1 > size)
 360                                         return 124;
 361                                 iva += b;
 362                                 b0 = size;
 363                                 size = b1;
 364                                 while(GETC(ch) <= ' ' && ch >= 0);
 365                                 if (b1 < b0)
 366                                         goto delta_adj;
 367                                 }
 368                         for(; dn0 < dn; dn0++) {
 369                                 if (dn0->extent != *dims++ || dn0->stride != 1)
 370                                         break;
 371                                 no1 *= dn0->extent;
 372                                 }
 373                         if (dn0 == dimens && dimens[0].stride == 1) {
 374                                 no1 = dimens[0].extent;
 375                                 dn0++;
 376                                 }
 377  delta_adj:
 378                         ex = 0;
 379                         for(dn1 = dn0; dn1 <= dn; dn1++)
 380                                 ex += (dn1->extent-1)
 381                                         * (dn1->delta *= dn1->stride);
 382                         for(dn1 = dn; dn1 > dn0; dn1--) {
 383                                 ex -= (dn1->extent - 1) * dn1->delta;
 384                                 dn1->delta -= ex;
 385                                 }
 386                         }
 387                 else if (dims = v->dims) {
 388                         no = no1 = dims[1];
 389                         ivae = iva + no*size;
 390                         }
 391                 else
 392  scalar:
 393                         no = no1 = 1;
 394                 if (ch != '=')
 395                         err(a->cierr, 115, where);
 396                 got1 = 1;
 397          readloop:
 398                 for(;;) {
 399                         if (iva >= ivae || iva < 0)
 400                                 goto mustend;
 401                         else if (iva + no1*size > ivae) {
 402                                 no1 = (ivae - iva)/size;
 403                                 l_read(&no1, vaddr + iva, size, type);
 404  mustend:
 405                                 if (GETC(ch) == '/' || ch == '$')
 406                                         lquit = 1;
 407                                 else
 408                                         err(a->cierr, 125, where);
 409                                 }
 410                         else
 411                                 l_read(&no1, vaddr + iva, size, type);
 412                         if (lquit)
 413                                 return 0;
 414                         if ((no -= no1) <= 0)
 415                                 break;
 416                         for(dn1 = dn0; dn1 <= dn; dn1++) {
 417                                 if (++dn1->curval < dn1->extent) {
 418                                         iva += dn1->delta;
 419                                         goto readloop;
 420                                         }
 421                                 dn1->curval = 0;
 422                                 }
 423                         break;
 424                         }
 425                 }
 426         }
 427
 428  integer
 429 s_rsne(a)
 430  cilist *a;
 431 {
 432         int n;
 433         extern integer e_rsle();
 434         external=1;
 435         if(n = c_le(a))
 436                 return n;
 437         if(curunit->uwrt && nowreading(curunit))
 438                 err(a->cierr,errno,where0);
 439         l_getc = t_getc;
 440         l_ungetc = ungetc;
 441         if (n = x_rsne(a))
 442                 return n;
 443         return e_rsle();
 444         }