4.3BSD - /usr/src/usr.bin/f77/src/f77pass1/data.c

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