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