Return to rsne.c CVS log

Up to [Research Unix] / researchv10dc / libI77

Annotation of researchv10dc/libI77/rsne.c, revision 1.1

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:                errfl(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: #ifndef No_Namelist_Questions
        !           263:  static Void
        !           264: #ifdef KR_headers
        !           265: print_ne(a) cilist *a;
        !           266: #else
        !           267: print_ne(cilist *a)
        !           268: #endif
        !           269: {
        !           270:        flag intext = f__external;
        !           271:        int rpsave = f__recpos;
        !           272:        FILE *cfsave = f__cf;
        !           273:        unit *usave = f__curunit;
        !           274:        cilist t;
        !           275:        t = *a;
        !           276:        t.ciunit = 6;
        !           277:        s_wsne(&t);
        !           278:        fflush(f__cf);
        !           279:        f__external = intext;
        !           280:        f__reading = 1;
        !           281:        f__recpos = rpsave;
        !           282:        f__cf = cfsave;
        !           283:        f__curunit = usave;
        !           284:        f__elist = a;
        !           285:        }
        !           286: #endif
        !           287: 
        !           288:  static char where0[] = "namelist read start ";
        !           289: 
        !           290: #ifdef KR_headers
        !           291: x_rsne(a) cilist *a;
        !           292: #else
        !           293: x_rsne(cilist *a)
        !           294: #endif
        !           295: {
        !           296:        int ch, got1, k, n, nd, quote;
        !           297:        Namelist *nl;
        !           298:        static char where[] = "namelist read";
        !           299:        char buf[64];
        !           300:        hashtab *ht;
        !           301:        Vardesc *v;
        !           302:        dimen *dn, *dn0, *dn1;
        !           303:        ftnlen *dims, *dims1;
        !           304:        ftnlen b, b0, b1, ex, no, no1, nomax, size, span;
        !           305:        ftnint type;
        !           306:        char *vaddr;
        !           307:        long iva, ivae;
        !           308:        dimen dimens[MAXDIM], substr;
        !           309: 
        !           310:        if (!Alpha['a'])
        !           311:                nl_init();
        !           312:        f__reading=1;
        !           313:        f__formatted=1;
        !           314:        got1 = 0;
        !           315:  top:
        !           316:        for(;;) switch(GETC(ch)) {
        !           317:                case EOF:
        !           318:                        err(a->ciend,(EOF),where0);
        !           319:                case '&':
        !           320:                case '$':
        !           321:                        goto have_amp;
        !           322: #ifndef No_Namelist_Questions
        !           323:                case '?':
        !           324:                        print_ne(a);
        !           325:                        continue;
        !           326: #endif
        !           327:                default:
        !           328:                        if (ch <= ' ' && ch >= 0)
        !           329:                                continue;
        !           330:                        errfl(a->cierr, 115, where0);
        !           331:                }
        !           332:  have_amp:
        !           333:        if (ch = getname(buf,sizeof(buf)))
        !           334:                return ch;
        !           335:        nl = (Namelist *)a->cifmt;
        !           336:        if (strcmp(buf, nl->name))
        !           337: #ifdef No_Bad_Namelist_Skip
        !           338:                errfl(a->cierr, 118, where0);
        !           339: #else
        !           340:        {
        !           341:                fprintf(stderr,
        !           342:                        "Skipping namelist \"%s\": seeking namelist \"%s\".\n",
        !           343:                        buf, nl->name);
        !           344:                fflush(stderr);
        !           345:                for(;;) switch(GETC(ch)) {
        !           346:                        case EOF:
        !           347:                                err(a->ciend, EOF, where0);
        !           348:                        case '/':
        !           349:                        case '&':
        !           350:                        case '$':
        !           351:                                if (f__external)
        !           352:                                        e_rsle();
        !           353:                                else
        !           354:                                        z_rnew();
        !           355:                                goto top;
        !           356:                        case '"':
        !           357:                        case '\'':
        !           358:                                quote = ch;
        !           359:  more_quoted:
        !           360:                                while(GETC(ch) != quote)
        !           361:                                        if (ch == EOF)
        !           362:                                                err(a->ciend, EOF, where0);
        !           363:                                if (GETC(ch) == quote)
        !           364:                                        goto more_quoted;
        !           365:                                Ungetc(ch,f__cf);
        !           366:                        default:
        !           367:                                continue;
        !           368:                        }
        !           369:                }
        !           370: #endif
        !           371:        ht = mk_hashtab(nl);
        !           372:        if (!ht)
        !           373:                errfl(f__elist->cierr, 113, where0);
        !           374:        for(;;) {
        !           375:                for(;;) switch(GETC(ch)) {
        !           376:                        case EOF:
        !           377:                                if (got1)
        !           378:                                        return 0;
        !           379:                                err(a->ciend, EOF, where0);
        !           380:                        case '/':
        !           381:                        case '$':
        !           382:                        case '&':
        !           383:                                return 0;
        !           384:                        default:
        !           385:                                if (ch <= ' ' && ch >= 0 || ch == ',')
        !           386:                                        continue;
        !           387:                                Ungetc(ch,f__cf);
        !           388:                                if (ch = getname(buf,sizeof(buf)))
        !           389:                                        return ch;
        !           390:                                goto havename;
        !           391:                        }
        !           392:  havename:
        !           393:                v = hash(ht,buf);
        !           394:                if (!v)
        !           395:                        errfl(a->cierr, 119, where);
        !           396:                while(GETC(ch) <= ' ' && ch >= 0);
        !           397:                vaddr = v->addr;
        !           398:                type = v->type;
        !           399:                if (type < 0) {
        !           400:                        size = -type;
        !           401:                        type = TYCHAR;
        !           402:                        }
        !           403:                else
        !           404:                        size = f__typesize[type];
        !           405:                ivae = size;
        !           406:                iva = 0;
        !           407:                if (ch == '(' /*)*/ ) {
        !           408:                        dn = dimens;
        !           409:                        if (!(dims = v->dims)) {
        !           410:                                if (type != TYCHAR)
        !           411:                                        errfl(a->cierr, 122, where);
        !           412:                                if (k = getdimen(&ch, dn, (ftnlen)size,
        !           413:                                                (ftnlen)size, &b))
        !           414:                                        errfl(a->cierr, k, where);
        !           415:                                if (ch != ')')
        !           416:                                        errfl(a->cierr, 115, where);
        !           417:                                b1 = dn->extent;
        !           418:                                if (--b < 0 || b + b1 > size)
        !           419:                                        return 124;
        !           420:                                iva += b;
        !           421:                                size = b1;
        !           422:                                while(GETC(ch) <= ' ' && ch >= 0);
        !           423:                                goto scalar;
        !           424:                                }
        !           425:                        nd = (int)dims[0];
        !           426:                        nomax = span = dims[1];
        !           427:                        ivae = iva + size*nomax;
        !           428:                        if (k = getdimen(&ch, dn, size, nomax, &b))
        !           429:                                errfl(a->cierr, k, where);
        !           430:                        no = dn->extent;
        !           431:                        b0 = dims[2];
        !           432:                        dims1 = dims += 3;
        !           433:                        ex = 1;
        !           434:                        for(n = 1; n++ < nd; dims++) {
        !           435:                                if (ch != ',')
        !           436:                                        errfl(a->cierr, 115, where);
        !           437:                                dn1 = dn + 1;
        !           438:                                span /= *dims;
        !           439:                                if (k = getdimen(&ch, dn1, dn->delta**dims,
        !           440:                                                span, &b1))
        !           441:                                        errfl(a->cierr, k, where);
        !           442:                                ex *= *dims;
        !           443:                                b += b1*ex;
        !           444:                                no *= dn1->extent;
        !           445:                                dn = dn1;
        !           446:                                }
        !           447:                        if (ch != ')')
        !           448:                                errfl(a->cierr, 115, where);
        !           449:                        b -= b0;
        !           450:                        if (b < 0 || b >= nomax)
        !           451:                                errfl(a->cierr, 125, where);
        !           452:                        iva += size * b;
        !           453:                        dims = dims1;
        !           454:                        while(GETC(ch) <= ' ' && ch >= 0);
        !           455:                        no1 = 1;
        !           456:                        dn0 = dimens;
        !           457:                        if (type == TYCHAR && ch == '(' /*)*/) {
        !           458:                                if (k = getdimen(&ch, &substr, size, size, &b))
        !           459:                                        errfl(a->cierr, k, where);
        !           460:                                if (ch != ')')
        !           461:                                        errfl(a->cierr, 115, where);
        !           462:                                b1 = substr.extent;
        !           463:                                if (--b < 0 || b + b1 > size)
        !           464:                                        return 124;
        !           465:                                iva += b;
        !           466:                                b0 = size;
        !           467:                                size = b1;
        !           468:                                while(GETC(ch) <= ' ' && ch >= 0);
        !           469:                                if (b1 < b0)
        !           470:                                        goto delta_adj;
        !           471:                                }
        !           472:                        for(; dn0 < dn; dn0++) {
        !           473:                                if (dn0->extent != *dims++ || dn0->stride != 1)
        !           474:                                        break;
        !           475:                                no1 *= dn0->extent;
        !           476:                                }
        !           477:                        if (dn0 == dimens && dimens[0].stride == 1) {
        !           478:                                no1 = dimens[0].extent;
        !           479:                                dn0++;
        !           480:                                }
        !           481:  delta_adj:
        !           482:                        ex = 0;
        !           483:                        for(dn1 = dn0; dn1 <= dn; dn1++)
        !           484:                                ex += (dn1->extent-1)
        !           485:                                        * (dn1->delta *= dn1->stride);
        !           486:                        for(dn1 = dn; dn1 > dn0; dn1--) {
        !           487:                                ex -= (dn1->extent - 1) * dn1->delta;
        !           488:                                dn1->delta -= ex;
        !           489:                                }
        !           490:                        }
        !           491:                else if (dims = v->dims) {
        !           492:                        no = no1 = dims[1];
        !           493:                        ivae = iva + no*size;
        !           494:                        }
        !           495:                else
        !           496:  scalar:
        !           497:                        no = no1 = 1;
        !           498:                if (ch != '=')
        !           499:                        errfl(a->cierr, 115, where);
        !           500:                got1 = nml_read = 1;
        !           501:                f__lcount = 0;
        !           502:         readloop:
        !           503:                for(;;) {
        !           504:                        if (iva >= ivae || iva < 0) {
        !           505:                                f__lquit = 1;
        !           506:                                goto mustend;
        !           507:                                }
        !           508:                        else if (iva + no1*size > ivae)
        !           509:                                no1 = (ivae - iva)/size;
        !           510:                        f__lquit = 0;
        !           511:                        if (k = l_read(&no1, vaddr + iva, size, type))
        !           512:                                return k;
        !           513:                        if (f__lquit == 1)
        !           514:                                return 0;
        !           515:  mustend:
        !           516:                        if (GETC(ch) == '/' || ch == '$' || ch == '&') {
        !           517:                                f__lquit = 1;
        !           518:                                return 0;
        !           519:                                }
        !           520:                        else if (f__lquit) {
        !           521:                                while(ch <= ' ' && ch >= 0)
        !           522:                                        GETC(ch);
        !           523:                                Ungetc(ch,f__cf);
        !           524:                                if (!Alpha[ch & 0xff] && ch >= 0)
        !           525:                                        errfl(a->cierr, 125, where);
        !           526:                                break;
        !           527:                                }
        !           528:                        Ungetc(ch,f__cf);
        !           529:                        if ((no -= no1) <= 0)
        !           530:                                break;
        !           531:                        for(dn1 = dn0; dn1 <= dn; dn1++) {
        !           532:                                if (++dn1->curval < dn1->extent) {
        !           533:                                        iva += dn1->delta;
        !           534:                                        goto readloop;
        !           535:                                        }
        !           536:                                dn1->curval = 0;
        !           537:                                }
        !           538:                        break;
        !           539:                        }
        !           540:                }
        !           541:        }
        !           542: 
        !           543:  integer
        !           544: #ifdef KR_headers
        !           545: s_rsne(a) cilist *a;
        !           546: #else
        !           547: s_rsne(cilist *a)
        !           548: #endif
        !           549: {
        !           550:        extern int l_eof;
        !           551:        int n;
        !           552: 
        !           553:        f__external=1;
        !           554:        l_eof = 0;
        !           555:        if(n = c_le(a))
        !           556:                return n;
        !           557:        if(f__curunit->uwrt && f__nowreading(f__curunit))
        !           558:                err(a->cierr,errno,where0);
        !           559:        l_getc = t_getc;
        !           560:        l_ungetc = un_getc;
        !           561:        f__doend = xrd_SL;
        !           562:        if (n = x_rsne(a))
        !           563:                return n;
        !           564:        return e_rsle();
        !           565:        }

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.