Return to data.c CVS log

Up to [CSRG BSD Unix] / 43BSDTahoe / usr.bin / f77 / f77.tahoe / f77pass1

Annotation of 43BSDTahoe/usr.bin/f77/f77.tahoe/f77pass1/data.c, revision 1.1

1.1     ! root        1: /*
        !             2:  * Copyright (c) 1980 Regents of the University of California.
        !             3:  * All rights reserved.  The Berkeley software License Agreement
        !             4:  * specifies the terms and conditions for redistribution.
        !             5:  */
        !             6: 
        !             7: #ifndef lint
        !             8: static char sccsid[] = "@(#)data.c     5.1 (Berkeley) 6/7/85";
        !             9: #endif not lint
        !            10: 
        !            11: /*
        !            12:  * data.c
        !            13:  *
        !            14:  * Routines for handling DATA statements, f77 compiler, 4.2 BSD.
        !            15:  *
        !            16:  * University of Utah CS Dept modification history:
        !            17:  *
        !            18:  * Revision 3.1  84/10/13  01:09:50  donn
        !            19:  * Installed Jerry Berkman's version; added UofU comment header.
        !            20:  * 
        !            21:  */
        !            22: 
        !            23: #include "defs.h"
        !            24: #include "data.h"
        !            25: 
        !            26: 
        !            27: /*  global variables  */
        !            28: 
        !            29: flag overlapflag;
        !            30: 
        !            31: 
        !            32: 
        !            33: /*  local variables  */
        !            34: 
        !            35: LOCAL char rstatus;
        !            36: LOCAL ftnint rvalue;
        !            37: LOCAL dovars *dvlist;
        !            38: LOCAL int dataerror;
        !            39: LOCAL vallist *grvals;
        !            40: LOCAL int datafile;
        !            41: LOCAL int chkfile;
        !            42: LOCAL long base;
        !            43: 
        !            44: 
        !            45: 
        !            46: /*  Copied from expr.c  */
        !            47: 
        !            48: LOCAL letter(c)
        !            49: register int c;
        !            50: {
        !            51: if( isupper(c) )
        !            52:        c = tolower(c);
        !            53: return(c - 'a');
        !            54: }
        !            55: 
        !            56: 
        !            57: 
        !            58: vexpr *
        !            59: cpdvalue(dp)
        !            60: vexpr *dp;
        !            61: {
        !            62:   register dvalue *p;
        !            63: 
        !            64:   if (dp->tag != DVALUE)
        !            65:     badtag("cpdvalue", dp->tag);
        !            66: 
        !            67:   p = ALLOC(Dvalue);
        !            68:   p->tag = DVALUE;
        !            69:   p->status = dp->dvalue.status;
        !            70:   p->value = dp->dvalue.value;
        !            71: 
        !            72:   return ((vexpr *) p);
        !            73: }
        !            74: 
        !            75: 
        !            76: 
        !            77: frvexpr(vp)
        !            78: register vexpr *vp;
        !            79: {
        !            80:   if (vp != NULL)
        !            81:     {
        !            82:       if (vp->tag == DNAME)
        !            83:        free(vp->dname.repr);
        !            84:       else if (vp->tag == DEXPR)
        !            85:        {
        !            86:          frvexpr(vp->dexpr.left);
        !            87:          frvexpr(vp->dexpr.right);
        !            88:        }
        !            89: 
        !            90:       free((char *) vp);
        !            91:     }
        !            92: 
        !            93:   return;
        !            94: }
        !            95: 
        !            96: 
        !            97: 
        !            98: frvlist(vp)
        !            99: register vlist *vp;
        !           100: {
        !           101:   register vlist *t;
        !           102: 
        !           103:   while (vp)
        !           104:     {
        !           105:       t = vp->next;
        !           106:       frvexpr(vp->val);
        !           107:       free((char *) vp);
        !           108:       vp = t;
        !           109:     }
        !           110: 
        !           111:   return;
        !           112: }
        !           113: 
        !           114: 
        !           115: 
        !           116: frelist(ep)
        !           117: elist *ep;
        !           118: {
        !           119:   register elist *p;
        !           120:   register elist *t;
        !           121:   register aelt *ap;
        !           122:   register dolist *dp;
        !           123: 
        !           124:   p = ep;
        !           125: 
        !           126:   while (p != NULL)
        !           127:     {
        !           128:       if (p->elt->tag == SIMPLE)
        !           129:        {
        !           130:          ap = (aelt *) p->elt;
        !           131:          frvlist(ap->subs);
        !           132:          if (ap->range != NULL)
        !           133:            {
        !           134:              frvexpr(ap->range->low);
        !           135:              frvexpr(ap->range->high);
        !           136:              free((char *) ap->range);
        !           137:            }
        !           138:          free((char *) ap);
        !           139:        }
        !           140:       else
        !           141:        {
        !           142:          dp = (dolist *) p->elt;
        !           143:          frvexpr(dp->dovar);
        !           144:          frvexpr(dp->init);
        !           145:          frvexpr(dp->limit);
        !           146:          frvexpr(dp->step);
        !           147:          frelist(dp->elts);
        !           148:          free((char *) dp);
        !           149:        }
        !           150: 
        !           151:       t = p;
        !           152:       p = p->next;
        !           153:       free((char *) t);
        !           154:     }
        !           155: 
        !           156:   return;
        !           157: }
        !           158: 
        !           159: 
        !           160: 
        !           161: frvallist(vp)
        !           162: vallist *vp;
        !           163: {
        !           164:   register vallist *p;
        !           165:   register vallist *t;
        !           166: 
        !           167:   p = vp;
        !           168:   while (p != NULL)
        !           169:     {
        !           170:       frexpr((tagptr) p->value);
        !           171:       t = p;
        !           172:       p = p->next;
        !           173:       free((char *) t);
        !           174:     }
        !           175: 
        !           176:   return;
        !           177: }
        !           178: 
        !           179: 
        !           180: 
        !           181: elist *revelist(ep)
        !           182: register elist *ep;
        !           183: {
        !           184:   register elist *next;
        !           185:   register elist *t;
        !           186: 
        !           187:   if (ep != NULL)
        !           188:     {
        !           189:       next = ep->next;
        !           190:       ep->next = NULL;
        !           191: 
        !           192:       while (next)
        !           193:        {
        !           194:          t = next->next;
        !           195:          next->next = ep;
        !           196:          ep = next;
        !           197:          next = t;
        !           198:        }
        !           199:     }
        !           200: 
        !           201:   return (ep);
        !           202: }
        !           203: 
        !           204: 
        !           205: 
        !           206: vlist *revvlist(vp)
        !           207: vlist *vp;
        !           208: {
        !           209:   register vlist *p;
        !           210:   register vlist *next;
        !           211:   register vlist *t;
        !           212: 
        !           213:   if (vp == NULL)
        !           214:     p = NULL;
        !           215:   else
        !           216:     {
        !           217:       p = vp;
        !           218:       next = p->next;
        !           219:       p->next = NULL;
        !           220: 
        !           221:       while (next)
        !           222:        {
        !           223:          t = next->next;
        !           224:          next->next = p;
        !           225:          p = next;
        !           226:          next = t;
        !           227:        }
        !           228:     }
        !           229: 
        !           230:   return (p);
        !           231: }
        !           232: 
        !           233: 
        !           234: 
        !           235: vallist *
        !           236: revrvals(vp)
        !           237: vallist *vp;
        !           238: {
        !           239:   register vallist *p;
        !           240:   register vallist *next;
        !           241:   register vallist *t;
        !           242: 
        !           243:   if (vp == NULL)
        !           244:     p = NULL;
        !           245:   else
        !           246:     {
        !           247:       p = vp;
        !           248:       next = p->next;
        !           249:       p->next = NULL;
        !           250:       while (next)
        !           251:        {
        !           252:          t = next->next;
        !           253:          next->next = p;
        !           254:          p = next;
        !           255:          next = t;
        !           256:        }
        !           257:     }
        !           258: 
        !           259:   return (p);
        !           260: }
        !           261: 
        !           262: 
        !           263: 
        !           264: vlist *prepvexpr(tail, head)
        !           265: vlist *tail;
        !           266: vexpr *head;
        !           267: {
        !           268:   register vlist *p;
        !           269: 
        !           270:   p = ALLOC(Vlist);
        !           271:   p->next = tail;
        !           272:   p->val = head;
        !           273: 
        !           274:   return (p);
        !           275: }
        !           276: 
        !           277: 
        !           278: 
        !           279: elist *preplval(tail, head)
        !           280: elist *tail;
        !           281: delt* head;
        !           282: {
        !           283:   register elist *p;
        !           284:   p = ALLOC(Elist);
        !           285:   p->next = tail;
        !           286:   p->elt = head;
        !           287: 
        !           288:   return (p);
        !           289: }
        !           290: 
        !           291: 
        !           292: 
        !           293: delt *mkdlval(name, subs, range)
        !           294: vexpr *name;
        !           295: vlist *subs;
        !           296: rpair *range;
        !           297: {
        !           298:   static char *iscomm =" improper initialization for variable in COMMON";
        !           299:   register aelt *p;
        !           300: 
        !           301:   p = ALLOC(Aelt);
        !           302:   p->tag = SIMPLE;
        !           303:   p->var = mkname(name->dname.len, name->dname.repr);
        !           304:   if ((procclass != CLBLOCK) && (p->var->vstg == STGCOMMON))
        !           305:        warn(iscomm);
        !           306:   p->subs = subs;
        !           307:   p->range = range;
        !           308: 
        !           309:   return ((delt *) p);
        !           310: }
        !           311: 
        !           312: 
        !           313: 
        !           314: delt *mkdatado(lvals, dovar, params)
        !           315: elist *lvals;
        !           316: vexpr *dovar;
        !           317: vlist *params;
        !           318: {
        !           319:   static char *toofew = "missing loop parameters";
        !           320:   static char *toomany = "too many loop parameters";
        !           321: 
        !           322:   register dolist *p;
        !           323:   register vlist *vp;
        !           324:   register int pcnt;
        !           325:   register dvalue *one;
        !           326: 
        !           327:   p = ALLOC(DoList);
        !           328:   p->tag = NESTED;
        !           329:   p->elts = revelist(lvals);
        !           330:   p->dovar = dovar;
        !           331: 
        !           332:   vp = params;
        !           333:   pcnt = 0;
        !           334:   while (vp)
        !           335:     {
        !           336:       pcnt++;
        !           337:       vp = vp->next;
        !           338:     }
        !           339: 
        !           340:   if (pcnt != 2 && pcnt != 3)
        !           341:     {
        !           342:       if (pcnt < 2)
        !           343:        err(toofew);
        !           344:       else
        !           345:        err(toomany);
        !           346: 
        !           347:       p->init = (vexpr *) ALLOC(Derror);
        !           348:       p->init->tag = DERROR;
        !           349: 
        !           350:       p->limit = (vexpr *) ALLOC(Derror);
        !           351:       p->limit->tag = DERROR;
        !           352: 
        !           353:       p->step = (vexpr *) ALLOC(Derror);
        !           354:       p->step->tag = DERROR;
        !           355:     }
        !           356:   else
        !           357:     {
        !           358:       vp = params;
        !           359: 
        !           360:       if (pcnt == 2)
        !           361:        {
        !           362:          one = ALLOC(Dvalue);
        !           363:          one->tag = DVALUE;
        !           364:          one->status = NORMAL;
        !           365:          one->value = 1;
        !           366:          p->step = (vexpr *) one;
        !           367:        }
        !           368:       else
        !           369:        {
        !           370:          p->step = vp->val;
        !           371:          vp->val = NULL;
        !           372:          vp = vp->next;
        !           373:        }
        !           374: 
        !           375:       p->limit = vp->val;
        !           376:       vp->val = NULL;
        !           377:       vp = vp->next;
        !           378: 
        !           379:       p->init = vp->val;
        !           380:       vp->val = NULL;
        !           381:     }
        !           382: 
        !           383:   frvlist(params);
        !           384:   return ((delt *) p);
        !           385: }
        !           386: 
        !           387: 
        !           388: 
        !           389: rpair *mkdrange(lb, ub)
        !           390: vexpr *lb, *ub;
        !           391: {
        !           392:   register rpair *p;
        !           393: 
        !           394:   p = ALLOC(Rpair);
        !           395:   p->low = lb;
        !           396:   p->high = ub;
        !           397: 
        !           398:   return (p);
        !           399: }
        !           400: 
        !           401: 
        !           402: 
        !           403: vallist *mkdrval(repl, val)
        !           404: vexpr *repl;
        !           405: expptr val;
        !           406: {
        !           407:   static char *badtag = "bad tag in mkdrval";
        !           408:   static char *negrepl = "negative replicator";
        !           409:   static char *zerorepl = "zero replicator";
        !           410:   static char *toobig = "replicator too large";
        !           411:   static char *nonconst = "%s is not a constant";
        !           412: 
        !           413:   register vexpr *vp;
        !           414:   register vallist *p;
        !           415:   register int status;
        !           416:   register ftnint value;
        !           417:   register int copied;
        !           418: 
        !           419:   copied = 0;
        !           420: 
        !           421:   if (repl->tag == DNAME)
        !           422:     {
        !           423:       vp = evaldname(repl);
        !           424:       copied = 1;
        !           425:     }
        !           426:   else
        !           427:     vp = repl;
        !           428: 
        !           429:   p = ALLOC(ValList);
        !           430:   p->next = NULL;
        !           431:   p->value = (Constp) val;
        !           432: 
        !           433:   if (vp->tag == DVALUE)
        !           434:     {
        !           435:       status = vp->dvalue.status;
        !           436:       value = vp->dvalue.value;
        !           437: 
        !           438:       if ((status == NORMAL && value < 0) || status == MINLESS1)
        !           439:        {
        !           440:          err(negrepl);
        !           441:          p->status = ERRVAL;
        !           442:        }
        !           443:       else if (status == NORMAL)
        !           444:        {
        !           445:          if (value == 0)
        !           446:            warn(zerorepl);
        !           447:          p->status = NORMAL;
        !           448:          p->repl = value;
        !           449:        }
        !           450:       else if (status == MAXPLUS1)
        !           451:        {
        !           452:          err(toobig);
        !           453:          p->status = ERRVAL;
        !           454:        }
        !           455:       else
        !           456:        p->status = ERRVAL;
        !           457:     }
        !           458:   else if (vp->tag == DNAME)
        !           459:     {
        !           460:       errnm(nonconst, vp->dname.len, vp->dname.repr);
        !           461:       p->status = ERRVAL;
        !           462:     }
        !           463:   else if (vp->tag == DERROR)
        !           464:     p->status = ERRVAL;
        !           465:   else
        !           466:     fatal(badtag);
        !           467: 
        !           468:   if (copied) frvexpr(vp);
        !           469:   return (p);
        !           470: }
        !           471: 
        !           472: 
        !           473: 
        !           474: /*  Evicon returns the value of the integer constant  */
        !           475: /*  pointed to by token.                              */
        !           476: 
        !           477: vexpr *evicon(len, token)
        !           478: register int len;
        !           479: register char *token;
        !           480: {
        !           481:   static char *badconst = "bad integer constant";
        !           482:   static char *overflow = "integer constant too large";
        !           483: 
        !           484:   register int i;
        !           485:   register ftnint val;
        !           486:   register int digit;
        !           487:   register dvalue *p;
        !           488: 
        !           489:   if (len <= 0)
        !           490:     fatal(badconst);
        !           491: 
        !           492:   p = ALLOC(Dvalue);
        !           493:   p->tag = DVALUE;
        !           494: 
        !           495:   i = 0;
        !           496:   val = 0;
        !           497:   while (i < len)
        !           498:     {
        !           499:       if (val > MAXINT/10)
        !           500:        {
        !           501:          err(overflow);
        !           502:          p->status = ERRVAL;
        !           503:          goto ret;
        !           504:        }
        !           505:       val = 10*val;
        !           506:       digit = token[i++];
        !           507:       if (!isdigit(digit))
        !           508:        fatal(badconst);
        !           509:       digit = digit - '0';
        !           510:       if (MAXINT - val >= digit)
        !           511:        val = val + digit;
        !           512:       else
        !           513:        if (i == len && MAXINT - val + 1 == digit)
        !           514:          {
        !           515:            p->status = MAXPLUS1;
        !           516:            goto ret;
        !           517:          }
        !           518:        else
        !           519:          {
        !           520:            err(overflow);
        !           521:            p->status = ERRVAL;
        !           522:            goto ret;
        !           523:          }
        !           524:     }
        !           525: 
        !           526:   p->status = NORMAL;
        !           527:   p->value = val;
        !           528: 
        !           529: ret:
        !           530:   return ((vexpr *) p);
        !           531: }
        !           532: 
        !           533: 
        !           534: 
        !           535: /*  Ivaltoicon converts a dvalue into a constant block.  */
        !           536: 
        !           537: expptr ivaltoicon(vp)
        !           538: register vexpr *vp;
        !           539: {
        !           540:   static char *badtag = "bad tag in ivaltoicon";
        !           541:   static char *overflow = "integer constant too large";
        !           542: 
        !           543:   register int vs;
        !           544:   register expptr p;
        !           545: 
        !           546:   if (vp->tag == DERROR)
        !           547:     return(errnode());
        !           548:   else if (vp->tag != DVALUE)
        !           549:     fatal(badtag);
        !           550: 
        !           551:   vs = vp->dvalue.status;
        !           552:   if (vs == NORMAL)
        !           553:     p = mkintcon(vp->dvalue.value);
        !           554:   else if ((MAXINT + MININT == -1) && vs == MINLESS1)
        !           555:     p = mkintcon(MININT);
        !           556:   else if (vs == MAXPLUS1 || vs == MINLESS1)
        !           557:     {
        !           558:       err(overflow);
        !           559:       p = errnode();
        !           560:     }
        !           561:   else
        !           562:     p = errnode();
        !           563: 
        !           564:   return (p);
        !           565: }
        !           566: 
        !           567: 
        !           568: 
        !           569: /*  Mkdname stores an identifier as a dname  */
        !           570: 
        !           571: vexpr *mkdname(len, str)
        !           572: int len;
        !           573: register char *str;
        !           574: {
        !           575:   register dname *p;
        !           576:   register int i;
        !           577:   register char *s;
        !           578: 
        !           579:   s = (char *) ckalloc(len + 1);
        !           580:   i = len;
        !           581:   s[i] = '\0';
        !           582: 
        !           583:   while (--i >= 0)
        !           584:     s[i] = str[i];
        !           585: 
        !           586:   p = ALLOC(Dname);
        !           587:   p->tag = DNAME;
        !           588:   p->len = len;
        !           589:   p->repr = s;
        !           590: 
        !           591:   return ((vexpr *) p);
        !           592: }
        !           593: 
        !           594: 
        !           595: 
        !           596: /*  Getname gets the symbol table information associated with  */
        !           597: /*  a name.  Getname differs from mkname in that it will not   */
        !           598: /*  add the name to the symbol table if it is not already      */
        !           599: /*  present.                                                   */
        !           600: 
        !           601: Namep getname(l, s)
        !           602: int l;
        !           603: register char *s;
        !           604: {
        !           605:   struct Hashentry *hp;
        !           606:   int hash;
        !           607:   register Namep q;
        !           608:   register int i;
        !           609:   char n[VL];
        !           610: 
        !           611:   hash = 0;
        !           612:   for (i = 0; i < l && *s != '\0'; ++i)
        !           613:     {
        !           614:       hash += *s;
        !           615:       n[i] = *s++;
        !           616:     }
        !           617: 
        !           618:   while (i < VL)
        !           619:     n[i++] = ' ';
        !           620: 
        !           621:   hash %= maxhash;
        !           622:   hp = hashtab + hash;
        !           623: 
        !           624:   while (q = hp->varp)
        !           625:     if (hash == hp->hashval
        !           626:        && eqn(VL, n, q->varname))
        !           627:       goto ret;
        !           628:     else if (++hp >= lasthash)
        !           629:       hp = hashtab;
        !           630: 
        !           631: ret:
        !           632:   return (q);
        !           633: }
        !           634: 
        !           635: 
        !           636: 
        !           637: /*  Evparam returns the value of the constant named by name.  */
        !           638: 
        !           639: expptr evparam(np)
        !           640: register vexpr *np;
        !           641: {
        !           642:   static char *badtag = "bad tag in evparam";
        !           643:   static char *undefined = "%s is undefined";
        !           644:   static char *nonconst = "%s is not constant";
        !           645: 
        !           646:   register struct Paramblock *tp;
        !           647:   register expptr p;
        !           648:   register int len;
        !           649:   register char *repr;
        !           650: 
        !           651:   if (np->tag != DNAME)
        !           652:     fatal(badtag);
        !           653: 
        !           654:   len = np->dname.len;
        !           655:   repr = np->dname.repr;
        !           656: 
        !           657:   tp = (struct Paramblock *) getname(len, repr);
        !           658: 
        !           659:   if (tp == NULL)
        !           660:     {
        !           661:       errnm(undefined, len, repr);
        !           662:       p = errnode();
        !           663:     }
        !           664:   else if (tp->vclass != CLPARAM || !ISCONST(tp->paramval))
        !           665:     {
        !           666:       if (tp->paramval->tag != TERROR)
        !           667:         errnm(nonconst, len, repr);
        !           668:       p = errnode();
        !           669:     }
        !           670:   else
        !           671:     p = (expptr) cpexpr(tp->paramval);
        !           672: 
        !           673:   return (p);
        !           674: }
        !           675: 
        !           676: 
        !           677: 
        !           678: vexpr *evaldname(dp)
        !           679: vexpr *dp;
        !           680: {
        !           681:   static char *undefined = "%s is undefined";
        !           682:   static char *nonconst = "%s is not a constant";
        !           683:   static char *nonint = "%s is not an integer";
        !           684: 
        !           685:   register dvalue *p;
        !           686:   register struct Paramblock *tp;
        !           687:   register int len;
        !           688:   register char *repr;
        !           689: 
        !           690:   p = ALLOC(Dvalue);
        !           691:   p->tag = DVALUE;
        !           692: 
        !           693:   len = dp->dname.len;
        !           694:   repr = dp->dname.repr;
        !           695: 
        !           696:   tp = (struct Paramblock *) getname(len, repr);
        !           697: 
        !           698:   if (tp == NULL)
        !           699:     {
        !           700:       errnm(undefined, len, repr);
        !           701:       p->status = ERRVAL;
        !           702:     }
        !           703:   else if (tp->vclass != CLPARAM || !ISCONST(tp->paramval))
        !           704:     {
        !           705:       if (tp->paramval->tag != TERROR)
        !           706:         errnm(nonconst, len, repr);
        !           707:       p->status = ERRVAL;
        !           708:     }
        !           709:   else if (!ISINT(tp->paramval->constblock.vtype))
        !           710:     {
        !           711:       errnm(nonint, len, repr);
        !           712:       p->status = ERRVAL;
        !           713:     }
        !           714:   else
        !           715:     {
        !           716:       if ((MAXINT + MININT == -1)
        !           717:          && tp->paramval->constblock.const.ci == MININT)
        !           718:        p->status = MINLESS1;
        !           719:       else
        !           720:        {
        !           721:          p->status = NORMAL;
        !           722:           p->value = tp->paramval->constblock.const.ci;
        !           723:        }
        !           724:     }
        !           725: 
        !           726:   return ((vexpr *) p);
        !           727: }
        !           728: 
        !           729: 
        !           730: 
        !           731: vexpr *mkdexpr(op, l, r)
        !           732: register int op;
        !           733: register vexpr *l;
        !           734: register vexpr *r;
        !           735: {
        !           736:   static char *badop = "bad operator in mkdexpr";
        !           737: 
        !           738:   register vexpr *p;
        !           739: 
        !           740:   switch (op)
        !           741:     {
        !           742:     default:
        !           743:       fatal(badop);
        !           744: 
        !           745:     case OPNEG:
        !           746:     case OPPLUS:
        !           747:     case OPMINUS:
        !           748:     case OPSTAR:
        !           749:     case OPSLASH:
        !           750:     case OPPOWER:
        !           751:       break;
        !           752:     }
        !           753: 
        !           754:   if ((l != NULL && l->tag == DERROR) || r->tag == DERROR)
        !           755:     {
        !           756:       frvexpr(l);
        !           757:       frvexpr(r);
        !           758:       p = (vexpr *) ALLOC(Derror);
        !           759:       p->tag = DERROR;
        !           760:     }
        !           761:   else if (op == OPNEG && r->tag == DVALUE)
        !           762:     {
        !           763:       p = negival(r);
        !           764:       frvexpr(r);
        !           765:     }
        !           766:   else if (op != OPNEG && l->tag == DVALUE && r->tag == DVALUE)
        !           767:     {
        !           768:       switch (op)
        !           769:        {
        !           770:        case OPPLUS:
        !           771:          p = addivals(l, r);
        !           772:          break;
        !           773: 
        !           774:        case OPMINUS:
        !           775:          p = subivals(l, r);
        !           776:          break;
        !           777: 
        !           778:        case OPSTAR:
        !           779:          p = mulivals(l, r);
        !           780:          break;
        !           781: 
        !           782:        case OPSLASH:
        !           783:          p = divivals(l, r);
        !           784:          break;
        !           785: 
        !           786:        case OPPOWER:
        !           787:          p = powivals(l, r);
        !           788:          break;
        !           789:        }
        !           790: 
        !           791:       frvexpr(l);
        !           792:       frvexpr(r);
        !           793:     }
        !           794:   else
        !           795:     {
        !           796:       p = (vexpr *) ALLOC(Dexpr);
        !           797:       p->tag = DEXPR;
        !           798:       p->dexpr.opcode = op;
        !           799:       p->dexpr.left = l;
        !           800:       p->dexpr.right = r;
        !           801:     }
        !           802: 
        !           803:   return (p);
        !           804: }
        !           805: 
        !           806: 
        !           807: 
        !           808: vexpr *addivals(l, r)
        !           809: vexpr *l;
        !           810: vexpr *r;
        !           811: {
        !           812:   static char *badtag = "bad tag in addivals";
        !           813:   static char *overflow = "integer value too large";
        !           814: 
        !           815:   register int ls, rs;
        !           816:   register ftnint lv, rv;
        !           817:   register dvalue *p;
        !           818:   register ftnint k;
        !           819: 
        !           820:   if (l->tag != DVALUE || r->tag != DVALUE)
        !           821:     fatal(badtag);
        !           822: 
        !           823:   ls = l->dvalue.status;
        !           824:   lv = l->dvalue.value;
        !           825:   rs = r->dvalue.status;
        !           826:   rv = r->dvalue.value;
        !           827: 
        !           828:   p = ALLOC(Dvalue);
        !           829:   p->tag = DVALUE;
        !           830: 
        !           831:   if (ls == ERRVAL || rs == ERRVAL)
        !           832:     p->status = ERRVAL;
        !           833: 
        !           834:   else if (ls == NORMAL && rs == NORMAL)
        !           835:     {
        !           836:       addints(lv, rv);
        !           837:       if (rstatus == ERRVAL)
        !           838:        err(overflow);
        !           839:       p->status = rstatus;
        !           840:       p->value = rvalue;
        !           841:     }
        !           842: 
        !           843:   else
        !           844:     {
        !           845:       if (rs == MAXPLUS1 || rs == MINLESS1)
        !           846:        {
        !           847:          rs = ls;
        !           848:          rv = lv;
        !           849:          ls = r->dvalue.status;
        !           850:        }
        !           851: 
        !           852:       if (rs == NORMAL && rv == 0)
        !           853:        p->status = ls;
        !           854:       else if (ls == MAXPLUS1)
        !           855:        {
        !           856:          if (rs == NORMAL && rv < 0)
        !           857:            {
        !           858:              p->status = NORMAL;
        !           859:              k = MAXINT + rv;
        !           860:              p->value = k + 1;
        !           861:            }
        !           862:          else if (rs == MINLESS1)
        !           863:            {
        !           864:              p->status = NORMAL;
        !           865:              p->value = 0;
        !           866:            }
        !           867:          else
        !           868:            {
        !           869:              err(overflow);
        !           870:              p->status = ERRVAL;
        !           871:            }
        !           872:        }
        !           873:       else
        !           874:        {
        !           875:          if (rs == NORMAL && rv > 0)
        !           876:            {
        !           877:              p->status = NORMAL;
        !           878:              k = ( -MAXINT ) + rv;
        !           879:              p->value = k - 1;
        !           880:            }
        !           881:          else if (rs == MAXPLUS1)
        !           882:            {
        !           883:              p->status = NORMAL;
        !           884:              p->value = 0;
        !           885:            }
        !           886:          else
        !           887:            {
        !           888:              err(overflow);
        !           889:              p->status = ERRVAL;
        !           890:            }
        !           891:        }
        !           892:     }
        !           893: 
        !           894:   return ((vexpr *) p);
        !           895: }
        !           896: 
        !           897: 
        !           898: 
        !           899: vexpr *negival(vp)
        !           900: vexpr *vp;
        !           901: {
        !           902:   static char *badtag = "bad tag in negival";
        !           903: 
        !           904:   register int vs;
        !           905:   register dvalue *p;
        !           906: 
        !           907:   if (vp->tag != DVALUE)
        !           908:     fatal(badtag);
        !           909: 
        !           910:   vs = vp->dvalue.status;
        !           911: 
        !           912:   p = ALLOC(Dvalue);
        !           913:   p->tag = DVALUE;
        !           914: 
        !           915:   if (vs == ERRVAL)
        !           916:     p->status = ERRVAL;
        !           917:   else if (vs == NORMAL)
        !           918:     {
        !           919:       p->status = NORMAL;
        !           920:       p->value = -(vp->dvalue.value);
        !           921:     }
        !           922:   else if (vs == MAXPLUS1)
        !           923:     p->status = MINLESS1;
        !           924:   else
        !           925:     p->status = MAXPLUS1;
        !           926: 
        !           927:   return ((vexpr *) p);
        !           928: }
        !           929: 
        !           930: 
        !           931: 
        !           932: vexpr *subivals(l, r)
        !           933: vexpr *l;
        !           934: vexpr *r;
        !           935: {
        !           936:   static char *badtag = "bad tag in subivals";
        !           937: 
        !           938:   register vexpr *p;
        !           939:   register vexpr *t;
        !           940: 
        !           941:   if (l->tag != DVALUE || r->tag != DVALUE)
        !           942:     fatal(badtag);
        !           943: 
        !           944:   t = negival(r);
        !           945:   p = addivals(l, t);
        !           946:   frvexpr(t);
        !           947: 
        !           948:   return (p);
        !           949: }
        !           950: 
        !           951: 
        !           952: 
        !           953: vexpr *mulivals(l, r)
        !           954: vexpr *l;
        !           955: vexpr *r;
        !           956: {
        !           957:   static char *badtag = "bad tag in mulivals";
        !           958:   static char *overflow = "integer value too large";
        !           959: 
        !           960:   register int ls, rs;
        !           961:   register ftnint lv, rv;
        !           962:   register dvalue *p;
        !           963: 
        !           964:   if (l->tag != DVALUE || r->tag != DVALUE)
        !           965:     fatal(badtag);
        !           966: 
        !           967:   ls = l->dvalue.status;
        !           968:   lv = l->dvalue.value;
        !           969:   rs = r->dvalue.status;
        !           970:   rv = r->dvalue.value;
        !           971: 
        !           972:   p = ALLOC(Dvalue);
        !           973:   p->tag = DVALUE;
        !           974: 
        !           975:   if (ls == ERRVAL || rs == ERRVAL)
        !           976:     p->status = ERRVAL;
        !           977: 
        !           978:   else if (ls == NORMAL && rs == NORMAL)
        !           979:     {
        !           980:       mulints(lv, rv);
        !           981:       if (rstatus == ERRVAL)
        !           982:        err(overflow);
        !           983:       p->status = rstatus;
        !           984:       p->value = rvalue;
        !           985:     }
        !           986:   else
        !           987:     {
        !           988:       if (rs == MAXPLUS1 || rs == MINLESS1)
        !           989:        {
        !           990:          rs = ls;
        !           991:          rv = lv;
        !           992:          ls = r->dvalue.status;
        !           993:        }
        !           994: 
        !           995:       if (rs == NORMAL && rv == 0)
        !           996:        {
        !           997:          p->status = NORMAL;
        !           998:          p->value = 0;
        !           999:        }
        !          1000:       else if (rs == NORMAL && rv == 1)
        !          1001:        p->status = ls;
        !          1002:       else if (rs == NORMAL && rv == -1)
        !          1003:        if (ls == MAXPLUS1)
        !          1004:          p->status = MINLESS1;
        !          1005:        else
        !          1006:          p->status = MAXPLUS1;
        !          1007:       else
        !          1008:        {
        !          1009:          err(overflow);
        !          1010:          p->status = ERRVAL;
        !          1011:        }
        !          1012:     }
        !          1013: 
        !          1014:   return ((vexpr *) p);
        !          1015: }
        !          1016: 
        !          1017: 
        !          1018: 
        !          1019: vexpr *divivals(l, r)
        !          1020: vexpr *l;
        !          1021: vexpr *r;
        !          1022: {
        !          1023:   static char *badtag = "bad tag in divivals";
        !          1024:   static char *zerodivide = "division by zero";
        !          1025: 
        !          1026:   register int ls, rs;
        !          1027:   register ftnint lv, rv;
        !          1028:   register dvalue *p;
        !          1029:   register ftnint k;
        !          1030:   register int sign;
        !          1031: 
        !          1032:   if (l->tag != DVALUE && r->tag != DVALUE)
        !          1033:     fatal(badtag);
        !          1034: 
        !          1035:   ls = l->dvalue.status;
        !          1036:   lv = l->dvalue.value;
        !          1037:   rs = r->dvalue.status;
        !          1038:   rv = r->dvalue.value;
        !          1039: 
        !          1040:   p = ALLOC(Dvalue);
        !          1041:   p->tag = DVALUE;
        !          1042: 
        !          1043:   if (ls == ERRVAL || rs == ERRVAL)
        !          1044:     p->status = ERRVAL;
        !          1045:   else if (rs == NORMAL)
        !          1046:     {
        !          1047:       if (rv == 0)
        !          1048:        {
        !          1049:          err(zerodivide);
        !          1050:          p->status = ERRVAL;
        !          1051:        }
        !          1052:       else if (ls == NORMAL)
        !          1053:        {
        !          1054:          p->status = NORMAL;
        !          1055:          p->value = lv / rv;
        !          1056:        }
        !          1057:       else if (rv == 1)
        !          1058:        p->status = ls;
        !          1059:       else if (rv == -1)
        !          1060:        if (ls == MAXPLUS1)
        !          1061:          p->status = MINLESS1;
        !          1062:        else
        !          1063:          p->status = MAXPLUS1;
        !          1064:       else
        !          1065:        {
        !          1066:          p->status = NORMAL;
        !          1067: 
        !          1068:          if (ls == MAXPLUS1)
        !          1069:            sign = 1;
        !          1070:          else
        !          1071:            sign = -1;
        !          1072: 
        !          1073:          if (rv < 0)
        !          1074:            {
        !          1075:              rv = -rv;
        !          1076:              sign = -sign;
        !          1077:            }
        !          1078:        
        !          1079:          k = MAXINT - rv;
        !          1080:          p->value = sign * ((k + 1)/rv + 1);
        !          1081:        }
        !          1082:     }
        !          1083:   else
        !          1084:     {
        !          1085:       p->status = NORMAL;
        !          1086:       if (ls == NORMAL)
        !          1087:        p->value = 0;
        !          1088:       else if ((ls == MAXPLUS1 && rs == MAXPLUS1)
        !          1089:                || (ls == MINLESS1 && rs == MINLESS1))
        !          1090:        p->value = 1;
        !          1091:       else
        !          1092:        p->value = -1;
        !          1093:     }
        !          1094: 
        !          1095:   return ((vexpr *) p);
        !          1096: }
        !          1097: 
        !          1098: 
        !          1099: 
        !          1100: vexpr *powivals(l, r)
        !          1101: vexpr *l;
        !          1102: vexpr *r;
        !          1103: {
        !          1104:   static char *badtag = "bad tag in powivals";
        !          1105:   static char *zerozero = "zero raised to the zero-th power";
        !          1106:   static char *zeroneg = "zero raised to a negative power";
        !          1107:   static char *overflow = "integer value too large";
        !          1108: 
        !          1109:   register int ls, rs;
        !          1110:   register ftnint lv, rv;
        !          1111:   register dvalue *p;
        !          1112: 
        !          1113:   if (l->tag != DVALUE || r->tag != DVALUE)
        !          1114:     fatal(badtag);
        !          1115: 
        !          1116:   ls = l->dvalue.status;
        !          1117:   lv = l->dvalue.value;
        !          1118:   rs = r->dvalue.status;
        !          1119:   rv = r->dvalue.value;
        !          1120: 
        !          1121:   p = ALLOC(Dvalue);
        !          1122:   p->tag = DVALUE;
        !          1123: 
        !          1124:   if (ls == ERRVAL || rs == ERRVAL)
        !          1125:     p->status = ERRVAL;
        !          1126: 
        !          1127:   else if (ls == NORMAL)
        !          1128:     {
        !          1129:       if (lv == 1)
        !          1130:        {
        !          1131:          p->status = NORMAL;
        !          1132:          p->value = 1;
        !          1133:        }
        !          1134:       else if (lv == 0)
        !          1135:        {
        !          1136:          if (rs == MAXPLUS1 || (rs == NORMAL && rv > 0))
        !          1137:            {
        !          1138:              p->status = NORMAL;
        !          1139:              p->value = 0;
        !          1140:            }
        !          1141:          else if (rs == NORMAL && rv == 0)
        !          1142:            {
        !          1143:              warn(zerozero);
        !          1144:              p->status = NORMAL;
        !          1145:              p->value = 1;
        !          1146:            }
        !          1147:          else
        !          1148:            {
        !          1149:              err(zeroneg);
        !          1150:              p->status = ERRVAL;
        !          1151:            }
        !          1152:        }
        !          1153:       else if (lv == -1)
        !          1154:        {
        !          1155:          p->status = NORMAL;
        !          1156:          if (rs == NORMAL)
        !          1157:            {
        !          1158:              if (rv < 0) rv = -rv;
        !          1159:              if (rv % 2 == 0)
        !          1160:                p->value = 1;
        !          1161:              else
        !          1162:                p->value = -1;
        !          1163:            }
        !          1164:          else
        !          1165: #          if (MAXINT % 2 == 1)
        !          1166:              p->value = 1;
        !          1167: #          else
        !          1168:              p->value = -1;
        !          1169: #          endif
        !          1170:        }
        !          1171:       else
        !          1172:        {
        !          1173:          if (rs == NORMAL && rv > 0)
        !          1174:            {
        !          1175:              rstatus = NORMAL;
        !          1176:              rvalue = lv;
        !          1177:              while (--rv && rstatus == NORMAL)
        !          1178:                mulints(rvalue, lv);
        !          1179:              if (rv == 0 && rstatus != ERRVAL)
        !          1180:                {
        !          1181:                  p->status = rstatus;
        !          1182:                  p->value = rvalue;
        !          1183:                }
        !          1184:              else
        !          1185:                {
        !          1186:                  err(overflow);
        !          1187:                  p->status = ERRVAL;
        !          1188:                }
        !          1189:            }
        !          1190:          else if (rs == MAXPLUS1)
        !          1191:            {
        !          1192:              err(overflow);
        !          1193:              p->status = ERRVAL;
        !          1194:            }
        !          1195:          else if (rs == NORMAL && rv == 0)
        !          1196:            {
        !          1197:              p->status = NORMAL;
        !          1198:              p->value = 1;
        !          1199:            }
        !          1200:          else
        !          1201:            {
        !          1202:              p->status = NORMAL;
        !          1203:              p->value = 0;
        !          1204:            }
        !          1205:        }
        !          1206:     }
        !          1207: 
        !          1208:   else
        !          1209:     {
        !          1210:       if (rs == MAXPLUS1 || (rs == NORMAL && rv > 1))
        !          1211:        {
        !          1212:          err(overflow);
        !          1213:          p->status = ERRVAL;
        !          1214:        }
        !          1215:       else if (rs == NORMAL && rv == 1)
        !          1216:        p->status = ls;
        !          1217:       else if (rs == NORMAL && rv == 0)
        !          1218:        {
        !          1219:          p->status = NORMAL;
        !          1220:          p->value = 1;
        !          1221:        }
        !          1222:       else
        !          1223:        {
        !          1224:          p->status = NORMAL;
        !          1225:          p->value = 0;
        !          1226:        }
        !          1227:     }
        !          1228: 
        !          1229:   return ((vexpr *) p);
        !          1230: }
        !          1231: 
        !          1232: 
        !          1233: 
        !          1234: /*  Addints adds two integer values.  */
        !          1235: 
        !          1236: addints(i, j)
        !          1237: register ftnint i, j;
        !          1238: {
        !          1239:   register ftnint margin;
        !          1240: 
        !          1241:   if (i == 0)
        !          1242:     {
        !          1243:       rstatus = NORMAL;
        !          1244:       rvalue = j;
        !          1245:     }
        !          1246:   else if (i > 0)
        !          1247:     {
        !          1248:       margin = MAXINT - i;
        !          1249:       if (j <= margin)
        !          1250:        {
        !          1251:          rstatus = NORMAL;
        !          1252:          rvalue = i + j;
        !          1253:        }
        !          1254:       else if (j == margin + 1)
        !          1255:        rstatus = MAXPLUS1;
        !          1256:       else
        !          1257:        rstatus = ERRVAL;
        !          1258:     }
        !          1259:   else
        !          1260:     {
        !          1261:       margin = ( -MAXINT ) - i;
        !          1262:       if (j >= margin)
        !          1263:        {
        !          1264:          rstatus = NORMAL;
        !          1265:          rvalue = i + j;
        !          1266:        }
        !          1267:       else if (j == margin - 1)
        !          1268:        rstatus = MINLESS1;
        !          1269:       else
        !          1270:        rstatus = ERRVAL;
        !          1271:     }
        !          1272: 
        !          1273:    return;
        !          1274: }
        !          1275: 
        !          1276: 
        !          1277: 
        !          1278: /*  Mulints multiplies two integer values  */
        !          1279: 
        !          1280: mulints(i, j)
        !          1281: register ftnint i, j;
        !          1282: {
        !          1283:   register ftnint sign;
        !          1284:   register ftnint margin;
        !          1285: 
        !          1286:   if (i == 0 || j == 0)
        !          1287:     {
        !          1288:       rstatus = NORMAL;
        !          1289:       rvalue = 0;
        !          1290:     }
        !          1291:   else
        !          1292:     {
        !          1293:       if ((i > 0 && j > 0) || (i < 0 && j < 0))
        !          1294:        sign = 1;
        !          1295:       else
        !          1296:        sign = -1;
        !          1297: 
        !          1298:       if (i < 0) i = -i;
        !          1299:       if (j < 0) j = -j;
        !          1300: 
        !          1301:       margin = MAXINT - i;
        !          1302:       margin = (margin + 1) / i;
        !          1303: 
        !          1304:       if (j <= margin)
        !          1305:        {
        !          1306:          rstatus = NORMAL;
        !          1307:          rvalue = i * j * sign;
        !          1308:        }
        !          1309:       else if (j - 1 == margin)
        !          1310:        {
        !          1311:          margin = i*margin - 1;
        !          1312:          if (margin == MAXINT - i)
        !          1313:            if (sign > 0)
        !          1314:              rstatus = MAXPLUS1;
        !          1315:            else
        !          1316:              rstatus = MINLESS1;
        !          1317:          else
        !          1318:            {
        !          1319:              rstatus = NORMAL;
        !          1320:              rvalue = i * j * sign;
        !          1321:            }
        !          1322:        }
        !          1323:       else
        !          1324:        rstatus = ERRVAL;
        !          1325:     }
        !          1326: 
        !          1327:   return;
        !          1328: }
        !          1329: 
        !          1330: 
        !          1331: 
        !          1332: vexpr *
        !          1333: evalvexpr(ep)
        !          1334: vexpr *ep;
        !          1335: {
        !          1336:   register vexpr *p;
        !          1337:   register vexpr *l, *r;
        !          1338: 
        !          1339:   switch (ep->tag)
        !          1340:     {
        !          1341:     case DVALUE:
        !          1342:       p = cpdvalue(ep);
        !          1343:       break;
        !          1344: 
        !          1345:     case DVAR:
        !          1346:       p = cpdvalue((vexpr *) ep->dvar.valp);
        !          1347:       break;
        !          1348: 
        !          1349:     case DNAME:
        !          1350:       p = evaldname(ep);
        !          1351:       break;
        !          1352: 
        !          1353:     case DEXPR:
        !          1354:       if (ep->dexpr.left == NULL)
        !          1355:        l = NULL;
        !          1356:       else
        !          1357:        l = evalvexpr(ep->dexpr.left);
        !          1358: 
        !          1359:       if (ep->dexpr.right == NULL)
        !          1360:        r = NULL;
        !          1361:       else
        !          1362:        r = evalvexpr(ep->dexpr.right);
        !          1363: 
        !          1364:       switch (ep->dexpr.opcode)
        !          1365:        {
        !          1366:        case OPNEG:
        !          1367:          p = negival(r);
        !          1368:          break;
        !          1369: 
        !          1370:        case OPPLUS:
        !          1371:          p = addivals(l, r);
        !          1372:          break;
        !          1373: 
        !          1374:        case OPMINUS:
        !          1375:          p = subivals(l, r);
        !          1376:          break;
        !          1377: 
        !          1378:        case OPSTAR:
        !          1379:          p = mulivals(l, r);
        !          1380:          break;
        !          1381: 
        !          1382:        case OPSLASH:
        !          1383:          p = divivals(l, r);
        !          1384:          break;
        !          1385: 
        !          1386:        case OPPOWER:
        !          1387:          p = powivals(l, r);
        !          1388:          break;
        !          1389:        }
        !          1390: 
        !          1391:       frvexpr(l);
        !          1392:       frvexpr(r);
        !          1393:       break;
        !          1394: 
        !          1395:     case DERROR:
        !          1396:       p = (vexpr *) ALLOC(Dvalue);
        !          1397:       p->tag = DVALUE;
        !          1398:       p->dvalue.status = ERRVAL;
        !          1399:       break;
        !          1400:     }
        !          1401: 
        !          1402:   return (p);
        !          1403: }
        !          1404: 
        !          1405: 
        !          1406: 
        !          1407: vexpr *
        !          1408: refrigdname(vp)
        !          1409: vexpr *vp;
        !          1410: {
        !          1411:   register vexpr *p;
        !          1412:   register int len;
        !          1413:   register char *repr;
        !          1414:   register int found;
        !          1415:   register dovars *dvp;
        !          1416: 
        !          1417:   len = vp->dname.len;
        !          1418:   repr = vp->dname.repr;
        !          1419: 
        !          1420:   found = NO;
        !          1421:   dvp = dvlist;
        !          1422:   while (found == NO && dvp != NULL)
        !          1423:     {
        !          1424:       if (len == dvp->len && eqn(len, repr, dvp->repr))
        !          1425:        found = YES;
        !          1426:       else
        !          1427:        dvp = dvp->next;
        !          1428:     }
        !          1429: 
        !          1430:   if (found == YES)
        !          1431:     {
        !          1432:       p = (vexpr *) ALLOC(Dvar);
        !          1433:       p->tag = DVAR;
        !          1434:       p->dvar.valp = dvp->valp;
        !          1435:     }
        !          1436:   else
        !          1437:     {
        !          1438:       p = evaldname(vp);
        !          1439:       if (p->dvalue.status == ERRVAL)
        !          1440:        dataerror = YES;
        !          1441:     }
        !          1442: 
        !          1443:   return (p);
        !          1444: }
        !          1445: 
        !          1446: 
        !          1447: 
        !          1448: refrigvexpr(vpp)
        !          1449: vexpr **vpp;
        !          1450: {
        !          1451:   register vexpr *vp;
        !          1452: 
        !          1453:   vp = *vpp;
        !          1454: 
        !          1455:   switch (vp->tag)
        !          1456:     {
        !          1457:     case DVALUE:
        !          1458:     case DVAR:
        !          1459:     case DERROR:
        !          1460:       break;
        !          1461: 
        !          1462:     case DEXPR:
        !          1463:       refrigvexpr( &(vp->dexpr.left) );
        !          1464:       refrigvexpr( &(vp->dexpr.right) );
        !          1465:       break;
        !          1466: 
        !          1467:     case DNAME:
        !          1468:       *(vpp) = refrigdname(vp);
        !          1469:       frvexpr(vp);
        !          1470:       break;
        !          1471:     }
        !          1472: 
        !          1473:   return;
        !          1474: }
        !          1475: 
        !          1476: 
        !          1477: 
        !          1478: int
        !          1479: chkvar(np, sname)
        !          1480: Namep np;
        !          1481: char *sname;
        !          1482: {
        !          1483:   static char *nonvar = "%s is not a variable";
        !          1484:   static char *arginit = "attempt to initialize a dummy argument: %s";
        !          1485:   static char *autoinit = "attempt to initialize an automatic variable: %s";
        !          1486:   static char *badclass = "bad class in chkvar";
        !          1487: 
        !          1488:   register int status;
        !          1489:   register struct Dimblock *dp;
        !          1490:   register int i;
        !          1491: 
        !          1492:   status = YES;
        !          1493: 
        !          1494:   if (np->vclass == CLUNKNOWN
        !          1495:       || (np->vclass == CLVAR && !np->vdcldone))
        !          1496:     vardcl(np);
        !          1497: 
        !          1498:   if (np->vstg == STGARG)
        !          1499:     {
        !          1500:       errstr(arginit, sname);
        !          1501:       dataerror = YES;
        !          1502:       status = NO;
        !          1503:     }
        !          1504:   else if (np->vclass != CLVAR)
        !          1505:     {
        !          1506:       errstr(nonvar, sname);
        !          1507:       dataerror = YES;
        !          1508:       status = NO;
        !          1509:     }
        !          1510:   else if (np->vstg == STGAUTO)
        !          1511:     {
        !          1512:       errstr(autoinit, sname);
        !          1513:       dataerror = YES;
        !          1514:       status = NO;
        !          1515:     }
        !          1516:   else if (np->vstg != STGBSS && np->vstg != STGINIT
        !          1517:            && np->vstg != STGCOMMON && np->vstg != STGEQUIV)
        !          1518:     {
        !          1519:       fatal(badclass);
        !          1520:     }
        !          1521:   else
        !          1522:     {
        !          1523:       switch (np->vtype)
        !          1524:        {
        !          1525:        case TYERROR:
        !          1526:          status = NO;
        !          1527:          dataerror = YES;
        !          1528:          break;
        !          1529: 
        !          1530:        case TYSHORT:
        !          1531:        case TYLONG:
        !          1532:        case TYREAL:
        !          1533:        case TYDREAL:
        !          1534:        case TYCOMPLEX:
        !          1535:        case TYDCOMPLEX:
        !          1536:        case TYLOGICAL:
        !          1537:        case TYCHAR:
        !          1538:          dp = np->vdim;
        !          1539:          if (dp != NULL)
        !          1540:            {
        !          1541:              if (dp->nelt == NULL || !ISICON(dp->nelt))
        !          1542:                {
        !          1543:                  status = NO;
        !          1544:                  dataerror = YES;
        !          1545:                }
        !          1546:            }
        !          1547:          break;
        !          1548: 
        !          1549:        default:
        !          1550:          badtype("chkvar", np->vtype);
        !          1551:        }
        !          1552:     }
        !          1553: 
        !          1554:   return (status);
        !          1555: }
        !          1556: 
        !          1557: 
        !          1558: 
        !          1559: refrigsubs(ap, sname)
        !          1560: aelt *ap;
        !          1561: char *sname;
        !          1562: {
        !          1563:   static char *nonarray = "subscripts on a simple variable:  %s";
        !          1564:   static char *toofew = "not enough subscripts on %s";
        !          1565:   static char *toomany = "too many subscripts on %s";
        !          1566: 
        !          1567:   register vlist *subp;
        !          1568:   register int nsubs;
        !          1569:   register Namep np;
        !          1570:   register struct Dimblock *dp;
        !          1571:   register int i;
        !          1572: 
        !          1573:   np = ap->var;
        !          1574:   dp = np->vdim;
        !          1575: 
        !          1576:   if (ap->subs != NULL)
        !          1577:     {
        !          1578:       if (np->vdim == NULL)
        !          1579:        {
        !          1580:          errstr(nonarray, sname);
        !          1581:          dataerror = YES;
        !          1582:        }
        !          1583:       else
        !          1584:        {
        !          1585:          nsubs = 0;
        !          1586:          subp = ap->subs;
        !          1587:          while (subp != NULL)
        !          1588:            {
        !          1589:              nsubs++;
        !          1590:              refrigvexpr( &(subp->val) );
        !          1591:              subp = subp->next;
        !          1592:            }
        !          1593: 
        !          1594:          if (dp->ndim != nsubs)
        !          1595:            {
        !          1596:              if (np->vdim->ndim > nsubs)
        !          1597:                errstr(toofew, sname);
        !          1598:              else
        !          1599:                errstr(toomany, sname);
        !          1600:              dataerror = YES;
        !          1601:            }
        !          1602:          else if (dp->baseoffset == NULL || !ISICON(dp->baseoffset))
        !          1603:            dataerror = YES;
        !          1604:          else
        !          1605:            {
        !          1606:              i = dp->ndim;
        !          1607:              while (i-- > 0)
        !          1608:                {
        !          1609:                  if (dp->dims[i].dimsize == NULL
        !          1610:                      || !ISICON(dp->dims[i].dimsize))
        !          1611:                    dataerror = YES;
        !          1612:                }
        !          1613:            }
        !          1614:        }
        !          1615:     }
        !          1616: 
        !          1617:   return;
        !          1618: }
        !          1619: 
        !          1620: 
        !          1621: 
        !          1622: refrigrange(ap, sname)
        !          1623: aelt *ap;
        !          1624: char *sname;
        !          1625: {
        !          1626:   static char *nonstr = "substring of a noncharacter variable:  %s";
        !          1627:   static char *array = "substring applied to an array:  %s";
        !          1628: 
        !          1629:   register Namep np;
        !          1630:   register dvalue *t;
        !          1631:   register rpair *rp;
        !          1632: 
        !          1633:   if (ap->range != NULL)
        !          1634:     {
        !          1635:       np = ap->var;
        !          1636:       if (np->vtype != TYCHAR)
        !          1637:        {
        !          1638:          errstr(nonstr, sname);
        !          1639:          dataerror = YES;
        !          1640:        }
        !          1641:       else if (ap->subs == NULL && np->vdim != NULL)
        !          1642:        {
        !          1643:          errstr(array, sname);
        !          1644:          dataerror = YES;
        !          1645:        }
        !          1646:       else
        !          1647:        {
        !          1648:          rp = ap->range;
        !          1649: 
        !          1650:          if (rp->low != NULL)
        !          1651:            refrigvexpr( &(rp->low) );
        !          1652:          else
        !          1653:            {
        !          1654:              t = ALLOC(Dvalue);
        !          1655:              t->tag = DVALUE;
        !          1656:              t->status = NORMAL;
        !          1657:              t->value = 1;
        !          1658:              rp->low = (vexpr *) t;
        !          1659:            }
        !          1660: 
        !          1661:          if (rp->high != NULL)
        !          1662:            refrigvexpr( &(rp->high) );
        !          1663:          else
        !          1664:            {
        !          1665:              if (!ISICON(np->vleng))
        !          1666:                {
        !          1667:                  rp->high = (vexpr *) ALLOC(Derror);
        !          1668:                  rp->high->tag = DERROR;
        !          1669:                }
        !          1670:              else
        !          1671:                {
        !          1672:                  t = ALLOC(Dvalue);
        !          1673:                  t->tag = DVALUE;
        !          1674:                  t->status = NORMAL;
        !          1675:                  t->value = np->vleng->constblock.const.ci;
        !          1676:                  rp->high = (vexpr *) t;
        !          1677:                }
        !          1678:            }
        !          1679:        }
        !          1680:     }
        !          1681: 
        !          1682:   return;
        !          1683: }
        !          1684: 
        !          1685: 
        !          1686: 
        !          1687: refrigaelt(ap)
        !          1688: aelt *ap;
        !          1689: {
        !          1690:   register Namep np;
        !          1691:   register char *bp, *sp;
        !          1692:   register int len;
        !          1693:   char buff[VL+1];
        !          1694: 
        !          1695:   np = ap->var;
        !          1696: 
        !          1697:   len = 0;
        !          1698:   bp = buff;
        !          1699:   sp = np->varname;
        !          1700:   while (len < VL && *sp != ' ' && *sp != '\0')
        !          1701:     {
        !          1702:       *bp++ = *sp++;
        !          1703:       len++;
        !          1704:     }
        !          1705:   *bp = '\0';
        !          1706: 
        !          1707:   if (chkvar(np, buff))
        !          1708:     {
        !          1709:       refrigsubs(ap, buff);
        !          1710:       refrigrange(ap, buff);
        !          1711:     }
        !          1712: 
        !          1713:   return;
        !          1714: }
        !          1715: 
        !          1716: 
        !          1717: 
        !          1718: refrigdo(dp)
        !          1719: dolist *dp;
        !          1720: {
        !          1721:   static char *duplicates = "implied DO variable %s redefined";
        !          1722:   static char *nonvar = "%s is not a variable";
        !          1723:   static char *nonint = "%s is not integer";
        !          1724: 
        !          1725:   register int len;
        !          1726:   register char *repr;
        !          1727:   register int found;
        !          1728:   register dovars *dvp;
        !          1729:   register Namep np;
        !          1730:   register dovars *t;
        !          1731: 
        !          1732:   refrigvexpr( &(dp->init) );
        !          1733:   refrigvexpr( &(dp->limit) );
        !          1734:   refrigvexpr( &(dp->step) );
        !          1735: 
        !          1736:   len = dp->dovar->dname.len;
        !          1737:   repr = dp->dovar->dname.repr;
        !          1738: 
        !          1739:   found = NO;
        !          1740:   dvp = dvlist;
        !          1741:   while (found == NO && dvp != NULL)
        !          1742:     if (len == dvp->len && eqn(len, repr, dvp->repr))
        !          1743:       found = YES;
        !          1744:     else
        !          1745:       dvp = dvp->next;
        !          1746: 
        !          1747:   if (found == YES)
        !          1748:     {
        !          1749:       errnm(duplicates, len, repr);
        !          1750:       dataerror = YES;
        !          1751:     }
        !          1752:   else
        !          1753:     {
        !          1754:       np = getname(len, repr);
        !          1755:       if (np == NULL)
        !          1756:        {
        !          1757:          if (!ISINT(impltype[letter(*repr)]))
        !          1758:            warnnm(nonint, len, repr);
        !          1759:        }
        !          1760:       else
        !          1761:        {
        !          1762:          if (np->vclass == CLUNKNOWN)
        !          1763:            vardcl(np);
        !          1764:          if (np->vclass != CLVAR)
        !          1765:            warnnm(nonvar, len, repr);
        !          1766:          else if (!ISINT(np->vtype))
        !          1767:            warnnm(nonint, len, repr);
        !          1768:        }
        !          1769:     }
        !          1770: 
        !          1771:   t = ALLOC(DoVars);
        !          1772:   t->next = dvlist;
        !          1773:   t->len = len;
        !          1774:   t->repr = repr;
        !          1775:   t->valp = ALLOC(Dvalue);
        !          1776:   t->valp->tag = DVALUE;
        !          1777:   dp->dovar = (vexpr *) t->valp;
        !          1778: 
        !          1779:   dvlist = t;
        !          1780: 
        !          1781:   refriglvals(dp->elts);
        !          1782: 
        !          1783:   dvlist = t->next;
        !          1784:   free((char *) t);
        !          1785: 
        !          1786:   return;
        !          1787: }
        !          1788: 
        !          1789: 
        !          1790: 
        !          1791: refriglvals(lvals)
        !          1792: elist *lvals;
        !          1793: {
        !          1794:   register elist *top;
        !          1795: 
        !          1796:   top = lvals;
        !          1797: 
        !          1798:   while (top != NULL)
        !          1799:     {
        !          1800:       if (top->elt->tag == SIMPLE)
        !          1801:        refrigaelt((aelt *) top->elt);
        !          1802:       else
        !          1803:        refrigdo((dolist *) top->elt);
        !          1804: 
        !          1805:       top = top->next;
        !          1806:     }
        !          1807: 
        !          1808:   return;
        !          1809: }
        !          1810: 
        !          1811: 
        !          1812: 
        !          1813: /*  Refrig freezes name/value bindings in the DATA name list  */
        !          1814: 
        !          1815: 
        !          1816: refrig(lvals)
        !          1817: elist *lvals;
        !          1818: {
        !          1819:   dvlist = NULL;
        !          1820:   refriglvals(lvals);
        !          1821:   return;
        !          1822: }
        !          1823: 
        !          1824: 
        !          1825: 
        !          1826: ftnint
        !          1827: indexer(ap)
        !          1828: aelt *ap;
        !          1829: {
        !          1830:   static char *badvar = "bad variable in indexer";
        !          1831:   static char *boundserror = "subscript out of bounds";
        !          1832: 
        !          1833:   register ftnint index;
        !          1834:   register vlist *sp;
        !          1835:   register Namep np;
        !          1836:   register struct Dimblock *dp;
        !          1837:   register int i;
        !          1838:   register dvalue *vp;
        !          1839:   register ftnint size;
        !          1840:   ftnint sub[MAXDIM];
        !          1841: 
        !          1842:   sp = ap->subs;
        !          1843:   if (sp == NULL) return (0);
        !          1844: 
        !          1845:   np = ap->var;
        !          1846:   dp = np->vdim;
        !          1847: 
        !          1848:   if (dp == NULL)
        !          1849:     fatal(badvar);
        !          1850: 
        !          1851:   i = 0;
        !          1852:   while (sp != NULL)
        !          1853:     {
        !          1854:       vp = (dvalue *) evalvexpr(sp->val);
        !          1855: 
        !          1856:       if (vp->status == NORMAL)
        !          1857:        sub[i++] = vp->value;
        !          1858:       else if ((MININT + MAXINT == -1) && vp->status == MINLESS1)
        !          1859:        sub[i++] = MININT;
        !          1860:       else
        !          1861:        {
        !          1862:          frvexpr((vexpr *) vp);
        !          1863:          return (-1);
        !          1864:        }
        !          1865: 
        !          1866:       frvexpr((vexpr *) vp);
        !          1867:       sp = sp->next;
        !          1868:     }
        !          1869: 
        !          1870:   index = sub[--i];
        !          1871:   while (i-- > 0)
        !          1872:     {
        !          1873:       size = dp->dims[i].dimsize->constblock.const.ci;
        !          1874:       index = sub[i] + index * size;
        !          1875:     }
        !          1876: 
        !          1877:   index -= dp->baseoffset->constblock.const.ci;
        !          1878: 
        !          1879:   if (index < 0 || index >= dp->nelt->constblock.const.ci)
        !          1880:     {
        !          1881:       err(boundserror);
        !          1882:       return (-1);
        !          1883:     }
        !          1884: 
        !          1885:   return (index);
        !          1886: }
        !          1887: 
        !          1888: 
        !          1889: 
        !          1890: savedata(lvals, rvals)
        !          1891: elist *lvals;
        !          1892: vallist *rvals;
        !          1893: {
        !          1894:   static char *toomany = "more data values than data items";
        !          1895: 
        !          1896:   register elist *top;
        !          1897: 
        !          1898:   dataerror = NO;
        !          1899:   badvalue = NO;
        !          1900: 
        !          1901:   lvals = revelist(lvals);
        !          1902:   grvals = revrvals(rvals);
        !          1903: 
        !          1904:   refrig(lvals);
        !          1905: 
        !          1906:   if (!dataerror)
        !          1907:     outdata(lvals);
        !          1908: 
        !          1909:   frelist(lvals);
        !          1910: 
        !          1911:   while (grvals != NULL && dataerror == NO)
        !          1912:     {
        !          1913:       if (grvals->status != NORMAL)
        !          1914:        dataerror = YES;
        !          1915:       else if (grvals->repl <= 0)
        !          1916:         grvals = grvals->next;
        !          1917:       else
        !          1918:        {
        !          1919:          err(toomany);
        !          1920:          dataerror = YES;
        !          1921:        }
        !          1922:     }
        !          1923:     
        !          1924:   frvallist(grvals);
        !          1925: 
        !          1926:   return;
        !          1927: }
        !          1928: 
        !          1929: 
        !          1930: 
        !          1931: setdfiles(np)
        !          1932: register Namep np;
        !          1933: {
        !          1934:   register struct Extsym *cp;
        !          1935:   register struct Equivblock *ep;
        !          1936:   register int stg;
        !          1937:   register int type;
        !          1938:   register ftnint typelen;
        !          1939:   register ftnint nelt;
        !          1940:   register ftnint varsize;
        !          1941: 
        !          1942:   stg = np->vstg;
        !          1943: 
        !          1944:   if (stg == STGBSS || stg == STGINIT)
        !          1945:     {
        !          1946:       datafile = vdatafile;
        !          1947:       chkfile = vchkfile;
        !          1948:       if (np->init == YES)
        !          1949:        base = np->initoffset;
        !          1950:       else
        !          1951:        {
        !          1952:          np->init = YES;
        !          1953:          np->initoffset = base = vdatahwm;
        !          1954:          if (np->vdim != NULL)
        !          1955:            nelt = np->vdim->nelt->constblock.const.ci;
        !          1956:          else
        !          1957:            nelt = 1;
        !          1958:          type = np->vtype;
        !          1959:          if (type == TYCHAR)
        !          1960:            typelen = np->vleng->constblock.const.ci;
        !          1961:          else if (type == TYLOGICAL)
        !          1962:            typelen = typesize[tylogical];
        !          1963:          else
        !          1964:            typelen = typesize[type];
        !          1965:          varsize = nelt * typelen;
        !          1966:          vdatahwm += varsize;
        !          1967:        }
        !          1968:     }
        !          1969:   else if (stg == STGEQUIV)
        !          1970:     {
        !          1971:       datafile = vdatafile;
        !          1972:       chkfile = vchkfile;
        !          1973:       ep = &eqvclass[np->vardesc.varno];
        !          1974:       if (ep->init == YES)
        !          1975:        base = ep->initoffset;
        !          1976:       else
        !          1977:        {
        !          1978:          ep->init = YES;
        !          1979:          ep->initoffset = base = vdatahwm;
        !          1980:          vdatahwm += ep->eqvleng;
        !          1981:        }
        !          1982:       base += np->voffset;
        !          1983:     }
        !          1984:   else if (stg == STGCOMMON)
        !          1985:     {
        !          1986:       datafile = cdatafile;
        !          1987:       chkfile = cchkfile;
        !          1988:       cp = &extsymtab[np->vardesc.varno];
        !          1989:       if (cp->init == YES)
        !          1990:        base = cp->initoffset;
        !          1991:       else
        !          1992:        {
        !          1993:          cp->init = YES;
        !          1994:          cp->initoffset = base = cdatahwm;
        !          1995:          cdatahwm += cp->maxleng;
        !          1996:        }
        !          1997:       base += np->voffset;
        !          1998:     }
        !          1999: 
        !          2000:   return;
        !          2001: }
        !          2002: 
        !          2003: 
        !          2004: 
        !          2005: wrtdata(offset, repl, len, const)
        !          2006: long offset;
        !          2007: ftnint repl;
        !          2008: ftnint len;
        !          2009: char *const;
        !          2010: {
        !          2011:   static char *badoffset = "bad offset in wrtdata";
        !          2012:   static char *toomuch = "too much data";
        !          2013:   static char *readerror = "read error on tmp file";
        !          2014:   static char *writeerror = "write error on tmp file";
        !          2015:   static char *seekerror = "seek error on tmp file";
        !          2016: 
        !          2017:   register ftnint k;
        !          2018:   long lastbyte;
        !          2019:   int bitpos;
        !          2020:   long chkoff;
        !          2021:   long lastoff;
        !          2022:   long chklen;
        !          2023:   long pos;
        !          2024:   int n;
        !          2025:   ftnint nbytes;
        !          2026:   int mask;
        !          2027:   register int i;
        !          2028:   char overlap;
        !          2029:   char allzero;
        !          2030:   char buff[BUFSIZ];
        !          2031: 
        !          2032:   if (offset < 0)
        !          2033:     fatal(badoffset);
        !          2034: 
        !          2035:   overlap = NO;
        !          2036: 
        !          2037:   k = repl * len;
        !          2038:   lastbyte = offset + k - 1;
        !          2039:   if (lastbyte < 0)
        !          2040:     {
        !          2041:       err(toomuch);
        !          2042:       dataerror = YES;
        !          2043:       return;
        !          2044:     }
        !          2045: 
        !          2046:   bitpos = offset % BYTESIZE;
        !          2047:   chkoff = offset/BYTESIZE;
        !          2048:   lastoff = lastbyte/BYTESIZE;
        !          2049:   chklen = lastoff - chkoff + 1;
        !          2050: 
        !          2051:   pos = lseek(chkfile, chkoff, 0);
        !          2052:   if (pos == -1)
        !          2053:     {
        !          2054:       err(seekerror);
        !          2055:       done(1);
        !          2056:     }
        !          2057: 
        !          2058:   while (k > 0)
        !          2059:     {
        !          2060:       if (chklen <= BUFSIZ)
        !          2061:        n = chklen;
        !          2062:       else
        !          2063:        {
        !          2064:          n = BUFSIZ;
        !          2065:          chklen -= BUFSIZ;
        !          2066:        }
        !          2067: 
        !          2068:       nbytes = read(chkfile, buff, n);
        !          2069:       if (nbytes < 0)
        !          2070:        {
        !          2071:          err(readerror);
        !          2072:          done(1);
        !          2073:        }
        !          2074: 
        !          2075:       if (nbytes == 0)
        !          2076:        buff[0] = '\0';
        !          2077: 
        !          2078:       if (nbytes < n)
        !          2079:        buff[ n-1 ] = '\0';
        !          2080: 
        !          2081:       i = 0;
        !          2082: 
        !          2083:       if (bitpos > 0)
        !          2084:        {
        !          2085:          while (k > 0 && bitpos < BYTESIZE)
        !          2086:            {
        !          2087:              mask = 1 << bitpos;
        !          2088: 
        !          2089:              if (mask & buff[0])
        !          2090:                overlap = YES;
        !          2091:              else
        !          2092:                buff[0] |= mask;
        !          2093: 
        !          2094:              k--;
        !          2095:              bitpos++;
        !          2096:            }
        !          2097: 
        !          2098:          if (bitpos == BYTESIZE)
        !          2099:            {
        !          2100:              bitpos = 0;
        !          2101:              i++;
        !          2102:            }
        !          2103:        }
        !          2104: 
        !          2105:       while (i < nbytes && overlap == NO)
        !          2106:        {
        !          2107:          if (buff[i] == 0 && k >= BYTESIZE)
        !          2108:            {
        !          2109:              buff[i++] = MAXBYTE;
        !          2110:              k -= BYTESIZE;
        !          2111:            }
        !          2112:          else if (k < BYTESIZE)
        !          2113:            {
        !          2114:              while (k-- > 0)
        !          2115:                {
        !          2116:                  mask = 1 << k;
        !          2117:                  if (mask & buff[i])
        !          2118:                    overlap = YES;
        !          2119:                  else
        !          2120:                    buff[i] |= mask;
        !          2121:                }
        !          2122:              i++;
        !          2123:            }
        !          2124:          else
        !          2125:            {
        !          2126:              overlap = YES;
        !          2127:              buff[i++] = MAXBYTE;
        !          2128:              k -= BYTESIZE;
        !          2129:            }
        !          2130:        }
        !          2131: 
        !          2132:       while (i < n)
        !          2133:        {
        !          2134:          if (k >= BYTESIZE)
        !          2135:            {
        !          2136:              buff[i++] = MAXBYTE;
        !          2137:              k -= BYTESIZE;
        !          2138:            }
        !          2139:          else
        !          2140:            {
        !          2141:              while (k-- > 0)
        !          2142:                {
        !          2143:                  mask = 1 << k;
        !          2144:                  buff[i] |= mask;
        !          2145:                }
        !          2146:              i++;
        !          2147:            }
        !          2148:        }
        !          2149: 
        !          2150:       pos = lseek(chkfile, -nbytes, 1);
        !          2151:       if (pos == -1)
        !          2152:        {
        !          2153:          err(seekerror);
        !          2154:          done(1);
        !          2155:        }
        !          2156: 
        !          2157:       nbytes = write(chkfile, buff, n);
        !          2158:       if (nbytes != n)
        !          2159:        {
        !          2160:          err(writeerror);
        !          2161:          done(1);
        !          2162:        }
        !          2163:     }
        !          2164: 
        !          2165:   if (overlap == NO)
        !          2166:     {
        !          2167:       allzero = YES;
        !          2168:       k = len;
        !          2169: 
        !          2170:       while (k > 0 && allzero != NO)
        !          2171:        if (const[--k] != 0) allzero = NO;
        !          2172: 
        !          2173:       if (allzero == YES)
        !          2174:        return;
        !          2175:     }
        !          2176: 
        !          2177:   pos = lseek(datafile, offset, 0);
        !          2178:   if (pos == -1)
        !          2179:     {
        !          2180:       err(seekerror);
        !          2181:       done(1);
        !          2182:     }
        !          2183: 
        !          2184:   k = repl;
        !          2185:   while (k-- > 0)
        !          2186:     {
        !          2187:       nbytes = write(datafile, const, len);
        !          2188:       if (nbytes != len)
        !          2189:        {
        !          2190:          err(writeerror);
        !          2191:          done(1);
        !          2192:        }
        !          2193:     }
        !          2194: 
        !          2195:   if (overlap) overlapflag = YES;
        !          2196: 
        !          2197:   return;
        !          2198: }
        !          2199: 
        !          2200: 
        !          2201: 
        !          2202: Constp
        !          2203: getdatum()
        !          2204: {
        !          2205:   static char *toofew = "more data items than data values";
        !          2206: 
        !          2207:   register vallist *t;
        !          2208: 
        !          2209:   while (grvals != NULL)
        !          2210:     {
        !          2211:       if (grvals->status != NORMAL)
        !          2212:        {
        !          2213:          dataerror = YES;
        !          2214:          return (NULL);
        !          2215:        }
        !          2216:       else if (grvals->repl > 0)
        !          2217:        {
        !          2218:          grvals->repl--;
        !          2219:          return (grvals->value);
        !          2220:        }
        !          2221:       else
        !          2222:        {
        !          2223:          badvalue = 0;
        !          2224:          frexpr ((tagptr) grvals->value);
        !          2225:          t = grvals;
        !          2226:          grvals = t->next;
        !          2227:          free((char *) t);
        !          2228:        }
        !          2229:     }
        !          2230: 
        !          2231:   err(toofew);
        !          2232:   dataerror = YES;
        !          2233:   return (NULL);
        !          2234: }
        !          2235: 
        !          2236: 
        !          2237: 
        !          2238: outdata(lvals)
        !          2239: elist *lvals;
        !          2240: {
        !          2241:   register elist *top;
        !          2242: 
        !          2243:   top = lvals;
        !          2244: 
        !          2245:   while (top != NULL && dataerror == NO)
        !          2246:     {
        !          2247:       if (top->elt->tag == SIMPLE)
        !          2248:        outaelt((aelt *) top->elt);
        !          2249:       else
        !          2250:        outdolist((dolist *) top->elt);
        !          2251: 
        !          2252:       top = top->next;
        !          2253:     }
        !          2254: 
        !          2255:   return;
        !          2256: }
        !          2257: 
        !          2258: 
        !          2259: 
        !          2260: outaelt(ap)
        !          2261: aelt *ap;
        !          2262: {
        !          2263:   static char *toofew = "more data items than data values";
        !          2264:   static char *boundserror = "substring expression out of bounds";
        !          2265:   static char *order = "substring expressions out of order";
        !          2266: 
        !          2267:   register Namep np;
        !          2268:   register long soffset;
        !          2269:   register dvalue *lwb;
        !          2270:   register dvalue *upb;
        !          2271:   register Constp const;
        !          2272:   register int k;
        !          2273:   register vallist *t;
        !          2274:   register int type;
        !          2275:   register ftnint typelen;
        !          2276:   register ftnint repl;
        !          2277: 
        !          2278:   extern char *packbytes();
        !          2279: 
        !          2280:   np = ap->var;
        !          2281:   setdfiles(np);
        !          2282: 
        !          2283:   type = np->vtype;
        !          2284: 
        !          2285:   if (type == TYCHAR)
        !          2286:     typelen = np->vleng->constblock.const.ci;
        !          2287:   else if (type == TYLOGICAL)
        !          2288:     typelen = typesize[tylogical];
        !          2289:   else
        !          2290:     typelen = typesize[type];
        !          2291: 
        !          2292:   if (ap->subs != NULL || np->vdim == NULL)
        !          2293:     {
        !          2294:       soffset = indexer(ap);
        !          2295:       if (soffset == -1)
        !          2296:        {
        !          2297:          dataerror = YES;
        !          2298:          return;
        !          2299:        }
        !          2300: 
        !          2301:       soffset = soffset * typelen;
        !          2302: 
        !          2303:       if (ap->range != NULL)
        !          2304:        {
        !          2305:          lwb = (dvalue *) evalvexpr(ap->range->low);
        !          2306:          upb = (dvalue *) evalvexpr(ap->range->high);
        !          2307:          if (lwb->status == ERRVAL || upb->status == ERRVAL)
        !          2308:            {
        !          2309:              frvexpr((vexpr *) lwb);
        !          2310:              frvexpr((vexpr *) upb);
        !          2311:              dataerror = YES;
        !          2312:              return;
        !          2313:            }
        !          2314: 
        !          2315:          if (lwb->status != NORMAL ||
        !          2316:              lwb->value < 1 ||
        !          2317:              lwb->value > typelen ||
        !          2318:              upb->status != NORMAL ||
        !          2319:              upb->value < 1 ||
        !          2320:              upb->value > typelen)
        !          2321:            {
        !          2322:              err(boundserror);
        !          2323:              frvexpr((vexpr *) lwb);
        !          2324:              frvexpr((vexpr *) upb);
        !          2325:              dataerror = YES;
        !          2326:              return;
        !          2327:            }
        !          2328: 
        !          2329:          if (lwb->value > upb->value)
        !          2330:            {
        !          2331:              err(order);
        !          2332:              frvexpr((vexpr *) lwb);
        !          2333:              frvexpr((vexpr *) upb);
        !          2334:              dataerror = YES;
        !          2335:              return;
        !          2336:            }
        !          2337: 
        !          2338:          soffset = soffset + lwb->value - 1;
        !          2339:          typelen = upb->value - lwb->value + 1;
        !          2340:          frvexpr((vexpr *) lwb);
        !          2341:          frvexpr((vexpr *) upb);
        !          2342:        }
        !          2343: 
        !          2344:       const = getdatum();
        !          2345:       if (const == NULL || !ISCONST(const))
        !          2346:        return;
        !          2347: 
        !          2348:       const = (Constp) convconst(type, typelen, const);
        !          2349:       if (const == NULL || !ISCONST(const))
        !          2350:        {
        !          2351:          frexpr((tagptr) const);
        !          2352:          return;
        !          2353:        }
        !          2354: 
        !          2355:       if (type == TYCHAR)
        !          2356:        wrtdata(base + soffset, 1, typelen, const->const.ccp);
        !          2357:       else
        !          2358:        wrtdata(base + soffset, 1, typelen, packbytes(const));
        !          2359: 
        !          2360:       frexpr((tagptr) const);
        !          2361:     }
        !          2362:   else
        !          2363:     {
        !          2364:       soffset = 0;
        !          2365:       k = np->vdim->nelt->constblock.const.ci;
        !          2366:       while (k > 0 && dataerror == NO)
        !          2367:        {
        !          2368:          if (grvals == NULL)
        !          2369:            {
        !          2370:              err(toofew);
        !          2371:              dataerror = YES;
        !          2372:            }
        !          2373:          else if (grvals->status != NORMAL)
        !          2374:            dataerror = YES;
        !          2375:          else if (grvals-> repl <= 0)
        !          2376:            {
        !          2377:              badvalue = 0;
        !          2378:              frexpr((tagptr) grvals->value);
        !          2379:              t = grvals;
        !          2380:              grvals = t->next;
        !          2381:              free((char *) t);
        !          2382:            }
        !          2383:          else
        !          2384:            {
        !          2385:              const = grvals->value;
        !          2386:              if (const == NULL || !ISCONST(const))
        !          2387:                {
        !          2388:                  dataerror = YES;
        !          2389:                }
        !          2390:              else
        !          2391:                {
        !          2392:                  const = (Constp) convconst(type, typelen, const);
        !          2393:                  if (const == NULL || !ISCONST(const))
        !          2394:                    {
        !          2395:                      dataerror = YES;
        !          2396:                      frexpr((tagptr) const);
        !          2397:                    }
        !          2398:                  else
        !          2399:                    {
        !          2400:                      if (k > grvals->repl)
        !          2401:                        repl = grvals->repl;
        !          2402:                      else
        !          2403:                        repl = k;
        !          2404: 
        !          2405:                      grvals->repl -= repl;
        !          2406:                      k -= repl;
        !          2407: 
        !          2408:                      if (type == TYCHAR)
        !          2409:                        wrtdata(base+soffset, repl, typelen, const->const.ccp);
        !          2410:                      else
        !          2411:                        wrtdata(base+soffset, repl, typelen, packbytes(const));
        !          2412: 
        !          2413:                      soffset = soffset + repl * typelen;
        !          2414: 
        !          2415:                      frexpr((tagptr) const);
        !          2416:                    }
        !          2417:                }
        !          2418:            }
        !          2419:        }
        !          2420:     }
        !          2421: 
        !          2422:   return;
        !          2423: }
        !          2424: 
        !          2425: 
        !          2426: 
        !          2427: outdolist(dp)
        !          2428: dolist *dp;
        !          2429: {
        !          2430:   static char *zerostep = "zero step in implied-DO";
        !          2431:   static char *order = "zero iteration count in implied-DO";
        !          2432: 
        !          2433:   register dvalue *e1, *e2, *e3;
        !          2434:   register int direction;
        !          2435:   register dvalue *dv;
        !          2436:   register int done;
        !          2437:   register int addin;
        !          2438:   register int ts;
        !          2439:   register ftnint tv;
        !          2440: 
        !          2441:   e1 = (dvalue *) evalvexpr(dp->init);
        !          2442:   e2 = (dvalue *) evalvexpr(dp->limit);
        !          2443:   e3 = (dvalue *) evalvexpr(dp->step);
        !          2444: 
        !          2445:   if (e1->status == ERRVAL ||
        !          2446:       e2->status == ERRVAL ||
        !          2447:       e3->status == ERRVAL)
        !          2448:     {
        !          2449:       dataerror = YES;
        !          2450:       goto ret;
        !          2451:     }
        !          2452: 
        !          2453:   if (e1->status == NORMAL)
        !          2454:     {
        !          2455:       if (e2->status == NORMAL)
        !          2456:        {
        !          2457:          if (e1->value < e2->value)
        !          2458:            direction = 1;
        !          2459:          else if (e1->value > e2->value)
        !          2460:            direction = -1;
        !          2461:          else
        !          2462:            direction = 0;
        !          2463:        }
        !          2464:       else if (e2->status == MAXPLUS1)
        !          2465:        direction = 1;
        !          2466:       else
        !          2467:        direction = -1;
        !          2468:     }
        !          2469:   else if (e1->status == MAXPLUS1)
        !          2470:     {
        !          2471:       if (e2->status == MAXPLUS1)
        !          2472:        direction = 0;
        !          2473:       else
        !          2474:        direction = -1;
        !          2475:     }
        !          2476:   else
        !          2477:     {
        !          2478:       if (e2->status == MINLESS1)
        !          2479:        direction = 0;
        !          2480:       else
        !          2481:        direction = 1;
        !          2482:     }
        !          2483: 
        !          2484:   if (e3->status == NORMAL && e3->value == 0)
        !          2485:     {
        !          2486:       err(zerostep);
        !          2487:       dataerror = YES;
        !          2488:       goto ret;
        !          2489:     }
        !          2490:   else if (e3->status == MAXPLUS1 ||
        !          2491:           (e3->status == NORMAL && e3->value > 0))
        !          2492:     {
        !          2493:       if (direction == -1)
        !          2494:        {
        !          2495:          warn(order);
        !          2496:          goto ret;
        !          2497:        }
        !          2498:     }
        !          2499:   else
        !          2500:     {
        !          2501:       if (direction == 1)
        !          2502:        {
        !          2503:          warn(order);
        !          2504:          goto ret;
        !          2505:        }
        !          2506:     }
        !          2507: 
        !          2508:   dv = (dvalue *) dp->dovar;
        !          2509:   dv->status = e1->status;
        !          2510:   dv->value = e1->value;
        !          2511: 
        !          2512:   done = NO;
        !          2513:   while (done == NO && dataerror == NO)
        !          2514:     {
        !          2515:       outdata(dp->elts);
        !          2516: 
        !          2517:       if (e3->status == NORMAL && dv->status == NORMAL)
        !          2518:        {
        !          2519:          addints(e3->value, dv->value);
        !          2520:          dv->status = rstatus;
        !          2521:          dv->value = rvalue;
        !          2522:        }
        !          2523:       else
        !          2524:        {
        !          2525:          if (e3->status != NORMAL)
        !          2526:            {
        !          2527:              if (e3->status == MAXPLUS1)
        !          2528:                addin = MAXPLUS1;
        !          2529:              else
        !          2530:                addin = MINLESS1;
        !          2531:              ts = dv->status;
        !          2532:              tv = dv->value;
        !          2533:            }
        !          2534:          else
        !          2535:            {
        !          2536:              if (dv->status == MAXPLUS1)
        !          2537:                addin = MAXPLUS1;
        !          2538:              else
        !          2539:                addin = MINLESS1;
        !          2540:              ts = e3->status;
        !          2541:              tv = e3->value;
        !          2542:            }
        !          2543: 
        !          2544:          if (addin == MAXPLUS1)
        !          2545:            {
        !          2546:              if (ts == MAXPLUS1 || (ts == NORMAL && tv > 0))
        !          2547:                dv->status = ERRVAL;
        !          2548:              else if (ts == NORMAL && tv == 0)
        !          2549:                dv->status = MAXPLUS1;
        !          2550:              else if (ts == NORMAL)
        !          2551:                {
        !          2552:                  dv->status = NORMAL;
        !          2553:                  dv->value = tv + MAXINT;
        !          2554:                  dv->value++;
        !          2555:                }
        !          2556:              else
        !          2557:                {
        !          2558:                  dv->status = NORMAL;
        !          2559:                  dv->value = 0;
        !          2560:                }
        !          2561:            }
        !          2562:          else
        !          2563:            {
        !          2564:              if (ts == MINLESS1 || (ts == NORMAL && tv < 0))
        !          2565:                dv->status = ERRVAL;
        !          2566:              else if (ts == NORMAL && tv == 0)
        !          2567:                dv->status = MINLESS1;
        !          2568:              else if (ts == NORMAL)
        !          2569:                {
        !          2570:                  dv->status = NORMAL;
        !          2571:                  dv->value = tv - MAXINT;
        !          2572:                  dv->value--;
        !          2573:                }
        !          2574:              else
        !          2575:                {
        !          2576:                  dv->status = NORMAL;
        !          2577:                  dv->value = 0;
        !          2578:                }
        !          2579:            }
        !          2580:        }
        !          2581: 
        !          2582:       if (dv->status == ERRVAL)
        !          2583:        done = YES;
        !          2584:       else if (direction > 0)
        !          2585:        {
        !          2586:          if (e2->status == NORMAL)
        !          2587:            {
        !          2588:              if (dv->status == MAXPLUS1 ||
        !          2589:                  (dv->status == NORMAL && dv->value > e2->value))
        !          2590:                done = YES;
        !          2591:            }
        !          2592:        }
        !          2593:       else if (direction < 0)
        !          2594:        {
        !          2595:          if (e2->status == NORMAL)
        !          2596:            {
        !          2597:              if (dv->status == MINLESS1 ||
        !          2598:                  (dv->status == NORMAL && dv->value < e2->value))
        !          2599:                done = YES;
        !          2600:            }
        !          2601:        }
        !          2602:       else
        !          2603:        done = YES;
        !          2604:     }
        !          2605: 
        !          2606: ret:
        !          2607:   frvexpr((vexpr *) e1);
        !          2608:   frvexpr((vexpr *) e2);
        !          2609:   frvexpr((vexpr *) e3);
        !          2610:   return;
        !          2611: }

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