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