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.constant.ci == MININT) 718 p->status = MINLESS1; 719 else 720 { 721 p->status = NORMAL; 722 p->value = tp->paramval->constblock.constant.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.constant.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.constant.ci; 1874 index = sub[i] + index * size; 1875 } 1876 1877 index -= dp->baseoffset->constblock.constant.ci; 1878 1879 if (index < 0 || index >= dp->nelt->constblock.constant.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.constant.ci; 1956 else 1957 nelt = 1; 1958 type = np->vtype; 1959 if (type == TYCHAR) 1960 typelen = np->vleng->constblock.constant.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, constant) 2006 long offset; 2007 ftnint repl; 2008 ftnint len; 2009 char *constant; 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 (constant[--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, constant, 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 constant; 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.constant.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 constant = getdatum(); 2345 if (constant == NULL || !ISCONST(constant)) 2346 return; 2347 2348 constant = (Constp) convconst(type, typelen, constant); 2349 if (constant == NULL || !ISCONST(constant)) 2350 { 2351 frexpr((tagptr) constant); 2352 return; 2353 } 2354 2355 if (type == TYCHAR) 2356 wrtdata(base + soffset, 1, typelen, constant->constant.ccp); 2357 else 2358 wrtdata(base + soffset, 1, typelen, packbytes(constant)); 2359 2360 frexpr((tagptr) constant); 2361 } 2362 else 2363 { 2364 soffset = 0; 2365 k = np->vdim->nelt->constblock.constant.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 constant = grvals->value; 2386 if (constant == NULL || !ISCONST(constant)) 2387 { 2388 dataerror = YES; 2389 } 2390 else 2391 { 2392 constant = (Constp) convconst(type, typelen, constant); 2393 if (constant == NULL || !ISCONST(constant)) 2394 { 2395 dataerror = YES; 2396 frexpr((tagptr) constant); 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, 2410 constant->constant.ccp); 2411 else 2412 wrtdata(base+soffset, repl, typelen, 2413 packbytes(constant)); 2414 2415 soffset = soffset + repl * typelen; 2416 2417 frexpr((tagptr) constant); 2418 } 2419 } 2420 } 2421 } 2422 } 2423 2424 return; 2425 } 2426 2427 2428 2429 outdolist(dp) 2430 dolist *dp; 2431 { 2432 static char *zerostep = "zero step in implied-DO"; 2433 static char *order = "zero iteration count in implied-DO"; 2434 2435 register dvalue *e1, *e2, *e3; 2436 register int direction; 2437 register dvalue *dv; 2438 register int done; 2439 register int addin; 2440 register int ts; 2441 register ftnint tv; 2442 2443 e1 = (dvalue *) evalvexpr(dp->init); 2444 e2 = (dvalue *) evalvexpr(dp->limit); 2445 e3 = (dvalue *) evalvexpr(dp->step); 2446 2447 if (e1->status == ERRVAL || 2448 e2->status == ERRVAL || 2449 e3->status == ERRVAL) 2450 { 2451 dataerror = YES; 2452 goto ret; 2453 } 2454 2455 if (e1->status == NORMAL) 2456 { 2457 if (e2->status == NORMAL) 2458 { 2459 if (e1->value < e2->value) 2460 direction = 1; 2461 else if (e1->value > e2->value) 2462 direction = -1; 2463 else 2464 direction = 0; 2465 } 2466 else if (e2->status == MAXPLUS1) 2467 direction = 1; 2468 else 2469 direction = -1; 2470 } 2471 else if (e1->status == MAXPLUS1) 2472 { 2473 if (e2->status == MAXPLUS1) 2474 direction = 0; 2475 else 2476 direction = -1; 2477 } 2478 else 2479 { 2480 if (e2->status == MINLESS1) 2481 direction = 0; 2482 else 2483 direction = 1; 2484 } 2485 2486 if (e3->status == NORMAL && e3->value == 0) 2487 { 2488 err(zerostep); 2489 dataerror = YES; 2490 goto ret; 2491 } 2492 else if (e3->status == MAXPLUS1 || 2493 (e3->status == NORMAL && e3->value > 0)) 2494 { 2495 if (direction == -1) 2496 { 2497 warn(order); 2498 goto ret; 2499 } 2500 } 2501 else 2502 { 2503 if (direction == 1) 2504 { 2505 warn(order); 2506 goto ret; 2507 } 2508 } 2509 2510 dv = (dvalue *) dp->dovar; 2511 dv->status = e1->status; 2512 dv->value = e1->value; 2513 2514 done = NO; 2515 while (done == NO && dataerror == NO) 2516 { 2517 outdata(dp->elts); 2518 2519 if (e3->status == NORMAL && dv->status == NORMAL) 2520 { 2521 addints(e3->value, dv->value); 2522 dv->status = rstatus; 2523 dv->value = rvalue; 2524 } 2525 else 2526 { 2527 if (e3->status != NORMAL) 2528 { 2529 if (e3->status == MAXPLUS1) 2530 addin = MAXPLUS1; 2531 else 2532 addin = MINLESS1; 2533 ts = dv->status; 2534 tv = dv->value; 2535 } 2536 else 2537 { 2538 if (dv->status == MAXPLUS1) 2539 addin = MAXPLUS1; 2540 else 2541 addin = MINLESS1; 2542 ts = e3->status; 2543 tv = e3->value; 2544 } 2545 2546 if (addin == MAXPLUS1) 2547 { 2548 if (ts == MAXPLUS1 || (ts == NORMAL && tv > 0)) 2549 dv->status = ERRVAL; 2550 else if (ts == NORMAL && tv == 0) 2551 dv->status = MAXPLUS1; 2552 else if (ts == NORMAL) 2553 { 2554 dv->status = NORMAL; 2555 dv->value = tv + MAXINT; 2556 dv->value++; 2557 } 2558 else 2559 { 2560 dv->status = NORMAL; 2561 dv->value = 0; 2562 } 2563 } 2564 else 2565 { 2566 if (ts == MINLESS1 || (ts == NORMAL && tv < 0)) 2567 dv->status = ERRVAL; 2568 else if (ts == NORMAL && tv == 0) 2569 dv->status = MINLESS1; 2570 else if (ts == NORMAL) 2571 { 2572 dv->status = NORMAL; 2573 dv->value = tv - MAXINT; 2574 dv->value--; 2575 } 2576 else 2577 { 2578 dv->status = NORMAL; 2579 dv->value = 0; 2580 } 2581 } 2582 } 2583 2584 if (dv->status == ERRVAL) 2585 done = YES; 2586 else if (direction > 0) 2587 { 2588 if (e2->status == NORMAL) 2589 { 2590 if (dv->status == MAXPLUS1 || 2591 (dv->status == NORMAL && dv->value > e2->value)) 2592 done = YES; 2593 } 2594 } 2595 else if (direction < 0) 2596 { 2597 if (e2->status == NORMAL) 2598 { 2599 if (dv->status == MINLESS1 || 2600 (dv->status == NORMAL && dv->value < e2->value)) 2601 done = YES; 2602 } 2603 } 2604 else 2605 done = YES; 2606 } 2607 2608 ret: 2609 frvexpr((vexpr *) e1); 2610 frvexpr((vexpr *) e2); 2611 frvexpr((vexpr *) e3); 2612 return; 2613 } 2614