6 #define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */
7 #define MAXDIM 20 /* maximum number of subscripts */
15 typedef struct dimen dimen
;
18 struct hashentry
*next
;
22 typedef struct hashentry hashentry
;
30 typedef struct hashtab hashtab
;
32 static hashtab
*nl_cache
;
34 static hashentry
**zot
;
36 extern ftnlen f__typesize
[];
39 extern int f__lcount
, nml_read
;
43 extern char *malloc(), *memset();
47 un_getc(x
,f__cf
) int x
; FILE *f__cf
;
48 { return ungetc(x
,f__cf
); }
50 #define un_getc ungetc
63 un_getc(int x
, FILE *f__cf
)
64 { return ungetc(x
,f__cf
); }
66 #define un_getc ungetc
67 extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */
73 hash(ht
, s
) hashtab
*ht
; register char *s
;
75 hash(hashtab
*ht
, register char *s
)
79 register hashentry
*h
;
82 for(x
= 0; c
= *s
++; x
= x
& 0x4000 ? ((x
<< 1) & 0x7fff) + 1 : x
<< 1)
84 for(h
= *(zot
= ht
->tab
+ x
% ht
->htsize
); h
; h
= h
->next
)
85 if (!strcmp(s0
, h
->name
))
92 mk_hashtab(nl
) Namelist
*nl
;
94 mk_hashtab(Namelist
*nl
)
99 Vardesc
*v
, **vd
, **vde
;
102 hashtab
**x
, **x0
, *y
;
103 for(x
= &nl_cache
; y
= *x
; x0
= x
, x
= &y
->next
)
106 if (n_nlcache
>= MAX_NL_CACHE
) {
107 /* discard least recently used namelist hash table */
109 free((char *)y
->next
);
118 for(nht
= 1; nht
< nv
; nht
<<= 1);
121 ht
= (hashtab
*)malloc(sizeof(hashtab
) + (nht
-1)*sizeof(hashentry
*)
122 + nv
*sizeof(hashentry
));
125 he
= (hashentry
*)&ht
->tab
[nht
];
130 memset((char *)ht
->tab
, 0, nht
*sizeof(hashentry
*));
135 if (!hash(ht
, v
->name
)) {
146 static char Alpha
[256], Alphanum
[256];
153 for(s
= "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c
= *s
++; )
156 = Alpha
[c
+ 'a' - 'A']
157 = Alphanum
[c
+ 'a' - 'A']
159 for(s
= "0123456789_"; c
= *s
++; )
163 #define GETC(x) (x=(*l_getc)())
164 #define Ungetc(x,y) (*l_ungetc)(x,y)
168 getname(s
, slen
) register char *s
; int slen
;
170 getname(register char *s
, int slen
)
173 register char *se
= s
+ slen
- 1;
177 if (!(*s
++ = Alpha
[ch
& 0xff])) {
180 errfl(f__elist
->cierr
, ch
, "namelist read");
182 while(*s
= Alphanum
[GETC(ch
) & 0xff])
186 err(f__elist
->cierr
, EOF
, "namelist read");
194 getnum(chp
, val
) int *chp
; ftnlen
*val
;
196 getnum(int *chp
, ftnlen
*val
)
199 register int ch
, sign
;
202 while(GETC(ch
) <= ' ' && ch
>= 0);
215 while(GETC(ch
) >= '0' && ch
<= '9')
217 while(ch
<= ' ' && ch
>= 0)
221 *val
= sign
? -x
: x
;
228 getdimen(chp
, d
, delta
, extent
, x1
)
229 int *chp
; dimen
*d
; ftnlen delta
, extent
, *x1
;
231 getdimen(int *chp
, dimen
*d
, ftnlen delta
, ftnlen extent
, ftnlen
*x1
)
237 if (k
= getnum(chp
, x1
))
241 if (k
= getnum(chp
, &x2
))
245 if (k
= getnum(chp
, &x3
))
252 if (x2
< 0 || x2
>= extent
)
264 #ifndef No_Namelist_Questions
267 print_ne(a
) cilist
*a
;
272 flag intext
= f__external
;
273 int rpsave
= f__recpos
;
274 FILE *cfsave
= f__cf
;
275 unit
*usave
= f__curunit
;
281 f__external
= intext
;
290 static char where0
[] = "namelist read start ";
298 int ch
, got1
, k
, n
, nd
, quote
, readall
;
300 static char where
[] = "namelist read";
304 dimen
*dn
, *dn0
, *dn1
;
305 ftnlen
*dims
, *dims1
;
306 ftnlen b
, b0
, b1
, ex
, no
, nomax
, size
, span
;
310 dimen dimens
[MAXDIM
], substr
;
318 for(;;) switch(GETC(ch
)) {
321 err(a
->ciend
,(EOF
),where0
);
325 #ifndef No_Namelist_Questions
331 if (ch
<= ' ' && ch
>= 0)
333 #ifndef No_Namelist_Comments
334 while(GETC(ch
) != '\n')
338 errfl(a
->cierr
, 115, where0
);
342 if (ch
= getname(buf
,sizeof(buf
)))
344 nl
= (Namelist
*)a
->cifmt
;
345 if (strcmp(buf
, nl
->name
))
346 #ifdef No_Bad_Namelist_Skip
347 errfl(a
->cierr
, 118, where0
);
351 "Skipping namelist \"%s\": seeking namelist \"%s\".\n",
354 for(;;) switch(GETC(ch
)) {
356 err(a
->ciend
, EOF
, where0
);
369 while(GETC(ch
) != quote
)
371 err(a
->ciend
, EOF
, where0
);
372 if (GETC(ch
) == quote
)
382 errfl(f__elist
->cierr
, 113, where0
);
384 for(;;) switch(GETC(ch
)) {
388 err(a
->ciend
, EOF
, where0
);
394 if (ch
<= ' ' && ch
>= 0 || ch
== ',')
397 if (ch
= getname(buf
,sizeof(buf
)))
404 errfl(a
->cierr
, 119, where
);
405 while(GETC(ch
) <= ' ' && ch
>= 0);
413 size
= f__typesize
[type
];
416 if (ch
== '(' /*)*/ ) {
418 if (!(dims
= v
->dims
)) {
420 errfl(a
->cierr
, 122, where
);
421 if (k
= getdimen(&ch
, dn
, (ftnlen
)size
,
423 errfl(a
->cierr
, k
, where
);
425 errfl(a
->cierr
, 115, where
);
427 if (--b
< 0 || b
+ b1
> size
)
431 while(GETC(ch
) <= ' ' && ch
>= 0);
435 nomax
= span
= dims
[1];
436 ivae
= iva
+ size
*nomax
;
438 if (k
= getdimen(&ch
, dn
, size
, nomax
, &b
))
439 errfl(a
->cierr
, k
, where
);
444 for(n
= 1; n
++ < nd
; dims
++) {
446 errfl(a
->cierr
, 115, where
);
449 if (k
= getdimen(&ch
, dn1
, dn
->delta
**dims
,
451 errfl(a
->cierr
, k
, where
);
458 errfl(a
->cierr
, 115, where
);
459 readall
= 1 - colonseen
;
461 if (b
< 0 || b
>= nomax
)
462 errfl(a
->cierr
, 125, where
);
465 while(GETC(ch
) <= ' ' && ch
>= 0);
468 if (type
== TYCHAR
&& ch
== '(' /*)*/) {
469 if (k
= getdimen(&ch
, &substr
, size
, size
, &b
))
470 errfl(a
->cierr
, k
, where
);
472 errfl(a
->cierr
, 115, where
);
474 if (--b
< 0 || b
+ b1
> size
)
479 while(GETC(ch
) <= ' ' && ch
>= 0);
485 for(; dn0
< dn
; dn0
++) {
486 if (dn0
->extent
!= *dims
++ || dn0
->stride
!= 1)
490 if (dn0
== dimens
&& dimens
[0].stride
== 1) {
491 no1
= dimens
[0].extent
;
496 for(dn1
= dn0
; dn1
<= dn
; dn1
++)
497 ex
+= (dn1
->extent
-1)
498 * (dn1
->delta
*= dn1
->stride
);
499 for(dn1
= dn
; dn1
> dn0
; dn1
--) {
500 ex
-= (dn1
->extent
- 1) * dn1
->delta
;
504 else if (dims
= v
->dims
) {
506 ivae
= iva
+ no
*size
;
512 errfl(a
->cierr
, 115, where
);
517 if (iva
>= ivae
|| iva
< 0) {
521 else if (iva
+ no1
*size
> ivae
)
522 no1
= (ivae
- iva
)/size
;
524 if (k
= l_read(&no1
, vaddr
+ iva
, size
, type
))
531 no1
= (ivae
- iva
)/size
;
534 if (k
= l_read(&no1
, vaddr
+ iva
,
537 iva
+= no1
* dn0
->delta
;
555 if (ch
== '/' || ch
== '$' || ch
== '&') {
560 while(ch
<= ' ' && ch
>= 0)
563 if (!Alpha
[ch
& 0xff] && ch
>= 0)
564 errfl(a
->cierr
, 125, where
);
568 if (readall
&& !Alpha
[ch
& 0xff])
570 if ((no
-= no1
) <= 0)
572 for(dn1
= dn0
; dn1
<= dn
; dn1
++) {
573 if (++dn1
->curval
< dn1
->extent
) {
598 if(f__curunit
->uwrt
&& f__nowreading(f__curunit
))
599 err(a
->cierr
,errno
,where0
);