6 #define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */
7 #define MAXDIM 20 /* maximum number of subscripts */
16 typedef struct dimen dimen;
20 struct hashentry *next;
24 typedef struct hashentry hashentry;
33 typedef struct hashtab hashtab;
35 static hashtab *nl_cache;
37 static hashentry **zot;
39 extern ftnlen f__typesize[];
42 extern int f__lcount, nml_read;
43 extern int t_getc (void);
53 un_getc (int x, FILE * f__cf)
55 return ungetc (x, f__cf);
58 #define un_getc ungetc
59 extern int ungetc (int, FILE *); /* for systems with a buggy stdio.h */
63 hash (hashtab * ht, register char *s)
66 register hashentry *h;
69 for (x = 0; (c = *s++); x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
71 for (h = *(zot = ht->tab + x % ht->htsize); h; h = h->next)
72 if (!strcmp (s0, h->name))
78 mk_hashtab (Namelist * nl)
82 Vardesc *v, **vd, **vde;
85 hashtab **x, **x0, *y;
86 for (x = &nl_cache; (y = *x); x0 = x, x = &y->next)
89 if (n_nlcache >= MAX_NL_CACHE)
91 /* discard least recently used namelist hash table */
93 free ((char *) y->next);
103 for (nht = 1; nht < nv; nht <<= 1);
106 ht = (hashtab *) malloc (sizeof (hashtab) + (nht - 1) * sizeof (hashentry *)
107 + nv * sizeof (hashentry));
110 he = (hashentry *) & ht->tab[nht];
115 memset ((char *) ht->tab, 0, nht * sizeof (hashentry *));
121 if (!hash (ht, v->name))
133 static char Alpha[256], Alphanum[256];
141 for (s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; (c = *s++);)
143 = Alphanum[c] = Alpha[c + 'a' - 'A'] = Alphanum[c + 'a' - 'A'] = c;
144 for (s = "0123456789_"; (c = *s++);)
148 #define GETC(x) (x=(*l_getc)())
149 #define Ungetc(x,y) (*l_ungetc)(x,y)
152 getname (register char *s, int slen)
154 register char *se = s + slen - 1;
158 if (!(*s++ = Alpha[ch & 0xff]))
162 errfl (f__elist->cierr, ch, "namelist read");
164 while ((*s = Alphanum[GETC (ch) & 0xff]))
168 err (f__elist->cierr, EOF, "namelist read");
175 getnum (int *chp, ftnlen * val)
177 register int ch, sign;
180 while (GETC (ch) <= ' ' && ch >= 0);
195 while (GETC (ch) >= '0' && ch <= '9')
196 x = 10 * x + ch - '0';
197 while (ch <= ' ' && ch >= 0)
201 *val = sign ? -x : x;
207 getdimen (int *chp, dimen * d, ftnlen delta, ftnlen extent, ftnlen * x1)
212 if ((k = getnum (chp, x1)))
217 if ((k = getnum (chp, &x2)))
222 if ((k = getnum (chp, &x3)))
229 if (x2 < 0 || x2 >= extent)
241 #ifndef No_Namelist_Questions
243 print_ne (cilist * a)
245 flag intext = f__external;
246 int rpsave = f__recpos;
247 FILE *cfsave = f__cf;
248 unit *usave = f__curunit;
254 f__external = intext;
263 static char where0[] = "namelist read start ";
268 int ch, got1, k, n, nd, quote, readall;
270 static char where[] = "namelist read";
274 dimen *dn, *dn0, *dn1;
275 ftnlen *dims, *dims1;
276 ftnlen b, b0, b1, ex, no, nomax, size, span;
280 dimen dimens[MAXDIM], substr;
281 int dollarsign_delimited;
289 dollarsign_delimited = 0;
295 err (a->ciend, (EOF), where0);
297 dollarsign_delimited = 1;
300 #ifndef No_Namelist_Questions
306 if (ch <= ' ' && ch >= 0)
308 #ifndef No_Namelist_Comments
309 while (GETC (ch) != '\n')
313 errfl (a->cierr, 115, where0);
317 if ((ch = getname (buf, sizeof (buf))))
319 nl = (Namelist *) a->cifmt;
320 if (strcmp (buf, nl->name))
321 #ifdef No_Bad_Namelist_Skip
322 errfl (a->cierr, 118, where0);
326 "Skipping namelist \"%s\": seeking namelist \"%s\".\n",
333 err (a->ciend, EOF, where0);
335 if (dollarsign_delimited)
348 while (GETC (ch) != quote)
350 err (a->ciend, EOF, where0);
351 if (GETC (ch) == quote)
359 ht = mk_hashtab (nl);
361 errfl (f__elist->cierr, 113, where0);
370 err (a->ciend, EOF, where0);
376 if ((ch <= ' ' && ch >= 0) || ch == ',')
379 if ((ch = getname (buf, sizeof (buf))))
386 errfl (a->cierr, 119, where);
387 while (GETC (ch) <= ' ' && ch >= 0);
396 size = f__typesize[type];
399 if (ch == '(' /*) */ )
402 if (!(dims = v->dims))
405 errfl (a->cierr, 122, where);
406 if ((k = getdimen (&ch, dn, (ftnlen) size, (ftnlen) size, &b)))
407 errfl (a->cierr, k, where);
409 errfl (a->cierr, 115, where);
411 if (--b < 0 || b + b1 > size)
415 while (GETC (ch) <= ' ' && ch >= 0);
419 nomax = span = dims[1];
420 ivae = iva + size * nomax;
422 if ((k = getdimen (&ch, dn, size, nomax, &b)))
423 errfl (a->cierr, k, where);
428 for (n = 1; n++ < nd; dims++)
431 errfl (a->cierr, 115, where);
434 if ((k = getdimen (&ch, dn1, dn->delta ** dims, span, &b1)))
435 errfl (a->cierr, k, where);
442 errfl (a->cierr, 115, where);
443 readall = 1 - colonseen;
445 if (b < 0 || b >= nomax)
446 errfl (a->cierr, 125, where);
449 while (GETC (ch) <= ' ' && ch >= 0);
452 if (type == TYCHAR && ch == '(' /*) */ )
454 if ((k = getdimen (&ch, &substr, size, size, &b)))
455 errfl (a->cierr, k, where);
457 errfl (a->cierr, 115, where);
459 if (--b < 0 || b + b1 > size)
464 while (GETC (ch) <= ' ' && ch >= 0);
470 for (; dn0 < dn; dn0++)
472 if (dn0->extent != *dims++ || dn0->stride != 1)
476 if (dn0 == dimens && dimens[0].stride == 1)
478 no1 = dimens[0].extent;
483 for (dn1 = dn0; dn1 <= dn; dn1++)
484 ex += (dn1->extent - 1) * (dn1->delta *= dn1->stride);
485 for (dn1 = dn; dn1 > dn0; dn1--)
487 ex -= (dn1->extent - 1) * dn1->delta;
491 else if ((dims = v->dims))
494 ivae = iva + no * size;
500 errfl (a->cierr, 115, where);
506 if (iva >= ivae || iva < 0)
511 else if (iva + no1 * size > ivae)
512 no1 = (ivae - iva) / size;
514 if ((k = l_read (&no1, vaddr + iva, size, type)))
523 ftnint no2 = (ivae - iva) / size;
526 if ((k = l_read (&no2, vaddr + iva, size, type)))
528 iva += no2 * dn0->delta;
551 if (ch == '/' || ch == '$' || ch == '&')
558 while (ch <= ' ' && ch >= 0)
561 if (!Alpha[ch & 0xff] && ch >= 0)
562 errfl (a->cierr, 125, where);
566 if (readall && !Alpha[ch & 0xff])
568 if ((no -= no1) <= 0)
570 for (dn1 = dn0; dn1 <= dn; dn1++)
572 if (++dn1->curval < dn1->extent)
594 if (f__curunit->uwrt && f__nowreading (f__curunit))
595 err (a->cierr, errno, where0);