1 #include "defs.h" 2 #include "conv.h" 3 4 int badvalue; 5 6 7 /* The following constants are used to check the limits of */ 8 /* conversions. Dmaxword is the largest double precision */ 9 /* number which can be converted to a two-byte integer */ 10 /* without overflow. Dminword is the smallest double */ 11 /* precision value which can be converted to a two-byte */ 12 /* integer without overflow. Dmaxint and dminint are the */ 13 /* analogous values for four-byte integers. */ 14 15 /* short array should be correct for both VAX and TAHOE */ 16 17 LOCAL short dmaxword[] = { 0x47ff, 0xfeff, 0xffff, 0xffff }; /* 32767.5 */ 18 LOCAL short dminword[] = { 0xc800, 0x007f, 0xffff, 0xffff }; /* -32768.499999999999 */ 19 20 LOCAL short dmaxint[] = { 0x4fff, 0xffff, 0xfeff, 0xffff }; /* 2147483647.5 */ 21 LOCAL short dminint[] = { 0xd000, 0x0000, 0x007f, 0xffff }; /* -2147483648.4999999 */ 22 23 LOCAL short dmaxreal[] = { 0x7fff, 0xffff, 0x7fff, 0xffff }; /* 1.7014117838986683e+38 */ 24 LOCAL short dminreal[] = { 0xffff, 0xffff, 0x7fff, 0xffff }; /* -1.7014117838986683e+38 */ 25 26 27 28 /* The routines which follow are used to convert */ 29 /* constants into constants of other types. */ 30 31 LOCAL char * 32 grabbits(len, cp) 33 int len; 34 Constp cp; 35 { 36 37 static char *toobig = "bit value too large"; 38 39 register char *p; 40 register char *bits; 41 register int i; 42 register int k; 43 register int lenb; 44 45 bits = cp->const.ccp; 46 lenb = cp->vleng->constblock.const.ci; 47 48 p = (char *) ckalloc(len); 49 50 if (len >= lenb) 51 k = lenb; 52 else 53 { 54 k = len; 55 if ( badvalue == 0 ) 56 { 57 #if (HERE == PDP11 || HERE == VAX) 58 i = len; 59 while ( i < lenb && bits[i] == 0 ) 60 i++; 61 if (i < lenb) 62 badvalue = 1; 63 #else 64 i = lenb - len - 1; 65 while ( i >= 0 && bits[i] == 0) 66 i--; 67 if (i >= 0) 68 badvalue = 1; 69 #endif 70 if (badvalue) 71 warn(toobig); 72 } 73 } 74 75 #if (HERE == PDP11 || HERE == VAX) 76 i = 0; 77 while (i < k) 78 { 79 p[i] = bits[i]; 80 i++; 81 } 82 #else 83 i = lenb; 84 while (k > 0) 85 p[--k] = bits[--i]; 86 #endif 87 88 return (p); 89 } 90 91 92 93 LOCAL char * 94 grabbytes(len, cp) 95 int len; 96 Constp cp; 97 { 98 register char *p; 99 register char *bytes; 100 register int i; 101 register int k; 102 register int lenb; 103 104 bytes = cp->const.ccp; 105 lenb = cp->vleng->constblock.const.ci; 106 107 p = (char *) ckalloc(len); 108 109 if (len >= lenb) 110 k = lenb; 111 else 112 k = len; 113 114 i = 0; 115 while (i < k) 116 { 117 p[i] = bytes[i]; 118 i++; 119 } 120 121 while (i < len) 122 p[i++] = BLANK; 123 124 return (p); 125 } 126 127 128 129 LOCAL expptr 130 cshort(cp) 131 Constp cp; 132 { 133 static char *toobig = "data value too large"; 134 static char *reserved = "reserved operand assigned to an integer"; 135 static char *compat1 = "logical datum assigned to an integer variable"; 136 static char *compat2 = "character datum assigned to an integer variable"; 137 138 register expptr p; 139 register short *shortp; 140 register ftnint value; 141 register long *rp; 142 register double *minp; 143 register double *maxp; 144 realvalue x; 145 146 switch (cp->vtype) 147 { 148 case TYBITSTR: 149 shortp = (short *) grabbits(2, cp); 150 p = (expptr) mkconst(TYSHORT); 151 p->constblock.const.ci = *shortp; 152 free((char *) shortp); 153 break; 154 155 case TYSHORT: 156 p = (expptr) cpexpr(cp); 157 break; 158 159 case TYLONG: 160 value = cp->const.ci; 161 if (value >= MINWORD && value <= MAXWORD) 162 { 163 p = (expptr) mkconst(TYSHORT); 164 p->constblock.const.ci = value; 165 } 166 else 167 { 168 if (badvalue <= 1) 169 { 170 badvalue = 2; 171 err(toobig); 172 } 173 p = errnode(); 174 } 175 break; 176 177 case TYREAL: 178 case TYDREAL: 179 case TYCOMPLEX: 180 case TYDCOMPLEX: 181 minp = (double *) dminword; 182 maxp = (double *) dmaxword; 183 rp = (long *) &(cp->const.cd[0]); 184 x.q.word1 = rp[0]; 185 x.q.word2 = rp[1]; 186 if (x.f.sign == 1 && x.f.exp == 0) 187 { 188 if (badvalue <= 1) 189 { 190 badvalue = 2; 191 err(reserved); 192 } 193 p = errnode(); 194 } 195 else if (x.d >= *minp && x.d <= *maxp) 196 { 197 p = (expptr) mkconst(TYSHORT); 198 p->constblock.const.ci = x.d; 199 } 200 else 201 { 202 if (badvalue <= 1) 203 { 204 badvalue = 2; 205 err(toobig); 206 } 207 p = errnode(); 208 } 209 break; 210 211 case TYLOGICAL: 212 if (badvalue <= 1) 213 { 214 badvalue = 2; 215 err(compat1); 216 } 217 p = errnode(); 218 break; 219 220 case TYCHAR: 221 if ( !ftn66flag && badvalue == 0 ) 222 { 223 badvalue = 1; 224 warn(compat2); 225 } 226 227 case TYHOLLERITH: 228 shortp = (short *) grabbytes(2, cp); 229 p = (expptr) mkconst(TYSHORT); 230 p->constblock.const.ci = *shortp; 231 free((char *) shortp); 232 break; 233 234 case TYERROR: 235 p = errnode(); 236 break; 237 } 238 239 return (p); 240 } 241 242 243 244 LOCAL expptr 245 clong(cp) 246 Constp cp; 247 { 248 static char *toobig = "data value too large"; 249 static char *reserved = "reserved operand assigned to an integer"; 250 static char *compat1 = "logical datum assigned to an integer variable"; 251 static char *compat2 = "character datum assigned to an integer variable"; 252 253 register expptr p; 254 register ftnint *longp; 255 register long *rp; 256 register double *minp; 257 register double *maxp; 258 realvalue x; 259 260 switch (cp->vtype) 261 { 262 case TYBITSTR: 263 longp = (ftnint *) grabbits(4, cp); 264 p = (expptr) mkconst(TYLONG); 265 p->constblock.const.ci = *longp; 266 free((char *) longp); 267 break; 268 269 case TYSHORT: 270 p = (expptr) mkconst(TYLONG); 271 p->constblock.const.ci = cp->const.ci; 272 break; 273 274 case TYLONG: 275 p = (expptr) cpexpr(cp); 276 break; 277 278 case TYREAL: 279 case TYDREAL: 280 case TYCOMPLEX: 281 case TYDCOMPLEX: 282 minp = (double *) dminint; 283 maxp = (double *) dmaxint; 284 rp = (long *) &(cp->const.cd[0]); 285 x.q.word1 = rp[0]; 286 x.q.word2 = rp[1]; 287 if (x.f.sign == 1 && x.f.exp == 0) 288 { 289 if (badvalue <= 1) 290 { 291 badvalue = 2; 292 err(reserved); 293 } 294 p = errnode(); 295 } 296 else if (x.d >= *minp && x.d <= *maxp) 297 { 298 p = (expptr) mkconst(TYLONG); 299 p->constblock.const.ci = x.d; 300 } 301 else 302 { 303 if (badvalue <= 1) 304 { 305 badvalue = 2; 306 err(toobig); 307 } 308 p = errnode(); 309 } 310 break; 311 312 case TYLOGICAL: 313 if (badvalue <= 1) 314 { 315 badvalue = 2; 316 err(compat1); 317 } 318 p = errnode(); 319 break; 320 321 case TYCHAR: 322 if ( !ftn66flag && badvalue == 0 ) 323 { 324 badvalue = 1; 325 warn(compat2); 326 } 327 328 case TYHOLLERITH: 329 longp = (ftnint *) grabbytes(4, cp); 330 p = (expptr) mkconst(TYLONG); 331 p->constblock.const.ci = *longp; 332 free((char *) longp); 333 break; 334 335 case TYERROR: 336 p = errnode(); 337 break; 338 } 339 340 return (p); 341 } 342 343 344 345 LOCAL expptr 346 creal(cp) 347 Constp cp; 348 { 349 static char *toobig = "data value too large"; 350 static char *compat1 = "logical datum assigned to a real variable"; 351 static char *compat2 = "character datum assigned to a real variable"; 352 353 register expptr p; 354 register long *longp; 355 register long *rp; 356 register double *minp; 357 register double *maxp; 358 realvalue x; 359 float y; 360 361 switch (cp->vtype) 362 { 363 case TYBITSTR: 364 longp = (long *) grabbits(4, cp); 365 p = (expptr) mkconst(TYREAL); 366 rp = (long *) &(p->constblock.const.cd[0]); 367 rp[0] = *longp; 368 free((char *) longp); 369 break; 370 371 case TYSHORT: 372 case TYLONG: 373 p = (expptr) mkconst(TYREAL); 374 p->constblock.const.cd[0] = cp->const.ci; 375 break; 376 377 case TYREAL: 378 case TYDREAL: 379 case TYCOMPLEX: 380 case TYDCOMPLEX: 381 minp = (double *) dminreal; 382 maxp = (double *) dmaxreal; 383 rp = (long *) &(cp->const.cd[0]); 384 x.q.word1 = rp[0]; 385 x.q.word2 = rp[1]; 386 if (x.f.sign == 1 && x.f.exp == 0) 387 { 388 p = (expptr) mkconst(TYREAL); 389 rp = (long *) &(p->constblock.const.cd[0]); 390 rp[0] = x.q.word1; 391 } 392 else if (x.d >= *minp && x.d <= *maxp) 393 { 394 p = (expptr) mkconst(TYREAL); 395 y = x.d; 396 p->constblock.const.cd[0] = y; 397 } 398 else 399 { 400 if (badvalue <= 1) 401 { 402 badvalue = 2; 403 err(toobig); 404 } 405 p = errnode(); 406 } 407 break; 408 409 case TYLOGICAL: 410 if (badvalue <= 1) 411 { 412 badvalue = 2; 413 err(compat1); 414 } 415 p = errnode(); 416 break; 417 418 case TYCHAR: 419 if ( !ftn66flag && badvalue == 0) 420 { 421 badvalue = 1; 422 warn(compat2); 423 } 424 425 case TYHOLLERITH: 426 longp = (long *) grabbytes(4, cp); 427 p = (expptr) mkconst(TYREAL); 428 rp = (long *) &(p->constblock.const.cd[0]); 429 rp[0] = *longp; 430 free((char *) longp); 431 break; 432 433 case TYERROR: 434 p = errnode(); 435 break; 436 } 437 438 return (p); 439 } 440 441 442 443 LOCAL expptr 444 cdreal(cp) 445 Constp cp; 446 { 447 static char *compat1 = 448 "logical datum assigned to a double precision variable"; 449 static char *compat2 = 450 "character datum assigned to a double precision variable"; 451 452 register expptr p; 453 register long *longp; 454 register long *rp; 455 456 switch (cp->vtype) 457 { 458 case TYBITSTR: 459 longp = (long *) grabbits(8, cp); 460 p = (expptr) mkconst(TYDREAL); 461 rp = (long *) &(p->constblock.const.cd[0]); 462 rp[0] = longp[0]; 463 rp[1] = longp[1]; 464 free((char *) longp); 465 break; 466 467 case TYSHORT: 468 case TYLONG: 469 p = (expptr) mkconst(TYDREAL); 470 p->constblock.const.cd[0] = cp->const.ci; 471 break; 472 473 case TYREAL: 474 case TYDREAL: 475 case TYCOMPLEX: 476 case TYDCOMPLEX: 477 p = (expptr) mkconst(TYDREAL); 478 longp = (long *) &(cp->const.cd[0]); 479 rp = (long *) &(p->constblock.const.cd[0]); 480 rp[0] = longp[0]; 481 rp[1] = longp[1]; 482 break; 483 484 case TYLOGICAL: 485 if (badvalue <= 1) 486 { 487 badvalue = 2; 488 err(compat1); 489 } 490 p = errnode(); 491 break; 492 493 case TYCHAR: 494 if ( !ftn66flag && badvalue == 0 ) 495 { 496 badvalue = 1; 497 warn(compat2); 498 } 499 500 case TYHOLLERITH: 501 longp = (long *) grabbytes(8, cp); 502 p = (expptr) mkconst(TYDREAL); 503 rp = (long *) &(p->constblock.const.cd[0]); 504 rp[0] = longp[0]; 505 rp[1] = longp[1]; 506 free((char *) longp); 507 break; 508 509 case TYERROR: 510 p = errnode(); 511 break; 512 } 513 514 return (p); 515 } 516 517 518 519 LOCAL expptr 520 ccomplex(cp) 521 Constp cp; 522 { 523 static char *toobig = "data value too large"; 524 static char *compat1 = "logical datum assigned to a complex variable"; 525 static char *compat2 = "character datum assigned to a complex variable"; 526 527 register expptr p; 528 register long *longp; 529 register long *rp; 530 register double *minp; 531 register double *maxp; 532 realvalue re, im; 533 int overflow; 534 float x; 535 536 switch (cp->vtype) 537 { 538 case TYBITSTR: 539 longp = (long *) grabbits(8, cp); 540 p = (expptr) mkconst(TYCOMPLEX); 541 rp = (long *) &(p->constblock.const.cd[0]); 542 rp[0] = longp[0]; 543 rp[2] = longp[1]; 544 free((char *) longp); 545 break; 546 547 case TYSHORT: 548 case TYLONG: 549 p = (expptr) mkconst(TYCOMPLEX); 550 p->constblock.const.cd[0] = cp->const.ci; 551 break; 552 553 case TYREAL: 554 case TYDREAL: 555 case TYCOMPLEX: 556 case TYDCOMPLEX: 557 overflow = 0; 558 minp = (double *) dminreal; 559 maxp = (double *) dmaxreal; 560 rp = (long *) &(cp->const.cd[0]); 561 re.q.word1 = rp[0]; 562 re.q.word2 = rp[1]; 563 im.q.word1 = rp[2]; 564 im.q.word2 = rp[3]; 565 if (((re.f.sign == 0 || re.f.exp != 0) && 566 (re.d < *minp || re.d > *maxp)) || 567 ((im.f.sign == 0 || re.f.exp != 0) && 568 (im.d < *minp || re.d > *maxp))) 569 { 570 if (badvalue <= 1) 571 { 572 badvalue = 2; 573 err(toobig); 574 } 575 p = errnode(); 576 } 577 else 578 { 579 p = (expptr) mkconst(TYCOMPLEX); 580 if (re.f.sign == 1 && re.f.exp == 0) 581 re.q.word2 = 0; 582 else 583 { 584 x = re.d; 585 re.d = x; 586 } 587 if (im.f.sign == 1 && im.f.exp == 0) 588 im.q.word2 = 0; 589 else 590 { 591 x = im.d; 592 im.d = x; 593 } 594 rp = (long *) &(p->constblock.const.cd[0]); 595 rp[0] = re.q.word1; 596 rp[1] = re.q.word2; 597 rp[2] = im.q.word1; 598 rp[3] = im.q.word2; 599 } 600 break; 601 602 case TYLOGICAL: 603 if (badvalue <= 1) 604 { 605 badvalue = 2; 606 err(compat1); 607 } 608 break; 609 610 case TYCHAR: 611 if ( !ftn66flag && badvalue == 0) 612 { 613 badvalue = 1; 614 warn(compat2); 615 } 616 617 case TYHOLLERITH: 618 longp = (long *) grabbytes(8, cp); 619 p = (expptr) mkconst(TYCOMPLEX); 620 rp = (long *) &(p->constblock.const.cd[0]); 621 rp[0] = longp[0]; 622 rp[2] = longp[1]; 623 free((char *) longp); 624 break; 625 626 case TYERROR: 627 p = errnode(); 628 break; 629 } 630 631 return (p); 632 } 633 634 635 636 LOCAL expptr 637 cdcomplex(cp) 638 Constp cp; 639 { 640 static char *compat1 = "logical datum assigned to a complex variable"; 641 static char *compat2 = "character datum assigned to a complex variable"; 642 643 register expptr p; 644 register long *longp; 645 register long *rp; 646 647 switch (cp->vtype) 648 { 649 case TYBITSTR: 650 longp = (long *) grabbits(16, cp); 651 p = (expptr) mkconst(TYDCOMPLEX); 652 rp = (long *) &(p->constblock.const.cd[0]); 653 rp[0] = longp[0]; 654 rp[1] = longp[1]; 655 rp[2] = longp[2]; 656 rp[3] = longp[3]; 657 free((char *) longp); 658 break; 659 660 case TYSHORT: 661 case TYLONG: 662 p = (expptr) mkconst(TYDCOMPLEX); 663 p->constblock.const.cd[0] = cp->const.ci; 664 break; 665 666 case TYREAL: 667 case TYDREAL: 668 case TYCOMPLEX: 669 case TYDCOMPLEX: 670 p = (expptr) mkconst(TYDCOMPLEX); 671 longp = (long *) &(cp->const.cd[0]); 672 rp = (long *) &(p->constblock.const.cd[0]); 673 rp[0] = longp[0]; 674 rp[1] = longp[1]; 675 rp[2] = longp[2]; 676 rp[3] = longp[3]; 677 break; 678 679 case TYLOGICAL: 680 if (badvalue <= 1) 681 { 682 badvalue = 2; 683 err(compat1); 684 } 685 p = errnode(); 686 break; 687 688 case TYCHAR: 689 if ( !ftn66flag && badvalue == 0 ) 690 { 691 badvalue = 1; 692 warn(compat2); 693 } 694 695 case TYHOLLERITH: 696 longp = (long *) grabbytes(16, cp); 697 p = (expptr) mkconst(TYDCOMPLEX); 698 rp = (long *) &(p->constblock.const.cd[0]); 699 rp[0] = longp[0]; 700 rp[1] = longp[1]; 701 rp[2] = longp[2]; 702 rp[3] = longp[3]; 703 free((char *) longp); 704 break; 705 706 case TYERROR: 707 p = errnode(); 708 break; 709 } 710 711 return (p); 712 } 713 714 715 716 LOCAL expptr 717 clogical(cp) 718 Constp cp; 719 { 720 static char *compat1 = "numeric datum assigned to a logical variable"; 721 static char *compat2 = "character datum assigned to a logical variable"; 722 723 register expptr p; 724 register long *longp; 725 register short *shortp; 726 register int size; 727 728 size = typesize[tylogical]; 729 730 switch (cp->vtype) 731 { 732 case TYBITSTR: 733 p = (expptr) mkconst(tylogical); 734 if (tylogical == TYSHORT) 735 { 736 shortp = (short *) grabbits(size, cp); 737 p->constblock.const.ci = (int) *shortp; 738 free((char *) shortp); 739 } 740 else 741 { 742 longp = (long *) grabbits(size, cp); 743 p->constblock.const.ci = *longp; 744 free((char *) longp); 745 } 746 break; 747 748 case TYSHORT: 749 case TYLONG: 750 case TYREAL: 751 case TYDREAL: 752 case TYCOMPLEX: 753 case TYDCOMPLEX: 754 if (badvalue <= 1) 755 { 756 badvalue = 2; 757 err(compat1); 758 } 759 p = errnode(); 760 break; 761 762 case TYLOGICAL: 763 p = (expptr) cpexpr(cp); 764 p->constblock.vtype = tylogical; 765 break; 766 767 case TYCHAR: 768 if ( !ftn66flag && badvalue == 0 ) 769 { 770 badvalue = 1; 771 warn(compat2); 772 } 773 774 case TYHOLLERITH: 775 p = (expptr) mkconst(tylogical); 776 if (tylogical == TYSHORT) 777 { 778 shortp = (short *) grabbytes(size, cp); 779 p->constblock.const.ci = (int) *shortp; 780 free((char *) shortp); 781 } 782 else 783 { 784 longp = (long *) grabbytes(4, cp); 785 p->constblock.const.ci = *longp; 786 free((char *) longp); 787 } 788 break; 789 790 case TYERROR: 791 p = errnode(); 792 break; 793 } 794 795 return (p); 796 } 797 798 799 800 LOCAL expptr 801 cchar(len, cp) 802 int len; 803 Constp cp; 804 { 805 static char *compat1 = "numeric datum assigned to a character variable"; 806 static char *compat2 = "logical datum assigned to a character variable"; 807 808 register expptr p; 809 register char *value; 810 811 switch (cp->vtype) 812 { 813 case TYBITSTR: 814 value = grabbits(len, cp); 815 p = (expptr) mkstrcon(len, value); 816 free(value); 817 break; 818 819 case TYSHORT: 820 case TYLONG: 821 case TYREAL: 822 case TYDREAL: 823 case TYCOMPLEX: 824 case TYDCOMPLEX: 825 if (badvalue <= 1) 826 { 827 badvalue = 2; 828 err(compat1); 829 } 830 p = errnode(); 831 break; 832 833 case TYLOGICAL: 834 if (badvalue <= 1) 835 { 836 badvalue = 2; 837 err(compat2); 838 } 839 p = errnode(); 840 break; 841 842 case TYCHAR: 843 case TYHOLLERITH: 844 value = grabbytes(len, cp); 845 p = (expptr) mkstrcon(len, value); 846 free(value); 847 break; 848 849 case TYERROR: 850 p = errnode(); 851 break; 852 } 853 854 return (p); 855 } 856 857 858 859 expptr 860 convconst(type, len, const) 861 int type; 862 int len; 863 Constp const; 864 { 865 register expptr p; 866 867 switch (type) 868 { 869 case TYSHORT: 870 p = cshort(const); 871 break; 872 873 case TYLONG: 874 p = clong(const); 875 break; 876 877 case TYREAL: 878 p = creal(const); 879 break; 880 881 case TYDREAL: 882 p = cdreal(const); 883 break; 884 885 case TYCOMPLEX: 886 p = ccomplex(const); 887 break; 888 889 case TYDCOMPLEX: 890 p = cdcomplex(const); 891 break; 892 893 case TYLOGICAL: 894 p = clogical(const); 895 break; 896 897 case TYCHAR: 898 p = cchar(len, const); 899 break; 900 901 case TYERROR: 902 case TYUNKNOWN: 903 p = errnode(); 904 break; 905 906 default: 907 badtype("convconst", type); 908 } 909 910 return (p); 911 } 912