| #include "f2c.h" |
| #include "fio.h" |
| #include "lio.h" |
| |
| #define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */ |
| #define MAXDIM 20 /* maximum number of subscripts */ |
| |
| struct dimen { |
| ftnlen extent; |
| ftnlen curval; |
| ftnlen delta; |
| ftnlen stride; |
| }; |
| typedef struct dimen dimen; |
| |
| struct hashentry { |
| struct hashentry *next; |
| char *name; |
| Vardesc *vd; |
| }; |
| typedef struct hashentry hashentry; |
| |
| struct hashtab { |
| struct hashtab *next; |
| Namelist *nl; |
| int htsize; |
| hashentry *tab[1]; |
| }; |
| typedef struct hashtab hashtab; |
| |
| static hashtab *nl_cache; |
| static int n_nlcache; |
| static hashentry **zot; |
| static int colonseen; |
| extern ftnlen f__typesize[]; |
| |
| extern flag f__lquit; |
| extern int f__lcount, nml_read; |
| extern t_getc(Void); |
| |
| #ifdef KR_headers |
| extern char *malloc(), *memset(); |
| |
| #ifdef ungetc |
| static int |
| un_getc(x,f__cf) int x; FILE *f__cf; |
| { return ungetc(x,f__cf); } |
| #else |
| #define un_getc ungetc |
| extern int ungetc(); |
| #endif |
| |
| #else |
| #undef abs |
| #undef min |
| #undef max |
| #include <stdlib.h> |
| #include <string.h> |
| |
| #ifdef ungetc |
| static int |
| un_getc(int x, FILE *f__cf) |
| { return ungetc(x,f__cf); } |
| #else |
| #define un_getc ungetc |
| extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ |
| #endif |
| #endif |
| |
| static Vardesc * |
| #ifdef KR_headers |
| hash(ht, s) hashtab *ht; register char *s; |
| #else |
| hash(hashtab *ht, register char *s) |
| #endif |
| { |
| register int c, x; |
| register hashentry *h; |
| char *s0 = s; |
| |
| for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1) |
| x += c; |
| for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next) |
| if (!strcmp(s0, h->name)) |
| return h->vd; |
| return 0; |
| } |
| |
| hashtab * |
| #ifdef KR_headers |
| mk_hashtab(nl) Namelist *nl; |
| #else |
| mk_hashtab(Namelist *nl) |
| #endif |
| { |
| int nht, nv; |
| hashtab *ht; |
| Vardesc *v, **vd, **vde; |
| hashentry *he; |
| |
| hashtab **x, **x0, *y; |
| for(x = &nl_cache; y = *x; x0 = x, x = &y->next) |
| if (nl == y->nl) |
| return y; |
| if (n_nlcache >= MAX_NL_CACHE) { |
| /* discard least recently used namelist hash table */ |
| y = *x0; |
| free((char *)y->next); |
| y->next = 0; |
| } |
| else |
| n_nlcache++; |
| nv = nl->nvars; |
| if (nv >= 0x4000) |
| nht = 0x7fff; |
| else { |
| for(nht = 1; nht < nv; nht <<= 1); |
| nht += nht - 1; |
| } |
| ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *) |
| + nv*sizeof(hashentry)); |
| if (!ht) |
| return 0; |
| he = (hashentry *)&ht->tab[nht]; |
| ht->nl = nl; |
| ht->htsize = nht; |
| ht->next = nl_cache; |
| nl_cache = ht; |
| memset((char *)ht->tab, 0, nht*sizeof(hashentry *)); |
| vd = nl->vars; |
| vde = vd + nv; |
| while(vd < vde) { |
| v = *vd++; |
| if (!hash(ht, v->name)) { |
| he->next = *zot; |
| *zot = he; |
| he->name = v->name; |
| he->vd = v; |
| he++; |
| } |
| } |
| return ht; |
| } |
| |
| static char Alpha[256], Alphanum[256]; |
| |
| static VOID |
| nl_init(Void) { |
| register char *s; |
| register int c; |
| |
| for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; ) |
| Alpha[c] |
| = Alphanum[c] |
| = Alpha[c + 'a' - 'A'] |
| = Alphanum[c + 'a' - 'A'] |
| = c; |
| for(s = "0123456789_"; c = *s++; ) |
| Alphanum[c] = c; |
| } |
| |
| #define GETC(x) (x=(*l_getc)()) |
| #define Ungetc(x,y) (*l_ungetc)(x,y) |
| |
| static int |
| #ifdef KR_headers |
| getname(s, slen) register char *s; int slen; |
| #else |
| getname(register char *s, int slen) |
| #endif |
| { |
| register char *se = s + slen - 1; |
| register int ch; |
| |
| GETC(ch); |
| if (!(*s++ = Alpha[ch & 0xff])) { |
| if (ch != EOF) |
| ch = 115; |
| errfl(f__elist->cierr, ch, "namelist read"); |
| } |
| while(*s = Alphanum[GETC(ch) & 0xff]) |
| if (s < se) |
| s++; |
| if (ch == EOF) |
| err(f__elist->cierr, EOF, "namelist read"); |
| if (ch > ' ') |
| Ungetc(ch,f__cf); |
| return *s = 0; |
| } |
| |
| static int |
| #ifdef KR_headers |
| getnum(chp, val) int *chp; ftnlen *val; |
| #else |
| getnum(int *chp, ftnlen *val) |
| #endif |
| { |
| register int ch, sign; |
| register ftnlen x; |
| |
| while(GETC(ch) <= ' ' && ch >= 0); |
| if (ch == '-') { |
| sign = 1; |
| GETC(ch); |
| } |
| else { |
| sign = 0; |
| if (ch == '+') |
| GETC(ch); |
| } |
| x = ch - '0'; |
| if (x < 0 || x > 9) |
| return 115; |
| while(GETC(ch) >= '0' && ch <= '9') |
| x = 10*x + ch - '0'; |
| while(ch <= ' ' && ch >= 0) |
| GETC(ch); |
| if (ch == EOF) |
| return EOF; |
| *val = sign ? -x : x; |
| *chp = ch; |
| return 0; |
| } |
| |
| static int |
| #ifdef KR_headers |
| getdimen(chp, d, delta, extent, x1) |
| int *chp; dimen *d; ftnlen delta, extent, *x1; |
| #else |
| getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1) |
| #endif |
| { |
| register int k; |
| ftnlen x2, x3; |
| |
| if (k = getnum(chp, x1)) |
| return k; |
| x3 = 1; |
| if (*chp == ':') { |
| if (k = getnum(chp, &x2)) |
| return k; |
| x2 -= *x1; |
| if (*chp == ':') { |
| if (k = getnum(chp, &x3)) |
| return k; |
| if (!x3) |
| return 123; |
| x2 /= x3; |
| colonseen = 1; |
| } |
| if (x2 < 0 || x2 >= extent) |
| return 123; |
| d->extent = x2 + 1; |
| } |
| else |
| d->extent = 1; |
| d->curval = 0; |
| d->delta = delta; |
| d->stride = x3; |
| return 0; |
| } |
| |
| #ifndef No_Namelist_Questions |
| static Void |
| #ifdef KR_headers |
| print_ne(a) cilist *a; |
| #else |
| print_ne(cilist *a) |
| #endif |
| { |
| flag intext = f__external; |
| int rpsave = f__recpos; |
| FILE *cfsave = f__cf; |
| unit *usave = f__curunit; |
| cilist t; |
| t = *a; |
| t.ciunit = 6; |
| s_wsne(&t); |
| fflush(f__cf); |
| f__external = intext; |
| f__reading = 1; |
| f__recpos = rpsave; |
| f__cf = cfsave; |
| f__curunit = usave; |
| f__elist = a; |
| } |
| #endif |
| |
| static char where0[] = "namelist read start "; |
| |
| #ifdef KR_headers |
| x_rsne(a) cilist *a; |
| #else |
| x_rsne(cilist *a) |
| #endif |
| { |
| int ch, got1, k, n, nd, quote, readall; |
| Namelist *nl; |
| static char where[] = "namelist read"; |
| char buf[64]; |
| hashtab *ht; |
| Vardesc *v; |
| dimen *dn, *dn0, *dn1; |
| ftnlen *dims, *dims1; |
| ftnlen b, b0, b1, ex, no, no1, nomax, size, span; |
| ftnint type; |
| char *vaddr; |
| long iva, ivae; |
| dimen dimens[MAXDIM], substr; |
| |
| if (!Alpha['a']) |
| nl_init(); |
| f__reading=1; |
| f__formatted=1; |
| got1 = 0; |
| top: |
| for(;;) switch(GETC(ch)) { |
| case EOF: |
| eof: |
| err(a->ciend,(EOF),where0); |
| case '&': |
| case '$': |
| goto have_amp; |
| #ifndef No_Namelist_Questions |
| case '?': |
| print_ne(a); |
| continue; |
| #endif |
| default: |
| if (ch <= ' ' && ch >= 0) |
| continue; |
| #ifndef No_Namelist_Comments |
| while(GETC(ch) != '\n') |
| if (ch == EOF) |
| goto eof; |
| #else |
| errfl(a->cierr, 115, where0); |
| #endif |
| } |
| have_amp: |
| if (ch = getname(buf,(int) sizeof(buf))) |
| return ch; |
| nl = (Namelist *)a->cifmt; |
| if (strcmp(buf, nl->name)) |
| #ifdef No_Bad_Namelist_Skip |
| errfl(a->cierr, 118, where0); |
| #else |
| { |
| fprintf(stderr, |
| "Skipping namelist \"%s\": seeking namelist \"%s\".\n", |
| buf, nl->name); |
| fflush(stderr); |
| for(;;) switch(GETC(ch)) { |
| case EOF: |
| err(a->ciend, EOF, where0); |
| case '/': |
| case '&': |
| case '$': |
| if (f__external) |
| e_rsle(); |
| else |
| z_rnew(); |
| goto top; |
| case '"': |
| case '\'': |
| quote = ch; |
| more_quoted: |
| while(GETC(ch) != quote) |
| if (ch == EOF) |
| err(a->ciend, EOF, where0); |
| if (GETC(ch) == quote) |
| goto more_quoted; |
| Ungetc(ch,f__cf); |
| default: |
| continue; |
| } |
| } |
| #endif |
| ht = mk_hashtab(nl); |
| if (!ht) |
| errfl(f__elist->cierr, 113, where0); |
| for(;;) { |
| for(;;) switch(GETC(ch)) { |
| case EOF: |
| if (got1) |
| return 0; |
| err(a->ciend, EOF, where0); |
| case '/': |
| case '$': |
| case '&': |
| return 0; |
| default: |
| if (ch <= ' ' && ch >= 0 || ch == ',') |
| continue; |
| Ungetc(ch,f__cf); |
| if (ch = getname(buf,(int) sizeof(buf))) |
| return ch; |
| goto havename; |
| } |
| havename: |
| v = hash(ht,buf); |
| if (!v) |
| errfl(a->cierr, 119, where); |
| while(GETC(ch) <= ' ' && ch >= 0); |
| vaddr = v->addr; |
| type = v->type; |
| if (type < 0) { |
| size = -type; |
| type = TYCHAR; |
| } |
| else |
| size = f__typesize[type]; |
| ivae = size; |
| iva = readall = 0; |
| if (ch == '(' /*)*/ ) { |
| dn = dimens; |
| if (!(dims = v->dims)) { |
| if (type != TYCHAR) |
| errfl(a->cierr, 122, where); |
| if (k = getdimen(&ch, dn, (ftnlen)size, |
| (ftnlen)size, &b)) |
| errfl(a->cierr, k, where); |
| if (ch != ')') |
| errfl(a->cierr, 115, where); |
| b1 = dn->extent; |
| if (--b < 0 || b + b1 > size) |
| return 124; |
| iva += b; |
| size = b1; |
| while(GETC(ch) <= ' ' && ch >= 0); |
| goto scalar; |
| } |
| nd = (int)dims[0]; |
| nomax = span = dims[1]; |
| ivae = iva + size*nomax; |
| colonseen = 0; |
| if (k = getdimen(&ch, dn, size, nomax, &b)) |
| errfl(a->cierr, k, where); |
| no = dn->extent; |
| b0 = dims[2]; |
| dims1 = dims += 3; |
| ex = 1; |
| for(n = 1; n++ < nd; dims++) { |
| if (ch != ',') |
| errfl(a->cierr, 115, where); |
| dn1 = dn + 1; |
| span /= *dims; |
| if (k = getdimen(&ch, dn1, dn->delta**dims, |
| span, &b1)) |
| errfl(a->cierr, k, where); |
| ex *= *dims; |
| b += b1*ex; |
| no *= dn1->extent; |
| dn = dn1; |
| } |
| if (ch != ')') |
| errfl(a->cierr, 115, where); |
| readall = 1 - colonseen; |
| b -= b0; |
| if (b < 0 || b >= nomax) |
| errfl(a->cierr, 125, where); |
| iva += size * b; |
| dims = dims1; |
| while(GETC(ch) <= ' ' && ch >= 0); |
| no1 = 1; |
| dn0 = dimens; |
| if (type == TYCHAR && ch == '(' /*)*/) { |
| if (k = getdimen(&ch, &substr, size, size, &b)) |
| errfl(a->cierr, k, where); |
| if (ch != ')') |
| errfl(a->cierr, 115, where); |
| b1 = substr.extent; |
| if (--b < 0 || b + b1 > size) |
| return 124; |
| iva += b; |
| b0 = size; |
| size = b1; |
| while(GETC(ch) <= ' ' && ch >= 0); |
| if (b1 < b0) |
| goto delta_adj; |
| } |
| if (readall) |
| goto delta_adj; |
| for(; dn0 < dn; dn0++) { |
| if (dn0->extent != *dims++ || dn0->stride != 1) |
| break; |
| no1 *= dn0->extent; |
| } |
| if (dn0 == dimens && dimens[0].stride == 1) { |
| no1 = dimens[0].extent; |
| dn0++; |
| } |
| delta_adj: |
| ex = 0; |
| for(dn1 = dn0; dn1 <= dn; dn1++) |
| ex += (dn1->extent-1) |
| * (dn1->delta *= dn1->stride); |
| for(dn1 = dn; dn1 > dn0; dn1--) { |
| ex -= (dn1->extent - 1) * dn1->delta; |
| dn1->delta -= ex; |
| } |
| } |
| else if (dims = v->dims) { |
| no = no1 = dims[1]; |
| ivae = iva + no*size; |
| } |
| else |
| scalar: |
| no = no1 = 1; |
| if (ch != '=') |
| errfl(a->cierr, 115, where); |
| got1 = nml_read = 1; |
| f__lcount = 0; |
| readloop: |
| for(;;) { |
| if (iva >= ivae || iva < 0) { |
| f__lquit = 1; |
| goto mustend; |
| } |
| else if (iva + no1*size > ivae) |
| no1 = (ivae - iva)/size; |
| f__lquit = 0; |
| if (k = l_read(&no1, vaddr + iva, size, type)) |
| return k; |
| if (f__lquit == 1) |
| return 0; |
| if (readall) { |
| iva += dn0->delta; |
| if (f__lcount > 0) { |
| no1 = (ivae - iva)/size; |
| if (no1 > f__lcount) |
| no1 = f__lcount; |
| if (k = l_read(&no1, vaddr + iva, |
| size, type)) |
| return k; |
| iva += no1 * dn0->delta; |
| } |
| } |
| mustend: |
| GETC(ch); |
| if (readall) |
| if (iva >= ivae) |
| readall = 0; |
| else for(;;) { |
| switch(ch) { |
| case ' ': |
| case '\t': |
| case '\n': |
| GETC(ch); |
| continue; |
| } |
| break; |
| } |
| if (ch == '/' || ch == '$' || ch == '&') { |
| f__lquit = 1; |
| return 0; |
| } |
| else if (f__lquit) { |
| while(ch <= ' ' && ch >= 0) |
| GETC(ch); |
| Ungetc(ch,f__cf); |
| if (!Alpha[ch & 0xff] && ch >= 0) |
| errfl(a->cierr, 125, where); |
| break; |
| } |
| Ungetc(ch,f__cf); |
| if (readall && !Alpha[ch & 0xff]) |
| goto readloop; |
| if ((no -= no1) <= 0) |
| break; |
| for(dn1 = dn0; dn1 <= dn; dn1++) { |
| if (++dn1->curval < dn1->extent) { |
| iva += dn1->delta; |
| goto readloop; |
| } |
| dn1->curval = 0; |
| } |
| break; |
| } |
| } |
| } |
| |
| integer |
| #ifdef KR_headers |
| s_rsne(a) cilist *a; |
| #else |
| s_rsne(cilist *a) |
| #endif |
| { |
| extern int l_eof; |
| int n; |
| |
| f__external=1; |
| l_eof = 0; |
| if(n = c_le(a)) |
| return n; |
| if(f__curunit->uwrt && f__nowreading(f__curunit)) |
| err(a->cierr,errno,where0); |
| l_getc = t_getc; |
| l_ungetc = un_getc; |
| f__doend = xrd_SL; |
| n = x_rsne(a); |
| nml_read = 0; |
| if (n) |
| return n; |
| return e_rsle(); |
| } |