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[] = "@(#)expr.c 5.1 (Berkeley) 06/07/85"; 9 #endif not lint 10 11 /* 12 * expr.c 13 * 14 * Routines for handling expressions, f77 compiler pass 1. 15 * 16 * University of Utah CS Dept modification history: 17 * 18 * Revision 3.13 85/05/13 16:40:37 mckusick 19 * fix to copy character values into numerics (from donn@utah-cs) 20 * 21 * Revision 3.12 85/03/18 08:07:47 donn 22 * Fixes to help out with short integers -- if integers are by default short, 23 * then so are constants; and if addresses can't be stored in shorts, complain. 24 * 25 * Revision 3.11 85/03/16 22:31:27 donn 26 * Added hack to mkconv() to allow character values of length > 1 to be 27 * converted to numeric types, for Helge Skrivervik. Note that this does 28 * not affect use of the intrinsic ichar() conversion. 29 * 30 * Revision 3.10 85/01/15 21:06:47 donn 31 * Changed mkconv() to comment on implicit conversions; added intrconv() for 32 * use with explicit conversions by intrinsic functions. 33 * 34 * Revision 3.9 85/01/11 21:05:49 donn 35 * Added changes to implement SAVE statements. 36 * 37 * Revision 3.8 84/12/17 02:21:06 donn 38 * Added a test to prevent constant folding from being done on expressions 39 * whose type is not known at that point in mkexpr(). 40 * 41 * Revision 3.7 84/12/11 21:14:17 donn 42 * Removed obnoxious 'excess precision' warning. 43 * 44 * Revision 3.6 84/11/23 01:00:36 donn 45 * Added code to trim excess precision from single-precision constants, and 46 * to warn the user when this occurs. 47 * 48 * Revision 3.5 84/11/23 00:10:39 donn 49 * Changed stfcall() to remark on argument type clashes in 'calls' to 50 * statement functions. 51 * 52 * Revision 3.4 84/11/22 21:21:17 donn 53 * Fixed bug in fix to mkexpr() that caused IMPLICIT to affect intrinsics. 54 * 55 * Revision 3.3 84/11/12 18:26:14 donn 56 * Shuffled some code around so that the compiler remembers to free some vleng 57 * structures which used to just sit around. 58 * 59 * Revision 3.2 84/10/16 19:24:15 donn 60 * Fix for Peter Montgomery's bug with -C and invalid subscripts -- prevent 61 * core dumps by replacing bad subscripts with good ones. 62 * 63 * Revision 3.1 84/10/13 01:31:32 donn 64 * Merged Jerry Berkman's version into mine. 65 * 66 * Revision 2.7 84/09/27 15:42:52 donn 67 * The last fix for multiplying undeclared variables by 0 isn't sufficient, 68 * since the type of the 0 may not be the (implicit) type of the variable. 69 * I added a hack to check the implicit type of implicitly declared 70 * variables... 71 * 72 * Revision 2.6 84/09/14 19:34:03 donn 73 * Problem noted by Mike Vevea -- mkexpr will sometimes attempt to convert 74 * 0 to type UNKNOWN, which is illegal. Fix is to use native type instead. 75 * Not sure how correct (or important) this is... 76 * 77 * Revision 2.5 84/08/05 23:05:27 donn 78 * Added fixes to prevent fixexpr() from slicing and dicing complex conversions 79 * with two operands. 80 * 81 * Revision 2.4 84/08/05 17:34:48 donn 82 * Added an optimization to mklhs() to detect substrings of the form ch(i:i) 83 * and assign constant length 1 to them. 84 * 85 * Revision 2.3 84/07/19 19:38:33 donn 86 * Added a typecast to the last fix. Somehow I missed it the first time... 87 * 88 * Revision 2.2 84/07/19 17:19:57 donn 89 * Caused OPPAREN expressions to inherit the length of their operands, so 90 * that parenthesized character expressions work correctly. 91 * 92 * Revision 2.1 84/07/19 12:03:02 donn 93 * Changed comment headers for UofU. 94 * 95 * Revision 1.2 84/04/06 20:12:17 donn 96 * Fixed bug which caused programs with mixed-type multiplications involving 97 * the constant 0 to choke the compiler. 98 * 99 */ 100 101 #include "defs.h" 102 103 104 /* little routines to create constant blocks */ 105 106 Constp mkconst(t) 107 register int t; 108 { 109 register Constp p; 110 111 p = ALLOC(Constblock); 112 p->tag = TCONST; 113 p->vtype = t; 114 return(p); 115 } 116 117 118 expptr mklogcon(l) 119 register int l; 120 { 121 register Constp p; 122 123 p = mkconst(TYLOGICAL); 124 p->const.ci = l; 125 return( (expptr) p ); 126 } 127 128 129 130 expptr mkintcon(l) 131 ftnint l; 132 { 133 register Constp p; 134 int usetype; 135 136 if(tyint == TYSHORT) 137 { 138 short s = l; 139 if(l != s) 140 usetype = TYLONG; 141 else 142 usetype = TYSHORT; 143 } 144 else 145 usetype = tyint; 146 p = mkconst(usetype); 147 p->const.ci = l; 148 return( (expptr) p ); 149 } 150 151 152 153 expptr mkaddcon(l) 154 register int l; 155 { 156 register Constp p; 157 158 p = mkconst(TYADDR); 159 p->const.ci = l; 160 return( (expptr) p ); 161 } 162 163 164 165 expptr mkrealcon(t, d) 166 register int t; 167 double d; 168 { 169 register Constp p; 170 171 if(t == TYREAL) 172 { 173 float f = d; 174 if(f != d) 175 { 176 #ifdef notdef 177 warn("excess precision in real constant lost"); 178 #endif notdef 179 d = f; 180 } 181 } 182 p = mkconst(t); 183 p->const.cd[0] = d; 184 return( (expptr) p ); 185 } 186 187 188 expptr mkbitcon(shift, leng, s) 189 int shift; 190 register int leng; 191 register char *s; 192 { 193 Constp p; 194 register int i, j, k; 195 register char *bp; 196 int size; 197 198 size = (shift*leng + BYTESIZE -1)/BYTESIZE; 199 bp = (char *) ckalloc(size); 200 201 i = 0; 202 203 #if (TARGET == PDP11 || TARGET == VAX) 204 j = 0; 205 #else 206 j = size; 207 #endif 208 209 k = 0; 210 211 while (leng > 0) 212 { 213 k |= (hextoi(s[--leng]) << i); 214 i += shift; 215 if (i >= BYTESIZE) 216 { 217 #if (TARGET == PDP11 || TARGET == VAX) 218 bp[j++] = k & MAXBYTE; 219 #else 220 bp[--j] = k & MAXBYTE; 221 #endif 222 k = k >> BYTESIZE; 223 i -= BYTESIZE; 224 } 225 } 226 227 if (k != 0) 228 #if (TARGET == PDP11 || TARGET == VAX) 229 bp[j++] = k; 230 #else 231 bp[--j] = k; 232 #endif 233 234 p = mkconst(TYBITSTR); 235 p->vleng = ICON(size); 236 p->const.ccp = bp; 237 238 return ((expptr) p); 239 } 240 241 242 243 expptr mkstrcon(l,v) 244 int l; 245 register char *v; 246 { 247 register Constp p; 248 register char *s; 249 250 p = mkconst(TYCHAR); 251 p->vleng = ICON(l); 252 p->const.ccp = s = (char *) ckalloc(l); 253 while(--l >= 0) 254 *s++ = *v++; 255 return( (expptr) p ); 256 } 257 258 259 expptr mkcxcon(realp,imagp) 260 register expptr realp, imagp; 261 { 262 int rtype, itype; 263 register Constp p; 264 265 rtype = realp->headblock.vtype; 266 itype = imagp->headblock.vtype; 267 268 if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) ) 269 { 270 p = mkconst( (rtype==TYDREAL||itype==TYDREAL) ? TYDCOMPLEX : TYCOMPLEX); 271 if( ISINT(rtype) ) 272 p->const.cd[0] = realp->constblock.const.ci; 273 else p->const.cd[0] = realp->constblock.const.cd[0]; 274 if( ISINT(itype) ) 275 p->const.cd[1] = imagp->constblock.const.ci; 276 else p->const.cd[1] = imagp->constblock.const.cd[0]; 277 } 278 else 279 { 280 err("invalid complex constant"); 281 p = (Constp) errnode(); 282 } 283 284 frexpr(realp); 285 frexpr(imagp); 286 return( (expptr) p ); 287 } 288 289 290 expptr errnode() 291 { 292 struct Errorblock *p; 293 p = ALLOC(Errorblock); 294 p->tag = TERROR; 295 p->vtype = TYERROR; 296 return( (expptr) p ); 297 } 298 299 300 301 302 303 expptr mkconv(t, p) 304 register int t; 305 register expptr p; 306 { 307 register expptr q; 308 Addrp r, s; 309 register int pt; 310 expptr opconv(); 311 312 if(t==TYUNKNOWN || t==TYERROR) 313 badtype("mkconv", t); 314 pt = p->headblock.vtype; 315 if(t == pt) 316 return(p); 317 318 if( pt == TYCHAR && ISNUMERIC(t) ) 319 { 320 warn("implicit conversion of character to numeric type"); 321 322 /* 323 * Ugly kluge to copy character values into numerics. 324 */ 325 s = mkaltemp(t, ENULL); 326 r = (Addrp) cpexpr(s); 327 r->vtype = TYCHAR; 328 r->varleng = typesize[t]; 329 r->vleng = mkintcon(r->varleng); 330 q = mkexpr(OPASSIGN, r, p); 331 q = mkexpr(OPCOMMA, q, s); 332 return(q); 333 } 334 335 #if SZADDR > SZSHORT 336 if( pt == TYADDR && t == TYSHORT) 337 { 338 err("insufficient precision to hold address type"); 339 return( errnode() ); 340 } 341 #endif 342 if( pt == TYADDR && ISNUMERIC(t) ) 343 warn("implicit conversion of address to numeric type"); 344 345 if( ISCONST(p) && pt!=TYADDR) 346 { 347 q = (expptr) mkconst(t); 348 consconv(t, &(q->constblock.const), 349 p->constblock.vtype, &(p->constblock.const) ); 350 frexpr(p); 351 } 352 #if TARGET == PDP11 353 else if(ISINT(t) && pt==TYCHAR) 354 { 355 q = mkexpr(OPBITAND, opconv(p,TYSHORT), ICON(255)); 356 if(t == TYLONG) 357 q = opconv(q, TYLONG); 358 } 359 #endif 360 else 361 q = opconv(p, t); 362 363 if(t == TYCHAR) 364 q->constblock.vleng = ICON(1); 365 return(q); 366 } 367 368 369 370 /* intrinsic conversions */ 371 expptr intrconv(t, p) 372 register int t; 373 register expptr p; 374 { 375 register expptr q; 376 register int pt; 377 expptr opconv(); 378 379 if(t==TYUNKNOWN || t==TYERROR) 380 badtype("intrconv", t); 381 pt = p->headblock.vtype; 382 if(t == pt) 383 return(p); 384 385 else if( ISCONST(p) && pt!=TYADDR) 386 { 387 q = (expptr) mkconst(t); 388 consconv(t, &(q->constblock.const), 389 p->constblock.vtype, &(p->constblock.const) ); 390 frexpr(p); 391 } 392 #if TARGET == PDP11 393 else if(ISINT(t) && pt==TYCHAR) 394 { 395 q = mkexpr(OPBITAND, opconv(p,TYSHORT), ICON(255)); 396 if(t == TYLONG) 397 q = opconv(q, TYLONG); 398 } 399 #endif 400 else 401 q = opconv(p, t); 402 403 if(t == TYCHAR) 404 q->constblock.vleng = ICON(1); 405 return(q); 406 } 407 408 409 410 expptr opconv(p, t) 411 expptr p; 412 int t; 413 { 414 register expptr q; 415 416 q = mkexpr(OPCONV, p, PNULL); 417 q->headblock.vtype = t; 418 return(q); 419 } 420 421 422 423 expptr addrof(p) 424 expptr p; 425 { 426 return( mkexpr(OPADDR, p, PNULL) ); 427 } 428 429 430 431 tagptr cpexpr(p) 432 register tagptr p; 433 { 434 register tagptr e; 435 int tag; 436 register chainp ep, pp; 437 tagptr cpblock(); 438 439 static int blksize[ ] = 440 { 0, 441 sizeof(struct Nameblock), 442 sizeof(struct Constblock), 443 sizeof(struct Exprblock), 444 sizeof(struct Addrblock), 445 sizeof(struct Tempblock), 446 sizeof(struct Primblock), 447 sizeof(struct Listblock), 448 sizeof(struct Errorblock) 449 }; 450 451 if(p == NULL) 452 return(NULL); 453 454 if( (tag = p->tag) == TNAME) 455 return(p); 456 457 e = cpblock( blksize[p->tag] , p); 458 459 switch(tag) 460 { 461 case TCONST: 462 if(e->constblock.vtype == TYCHAR) 463 { 464 e->constblock.const.ccp = 465 copyn(1+strlen(e->constblock.const.ccp), 466 e->constblock.const.ccp); 467 e->constblock.vleng = 468 (expptr) cpexpr(e->constblock.vleng); 469 } 470 case TERROR: 471 break; 472 473 case TEXPR: 474 e->exprblock.leftp = (expptr) cpexpr(p->exprblock.leftp); 475 e->exprblock.rightp = (expptr) cpexpr(p->exprblock.rightp); 476 break; 477 478 case TLIST: 479 if(pp = p->listblock.listp) 480 { 481 ep = e->listblock.listp = 482 mkchain( cpexpr(pp->datap), CHNULL); 483 for(pp = pp->nextp ; pp ; pp = pp->nextp) 484 ep = ep->nextp = 485 mkchain( cpexpr(pp->datap), CHNULL); 486 } 487 break; 488 489 case TADDR: 490 e->addrblock.vleng = (expptr) cpexpr(e->addrblock.vleng); 491 e->addrblock.memoffset = (expptr)cpexpr(e->addrblock.memoffset); 492 e->addrblock.istemp = NO; 493 break; 494 495 case TTEMP: 496 e->tempblock.vleng = (expptr) cpexpr(e->tempblock.vleng); 497 e->tempblock.istemp = NO; 498 break; 499 500 case TPRIM: 501 e->primblock.argsp = (struct Listblock *) 502 cpexpr(e->primblock.argsp); 503 e->primblock.fcharp = (expptr) cpexpr(e->primblock.fcharp); 504 e->primblock.lcharp = (expptr) cpexpr(e->primblock.lcharp); 505 break; 506 507 default: 508 badtag("cpexpr", tag); 509 } 510 511 return(e); 512 } 513 514 frexpr(p) 515 register tagptr p; 516 { 517 register chainp q; 518 519 if(p == NULL) 520 return; 521 522 switch(p->tag) 523 { 524 case TCONST: 525 switch (p->constblock.vtype) 526 { 527 case TYBITSTR: 528 case TYCHAR: 529 case TYHOLLERITH: 530 free( (charptr) (p->constblock.const.ccp) ); 531 frexpr(p->constblock.vleng); 532 } 533 break; 534 535 case TADDR: 536 if (!optimflag && p->addrblock.istemp) 537 { 538 frtemp(p); 539 return; 540 } 541 frexpr(p->addrblock.vleng); 542 frexpr(p->addrblock.memoffset); 543 break; 544 545 case TTEMP: 546 frexpr(p->tempblock.vleng); 547 break; 548 549 case TERROR: 550 break; 551 552 case TNAME: 553 return; 554 555 case TPRIM: 556 frexpr(p->primblock.argsp); 557 frexpr(p->primblock.fcharp); 558 frexpr(p->primblock.lcharp); 559 break; 560 561 case TEXPR: 562 frexpr(p->exprblock.leftp); 563 if(p->exprblock.rightp) 564 frexpr(p->exprblock.rightp); 565 break; 566 567 case TLIST: 568 for(q = p->listblock.listp ; q ; q = q->nextp) 569 frexpr(q->datap); 570 frchain( &(p->listblock.listp) ); 571 break; 572 573 default: 574 badtag("frexpr", p->tag); 575 } 576 577 free( (charptr) p ); 578 } 579 580 /* fix up types in expression; replace subtrees and convert 581 names to address blocks */ 582 583 expptr fixtype(p) 584 register tagptr p; 585 { 586 587 if(p == 0) 588 return(0); 589 590 switch(p->tag) 591 { 592 case TCONST: 593 return( (expptr) p ); 594 595 case TADDR: 596 p->addrblock.memoffset = fixtype(p->addrblock.memoffset); 597 return( (expptr) p); 598 599 case TTEMP: 600 return( (expptr) p); 601 602 case TERROR: 603 return( (expptr) p); 604 605 default: 606 badtag("fixtype", p->tag); 607 608 case TEXPR: 609 return( fixexpr(p) ); 610 611 case TLIST: 612 return( (expptr) p ); 613 614 case TPRIM: 615 if(p->primblock.argsp && p->primblock.namep->vclass!=CLVAR) 616 { 617 if(p->primblock.namep->vtype == TYSUBR) 618 { 619 err("function invocation of subroutine"); 620 return( errnode() ); 621 } 622 else 623 return( mkfunct(p) ); 624 } 625 else return( mklhs(p) ); 626 } 627 } 628 629 630 631 632 633 /* special case tree transformations and cleanups of expression trees */ 634 635 expptr fixexpr(p) 636 register Exprp p; 637 { 638 expptr lp; 639 register expptr rp; 640 register expptr q; 641 int opcode, ltype, rtype, ptype, mtype; 642 expptr lconst, rconst; 643 expptr mkpower(); 644 645 if( ISERROR(p) ) 646 return( (expptr) p ); 647 else if(p->tag != TEXPR) 648 badtag("fixexpr", p->tag); 649 opcode = p->opcode; 650 if (ISCONST(p->leftp)) 651 lconst = (expptr) cpexpr(p->leftp); 652 else 653 lconst = NULL; 654 if (p->rightp && ISCONST(p->rightp)) 655 rconst = (expptr) cpexpr(p->rightp); 656 else 657 rconst = NULL; 658 lp = p->leftp = fixtype(p->leftp); 659 ltype = lp->headblock.vtype; 660 if(opcode==OPASSIGN && lp->tag!=TADDR && lp->tag!=TTEMP) 661 { 662 err("left side of assignment must be variable"); 663 frexpr(p); 664 return( errnode() ); 665 } 666 667 if(p->rightp) 668 { 669 rp = p->rightp = fixtype(p->rightp); 670 rtype = rp->headblock.vtype; 671 } 672 else 673 { 674 rp = NULL; 675 rtype = 0; 676 } 677 678 if(ltype==TYERROR || rtype==TYERROR) 679 { 680 frexpr(p); 681 frexpr(lconst); 682 frexpr(rconst); 683 return( errnode() ); 684 } 685 686 /* force folding if possible */ 687 if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) ) 688 { 689 q = mkexpr(opcode, lp, rp); 690 if( ISCONST(q) ) 691 { 692 frexpr(lconst); 693 frexpr(rconst); 694 return(q); 695 } 696 free( (charptr) q ); /* constants did not fold */ 697 } 698 699 if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR) 700 { 701 frexpr(p); 702 frexpr(lconst); 703 frexpr(rconst); 704 return( errnode() ); 705 } 706 707 switch(opcode) 708 { 709 case OPCONCAT: 710 if(p->vleng == NULL) 711 p->vleng = mkexpr(OPPLUS, 712 cpexpr(lp->headblock.vleng), 713 cpexpr(rp->headblock.vleng) ); 714 break; 715 716 case OPASSIGN: 717 case OPPLUSEQ: 718 case OPSTAREQ: 719 if(ltype == rtype) 720 break; 721 if( ! rconst && ISREAL(ltype) && ISREAL(rtype) ) 722 break; 723 if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) ) 724 break; 725 if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT) 726 #if FAMILY==PCC 727 && typesize[ltype]>=typesize[rtype] ) 728 #else 729 && typesize[ltype]==typesize[rtype] ) 730 #endif 731 break; 732 if (rconst) 733 { 734 p->rightp = fixtype( mkconv(ptype, cpexpr(rconst)) ); 735 frexpr(rp); 736 } 737 else 738 p->rightp = fixtype(mkconv(ptype, rp)); 739 break; 740 741 case OPSLASH: 742 if( ISCOMPLEX(rtype) ) 743 { 744 p = (Exprp) call2(ptype, 745 ptype==TYCOMPLEX? "c_div" : "z_div", 746 mkconv(ptype, lp), mkconv(ptype, rp) ); 747 break; 748 } 749 case OPPLUS: 750 case OPMINUS: 751 case OPSTAR: 752 case OPMOD: 753 if(ptype==TYDREAL && ( (ltype==TYREAL && ! lconst ) || 754 (rtype==TYREAL && ! rconst ) )) 755 break; 756 if( ISCOMPLEX(ptype) ) 757 break; 758 if(ltype != ptype) 759 if (lconst) 760 { 761 p->leftp = fixtype(mkconv(ptype, 762 cpexpr(lconst))); 763 frexpr(lp); 764 } 765 else 766 p->leftp = fixtype(mkconv(ptype,lp)); 767 if(rtype != ptype) 768 if (rconst) 769 { 770 p->rightp = fixtype(mkconv(ptype, 771 cpexpr(rconst))); 772 frexpr(rp); 773 } 774 else 775 p->rightp = fixtype(mkconv(ptype,rp)); 776 break; 777 778 case OPPOWER: 779 return( mkpower(p) ); 780 781 case OPLT: 782 case OPLE: 783 case OPGT: 784 case OPGE: 785 case OPEQ: 786 case OPNE: 787 if(ltype == rtype) 788 break; 789 mtype = cktype(OPMINUS, ltype, rtype); 790 if(mtype==TYDREAL && ( (ltype==TYREAL && ! lconst) || 791 (rtype==TYREAL && ! rconst) )) 792 break; 793 if( ISCOMPLEX(mtype) ) 794 break; 795 if(ltype != mtype) 796 if (lconst) 797 { 798 p->leftp = fixtype(mkconv(mtype, 799 cpexpr(lconst))); 800 frexpr(lp); 801 } 802 else 803 p->leftp = fixtype(mkconv(mtype,lp)); 804 if(rtype != mtype) 805 if (rconst) 806 { 807 p->rightp = fixtype(mkconv(mtype, 808 cpexpr(rconst))); 809 frexpr(rp); 810 } 811 else 812 p->rightp = fixtype(mkconv(mtype,rp)); 813 break; 814 815 816 case OPCONV: 817 if(ISCOMPLEX(p->vtype)) 818 { 819 ptype = cktype(OPCONV, p->vtype, ltype); 820 if(p->rightp) 821 ptype = cktype(OPCONV, ptype, rtype); 822 break; 823 } 824 ptype = cktype(OPCONV, p->vtype, ltype); 825 if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA) 826 { 827 lp->exprblock.rightp = 828 fixtype( mkconv(ptype, lp->exprblock.rightp) ); 829 free( (charptr) p ); 830 p = (Exprp) lp; 831 } 832 break; 833 834 case OPADDR: 835 if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR) 836 fatal("addr of addr"); 837 break; 838 839 case OPCOMMA: 840 case OPQUEST: 841 case OPCOLON: 842 break; 843 844 case OPPAREN: 845 p->vleng = (expptr) cpexpr( lp->headblock.vleng ); 846 break; 847 848 case OPMIN: 849 case OPMAX: 850 ptype = p->vtype; 851 break; 852 853 default: 854 break; 855 } 856 857 p->vtype = ptype; 858 frexpr(lconst); 859 frexpr(rconst); 860 return((expptr) p); 861 } 862 863 #if SZINT < SZLONG 864 /* 865 for efficient subscripting, replace long ints by shorts 866 in easy places 867 */ 868 869 expptr shorten(p) 870 register expptr p; 871 { 872 register expptr q; 873 874 if(p->headblock.vtype != TYLONG) 875 return(p); 876 877 switch(p->tag) 878 { 879 case TERROR: 880 case TLIST: 881 return(p); 882 883 case TCONST: 884 case TADDR: 885 return( mkconv(TYINT,p) ); 886 887 case TEXPR: 888 break; 889 890 default: 891 badtag("shorten", p->tag); 892 } 893 894 switch(p->exprblock.opcode) 895 { 896 case OPPLUS: 897 case OPMINUS: 898 case OPSTAR: 899 q = shorten( cpexpr(p->exprblock.rightp) ); 900 if(q->headblock.vtype == TYINT) 901 { 902 p->exprblock.leftp = shorten(p->exprblock.leftp); 903 if(p->exprblock.leftp->headblock.vtype == TYLONG) 904 frexpr(q); 905 else 906 { 907 frexpr(p->exprblock.rightp); 908 p->exprblock.rightp = q; 909 p->exprblock.vtype = TYINT; 910 } 911 } 912 break; 913 914 case OPNEG: 915 case OPPAREN: 916 p->exprblock.leftp = shorten(p->exprblock.leftp); 917 if(p->exprblock.leftp->headblock.vtype == TYINT) 918 p->exprblock.vtype = TYINT; 919 break; 920 921 case OPCALL: 922 case OPCCALL: 923 p = mkconv(TYINT,p); 924 break; 925 default: 926 break; 927 } 928 929 return(p); 930 } 931 #endif 932 933 /* fix an argument list, taking due care for special first level cases */ 934 935 fixargs(doput, p0) 936 int doput; /* doput is true if the function is not intrinsic; 937 was used to decide whether to do a putconst, 938 but this is no longer done here (Feb82)*/ 939 struct Listblock *p0; 940 { 941 register chainp p; 942 register tagptr q, t; 943 register int qtag; 944 int nargs; 945 Addrp mkscalar(); 946 947 nargs = 0; 948 if(p0) 949 for(p = p0->listp ; p ; p = p->nextp) 950 { 951 ++nargs; 952 q = p->datap; 953 qtag = q->tag; 954 if(qtag == TCONST) 955 { 956 if(q->constblock.vtype == TYSHORT) 957 q = (tagptr) mkconv(tyint, q); 958 p->datap = q ; 959 } 960 else if(qtag==TPRIM && q->primblock.argsp==0 && 961 q->primblock.namep->vclass==CLPROC) 962 p->datap = (tagptr) mkaddr(q->primblock.namep); 963 else if(qtag==TPRIM && q->primblock.argsp==0 && 964 q->primblock.namep->vdim!=NULL) 965 p->datap = (tagptr) mkscalar(q->primblock.namep); 966 else if(qtag==TPRIM && q->primblock.argsp==0 && 967 q->primblock.namep->vdovar && 968 (t = (tagptr) memversion(q->primblock.namep)) ) 969 p->datap = (tagptr) fixtype(t); 970 else 971 p->datap = (tagptr) fixtype(q); 972 } 973 return(nargs); 974 } 975 976 977 Addrp mkscalar(np) 978 register Namep np; 979 { 980 register Addrp ap; 981 982 vardcl(np); 983 ap = mkaddr(np); 984 985 #if TARGET == VAX 986 /* on the VAX, prolog causes array arguments 987 to point at the (0,...,0) element, except when 988 subscript checking is on 989 */ 990 #ifdef SDB 991 if( !checksubs && !sdbflag && np->vstg==STGARG) 992 #else 993 if( !checksubs && np->vstg==STGARG) 994 #endif 995 { 996 register struct Dimblock *dp; 997 dp = np->vdim; 998 frexpr(ap->memoffset); 999 ap->memoffset = mkexpr(OPSTAR, 1000 (np->vtype==TYCHAR ? 1001 cpexpr(np->vleng) : 1002 (tagptr)ICON(typesize[np->vtype]) ), 1003 cpexpr(dp->baseoffset) ); 1004 } 1005 #endif 1006 return(ap); 1007 } 1008 1009 1010 1011 1012 1013 expptr mkfunct(p) 1014 register struct Primblock *p; 1015 { 1016 struct Entrypoint *ep; 1017 Addrp ap; 1018 struct Extsym *extp; 1019 register Namep np; 1020 register expptr q; 1021 expptr intrcall(), stfcall(); 1022 int k, nargs; 1023 int class; 1024 1025 if(p->tag != TPRIM) 1026 return( errnode() ); 1027 1028 np = p->namep; 1029 class = np->vclass; 1030 1031 if(class == CLUNKNOWN) 1032 { 1033 np->vclass = class = CLPROC; 1034 if(np->vstg == STGUNKNOWN) 1035 { 1036 if(np->vtype!=TYSUBR && (k = intrfunct(np->varname)) ) 1037 { 1038 np->vstg = STGINTR; 1039 np->vardesc.varno = k; 1040 np->vprocclass = PINTRINSIC; 1041 } 1042 else 1043 { 1044 extp = mkext( varunder(VL,np->varname) ); 1045 extp->extstg = STGEXT; 1046 np->vstg = STGEXT; 1047 np->vardesc.varno = extp - extsymtab; 1048 np->vprocclass = PEXTERNAL; 1049 } 1050 } 1051 else if(np->vstg==STGARG) 1052 { 1053 if(np->vtype!=TYCHAR && !ftn66flag) 1054 warn("Dummy procedure not declared EXTERNAL. Code may be wrong."); 1055 np->vprocclass = PEXTERNAL; 1056 } 1057 } 1058 1059 if(class != CLPROC) 1060 fatali("invalid class code %d for function", class); 1061 if(p->fcharp || p->lcharp) 1062 { 1063 err("no substring of function call"); 1064 goto error; 1065 } 1066 impldcl(np); 1067 nargs = fixargs( np->vprocclass!=PINTRINSIC, p->argsp); 1068 1069 switch(np->vprocclass) 1070 { 1071 case PEXTERNAL: 1072 ap = mkaddr(np); 1073 call: 1074 q = mkexpr(OPCALL, ap, p->argsp); 1075 if( (q->exprblock.vtype = np->vtype) == TYUNKNOWN) 1076 { 1077 err("attempt to use untyped function"); 1078 goto error; 1079 } 1080 if(np->vleng) 1081 q->exprblock.vleng = (expptr) cpexpr(np->vleng); 1082 break; 1083 1084 case PINTRINSIC: 1085 q = intrcall(np, p->argsp, nargs); 1086 break; 1087 1088 case PSTFUNCT: 1089 q = stfcall(np, p->argsp); 1090 break; 1091 1092 case PTHISPROC: 1093 warn("recursive call"); 1094 for(ep = entries ; ep ; ep = ep->entnextp) 1095 if(ep->enamep == np) 1096 break; 1097 if(ep == NULL) 1098 fatal("mkfunct: impossible recursion"); 1099 ap = builtin(np->vtype, varstr(XL, ep->entryname->extname) ); 1100 goto call; 1101 1102 default: 1103 fatali("mkfunct: impossible vprocclass %d", 1104 (int) (np->vprocclass) ); 1105 } 1106 free( (charptr) p ); 1107 return(q); 1108 1109 error: 1110 frexpr(p); 1111 return( errnode() ); 1112 } 1113 1114 1115 1116 LOCAL expptr stfcall(np, actlist) 1117 Namep np; 1118 struct Listblock *actlist; 1119 { 1120 register chainp actuals; 1121 int nargs; 1122 chainp oactp, formals; 1123 int type; 1124 expptr q, rhs, ap; 1125 Namep tnp; 1126 register struct Rplblock *rp; 1127 struct Rplblock *tlist; 1128 1129 if(actlist) 1130 { 1131 actuals = actlist->listp; 1132 free( (charptr) actlist); 1133 } 1134 else 1135 actuals = NULL; 1136 oactp = actuals; 1137 1138 nargs = 0; 1139 tlist = NULL; 1140 if( (type = np->vtype) == TYUNKNOWN) 1141 { 1142 err("attempt to use untyped statement function"); 1143 q = errnode(); 1144 goto ret; 1145 } 1146 formals = (chainp) (np->varxptr.vstfdesc->datap); 1147 rhs = (expptr) (np->varxptr.vstfdesc->nextp); 1148 1149 /* copy actual arguments into temporaries */ 1150 while(actuals!=NULL && formals!=NULL) 1151 { 1152 rp = ALLOC(Rplblock); 1153 rp->rplnp = tnp = (Namep) (formals->datap); 1154 ap = fixtype(actuals->datap); 1155 if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR 1156 && (ap->tag==TCONST || ap->tag==TADDR || ap->tag==TTEMP) ) 1157 { 1158 rp->rplvp = (expptr) ap; 1159 rp->rplxp = NULL; 1160 rp->rpltag = ap->tag; 1161 } 1162 else { 1163 rp->rplvp = (expptr) mktemp(tnp->vtype, tnp->vleng); 1164 rp->rplxp = fixtype( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap) ); 1165 if( (rp->rpltag = rp->rplxp->tag) == TERROR) 1166 err("disagreement of argument types in statement function call"); 1167 else if(tnp->vtype!=ap->headblock.vtype) 1168 warn("argument type mismatch in statement function"); 1169 } 1170 rp->rplnextp = tlist; 1171 tlist = rp; 1172 actuals = actuals->nextp; 1173 formals = formals->nextp; 1174 ++nargs; 1175 } 1176 1177 if(actuals!=NULL || formals!=NULL) 1178 err("statement function definition and argument list differ"); 1179 1180 /* 1181 now push down names involved in formal argument list, then 1182 evaluate rhs of statement function definition in this environment 1183 */ 1184 1185 if(tlist) /* put tlist in front of the rpllist */ 1186 { 1187 for(rp = tlist; rp->rplnextp; rp = rp->rplnextp) 1188 ; 1189 rp->rplnextp = rpllist; 1190 rpllist = tlist; 1191 } 1192 1193 q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) ); 1194 1195 /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */ 1196 while(--nargs >= 0) 1197 { 1198 if(rpllist->rplxp) 1199 q = mkexpr(OPCOMMA, rpllist->rplxp, q); 1200 rp = rpllist->rplnextp; 1201 frexpr(rpllist->rplvp); 1202 free(rpllist); 1203 rpllist = rp; 1204 } 1205 1206 ret: 1207 frchain( &oactp ); 1208 return(q); 1209 } 1210 1211 1212 1213 1214 Addrp mkplace(np) 1215 register Namep np; 1216 { 1217 register Addrp s; 1218 register struct Rplblock *rp; 1219 int regn; 1220 1221 /* is name on the replace list? */ 1222 1223 for(rp = rpllist ; rp ; rp = rp->rplnextp) 1224 { 1225 if(np == rp->rplnp) 1226 { 1227 if(rp->rpltag == TNAME) 1228 { 1229 np = (Namep) (rp->rplvp); 1230 break; 1231 } 1232 else return( (Addrp) cpexpr(rp->rplvp) ); 1233 } 1234 } 1235 1236 /* is variable a DO index in a register ? */ 1237 1238 if(np->vdovar && ( (regn = inregister(np)) >= 0) ) 1239 if(np->vtype == TYERROR) 1240 return( (Addrp) errnode() ); 1241 else 1242 { 1243 s = ALLOC(Addrblock); 1244 s->tag = TADDR; 1245 s->vstg = STGREG; 1246 s->vtype = TYIREG; 1247 s->issaved = np->vsave; 1248 s->memno = regn; 1249 s->memoffset = ICON(0); 1250 return(s); 1251 } 1252 1253 vardcl(np); 1254 return(mkaddr(np)); 1255 } 1256 1257 1258 1259 1260 expptr mklhs(p) 1261 register struct Primblock *p; 1262 { 1263 expptr suboffset(); 1264 register Addrp s; 1265 Namep np; 1266 1267 if(p->tag != TPRIM) 1268 return( (expptr) p ); 1269 np = p->namep; 1270 1271 s = mkplace(np); 1272 if(s->tag!=TADDR || s->vstg==STGREG) 1273 { 1274 free( (charptr) p ); 1275 return( (expptr) s ); 1276 } 1277 1278 /* compute the address modified by subscripts */ 1279 1280 s->memoffset = mkexpr(OPPLUS, s->memoffset, suboffset(p) ); 1281 frexpr(p->argsp); 1282 p->argsp = NULL; 1283 1284 /* now do substring part */ 1285 1286 if(p->fcharp || p->lcharp) 1287 { 1288 if(np->vtype != TYCHAR) 1289 errstr("substring of noncharacter %s", varstr(VL,np->varname)); 1290 else { 1291 if(p->lcharp == NULL) 1292 p->lcharp = (expptr) cpexpr(s->vleng); 1293 frexpr(s->vleng); 1294 if(p->fcharp) 1295 { 1296 if(p->fcharp->tag == TPRIM && p->lcharp->tag == TPRIM 1297 && p->fcharp->primblock.namep == p->lcharp->primblock.namep) 1298 /* A trivial optimization -- upper == lower */ 1299 s->vleng = ICON(1); 1300 else 1301 s->vleng = mkexpr(OPMINUS, p->lcharp, 1302 mkexpr(OPMINUS, p->fcharp, ICON(1) )); 1303 } 1304 else 1305 s->vleng = p->lcharp; 1306 } 1307 } 1308 1309 s->vleng = fixtype( s->vleng ); 1310 s->memoffset = fixtype( s->memoffset ); 1311 free( (charptr) p ); 1312 return( (expptr) s ); 1313 } 1314 1315 1316 1317 1318 1319 deregister(np) 1320 Namep np; 1321 { 1322 if(nregvar>0 && regnamep[nregvar-1]==np) 1323 { 1324 --nregvar; 1325 #if FAMILY == DMR 1326 putnreg(); 1327 #endif 1328 } 1329 } 1330 1331 1332 1333 1334 Addrp memversion(np) 1335 register Namep np; 1336 { 1337 register Addrp s; 1338 1339 if(np->vdovar==NO || (inregister(np)<0) ) 1340 return(NULL); 1341 np->vdovar = NO; 1342 s = mkplace(np); 1343 np->vdovar = YES; 1344 return(s); 1345 } 1346 1347 1348 1349 inregister(np) 1350 register Namep np; 1351 { 1352 register int i; 1353 1354 for(i = 0 ; i < nregvar ; ++i) 1355 if(regnamep[i] == np) 1356 return( regnum[i] ); 1357 return(-1); 1358 } 1359 1360 1361 1362 1363 enregister(np) 1364 Namep np; 1365 { 1366 if( inregister(np) >= 0) 1367 return(YES); 1368 if(nregvar >= maxregvar) 1369 return(NO); 1370 vardcl(np); 1371 if( ONEOF(np->vtype, MSKIREG) ) 1372 { 1373 regnamep[nregvar++] = np; 1374 if(nregvar > highregvar) 1375 highregvar = nregvar; 1376 #if FAMILY == DMR 1377 putnreg(); 1378 #endif 1379 return(YES); 1380 } 1381 else 1382 return(NO); 1383 } 1384 1385 1386 1387 1388 expptr suboffset(p) 1389 register struct Primblock *p; 1390 { 1391 int n; 1392 expptr size; 1393 expptr oftwo(); 1394 chainp cp; 1395 expptr offp, prod; 1396 expptr subcheck(); 1397 struct Dimblock *dimp; 1398 expptr sub[MAXDIM+1]; 1399 register Namep np; 1400 1401 np = p->namep; 1402 offp = ICON(0); 1403 n = 0; 1404 if(p->argsp) 1405 for(cp = p->argsp->listp ; cp ; ++n, cp = cp->nextp) 1406 { 1407 sub[n] = fixtype(cpexpr(cp->datap)); 1408 if ( ! ISINT(sub[n]->headblock.vtype)) { 1409 errstr("%s: non-integer subscript expression", 1410 varstr(VL, np->varname) ); 1411 /* Provide a substitute -- go on to find more errors */ 1412 frexpr(sub[n]); 1413 sub[n] = ICON(1); 1414 } 1415 if(n > maxdim) 1416 { 1417 char str[28+VL]; 1418 sprintf(str, "%s: more than %d subscripts", 1419 varstr(VL, np->varname), maxdim ); 1420 err( str ); 1421 break; 1422 } 1423 } 1424 1425 dimp = np->vdim; 1426 if(n>0 && dimp==NULL) 1427 errstr("%s: subscripts on scalar variable", 1428 varstr(VL, np->varname), maxdim ); 1429 else if(dimp && dimp->ndim!=n) 1430 errstr("wrong number of subscripts on %s", 1431 varstr(VL, np->varname) ); 1432 else if(n > 0) 1433 { 1434 prod = sub[--n]; 1435 while( --n >= 0) 1436 prod = mkexpr(OPPLUS, sub[n], 1437 mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) ); 1438 #if TARGET == VAX 1439 #ifdef SDB 1440 if(checksubs || np->vstg!=STGARG || sdbflag) 1441 #else 1442 if(checksubs || np->vstg!=STGARG) 1443 #endif 1444 prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset)); 1445 #else 1446 prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset)); 1447 #endif 1448 if(checksubs) 1449 prod = subcheck(np, prod); 1450 size = np->vtype == TYCHAR ? 1451 (expptr) cpexpr(np->vleng) : ICON(typesize[np->vtype]); 1452 if (!oftwo(size)) 1453 prod = mkexpr(OPSTAR, prod, size); 1454 else 1455 prod = mkexpr(OPLSHIFT,prod,oftwo(size)); 1456 1457 offp = mkexpr(OPPLUS, offp, prod); 1458 } 1459 1460 if(p->fcharp && np->vtype==TYCHAR) 1461 offp = mkexpr(OPPLUS, offp, mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1) )); 1462 1463 return(offp); 1464 } 1465 1466 1467 1468 1469 expptr subcheck(np, p) 1470 Namep np; 1471 register expptr p; 1472 { 1473 struct Dimblock *dimp; 1474 expptr t, checkvar, checkcond, badcall; 1475 1476 dimp = np->vdim; 1477 if(dimp->nelt == NULL) 1478 return(p); /* don't check arrays with * bounds */ 1479 checkvar = NULL; 1480 checkcond = NULL; 1481 if( ISICON(p) ) 1482 { 1483 if(p->constblock.const.ci < 0) 1484 goto badsub; 1485 if( ISICON(dimp->nelt) ) 1486 if(p->constblock.const.ci < dimp->nelt->constblock.const.ci) 1487 return(p); 1488 else 1489 goto badsub; 1490 } 1491 if(p->tag==TADDR && p->addrblock.vstg==STGREG) 1492 { 1493 checkvar = (expptr) cpexpr(p); 1494 t = p; 1495 } 1496 else { 1497 checkvar = (expptr) mktemp(p->headblock.vtype, ENULL); 1498 t = mkexpr(OPASSIGN, cpexpr(checkvar), p); 1499 } 1500 checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) ); 1501 if( ! ISICON(p) ) 1502 checkcond = mkexpr(OPAND, checkcond, 1503 mkexpr(OPLE, ICON(0), cpexpr(checkvar)) ); 1504 1505 badcall = call4(p->headblock.vtype, "s_rnge", 1506 mkstrcon(VL, np->varname), 1507 mkconv(TYLONG, cpexpr(checkvar)), 1508 mkstrcon(XL, procname), 1509 ICON(lineno) ); 1510 badcall->exprblock.opcode = OPCCALL; 1511 p = mkexpr(OPQUEST, checkcond, 1512 mkexpr(OPCOLON, checkvar, badcall)); 1513 1514 return(p); 1515 1516 badsub: 1517 frexpr(p); 1518 errstr("subscript on variable %s out of range", varstr(VL,np->varname)); 1519 return ( ICON(0) ); 1520 } 1521 1522 1523 1524 1525 Addrp mkaddr(p) 1526 register Namep p; 1527 { 1528 struct Extsym *extp; 1529 register Addrp t; 1530 Addrp intraddr(); 1531 1532 switch( p->vstg) 1533 { 1534 case STGUNKNOWN: 1535 if(p->vclass != CLPROC) 1536 break; 1537 extp = mkext( varunder(VL, p->varname) ); 1538 extp->extstg = STGEXT; 1539 p->vstg = STGEXT; 1540 p->vardesc.varno = extp - extsymtab; 1541 p->vprocclass = PEXTERNAL; 1542 1543 case STGCOMMON: 1544 case STGEXT: 1545 case STGBSS: 1546 case STGINIT: 1547 case STGEQUIV: 1548 case STGARG: 1549 case STGLENG: 1550 case STGAUTO: 1551 t = ALLOC(Addrblock); 1552 t->tag = TADDR; 1553 if(p->vclass==CLPROC && p->vprocclass==PTHISPROC) 1554 t->vclass = CLVAR; 1555 else 1556 t->vclass = p->vclass; 1557 t->vtype = p->vtype; 1558 t->vstg = p->vstg; 1559 t->memno = p->vardesc.varno; 1560 t->issaved = p->vsave; 1561 if(p->vdim) t->isarray = YES; 1562 t->memoffset = ICON(p->voffset); 1563 if(p->vleng) 1564 { 1565 t->vleng = (expptr) cpexpr(p->vleng); 1566 if( ISICON(t->vleng) ) 1567 t->varleng = t->vleng->constblock.const.ci; 1568 } 1569 if (p->vstg == STGBSS) 1570 t->varsize = p->varsize; 1571 else if (p->vstg == STGEQUIV) 1572 t->varsize = eqvclass[t->memno].eqvleng; 1573 return(t); 1574 1575 case STGINTR: 1576 return( intraddr(p) ); 1577 1578 } 1579 /*debug*/fprintf(diagfile,"mkaddr. vtype=%d, vclass=%d\n", p->vtype, p->vclass); 1580 badstg("mkaddr", p->vstg); 1581 /* NOTREACHED */ 1582 } 1583 1584 1585 1586 1587 Addrp mkarg(type, argno) 1588 int type, argno; 1589 { 1590 register Addrp p; 1591 1592 p = ALLOC(Addrblock); 1593 p->tag = TADDR; 1594 p->vtype = type; 1595 p->vclass = CLVAR; 1596 p->vstg = (type==TYLENG ? STGLENG : STGARG); 1597 p->memno = argno; 1598 return(p); 1599 } 1600 1601 1602 1603 1604 expptr mkprim(v, args, substr) 1605 register union 1606 { 1607 struct Paramblock paramblock; 1608 struct Nameblock nameblock; 1609 struct Headblock headblock; 1610 } *v; 1611 struct Listblock *args; 1612 chainp substr; 1613 { 1614 register struct Primblock *p; 1615 1616 if(v->headblock.vclass == CLPARAM) 1617 { 1618 if(args || substr) 1619 { 1620 errstr("no qualifiers on parameter name %s", 1621 varstr(VL,v->paramblock.varname)); 1622 frexpr(args); 1623 if(substr) 1624 { 1625 frexpr(substr->datap); 1626 frexpr(substr->nextp->datap); 1627 frchain(&substr); 1628 } 1629 frexpr(v); 1630 return( errnode() ); 1631 } 1632 return( (expptr) cpexpr(v->paramblock.paramval) ); 1633 } 1634 1635 p = ALLOC(Primblock); 1636 p->tag = TPRIM; 1637 p->vtype = v->nameblock.vtype; 1638 p->namep = (Namep) v; 1639 p->argsp = args; 1640 if(substr) 1641 { 1642 p->fcharp = (expptr) (substr->datap); 1643 p->lcharp = (expptr) (substr->nextp->datap); 1644 frchain(&substr); 1645 } 1646 return( (expptr) p); 1647 } 1648 1649 1650 1651 vardcl(v) 1652 register Namep v; 1653 { 1654 int nelt; 1655 struct Dimblock *t; 1656 Addrp p; 1657 expptr neltp; 1658 int eltsize; 1659 int varsize; 1660 int tsize; 1661 int align; 1662 1663 if(v->vdcldone) 1664 return; 1665 if(v->vclass == CLNAMELIST) 1666 return; 1667 1668 if(v->vtype == TYUNKNOWN) 1669 impldcl(v); 1670 if(v->vclass == CLUNKNOWN) 1671 v->vclass = CLVAR; 1672 else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC) 1673 { 1674 dclerr("used both as variable and non-variable", v); 1675 return; 1676 } 1677 if(v->vstg==STGUNKNOWN) 1678 v->vstg = implstg[ letter(v->varname[0]) ]; 1679 1680 switch(v->vstg) 1681 { 1682 case STGBSS: 1683 v->vardesc.varno = ++lastvarno; 1684 if (v->vclass != CLVAR) 1685 break; 1686 nelt = 1; 1687 t = v->vdim; 1688 if (t) 1689 { 1690 neltp = t->nelt; 1691 if (neltp && ISICON(neltp)) 1692 nelt = neltp->constblock.const.ci; 1693 else 1694 dclerr("improperly dimensioned array", v); 1695 } 1696 1697 if (v->vtype == TYCHAR) 1698 { 1699 v->vleng = fixtype(v->vleng); 1700 if (v->vleng == NULL) 1701 eltsize = typesize[TYCHAR]; 1702 else if (ISICON(v->vleng)) 1703 eltsize = typesize[TYCHAR] * 1704 v->vleng->constblock.const.ci; 1705 else if (v->vleng->tag != TERROR) 1706 { 1707 errstr("nonconstant string length on %s", 1708 varstr(VL, v->varname)); 1709 eltsize = 0; 1710 } 1711 } 1712 else 1713 eltsize = typesize[v->vtype]; 1714 1715 v->varsize = nelt * eltsize; 1716 break; 1717 case STGAUTO: 1718 if(v->vclass==CLPROC && v->vprocclass==PTHISPROC) 1719 break; 1720 nelt = 1; 1721 if(t = v->vdim) 1722 if( (neltp = t->nelt) && ISCONST(neltp) ) 1723 nelt = neltp->constblock.const.ci; 1724 else 1725 dclerr("adjustable automatic array", v); 1726 p = autovar(nelt, v->vtype, v->vleng); 1727 v->vardesc.varno = p->memno; 1728 v->voffset = p->memoffset->constblock.const.ci; 1729 frexpr(p); 1730 break; 1731 1732 default: 1733 break; 1734 } 1735 v->vdcldone = YES; 1736 } 1737 1738 1739 1740 1741 impldcl(p) 1742 register Namep p; 1743 { 1744 register int k; 1745 int type, leng; 1746 1747 if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) ) 1748 return; 1749 if(p->vtype == TYUNKNOWN) 1750 { 1751 k = letter(p->varname[0]); 1752 type = impltype[ k ]; 1753 leng = implleng[ k ]; 1754 if(type == TYUNKNOWN) 1755 { 1756 if(p->vclass == CLPROC) 1757 return; 1758 dclerr("attempt to use undefined variable", p); 1759 type = TYERROR; 1760 leng = 1; 1761 } 1762 settype(p, type, leng); 1763 } 1764 } 1765 1766 1767 1768 1769 LOCAL letter(c) 1770 register int c; 1771 { 1772 if( isupper(c) ) 1773 c = tolower(c); 1774 return(c - 'a'); 1775 } 1776 1777 #define ICONEQ(z, c) (ISICON(z) && z->constblock.const.ci==c) 1778 #define COMMUTE { e = lp; lp = rp; rp = e; } 1779 1780 1781 expptr mkexpr(opcode, lp, rp) 1782 int opcode; 1783 register expptr lp, rp; 1784 { 1785 register expptr e, e1; 1786 int etype; 1787 int ltype, rtype; 1788 int ltag, rtag; 1789 expptr q, q1; 1790 expptr fold(); 1791 int k; 1792 1793 ltype = lp->headblock.vtype; 1794 ltag = lp->tag; 1795 if(rp && opcode!=OPCALL && opcode!=OPCCALL) 1796 { 1797 rtype = rp->headblock.vtype; 1798 rtag = rp->tag; 1799 } 1800 else { 1801 rtype = 0; 1802 rtag = 0; 1803 } 1804 1805 /* 1806 * Yuck. Why can't we fold constants AFTER 1807 * variables are implicitly declared??? 1808 */ 1809 if(ltype == TYUNKNOWN && ltag == TPRIM && lp->primblock.argsp == NULL) 1810 { 1811 k = letter(lp->primblock.namep->varname[0]); 1812 ltype = impltype[ k ]; 1813 } 1814 if(rtype == TYUNKNOWN && rtag == TPRIM && rp->primblock.argsp == NULL) 1815 { 1816 k = letter(rp->primblock.namep->varname[0]); 1817 rtype = impltype[ k ]; 1818 } 1819 1820 etype = cktype(opcode, ltype, rtype); 1821 if(etype == TYERROR) 1822 goto error; 1823 1824 if(etype != TYUNKNOWN) 1825 switch(opcode) 1826 { 1827 /* check for multiplication by 0 and 1 and addition to 0 */ 1828 1829 case OPSTAR: 1830 if( ISCONST(lp) ) 1831 COMMUTE 1832 1833 if( ISICON(rp) ) 1834 { 1835 if(rp->constblock.const.ci == 0) 1836 { 1837 if(etype == TYUNKNOWN) 1838 break; 1839 rp = mkconv(etype, rp); 1840 goto retright; 1841 } 1842 if ((lp->tag == TEXPR) && 1843 ((lp->exprblock.opcode == OPPLUS) || 1844 (lp->exprblock.opcode == OPMINUS)) && 1845 ISCONST(lp->exprblock.rightp) && 1846 ISINT(lp->exprblock.rightp->constblock.vtype)) 1847 { 1848 q1 = mkexpr(OPSTAR, lp->exprblock.rightp, 1849 cpexpr(rp)); 1850 q = mkexpr(OPSTAR, lp->exprblock.leftp, rp); 1851 q = mkexpr(lp->exprblock.opcode, q, q1); 1852 free ((char *) lp); 1853 return q; 1854 } 1855 else 1856 goto mulop; 1857 } 1858 break; 1859 1860 case OPSLASH: 1861 case OPMOD: 1862 if( ICONEQ(rp, 0) ) 1863 { 1864 err("attempted division by zero"); 1865 rp = ICON(1); 1866 break; 1867 } 1868 if(opcode == OPMOD) 1869 break; 1870 1871 1872 mulop: 1873 if( ISICON(rp) ) 1874 { 1875 if(rp->constblock.const.ci == 1) 1876 goto retleft; 1877 1878 if(rp->constblock.const.ci == -1) 1879 { 1880 frexpr(rp); 1881 return( mkexpr(OPNEG, lp, PNULL) ); 1882 } 1883 } 1884 1885 if( ISSTAROP(lp) && ISICON(lp->exprblock.rightp) ) 1886 { 1887 if(opcode == OPSTAR) 1888 e = mkexpr(OPSTAR, lp->exprblock.rightp, rp); 1889 else if(ISICON(rp) && 1890 (lp->exprblock.rightp->constblock.const.ci % 1891 rp->constblock.const.ci) == 0) 1892 e = mkexpr(OPSLASH, lp->exprblock.rightp, rp); 1893 else break; 1894 1895 e1 = lp->exprblock.leftp; 1896 free( (charptr) lp ); 1897 return( mkexpr(OPSTAR, e1, e) ); 1898 } 1899 break; 1900 1901 1902 case OPPLUS: 1903 if( ISCONST(lp) ) 1904 COMMUTE 1905 goto addop; 1906 1907 case OPMINUS: 1908 if( ICONEQ(lp, 0) ) 1909 { 1910 frexpr(lp); 1911 return( mkexpr(OPNEG, rp, ENULL) ); 1912 } 1913 1914 if( ISCONST(rp) ) 1915 { 1916 opcode = OPPLUS; 1917 consnegop(rp); 1918 } 1919 1920 addop: 1921 if( ISICON(rp) ) 1922 { 1923 if(rp->constblock.const.ci == 0) 1924 goto retleft; 1925 if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) ) 1926 { 1927 e = mkexpr(OPPLUS, lp->exprblock.rightp, rp); 1928 e1 = lp->exprblock.leftp; 1929 free( (charptr) lp ); 1930 return( mkexpr(OPPLUS, e1, e) ); 1931 } 1932 } 1933 break; 1934 1935 1936 case OPPOWER: 1937 break; 1938 1939 case OPNEG: 1940 if(ltag==TEXPR && lp->exprblock.opcode==OPNEG) 1941 { 1942 e = lp->exprblock.leftp; 1943 free( (charptr) lp ); 1944 return(e); 1945 } 1946 break; 1947 1948 case OPNOT: 1949 if(ltag==TEXPR && lp->exprblock.opcode==OPNOT) 1950 { 1951 e = lp->exprblock.leftp; 1952 free( (charptr) lp ); 1953 return(e); 1954 } 1955 break; 1956 1957 case OPCALL: 1958 case OPCCALL: 1959 etype = ltype; 1960 if(rp!=NULL && rp->listblock.listp==NULL) 1961 { 1962 free( (charptr) rp ); 1963 rp = NULL; 1964 } 1965 break; 1966 1967 case OPAND: 1968 case OPOR: 1969 if( ISCONST(lp) ) 1970 COMMUTE 1971 1972 if( ISCONST(rp) ) 1973 { 1974 if(rp->constblock.const.ci == 0) 1975 if(opcode == OPOR) 1976 goto retleft; 1977 else 1978 goto retright; 1979 else if(opcode == OPOR) 1980 goto retright; 1981 else 1982 goto retleft; 1983 } 1984 case OPLSHIFT: 1985 if (ISICON(rp)) 1986 { 1987 if (rp->constblock.const.ci == 0) 1988 goto retleft; 1989 if ((lp->tag == TEXPR) && 1990 ((lp->exprblock.opcode == OPPLUS) || 1991 (lp->exprblock.opcode == OPMINUS)) && 1992 ISICON(lp->exprblock.rightp)) 1993 { 1994 q1 = mkexpr(OPLSHIFT, lp->exprblock.rightp, 1995 cpexpr(rp)); 1996 q = mkexpr(OPLSHIFT, lp->exprblock.leftp, rp); 1997 q = mkexpr(lp->exprblock.opcode, q, q1); 1998 free((char *) lp); 1999 return q; 2000 } 2001 } 2002 2003 case OPEQV: 2004 case OPNEQV: 2005 2006 case OPBITAND: 2007 case OPBITOR: 2008 case OPBITXOR: 2009 case OPBITNOT: 2010 case OPRSHIFT: 2011 2012 case OPLT: 2013 case OPGT: 2014 case OPLE: 2015 case OPGE: 2016 case OPEQ: 2017 case OPNE: 2018 2019 case OPCONCAT: 2020 break; 2021 case OPMIN: 2022 case OPMAX: 2023 2024 case OPASSIGN: 2025 case OPPLUSEQ: 2026 case OPSTAREQ: 2027 2028 case OPCONV: 2029 case OPADDR: 2030 2031 case OPCOMMA: 2032 case OPQUEST: 2033 case OPCOLON: 2034 2035 case OPPAREN: 2036 break; 2037 2038 default: 2039 badop("mkexpr", opcode); 2040 } 2041 2042 e = (expptr) ALLOC(Exprblock); 2043 e->exprblock.tag = TEXPR; 2044 e->exprblock.opcode = opcode; 2045 e->exprblock.vtype = etype; 2046 e->exprblock.leftp = lp; 2047 e->exprblock.rightp = rp; 2048 if(ltag==TCONST && (rp==0 || rtag==TCONST) ) 2049 e = fold(e); 2050 return(e); 2051 2052 retleft: 2053 frexpr(rp); 2054 return(lp); 2055 2056 retright: 2057 frexpr(lp); 2058 return(rp); 2059 2060 error: 2061 frexpr(lp); 2062 if(rp && opcode!=OPCALL && opcode!=OPCCALL) 2063 frexpr(rp); 2064 return( errnode() ); 2065 } 2066 2067 #define ERR(s) { errs = s; goto error; } 2068 2069 cktype(op, lt, rt) 2070 register int op, lt, rt; 2071 { 2072 char *errs; 2073 2074 if(lt==TYERROR || rt==TYERROR) 2075 goto error1; 2076 2077 if(lt==TYUNKNOWN) 2078 return(TYUNKNOWN); 2079 if(rt==TYUNKNOWN) 2080 if (op!=OPNOT && op!=OPBITNOT && op!=OPNEG && op!=OPCALL && 2081 op!=OPCCALL && op!=OPADDR && op!=OPPAREN) 2082 return(TYUNKNOWN); 2083 2084 switch(op) 2085 { 2086 case OPPLUS: 2087 case OPMINUS: 2088 case OPSTAR: 2089 case OPSLASH: 2090 case OPPOWER: 2091 case OPMOD: 2092 if( ISNUMERIC(lt) && ISNUMERIC(rt) ) 2093 return( maxtype(lt, rt) ); 2094 ERR("nonarithmetic operand of arithmetic operator") 2095 2096 case OPNEG: 2097 if( ISNUMERIC(lt) ) 2098 return(lt); 2099 ERR("nonarithmetic operand of negation") 2100 2101 case OPNOT: 2102 if(lt == TYLOGICAL) 2103 return(TYLOGICAL); 2104 ERR("NOT of nonlogical") 2105 2106 case OPAND: 2107 case OPOR: 2108 case OPEQV: 2109 case OPNEQV: 2110 if(lt==TYLOGICAL && rt==TYLOGICAL) 2111 return(TYLOGICAL); 2112 ERR("nonlogical operand of logical operator") 2113 2114 case OPLT: 2115 case OPGT: 2116 case OPLE: 2117 case OPGE: 2118 case OPEQ: 2119 case OPNE: 2120 if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL) 2121 { 2122 if(lt != rt) 2123 ERR("illegal comparison") 2124 } 2125 2126 else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) ) 2127 { 2128 if(op!=OPEQ && op!=OPNE) 2129 ERR("order comparison of complex data") 2130 } 2131 2132 else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) ) 2133 ERR("comparison of nonarithmetic data") 2134 return(TYLOGICAL); 2135 2136 case OPCONCAT: 2137 if(lt==TYCHAR && rt==TYCHAR) 2138 return(TYCHAR); 2139 ERR("concatenation of nonchar data") 2140 2141 case OPCALL: 2142 case OPCCALL: 2143 return(lt); 2144 2145 case OPADDR: 2146 return(TYADDR); 2147 2148 case OPCONV: 2149 if(ISCOMPLEX(lt)) 2150 { 2151 if(ISNUMERIC(rt)) 2152 return(lt); 2153 ERR("impossible conversion") 2154 } 2155 if(rt == 0) 2156 return(0); 2157 if(lt==TYCHAR && ISINT(rt) ) 2158 return(TYCHAR); 2159 case OPASSIGN: 2160 case OPPLUSEQ: 2161 case OPSTAREQ: 2162 if( ISINT(lt) && rt==TYCHAR) 2163 return(lt); 2164 if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL) 2165 if(op!=OPASSIGN || lt!=rt) 2166 { 2167 /* debug fprintf(diagfile, " lt=%d, rt=%d, op=%d\n", lt, rt, op); */ 2168 /* debug fatal("impossible conversion. possible compiler bug"); */ 2169 ERR("impossible conversion") 2170 } 2171 return(lt); 2172 2173 case OPMIN: 2174 case OPMAX: 2175 case OPBITOR: 2176 case OPBITAND: 2177 case OPBITXOR: 2178 case OPBITNOT: 2179 case OPLSHIFT: 2180 case OPRSHIFT: 2181 case OPPAREN: 2182 return(lt); 2183 2184 case OPCOMMA: 2185 case OPQUEST: 2186 case OPCOLON: 2187 return(rt); 2188 2189 default: 2190 badop("cktype", op); 2191 } 2192 error: err(errs); 2193 error1: return(TYERROR); 2194 } 2195 2196 LOCAL expptr fold(e) 2197 register expptr e; 2198 { 2199 Constp p; 2200 register expptr lp, rp; 2201 int etype, mtype, ltype, rtype, opcode; 2202 int i, ll, lr; 2203 char *q, *s; 2204 union Constant lcon, rcon; 2205 2206 opcode = e->exprblock.opcode; 2207 etype = e->exprblock.vtype; 2208 2209 lp = e->exprblock.leftp; 2210 ltype = lp->headblock.vtype; 2211 rp = e->exprblock.rightp; 2212 2213 if(rp == 0) 2214 switch(opcode) 2215 { 2216 case OPNOT: 2217 lp->constblock.const.ci = ! lp->constblock.const.ci; 2218 return(lp); 2219 2220 case OPBITNOT: 2221 lp->constblock.const.ci = ~ lp->constblock.const.ci; 2222 return(lp); 2223 2224 case OPNEG: 2225 consnegop(lp); 2226 return(lp); 2227 2228 case OPCONV: 2229 case OPADDR: 2230 case OPPAREN: 2231 return(e); 2232 2233 default: 2234 badop("fold", opcode); 2235 } 2236 2237 rtype = rp->headblock.vtype; 2238 2239 p = ALLOC(Constblock); 2240 p->tag = TCONST; 2241 p->vtype = etype; 2242 p->vleng = e->exprblock.vleng; 2243 2244 switch(opcode) 2245 { 2246 case OPCOMMA: 2247 case OPQUEST: 2248 case OPCOLON: 2249 return(e); 2250 2251 case OPAND: 2252 p->const.ci = lp->constblock.const.ci && 2253 rp->constblock.const.ci; 2254 break; 2255 2256 case OPOR: 2257 p->const.ci = lp->constblock.const.ci || 2258 rp->constblock.const.ci; 2259 break; 2260 2261 case OPEQV: 2262 p->const.ci = lp->constblock.const.ci == 2263 rp->constblock.const.ci; 2264 break; 2265 2266 case OPNEQV: 2267 p->const.ci = lp->constblock.const.ci != 2268 rp->constblock.const.ci; 2269 break; 2270 2271 case OPBITAND: 2272 p->const.ci = lp->constblock.const.ci & 2273 rp->constblock.const.ci; 2274 break; 2275 2276 case OPBITOR: 2277 p->const.ci = lp->constblock.const.ci | 2278 rp->constblock.const.ci; 2279 break; 2280 2281 case OPBITXOR: 2282 p->const.ci = lp->constblock.const.ci ^ 2283 rp->constblock.const.ci; 2284 break; 2285 2286 case OPLSHIFT: 2287 p->const.ci = lp->constblock.const.ci << 2288 rp->constblock.const.ci; 2289 break; 2290 2291 case OPRSHIFT: 2292 p->const.ci = lp->constblock.const.ci >> 2293 rp->constblock.const.ci; 2294 break; 2295 2296 case OPCONCAT: 2297 ll = lp->constblock.vleng->constblock.const.ci; 2298 lr = rp->constblock.vleng->constblock.const.ci; 2299 p->const.ccp = q = (char *) ckalloc(ll+lr); 2300 p->vleng = ICON(ll+lr); 2301 s = lp->constblock.const.ccp; 2302 for(i = 0 ; i < ll ; ++i) 2303 *q++ = *s++; 2304 s = rp->constblock.const.ccp; 2305 for(i = 0; i < lr; ++i) 2306 *q++ = *s++; 2307 break; 2308 2309 2310 case OPPOWER: 2311 if( ! ISINT(rtype) ) 2312 return(e); 2313 conspower(&(p->const), lp, rp->constblock.const.ci); 2314 break; 2315 2316 2317 default: 2318 if(ltype == TYCHAR) 2319 { 2320 lcon.ci = cmpstr(lp->constblock.const.ccp, 2321 rp->constblock.const.ccp, 2322 lp->constblock.vleng->constblock.const.ci, 2323 rp->constblock.vleng->constblock.const.ci); 2324 rcon.ci = 0; 2325 mtype = tyint; 2326 } 2327 else { 2328 mtype = maxtype(ltype, rtype); 2329 consconv(mtype, &lcon, ltype, &(lp->constblock.const) ); 2330 consconv(mtype, &rcon, rtype, &(rp->constblock.const) ); 2331 } 2332 consbinop(opcode, mtype, &(p->const), &lcon, &rcon); 2333 break; 2334 } 2335 2336 frexpr(e); 2337 return( (expptr) p ); 2338 } 2339 2340 2341 2342 /* assign constant l = r , doing coercion */ 2343 2344 consconv(lt, lv, rt, rv) 2345 int lt, rt; 2346 register union Constant *lv, *rv; 2347 { 2348 switch(lt) 2349 { 2350 case TYCHAR: 2351 *(lv->ccp = (char *) ckalloc(1)) = rv->ci; 2352 break; 2353 2354 case TYSHORT: 2355 case TYLONG: 2356 if(rt == TYCHAR) 2357 lv->ci = rv->ccp[0]; 2358 else if( ISINT(rt) ) 2359 lv->ci = rv->ci; 2360 else lv->ci = rv->cd[0]; 2361 break; 2362 2363 case TYCOMPLEX: 2364 case TYDCOMPLEX: 2365 switch(rt) 2366 { 2367 case TYSHORT: 2368 case TYLONG: 2369 /* fall through and do real assignment of 2370 first element 2371 */ 2372 case TYREAL: 2373 case TYDREAL: 2374 lv->cd[1] = 0; break; 2375 case TYCOMPLEX: 2376 case TYDCOMPLEX: 2377 lv->cd[1] = rv->cd[1]; break; 2378 } 2379 2380 case TYREAL: 2381 case TYDREAL: 2382 if( ISINT(rt) ) 2383 lv->cd[0] = rv->ci; 2384 else lv->cd[0] = rv->cd[0]; 2385 if( lt == TYREAL) 2386 { 2387 float f = lv->cd[0]; 2388 lv->cd[0] = f; 2389 } 2390 break; 2391 2392 case TYLOGICAL: 2393 lv->ci = rv->ci; 2394 break; 2395 } 2396 } 2397 2398 2399 2400 consnegop(p) 2401 register Constp p; 2402 { 2403 switch(p->vtype) 2404 { 2405 case TYSHORT: 2406 case TYLONG: 2407 p->const.ci = - p->const.ci; 2408 break; 2409 2410 case TYCOMPLEX: 2411 case TYDCOMPLEX: 2412 p->const.cd[1] = - p->const.cd[1]; 2413 /* fall through and do the real parts */ 2414 case TYREAL: 2415 case TYDREAL: 2416 p->const.cd[0] = - p->const.cd[0]; 2417 break; 2418 default: 2419 badtype("consnegop", p->vtype); 2420 } 2421 } 2422 2423 2424 2425 LOCAL conspower(powp, ap, n) 2426 register union Constant *powp; 2427 Constp ap; 2428 ftnint n; 2429 { 2430 register int type; 2431 union Constant x; 2432 2433 switch(type = ap->vtype) /* pow = 1 */ 2434 { 2435 case TYSHORT: 2436 case TYLONG: 2437 powp->ci = 1; 2438 break; 2439 case TYCOMPLEX: 2440 case TYDCOMPLEX: 2441 powp->cd[1] = 0; 2442 case TYREAL: 2443 case TYDREAL: 2444 powp->cd[0] = 1; 2445 break; 2446 default: 2447 badtype("conspower", type); 2448 } 2449 2450 if(n == 0) 2451 return; 2452 if(n < 0) 2453 { 2454 if( ISINT(type) ) 2455 { 2456 if (ap->const.ci == 0) 2457 err("zero raised to a negative power"); 2458 else if (ap->const.ci == 1) 2459 return; 2460 else if (ap->const.ci == -1) 2461 { 2462 if (n < -2) 2463 n = n + 2; 2464 n = -n; 2465 if (n % 2 == 1) 2466 powp->ci = -1; 2467 } 2468 else 2469 powp->ci = 0; 2470 return; 2471 } 2472 n = - n; 2473 consbinop(OPSLASH, type, &x, powp, &(ap->const)); 2474 } 2475 else 2476 consbinop(OPSTAR, type, &x, powp, &(ap->const)); 2477 2478 for( ; ; ) 2479 { 2480 if(n & 01) 2481 consbinop(OPSTAR, type, powp, powp, &x); 2482 if(n >>= 1) 2483 consbinop(OPSTAR, type, &x, &x, &x); 2484 else 2485 break; 2486 } 2487 } 2488 2489 2490 2491 /* do constant operation cp = a op b */ 2492 2493 2494 LOCAL consbinop(opcode, type, cp, ap, bp) 2495 int opcode, type; 2496 register union Constant *ap, *bp, *cp; 2497 { 2498 int k; 2499 double temp; 2500 2501 switch(opcode) 2502 { 2503 case OPPLUS: 2504 switch(type) 2505 { 2506 case TYSHORT: 2507 case TYLONG: 2508 cp->ci = ap->ci + bp->ci; 2509 break; 2510 case TYCOMPLEX: 2511 case TYDCOMPLEX: 2512 cp->cd[1] = ap->cd[1] + bp->cd[1]; 2513 case TYREAL: 2514 case TYDREAL: 2515 cp->cd[0] = ap->cd[0] + bp->cd[0]; 2516 break; 2517 } 2518 break; 2519 2520 case OPMINUS: 2521 switch(type) 2522 { 2523 case TYSHORT: 2524 case TYLONG: 2525 cp->ci = ap->ci - bp->ci; 2526 break; 2527 case TYCOMPLEX: 2528 case TYDCOMPLEX: 2529 cp->cd[1] = ap->cd[1] - bp->cd[1]; 2530 case TYREAL: 2531 case TYDREAL: 2532 cp->cd[0] = ap->cd[0] - bp->cd[0]; 2533 break; 2534 } 2535 break; 2536 2537 case OPSTAR: 2538 switch(type) 2539 { 2540 case TYSHORT: 2541 case TYLONG: 2542 cp->ci = ap->ci * bp->ci; 2543 break; 2544 case TYREAL: 2545 case TYDREAL: 2546 cp->cd[0] = ap->cd[0] * bp->cd[0]; 2547 break; 2548 case TYCOMPLEX: 2549 case TYDCOMPLEX: 2550 temp = ap->cd[0] * bp->cd[0] - 2551 ap->cd[1] * bp->cd[1] ; 2552 cp->cd[1] = ap->cd[0] * bp->cd[1] + 2553 ap->cd[1] * bp->cd[0] ; 2554 cp->cd[0] = temp; 2555 break; 2556 } 2557 break; 2558 case OPSLASH: 2559 switch(type) 2560 { 2561 case TYSHORT: 2562 case TYLONG: 2563 cp->ci = ap->ci / bp->ci; 2564 break; 2565 case TYREAL: 2566 case TYDREAL: 2567 cp->cd[0] = ap->cd[0] / bp->cd[0]; 2568 break; 2569 case TYCOMPLEX: 2570 case TYDCOMPLEX: 2571 zdiv(cp,ap,bp); 2572 break; 2573 } 2574 break; 2575 2576 case OPMOD: 2577 if( ISINT(type) ) 2578 { 2579 cp->ci = ap->ci % bp->ci; 2580 break; 2581 } 2582 else 2583 fatal("inline mod of noninteger"); 2584 2585 default: /* relational ops */ 2586 switch(type) 2587 { 2588 case TYSHORT: 2589 case TYLONG: 2590 if(ap->ci < bp->ci) 2591 k = -1; 2592 else if(ap->ci == bp->ci) 2593 k = 0; 2594 else k = 1; 2595 break; 2596 case TYREAL: 2597 case TYDREAL: 2598 if(ap->cd[0] < bp->cd[0]) 2599 k = -1; 2600 else if(ap->cd[0] == bp->cd[0]) 2601 k = 0; 2602 else k = 1; 2603 break; 2604 case TYCOMPLEX: 2605 case TYDCOMPLEX: 2606 if(ap->cd[0] == bp->cd[0] && 2607 ap->cd[1] == bp->cd[1] ) 2608 k = 0; 2609 else k = 1; 2610 break; 2611 } 2612 2613 switch(opcode) 2614 { 2615 case OPEQ: 2616 cp->ci = (k == 0); 2617 break; 2618 case OPNE: 2619 cp->ci = (k != 0); 2620 break; 2621 case OPGT: 2622 cp->ci = (k == 1); 2623 break; 2624 case OPLT: 2625 cp->ci = (k == -1); 2626 break; 2627 case OPGE: 2628 cp->ci = (k >= 0); 2629 break; 2630 case OPLE: 2631 cp->ci = (k <= 0); 2632 break; 2633 default: 2634 badop ("consbinop", opcode); 2635 } 2636 break; 2637 } 2638 } 2639 2640 2641 2642 2643 conssgn(p) 2644 register expptr p; 2645 { 2646 if( ! ISCONST(p) ) 2647 fatal( "sgn(nonconstant)" ); 2648 2649 switch(p->headblock.vtype) 2650 { 2651 case TYSHORT: 2652 case TYLONG: 2653 if(p->constblock.const.ci > 0) return(1); 2654 if(p->constblock.const.ci < 0) return(-1); 2655 return(0); 2656 2657 case TYREAL: 2658 case TYDREAL: 2659 if(p->constblock.const.cd[0] > 0) return(1); 2660 if(p->constblock.const.cd[0] < 0) return(-1); 2661 return(0); 2662 2663 case TYCOMPLEX: 2664 case TYDCOMPLEX: 2665 return(p->constblock.const.cd[0]!=0 || p->constblock.const.cd[1]!=0); 2666 2667 default: 2668 badtype( "conssgn", p->constblock.vtype); 2669 } 2670 /* NOTREACHED */ 2671 } 2672 2673 char *powint[ ] = { "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" }; 2674 2675 2676 LOCAL expptr mkpower(p) 2677 register expptr p; 2678 { 2679 register expptr q, lp, rp; 2680 int ltype, rtype, mtype; 2681 2682 lp = p->exprblock.leftp; 2683 rp = p->exprblock.rightp; 2684 ltype = lp->headblock.vtype; 2685 rtype = rp->headblock.vtype; 2686 2687 if(ISICON(rp)) 2688 { 2689 if(rp->constblock.const.ci == 0) 2690 { 2691 frexpr(p); 2692 if( ISINT(ltype) ) 2693 return( ICON(1) ); 2694 else 2695 { 2696 expptr pp; 2697 pp = mkconv(ltype, ICON(1)); 2698 return( pp ); 2699 } 2700 } 2701 if(rp->constblock.const.ci < 0) 2702 { 2703 if( ISINT(ltype) ) 2704 { 2705 frexpr(p); 2706 err("integer**negative"); 2707 return( errnode() ); 2708 } 2709 rp->constblock.const.ci = - rp->constblock.const.ci; 2710 p->exprblock.leftp = lp = fixexpr(mkexpr(OPSLASH, ICON(1), lp)); 2711 } 2712 if(rp->constblock.const.ci == 1) 2713 { 2714 frexpr(rp); 2715 free( (charptr) p ); 2716 return(lp); 2717 } 2718 2719 if( ONEOF(ltype, MSKINT|MSKREAL) ) 2720 { 2721 p->exprblock.vtype = ltype; 2722 return(p); 2723 } 2724 } 2725 if( ISINT(rtype) ) 2726 { 2727 if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) ) 2728 q = call2(TYSHORT, "pow_hh", lp, rp); 2729 else { 2730 if(ltype == TYSHORT) 2731 { 2732 ltype = TYLONG; 2733 lp = mkconv(TYLONG,lp); 2734 } 2735 q = call2(ltype, powint[ltype-TYLONG], lp, mkconv(TYLONG, rp)); 2736 } 2737 } 2738 else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) 2739 q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp)); 2740 else { 2741 q = call2(TYDCOMPLEX, "pow_zz", 2742 mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp)); 2743 if(mtype == TYCOMPLEX) 2744 q = mkconv(TYCOMPLEX, q); 2745 } 2746 free( (charptr) p ); 2747 return(q); 2748 } 2749 2750 2751 2752 /* Complex Division. Same code as in Runtime Library 2753 */ 2754 2755 struct dcomplex { double dreal, dimag; }; 2756 2757 2758 LOCAL zdiv(c, a, b) 2759 register struct dcomplex *a, *b, *c; 2760 { 2761 double ratio, den; 2762 double abr, abi; 2763 2764 if( (abr = b->dreal) < 0.) 2765 abr = - abr; 2766 if( (abi = b->dimag) < 0.) 2767 abi = - abi; 2768 if( abr <= abi ) 2769 { 2770 if(abi == 0) 2771 fatal("complex division by zero"); 2772 ratio = b->dreal / b->dimag ; 2773 den = b->dimag * (1 + ratio*ratio); 2774 c->dreal = (a->dreal*ratio + a->dimag) / den; 2775 c->dimag = (a->dimag*ratio - a->dreal) / den; 2776 } 2777 2778 else 2779 { 2780 ratio = b->dimag / b->dreal ; 2781 den = b->dreal * (1 + ratio*ratio); 2782 c->dreal = (a->dreal + a->dimag*ratio) / den; 2783 c->dimag = (a->dimag - a->dreal*ratio) / den; 2784 } 2785 2786 } 2787 2788 expptr oftwo(e) 2789 expptr e; 2790 { 2791 int val,res; 2792 2793 if (! ISCONST (e)) 2794 return (0); 2795 2796 val = e->constblock.const.ci; 2797 switch (val) 2798 { 2799 case 2: res = 1; break; 2800 case 4: res = 2; break; 2801 case 8: res = 3; break; 2802 case 16: res = 4; break; 2803 case 32: res = 5; break; 2804 case 64: res = 6; break; 2805 case 128: res = 7; break; 2806 case 256: res = 8; break; 2807 default: return (0); 2808 } 2809 return (ICON (res)); 2810 } 2811