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