1 /* $Id: expr.c,v 1.1.1.1 2008/08/24 05:33:06 gmcgarry Exp $ */ 2 /* 3 * Copyright(C) Caldera International Inc. 2001-2002. All rights reserved. 4 * 5 * Redistribution and use in source and binary forms, with or without 6 * modification, are permitted provided that the following conditions 7 * are met: 8 * 9 * Redistributions of source code and documentation must retain the above 10 * copyright notice, this list of conditions and the following disclaimer. 11 * Redistributions in binary form must reproduce the above copyright 12 * notice, this list of conditionsand the following disclaimer in the 13 * documentation and/or other materials provided with the distribution. 14 * All advertising materials mentioning features or use of this software 15 * must display the following acknowledgement: 16 * This product includes software developed or owned by Caldera 17 * International, Inc. 18 * Neither the name of Caldera International, Inc. nor the names of other 19 * contributors may be used to endorse or promote products derived from 20 * this software without specific prior written permission. 21 * 22 * USE OF THE SOFTWARE PROVIDED FOR UNDER THIS LICENSE BY CALDERA 23 * INTERNATIONAL, INC. AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR 24 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 25 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 26 * DISCLAIMED. IN NO EVENT SHALL CALDERA INTERNATIONAL, INC. BE LIABLE 27 * FOR ANY DIRECT, INDIRECT INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 28 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 29 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 30 * HOWEVER CAUSED AND ON ANY THEORY OFLIABILITY, WHETHER IN CONTRACT, 31 * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 32 * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 33 * POSSIBILITY OF SUCH DAMAGE. 34 */ 35 #include <string.h> 36 37 #include "defines.h" 38 #include "defs.h" 39 40 /* little routines to create constant blocks */ 41 LOCAL int letter(int c); 42 LOCAL void conspower(union constant *, struct bigblock *, ftnint); 43 LOCAL void consbinop(int, int, union constant *, union constant *, 44 union constant *); 45 LOCAL void zdiv(struct dcomplex *, struct dcomplex *, struct dcomplex *); 46 LOCAL struct bigblock *stfcall(struct bigblock *, struct bigblock *); 47 LOCAL bigptr mkpower(struct bigblock *p); 48 LOCAL bigptr fold(struct bigblock *e); 49 LOCAL bigptr subcheck(struct bigblock *, bigptr); 50 51 struct bigblock *mkconst(t) 52 register int t; 53 { 54 register struct bigblock *p; 55 56 p = BALLO(); 57 p->tag = TCONST; 58 p->vtype = t; 59 return(p); 60 } 61 62 63 struct bigblock *mklogcon(l) 64 register int l; 65 { 66 register struct bigblock * p; 67 68 p = mkconst(TYLOGICAL); 69 p->b_const.fconst.ci = l; 70 return(p); 71 } 72 73 74 75 struct bigblock *mkintcon(l) 76 ftnint l; 77 { 78 register struct bigblock *p; 79 80 p = mkconst(TYLONG); 81 p->b_const.fconst.ci = l; 82 #ifdef MAXSHORT 83 if(l >= -MAXSHORT && l <= MAXSHORT) 84 p->vtype = TYSHORT; 85 #endif 86 return(p); 87 } 88 89 90 91 struct bigblock *mkaddcon(l) 92 register int l; 93 { 94 register struct bigblock *p; 95 96 p = mkconst(TYADDR); 97 p->b_const.fconst.ci = l; 98 return(p); 99 } 100 101 102 103 struct bigblock *mkrealcon(t, d) 104 register int t; 105 double d; 106 { 107 register struct bigblock *p; 108 109 p = mkconst(t); 110 p->b_const.fconst.cd[0] = d; 111 return(p); 112 } 113 114 115 struct bigblock *mkbitcon(shift, leng, s) 116 int shift; 117 int leng; 118 char *s; 119 { 120 register struct bigblock *p; 121 122 p = mkconst(TYUNKNOWN); 123 p->b_const.fconst.ci = 0; 124 while(--leng >= 0) 125 if(*s != ' ') 126 p->b_const.fconst.ci = (p->b_const.fconst.ci << shift) | hextoi(*s++); 127 return(p); 128 } 129 130 131 132 133 134 struct bigblock *mkstrcon(l,v) 135 int l; 136 register char *v; 137 { 138 register struct bigblock *p; 139 register char *s; 140 141 p = mkconst(TYCHAR); 142 p->vleng = MKICON(l); 143 p->b_const.fconst.ccp = s = (char *) ckalloc(l); 144 while(--l >= 0) 145 *s++ = *v++; 146 return(p); 147 } 148 149 150 struct bigblock *mkcxcon(realp,imagp) 151 register bigptr realp, imagp; 152 { 153 int rtype, itype; 154 register struct bigblock *p; 155 156 rtype = realp->vtype; 157 itype = imagp->vtype; 158 159 if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) ) 160 { 161 p = mkconst( (rtype==TYDREAL||itype==TYDREAL) ? TYDCOMPLEX : TYCOMPLEX ); 162 if( ISINT(rtype) ) 163 p->b_const.fconst.cd[0] = realp->b_const.fconst.ci; 164 else p->b_const.fconst.cd[0] = realp->b_const.fconst.cd[0]; 165 if( ISINT(itype) ) 166 p->b_const.fconst.cd[1] = imagp->b_const.fconst.ci; 167 else p->b_const.fconst.cd[1] = imagp->b_const.fconst.cd[0]; 168 } 169 else 170 { 171 err("invalid complex constant"); 172 p = errnode(); 173 } 174 175 frexpr(realp); 176 frexpr(imagp); 177 return(p); 178 } 179 180 181 struct bigblock *errnode() 182 { 183 struct bigblock *p; 184 p = BALLO(); 185 p->tag = TERROR; 186 p->vtype = TYERROR; 187 return(p); 188 } 189 190 191 192 193 194 bigptr mkconv(t, p) 195 register int t; 196 register bigptr p; 197 { 198 register bigptr q; 199 200 if(t==TYUNKNOWN || t==TYERROR) 201 fatal1("mkconv of impossible type %d", t); 202 if(t == p->vtype) 203 return(p); 204 205 else if( ISCONST(p) && p->vtype!=TYADDR) 206 { 207 q = mkconst(t); 208 consconv(t, &(q->b_const.fconst), p->vtype, &(p->b_const.fconst)); 209 frexpr(p); 210 } 211 else 212 { 213 q = mkexpr(OPCONV, p, 0); 214 q->vtype = t; 215 } 216 return(q); 217 } 218 219 220 221 struct bigblock *addrof(p) 222 bigptr p; 223 { 224 return( mkexpr(OPADDR, p, NULL) ); 225 } 226 227 228 229 bigptr 230 cpexpr(p) 231 register bigptr p; 232 { 233 register bigptr e; 234 int tag; 235 register chainp ep, pp; 236 237 #if 0 238 static int blksize[ ] = { 0, sizeof(struct nameblock), sizeof(struct constblock), 239 sizeof(struct exprblock), sizeof(struct addrblock), 240 sizeof(struct primblock), sizeof(struct listblock), 241 sizeof(struct errorblock) 242 }; 243 #endif 244 245 if(p == NULL) 246 return(NULL); 247 248 if( (tag = p->tag) == TNAME) 249 return(p); 250 251 #if 0 252 e = cpblock( blksize[p->tag] , p); 253 #else 254 e = cpblock( sizeof(struct bigblock) , p); 255 #endif 256 257 switch(tag) 258 { 259 case TCONST: 260 if(e->vtype == TYCHAR) 261 { 262 e->b_const.fconst.ccp = copyn(1+strlen(e->b_const.fconst.ccp), e->b_const.fconst.ccp); 263 e->vleng = cpexpr(e->vleng); 264 } 265 case TERROR: 266 break; 267 268 case TEXPR: 269 e->b_expr.leftp = cpexpr(p->b_expr.leftp); 270 e->b_expr.rightp = cpexpr(p->b_expr.rightp); 271 break; 272 273 case TLIST: 274 if((pp = p->b_list.listp)) 275 { 276 ep = e->b_list.listp = mkchain( cpexpr(pp->chain.datap), NULL); 277 for(pp = pp->chain.nextp ; pp ; pp = pp->chain.nextp) 278 ep = ep->chain.nextp = mkchain( cpexpr(pp->chain.datap), NULL); 279 } 280 break; 281 282 case TADDR: 283 e->vleng = cpexpr(e->vleng); 284 e->b_addr.memoffset = cpexpr(e->b_addr.memoffset); 285 e->b_addr.istemp = NO; 286 break; 287 288 case TPRIM: 289 e->b_prim.argsp = cpexpr(e->b_prim.argsp); 290 e->b_prim.fcharp = cpexpr(e->b_prim.fcharp); 291 e->b_prim.lcharp = cpexpr(e->b_prim.lcharp); 292 break; 293 294 default: 295 fatal1("cpexpr: impossible tag %d", tag); 296 } 297 298 return(e); 299 } 300 301 void 302 frexpr(p) 303 register bigptr p; 304 { 305 register chainp q; 306 307 if(p == NULL) 308 return; 309 310 switch(p->tag) 311 { 312 case TCONST: 313 if( ISCHAR(p) ) 314 { 315 ckfree(p->b_const.fconst.ccp); 316 frexpr(p->vleng); 317 } 318 break; 319 320 case TADDR: 321 if(p->b_addr.istemp) 322 { 323 frtemp(p); 324 return; 325 } 326 frexpr(p->vleng); 327 frexpr(p->b_addr.memoffset); 328 break; 329 330 case TERROR: 331 break; 332 333 case TNAME: 334 return; 335 336 case TPRIM: 337 frexpr(p->b_prim.argsp); 338 frexpr(p->b_prim.fcharp); 339 frexpr(p->b_prim.lcharp); 340 break; 341 342 case TEXPR: 343 frexpr(p->b_expr.leftp); 344 if(p->b_expr.rightp) 345 frexpr(p->b_expr.rightp); 346 break; 347 348 case TLIST: 349 for(q = p->b_list.listp ; q ; q = q->chain.nextp) 350 frexpr(q->chain.datap); 351 frchain( &(p->b_list.listp) ); 352 break; 353 354 default: 355 fatal1("frexpr: impossible tag %d", p->tag); 356 } 357 358 ckfree(p); 359 } 360 361 /* fix up types in expression; replace subtrees and convert 362 names to address blocks */ 363 364 bigptr fixtype(p) 365 register bigptr p; 366 { 367 368 if(p == 0) 369 return(0); 370 371 switch(p->tag) 372 { 373 case TCONST: 374 if( ! ONEOF(p->vtype, MSKINT|MSKLOGICAL|MSKADDR) ) 375 p = putconst(p); 376 return(p); 377 378 case TADDR: 379 p->b_addr.memoffset = fixtype(p->b_addr.memoffset); 380 return(p); 381 382 case TERROR: 383 return(p); 384 385 default: 386 fatal1("fixtype: impossible tag %d", p->tag); 387 388 case TEXPR: 389 return( fixexpr(p) ); 390 391 case TLIST: 392 return( p ); 393 394 case TPRIM: 395 if(p->b_prim.argsp && p->b_prim.namep->vclass!=CLVAR) 396 return( mkfunct(p) ); 397 else return( mklhs(p) ); 398 } 399 } 400 401 402 403 404 405 /* special case tree transformations and cleanups of expression trees */ 406 407 bigptr fixexpr(p) 408 register struct bigblock *p; 409 { 410 bigptr lp; 411 register bigptr rp; 412 register bigptr q; 413 int opcode, ltype, rtype, ptype, mtype; 414 415 if(p->tag == TERROR) 416 return(p); 417 else if(p->tag != TEXPR) 418 fatal1("fixexpr: invalid tag %d", p->tag); 419 opcode = p->b_expr.opcode; 420 lp = p->b_expr.leftp = fixtype(p->b_expr.leftp); 421 ltype = lp->vtype; 422 if(opcode==OPASSIGN && lp->tag!=TADDR) 423 { 424 err("left side of assignment must be variable"); 425 frexpr(p); 426 return( errnode() ); 427 } 428 429 if(p->b_expr.rightp) 430 { 431 rp = p->b_expr.rightp = fixtype(p->b_expr.rightp); 432 rtype = rp->vtype; 433 } 434 else 435 { 436 rp = NULL; 437 rtype = 0; 438 } 439 440 /* force folding if possible */ 441 if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) ) 442 { 443 q = mkexpr(opcode, lp, rp); 444 if( ISCONST(q) ) 445 return(q); 446 ckfree(q); /* constants did not fold */ 447 } 448 449 if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR) 450 { 451 frexpr(p); 452 return( errnode() ); 453 } 454 455 switch(opcode) 456 { 457 case OPCONCAT: 458 if(p->vleng == NULL) 459 p->vleng = mkexpr(OPPLUS, cpexpr(lp->vleng), 460 cpexpr(rp->vleng) ); 461 break; 462 463 case OPASSIGN: 464 if(ltype == rtype) 465 break; 466 if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) ) 467 break; 468 if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) ) 469 break; 470 if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT) 471 && typesize[ltype]>=typesize[rtype] ) 472 break; 473 p->b_expr.rightp = fixtype( mkconv(ptype, rp) ); 474 break; 475 476 case OPSLASH: 477 if( ISCOMPLEX(rtype) ) 478 { 479 p = call2(ptype, ptype==TYCOMPLEX? "c_div" : "z_div", 480 mkconv(ptype, lp), mkconv(ptype, rp) ); 481 break; 482 } 483 case OPPLUS: 484 case OPMINUS: 485 case OPSTAR: 486 case OPMOD: 487 if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) || 488 (rtype==TYREAL && ! ISCONST(rp) ) )) 489 break; 490 if( ISCOMPLEX(ptype) ) 491 break; 492 if(ltype != ptype) 493 p->b_expr.leftp = fixtype(mkconv(ptype,lp)); 494 if(rtype != ptype) 495 p->b_expr.rightp = fixtype(mkconv(ptype,rp)); 496 break; 497 498 case OPPOWER: 499 return( mkpower(p) ); 500 501 case OPLT: 502 case OPLE: 503 case OPGT: 504 case OPGE: 505 case OPEQ: 506 case OPNE: 507 if(ltype == rtype) 508 break; 509 mtype = cktype(OPMINUS, ltype, rtype); 510 if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) || 511 (rtype==TYREAL && ! ISCONST(rp)) )) 512 break; 513 if( ISCOMPLEX(mtype) ) 514 break; 515 if(ltype != mtype) 516 p->b_expr.leftp = fixtype(mkconv(mtype,lp)); 517 if(rtype != mtype) 518 p->b_expr.rightp = fixtype(mkconv(mtype,rp)); 519 break; 520 521 522 case OPCONV: 523 ptype = cktype(OPCONV, p->vtype, ltype); 524 if(lp->tag==TEXPR && lp->b_expr.opcode==OPCOMMA) 525 { 526 lp->b_expr.rightp = fixtype( mkconv(ptype, lp->b_expr.rightp) ); 527 ckfree(p); 528 p = lp; 529 } 530 break; 531 532 case OPADDR: 533 if(lp->tag==TEXPR && lp->b_expr.opcode==OPADDR) 534 fatal("addr of addr"); 535 break; 536 537 case OPCOMMA: 538 break; 539 540 case OPMIN: 541 case OPMAX: 542 ptype = p->vtype; 543 break; 544 545 default: 546 break; 547 } 548 549 p->vtype = ptype; 550 return(p); 551 } 552 553 #if SZINT < SZLONG 554 /* 555 for efficient subscripting, replace long ints by shorts 556 in easy places 557 */ 558 559 bigptr shorten(p) 560 register bigptr p; 561 { 562 register bigptr q; 563 564 if(p->vtype != TYLONG) 565 return(p); 566 567 switch(p->tag) 568 { 569 case TERROR: 570 case TLIST: 571 return(p); 572 573 case TCONST: 574 case TADDR: 575 return( mkconv(TYINT,p) ); 576 577 case TEXPR: 578 break; 579 580 default: 581 fatal1("shorten: invalid tag %d", p->tag); 582 } 583 584 switch(p->opcode) 585 { 586 case OPPLUS: 587 case OPMINUS: 588 case OPSTAR: 589 q = shorten( cpexpr(p->rightp) ); 590 if(q->vtype == TYINT) 591 { 592 p->leftp = shorten(p->leftp); 593 if(p->leftp->vtype == TYLONG) 594 frexpr(q); 595 else 596 { 597 frexpr(p->rightp); 598 p->rightp = q; 599 p->vtype = TYINT; 600 } 601 } 602 break; 603 604 case OPNEG: 605 p->leftp = shorten(p->leftp); 606 if(p->leftp->vtype == TYINT) 607 p->vtype = TYINT; 608 break; 609 610 case OPCALL: 611 case OPCCALL: 612 p = mkconv(TYINT,p); 613 break; 614 default: 615 break; 616 } 617 618 return(p); 619 } 620 #endif 621 622 int 623 fixargs(doput, p0) 624 int doput; 625 struct bigblock *p0; 626 { 627 register chainp p; 628 register bigptr q, t; 629 register int qtag; 630 int nargs; 631 632 nargs = 0; 633 if(p0) 634 for(p = p0->b_list.listp ; p ; p = p->chain.nextp) 635 { 636 ++nargs; 637 q = p->chain.datap; 638 qtag = q->tag; 639 if(qtag == TCONST) 640 { 641 if(q->vtype == TYSHORT) 642 q = mkconv(tyint, q); 643 if(doput) 644 p->chain.datap = putconst(q); 645 else 646 p->chain.datap = q; 647 } 648 else if(qtag==TPRIM && q->b_prim.argsp==0 && q->b_prim.namep->vclass==CLPROC) 649 p->chain.datap = mkaddr(q->b_prim.namep); 650 else if(qtag==TPRIM && q->b_prim.argsp==0 && q->b_prim.namep->b_name.vdim!=NULL) 651 p->chain.datap = mkscalar(q->b_prim.namep); 652 else if(qtag==TPRIM && q->b_prim.argsp==0 && q->b_prim.namep->b_name.vdovar && 653 (t = memversion(q->b_prim.namep)) ) 654 p->chain.datap = fixtype(t); 655 else p->chain.datap = fixtype(q); 656 } 657 return(nargs); 658 } 659 660 struct bigblock * 661 mkscalar(np) 662 register struct bigblock *np; 663 { 664 register struct bigblock *ap; 665 666 vardcl(np); 667 ap = mkaddr(np); 668 669 #ifdef __vax__ 670 /* on the VAX, prolog causes array arguments 671 to point at the (0,...,0) element, except when 672 subscript checking is on 673 */ 674 if( !checksubs && np->vstg==STGARG) 675 { 676 register struct dimblock *dp; 677 dp = np->vdim; 678 frexpr(ap->memoffset); 679 ap->memoffset = mkexpr(OPSTAR, MKICON(typesize[np->vtype]), 680 cpexpr(dp->baseoffset) ); 681 } 682 #endif 683 return(ap); 684 } 685 686 687 688 689 690 bigptr mkfunct(p) 691 register struct bigblock * p; 692 { 693 chainp ep; 694 struct bigblock *ap; 695 struct extsym *extp; 696 register struct bigblock *np; 697 register struct bigblock *q; 698 int k, nargs; 699 int class; 700 701 np = p->b_prim.namep; 702 class = np->vclass; 703 704 if(class == CLUNKNOWN) 705 { 706 np->vclass = class = CLPROC; 707 if(np->vstg == STGUNKNOWN) 708 { 709 if((k = intrfunct(np->b_name.varname))) 710 { 711 np->vstg = STGINTR; 712 np->b_name.vardesc.varno = k; 713 np->b_name.vprocclass = PINTRINSIC; 714 } 715 else 716 { 717 extp = mkext( varunder(VL,np->b_name.varname) ); 718 extp->extstg = STGEXT; 719 np->vstg = STGEXT; 720 np->b_name.vardesc.varno = extp - extsymtab; 721 np->b_name.vprocclass = PEXTERNAL; 722 } 723 } 724 else if(np->vstg==STGARG) 725 { 726 if(np->vtype!=TYCHAR && !ftn66flag) 727 warn("Dummy procedure not declared EXTERNAL. Code may be wrong."); 728 np->b_name.vprocclass = PEXTERNAL; 729 } 730 } 731 732 if(class != CLPROC) 733 fatal1("invalid class code for function", class); 734 if(p->b_prim.fcharp || p->b_prim.lcharp) 735 { 736 err("no substring of function call"); 737 goto error; 738 } 739 impldcl(np); 740 nargs = fixargs( np->b_name.vprocclass!=PINTRINSIC, p->b_prim.argsp); 741 742 switch(np->b_name.vprocclass) 743 { 744 case PEXTERNAL: 745 ap = mkaddr(np); 746 call: 747 q = mkexpr(OPCALL, ap, p->b_prim.argsp); 748 q->vtype = np->vtype; 749 if(np->vleng) 750 q->vleng = cpexpr(np->vleng); 751 break; 752 753 case PINTRINSIC: 754 q = intrcall(np, p->b_prim.argsp, nargs); 755 break; 756 757 case PSTFUNCT: 758 q = stfcall(np, p->b_prim.argsp); 759 break; 760 761 case PTHISPROC: 762 warn("recursive call"); 763 for(ep = entries ; ep ; ep = ep->entrypoint.nextp) 764 if(ep->entrypoint.enamep == np) 765 break; 766 if(ep == NULL) 767 fatal("mkfunct: impossible recursion"); 768 ap = builtin(np->vtype, varstr(XL, ep->entrypoint.entryname->extname) ); 769 goto call; 770 771 default: 772 fatal1("mkfunct: impossible vprocclass %d", np->b_name.vprocclass); 773 q = 0; /* XXX gcc */ 774 } 775 ckfree(p); 776 return(q); 777 778 error: 779 frexpr(p); 780 return( errnode() ); 781 } 782 783 784 785 LOCAL struct bigblock * 786 stfcall(struct bigblock *np, struct bigblock *actlist) 787 { 788 register chainp actuals; 789 int nargs; 790 chainp oactp, formals; 791 int type; 792 struct bigblock *q, *rhs; 793 bigptr ap; 794 register chainp rp; 795 chainp tlist; 796 797 if(actlist) { 798 actuals = actlist->b_list.listp; 799 ckfree(actlist); 800 } else 801 actuals = NULL; 802 oactp = actuals; 803 804 nargs = 0; 805 tlist = NULL; 806 type = np->vtype; 807 808 formals = (chainp)np->b_name.vardesc.vstfdesc->chain.datap; 809 rhs = (bigptr)np->b_name.vardesc.vstfdesc->chain.nextp; 810 811 /* copy actual arguments into temporaries */ 812 while(actuals!=NULL && formals!=NULL) { 813 rp = ALLOC(rplblock); 814 rp->rplblock.rplnp = q = formals->chain.datap; 815 ap = fixtype(actuals->chain.datap); 816 if(q->vtype==ap->vtype && q->vtype!=TYCHAR 817 && (ap->tag==TCONST || ap->tag==TADDR) ) { 818 rp->rplblock.rplvp = ap; 819 rp->rplblock.rplxp = NULL; 820 rp->rplblock.rpltag = ap->tag; 821 } else { 822 rp->rplblock.rplvp = fmktemp(q->vtype, q->vleng); 823 rp->rplblock.rplxp = fixtype( mkexpr(OPASSIGN, 824 cpexpr(rp->rplblock.rplvp), ap) ); 825 if( (rp->rplblock.rpltag = 826 rp->rplblock.rplxp->tag) == TERROR) 827 err("disagreement of argument types in statement function call"); 828 } 829 rp->rplblock.nextp = tlist; 830 tlist = rp; 831 actuals = actuals->chain.nextp; 832 formals = formals->chain.nextp; 833 ++nargs; 834 } 835 836 if(actuals!=NULL || formals!=NULL) 837 err("statement function definition and argument list differ"); 838 839 /* 840 now push down names involved in formal argument list, then 841 evaluate rhs of statement function definition in this environment 842 */ 843 rpllist = hookup(tlist, rpllist); 844 q = mkconv(type, fixtype(cpexpr(rhs)) ); 845 846 /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */ 847 while(--nargs >= 0) { 848 if(rpllist->rplblock.rplxp) 849 q = mkexpr(OPCOMMA, rpllist->rplblock.rplxp, q); 850 rp = rpllist->rplblock.nextp; 851 frexpr(rpllist->rplblock.rplvp); 852 ckfree(rpllist); 853 rpllist = rp; 854 } 855 856 frchain( &oactp ); 857 return(q); 858 } 859 860 861 862 863 struct bigblock * 864 mklhs(struct bigblock *p) 865 { 866 struct bigblock *s; 867 struct bigblock *np; 868 chainp rp; 869 int regn; 870 871 /* first fixup name */ 872 873 if(p->tag != TPRIM) 874 return(p); 875 876 np = p->b_prim.namep; 877 878 /* is name on the replace list? */ 879 880 for(rp = rpllist ; rp ; rp = rp->rplblock.nextp) { 881 if(np == rp->rplblock.rplnp) { 882 if(rp->rplblock.rpltag == TNAME) { 883 np = p->b_prim.namep = rp->rplblock.rplvp; 884 break; 885 } else 886 return( cpexpr(rp->rplblock.rplvp) ); 887 } 888 } 889 890 /* is variable a DO index in a register ? */ 891 892 if(np->b_name.vdovar && ( (regn = inregister(np)) >= 0) ) { 893 if(np->vtype == TYERROR) 894 return( errnode() ); 895 else { 896 s = BALLO(); 897 s->tag = TADDR; 898 s->vstg = STGREG; 899 s->vtype = TYIREG; 900 s->b_addr.memno = regn; 901 s->b_addr.memoffset = MKICON(0); 902 return(s); 903 } 904 } 905 906 vardcl(np); 907 s = mkaddr(np); 908 s->b_addr.memoffset = mkexpr(OPPLUS, s->b_addr.memoffset, suboffset(p) ); 909 frexpr(p->b_prim.argsp); 910 p->b_prim.argsp = NULL; 911 912 /* now do substring part */ 913 914 if(p->b_prim.fcharp || p->b_prim.lcharp) { 915 if(np->vtype != TYCHAR) 916 err1("substring of noncharacter %s", 917 varstr(VL,np->b_name.varname)); 918 else { 919 if(p->b_prim.lcharp == NULL) 920 p->b_prim.lcharp = cpexpr(s->vleng); 921 if(p->b_prim.fcharp) 922 s->vleng = mkexpr(OPMINUS, p->b_prim.lcharp, 923 mkexpr(OPMINUS, p->b_prim.fcharp, MKICON(1) )); 924 else { 925 frexpr(s->vleng); 926 s->vleng = p->b_prim.lcharp; 927 } 928 } 929 } 930 931 s->vleng = fixtype( s->vleng ); 932 s->b_addr.memoffset = fixtype( s->b_addr.memoffset ); 933 ckfree(p); 934 return(s); 935 } 936 937 938 939 940 void 941 deregister(np) 942 struct bigblock *np; 943 { 944 } 945 946 947 948 949 struct bigblock *memversion(np) 950 register struct bigblock *np; 951 { 952 register struct bigblock *s; 953 954 if(np->b_name.vdovar==NO || (inregister(np)<0) ) 955 return(NULL); 956 np->b_name.vdovar = NO; 957 s = mklhs( mkprim(np, 0,0,0) ); 958 np->b_name.vdovar = YES; 959 return(s); 960 } 961 962 963 int 964 inregister(np) 965 register struct bigblock *np; 966 { 967 return(-1); 968 } 969 970 971 972 int 973 enregister(np) 974 struct bigblock *np; 975 { 976 return(NO); 977 } 978 979 980 981 982 bigptr suboffset(p) 983 register struct bigblock *p; 984 { 985 int n; 986 bigptr size; 987 chainp cp; 988 bigptr offp, prod; 989 struct dimblock *dimp; 990 bigptr sub[8]; 991 register struct bigblock *np; 992 993 np = p->b_prim.namep; 994 offp = MKICON(0); 995 n = 0; 996 if(p->b_prim.argsp) 997 for(cp = p->b_prim.argsp->b_list.listp ; cp ; cp = cp->chain.nextp) 998 { 999 sub[n++] = fixtype(cpexpr(cp->chain.datap)); 1000 if(n > 7) 1001 { 1002 err("more than 7 subscripts"); 1003 break; 1004 } 1005 } 1006 1007 dimp = np->b_name.vdim; 1008 if(n>0 && dimp==NULL) 1009 err("subscripts on scalar variable"); 1010 else if(dimp && dimp->ndim!=n) 1011 err1("wrong number of subscripts on %s", 1012 varstr(VL, np->b_name.varname) ); 1013 else if(n > 0) 1014 { 1015 prod = sub[--n]; 1016 while( --n >= 0) 1017 prod = mkexpr(OPPLUS, sub[n], 1018 mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) ); 1019 #ifdef __vax__ 1020 if(checksubs || np->vstg!=STGARG) 1021 prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset)); 1022 #else 1023 prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset)); 1024 #endif 1025 if(checksubs) 1026 prod = subcheck(np, prod); 1027 if(np->vtype == TYCHAR) 1028 size = cpexpr(np->vleng); 1029 else size = MKICON( typesize[np->vtype] ); 1030 prod = mkexpr(OPSTAR, prod, size); 1031 offp = mkexpr(OPPLUS, offp, prod); 1032 } 1033 1034 if(p->b_prim.fcharp && np->vtype==TYCHAR) 1035 offp = mkexpr(OPPLUS, offp, mkexpr(OPMINUS, cpexpr(p->b_prim.fcharp), MKICON(1) )); 1036 1037 return(offp); 1038 } 1039 1040 1041 /* 1042 * Check if an array is addressed out of bounds. 1043 */ 1044 bigptr 1045 subcheck(struct bigblock *np, bigptr p) 1046 { 1047 struct dimblock *dimp; 1048 bigptr t, badcall; 1049 int l1, l2; 1050 1051 dimp = np->b_name.vdim; 1052 if(dimp->nelt == NULL) 1053 return(p); /* don't check arrays with * bounds */ 1054 if( ISICON(p) ) { 1055 if(p->b_const.fconst.ci < 0) 1056 goto badsub; 1057 if( ISICON(dimp->nelt) ) { 1058 if(p->b_const.fconst.ci < dimp->nelt->b_const.fconst.ci) 1059 return(p); 1060 else 1061 goto badsub; 1062 } 1063 } 1064 1065 if (p->tag==TADDR && p->vstg==STGREG) { 1066 t = p; 1067 } else { 1068 t = fmktemp(p->vtype, NULL); 1069 putexpr(mkexpr(OPASSIGN, cpexpr(t), p)); 1070 } 1071 /* t now cotains evaluated expression */ 1072 1073 l1 = newlabel(); 1074 l2 = newlabel(); 1075 putif(mkexpr(OPLT, cpexpr(t), cpexpr(dimp->nelt)), l1); 1076 putif(mkexpr(OPGE, cpexpr(t), MKICON(0)), l1); 1077 putgoto(l2); 1078 putlabel(l1); 1079 1080 badcall = call4(t->vtype, "s_rnge", mkstrcon(VL, np->b_name.varname), 1081 mkconv(TYLONG, cpexpr(t)), 1082 mkstrcon(XL, procname), MKICON(lineno)); 1083 badcall->b_expr.opcode = OPCCALL; 1084 1085 putexpr(badcall); 1086 putlabel(l2); 1087 return t; 1088 1089 badsub: 1090 frexpr(p); 1091 err1("subscript on variable %s out of range", 1092 varstr(VL,np->b_name.varname)); 1093 return ( MKICON(0) ); 1094 } 1095 1096 1097 1098 1099 struct bigblock *mkaddr(p) 1100 register struct bigblock *p; 1101 { 1102 struct extsym *extp; 1103 register struct bigblock *t; 1104 1105 switch( p->vstg) 1106 { 1107 case STGUNKNOWN: 1108 if(p->vclass != CLPROC) 1109 break; 1110 extp = mkext( varunder(VL, p->b_name.varname) ); 1111 extp->extstg = STGEXT; 1112 p->vstg = STGEXT; 1113 p->b_name.vardesc.varno = extp - extsymtab; 1114 p->b_name.vprocclass = PEXTERNAL; 1115 1116 case STGCOMMON: 1117 case STGEXT: 1118 case STGBSS: 1119 case STGINIT: 1120 case STGEQUIV: 1121 case STGARG: 1122 case STGLENG: 1123 case STGAUTO: 1124 t = BALLO(); 1125 t->tag = TADDR; 1126 t->vclass = p->vclass; 1127 t->vtype = p->vtype; 1128 t->vstg = p->vstg; 1129 t->b_addr.memno = p->b_name.vardesc.varno; 1130 t->b_addr.memoffset = MKICON(p->b_name.voffset); 1131 if(p->vleng) 1132 t->vleng = cpexpr(p->vleng); 1133 return(t); 1134 1135 case STGINTR: 1136 return( intraddr(p) ); 1137 1138 } 1139 /*debug*/ fprintf(diagfile, "mkaddr. vtype=%d, vclass=%d\n", p->vtype, p->vclass); 1140 fatal1("mkaddr: impossible storage tag %d", p->vstg); 1141 /* NOTREACHED */ 1142 return 0; /* XXX gcc */ 1143 } 1144 1145 1146 1147 struct bigblock * 1148 mkarg(type, argno) 1149 int type, argno; 1150 { 1151 register struct bigblock *p; 1152 1153 p = BALLO(); 1154 p->tag = TADDR; 1155 p->vtype = type; 1156 p->vclass = CLVAR; 1157 p->vstg = (type==TYLENG ? STGLENG : STGARG); 1158 p->b_addr.memno = argno; 1159 return(p); 1160 } 1161 1162 1163 1164 1165 bigptr mkprim(v, args, lstr, rstr) 1166 register bigptr v; 1167 struct bigblock *args; 1168 bigptr lstr, rstr; 1169 { 1170 register struct bigblock *p; 1171 1172 if(v->vclass == CLPARAM) 1173 { 1174 if(args || lstr || rstr) 1175 { 1176 err1("no qualifiers on parameter name", varstr(VL,v->b_name.varname)); 1177 frexpr(args); 1178 frexpr(lstr); 1179 frexpr(rstr); 1180 frexpr(v); 1181 return( errnode() ); 1182 } 1183 return( cpexpr(v->b_param.paramval) ); 1184 } 1185 1186 p = BALLO(); 1187 p->tag = TPRIM; 1188 p->vtype = v->vtype; 1189 p->b_prim.namep = v; 1190 p->b_prim.argsp = args; 1191 p->b_prim.fcharp = lstr; 1192 p->b_prim.lcharp = rstr; 1193 return(p); 1194 } 1195 1196 1197 void 1198 vardcl(v) 1199 register struct bigblock *v; 1200 { 1201 int nelt; 1202 struct dimblock *t; 1203 struct bigblock *p; 1204 bigptr neltp; 1205 1206 if(v->b_name.vdcldone) return; 1207 1208 if(v->vtype == TYUNKNOWN) 1209 impldcl(v); 1210 if(v->vclass == CLUNKNOWN) 1211 v->vclass = CLVAR; 1212 else if(v->vclass!=CLVAR && v->b_name.vprocclass!=PTHISPROC) 1213 { 1214 dclerr("used as variable", v); 1215 return; 1216 } 1217 if(v->vstg==STGUNKNOWN) 1218 v->vstg = implstg[ letter(v->b_name.varname[0]) ]; 1219 1220 switch(v->vstg) 1221 { 1222 case STGBSS: 1223 v->b_name.vardesc.varno = ++lastvarno; 1224 break; 1225 case STGAUTO: 1226 if(v->vclass==CLPROC && v->b_name.vprocclass==PTHISPROC) 1227 break; 1228 nelt = 1; 1229 if((t = v->b_name.vdim)) { 1230 if( (neltp = t->nelt) && ISCONST(neltp) ) 1231 nelt = neltp->b_const.fconst.ci; 1232 else 1233 dclerr("adjustable automatic array", v); 1234 } 1235 p = autovar(nelt, v->vtype, v->vleng); 1236 v->b_name.voffset = p->b_addr.memoffset->b_const.fconst.ci; 1237 frexpr(p); 1238 break; 1239 1240 default: 1241 break; 1242 } 1243 v->b_name.vdcldone = YES; 1244 } 1245 1246 1247 1248 void 1249 impldcl(p) 1250 register struct bigblock *p; 1251 { 1252 register int k; 1253 int type, leng; 1254 1255 if(p->b_name.vdcldone || (p->vclass==CLPROC && p->b_name.vprocclass==PINTRINSIC) ) 1256 return; 1257 if(p->vtype == TYUNKNOWN) 1258 { 1259 k = letter(p->b_name.varname[0]); 1260 type = impltype[ k ]; 1261 leng = implleng[ k ]; 1262 if(type == TYUNKNOWN) 1263 { 1264 if(p->vclass == CLPROC) 1265 return; 1266 dclerr("attempt to use undefined variable", p); 1267 type = TYERROR; 1268 leng = 1; 1269 } 1270 settype(p, type, leng); 1271 } 1272 } 1273 1274 1275 1276 1277 LOCAL int 1278 letter(c) 1279 register int c; 1280 { 1281 if( isupper(c) ) 1282 c = tolower(c); 1283 return(c - 'a'); 1284 } 1285 1286 #define ICONEQ(z, c) (ISICON(z) && z->b_const.fconst.ci==c) 1287 #define COMMUTE { e = lp; lp = rp; rp = e; } 1288 1289 1290 struct bigblock * 1291 mkexpr(opcode, lp, rp) 1292 int opcode; 1293 register bigptr lp, rp; 1294 { 1295 register struct bigblock *e, *e1; 1296 int etype; 1297 int ltype, rtype; 1298 int ltag, rtag; 1299 1300 ltype = lp->vtype; 1301 ltag = lp->tag; 1302 if(rp && opcode!=OPCALL && opcode!=OPCCALL) 1303 { 1304 rtype = rp->vtype; 1305 rtag = rp->tag; 1306 } 1307 else rtype = rtag = 0; 1308 1309 etype = cktype(opcode, ltype, rtype); 1310 if(etype == TYERROR) 1311 goto error; 1312 1313 switch(opcode) 1314 { 1315 /* check for multiplication by 0 and 1 and addition to 0 */ 1316 1317 case OPSTAR: 1318 if( ISCONST(lp) ) 1319 COMMUTE 1320 1321 if( ISICON(rp) ) 1322 { 1323 if(rp->b_const.fconst.ci == 0) 1324 goto retright; 1325 goto mulop; 1326 } 1327 break; 1328 1329 case OPSLASH: 1330 case OPMOD: 1331 if( ICONEQ(rp, 0) ) 1332 { 1333 err("attempted division by zero"); 1334 rp = MKICON(1); 1335 break; 1336 } 1337 if(opcode == OPMOD) 1338 break; 1339 1340 1341 mulop: 1342 if( ISICON(rp) ) 1343 { 1344 if(rp->b_const.fconst.ci == 1) 1345 goto retleft; 1346 1347 if(rp->b_const.fconst.ci == -1) 1348 { 1349 frexpr(rp); 1350 return( mkexpr(OPNEG, lp, 0) ); 1351 } 1352 } 1353 1354 if( ISSTAROP(lp) && ISICON(lp->b_expr.rightp) ) 1355 { 1356 if(opcode == OPSTAR) 1357 e = mkexpr(OPSTAR, lp->b_expr.rightp, rp); 1358 else if(ISICON(rp) && lp->b_expr.rightp->b_const.fconst.ci % rp->b_const.fconst.ci == 0) 1359 e = mkexpr(OPSLASH, lp->b_expr.rightp, rp); 1360 else break; 1361 1362 e1 = lp->b_expr.leftp; 1363 ckfree(lp); 1364 return( mkexpr(OPSTAR, e1, e) ); 1365 } 1366 break; 1367 1368 1369 case OPPLUS: 1370 if( ISCONST(lp) ) 1371 COMMUTE 1372 goto addop; 1373 1374 case OPMINUS: 1375 if( ICONEQ(lp, 0) ) 1376 { 1377 frexpr(lp); 1378 return( mkexpr(OPNEG, rp, 0) ); 1379 } 1380 1381 if( ISCONST(rp) ) 1382 { 1383 opcode = OPPLUS; 1384 consnegop(rp); 1385 } 1386 1387 addop: 1388 if( ISICON(rp) ) 1389 { 1390 if(rp->b_const.fconst.ci == 0) 1391 goto retleft; 1392 if( ISPLUSOP(lp) && ISICON(lp->b_expr.rightp) ) 1393 { 1394 e = mkexpr(OPPLUS, lp->b_expr.rightp, rp); 1395 e1 = lp->b_expr.leftp; 1396 ckfree(lp); 1397 return( mkexpr(OPPLUS, e1, e) ); 1398 } 1399 } 1400 break; 1401 1402 1403 case OPPOWER: 1404 break; 1405 1406 case OPNEG: 1407 if(ltag==TEXPR && lp->b_expr.opcode==OPNEG) 1408 { 1409 e = lp->b_expr.leftp; 1410 ckfree(lp); 1411 return(e); 1412 } 1413 break; 1414 1415 case OPNOT: 1416 if(ltag==TEXPR && lp->b_expr.opcode==OPNOT) 1417 { 1418 e = lp->b_expr.leftp; 1419 ckfree(lp); 1420 return(e); 1421 } 1422 break; 1423 1424 case OPCALL: 1425 case OPCCALL: 1426 etype = ltype; 1427 if(rp!=NULL && rp->b_list.listp==NULL) 1428 { 1429 ckfree(rp); 1430 rp = NULL; 1431 } 1432 break; 1433 1434 case OPAND: 1435 case OPOR: 1436 if( ISCONST(lp) ) 1437 COMMUTE 1438 1439 if( ISCONST(rp) ) 1440 { 1441 if(rp->b_const.fconst.ci == 0) 1442 if(opcode == OPOR) 1443 goto retleft; 1444 else 1445 goto retright; 1446 else if(opcode == OPOR) 1447 goto retright; 1448 else 1449 goto retleft; 1450 } 1451 case OPEQV: 1452 case OPNEQV: 1453 1454 case OPBITAND: 1455 case OPBITOR: 1456 case OPBITXOR: 1457 case OPBITNOT: 1458 case OPLSHIFT: 1459 case OPRSHIFT: 1460 1461 case OPLT: 1462 case OPGT: 1463 case OPLE: 1464 case OPGE: 1465 case OPEQ: 1466 case OPNE: 1467 1468 case OPCONCAT: 1469 break; 1470 case OPMIN: 1471 case OPMAX: 1472 1473 case OPASSIGN: 1474 1475 case OPCONV: 1476 case OPADDR: 1477 1478 case OPCOMMA: 1479 break; 1480 1481 default: 1482 fatal1("mkexpr: impossible opcode %d", opcode); 1483 } 1484 1485 e = BALLO(); 1486 e->tag = TEXPR; 1487 e->b_expr.opcode = opcode; 1488 e->vtype = etype; 1489 e->b_expr.leftp = lp; 1490 e->b_expr.rightp = rp; 1491 if(ltag==TCONST && (rp==0 || rtag==TCONST) ) 1492 e = fold(e); 1493 return(e); 1494 1495 retleft: 1496 frexpr(rp); 1497 return(lp); 1498 1499 retright: 1500 frexpr(lp); 1501 return(rp); 1502 1503 error: 1504 frexpr(lp); 1505 if(rp && opcode!=OPCALL && opcode!=OPCCALL) 1506 frexpr(rp); 1507 return( errnode() ); 1508 } 1509 1510 #define ERR(s) { errs = s; goto error; } 1511 1512 int 1513 cktype(op, lt, rt) 1514 register int op, lt, rt; 1515 { 1516 char *errs = NULL; /* XXX gcc */ 1517 1518 if(lt==TYERROR || rt==TYERROR) 1519 goto error1; 1520 1521 if(lt==TYUNKNOWN) 1522 return(TYUNKNOWN); 1523 if(rt==TYUNKNOWN) 1524 if(op!=OPNOT && op!=OPBITNOT && op!=OPNEG && op!=OPCALL && op!=OPCCALL && op!=OPADDR) 1525 return(TYUNKNOWN); 1526 1527 switch(op) 1528 { 1529 case OPPLUS: 1530 case OPMINUS: 1531 case OPSTAR: 1532 case OPSLASH: 1533 case OPPOWER: 1534 case OPMOD: 1535 if( ISNUMERIC(lt) && ISNUMERIC(rt) ) 1536 return( maxtype(lt, rt) ); 1537 ERR("nonarithmetic operand of arithmetic operator") 1538 1539 case OPNEG: 1540 if( ISNUMERIC(lt) ) 1541 return(lt); 1542 ERR("nonarithmetic operand of negation") 1543 1544 case OPNOT: 1545 if(lt == TYLOGICAL) 1546 return(TYLOGICAL); 1547 ERR("NOT of nonlogical") 1548 1549 case OPAND: 1550 case OPOR: 1551 case OPEQV: 1552 case OPNEQV: 1553 if(lt==TYLOGICAL && rt==TYLOGICAL) 1554 return(TYLOGICAL); 1555 ERR("nonlogical operand of logical operator") 1556 1557 case OPLT: 1558 case OPGT: 1559 case OPLE: 1560 case OPGE: 1561 case OPEQ: 1562 case OPNE: 1563 if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL) 1564 { 1565 if(lt != rt) 1566 ERR("illegal comparison") 1567 } 1568 1569 else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) ) 1570 { 1571 if(op!=OPEQ && op!=OPNE) 1572 ERR("order comparison of complex data") 1573 } 1574 1575 else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) ) 1576 ERR("comparison of nonarithmetic data") 1577 return(TYLOGICAL); 1578 1579 case OPCONCAT: 1580 if(lt==TYCHAR && rt==TYCHAR) 1581 return(TYCHAR); 1582 ERR("concatenation of nonchar data") 1583 1584 case OPCALL: 1585 case OPCCALL: 1586 return(lt); 1587 1588 case OPADDR: 1589 return(TYADDR); 1590 1591 case OPCONV: 1592 if(rt == 0) 1593 return(0); 1594 case OPASSIGN: 1595 if( ISINT(lt) && rt==TYCHAR) 1596 return(lt); 1597 if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL) 1598 if(op!=OPASSIGN || lt!=rt) 1599 { 1600 /* debug fprintf(diagfile, " lt=%d, rt=%d, op=%d\n", lt, rt, op); */ 1601 /* debug fatal("impossible conversion. possible compiler bug"); */ 1602 ERR("impossible conversion") 1603 } 1604 return(lt); 1605 1606 case OPMIN: 1607 case OPMAX: 1608 case OPBITOR: 1609 case OPBITAND: 1610 case OPBITXOR: 1611 case OPBITNOT: 1612 case OPLSHIFT: 1613 case OPRSHIFT: 1614 return(lt); 1615 1616 case OPCOMMA: 1617 return(rt); 1618 1619 default: 1620 fatal1("cktype: impossible opcode %d", op); 1621 } 1622 error: err(errs); 1623 error1: return(TYERROR); 1624 } 1625 1626 LOCAL bigptr fold(e) 1627 register struct bigblock *e; 1628 { 1629 struct bigblock *p; 1630 register bigptr lp, rp; 1631 int etype, mtype, ltype, rtype, opcode; 1632 int i, ll, lr; 1633 char *q, *s; 1634 union constant lcon, rcon; 1635 1636 opcode = e->b_expr.opcode; 1637 etype = e->vtype; 1638 1639 lp = e->b_expr.leftp; 1640 ltype = lp->vtype; 1641 rp = e->b_expr.rightp; 1642 1643 if(rp == 0) 1644 switch(opcode) 1645 { 1646 case OPNOT: 1647 lp->b_const.fconst.ci = ! lp->b_const.fconst.ci; 1648 return(lp); 1649 1650 case OPBITNOT: 1651 lp->b_const.fconst.ci = ~ lp->b_const.fconst.ci; 1652 return(lp); 1653 1654 case OPNEG: 1655 consnegop(lp); 1656 return(lp); 1657 1658 case OPCONV: 1659 case OPADDR: 1660 return(e); 1661 1662 default: 1663 fatal1("fold: invalid unary operator %d", opcode); 1664 } 1665 1666 rtype = rp->vtype; 1667 1668 p = BALLO(); 1669 p->tag = TCONST; 1670 p->vtype = etype; 1671 p->vleng = e->vleng; 1672 1673 switch(opcode) 1674 { 1675 case OPCOMMA: 1676 return(e); 1677 1678 case OPAND: 1679 p->b_const.fconst.ci = lp->b_const.fconst.ci && rp->b_const.fconst.ci; 1680 break; 1681 1682 case OPOR: 1683 p->b_const.fconst.ci = lp->b_const.fconst.ci || rp->b_const.fconst.ci; 1684 break; 1685 1686 case OPEQV: 1687 p->b_const.fconst.ci = lp->b_const.fconst.ci == rp->b_const.fconst.ci; 1688 break; 1689 1690 case OPNEQV: 1691 p->b_const.fconst.ci = lp->b_const.fconst.ci != rp->b_const.fconst.ci; 1692 break; 1693 1694 case OPBITAND: 1695 p->b_const.fconst.ci = lp->b_const.fconst.ci & rp->b_const.fconst.ci; 1696 break; 1697 1698 case OPBITOR: 1699 p->b_const.fconst.ci = lp->b_const.fconst.ci | rp->b_const.fconst.ci; 1700 break; 1701 1702 case OPBITXOR: 1703 p->b_const.fconst.ci = lp->b_const.fconst.ci ^ rp->b_const.fconst.ci; 1704 break; 1705 1706 case OPLSHIFT: 1707 p->b_const.fconst.ci = lp->b_const.fconst.ci << rp->b_const.fconst.ci; 1708 break; 1709 1710 case OPRSHIFT: 1711 p->b_const.fconst.ci = lp->b_const.fconst.ci >> rp->b_const.fconst.ci; 1712 break; 1713 1714 case OPCONCAT: 1715 ll = lp->vleng->b_const.fconst.ci; 1716 lr = rp->vleng->b_const.fconst.ci; 1717 p->b_const.fconst.ccp = q = (char *) ckalloc(ll+lr); 1718 p->vleng = MKICON(ll+lr); 1719 s = lp->b_const.fconst.ccp; 1720 for(i = 0 ; i < ll ; ++i) 1721 *q++ = *s++; 1722 s = rp->b_const.fconst.ccp; 1723 for(i = 0; i < lr; ++i) 1724 *q++ = *s++; 1725 break; 1726 1727 1728 case OPPOWER: 1729 if( ! ISINT(rtype) ) 1730 return(e); 1731 conspower(&(p->b_const.fconst), lp, rp->b_const.fconst.ci); 1732 break; 1733 1734 1735 default: 1736 if(ltype == TYCHAR) 1737 { 1738 lcon.ci = cmpstr(lp->b_const.fconst.ccp, rp->b_const.fconst.ccp, 1739 lp->vleng->b_const.fconst.ci, rp->vleng->b_const.fconst.ci); 1740 rcon.ci = 0; 1741 mtype = tyint; 1742 } 1743 else { 1744 mtype = maxtype(ltype, rtype); 1745 consconv(mtype, &lcon, ltype, &(lp->b_const.fconst) ); 1746 consconv(mtype, &rcon, rtype, &(rp->b_const.fconst) ); 1747 } 1748 consbinop(opcode, mtype, &(p->b_const.fconst), &lcon, &rcon); 1749 break; 1750 } 1751 1752 frexpr(e); 1753 return(p); 1754 } 1755 1756 1757 1758 /* assign constant l = r , doing coercion */ 1759 void 1760 consconv(lt, lv, rt, rv) 1761 int lt, rt; 1762 register union constant *lv, *rv; 1763 { 1764 switch(lt) 1765 { 1766 case TYSHORT: 1767 case TYLONG: 1768 if( ISINT(rt) ) 1769 lv->ci = rv->ci; 1770 else lv->ci = rv->cd[0]; 1771 break; 1772 1773 case TYCOMPLEX: 1774 case TYDCOMPLEX: 1775 switch(rt) 1776 { 1777 case TYSHORT: 1778 case TYLONG: 1779 /* fall through and do real assignment of 1780 first element 1781 */ 1782 case TYREAL: 1783 case TYDREAL: 1784 lv->cd[1] = 0; break; 1785 case TYCOMPLEX: 1786 case TYDCOMPLEX: 1787 lv->cd[1] = rv->cd[1]; break; 1788 } 1789 1790 case TYREAL: 1791 case TYDREAL: 1792 if( ISINT(rt) ) 1793 lv->cd[0] = rv->ci; 1794 else lv->cd[0] = rv->cd[0]; 1795 break; 1796 1797 case TYLOGICAL: 1798 lv->ci = rv->ci; 1799 break; 1800 } 1801 } 1802 1803 1804 void 1805 consnegop(p) 1806 register struct bigblock *p; 1807 { 1808 switch(p->vtype) 1809 { 1810 case TYSHORT: 1811 case TYLONG: 1812 p->b_const.fconst.ci = - p->b_const.fconst.ci; 1813 break; 1814 1815 case TYCOMPLEX: 1816 case TYDCOMPLEX: 1817 p->b_const.fconst.cd[1] = - p->b_const.fconst.cd[1]; 1818 /* fall through and do the real parts */ 1819 case TYREAL: 1820 case TYDREAL: 1821 p->b_const.fconst.cd[0] = - p->b_const.fconst.cd[0]; 1822 break; 1823 default: 1824 fatal1("consnegop: impossible type %d", p->vtype); 1825 } 1826 } 1827 1828 1829 1830 LOCAL void 1831 conspower(powp, ap, n) 1832 register union constant *powp; 1833 struct bigblock *ap; 1834 ftnint n; 1835 { 1836 register int type; 1837 union constant x; 1838 1839 switch(type = ap->vtype) /* pow = 1 */ 1840 { 1841 case TYSHORT: 1842 case TYLONG: 1843 powp->ci = 1; 1844 break; 1845 case TYCOMPLEX: 1846 case TYDCOMPLEX: 1847 powp->cd[1] = 0; 1848 case TYREAL: 1849 case TYDREAL: 1850 powp->cd[0] = 1; 1851 break; 1852 default: 1853 fatal1("conspower: invalid type %d", type); 1854 } 1855 1856 if(n == 0) 1857 return; 1858 if(n < 0) 1859 { 1860 if( ISINT(type) ) 1861 { 1862 err("integer ** negative power "); 1863 return; 1864 } 1865 n = - n; 1866 consbinop(OPSLASH, type, &x, powp, &(ap->b_const.fconst)); 1867 } 1868 else 1869 consbinop(OPSTAR, type, &x, powp, &(ap->b_const.fconst)); 1870 1871 for( ; ; ) 1872 { 1873 if(n & 01) 1874 consbinop(OPSTAR, type, powp, powp, &x); 1875 if(n >>= 1) 1876 consbinop(OPSTAR, type, &x, &x, &x); 1877 else 1878 break; 1879 } 1880 } 1881 1882 1883 1884 /* do constant operation cp = a op b */ 1885 1886 1887 LOCAL void 1888 consbinop(opcode, type, cp, ap, bp) 1889 int opcode, type; 1890 register union constant *ap, *bp, *cp; 1891 { 1892 int k; 1893 double temp; 1894 1895 switch(opcode) 1896 { 1897 case OPPLUS: 1898 switch(type) 1899 { 1900 case TYSHORT: 1901 case TYLONG: 1902 cp->ci = ap->ci + bp->ci; 1903 break; 1904 case TYCOMPLEX: 1905 case TYDCOMPLEX: 1906 cp->cd[1] = ap->cd[1] + bp->cd[1]; 1907 case TYREAL: 1908 case TYDREAL: 1909 cp->cd[0] = ap->cd[0] + bp->cd[0]; 1910 break; 1911 } 1912 break; 1913 1914 case OPMINUS: 1915 switch(type) 1916 { 1917 case TYSHORT: 1918 case TYLONG: 1919 cp->ci = ap->ci - bp->ci; 1920 break; 1921 case TYCOMPLEX: 1922 case TYDCOMPLEX: 1923 cp->cd[1] = ap->cd[1] - bp->cd[1]; 1924 case TYREAL: 1925 case TYDREAL: 1926 cp->cd[0] = ap->cd[0] - bp->cd[0]; 1927 break; 1928 } 1929 break; 1930 1931 case OPSTAR: 1932 switch(type) 1933 { 1934 case TYSHORT: 1935 case TYLONG: 1936 cp->ci = ap->ci * bp->ci; 1937 break; 1938 case TYREAL: 1939 case TYDREAL: 1940 cp->cd[0] = ap->cd[0] * bp->cd[0]; 1941 break; 1942 case TYCOMPLEX: 1943 case TYDCOMPLEX: 1944 temp = ap->cd[0] * bp->cd[0] - 1945 ap->cd[1] * bp->cd[1] ; 1946 cp->cd[1] = ap->cd[0] * bp->cd[1] + 1947 ap->cd[1] * bp->cd[0] ; 1948 cp->cd[0] = temp; 1949 break; 1950 } 1951 break; 1952 case OPSLASH: 1953 switch(type) 1954 { 1955 case TYSHORT: 1956 case TYLONG: 1957 cp->ci = ap->ci / bp->ci; 1958 break; 1959 case TYREAL: 1960 case TYDREAL: 1961 cp->cd[0] = ap->cd[0] / bp->cd[0]; 1962 break; 1963 case TYCOMPLEX: 1964 case TYDCOMPLEX: 1965 zdiv(&cp->dc, &ap->dc, &bp->dc); 1966 break; 1967 } 1968 break; 1969 1970 case OPMOD: 1971 if( ISINT(type) ) 1972 { 1973 cp->ci = ap->ci % bp->ci; 1974 break; 1975 } 1976 else 1977 fatal("inline mod of noninteger"); 1978 1979 default: /* relational ops */ 1980 switch(type) 1981 { 1982 case TYSHORT: 1983 case TYLONG: 1984 if(ap->ci < bp->ci) 1985 k = -1; 1986 else if(ap->ci == bp->ci) 1987 k = 0; 1988 else k = 1; 1989 break; 1990 case TYREAL: 1991 case TYDREAL: 1992 if(ap->cd[0] < bp->cd[0]) 1993 k = -1; 1994 else if(ap->cd[0] == bp->cd[0]) 1995 k = 0; 1996 else k = 1; 1997 break; 1998 case TYCOMPLEX: 1999 case TYDCOMPLEX: 2000 if(ap->cd[0] == bp->cd[0] && 2001 ap->cd[1] == bp->cd[1] ) 2002 k = 0; 2003 else k = 1; 2004 break; 2005 default: /* XXX gcc */ 2006 k = 0; 2007 break; 2008 } 2009 2010 switch(opcode) 2011 { 2012 case OPEQ: 2013 cp->ci = (k == 0); 2014 break; 2015 case OPNE: 2016 cp->ci = (k != 0); 2017 break; 2018 case OPGT: 2019 cp->ci = (k == 1); 2020 break; 2021 case OPLT: 2022 cp->ci = (k == -1); 2023 break; 2024 case OPGE: 2025 cp->ci = (k >= 0); 2026 break; 2027 case OPLE: 2028 cp->ci = (k <= 0); 2029 break; 2030 } 2031 break; 2032 } 2033 } 2034 2035 2036 2037 int 2038 conssgn(p) 2039 register bigptr p; 2040 { 2041 if( ! ISCONST(p) ) 2042 fatal( "sgn(nonconstant)" ); 2043 2044 switch(p->vtype) 2045 { 2046 case TYSHORT: 2047 case TYLONG: 2048 if(p->b_const.fconst.ci > 0) return(1); 2049 if(p->b_const.fconst.ci < 0) return(-1); 2050 return(0); 2051 2052 case TYREAL: 2053 case TYDREAL: 2054 if(p->b_const.fconst.cd[0] > 0) return(1); 2055 if(p->b_const.fconst.cd[0] < 0) return(-1); 2056 return(0); 2057 2058 case TYCOMPLEX: 2059 case TYDCOMPLEX: 2060 return(p->b_const.fconst.cd[0]!=0 || p->b_const.fconst.cd[1]!=0); 2061 2062 default: 2063 fatal1( "conssgn(type %d)", p->vtype); 2064 } 2065 /* NOTREACHED */ 2066 return 0; /* XXX gcc */ 2067 } 2068 2069 char *powint[ ] = { "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" }; 2070 2071 2072 LOCAL bigptr mkpower(p) 2073 register struct bigblock *p; 2074 { 2075 register bigptr q, lp, rp; 2076 int ltype, rtype, mtype; 2077 2078 lp = p->b_expr.leftp; 2079 rp = p->b_expr.rightp; 2080 ltype = lp->vtype; 2081 rtype = rp->vtype; 2082 2083 if(ISICON(rp)) 2084 { 2085 if(rp->b_const.fconst.ci == 0) 2086 { 2087 frexpr(p); 2088 if( ISINT(ltype) ) 2089 return( MKICON(1) ); 2090 else 2091 return( putconst( mkconv(ltype, MKICON(1))) ); 2092 } 2093 if(rp->b_const.fconst.ci < 0) 2094 { 2095 if( ISINT(ltype) ) 2096 { 2097 frexpr(p); 2098 err("integer**negative"); 2099 return( errnode() ); 2100 } 2101 rp->b_const.fconst.ci = - rp->b_const.fconst.ci; 2102 p->b_expr.leftp = lp = fixexpr(mkexpr(OPSLASH, MKICON(1), lp)); 2103 } 2104 if(rp->b_const.fconst.ci == 1) 2105 { 2106 frexpr(rp); 2107 ckfree(p); 2108 return(lp); 2109 } 2110 2111 if( ONEOF(ltype, MSKINT|MSKREAL) ) 2112 { 2113 p->vtype = ltype; 2114 return(p); 2115 } 2116 } 2117 if( ISINT(rtype) ) 2118 { 2119 if(ltype==TYSHORT && rtype==TYSHORT) 2120 q = call2(TYSHORT, "pow_hh", lp, rp); 2121 else { 2122 if(ltype == TYSHORT) 2123 { 2124 ltype = TYLONG; 2125 lp = mkconv(TYLONG,lp); 2126 } 2127 q = call2(ltype, powint[ltype-TYLONG], lp, mkconv(TYLONG, rp)); 2128 } 2129 } 2130 else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) 2131 q = call2(mtype, "pow_dd", 2132 mkconv(TYDREAL,lp), mkconv(TYDREAL,rp)); 2133 else { 2134 q = call2(TYDCOMPLEX, "pow_zz", 2135 mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp)); 2136 if(mtype == TYCOMPLEX) 2137 q = mkconv(TYCOMPLEX, q); 2138 } 2139 ckfree(p); 2140 return(q); 2141 } 2142 2143 2144 2145 /* Complex Division. Same code as in Runtime Library 2146 */ 2147 2148 2149 2150 LOCAL void 2151 zdiv(c, a, b) 2152 register struct dcomplex *a, *b, *c; 2153 { 2154 double ratio, den; 2155 double abr, abi; 2156 2157 if( (abr = b->dreal) < 0.) 2158 abr = - abr; 2159 if( (abi = b->dimag) < 0.) 2160 abi = - abi; 2161 if( abr <= abi ) 2162 { 2163 if(abi == 0) 2164 fatal("complex division by zero"); 2165 ratio = b->dreal / b->dimag ; 2166 den = b->dimag * (1 + ratio*ratio); 2167 c->dreal = (a->dreal*ratio + a->dimag) / den; 2168 c->dimag = (a->dimag*ratio - a->dreal) / den; 2169 } 2170 2171 else 2172 { 2173 ratio = b->dimag / b->dreal ; 2174 den = b->dreal * (1 + ratio*ratio); 2175 c->dreal = (a->dreal + a->dimag*ratio) / den; 2176 c->dimag = (a->dimag - a->dreal*ratio) / den; 2177 } 2178 2179 } 2180