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