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