![[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 / old1|
Return to rsne.c CVS log | Up to [Research Unix] / researchv10dc / libI77 / old1 |
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: err(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: static char where0[] = "namelist read start ";
263:
264: #ifdef KR_headers
265: x_rsne(a) cilist *a;
266: #else
267: x_rsne(cilist *a)
268: #endif
269: {
270: int ch, got1, k, n, nd;
271: Namelist *nl;
272: static char where[] = "namelist read";
273: char buf[64];
274: hashtab *ht;
275: Vardesc *v;
276: dimen *dn, *dn0, *dn1;
277: ftnlen *dims, *dims1;
278: ftnlen b, b0, b1, ex, no, no1, nomax, size, span;
279: ftnint type;
280: char *vaddr;
281: long iva, ivae;
282: dimen dimens[MAXDIM], substr;
283:
284: if (!Alpha['a'])
285: nl_init();
286: f__reading=1;
287: f__formatted=1;
288: got1 = 0;
289: for(;;) switch(GETC(ch)) {
290: case EOF:
291: err(a->ciend,(EOF),where0);
292: case '&':
293: case '$':
294: goto have_amp;
295: default:
296: if (ch <= ' ' && ch >= 0)
297: continue;
298: err(a->cierr, 115, where0);
299: }
300: have_amp:
301: if (ch = getname(buf,sizeof(buf)))
302: return ch;
303: nl = (Namelist *)a->cifmt;
304: if (strcmp(buf, nl->name))
305: err(a->cierr, 118, where0);
306: ht = mk_hashtab(nl);
307: if (!ht)
308: err(f__elist->cierr, 113, where0);
309: for(;;) {
310: for(;;) switch(GETC(ch)) {
311: case EOF:
312: if (got1)
313: return 0;
314: err(a->ciend,(EOF),where0);
315: case '/':
316: case '$':
317: case '&':
318: return 0;
319: default:
320: if (ch <= ' ' && ch >= 0 || ch == ',')
321: continue;
322: Ungetc(ch,f__cf);
323: if (ch = getname(buf,sizeof(buf)))
324: return ch;
325: goto havename;
326: }
327: havename:
328: v = hash(ht,buf);
329: if (!v)
330: err(a->cierr, 119, where);
331: while(GETC(ch) <= ' ' && ch >= 0);
332: vaddr = v->addr;
333: type = v->type;
334: if (type < 0) {
335: size = -type;
336: type = TYCHAR;
337: }
338: else
339: size = f__typesize[type];
340: ivae = size;
341: iva = 0;
342: if (ch == '(' /*)*/ ) {
343: dn = dimens;
344: if (!(dims = v->dims)) {
345: if (type != TYCHAR)
346: err(a->cierr, 122, where);
347: if (k = getdimen(&ch, dn, (ftnlen)size,
348: (ftnlen)size, &b))
349: err(a->cierr, k, where);
350: if (ch != ')')
351: err(a->cierr, 115, where);
352: b1 = dn->extent;
353: if (--b < 0 || b + b1 > size)
354: return 124;
355: iva += b;
356: size = b1;
357: while(GETC(ch) <= ' ' && ch >= 0);
358: goto scalar;
359: }
360: nd = dims[0];
361: nomax = span = dims[1];
362: ivae = iva + size*nomax;
363: if (k = getdimen(&ch, dn, size, nomax, &b))
364: err(a->cierr, k, where);
365: no = dn->extent;
366: b0 = dims[2];
367: dims1 = dims += 3;
368: ex = 1;
369: for(n = 1; n++ < nd; dims++) {
370: if (ch != ',')
371: err(a->cierr, 115, where);
372: dn1 = dn + 1;
373: span /= *dims;
374: if (k = getdimen(&ch, dn1, dn->delta**dims,
375: span, &b1))
376: err(a->cierr, k, where);
377: ex *= *dims;
378: b += b1*ex;
379: no *= dn1->extent;
380: dn = dn1;
381: }
382: if (ch != ')')
383: err(a->cierr, 115, where);
384: b -= b0;
385: if (b < 0 || b >= nomax)
386: err(a->cierr, 125, where);
387: iva += size * b;
388: dims = dims1;
389: while(GETC(ch) <= ' ' && ch >= 0);
390: no1 = 1;
391: dn0 = dimens;
392: if (type == TYCHAR && ch == '(' /*)*/) {
393: if (k = getdimen(&ch, &substr, size, size, &b))
394: err(a->cierr, k, where);
395: if (ch != ')')
396: err(a->cierr, 115, where);
397: b1 = substr.extent;
398: if (--b < 0 || b + b1 > size)
399: return 124;
400: iva += b;
401: b0 = size;
402: size = b1;
403: while(GETC(ch) <= ' ' && ch >= 0);
404: if (b1 < b0)
405: goto delta_adj;
406: }
407: for(; dn0 < dn; dn0++) {
408: if (dn0->extent != *dims++ || dn0->stride != 1)
409: break;
410: no1 *= dn0->extent;
411: }
412: if (dn0 == dimens && dimens[0].stride == 1) {
413: no1 = dimens[0].extent;
414: dn0++;
415: }
416: delta_adj:
417: ex = 0;
418: for(dn1 = dn0; dn1 <= dn; dn1++)
419: ex += (dn1->extent-1)
420: * (dn1->delta *= dn1->stride);
421: for(dn1 = dn; dn1 > dn0; dn1--) {
422: ex -= (dn1->extent - 1) * dn1->delta;
423: dn1->delta -= ex;
424: }
425: }
426: else if (dims = v->dims) {
427: no = no1 = dims[1];
428: ivae = iva + no*size;
429: }
430: else
431: scalar:
432: no = no1 = 1;
433: if (ch != '=')
434: err(a->cierr, 115, where);
435: got1 = nml_read = 1;
436: f__lcount = 0;
437: readloop:
438: for(;;) {
439: if (iva >= ivae || iva < 0) {
440: f__lquit = 1;
441: goto mustend;
442: }
443: else if (iva + no1*size > ivae)
444: no1 = (ivae - iva)/size;
445: f__lquit = 0;
446: l_read(&no1, vaddr + iva, size, type);
447: if (f__lquit == 1)
448: return 0;
449: mustend:
450: if (GETC(ch) == '/' || ch == '$' || ch == '&') {
451: f__lquit = 1;
452: return 0;
453: }
454: else if (f__lquit) {
455: while(ch <= ' ' && ch >= 0)
456: GETC(ch);
457: Ungetc(ch,f__cf);
458: if (!Alpha[ch & 0xff] && ch >= 0)
459: err(a->cierr, 125, where);
460: break;
461: }
462: Ungetc(ch,f__cf);
463: if ((no -= no1) <= 0)
464: break;
465: for(dn1 = dn0; dn1 <= dn; dn1++) {
466: if (++dn1->curval < dn1->extent) {
467: iva += dn1->delta;
468: goto readloop;
469: }
470: dn1->curval = 0;
471: }
472: break;
473: }
474: }
475: }
476:
477: integer
478: #ifdef KR_headers
479: s_rsne(a) cilist *a;
480: #else
481: s_rsne(cilist *a)
482: #endif
483: {
484: extern int l_eof;
485: int n;
486:
487: f__external=1;
488: l_eof = 0;
489: if(n = c_le(a))
490: return n;
491: if(f__curunit->uwrt && f__nowreading(f__curunit))
492: err(a->cierr,errno,where0);
493: l_getc = t_getc;
494: l_ungetc = un_getc;
495: if (n = x_rsne(a))
496: return n;
497: return e_rsle();
498: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.