![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to rsne.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10dc / libI77|
Return to rsne.c CVS log | Up to [Research Unix] / researchv10dc / libI77 |
1.1 root 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 n_nlcache;
33: static hashentry **zot;
34: extern ftnlen f__typesize[];
35:
36: extern flag f__lquit;
37: extern int f__lcount, nml_read;
38: extern t_getc(Void);
39:
40: #ifdef KR_headers
41: extern char *malloc(), *memset();
42:
43: #ifdef ungetc
44: static int
45: un_getc(x,f__cf) int x; FILE *f__cf;
46: { return ungetc(x,f__cf); }
47: #else
48: #define un_getc ungetc
49: extern int ungetc();
50: #endif
51:
52: #else
53: #undef abs
54: #undef min
55: #undef max
56: #include "stdlib.h"
57: #include "string.h"
58:
59: #ifdef ungetc
60: static int
61: un_getc(int x, FILE *f__cf)
62: { return ungetc(x,f__cf); }
63: #else
64: #define un_getc ungetc
65: #endif
66: #endif
67:
68: static Vardesc *
69: #ifdef KR_headers
70: hash(ht, s) hashtab *ht; register char *s;
71: #else
72: hash(hashtab *ht, register char *s)
73: #endif
74: {
75: register int c, x;
76: register hashentry *h;
77: char *s0 = s;
78:
79: for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
80: x += c;
81: for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next)
82: if (!strcmp(s0, h->name))
83: return h->vd;
84: return 0;
85: }
86:
87: hashtab *
88: #ifdef KR_headers
89: mk_hashtab(nl) Namelist *nl;
90: #else
91: mk_hashtab(Namelist *nl)
92: #endif
93: {
94: int nht, nv;
95: hashtab *ht;
96: Vardesc *v, **vd, **vde;
97: hashentry *he;
98:
99: hashtab **x, **x0, *y;
100: for(x = &nl_cache; y = *x; x0 = x, x = &y->next)
101: if (nl == y->nl)
102: return y;
103: if (n_nlcache >= MAX_NL_CACHE) {
104: /* discard least recently used namelist hash table */
105: y = *x0;
106: free((char *)y->next);
107: y->next = 0;
108: }
109: else
110: n_nlcache++;
111: nv = nl->nvars;
112: if (nv >= 0x4000)
113: nht = 0x7fff;
114: else {
115: for(nht = 1; nht < nv; nht <<= 1);
116: nht += nht - 1;
117: }
118: ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *)
119: + nv*sizeof(hashentry));
120: if (!ht)
121: return 0;
122: he = (hashentry *)&ht->tab[nht];
123: ht->nl = nl;
124: ht->htsize = nht;
125: ht->next = nl_cache;
126: nl_cache = ht;
127: memset((char *)ht->tab, 0, nht*sizeof(hashentry *));
128: vd = nl->vars;
129: vde = vd + nv;
130: while(vd < vde) {
131: v = *vd++;
132: if (!hash(ht, v->name)) {
133: he->next = *zot;
134: *zot = he;
135: he->name = v->name;
136: he->vd = v;
137: he++;
138: }
139: }
140: return ht;
141: }
142:
143: static char Alpha[256], Alphanum[256];
144:
145: static VOID
146: nl_init(Void) {
147: register char *s;
148: register int c;
149:
150: if(!f__init)
151: f_init();
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
167: getname(s, slen) register char *s; int slen;
168: #else
169: getname(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
193: getnum(chp, val) int *chp; ftnlen *val;
194: #else
195: getnum(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
227: getdimen(chp, d, delta, extent, x1)
228: int *chp; dimen *d; ftnlen delta, extent, *x1;
229: #else
230: getdimen(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: }
250: if (x2 < 0 || x2 >= extent)
251: return 123;
252: d->extent = x2 + 1;
253: }
254: else
255: d->extent = 1;
256: d->curval = 0;
257: d->delta = delta;
258: d->stride = x3;
259: return 0;
260: }
261:
262: #ifndef No_Namelist_Questions
263: static Void
264: #ifdef KR_headers
265: print_ne(a) cilist *a;
266: #else
267: print_ne(cilist *a)
268: #endif
269: {
270: flag intext = f__external;
271: int rpsave = f__recpos;
272: FILE *cfsave = f__cf;
273: unit *usave = f__curunit;
274: cilist t;
275: t = *a;
276: t.ciunit = 6;
277: s_wsne(&t);
278: fflush(f__cf);
279: f__external = intext;
280: f__reading = 1;
281: f__recpos = rpsave;
282: f__cf = cfsave;
283: f__curunit = usave;
284: f__elist = a;
285: }
286: #endif
287:
288: static char where0[] = "namelist read start ";
289:
290: #ifdef KR_headers
291: x_rsne(a) cilist *a;
292: #else
293: x_rsne(cilist *a)
294: #endif
295: {
296: int ch, got1, k, n, nd, quote;
297: Namelist *nl;
298: static char where[] = "namelist read";
299: char buf[64];
300: hashtab *ht;
301: Vardesc *v;
302: dimen *dn, *dn0, *dn1;
303: ftnlen *dims, *dims1;
304: ftnlen b, b0, b1, ex, no, no1, nomax, size, span;
305: ftnint type;
306: char *vaddr;
307: long iva, ivae;
308: dimen dimens[MAXDIM], substr;
309:
310: if (!Alpha['a'])
311: nl_init();
312: f__reading=1;
313: f__formatted=1;
314: got1 = 0;
315: top:
316: for(;;) switch(GETC(ch)) {
317: case EOF:
318: err(a->ciend,(EOF),where0);
319: case '&':
320: case '$':
321: goto have_amp;
322: #ifndef No_Namelist_Questions
323: case '?':
324: print_ne(a);
325: continue;
326: #endif
327: default:
328: if (ch <= ' ' && ch >= 0)
329: continue;
330: errfl(a->cierr, 115, where0);
331: }
332: have_amp:
333: if (ch = getname(buf,sizeof(buf)))
334: return ch;
335: nl = (Namelist *)a->cifmt;
336: if (strcmp(buf, nl->name))
337: #ifdef No_Bad_Namelist_Skip
338: errfl(a->cierr, 118, where0);
339: #else
340: {
341: fprintf(stderr,
342: "Skipping namelist \"%s\": seeking namelist \"%s\".\n",
343: buf, nl->name);
344: fflush(stderr);
345: for(;;) switch(GETC(ch)) {
346: case EOF:
347: err(a->ciend, EOF, where0);
348: case '/':
349: case '&':
350: case '$':
351: if (f__external)
352: e_rsle();
353: else
354: z_rnew();
355: goto top;
356: case '"':
357: case '\'':
358: quote = ch;
359: more_quoted:
360: while(GETC(ch) != quote)
361: if (ch == EOF)
362: err(a->ciend, EOF, where0);
363: if (GETC(ch) == quote)
364: goto more_quoted;
365: Ungetc(ch,f__cf);
366: default:
367: continue;
368: }
369: }
370: #endif
371: ht = mk_hashtab(nl);
372: if (!ht)
373: errfl(f__elist->cierr, 113, where0);
374: for(;;) {
375: for(;;) switch(GETC(ch)) {
376: case EOF:
377: if (got1)
378: return 0;
379: err(a->ciend, EOF, where0);
380: case '/':
381: case '$':
382: case '&':
383: return 0;
384: default:
385: if (ch <= ' ' && ch >= 0 || ch == ',')
386: continue;
387: Ungetc(ch,f__cf);
388: if (ch = getname(buf,sizeof(buf)))
389: return ch;
390: goto havename;
391: }
392: havename:
393: v = hash(ht,buf);
394: if (!v)
395: errfl(a->cierr, 119, where);
396: while(GETC(ch) <= ' ' && ch >= 0);
397: vaddr = v->addr;
398: type = v->type;
399: if (type < 0) {
400: size = -type;
401: type = TYCHAR;
402: }
403: else
404: size = f__typesize[type];
405: ivae = size;
406: iva = 0;
407: if (ch == '(' /*)*/ ) {
408: dn = dimens;
409: if (!(dims = v->dims)) {
410: if (type != TYCHAR)
411: errfl(a->cierr, 122, where);
412: if (k = getdimen(&ch, dn, (ftnlen)size,
413: (ftnlen)size, &b))
414: errfl(a->cierr, k, where);
415: if (ch != ')')
416: errfl(a->cierr, 115, where);
417: b1 = dn->extent;
418: if (--b < 0 || b + b1 > size)
419: return 124;
420: iva += b;
421: size = b1;
422: while(GETC(ch) <= ' ' && ch >= 0);
423: goto scalar;
424: }
425: nd = (int)dims[0];
426: nomax = span = dims[1];
427: ivae = iva + size*nomax;
428: if (k = getdimen(&ch, dn, size, nomax, &b))
429: errfl(a->cierr, k, where);
430: no = dn->extent;
431: b0 = dims[2];
432: dims1 = dims += 3;
433: ex = 1;
434: for(n = 1; n++ < nd; dims++) {
435: if (ch != ',')
436: errfl(a->cierr, 115, where);
437: dn1 = dn + 1;
438: span /= *dims;
439: if (k = getdimen(&ch, dn1, dn->delta**dims,
440: span, &b1))
441: errfl(a->cierr, k, where);
442: ex *= *dims;
443: b += b1*ex;
444: no *= dn1->extent;
445: dn = dn1;
446: }
447: if (ch != ')')
448: errfl(a->cierr, 115, where);
449: b -= b0;
450: if (b < 0 || b >= nomax)
451: errfl(a->cierr, 125, where);
452: iva += size * b;
453: dims = dims1;
454: while(GETC(ch) <= ' ' && ch >= 0);
455: no1 = 1;
456: dn0 = dimens;
457: if (type == TYCHAR && ch == '(' /*)*/) {
458: if (k = getdimen(&ch, &substr, size, size, &b))
459: errfl(a->cierr, k, where);
460: if (ch != ')')
461: errfl(a->cierr, 115, where);
462: b1 = substr.extent;
463: if (--b < 0 || b + b1 > size)
464: return 124;
465: iva += b;
466: b0 = size;
467: size = b1;
468: while(GETC(ch) <= ' ' && ch >= 0);
469: if (b1 < b0)
470: goto delta_adj;
471: }
472: for(; dn0 < dn; dn0++) {
473: if (dn0->extent != *dims++ || dn0->stride != 1)
474: break;
475: no1 *= dn0->extent;
476: }
477: if (dn0 == dimens && dimens[0].stride == 1) {
478: no1 = dimens[0].extent;
479: dn0++;
480: }
481: delta_adj:
482: ex = 0;
483: for(dn1 = dn0; dn1 <= dn; dn1++)
484: ex += (dn1->extent-1)
485: * (dn1->delta *= dn1->stride);
486: for(dn1 = dn; dn1 > dn0; dn1--) {
487: ex -= (dn1->extent - 1) * dn1->delta;
488: dn1->delta -= ex;
489: }
490: }
491: else if (dims = v->dims) {
492: no = no1 = dims[1];
493: ivae = iva + no*size;
494: }
495: else
496: scalar:
497: no = no1 = 1;
498: if (ch != '=')
499: errfl(a->cierr, 115, where);
500: got1 = nml_read = 1;
501: f__lcount = 0;
502: readloop:
503: for(;;) {
504: if (iva >= ivae || iva < 0) {
505: f__lquit = 1;
506: goto mustend;
507: }
508: else if (iva + no1*size > ivae)
509: no1 = (ivae - iva)/size;
510: f__lquit = 0;
511: if (k = l_read(&no1, vaddr + iva, size, type))
512: return k;
513: if (f__lquit == 1)
514: return 0;
515: mustend:
516: if (GETC(ch) == '/' || ch == '$' || ch == '&') {
517: f__lquit = 1;
518: return 0;
519: }
520: else if (f__lquit) {
521: while(ch <= ' ' && ch >= 0)
522: GETC(ch);
523: Ungetc(ch,f__cf);
524: if (!Alpha[ch & 0xff] && ch >= 0)
525: errfl(a->cierr, 125, where);
526: break;
527: }
528: Ungetc(ch,f__cf);
529: if ((no -= no1) <= 0)
530: break;
531: for(dn1 = dn0; dn1 <= dn; dn1++) {
532: if (++dn1->curval < dn1->extent) {
533: iva += dn1->delta;
534: goto readloop;
535: }
536: dn1->curval = 0;
537: }
538: break;
539: }
540: }
541: }
542:
543: integer
544: #ifdef KR_headers
545: s_rsne(a) cilist *a;
546: #else
547: s_rsne(cilist *a)
548: #endif
549: {
550: extern int l_eof;
551: int n;
552:
553: f__external=1;
554: l_eof = 0;
555: if(n = c_le(a))
556: return n;
557: if(f__curunit->uwrt && f__nowreading(f__curunit))
558: err(a->cierr,errno,where0);
559: l_getc = t_getc;
560: l_ungetc = un_getc;
561: f__doend = xrd_SL;
562: if (n = x_rsne(a))
563: return n;
564: return e_rsle();
565: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.