00001 #include "stdlib.h"
00002 #include "f2c.h"
00003 #include "fio.h"
00004 #include "lio.h"
00005
00006 #define MAX_NL_CACHE 3
00007 #define MAXDIM 20
00008
00009 struct dimen {
00010 ftnlen extent;
00011 ftnlen curval;
00012 ftnlen delta;
00013 ftnlen stride;
00014 };
00015 typedef struct dimen dimen;
00016
00017 struct hashentry {
00018 struct hashentry *next;
00019 char *name;
00020 Vardesc *vd;
00021 };
00022 typedef struct hashentry hashentry;
00023
00024 struct hashtab {
00025 struct hashtab *next;
00026 Namelist *nl;
00027 int htsize;
00028 hashentry *tab[1];
00029 };
00030 typedef struct hashtab hashtab;
00031
00032 static hashtab *nl_cache;
00033 static n_nlcache;
00034 static hashentry **zot;
00035 static int colonseen;
00036 extern ftnlen f__typesize[];
00037
00038 extern flag f__lquit;
00039 extern int f__lcount, nml_read;
00040 extern t_getc(Void);
00041
00042 #ifdef KR_headers
00043 extern char *malloc(), *memset();
00044
00045 #ifdef ungetc
00046 static int
00047 un_getc(x,f__cf) int x; FILE *f__cf;
00048 { return ungetc(x,f__cf); }
00049 #else
00050 #define un_getc ungetc
00051 extern int ungetc();
00052 #endif
00053
00054 #else
00055 #undef abs
00056 #undef min
00057 #undef max
00058 #include "stdlib.h"
00059 #include "string.h"
00060
00061 #ifdef ungetc
00062 static int
00063 un_getc(int x, FILE *f__cf)
00064 { return ungetc(x,f__cf); }
00065 #else
00066 #define un_getc ungetc
00067 extern int ungetc(int, FILE*);
00068 #endif
00069 #endif
00070
00071 static Vardesc *
00072 #ifdef KR_headers
00073 hash(ht, s) hashtab *ht; register char *s;
00074 #else
00075 hash(hashtab *ht, register char *s)
00076 #endif
00077 {
00078 register int c, x;
00079 register hashentry *h;
00080 char *s0 = s;
00081
00082 for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
00083 x += c;
00084 for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next)
00085 if (!strcmp(s0, h->name))
00086 return h->vd;
00087 return 0;
00088 }
00089
00090 hashtab *
00091 #ifdef KR_headers
00092 mk_hashtab(nl) Namelist *nl;
00093 #else
00094 mk_hashtab(Namelist *nl)
00095 #endif
00096 {
00097 int nht, nv;
00098 hashtab *ht;
00099 Vardesc *v, **vd, **vde;
00100 hashentry *he;
00101
00102 hashtab **x, **x0, *y;
00103 for(x = &nl_cache; y = *x; x0 = x, x = &y->next)
00104 if (nl == y->nl)
00105 return y;
00106 if (n_nlcache >= MAX_NL_CACHE) {
00107
00108 y = *x0;
00109 free((char *)y->next);
00110 y->next = 0;
00111 }
00112 else
00113 n_nlcache++;
00114 nv = nl->nvars;
00115 if (nv >= 0x4000)
00116 nht = 0x7fff;
00117 else {
00118 for(nht = 1; nht < nv; nht <<= 1);
00119 nht += nht - 1;
00120 }
00121 ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *)
00122 + nv*sizeof(hashentry));
00123 if (!ht)
00124 return 0;
00125 he = (hashentry *)&ht->tab[nht];
00126 ht->nl = nl;
00127 ht->htsize = nht;
00128 ht->next = nl_cache;
00129 nl_cache = ht;
00130 memset((char *)ht->tab, 0, nht*sizeof(hashentry *));
00131 vd = nl->vars;
00132 vde = vd + nv;
00133 while(vd < vde) {
00134 v = *vd++;
00135 if (!hash(ht, v->name)) {
00136 he->next = *zot;
00137 *zot = he;
00138 he->name = v->name;
00139 he->vd = v;
00140 he++;
00141 }
00142 }
00143 return ht;
00144 }
00145
00146 static char Alpha[256], Alphanum[256];
00147
00148 static VOID
00149 nl_init(Void) {
00150 register char *s;
00151 register int c;
00152
00153 if(!f__init)
00154 f_init();
00155 for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; )
00156 Alpha[c]
00157 = Alphanum[c]
00158 = Alpha[c + 'a' - 'A']
00159 = Alphanum[c + 'a' - 'A']
00160 = c;
00161 for(s = "0123456789_"; c = *s++; )
00162 Alphanum[c] = c;
00163 }
00164
00165 #define GETC(x) (x=(*l_getc)())
00166 #define Ungetc(x,y) (*l_ungetc)(x,y)
00167
00168 static int
00169 #ifdef KR_headers
00170 getname(s, slen) register char *s; int slen;
00171 #else
00172 getname(register char *s, int slen)
00173 #endif
00174 {
00175 register char *se = s + slen - 1;
00176 register int ch;
00177
00178 GETC(ch);
00179 if (!(*s++ = Alpha[ch & 0xff])) {
00180 if (ch != EOF)
00181 ch = 115;
00182 errfl(f__elist->cierr, ch, "namelist read");
00183 }
00184 while(*s = Alphanum[GETC(ch) & 0xff])
00185 if (s < se)
00186 s++;
00187 if (ch == EOF)
00188 err(f__elist->cierr, EOF, "namelist read");
00189 if (ch > ' ')
00190 Ungetc(ch,f__cf);
00191 return *s = 0;
00192 }
00193
00194 static int
00195 #ifdef KR_headers
00196 getnum(chp, val) int *chp; ftnlen *val;
00197 #else
00198 getnum(int *chp, ftnlen *val)
00199 #endif
00200 {
00201 register int ch, sign;
00202 register ftnlen x;
00203
00204 while(GETC(ch) <= ' ' && ch >= 0);
00205 if (ch == '-') {
00206 sign = 1;
00207 GETC(ch);
00208 }
00209 else {
00210 sign = 0;
00211 if (ch == '+')
00212 GETC(ch);
00213 }
00214 x = ch - '0';
00215 if (x < 0 || x > 9)
00216 return 115;
00217 while(GETC(ch) >= '0' && ch <= '9')
00218 x = 10*x + ch - '0';
00219 while(ch <= ' ' && ch >= 0)
00220 GETC(ch);
00221 if (ch == EOF)
00222 return EOF;
00223 *val = sign ? -x : x;
00224 *chp = ch;
00225 return 0;
00226 }
00227
00228 static int
00229 #ifdef KR_headers
00230 getdimen(chp, d, delta, extent, x1)
00231 int *chp; dimen *d; ftnlen delta, extent, *x1;
00232 #else
00233 getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1)
00234 #endif
00235 {
00236 register int k;
00237 ftnlen x2, x3;
00238
00239 if (k = getnum(chp, x1))
00240 return k;
00241 x3 = 1;
00242 if (*chp == ':') {
00243 if (k = getnum(chp, &x2))
00244 return k;
00245 x2 -= *x1;
00246 if (*chp == ':') {
00247 if (k = getnum(chp, &x3))
00248 return k;
00249 if (!x3)
00250 return 123;
00251 x2 /= x3;
00252 colonseen = 1;
00253 }
00254 if (x2 < 0 || x2 >= extent)
00255 return 123;
00256 d->extent = x2 + 1;
00257 }
00258 else
00259 d->extent = 1;
00260 d->curval = 0;
00261 d->delta = delta;
00262 d->stride = x3;
00263 return 0;
00264 }
00265
00266 #ifndef No_Namelist_Questions
00267 static Void
00268 #ifdef KR_headers
00269 print_ne(a) cilist *a;
00270 #else
00271 print_ne(cilist *a)
00272 #endif
00273 {
00274 flag intext = f__external;
00275 int rpsave = f__recpos;
00276 FILE *cfsave = f__cf;
00277 unit *usave = f__curunit;
00278 cilist t;
00279 t = *a;
00280 t.ciunit = 6;
00281 s_wsne(&t);
00282 fflush(f__cf);
00283 f__external = intext;
00284 f__reading = 1;
00285 f__recpos = rpsave;
00286 f__cf = cfsave;
00287 f__curunit = usave;
00288 f__elist = a;
00289 }
00290 #endif
00291
00292 static char where0[] = "namelist read start ";
00293
00294 #ifdef KR_headers
00295 x_rsne(a) cilist *a;
00296 #else
00297 x_rsne(cilist *a)
00298 #endif
00299 {
00300 int ch, got1, k, n, nd, quote, readall;
00301 Namelist *nl;
00302 static char where[] = "namelist read";
00303 char buf[64];
00304 hashtab *ht;
00305 Vardesc *v;
00306 dimen *dn, *dn0, *dn1;
00307 ftnlen *dims, *dims1;
00308 ftnlen b, b0, b1, ex, no, no1, nomax, size, span;
00309 ftnint type;
00310 char *vaddr;
00311 long iva, ivae;
00312 dimen dimens[MAXDIM], substr;
00313
00314 if (!Alpha['a'])
00315 nl_init();
00316 f__reading=1;
00317 f__formatted=1;
00318 got1 = 0;
00319 top:
00320 for(;;) switch(GETC(ch)) {
00321 case EOF:
00322 eof:
00323 err(a->ciend,(EOF),where0);
00324 case '&':
00325 case '$':
00326 goto have_amp;
00327 #ifndef No_Namelist_Questions
00328 case '?':
00329 print_ne(a);
00330 continue;
00331 #endif
00332 default:
00333 if (ch <= ' ' && ch >= 0)
00334 continue;
00335 #ifndef No_Namelist_Comments
00336 while(GETC(ch) != '\n')
00337 if (ch == EOF)
00338 goto eof;
00339 #else
00340 errfl(a->cierr, 115, where0);
00341 #endif
00342 }
00343 have_amp:
00344 if (ch = getname(buf,sizeof(buf)))
00345 return ch;
00346 nl = (Namelist *)a->cifmt;
00347 if (strcmp(buf, nl->name))
00348 #ifdef No_Bad_Namelist_Skip
00349 errfl(a->cierr, 118, where0);
00350 #else
00351 {
00352 fprintf(stderr,
00353 "Skipping namelist \"%s\": seeking namelist \"%s\".\n",
00354 buf, nl->name);
00355 fflush(stderr);
00356 for(;;) switch(GETC(ch)) {
00357 case EOF:
00358 err(a->ciend, EOF, where0);
00359 case '/':
00360 case '&':
00361 case '$':
00362 if (f__external)
00363 e_rsle();
00364 else
00365 z_rnew();
00366 goto top;
00367 case '"':
00368 case '\'':
00369 quote = ch;
00370 more_quoted:
00371 while(GETC(ch) != quote)
00372 if (ch == EOF)
00373 err(a->ciend, EOF, where0);
00374 if (GETC(ch) == quote)
00375 goto more_quoted;
00376 Ungetc(ch,f__cf);
00377 default:
00378 continue;
00379 }
00380 }
00381 #endif
00382 ht = mk_hashtab(nl);
00383 if (!ht)
00384 errfl(f__elist->cierr, 113, where0);
00385 for(;;) {
00386 for(;;) switch(GETC(ch)) {
00387 case EOF:
00388 if (got1)
00389 return 0;
00390 err(a->ciend, EOF, where0);
00391 case '/':
00392 case '$':
00393 case '&':
00394 return 0;
00395 default:
00396 if (ch <= ' ' && ch >= 0 || ch == ',')
00397 continue;
00398 Ungetc(ch,f__cf);
00399 if (ch = getname(buf,sizeof(buf)))
00400 return ch;
00401 goto havename;
00402 }
00403 havename:
00404 v = hash(ht,buf);
00405 if (!v)
00406 errfl(a->cierr, 119, where);
00407 while(GETC(ch) <= ' ' && ch >= 0);
00408 vaddr = v->addr;
00409 type = v->type;
00410 if (type < 0) {
00411 size = -type;
00412 type = TYCHAR;
00413 }
00414 else
00415 size = f__typesize[type];
00416 ivae = size;
00417 iva = readall = 0;
00418 if (ch == '(' ) {
00419 dn = dimens;
00420 if (!(dims = v->dims)) {
00421 if (type != TYCHAR)
00422 errfl(a->cierr, 122, where);
00423 if (k = getdimen(&ch, dn, (ftnlen)size,
00424 (ftnlen)size, &b))
00425 errfl(a->cierr, k, where);
00426 if (ch != ')')
00427 errfl(a->cierr, 115, where);
00428 b1 = dn->extent;
00429 if (--b < 0 || b + b1 > size)
00430 return 124;
00431 iva += b;
00432 size = b1;
00433 while(GETC(ch) <= ' ' && ch >= 0);
00434 goto scalar;
00435 }
00436 nd = (int)dims[0];
00437 nomax = span = dims[1];
00438 ivae = iva + size*nomax;
00439 colonseen = 0;
00440 if (k = getdimen(&ch, dn, size, nomax, &b))
00441 errfl(a->cierr, k, where);
00442 no = dn->extent;
00443 b0 = dims[2];
00444 dims1 = dims += 3;
00445 ex = 1;
00446 for(n = 1; n++ < nd; dims++) {
00447 if (ch != ',')
00448 errfl(a->cierr, 115, where);
00449 dn1 = dn + 1;
00450 span /= *dims;
00451 if (k = getdimen(&ch, dn1, dn->delta**dims,
00452 span, &b1))
00453 errfl(a->cierr, k, where);
00454 ex *= *dims;
00455 b += b1*ex;
00456 no *= dn1->extent;
00457 dn = dn1;
00458 }
00459 if (ch != ')')
00460 errfl(a->cierr, 115, where);
00461 readall = 1 - colonseen;
00462 b -= b0;
00463 if (b < 0 || b >= nomax)
00464 errfl(a->cierr, 125, where);
00465 iva += size * b;
00466 dims = dims1;
00467 while(GETC(ch) <= ' ' && ch >= 0);
00468 no1 = 1;
00469 dn0 = dimens;
00470 if (type == TYCHAR && ch == '(' ) {
00471 if (k = getdimen(&ch, &substr, size, size, &b))
00472 errfl(a->cierr, k, where);
00473 if (ch != ')')
00474 errfl(a->cierr, 115, where);
00475 b1 = substr.extent;
00476 if (--b < 0 || b + b1 > size)
00477 return 124;
00478 iva += b;
00479 b0 = size;
00480 size = b1;
00481 while(GETC(ch) <= ' ' && ch >= 0);
00482 if (b1 < b0)
00483 goto delta_adj;
00484 }
00485 if (readall)
00486 goto delta_adj;
00487 for(; dn0 < dn; dn0++) {
00488 if (dn0->extent != *dims++ || dn0->stride != 1)
00489 break;
00490 no1 *= dn0->extent;
00491 }
00492 if (dn0 == dimens && dimens[0].stride == 1) {
00493 no1 = dimens[0].extent;
00494 dn0++;
00495 }
00496 delta_adj:
00497 ex = 0;
00498 for(dn1 = dn0; dn1 <= dn; dn1++)
00499 ex += (dn1->extent-1)
00500 * (dn1->delta *= dn1->stride);
00501 for(dn1 = dn; dn1 > dn0; dn1--) {
00502 ex -= (dn1->extent - 1) * dn1->delta;
00503 dn1->delta -= ex;
00504 }
00505 }
00506 else if (dims = v->dims) {
00507 no = no1 = dims[1];
00508 ivae = iva + no*size;
00509 }
00510 else
00511 scalar:
00512 no = no1 = 1;
00513 if (ch != '=')
00514 errfl(a->cierr, 115, where);
00515 got1 = nml_read = 1;
00516 f__lcount = 0;
00517 readloop:
00518 for(;;) {
00519 if (iva >= ivae || iva < 0) {
00520 f__lquit = 1;
00521 goto mustend;
00522 }
00523 else if (iva + no1*size > ivae)
00524 no1 = (ivae - iva)/size;
00525 f__lquit = 0;
00526 if (k = l_read(&no1, vaddr + iva, size, type))
00527 return k;
00528 if (f__lquit == 1)
00529 return 0;
00530 if (readall) {
00531 iva += dn0->delta;
00532 if (f__lcount > 0) {
00533 no1 = (ivae - iva)/size;
00534 if (no1 > f__lcount)
00535 no1 = f__lcount;
00536 iva += no1 * dn0->delta;
00537 if (k = l_read(&no1, vaddr + iva,
00538 size, type))
00539 return k;
00540 }
00541 }
00542 mustend:
00543 GETC(ch);
00544 if (readall)
00545 if (iva >= ivae)
00546 readall = 0;
00547 else for(;;) {
00548 switch(ch) {
00549 case ' ':
00550 case '\t':
00551 case '\n':
00552 GETC(ch);
00553 continue;
00554 }
00555 break;
00556 }
00557 if (ch == '/' || ch == '$' || ch == '&') {
00558 f__lquit = 1;
00559 return 0;
00560 }
00561 else if (f__lquit) {
00562 while(ch <= ' ' && ch >= 0)
00563 GETC(ch);
00564 Ungetc(ch,f__cf);
00565 if (!Alpha[ch & 0xff] && ch >= 0)
00566 errfl(a->cierr, 125, where);
00567 break;
00568 }
00569 Ungetc(ch,f__cf);
00570 if (readall && !Alpha[ch & 0xff])
00571 goto readloop;
00572 if ((no -= no1) <= 0)
00573 break;
00574 for(dn1 = dn0; dn1 <= dn; dn1++) {
00575 if (++dn1->curval < dn1->extent) {
00576 iva += dn1->delta;
00577 goto readloop;
00578 }
00579 dn1->curval = 0;
00580 }
00581 break;
00582 }
00583 }
00584 }
00585
00586 integer
00587 #ifdef KR_headers
00588 s_rsne(a) cilist *a;
00589 #else
00590 s_rsne(cilist *a)
00591 #endif
00592 {
00593 extern int l_eof;
00594 int n;
00595
00596 f__external=1;
00597 l_eof = 0;
00598 if(n = c_le(a))
00599 return n;
00600 if(f__curunit->uwrt && f__nowreading(f__curunit))
00601 err(a->cierr,errno,where0);
00602 l_getc = t_getc;
00603 l_ungetc = un_getc;
00604 f__doend = xrd_SL;
00605 n = x_rsne(a);
00606 nml_read = 0;
00607 if (n)
00608 return n;
00609 return e_rsle();
00610 }
