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