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