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