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