4.3BSD - /usr/src/usr.bin/f77/src/f77pass1/expr.c

   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.8 (Berkeley) 5/9/86";
   9: #endif not lint
  10: 
  11: /*
  12:  * expr.c
  13:  *
  14:  * Routines for handling expressions, f77 compiler pass 1.
  15:  *
  16:  * University of Utah CS Dept modification history:
  17:  *
  18:  * $Log:	expr.c,v $
  19:  * Revision 5.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->const.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->const.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->const.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->const.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->const.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->const.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->const.cd[0] = realp->constblock.const.ci;
 335:     else    p->const.cd[0] = realp->constblock.const.cd[0];
 336:     if( ISINT(itype) )
 337:         p->const.cd[1] = imagp->constblock.const.ci;
 338:     else    p->const.cd[1] = imagp->constblock.const.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.const),
 411:         p->constblock.vtype, &(p->constblock.const) );
 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.const),
 451:         p->constblock.vtype, &(p->constblock.const) );
 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.const.ccp =
 527:                 copyn(1+strlen(e->constblock.const.ccp),
 528:                     e->constblock.const.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.const.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.const.ci < 0)
1566:         goto badsub;
1567:     if( ISICON(dimp->nelt) )
1568:         if(p->constblock.const.ci < dimp->nelt->constblock.const.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.const.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.const.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.const.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.const.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.const.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.const.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.const.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.const.ci == 1)
1992:                 goto retleft;
1993: 
1994:             if(rp->constblock.const.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.const.ci %
2007:                     rp->constblock.const.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.const.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.const.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.const.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.const.ci = ! lp->constblock.const.ci;
2403:             return(lp);
2404: 
2405:         case OPBITNOT:
2406:             lp->constblock.const.ci = ~ lp->constblock.const.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->const.ci = lp->constblock.const.ci &&
2438:                 rp->constblock.const.ci;
2439:         break;
2440: 
2441:     case OPOR:
2442:         p->const.ci = lp->constblock.const.ci ||
2443:                 rp->constblock.const.ci;
2444:         break;
2445: 
2446:     case OPEQV:
2447:         p->const.ci = lp->constblock.const.ci ==
2448:                 rp->constblock.const.ci;
2449:         break;
2450: 
2451:     case OPNEQV:
2452:         p->const.ci = lp->constblock.const.ci !=
2453:                 rp->constblock.const.ci;
2454:         break;
2455: 
2456:     case OPBITAND:
2457:         p->const.ci = lp->constblock.const.ci &
2458:                 rp->constblock.const.ci;
2459:         break;
2460: 
2461:     case OPBITOR:
2462:         p->const.ci = lp->constblock.const.ci |
2463:                 rp->constblock.const.ci;
2464:         break;
2465: 
2466:     case OPBITXOR:
2467:         p->const.ci = lp->constblock.const.ci ^
2468:                 rp->constblock.const.ci;
2469:         break;
2470: 
2471:     case OPLSHIFT:
2472:         p->const.ci = lp->constblock.const.ci <<
2473:                 rp->constblock.const.ci;
2474:         break;
2475: 
2476:     case OPRSHIFT:
2477:         p->const.ci = lp->constblock.const.ci >>
2478:                 rp->constblock.const.ci;
2479:         break;
2480: 
2481:     case OPCONCAT:
2482:         ll = lp->constblock.vleng->constblock.const.ci;
2483:         lr = rp->constblock.vleng->constblock.const.ci;
2484:         p->const.ccp = q = (char *) ckalloc(ll+lr);
2485:         p->vleng = ICON(ll+lr);
2486:         s = lp->constblock.const.ccp;
2487:         for(i = 0 ; i < ll ; ++i)
2488:             *q++ = *s++;
2489:         s = rp->constblock.const.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->const), lp, rp->constblock.const.ci);
2499:         break;
2500: 
2501: 
2502:     default:
2503:         if(ltype == TYCHAR)
2504:             {
2505:             lcon.ci = cmpstr(lp->constblock.const.ccp,
2506:                     rp->constblock.const.ccp,
2507:                     lp->constblock.vleng->constblock.const.ci,
2508:                     rp->constblock.vleng->constblock.const.ci);
2509:             rcon.ci = 0;
2510:             mtype = tyint;
2511:             }
2512:         else    {
2513:             mtype = maxtype(ltype, rtype);
2514:             consconv(mtype, &lcon, ltype, &(lp->constblock.const) );
2515:             consconv(mtype, &rcon, rtype, &(rp->constblock.const) );
2516:             }
2517:         consbinop(opcode, mtype, &(p->const), &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->const.ci = - p->const.ci;
2595:         break;
2596: 
2597:     case TYCOMPLEX:
2598:     case TYDCOMPLEX:
2599:         p->const.cd[1] = - p->const.cd[1];
2600:         /* fall through and do the real parts */
2601:     case TYREAL:
2602:     case TYDREAL:
2603:         p->const.cd[0] = - p->const.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->const.ci == 0)
2644:             err("zero raised to a negative power");
2645:         else if (ap->const.ci == 1)
2646:             return;
2647:         else if (ap->const.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->const));
2661:     }
2662: else
2663:     consbinop(OPSTAR, type, &x, powp, &(ap->const));
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.const.ci > 0) return(1);
2848:         if(p->constblock.const.ci < 0) return(-1);
2849:         return(0);
2850: 
2851:     case TYREAL:
2852:     case TYDREAL:
2853:         if(p->constblock.const.cd[0] > 0) return(1);
2854:         if(p->constblock.const.cd[0] < 0) return(-1);
2855:         return(0);
2856: 
2857:     case TYCOMPLEX:
2858:     case TYDCOMPLEX:
2859:         return(p->constblock.const.cd[0]!=0 || p->constblock.const.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.const.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.const.ci < 0)
2898:         {
2899:         if( ISINT(ltype) )
2900:             {
2901:             frexpr(p);
2902:             err("integer**negative");
2903:             return( errnode() );
2904:             }
2905:         rp->constblock.const.ci = - rp->constblock.const.ci;
2906:         p->exprblock.leftp = lp = fixexpr(mkexpr(OPSLASH, ICON(1), lp));
2907:         }
2908:     if(rp->constblock.const.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.const.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: }