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