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