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