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