1#include "f2c.h"
2#include "fio.h"
3#include "lio.h"
4
5#define MAX_NL_CACHE 3	/* maximum number of namelist hash tables to cache */
6#define MAXDIM 20	/* maximum number of subscripts */
7
8 struct dimen {
9	ftnlen extent;
10	ftnlen curval;
11	ftnlen delta;
12	ftnlen stride;
13	};
14 typedef struct dimen dimen;
15
16 struct hashentry {
17	struct hashentry *next;
18	char *name;
19	Vardesc *vd;
20	};
21 typedef struct hashentry hashentry;
22
23 struct hashtab {
24	struct hashtab *next;
25	Namelist *nl;
26	int htsize;
27	hashentry *tab[1];
28	};
29 typedef struct hashtab hashtab;
30
31 static hashtab *nl_cache;
32 static int n_nlcache;
33 static hashentry **zot;
34 static int colonseen;
35 extern ftnlen f__typesize[];
36
37 extern flag f__lquit;
38 extern int f__lcount, nml_read;
39 extern t_getc(Void);
40
41#ifdef KR_headers
42 extern char *malloc(), *memset();
43
44#ifdef ungetc
45 static int
46un_getc(x,f__cf) int x; FILE *f__cf;
47{ return ungetc(x,f__cf); }
48#else
49#define un_getc ungetc
50 extern int ungetc();
51#endif
52
53#else
54#undef abs
55#undef min
56#undef max
57#include <stdlib.h>
58#include <string.h>
59
60#ifdef ungetc
61 static int
62un_getc(int x, FILE *f__cf)
63{ return ungetc(x,f__cf); }
64#else
65#define un_getc ungetc
66extern int ungetc(int, FILE*);	/* for systems with a buggy stdio.h */
67#endif
68#endif
69
70 static Vardesc *
71#ifdef KR_headers
72hash(ht, s) hashtab *ht; register char *s;
73#else
74hash(hashtab *ht, register char *s)
75#endif
76{
77	register int c, x;
78	register hashentry *h;
79	char *s0 = s;
80
81	for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
82		x += c;
83	for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next)
84		if (!strcmp(s0, h->name))
85			return h->vd;
86	return 0;
87	}
88
89 hashtab *
90#ifdef KR_headers
91mk_hashtab(nl) Namelist *nl;
92#else
93mk_hashtab(Namelist *nl)
94#endif
95{
96	int nht, nv;
97	hashtab *ht;
98	Vardesc *v, **vd, **vde;
99	hashentry *he;
100
101	hashtab **x, **x0, *y;
102	for(x = &nl_cache; y = *x; x0 = x, x = &y->next)
103		if (nl == y->nl)
104			return y;
105	if (n_nlcache >= MAX_NL_CACHE) {
106		/* discard least recently used namelist hash table */
107		y = *x0;
108		free((char *)y->next);
109		y->next = 0;
110		}
111	else
112		n_nlcache++;
113	nv = nl->nvars;
114	if (nv >= 0x4000)
115		nht = 0x7fff;
116	else {
117		for(nht = 1; nht < nv; nht <<= 1);
118		nht += nht - 1;
119		}
120	ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *)
121				+ nv*sizeof(hashentry));
122	if (!ht)
123		return 0;
124	he = (hashentry *)&ht->tab[nht];
125	ht->nl = nl;
126	ht->htsize = nht;
127	ht->next = nl_cache;
128	nl_cache = ht;
129	memset((char *)ht->tab, 0, nht*sizeof(hashentry *));
130	vd = nl->vars;
131	vde = vd + nv;
132	while(vd < vde) {
133		v = *vd++;
134		if (!hash(ht, v->name)) {
135			he->next = *zot;
136			*zot = he;
137			he->name = v->name;
138			he->vd = v;
139			he++;
140			}
141		}
142	return ht;
143	}
144
145static char Alpha[256], Alphanum[256];
146
147 static VOID
148nl_init(Void) {
149	register char *s;
150	register int c;
151
152	for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; )
153		Alpha[c]
154		= Alphanum[c]
155		= Alpha[c + 'a' - 'A']
156		= Alphanum[c + 'a' - 'A']
157		= c;
158	for(s = "0123456789_"; c = *s++; )
159		Alphanum[c] = c;
160	}
161
162#define GETC(x) (x=(*l_getc)())
163#define Ungetc(x,y) (*l_ungetc)(x,y)
164
165 static int
166#ifdef KR_headers
167getname(s, slen) register char *s; int slen;
168#else
169getname(register char *s, int slen)
170#endif
171{
172	register char *se = s + slen - 1;
173	register int ch;
174
175	GETC(ch);
176	if (!(*s++ = Alpha[ch & 0xff])) {
177		if (ch != EOF)
178			ch = 115;
179		errfl(f__elist->cierr, ch, "namelist read");
180		}
181	while(*s = Alphanum[GETC(ch) & 0xff])
182		if (s < se)
183			s++;
184	if (ch == EOF)
185		err(f__elist->cierr, EOF, "namelist read");
186	if (ch > ' ')
187		Ungetc(ch,f__cf);
188	return *s = 0;
189	}
190
191 static int
192#ifdef KR_headers
193getnum(chp, val) int *chp; ftnlen *val;
194#else
195getnum(int *chp, ftnlen *val)
196#endif
197{
198	register int ch, sign;
199	register ftnlen x;
200
201	while(GETC(ch) <= ' ' && ch >= 0);
202	if (ch == '-') {
203		sign = 1;
204		GETC(ch);
205		}
206	else {
207		sign = 0;
208		if (ch == '+')
209			GETC(ch);
210		}
211	x = ch - '0';
212	if (x < 0 || x > 9)
213		return 115;
214	while(GETC(ch) >= '0' && ch <= '9')
215		x = 10*x + ch - '0';
216	while(ch <= ' ' && ch >= 0)
217		GETC(ch);
218	if (ch == EOF)
219		return EOF;
220	*val = sign ? -x : x;
221	*chp = ch;
222	return 0;
223	}
224
225 static int
226#ifdef KR_headers
227getdimen(chp, d, delta, extent, x1)
228 int *chp; dimen *d; ftnlen delta, extent, *x1;
229#else
230getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1)
231#endif
232{
233	register int k;
234	ftnlen x2, x3;
235
236	if (k = getnum(chp, x1))
237		return k;
238	x3 = 1;
239	if (*chp == ':') {
240		if (k = getnum(chp, &x2))
241			return k;
242		x2 -= *x1;
243		if (*chp == ':') {
244			if (k = getnum(chp, &x3))
245				return k;
246			if (!x3)
247				return 123;
248			x2 /= x3;
249			colonseen = 1;
250			}
251		if (x2 < 0 || x2 >= extent)
252			return 123;
253		d->extent = x2 + 1;
254		}
255	else
256		d->extent = 1;
257	d->curval = 0;
258	d->delta = delta;
259	d->stride = x3;
260	return 0;
261	}
262
263#ifndef No_Namelist_Questions
264 static Void
265#ifdef KR_headers
266print_ne(a) cilist *a;
267#else
268print_ne(cilist *a)
269#endif
270{
271	flag intext = f__external;
272	int rpsave = f__recpos;
273	FILE *cfsave = f__cf;
274	unit *usave = f__curunit;
275	cilist t;
276	t = *a;
277	t.ciunit = 6;
278	s_wsne(&t);
279	fflush(f__cf);
280	f__external = intext;
281	f__reading = 1;
282	f__recpos = rpsave;
283	f__cf = cfsave;
284	f__curunit = usave;
285	f__elist = a;
286	}
287#endif
288
289 static char where0[] = "namelist read start ";
290
291#ifdef KR_headers
292x_rsne(a) cilist *a;
293#else
294x_rsne(cilist *a)
295#endif
296{
297	int ch, got1, k, n, nd, quote, readall;
298	Namelist *nl;
299	static char where[] = "namelist read";
300	char buf[64];
301	hashtab *ht;
302	Vardesc *v;
303	dimen *dn, *dn0, *dn1;
304	ftnlen *dims, *dims1;
305	ftnlen b, b0, b1, ex, no, no1, nomax, size, span;
306	ftnint type;
307	char *vaddr;
308	long iva, ivae;
309	dimen dimens[MAXDIM], substr;
310
311	if (!Alpha['a'])
312		nl_init();
313	f__reading=1;
314	f__formatted=1;
315	got1 = 0;
316 top:
317	for(;;) switch(GETC(ch)) {
318		case EOF:
319 eof:
320			err(a->ciend,(EOF),where0);
321		case '&':
322		case '$':
323			goto have_amp;
324#ifndef No_Namelist_Questions
325		case '?':
326			print_ne(a);
327			continue;
328#endif
329		default:
330			if (ch <= ' ' && ch >= 0)
331				continue;
332#ifndef No_Namelist_Comments
333			while(GETC(ch) != '\n')
334				if (ch == EOF)
335					goto eof;
336#else
337			errfl(a->cierr, 115, where0);
338#endif
339		}
340 have_amp:
341	if (ch = getname(buf,(int) sizeof(buf)))
342		return ch;
343	nl = (Namelist *)a->cifmt;
344	if (strcmp(buf, nl->name))
345#ifdef No_Bad_Namelist_Skip
346		errfl(a->cierr, 118, where0);
347#else
348	{
349		fprintf(stderr,
350			"Skipping namelist \"%s\": seeking namelist \"%s\".\n",
351			buf, nl->name);
352		fflush(stderr);
353		for(;;) switch(GETC(ch)) {
354			case EOF:
355				err(a->ciend, EOF, where0);
356			case '/':
357			case '&':
358			case '$':
359				if (f__external)
360					e_rsle();
361				else
362					z_rnew();
363				goto top;
364			case '"':
365			case '\'':
366				quote = ch;
367 more_quoted:
368				while(GETC(ch) != quote)
369					if (ch == EOF)
370						err(a->ciend, EOF, where0);
371				if (GETC(ch) == quote)
372					goto more_quoted;
373				Ungetc(ch,f__cf);
374			default:
375				continue;
376			}
377		}
378#endif
379	ht = mk_hashtab(nl);
380	if (!ht)
381		errfl(f__elist->cierr, 113, where0);
382	for(;;) {
383		for(;;) switch(GETC(ch)) {
384			case EOF:
385				if (got1)
386					return 0;
387				err(a->ciend, EOF, where0);
388			case '/':
389			case '$':
390			case '&':
391				return 0;
392			default:
393				if (ch <= ' ' && ch >= 0 || ch == ',')
394					continue;
395				Ungetc(ch,f__cf);
396				if (ch = getname(buf,(int) sizeof(buf)))
397					return ch;
398				goto havename;
399			}
400 havename:
401		v = hash(ht,buf);
402		if (!v)
403			errfl(a->cierr, 119, where);
404		while(GETC(ch) <= ' ' && ch >= 0);
405		vaddr = v->addr;
406		type = v->type;
407		if (type < 0) {
408			size = -type;
409			type = TYCHAR;
410			}
411		else
412			size = f__typesize[type];
413		ivae = size;
414		iva = readall = 0;
415		if (ch == '(' /*)*/ ) {
416			dn = dimens;
417			if (!(dims = v->dims)) {
418				if (type != TYCHAR)
419					errfl(a->cierr, 122, where);
420				if (k = getdimen(&ch, dn, (ftnlen)size,
421						(ftnlen)size, &b))
422					errfl(a->cierr, k, where);
423				if (ch != ')')
424					errfl(a->cierr, 115, where);
425				b1 = dn->extent;
426				if (--b < 0 || b + b1 > size)
427					return 124;
428				iva += b;
429				size = b1;
430				while(GETC(ch) <= ' ' && ch >= 0);
431				goto scalar;
432				}
433			nd = (int)dims[0];
434			nomax = span = dims[1];
435			ivae = iva + size*nomax;
436			colonseen = 0;
437			if (k = getdimen(&ch, dn, size, nomax, &b))
438				errfl(a->cierr, k, where);
439			no = dn->extent;
440			b0 = dims[2];
441			dims1 = dims += 3;
442			ex = 1;
443			for(n = 1; n++ < nd; dims++) {
444				if (ch != ',')
445					errfl(a->cierr, 115, where);
446				dn1 = dn + 1;
447				span /= *dims;
448				if (k = getdimen(&ch, dn1, dn->delta**dims,
449						span, &b1))
450					errfl(a->cierr, k, where);
451				ex *= *dims;
452				b += b1*ex;
453				no *= dn1->extent;
454				dn = dn1;
455				}
456			if (ch != ')')
457				errfl(a->cierr, 115, where);
458			readall = 1 - colonseen;
459			b -= b0;
460			if (b < 0 || b >= nomax)
461				errfl(a->cierr, 125, where);
462			iva += size * b;
463			dims = dims1;
464			while(GETC(ch) <= ' ' && ch >= 0);
465			no1 = 1;
466			dn0 = dimens;
467			if (type == TYCHAR && ch == '(' /*)*/) {
468				if (k = getdimen(&ch, &substr, size, size, &b))
469					errfl(a->cierr, k, where);
470				if (ch != ')')
471					errfl(a->cierr, 115, where);
472				b1 = substr.extent;
473				if (--b < 0 || b + b1 > size)
474					return 124;
475				iva += b;
476				b0 = size;
477				size = b1;
478				while(GETC(ch) <= ' ' && ch >= 0);
479				if (b1 < b0)
480					goto delta_adj;
481				}
482			if (readall)
483				goto delta_adj;
484			for(; dn0 < dn; dn0++) {
485				if (dn0->extent != *dims++ || dn0->stride != 1)
486					break;
487				no1 *= dn0->extent;
488				}
489			if (dn0 == dimens && dimens[0].stride == 1) {
490				no1 = dimens[0].extent;
491				dn0++;
492				}
493 delta_adj:
494			ex = 0;
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;
500				dn1->delta -= ex;
501				}
502			}
503		else if (dims = v->dims) {
504			no = no1 = dims[1];
505			ivae = iva + no*size;
506			}
507		else
508 scalar:
509			no = no1 = 1;
510		if (ch != '=')
511			errfl(a->cierr, 115, where);
512		got1 = nml_read = 1;
513		f__lcount = 0;
514	 readloop:
515		for(;;) {
516			if (iva >= ivae || iva < 0) {
517				f__lquit = 1;
518				goto mustend;
519				}
520			else if (iva + no1*size > ivae)
521				no1 = (ivae - iva)/size;
522			f__lquit = 0;
523			if (k = l_read(&no1, vaddr + iva, size, type))
524				return k;
525			if (f__lquit == 1)
526				return 0;
527			if (readall) {
528				iva += dn0->delta;
529				if (f__lcount > 0) {
530					no1 = (ivae - iva)/size;
531					if (no1 > f__lcount)
532						no1 = f__lcount;
533					if (k = l_read(&no1, vaddr + iva,
534							size, type))
535						return k;
536					iva += no1 * dn0->delta;
537					}
538				}
539 mustend:
540			GETC(ch);
541			if (readall)
542				if (iva >= ivae)
543					readall = 0;
544				else for(;;) {
545					switch(ch) {
546						case ' ':
547						case '\t':
548						case '\n':
549							GETC(ch);
550							continue;
551						}
552					break;
553					}
554			if (ch == '/' || ch == '$' || ch == '&') {
555				f__lquit = 1;
556				return 0;
557				}
558			else if (f__lquit) {
559				while(ch <= ' ' && ch >= 0)
560					GETC(ch);
561				Ungetc(ch,f__cf);
562				if (!Alpha[ch & 0xff] && ch >= 0)
563					errfl(a->cierr, 125, where);
564				break;
565				}
566			Ungetc(ch,f__cf);
567			if (readall && !Alpha[ch & 0xff])
568				goto readloop;
569			if ((no -= no1) <= 0)
570				break;
571			for(dn1 = dn0; dn1 <= dn; dn1++) {
572				if (++dn1->curval < dn1->extent) {
573					iva += dn1->delta;
574					goto readloop;
575					}
576				dn1->curval = 0;
577				}
578			break;
579			}
580		}
581	}
582
583 integer
584#ifdef KR_headers
585s_rsne(a) cilist *a;
586#else
587s_rsne(cilist *a)
588#endif
589{
590	extern int l_eof;
591	int n;
592
593	f__external=1;
594	l_eof = 0;
595	if(n = c_le(a))
596		return n;
597	if(f__curunit->uwrt && f__nowreading(f__curunit))
598		err(a->cierr,errno,where0);
599	l_getc = t_getc;
600	l_ungetc = un_getc;
601	f__doend = xrd_SL;
602	n = x_rsne(a);
603	nml_read = 0;
604	if (n)
605		return n;
606	return e_rsle();
607	}
608