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