#define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */
#define MAXDIM 20 /* maximum number of subscripts */
typedef struct dimen dimen
;
typedef struct hashentry hashentry
;
typedef struct hashtab hashtab
;
static hashtab
*nl_cache
;
extern ftnlen f__typesize
[];
extern int f__lcount
, nml_read
;
extern char *malloc(), *memset();
un_getc(x
,f__cf
) int x
; FILE *f__cf
;
{ return ungetc(x
,f__cf
); }
un_getc(int x
, FILE *f__cf
)
{ return ungetc(x
,f__cf
); }
hash(ht
, s
) hashtab
*ht
; register char *s
;
hash(hashtab
*ht
, register char *s
)
for(x
= 0; c
= *s
++; x
= x
& 0x4000 ? ((x
<< 1) & 0x7fff) + 1 : x
<< 1)
for(h
= *(zot
= ht
->tab
+ x
% ht
->htsize
); h
; h
= h
->next
)
if (!strcmp(s0
, h
->name
))
mk_hashtab(nl
) Namelist
*nl
;
for(x
= &nl_cache
; y
= *x
; x0
= x
, x
= &y
->next
)
if (n_nlcache
>= MAX_NL_CACHE
) {
/* discard least recently used namelist hash table */
for(nht
= 1; nht
< nv
; nht
<<= 1);
ht
= (hashtab
*)malloc(sizeof(hashtab
) + (nht
-1)*sizeof(hashentry
*)
he
= (hashentry
*)&ht
->tab
[nht
];
memset((char *)ht
->tab
, 0, nht
*sizeof(hashentry
*));
if (!hash(ht
, v
->name
)) {
static char Alpha
[256], Alphanum
[256];
for(s
= "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c
= *s
++; )
= Alphanum
[c
+ 'a' - 'A']
for(s
= "0123456789_"; c
= *s
++; )
#define GETC(x) (x=(*l_getc)())
#define Ungetc(x,y) (*l_ungetc)(x,y)
getname(s
, slen
) register char *s
; int slen
;
getname(register char *s
, int slen
)
register char *se
= s
+ slen
- 1;
if (!(*s
++ = Alpha
[ch
& 0xff])) {
errfl(f__elist
->cierr
, ch
, "namelist read");
while(*s
= Alphanum
[GETC(ch
) & 0xff])
err(f__elist
->cierr
, EOF
, "namelist read");
getnum(chp
, val
) int *chp
; ftnlen
*val
;
getnum(int *chp
, ftnlen
*val
)
while(GETC(ch
) <= ' ' && ch
>= 0);
while(GETC(ch
) >= '0' && ch
<= '9')
while(ch
<= ' ' && ch
>= 0)
getdimen(chp
, d
, delta
, extent
, x1
)
int *chp
; dimen
*d
; ftnlen delta
, extent
, *x1
;
getdimen(int *chp
, dimen
*d
, ftnlen delta
, ftnlen extent
, ftnlen
*x1
)
if (k
= getnum(chp
, &x2
))
if (k
= getnum(chp
, &x3
))
if (x2
< 0 || x2
>= extent
)
#ifndef No_Namelist_Questions
flag intext
= f__external
;
unit
*usave
= f__curunit
;
static char where0
[] = "namelist read start ";
int ch
, got1
, k
, n
, nd
, quote
;
static char where
[] = "namelist read";
ftnlen b
, b0
, b1
, ex
, no
, no1
, nomax
, size
, span
;
dimen dimens
[MAXDIM
], substr
;
for(;;) switch(GETC(ch
)) {
err(a
->ciend
,(EOF
),where0
);
#ifndef No_Namelist_Questions
if (ch
<= ' ' && ch
>= 0)
errfl(a
->cierr
, 115, where0
);
if (ch
= getname(buf
,sizeof(buf
)))
nl
= (Namelist
*)a
->cifmt
;
if (strcmp(buf
, nl
->name
))
#ifdef No_Bad_Namelist_Skip
errfl(a
->cierr
, 118, where0
);
"Skipping namelist \"%s\": seeking namelist \"%s\".\n",
for(;;) switch(GETC(ch
)) {
err(a
->ciend
, EOF
, where0
);
err(a
->ciend
, EOF
, where0
);
errfl(f__elist
->cierr
, 113, where0
);
for(;;) switch(GETC(ch
)) {
err(a
->ciend
, EOF
, where0
);
if (ch
<= ' ' && ch
>= 0 || ch
== ',')
if (ch
= getname(buf
,sizeof(buf
)))
errfl(a
->cierr
, 119, where
);
while(GETC(ch
) <= ' ' && ch
>= 0);
size
= f__typesize
[type
];
errfl(a
->cierr
, 122, where
);
if (k
= getdimen(&ch
, dn
, (ftnlen
)size
,
errfl(a
->cierr
, k
, where
);
errfl(a
->cierr
, 115, where
);
if (--b
< 0 || b
+ b1
> size
)
while(GETC(ch
) <= ' ' && ch
>= 0);
if (k
= getdimen(&ch
, dn
, size
, nomax
, &b
))
errfl(a
->cierr
, k
, where
);
for(n
= 1; n
++ < nd
; dims
++) {
errfl(a
->cierr
, 115, where
);
if (k
= getdimen(&ch
, dn1
, dn
->delta
**dims
,
errfl(a
->cierr
, k
, where
);
errfl(a
->cierr
, 115, where
);
errfl(a
->cierr
, 125, where
);
while(GETC(ch
) <= ' ' && ch
>= 0);
if (type
== TYCHAR
&& ch
== '(' /*)*/) {
if (k
= getdimen(&ch
, &substr
, size
, size
, &b
))
errfl(a
->cierr
, k
, where
);
errfl(a
->cierr
, 115, where
);
if (--b
< 0 || b
+ b1
> size
)
while(GETC(ch
) <= ' ' && ch
>= 0);
if (dn0
->extent
!= *dims
++ || dn0
->stride
!= 1)
if (dn0
== dimens
&& dimens
[0].stride
== 1) {
for(dn1
= dn0
; dn1
<= dn
; dn1
++)
* (dn1
->delta
*= dn1
->stride
);
for(dn1
= dn
; dn1
> dn0
; dn1
--) {
ex
-= (dn1
->extent
- 1) * dn1
->delta
;
else if (dims
= v
->dims
) {
errfl(a
->cierr
, 115, where
);
if (iva
>= ivae
|| iva
< 0) {
else if (iva
+ no1
*size
> ivae
)
if (k
= l_read(&no1
, vaddr
+ iva
, size
, type
))
if (GETC(ch
) == '/' || ch
== '$' || ch
== '&') {
while(ch
<= ' ' && ch
>= 0)
if (!Alpha
[ch
& 0xff] && ch
>= 0)
errfl(a
->cierr
, 125, where
);
for(dn1
= dn0
; dn1
<= dn
; dn1
++) {
if (++dn1
->curval
< dn1
->extent
) {
if(f__curunit
->uwrt
&& f__nowreading(f__curunit
))
err(a
->cierr
,errno
,where0
);