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