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