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