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 iva
+= no1
* dn0
->delta
;
534 if (k
= l_read(&no1
, vaddr
+ iva
,
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
);