5 #define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */
6 #define MAXDIM 20 /* maximum number of subscripts */
14 typedef struct dimen dimen;
17 struct hashentry *next;
21 typedef struct hashentry hashentry;
29 typedef struct hashtab hashtab;
31 static hashtab *nl_cache;
33 static hashentry **zot;
35 extern ftnlen f__typesize[];
38 extern int f__lcount, nml_read;
42 extern char *malloc(), *memset();
46 un_getc(x,f__cf) int x; FILE *f__cf;
47 { return ungetc(x,f__cf); }
49 #define un_getc ungetc
62 un_getc(int x, FILE *f__cf)
63 { return ungetc(x,f__cf); }
65 #define un_getc ungetc
66 extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */
72 hash(ht, s) hashtab *ht; register char *s;
74 hash(hashtab *ht, register char *s)
78 register hashentry *h;
81 for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
83 for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next)
84 if (!strcmp(s0, h->name))
91 mk_hashtab(nl) Namelist *nl;
93 mk_hashtab(Namelist *nl)
98 Vardesc *v, **vd, **vde;
101 hashtab **x, **x0, *y;
102 for(x = &nl_cache; y = *x; x0 = x, x = &y->next)
105 if (n_nlcache >= MAX_NL_CACHE) {
106 /* discard least recently used namelist hash table */
108 free((char *)y->next);
117 for(nht = 1; nht < nv; nht <<= 1);
120 ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *)
121 + nv*sizeof(hashentry));
124 he = (hashentry *)&ht->tab[nht];
129 memset((char *)ht->tab, 0, nht*sizeof(hashentry *));
134 if (!hash(ht, v->name)) {
145 static char Alpha[256], Alphanum[256];
152 for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; )
155 = Alpha[c + 'a' - 'A']
156 = Alphanum[c + 'a' - 'A']
158 for(s = "0123456789_"; c = *s++; )
162 #define GETC(x) (x=(*l_getc)())
163 #define Ungetc(x,y) (*l_ungetc)(x,y)
167 getname(s, slen) register char *s; int slen;
169 getname(register char *s, int slen)
172 register char *se = s + slen - 1;
176 if (!(*s++ = Alpha[ch & 0xff])) {
179 errfl(f__elist->cierr, ch, "namelist read");
181 while(*s = Alphanum[GETC(ch) & 0xff])
185 err(f__elist->cierr, EOF, "namelist read");
193 getnum(chp, val) int *chp; ftnlen *val;
195 getnum(int *chp, ftnlen *val)
198 register int ch, sign;
201 while(GETC(ch) <= ' ' && ch >= 0);
214 while(GETC(ch) >= '0' && ch <= '9')
216 while(ch <= ' ' && ch >= 0)
220 *val = sign ? -x : x;
227 getdimen(chp, d, delta, extent, x1)
228 int *chp; dimen *d; ftnlen delta, extent, *x1;
230 getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1)
236 if (k = getnum(chp, x1))
240 if (k = getnum(chp, &x2))
244 if (k = getnum(chp, &x3))
251 if (x2 < 0 || x2 >= extent)
263 #ifndef No_Namelist_Questions
266 print_ne(a) cilist *a;
271 flag intext = f__external;
272 int rpsave = f__recpos;
273 FILE *cfsave = f__cf;
274 unit *usave = f__curunit;
280 f__external = intext;
289 static char where0[] = "namelist read start ";
297 int ch, got1, k, n, nd, quote, readall;
299 static char where[] = "namelist read";
303 dimen *dn, *dn0, *dn1;
304 ftnlen *dims, *dims1;
305 ftnlen b, b0, b1, ex, no, no1, nomax, size, span;
309 dimen dimens[MAXDIM], substr;
317 for(;;) switch(GETC(ch)) {
320 err(a->ciend,(EOF),where0);
324 #ifndef No_Namelist_Questions
330 if (ch <= ' ' && ch >= 0)
332 #ifndef No_Namelist_Comments
333 while(GETC(ch) != '\n')
337 errfl(a->cierr, 115, where0);
341 if (ch = getname(buf,(int) sizeof(buf)))
343 nl = (Namelist *)a->cifmt;
344 if (strcmp(buf, nl->name))
345 #ifdef No_Bad_Namelist_Skip
346 errfl(a->cierr, 118, where0);
350 "Skipping namelist \"%s\": seeking namelist \"%s\".\n",
353 for(;;) switch(GETC(ch)) {
355 err(a->ciend, EOF, where0);
368 while(GETC(ch) != quote)
370 err(a->ciend, EOF, where0);
371 if (GETC(ch) == quote)
381 errfl(f__elist->cierr, 113, where0);
383 for(;;) switch(GETC(ch)) {
387 err(a->ciend, EOF, where0);
393 if (ch <= ' ' && ch >= 0 || ch == ',')
396 if (ch = getname(buf,(int) sizeof(buf)))
403 errfl(a->cierr, 119, where);
404 while(GETC(ch) <= ' ' && ch >= 0);
412 size = f__typesize[type];
415 if (ch == '(' /*)*/ ) {
417 if (!(dims = v->dims)) {
419 errfl(a->cierr, 122, where);
420 if (k = getdimen(&ch, dn, (ftnlen)size,
422 errfl(a->cierr, k, where);
424 errfl(a->cierr, 115, where);
426 if (--b < 0 || b + b1 > size)
430 while(GETC(ch) <= ' ' && ch >= 0);
434 nomax = span = dims[1];
435 ivae = iva + size*nomax;
437 if (k = getdimen(&ch, dn, size, nomax, &b))
438 errfl(a->cierr, k, where);
443 for(n = 1; n++ < nd; dims++) {
445 errfl(a->cierr, 115, where);
448 if (k = getdimen(&ch, dn1, dn->delta**dims,
450 errfl(a->cierr, k, where);
457 errfl(a->cierr, 115, where);
458 readall = 1 - colonseen;
460 if (b < 0 || b >= nomax)
461 errfl(a->cierr, 125, where);
464 while(GETC(ch) <= ' ' && ch >= 0);
467 if (type == TYCHAR && ch == '(' /*)*/) {
468 if (k = getdimen(&ch, &substr, size, size, &b))
469 errfl(a->cierr, k, where);
471 errfl(a->cierr, 115, where);
473 if (--b < 0 || b + b1 > size)
478 while(GETC(ch) <= ' ' && ch >= 0);
484 for(; dn0 < dn; dn0++) {
485 if (dn0->extent != *dims++ || dn0->stride != 1)
489 if (dn0 == dimens && dimens[0].stride == 1) {
490 no1 = dimens[0].extent;
495 for(dn1 = dn0; dn1 <= dn; dn1++)
496 ex += (dn1->extent-1)
497 * (dn1->delta *= dn1->stride);
498 for(dn1 = dn; dn1 > dn0; dn1--) {
499 ex -= (dn1->extent - 1) * dn1->delta;
503 else if (dims = v->dims) {
505 ivae = iva + no*size;
511 errfl(a->cierr, 115, where);
516 if (iva >= ivae || iva < 0) {
520 else if (iva + no1*size > ivae)
521 no1 = (ivae - iva)/size;
523 if (k = l_read(&no1, vaddr + iva, size, type))
530 no1 = (ivae - iva)/size;
533 if (k = l_read(&no1, vaddr + iva,
536 iva += no1 * dn0->delta;
554 if (ch == '/' || ch == '$' || ch == '&') {
559 while(ch <= ' ' && ch >= 0)
562 if (!Alpha[ch & 0xff] && ch >= 0)
563 errfl(a->cierr, 125, where);
567 if (readall && !Alpha[ch & 0xff])
569 if ((no -= no1) <= 0)
571 for(dn1 = dn0; dn1 <= dn; dn1++) {
572 if (++dn1->curval < dn1->extent) {
597 if(f__curunit->uwrt && f__nowreading(f__curunit))
598 err(a->cierr,errno,where0);