2.9BSD - /usr/src/cmd/f77/expr.c

   1: #include "defs"
   2: #include "string_defs"
   3: 
   4: /* little routines to create constant blocks */
   5: 
   6: struct constblock *mkconst(t)
   7: register int t;
   8: {
   9: register struct constblock *p;
  10: 
  11: p = ALLOC(constblock);
  12: p->tag = TCONST;
  13: p->vtype = t;
  14: return(p);
  15: }
  16: 
  17: 
  18: struct constblock *mklogcon(l)
  19: register int l;
  20: {
  21: register struct constblock * p;
  22: 
  23: p = mkconst(TYLOGICAL);
  24: p->const.ci = l;
  25: return(p);
  26: }
  27: 
  28: 
  29: 
  30: struct constblock *mkintcon(l)
  31: ftnint l;
  32: {
  33: register struct constblock *p;
  34: 
  35: p = mkconst(TYLONG);
  36: p->const.ci = l;
  37: #ifdef MAXSHORT
  38:     if(l >= -MAXSHORT   &&   l <= MAXSHORT)
  39:         p->vtype = TYSHORT;
  40: #endif
  41: return(p);
  42: }
  43: 
  44: 
  45: 
  46: struct constblock *mkaddcon(l)
  47: register int l;
  48: {
  49: register struct constblock *p;
  50: 
  51: p = mkconst(TYADDR);
  52: p->const.ci = l;
  53: return(p);
  54: }
  55: 
  56: 
  57: 
  58: struct constblock *mkrealcon(t, d)
  59: register int t;
  60: double d;
  61: {
  62: register struct constblock *p;
  63: 
  64: p = mkconst(t);
  65: p->const.cd[0] = d;
  66: return(p);
  67: }
  68: 
  69: 
  70: struct constblock *mkbitcon(shift, leng, s)
  71: int shift;
  72: int leng;
  73: char *s;
  74: {
  75: register struct constblock *p;
  76: 
  77: p = mkconst(TYUNKNOWN);
  78: p->const.ci = 0;
  79: while(--leng >= 0)
  80:     if(*s != ' ')
  81:         p->const.ci = (p->const.ci << shift) | hextoi(*s++);
  82: return(p);
  83: }
  84: 
  85: 
  86: 
  87: 
  88: 
  89: struct constblock *mkstrcon(l,v)
  90: int l;
  91: register char *v;
  92: {
  93: register struct constblock *p;
  94: register char *s;
  95: 
  96: p = mkconst(TYCHAR);
  97: p->vleng = ICON(l);
  98: p->const.ccp = s = (char *) ckalloc(l);
  99: while(--l >= 0)
 100:     *s++ = *v++;
 101: return(p);
 102: }
 103: 
 104: 
 105: struct constblock *mkcxcon(realp,imagp)
 106: register expptr realp, imagp;
 107: {
 108: int rtype, itype;
 109: register struct constblock *p;
 110: 
 111: rtype = realp->vtype;
 112: itype = imagp->vtype;
 113: 
 114: if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
 115:     {
 116:     p = mkconst( (rtype==TYDREAL||itype==TYDREAL) ? TYDCOMPLEX : TYCOMPLEX );
 117:     if( ISINT(rtype) )
 118:         p->const.cd[0] = realp->const.ci;
 119:     else    p->const.cd[0] = realp->const.cd[0];
 120:     if( ISINT(itype) )
 121:         p->const.cd[1] = imagp->const.ci;
 122:     else    p->const.cd[1] = imagp->const.cd[0];
 123:     }
 124: else
 125:     {
 126:     error("invalid complex constant",0,0,ERR);
 127:     p = errnode();
 128:     }
 129: 
 130: frexpr(realp);
 131: frexpr(imagp);
 132: return(p);
 133: }
 134: 
 135: 
 136: struct errorblock *errnode()
 137: {
 138: struct errorblock *p;
 139: p = ALLOC(errorblock);
 140: p->tag = TERROR;
 141: p->vtype = TYERROR;
 142: return(p);
 143: }
 144: 
 145: 
 146: 
 147: 
 148: 
 149: expptr mkconv(t, p)
 150: register int t;
 151: register expptr p;
 152: {
 153: register expptr q;
 154: register int pt;
 155: expptr opconv();
 156: 
 157: if(t==TYUNKNOWN || t==TYERROR)
 158:     error("mkconv of impossible type %d", t,0,FATAL1);
 159: pt = p->vtype;
 160: if(t == pt)
 161:     return(p);
 162: 
 163: else if( ISCONST(p) && pt!=TYADDR)
 164:     {
 165:     q = mkconst(t);
 166:     consconv(t, &(q->const), p->vtype, &(p->const));
 167:     frexpr(p);
 168:     }
 169: #if TARGET == PDP11
 170:     else if(ISINT(t) && pt==TYCHAR)
 171:         {
 172:         q = mkexpr(OPBITAND, opconv(p,TYSHORT), ICON(255));
 173:         if(t == TYLONG)
 174:             q = opconv(q, TYLONG);
 175:         }
 176: #endif
 177: else
 178:     q = opconv(p, t);
 179: 
 180: if(t == TYCHAR)
 181:     q->vleng = ICON(1);
 182: return(q);
 183: }
 184: 
 185: 
 186: 
 187: expptr opconv(p, t)
 188: expptr p;
 189: int t;
 190: {
 191: register expptr q;
 192: 
 193: q = mkexpr(OPCONV, p, 0);
 194: q->vtype = t;
 195: return(q);
 196: }
 197: 
 198: 
 199: 
 200: struct exprblock *addrof(p)
 201: expptr p;
 202: {
 203: return( mkexpr(OPADDR, p, NULL) );
 204: }
 205: 
 206: 
 207: 
 208: tagptr cpexpr(p)
 209: register tagptr p;
 210: {
 211: register tagptr e;
 212: int tag;
 213: register chainp ep, pp;
 214: ptr cpblock();
 215: 
 216: static int blksize[ ] =
 217:     {   0,
 218:         sizeof(struct nameblock),
 219:         sizeof(struct constblock),
 220:         sizeof(struct exprblock),
 221:         sizeof(struct addrblock),
 222:         sizeof(struct primblock),
 223:         sizeof(struct listblock),
 224:         sizeof(struct errorblock)
 225:     };
 226: 
 227: if(p == NULL)
 228:     return(NULL);
 229: 
 230: if( (tag = p->tag) == TNAME)
 231:     return(p);
 232: 
 233: e = cpblock( blksize[p->tag] , p);
 234: 
 235: switch(tag)
 236:     {
 237:     case TCONST:
 238:         if(e->vtype == TYCHAR)
 239:             {
 240:             e->const.ccp = copyn(1+strlen(e->const.ccp), e->const.ccp);
 241:             e->vleng = cpexpr(e->vleng);
 242:             }
 243:     case TERROR:
 244:         break;
 245: 
 246:     case TEXPR:
 247:         e->leftp = cpexpr(p->leftp);
 248:         e->rightp = cpexpr(p->rightp);
 249:         break;
 250: 
 251:     case TLIST:
 252:         if(pp = p->listp)
 253:             {
 254:             ep = e->listp = mkchain( cpexpr(pp->datap), NULL);
 255:             for(pp = pp->nextp ; pp ; pp = pp->nextp)
 256:                 ep = ep->nextp = mkchain( cpexpr(pp->datap), NULL);
 257:             }
 258:         break;
 259: 
 260:     case TADDR:
 261:         e->vleng = cpexpr(e->vleng);
 262:         e->memoffset = cpexpr(e->memoffset);
 263:         e->istemp = NO;
 264:         break;
 265: 
 266:     case TPRIM:
 267:         e->argsp = cpexpr(e->argsp);
 268:         e->fcharp = cpexpr(e->fcharp);
 269:         e->lcharp = cpexpr(e->lcharp);
 270:         break;
 271: 
 272:     default:
 273:         error("cpexpr: impossible tag %d", tag,0,FATAL1);
 274:     }
 275: 
 276: return(e);
 277: }
 278: 
 279: frexpr(p)
 280: register tagptr p;
 281: {
 282: register chainp q;
 283: 
 284: if(p == NULL)
 285:     return;
 286: 
 287: switch(p->tag)
 288:     {
 289:     case TCONST:
 290:         if( ISCHAR(p) )
 291:             {
 292:             free(p->const.ccp);
 293:             frexpr(p->vleng);
 294:             }
 295:         break;
 296: 
 297:     case TADDR:
 298:         if(p->istemp)
 299:             {
 300:             frtemp(p);
 301:             return;
 302:             }
 303:         frexpr(p->vleng);
 304:         frexpr(p->memoffset);
 305:         break;
 306: 
 307:     case TERROR:
 308:         break;
 309: 
 310:     case TNAME:
 311:         return;
 312: 
 313:     case TPRIM:
 314:         frexpr(p->argsp);
 315:         frexpr(p->fcharp);
 316:         frexpr(p->lcharp);
 317:         break;
 318: 
 319:     case TEXPR:
 320:         frexpr(p->leftp);
 321:         if(p->rightp)
 322:             frexpr(p->rightp);
 323:         break;
 324: 
 325:     case TLIST:
 326:         for(q = p->listp ; q ; q = q->nextp)
 327:             frexpr(q->datap);
 328:         frchain( &(p->listp) );
 329:         break;
 330: 
 331:     default:
 332:         error("frexpr: impossible tag %d", p->tag,0,FATAL1);
 333:     }
 334: 
 335: free(p);
 336: }
 337: 
 338: /* fix up types in expression; replace subtrees and convert
 339:    names to address blocks */
 340: 
 341: expptr fixtype(p)
 342: register tagptr p;
 343: {
 344: 
 345: if(p == 0)
 346:     return(0);
 347: 
 348: switch(p->tag)
 349:     {
 350:     case TCONST:
 351:         if( ! ONEOF(p->vtype, MSKINT|MSKLOGICAL|MSKADDR) )
 352:             p = putconst(p);
 353:         return(p);
 354: 
 355:     case TADDR:
 356:         p->memoffset = fixtype(p->memoffset);
 357:         return(p);
 358: 
 359:     case TERROR:
 360:         return(p);
 361: 
 362:     default:
 363:         error("fixtype: impossible tag %d", p->tag,0,FATAL1);
 364: 
 365:     case TEXPR:
 366:         return( fixexpr(p) );
 367: 
 368:     case TLIST:
 369:         return( p );
 370: 
 371:     case TPRIM:
 372:         if(p->argsp && p->namep->vclass!=CLVAR)
 373:             return( mkfunct(p) );
 374:         else    return( mklhs(p) );
 375:     }
 376: }
 377: 
 378: 
 379: 
 380: 
 381: 
 382: /* special case tree transformations and cleanups of expression trees */
 383: 
 384: expptr fixexpr(p)
 385: register struct exprblock *p;
 386: {
 387: expptr lp;
 388: register expptr rp;
 389: register expptr q;
 390: int opcode, ltype, rtype, ptype, mtype;
 391: expptr mkpower();
 392: 
 393: if(p->tag == TERROR)
 394:     return(p);
 395: else if(p->tag != TEXPR)
 396:     error("fixexpr: invalid tag %d", p->tag,0,FATAL1);
 397: opcode = p->opcode;
 398: lp = p->leftp = fixtype(p->leftp);
 399: ltype = lp->vtype;
 400: if(opcode==OPASSIGN && lp->tag!=TADDR)
 401:     {
 402:     error("left side of assignment must be variable",0,0,ERR);
 403:     frexpr(p);
 404:     return( errnode() );
 405:     }
 406: 
 407: if(p->rightp)
 408:     {
 409:     rp = p->rightp = fixtype(p->rightp);
 410:     rtype = rp->vtype;
 411:     }
 412: else
 413:     {
 414:     rp = NULL;
 415:     rtype = 0;
 416:     }
 417: 
 418: /* force folding if possible */
 419: if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
 420:     {
 421:     q = mkexpr(opcode, lp, rp);
 422:     if( ISCONST(q) )
 423:         return(q);
 424:     free(q);    /* constants did not fold */
 425:     }
 426: 
 427: if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
 428:     {
 429:     frexpr(p);
 430:     return( errnode() );
 431:     }
 432: 
 433: switch(opcode)
 434:     {
 435:     case OPCONCAT:
 436:         if(p->vleng == NULL)
 437:             p->vleng = mkexpr(OPPLUS, cpexpr(lp->vleng),
 438:                 cpexpr(rp->vleng) );
 439:         break;
 440: 
 441:     case OPASSIGN:
 442:     case OPPLUSEQ:
 443:     case OPSTAREQ:
 444:         if(ltype == rtype)
 445:             break;
 446:         if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
 447:             break;
 448:         if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
 449:             break;
 450:         if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
 451: #if FAMILY==SCJ
 452:             && typesize[ltype]>=typesize[rtype] )
 453: #else
 454:             && typesize[ltype]==typesize[rtype] )
 455: #endif
 456:             break;
 457:         p->rightp = fixtype( mkconv(ptype, rp) );
 458:         break;
 459: 
 460:     case OPSLASH:
 461:         if( ISCOMPLEX(rtype) )
 462:             {
 463:             p = call2(ptype, ptype==TYCOMPLEX? "c_div" : "z_div",
 464:                 mkconv(ptype, lp), mkconv(ptype, rp) );
 465:             break;
 466:             }
 467:     case OPPLUS:
 468:     case OPMINUS:
 469:     case OPSTAR:
 470:     case OPMOD:
 471:         if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
 472:             (rtype==TYREAL && ! ISCONST(rp) ) ))
 473:             break;
 474:         if( ISCOMPLEX(ptype) )
 475:             break;
 476:         if(ltype != ptype)
 477:             p->leftp = fixtype(mkconv(ptype,lp));
 478:         if(rtype != ptype)
 479:             p->rightp = fixtype(mkconv(ptype,rp));
 480:         break;
 481: 
 482:     case OPPOWER:
 483:         return( mkpower(p) );
 484: 
 485:     case OPLT:
 486:     case OPLE:
 487:     case OPGT:
 488:     case OPGE:
 489:     case OPEQ:
 490:     case OPNE:
 491:         if(ltype == rtype)
 492:             break;
 493:         mtype = cktype(OPMINUS, ltype, rtype);
 494:         if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) ||
 495:             (rtype==TYREAL && ! ISCONST(rp)) ))
 496:             break;
 497:         if( ISCOMPLEX(mtype) )
 498:             break;
 499:         if(ltype != mtype)
 500:             p->leftp = fixtype(mkconv(mtype,lp));
 501:         if(rtype != mtype)
 502:             p->rightp = fixtype(mkconv(mtype,rp));
 503:         break;
 504: 
 505: 
 506:     case OPCONV:
 507:         ptype = cktype(OPCONV, p->vtype, ltype);
 508:         if(lp->tag==TEXPR && lp->opcode==OPCOMMA)
 509:             {
 510:             lp->rightp = fixtype( mkconv(ptype, lp->rightp) );
 511:             free(p);
 512:             p = lp;
 513:             }
 514:         break;
 515: 
 516:     case OPADDR:
 517:         if(lp->tag==TEXPR && lp->opcode==OPADDR)
 518:             error("addr of addr",0,0,FATAL);
 519:         break;
 520: 
 521:     case OPCOMMA:
 522:     case OPQUEST:
 523:     case OPCOLON:
 524:         break;
 525: 
 526:     case OPMIN:
 527:     case OPMAX:
 528:         ptype = p->vtype;
 529:         break;
 530: 
 531:     default:
 532:         break;
 533:     }
 534: 
 535: p->vtype = ptype;
 536: return(p);
 537: }
 538: 
 539: #if SZINT < SZLONG
 540: /*
 541:    for efficient subscripting, replace long ints by shorts
 542:    in easy places
 543: */
 544: 
 545: expptr shorten(p)
 546: register expptr p;
 547: {
 548: register expptr q;
 549: 
 550: if(p->vtype != TYLONG)
 551:     return(p);
 552: 
 553: switch(p->tag)
 554:     {
 555:     case TERROR:
 556:     case TLIST:
 557:         return(p);
 558: 
 559:     case TCONST:
 560:     case TADDR:
 561:         return( mkconv(TYINT,p) );
 562: 
 563:     case TEXPR:
 564:         break;
 565: 
 566:     default:
 567:         error("shorten: invalid tag %d", p->tag,0,FATAL1);
 568:     }
 569: 
 570: switch(p->opcode)
 571:     {
 572:     case OPPLUS:
 573:     case OPMINUS:
 574:     case OPSTAR:
 575:         q = shorten( cpexpr(p->rightp) );
 576:         if(q->vtype == TYINT)
 577:             {
 578:             p->leftp = shorten(p->leftp);
 579:             if(p->leftp->vtype == TYLONG)
 580:                 frexpr(q);
 581:             else
 582:                 {
 583:                 frexpr(p->rightp);
 584:                 p->rightp = q;
 585:                 p->vtype = TYINT;
 586:                 }
 587:             }
 588:         break;
 589: 
 590:     case OPNEG:
 591:         p->leftp = shorten(p->leftp);
 592:         if(p->leftp->vtype == TYINT)
 593:             p->vtype = TYINT;
 594:         break;
 595: 
 596:     case OPCALL:
 597:     case OPCCALL:
 598:         p = mkconv(TYINT,p);
 599:         break;
 600:     default:
 601:         break;
 602:     }
 603: 
 604: return(p);
 605: }
 606: #endif
 607: 
 608: fixargs(doput, p0)
 609: int doput;
 610: struct listblock *p0;
 611: {
 612: register chainp p;
 613: register tagptr q, t;
 614: register int qtag;
 615: int nargs;
 616: struct addrblock *mkaddr();
 617: 
 618: nargs = 0;
 619: if(p0)
 620:     for(p = p0->listp ; p ; p = p->nextp)
 621:     {
 622:     ++nargs;
 623:     q = p->datap;
 624:     qtag = q->tag;
 625:     if(qtag == TCONST)
 626:         {
 627:         if(q->vtype == TYSHORT)
 628:             q = mkconv(tyint, q);
 629:         if(doput)
 630:             p->datap = putconst(q);
 631:         else
 632:             p->datap = q;
 633:         }
 634:     else if(qtag==TPRIM && q->argsp==0 && q->namep->vclass==CLPROC)
 635:         p->datap = mkaddr(q->namep);
 636:     else if(qtag==TPRIM && q->argsp==0 && q->namep->vdim!=NULL)
 637:         p->datap = mkscalar(q->namep);
 638:     else if(qtag==TPRIM && q->argsp==0 && q->namep->vdovar &&
 639:         (t = memversion(q->namep)) )
 640:             p->datap = fixtype(t);
 641:     else    p->datap = fixtype(q);
 642:     }
 643: return(nargs);
 644: }
 645: 
 646: 
 647: mkscalar(np)
 648: register struct nameblock *np;
 649: {
 650: register struct addrblock *ap;
 651: register struct dimblock *dp;
 652: 
 653: vardcl(np);
 654: ap = mkaddr(np);
 655: 
 656: #if TARGET == VAX
 657:     /* on the VAX, prolog causes array arguments
 658: 	   to point at the (0,...,0) element, except when
 659: 	   subscript checking is on
 660: 	*/
 661:     if( !checksubs && np->vstg==STGARG)
 662:         {
 663:         dp = np->vdim;
 664:         frexpr(ap->memoffset);
 665:         ap->memoffset = mkexpr(OPSTAR, ICON(typesize[np->vtype]),
 666:                     cpexpr(dp->baseoffset) );
 667:         }
 668: #endif
 669: return(ap);
 670: }
 671: 
 672: 
 673: 
 674: 
 675: 
 676: expptr mkfunct(p)
 677: register struct primblock * p;
 678: {
 679: struct entrypoint *ep;
 680: struct addrblock *ap;
 681: struct extsym *mkext(), *extp;
 682: register struct nameblock *np;
 683: register struct exprblock *q;
 684: struct exprblock *intrcall(), *stfcall();
 685: int k, nargs;
 686: int class;
 687: 
 688: np = p->namep;
 689: class = np->vclass;
 690: 
 691: if(class == CLUNKNOWN)
 692:     {
 693:     np->vclass = class = CLPROC;
 694:     if(np->vstg == STGUNKNOWN)
 695:         {
 696:         if(k = intrfunct(np->varname))
 697:             {
 698:             np->vstg = STGINTR;
 699:             np->vardesc.varno = k;
 700:             np->vprocclass = PINTRINSIC;
 701:             }
 702:         else
 703:             {
 704:             extp = mkext( varunder(VL,np->varname) );
 705:             extp->extstg = STGEXT;
 706:             np->vstg = STGEXT;
 707:             np->vardesc.varno = extp - extsymtab;
 708:             np->vprocclass = PEXTERNAL;
 709:             }
 710:         }
 711:     else if(np->vstg==STGARG)
 712:         {
 713:         if(np->vtype!=TYCHAR && !ftn66flag)
 714:             error("Dummy procedure not declared EXTERNAL. Code may be wrong.",0,0,WARN);
 715:         np->vprocclass = PEXTERNAL;
 716:         }
 717:     }
 718: 
 719: if(class != CLPROC)
 720:     error("invalid class code for function", class,0,FATAL1);
 721: if(p->fcharp || p->lcharp)
 722:     {
 723:     error("no substring of function call",0,0,ERR);
 724:     goto err;
 725:     }
 726: impldcl(np);
 727: nargs = fixargs( np->vprocclass!=PINTRINSIC,  p->argsp);
 728: 
 729: switch(np->vprocclass)
 730:     {
 731:     case PEXTERNAL:
 732:         ap = mkaddr(np);
 733:     call:
 734:         q = mkexpr(OPCALL, ap, p->argsp);
 735:         q->vtype = np->vtype;
 736:         if(np->vleng)
 737:             q->vleng = cpexpr(np->vleng);
 738:         break;
 739: 
 740:     case PINTRINSIC:
 741:         q = intrcall(np, p->argsp, nargs);
 742:         break;
 743: 
 744:     case PSTFUNCT:
 745:         q = stfcall(np, p->argsp);
 746:         break;
 747: 
 748:     case PTHISPROC:
 749:         error("recursive call",0,0,WARN);
 750:         for(ep = entries ; ep ; ep = ep->nextp)
 751:             if(ep->enamep == np)
 752:                 break;
 753:         if(ep == NULL)
 754:             error("mkfunct: impossible recursion",0,0,FATAL);
 755:         ap = builtin(np->vtype, varstr(XL, ep->entryname->extname) );
 756:         goto call;
 757: 
 758:     default:
 759:         error("mkfunct: impossible vprocclass %d", np->vprocclass,0,FATAL1);
 760:     }
 761: free(p);
 762: return(q);
 763: 
 764: err:
 765:     frexpr(p);
 766:     return( errnode() );
 767: }
 768: 
 769: 
 770: 
 771: LOCAL struct exprblock *stfcall(np, actlist)
 772: struct nameblock *np;
 773: struct listblock *actlist;
 774: {
 775: register chainp actuals;
 776: int nargs;
 777: chainp oactp, formals;
 778: int type;
 779: struct exprblock *q, *rhs;
 780: expptr ap;
 781: register struct rplblock *rp;
 782: struct rplblock *tlist;
 783: 
 784: if(actlist)
 785:     {
 786:     actuals = actlist->listp;
 787:     free(actlist);
 788:     }
 789: else
 790:     actuals = NULL;
 791: oactp = actuals;
 792: 
 793: nargs = 0;
 794: tlist = NULL;
 795: type = np->vtype;
 796: formals = np->vardesc.vstfdesc->datap;
 797: rhs = np->vardesc.vstfdesc->nextp;
 798: 
 799: /* copy actual arguments into temporaries */
 800: while(actuals!=NULL && formals!=NULL)
 801:     {
 802:     rp = ALLOC(rplblock);
 803:     rp->rplnp = q = formals->datap;
 804:     ap = fixtype(actuals->datap);
 805:     if(q->vtype==ap->vtype && q->vtype!=TYCHAR
 806:        && (ap->tag==TCONST || ap->tag==TADDR) )
 807:         {
 808:         rp->rplvp = ap;
 809:         rp->rplxp = NULL;
 810:         rp->rpltag = ap->tag;
 811:         }
 812:     else    {
 813:         rp->rplvp = mktemp(q->vtype, q->vleng);
 814:         rp->rplxp = fixtype( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap) );
 815:         if( (rp->rpltag = rp->rplxp->tag) == TERROR)
 816:             error("disagreement of argument types in statement function call",0,0,ERR);
 817:         }
 818:     rp->nextp = tlist;
 819:     tlist = rp;
 820:     actuals = actuals->nextp;
 821:     formals = formals->nextp;
 822:     ++nargs;
 823:     }
 824: 
 825: if(actuals!=NULL || formals!=NULL)
 826:     error("statement function definition and argument list differ",0,0,ERR);
 827: 
 828: /*
 829:    now push down names involved in formal argument list, then
 830:    evaluate rhs of statement function definition in this environment
 831: */
 832: rpllist = hookup(tlist, rpllist);
 833: q = mkconv(type, fixtype(cpexpr(rhs)) );
 834: 
 835: /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
 836: while(--nargs >= 0)
 837:     {
 838:     if(rpllist->rplxp)
 839:         q = mkexpr(OPCOMMA, rpllist->rplxp, q);
 840:     rp = rpllist->nextp;
 841:     frexpr(rpllist->rplvp);
 842:     free(rpllist);
 843:     rpllist = rp;
 844:     }
 845: 
 846: frchain( &oactp );
 847: return(q);
 848: }
 849: 
 850: 
 851: 
 852: 
 853: struct addrblock *mklhs(p)
 854: register struct primblock * p;
 855: {
 856: register struct addrblock *s;
 857: expptr suboffset();
 858: struct nameblock *np;
 859: register struct rplblock *rp;
 860: int regn;
 861: 
 862: /* first fixup name */
 863: 
 864: if(p->tag != TPRIM)
 865:     return(p);
 866: np = p->namep;
 867: 
 868: /* is name on the replace list? */
 869: 
 870: for(rp = rpllist ; rp ; rp = rp->nextp)
 871:     {
 872:     if(np == rp->rplnp)
 873:         {
 874:         if(rp->rpltag == TNAME)
 875:             {
 876:             np = p->namep = rp->rplvp;
 877:             break;
 878:             }
 879:         else    return( cpexpr(rp->rplvp) );
 880:         }
 881:     }
 882: 
 883: /* is variable a DO index in a register ? */
 884: 
 885: if(np->vdovar && ( (regn = inregister(np)) >= 0) )
 886:     if(np->vtype == TYERROR)
 887:         return( errnode() );
 888:     else
 889:         {
 890:         s = ALLOC(addrblock);
 891:         s->tag = TADDR;
 892:         s->vstg = STGREG;
 893:         s->vtype = TYIREG;
 894:         s->memno = regn;
 895:         s->memoffset = ICON(0);
 896:         return(s);
 897:         }
 898: 
 899: vardcl(np);
 900: s = mkaddr(np);
 901: s->memoffset = mkexpr(OPPLUS, s->memoffset, suboffset(p) );
 902: frexpr(p->argsp);
 903: p->argsp = NULL;
 904: 
 905: /* now do substring part */
 906: 
 907: if(p->fcharp || p->lcharp)
 908:     {
 909:     if(np->vtype != TYCHAR)
 910:         error("substring of noncharacter %s", varstr(VL,np->varname),0,ERR1);
 911:     else    {
 912:         if(p->lcharp == NULL)
 913:             p->lcharp = cpexpr(s->vleng);
 914:         if(p->fcharp)
 915:             s->vleng = mkexpr(OPMINUS, p->lcharp,
 916:                 mkexpr(OPMINUS, p->fcharp, ICON(1) ));
 917:         else    {
 918:             frexpr(s->vleng);
 919:             s->vleng = p->lcharp;
 920:             }
 921:         }
 922:     }
 923: 
 924: s->vleng = fixtype( s->vleng );
 925: s->memoffset = fixtype( s->memoffset );
 926: free(p);
 927: return(s);
 928: }
 929: 
 930: 
 931: 
 932: 
 933: 
 934: deregister(np)
 935: struct nameblock *np;
 936: {
 937: if(nregvar>0 && regnamep[nregvar-1]==np)
 938:     {
 939:     --nregvar;
 940: #if FAMILY == DMR
 941:     putnreg();
 942: #endif
 943:     }
 944: }
 945: 
 946: 
 947: 
 948: 
 949: struct addrblock *memversion(np)
 950: register struct nameblock *np;
 951: {
 952: register struct addrblock *s;
 953: 
 954: if(np->vdovar==NO || (inregister(np)<0) )
 955:     return(NULL);
 956: np->vdovar = NO;
 957: s = mklhs( mkprim(np, 0,0,0) );
 958: np->vdovar = YES;
 959: return(s);
 960: }
 961: 
 962: 
 963: 
 964: inregister(np)
 965: register struct nameblock *np;
 966: {
 967: register int i;
 968: 
 969: for(i = 0 ; i < nregvar ; ++i)
 970:     if(regnamep[i] == np)
 971:         return( regnum[i] );
 972: return(-1);
 973: }
 974: 
 975: 
 976: 
 977: 
 978: enregister(np)
 979: struct nameblock *np;
 980: {
 981: if( inregister(np) >= 0)
 982:     return(YES);
 983: if(nregvar >= maxregvar)
 984:     return(NO);
 985: vardcl(np);
 986: if( ONEOF(np->vtype, MSKIREG) )
 987:     {
 988:     regnamep[nregvar++] = np;
 989:     if(nregvar > highregvar)
 990:         highregvar = nregvar;
 991: #if FAMILY == DMR
 992:     putnreg();
 993: #endif
 994:     return(YES);
 995:     }
 996: else
 997:     return(NO);
 998: }
 999: 
1000: 
1001: 
1002: 
1003: expptr suboffset(p)
1004: register struct primblock *p;
1005: {
1006: int n;
1007: expptr size;
1008: chainp cp;
1009: expptr offp, prod;
1010: expptr subcheck();
1011: struct dimblock *dimp;
1012: expptr sub[8];
1013: register struct nameblock *np;
1014: 
1015: np = p->namep;
1016: offp = ICON(0);
1017: n = 0;
1018: if(p->argsp)
1019:     for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
1020:         {
1021:         sub[n++] = fixtype(cpexpr(cp->datap));
1022:         if(n > 7)
1023:             {
1024:             error("more than 7 subscripts",0,0,ERR);
1025:             break;
1026:             }
1027:         }
1028: 
1029: dimp = np->vdim;
1030: if(n>0 && dimp==NULL)
1031:     error("subscripts on scalar variable",0,0,ERR);
1032: else if(dimp && dimp->ndim!=n)
1033:     error("wrong number of subscripts on %s", varstr(VL, np->varname),0,ERR1);
1034: else if(n > 0)
1035:     {
1036:     prod = sub[--n];
1037:     while( --n >= 0)
1038:         prod = mkexpr(OPPLUS, sub[n],
1039:             mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
1040: #if TARGET == VAX
1041:     if(checksubs || np->vstg!=STGARG)
1042:         prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
1043: #else
1044:     prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
1045: #endif
1046:     if(checksubs)
1047:         prod = subcheck(np, prod);
1048:     if(np->vtype == TYCHAR)
1049:         size = cpexpr(np->vleng);
1050:     else    size = ICON( typesize[np->vtype] );
1051:     prod = mkexpr(OPSTAR, prod, size);
1052:     offp = mkexpr(OPPLUS, offp, prod);
1053:     }
1054: 
1055: if(p->fcharp && np->vtype==TYCHAR)
1056:     offp = mkexpr(OPPLUS, offp, mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1) ));
1057: 
1058: return(offp);
1059: }
1060: 
1061: 
1062: 
1063: 
1064: expptr subcheck(np, p)
1065: struct nameblock *np;
1066: register expptr p;
1067: {
1068: struct dimblock *dimp;
1069: expptr t, checkvar, checkcond, badcall;
1070: 
1071: dimp = np->vdim;
1072: if(dimp->nelt == NULL)
1073:     return(p);  /* don't check arrays with * bounds */
1074: checkvar = NULL;
1075: checkcond = NULL;
1076: if( ISICON(p) )
1077:     {
1078:     if(p->const.ci < 0)
1079:         goto badsub;
1080:     if( ISICON(dimp->nelt) )
1081:         if(p->const.ci < dimp->nelt->const.ci)
1082:             return(p);
1083:         else
1084:             goto badsub;
1085:     }
1086: if(p->tag==TADDR && p->vstg==STGREG)
1087:     {
1088:     checkvar = cpexpr(p);
1089:     t = p;
1090:     }
1091: else    {
1092:     checkvar = mktemp(p->vtype, NULL);
1093:     t = mkexpr(OPASSIGN, cpexpr(checkvar), p);
1094:     }
1095: checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) );
1096: if( ! ISICON(p) )
1097:     checkcond = mkexpr(OPAND, checkcond,
1098:             mkexpr(OPLE, ICON(0), cpexpr(checkvar)) );
1099: 
1100: badcall = call4(p->vtype, "s_rnge", mkstrcon(VL, np->varname),
1101:         mkconv(TYLONG,  cpexpr(checkvar)),
1102:         mkstrcon(XL, procname), ICON(lineno));
1103: badcall->opcode = OPCCALL;
1104: p = mkexpr(OPQUEST, checkcond,
1105:     mkexpr(OPCOLON, checkvar, badcall));
1106: 
1107: return(p);
1108: 
1109: badsub:
1110:     frexpr(p);
1111:     error("subscript on variable %s out of range", varstr(VL,np->varname),0,ERR1);
1112:     return ( ICON(0) );
1113: }
1114: 
1115: 
1116: 
1117: 
1118: struct addrblock *mkaddr(p)
1119: register struct nameblock *p;
1120: {
1121: struct extsym *mkext(), *extp;
1122: register struct addrblock *t;
1123: struct addrblock *intraddr();
1124: 
1125: switch( p->vstg)
1126:     {
1127:     case STGUNKNOWN:
1128:         if(p->vclass != CLPROC)
1129:             break;
1130:         extp = mkext( varunder(VL, p->varname) );
1131:         extp->extstg = STGEXT;
1132:         p->vstg = STGEXT;
1133:         p->vardesc.varno = extp - extsymtab;
1134:         p->vprocclass = PEXTERNAL;
1135: 
1136:     case STGCOMMON:
1137:     case STGEXT:
1138:     case STGBSS:
1139:     case STGINIT:
1140:     case STGEQUIV:
1141:     case STGARG:
1142:     case STGLENG:
1143:     case STGAUTO:
1144:         t = ALLOC(addrblock);
1145:         t->tag = TADDR;
1146:         if(p->vclass==CLPROC && p->vprocclass==PTHISPROC)
1147:             t->vclass = CLVAR;
1148:         else
1149:             t->vclass = p->vclass;
1150:         t->vtype = p->vtype;
1151:         t->vstg = p->vstg;
1152:         t->memno = p->vardesc.varno;
1153:         t->memoffset = ICON(p->voffset);
1154:         if(p->vleng)
1155:             t->vleng = cpexpr(p->vleng);
1156:         return(t);
1157: 
1158:     case STGINTR:
1159:         return( intraddr(p) );
1160: 
1161:     }
1162: /*debug*/ fprintf(diagfile, "mkaddr. vtype=%d, vclass=%d\n", p->vtype, p->vclass);
1163: error("mkaddr: impossible storage tag %d", p->vstg,0,FATAL1);
1164: /* NOTREACHED */
1165: }
1166: 
1167: 
1168: 
1169: 
1170: mkarg(type, argno)
1171: int type, argno;
1172: {
1173: register struct addrblock *p;
1174: 
1175: p = ALLOC(addrblock);
1176: p->tag = TADDR;
1177: p->vtype = type;
1178: p->vclass = CLVAR;
1179: p->vstg = (type==TYLENG ? STGLENG : STGARG);
1180: p->memno = argno;
1181: return(p);
1182: }
1183: 
1184: 
1185: 
1186: 
1187: tagptr mkprim(v, args, lstr, rstr)
1188: register union { struct paramblock; struct nameblock; } *v;
1189: struct listblock *args;
1190: expptr lstr, rstr;
1191: {
1192: register struct primblock *p;
1193: 
1194: if(v->vclass == CLPARAM)
1195:     {
1196:     if(args || lstr || rstr)
1197:         {
1198:         error("no qualifiers on parameter name", varstr(VL,v->varname),0,ERR1);
1199:         frexpr(args);
1200:         frexpr(lstr);
1201:         frexpr(rstr);
1202:         frexpr(v);
1203:         return( errnode() );
1204:         }
1205:     return( cpexpr(v->paramval) );
1206:     }
1207: 
1208: p = ALLOC(primblock);
1209: p->tag = TPRIM;
1210: p->vtype = v->vtype;
1211: p->namep = v;
1212: p->argsp = args;
1213: p->fcharp = lstr;
1214: p->lcharp = rstr;
1215: return(p);
1216: }
1217: 
1218: 
1219: 
1220: vardcl(v)
1221: register struct nameblock *v;
1222: {
1223: int nelt;
1224: struct dimblock *t;
1225: struct addrblock *p;
1226: expptr neltp;
1227: 
1228: if(v->vdcldone) return;
1229: 
1230: if(v->vtype == TYUNKNOWN)
1231:     impldcl(v);
1232: if(v->vclass == CLUNKNOWN)
1233:     v->vclass = CLVAR;
1234: else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC)
1235:     {
1236:     error("used as variable", v, 0, DCLERR);
1237:     return;
1238:     }
1239: if(v->vstg==STGUNKNOWN)
1240:     v->vstg = implstg[ letter(v->varname[0]) ];
1241: 
1242: switch(v->vstg)
1243:     {
1244:     case STGBSS:
1245:         v->vardesc.varno = ++lastvarno;
1246:         break;
1247:     case STGAUTO:
1248:         if(v->vclass==CLPROC && v->vprocclass==PTHISPROC)
1249:             break;
1250:         nelt = 1;
1251:         if(t = v->vdim)
1252:             if( (neltp = t->nelt) && ISCONST(neltp) )
1253:                 nelt = neltp->const.ci;
1254:             else
1255:                 error("adjustable automatic array", v, 0, DCLERR);
1256:         p = autovar(nelt, v->vtype, v->vleng);
1257:         v->voffset = p->memoffset->const.ci;
1258:         frexpr(p);
1259:         break;
1260: 
1261:     default:
1262:         break;
1263:     }
1264: v->vdcldone = YES;
1265: }
1266: 
1267: 
1268: 
1269: 
1270: impldcl(p)
1271: register struct nameblock *p;
1272: {
1273: register int k;
1274: int type, leng;
1275: 
1276: if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) )
1277:     return;
1278: if(p->vtype == TYUNKNOWN)
1279:     {
1280:     k = letter(p->varname[0]);
1281:     type = impltype[ k ];
1282:     leng = implleng[ k ];
1283:     if(type == TYUNKNOWN)
1284:         {
1285:         if(p->vclass == CLPROC)
1286:             return;
1287:         error("attempt to use undefined variable", p, 0, DCLERR);
1288:         type = TYERROR;
1289:         leng = 1;
1290:         }
1291:     settype(p, type, leng);
1292:     }
1293: }
1294: 
1295: 
1296: 
1297: 
1298: LOCAL letter(c)
1299: register int c;
1300: {
1301: if( isupper(c) )
1302:     c = tolower(c);
1303: return(c - 'a');
1304: }
1305: 
1306: #define ICONEQ(z, c)  (ISICON(z) && z->const.ci==c)
1307: #define COMMUTE { e = lp;  lp = rp;  rp = e; }
1308: 
1309: 
1310: expptr mkexpr(opcode, lp, rp)
1311: int opcode;
1312: register expptr lp, rp;
1313: {
1314: register struct exprblock *e, *e1;
1315: int etype;
1316: int ltype, rtype;
1317: int ltag, rtag;
1318: expptr fold();
1319: 
1320: ltype = lp->vtype;
1321: ltag = lp->tag;
1322: if(rp && opcode!=OPCALL && opcode!=OPCCALL)
1323:     {
1324:     rtype = rp->vtype;
1325:     rtag = rp->tag;
1326:     }
1327: else  rtype = 0;
1328: 
1329: etype = cktype(opcode, ltype, rtype);
1330: if(etype == TYERROR)
1331:     goto err;
1332: 
1333: switch(opcode)
1334:     {
1335:     /* check for multiplication by 0 and 1 and addition to 0 */
1336: 
1337:     case OPSTAR:
1338:         if( ISCONST(lp) )
1339:             COMMUTE
1340: 
1341:         if( ISICON(rp) )
1342:             {
1343:             if(rp->const.ci == 0)
1344:                 goto retright;
1345:             goto mulop;
1346:             }
1347:         break;
1348: 
1349:     case OPSLASH:
1350:     case OPMOD:
1351:         if( ICONEQ(rp, 0) )
1352:             {
1353:             error("attempted division by zero",0,0,ERR);
1354:             rp = ICON(1);
1355:             break;
1356:             }
1357:         if(opcode == OPMOD)
1358:             break;
1359: 
1360: 
1361:     mulop:
1362:         if( ISICON(rp) )
1363:             {
1364:             if(rp->const.ci == 1)
1365:                 goto retleft;
1366: 
1367:             if(rp->const.ci == -1)
1368:                 {
1369:                 frexpr(rp);
1370:                 return( mkexpr(OPNEG, lp, 0) );
1371:                 }
1372:             }
1373: 
1374:         if( ISSTAROP(lp) && ISICON(lp->rightp) )
1375:             {
1376:             if(opcode == OPSTAR)
1377:                 e = mkexpr(OPSTAR, lp->rightp, rp);
1378:             else  if(ISICON(rp) && lp->rightp->const.ci % rp->const.ci == 0)
1379:                 e = mkexpr(OPSLASH, lp->rightp, rp);
1380:             else    break;
1381: 
1382:             e1 = lp->leftp;
1383:             free(lp);
1384:             return( mkexpr(OPSTAR, e1, e) );
1385:             }
1386:         break;
1387: 
1388: 
1389:     case OPPLUS:
1390:         if( ISCONST(lp) )
1391:             COMMUTE
1392:         goto addop;
1393: 
1394:     case OPMINUS:
1395:         if( ICONEQ(lp, 0) )
1396:             {
1397:             frexpr(lp);
1398:             return( mkexpr(OPNEG, rp, 0) );
1399:             }
1400: 
1401:         if( ISCONST(rp) )
1402:             {
1403:             opcode = OPPLUS;
1404:             consnegop(rp);
1405:             }
1406: 
1407:     addop:
1408:         if( ISICON(rp) )
1409:             {
1410:             if(rp->const.ci == 0)
1411:                 goto retleft;
1412:             if( ISPLUSOP(lp) && ISICON(lp->rightp) )
1413:                 {
1414:                 e = mkexpr(OPPLUS, lp->rightp, rp);
1415:                 e1 = lp->leftp;
1416:                 free(lp);
1417:                 return( mkexpr(OPPLUS, e1, e) );
1418:                 }
1419:             }
1420:         break;
1421: 
1422: 
1423:     case OPPOWER:
1424:         break;
1425: 
1426:     case OPNEG:
1427:         if(ltag==TEXPR && lp->opcode==OPNEG)
1428:             {
1429:             e = lp->leftp;
1430:             free(lp);
1431:             return(e);
1432:             }
1433:         break;
1434: 
1435:     case OPNOT:
1436:         if(ltag==TEXPR && lp->opcode==OPNOT)
1437:             {
1438:             e = lp->leftp;
1439:             free(lp);
1440:             return(e);
1441:             }
1442:         break;
1443: 
1444:     case OPCALL:
1445:     case OPCCALL:
1446:         etype = ltype;
1447:         if(rp!=NULL && rp->listp==NULL)
1448:             {
1449:             free(rp);
1450:             rp = NULL;
1451:             }
1452:         break;
1453: 
1454:     case OPAND:
1455:     case OPOR:
1456:         if( ISCONST(lp) )
1457:             COMMUTE
1458: 
1459:         if( ISCONST(rp) )
1460:             {
1461:             if(rp->const.ci == 0)
1462:                 if(opcode == OPOR)
1463:                     goto retleft;
1464:                 else
1465:                     goto retright;
1466:             else if(opcode == OPOR)
1467:                 goto retright;
1468:             else
1469:                 goto retleft;
1470:             }
1471:     case OPEQV:
1472:     case OPNEQV:
1473: 
1474:     case OPBITAND:
1475:     case OPBITOR:
1476:     case OPBITXOR:
1477:     case OPBITNOT:
1478:     case OPLSHIFT:
1479:     case OPRSHIFT:
1480: 
1481:     case OPLT:
1482:     case OPGT:
1483:     case OPLE:
1484:     case OPGE:
1485:     case OPEQ:
1486:     case OPNE:
1487: 
1488:     case OPCONCAT:
1489:         break;
1490:     case OPMIN:
1491:     case OPMAX:
1492: 
1493:     case OPASSIGN:
1494:     case OPPLUSEQ:
1495:     case OPSTAREQ:
1496: 
1497:     case OPCONV:
1498:     case OPADDR:
1499: 
1500:     case OPCOMMA:
1501:     case OPQUEST:
1502:     case OPCOLON:
1503:         break;
1504: 
1505:     default:
1506:         error("mkexpr: impossible opcode %d", opcode,0,FATAL1);
1507:     }
1508: 
1509: e = ALLOC(exprblock);
1510: e->tag = TEXPR;
1511: e->opcode = opcode;
1512: e->vtype = etype;
1513: e->leftp = lp;
1514: e->rightp = rp;
1515: if(ltag==TCONST && (rp==0 || rtag==TCONST) )
1516:     e = fold(e);
1517: return(e);
1518: 
1519: retleft:
1520:     frexpr(rp);
1521:     return(lp);
1522: 
1523: retright:
1524:     frexpr(lp);
1525:     return(rp);
1526: 
1527: err:
1528:     frexpr(lp);
1529:     if(rp && opcode!=OPCALL && opcode!=OPCCALL)
1530:         frexpr(rp);
1531:     return( errnode() );
1532: }
1533: 
1534: 
1535: cktype(op, lt, rt)
1536: register int op, lt, rt;
1537: {
1538: char *errs;
1539: 
1540: if(lt==TYERROR || rt==TYERROR)
1541:     goto err1;
1542: 
1543: if(lt==TYUNKNOWN)
1544:     return(TYUNKNOWN);
1545: if(rt==TYUNKNOWN)
1546:     if(op!=OPNOT && op!=OPBITNOT && op!=OPNEG && op!=OPCALL && op!=OPCCALL && op!=OPADDR)
1547:         return(TYUNKNOWN);
1548: 
1549: switch(op)
1550:     {
1551:     case OPPLUS:
1552:     case OPMINUS:
1553:     case OPSTAR:
1554:     case OPSLASH:
1555:     case OPPOWER:
1556:     case OPMOD:
1557:         if( ISNUMERIC(lt) && ISNUMERIC(rt) )
1558:             return( maxtype(lt, rt) );
1559:         error("nonarithmetic operand of arithmetic operator",0,0,ERR);goto err1;
1560: 
1561:     case OPNEG:
1562:         if( ISNUMERIC(lt) )
1563:             return(lt);
1564:         error("nonarithmetic operand of negation",0,0,ERR);goto err1;
1565: 
1566:     case OPNOT:
1567:         if(lt == TYLOGICAL)
1568:             return(TYLOGICAL);
1569:         error("NOT of nonlogical",0,0,ERR);goto err1;
1570: 
1571:     case OPAND:
1572:     case OPOR:
1573:     case OPEQV:
1574:     case OPNEQV:
1575:         if(lt==TYLOGICAL && rt==TYLOGICAL)
1576:             return(TYLOGICAL);
1577:         error("nonlogical operand of logical operator",0,0,ERR);goto err1;
1578: 
1579:     case OPLT:
1580:     case OPGT:
1581:     case OPLE:
1582:     case OPGE:
1583:     case OPEQ:
1584:     case OPNE:
1585:         if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
1586:             {
1587:             if(lt != rt)
1588:                 {error("illegal comparison",0,0,ERR);goto err1;}
1589:             }
1590: 
1591:         else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
1592:             {
1593:             if(op!=OPEQ && op!=OPNE)
1594:                 {error("order comparison of complex data",0,0,ERR);goto err1;}
1595:             }
1596: 
1597:         else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
1598:             {error("comparison of nonarithmetic data",0,0,ERR);goto err1;}
1599:         return(TYLOGICAL);
1600: 
1601:     case OPCONCAT:
1602:         if(lt==TYCHAR && rt==TYCHAR)
1603:             return(TYCHAR);
1604:         error("concatenation of nonchar data",0,0,ERR);goto err1;
1605: 
1606:     case OPCALL:
1607:     case OPCCALL:
1608:         return(lt);
1609: 
1610:     case OPADDR:
1611:         return(TYADDR);
1612: 
1613:     case OPCONV:
1614:         if(rt == 0)
1615:             return(0);
1616:         if(lt==TYCHAR && ISINT(rt) )
1617:             return(TYCHAR);
1618:     case OPASSIGN:
1619:     case OPPLUSEQ:
1620:     case OPSTAREQ:
1621:         if( ISINT(lt) && rt==TYCHAR)
1622:             return(lt);
1623:         if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
1624:             if(op!=OPASSIGN || lt!=rt)
1625:                 {
1626: /* debug fprintf(diagfile, " lt=%d, rt=%d, op=%d\n", lt, rt, op); */
1627: /* debug error("impossible conversion.  possible compiler bug",0,0,FATAL); */
1628:                 error("impossible conversion",0,0,ERR);goto err1;
1629:                 }
1630:         return(lt);
1631: 
1632:     case OPMIN:
1633:     case OPMAX:
1634:     case OPBITOR:
1635:     case OPBITAND:
1636:     case OPBITXOR:
1637:     case OPBITNOT:
1638:     case OPLSHIFT:
1639:     case OPRSHIFT:
1640:         return(lt);
1641: 
1642:     case OPCOMMA:
1643:     case OPQUEST:
1644:     case OPCOLON:
1645:         return(rt);
1646: 
1647:     default:
1648:         error("cktype: impossible opcode %d", op,0,FATAL1);
1649:     }
1650: err1:   return(TYERROR);
1651: }
1652: 
1653: LOCAL expptr fold(e)
1654: register struct exprblock *e;
1655: {
1656: struct constblock *p;
1657: #ifdef VERSION6
1658:     expptr lp, rp;
1659: #else
1660:     register expptr lp, rp;
1661: #endif
1662: int etype, mtype, ltype, rtype, opcode;
1663: int i, ll, lr;
1664: char *q, *s;
1665: union constant lcon, rcon;
1666: 
1667: opcode = e->opcode;
1668: etype = e->vtype;
1669: 
1670: lp = e->leftp;
1671: ltype = lp->vtype;
1672: rp = e->rightp;
1673: 
1674: if(rp == 0)
1675:     switch(opcode)
1676:         {
1677:         case OPNOT:
1678:             lp->const.ci = ! lp->const.ci;
1679:             return(lp);
1680: 
1681:         case OPBITNOT:
1682:             lp->const.ci = ~ lp->const.ci;
1683:             return(lp);
1684: 
1685:         case OPNEG:
1686:             consnegop(lp);
1687:             return(lp);
1688: 
1689:         case OPCONV:
1690:         case OPADDR:
1691:             return(e);
1692: 
1693:         default:
1694:             error("fold: invalid unary operator %d", opcode,0,FATAL1);
1695:         }
1696: 
1697: rtype = rp->vtype;
1698: 
1699: p = ALLOC(constblock);
1700: p->tag = TCONST;
1701: p->vtype = etype;
1702: p->vleng = e->vleng;
1703: 
1704: switch(opcode)
1705:     {
1706:     case OPCOMMA:
1707:     case OPQUEST:
1708:     case OPCOLON:
1709:         return(e);
1710: 
1711:     case OPAND:
1712:         p->const.ci = lp->const.ci && rp->const.ci;
1713:         break;
1714: 
1715:     case OPOR:
1716:         p->const.ci = lp->const.ci || rp->const.ci;
1717:         break;
1718: 
1719:     case OPEQV:
1720:         p->const.ci = lp->const.ci == rp->const.ci;
1721:         break;
1722: 
1723:     case OPNEQV:
1724:         p->const.ci = lp->const.ci != rp->const.ci;
1725:         break;
1726: 
1727:     case OPBITAND:
1728:         p->const.ci = lp->const.ci & rp->const.ci;
1729:         break;
1730: 
1731:     case OPBITOR:
1732:         p->const.ci = lp->const.ci | rp->const.ci;
1733:         break;
1734: 
1735:     case OPBITXOR:
1736:         p->const.ci = lp->const.ci ^ rp->const.ci;
1737:         break;
1738: 
1739:     case OPLSHIFT:
1740:         p->const.ci = lp->const.ci << rp->const.ci;
1741:         break;
1742: 
1743:     case OPRSHIFT:
1744:         p->const.ci = lp->const.ci >> rp->const.ci;
1745:         break;
1746: 
1747:     case OPCONCAT:
1748:         ll = lp->vleng->const.ci;
1749:         lr = rp->vleng->const.ci;
1750:         p->const.ccp = q = (char *) ckalloc(ll+lr);
1751:         p->vleng = ICON(ll+lr);
1752:         s = lp->const.ccp;
1753:         for(i = 0 ; i < ll ; ++i)
1754:             *q++ = *s++;
1755:         s = rp->const.ccp;
1756:         for(i = 0; i < lr; ++i)
1757:             *q++ = *s++;
1758:         break;
1759: 
1760: 
1761:     case OPPOWER:
1762:         if( ! ISINT(rtype) )
1763:             return(e);
1764:         conspower(&(p->const), lp, rp->const.ci);
1765:         break;
1766: 
1767: 
1768:     default:
1769:         if(ltype == TYCHAR)
1770:             {
1771:             lcon.ci = cmpstr(lp->const.ccp, rp->const.ccp,
1772:                     lp->vleng->const.ci, rp->vleng->const.ci);
1773:             rcon.ci = 0;
1774:             mtype = tyint;
1775:             }
1776:         else    {
1777:             mtype = maxtype(ltype, rtype);
1778:             consconv(mtype, &lcon, ltype, &(lp->const) );
1779:             consconv(mtype, &rcon, rtype, &(rp->const) );
1780:             }
1781:         consbinop(opcode, mtype, &(p->const), &lcon, &rcon);
1782:         break;
1783:     }
1784: 
1785: frexpr(e);
1786: return(p);
1787: }
1788: 
1789: 
1790: 
1791: /* assign constant l = r , doing coercion */
1792: 
1793: consconv(lt, lv, rt, rv)
1794: int lt, rt;
1795: register union constant *lv, *rv;
1796: {
1797: switch(lt)
1798:     {
1799:     case TYCHAR:
1800:         *(lv->ccp = ckalloc(1)) = rv->ci;
1801:         break;
1802: 
1803:     case TYSHORT:
1804:     case TYLONG:
1805:         if(rt == TYCHAR)
1806:             lv->ci = rv->ccp[0];
1807:         else if( ISINT(rt) )
1808:             lv->ci = rv->ci;
1809:         else    lv->ci = rv->cd[0];
1810:         break;
1811: 
1812:     case TYCOMPLEX:
1813:     case TYDCOMPLEX:
1814:         switch(rt)
1815:             {
1816:             case TYSHORT:
1817:             case TYLONG:
1818:                 /* fall through and do real assignment of
1819: 				   first element
1820: 				*/
1821:             case TYREAL:
1822:             case TYDREAL:
1823:                 lv->cd[1] = 0; break;
1824:             case TYCOMPLEX:
1825:             case TYDCOMPLEX:
1826:                 lv->cd[1] = rv->cd[1]; break;
1827:             }
1828: 
1829:     case TYREAL:
1830:     case TYDREAL:
1831:         if( ISINT(rt) )
1832:             lv->cd[0] = rv->ci;
1833:         else    lv->cd[0] = rv->cd[0];
1834:         break;
1835: 
1836:     case TYLOGICAL:
1837:         lv->ci = rv->ci;
1838:         break;
1839:     }
1840: }
1841: 
1842: 
1843: 
1844: consnegop(p)
1845: register struct constblock *p;
1846: {
1847: switch(p->vtype)
1848:     {
1849:     case TYSHORT:
1850:     case TYLONG:
1851:         p->const.ci = - p->const.ci;
1852:         break;
1853: 
1854:     case TYCOMPLEX:
1855:     case TYDCOMPLEX:
1856:         p->const.cd[1] = - p->const.cd[1];
1857:         /* fall through and do the real parts */
1858:     case TYREAL:
1859:     case TYDREAL:
1860:         p->const.cd[0] = - p->const.cd[0];
1861:         break;
1862:     default:
1863:         error("consnegop: impossible type %d", p->vtype,0,FATAL1);
1864:     }
1865: }
1866: 
1867: 
1868: 
1869: LOCAL conspower(powp, ap, n)
1870: register union constant *powp;
1871: struct constblock *ap;
1872: ftnint n;
1873: {
1874: register int type;
1875: union constant x;
1876: 
1877: switch(type = ap->vtype)    /* pow = 1 */
1878:     {
1879:     case TYSHORT:
1880:     case TYLONG:
1881:         powp->ci = 1;
1882:         break;
1883:     case TYCOMPLEX:
1884:     case TYDCOMPLEX:
1885:         powp->cd[1] = 0;
1886:     case TYREAL:
1887:     case TYDREAL:
1888:         powp->cd[0] = 1;
1889:         break;
1890:     default:
1891:         error("conspower: invalid type %d", type,0,FATAL1);
1892:     }
1893: 
1894: if(n == 0)
1895:     return;
1896: if(n < 0)
1897:     {
1898:     if( ISINT(type) )
1899:         {
1900:         error("integer ** negative power ",0,0,ERR);
1901:         return;
1902:         }
1903:     n = - n;
1904:     consbinop(OPSLASH, type, &x, powp, &(ap->const));
1905:     }
1906: else
1907:     consbinop(OPSTAR, type, &x, powp, &(ap->const));
1908: 
1909: for( ; ; )
1910:     {
1911:     if(n & 01)
1912:         consbinop(OPSTAR, type, powp, powp, &x);
1913:     if(n >>= 1)
1914:         consbinop(OPSTAR, type, &x, &x, &x);
1915:     else
1916:         break;
1917:     }
1918: }
1919: 
1920: 
1921: 
1922: /* do constant operation cp = a op b */
1923: 
1924: 
1925: LOCAL consbinop(opcode, type, cp, ap, bp)
1926: int opcode, type;
1927: register union constant *ap, *bp, *cp;
1928: {
1929: int k;
1930: double temp;
1931: 
1932: switch(opcode)
1933:     {
1934:     case OPPLUS:
1935:         switch(type)
1936:             {
1937:             case TYSHORT:
1938:             case TYLONG:
1939:                 cp->ci = ap->ci + bp->ci;
1940:                 break;
1941:             case TYCOMPLEX:
1942:             case TYDCOMPLEX:
1943:                 cp->cd[1] = ap->cd[1] + bp->cd[1];
1944:             case TYREAL:
1945:             case TYDREAL:
1946:                 cp->cd[0] = ap->cd[0] + bp->cd[0];
1947:                 break;
1948:             }
1949:         break;
1950: 
1951:     case OPMINUS:
1952:         switch(type)
1953:             {
1954:             case TYSHORT:
1955:             case TYLONG:
1956:                 cp->ci = ap->ci - bp->ci;
1957:                 break;
1958:             case TYCOMPLEX:
1959:             case TYDCOMPLEX:
1960:                 cp->cd[1] = ap->cd[1] - bp->cd[1];
1961:             case TYREAL:
1962:             case TYDREAL:
1963:                 cp->cd[0] = ap->cd[0] - bp->cd[0];
1964:                 break;
1965:             }
1966:         break;
1967: 
1968:     case OPSTAR:
1969:         switch(type)
1970:             {
1971:             case TYSHORT:
1972:             case TYLONG:
1973:                 cp->ci = ap->ci * bp->ci;
1974:                 break;
1975:             case TYREAL:
1976:             case TYDREAL:
1977:                 cp->cd[0] = ap->cd[0] * bp->cd[0];
1978:                 break;
1979:             case TYCOMPLEX:
1980:             case TYDCOMPLEX:
1981:                 temp = ap->cd[0] * bp->cd[0] -
1982:                         ap->cd[1] * bp->cd[1] ;
1983:                 cp->cd[1] = ap->cd[0] * bp->cd[1] +
1984:                         ap->cd[1] * bp->cd[0] ;
1985:                 cp->cd[0] = temp;
1986:                 break;
1987:             }
1988:         break;
1989:     case OPSLASH:
1990:         switch(type)
1991:             {
1992:             case TYSHORT:
1993:             case TYLONG:
1994:                 cp->ci = ap->ci / bp->ci;
1995:                 break;
1996:             case TYREAL:
1997:             case TYDREAL:
1998:                 cp->cd[0] = ap->cd[0] / bp->cd[0];
1999:                 break;
2000:             case TYCOMPLEX:
2001:             case TYDCOMPLEX:
2002:                 zdiv(cp,ap,bp);
2003:                 break;
2004:             }
2005:         break;
2006: 
2007:     case OPMOD:
2008:         if( ISINT(type) )
2009:             {
2010:             cp->ci = ap->ci % bp->ci;
2011:             break;
2012:             }
2013:         else
2014:             error("inline mod of noninteger",0,0,FATAL);
2015: 
2016:     default:      /* relational ops */
2017:         switch(type)
2018:             {
2019:             case TYSHORT:
2020:             case TYLONG:
2021:                 if(ap->ci < bp->ci)
2022:                     k = -1;
2023:                 else if(ap->ci == bp->ci)
2024:                     k = 0;
2025:                 else    k = 1;
2026:                 break;
2027:             case TYREAL:
2028:             case TYDREAL:
2029:                 if(ap->cd[0] < bp->cd[0])
2030:                     k = -1;
2031:                 else if(ap->cd[0] == bp->cd[0])
2032:                     k = 0;
2033:                 else    k = 1;
2034:                 break;
2035:             case TYCOMPLEX:
2036:             case TYDCOMPLEX:
2037:                 if(ap->cd[0] == bp->cd[0] &&
2038:                    ap->cd[1] == bp->cd[1] )
2039:                     k = 0;
2040:                 else    k = 1;
2041:                 break;
2042:             }
2043: 
2044:         switch(opcode)
2045:             {
2046:             case OPEQ:
2047:                 cp->ci = (k == 0);
2048:                 break;
2049:             case OPNE:
2050:                 cp->ci = (k != 0);
2051:                 break;
2052:             case OPGT:
2053:                 cp->ci = (k == 1);
2054:                 break;
2055:             case OPLT:
2056:                 cp->ci = (k == -1);
2057:                 break;
2058:             case OPGE:
2059:                 cp->ci = (k >= 0);
2060:                 break;
2061:             case OPLE:
2062:                 cp->ci = (k <= 0);
2063:                 break;
2064:             }
2065:         break;
2066:     }
2067: }
2068: 
2069: 
2070: 
2071: 
2072: conssgn(p)
2073: register expptr p;
2074: {
2075: if( ! ISCONST(p) )
2076:     error("sgn(nonconstant)" ,0,0,FATAL);
2077: 
2078: switch(p->vtype)
2079:     {
2080:     case TYSHORT:
2081:     case TYLONG:
2082:         if(p->const.ci > 0) return(1);
2083:         if(p->const.ci < 0) return(-1);
2084:         return(0);
2085: 
2086:     case TYREAL:
2087:     case TYDREAL:
2088:         if(p->const.cd[0] > 0) return(1);
2089:         if(p->const.cd[0] < 0) return(-1);
2090:         return(0);
2091: 
2092:     case TYCOMPLEX:
2093:     case TYDCOMPLEX:
2094:         return(p->const.cd[0]!=0 || p->const.cd[1]!=0);
2095: 
2096:     default:
2097:         error("conssgn(type %d)", p->vtype,0,FATAL1);
2098:     }
2099: /* NOTREACHED */
2100: }
2101: 
2102: char *powint[ ] = { "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" };
2103: 
2104: 
2105: LOCAL expptr mkpower(p)
2106: register struct exprblock *p;
2107: {
2108: register expptr q, lp, rp;
2109: int ltype, rtype, mtype;
2110: 
2111: lp = p->leftp;
2112: rp = p->rightp;
2113: ltype = lp->vtype;
2114: rtype = rp->vtype;
2115: 
2116: if(ISICON(rp))
2117:     {
2118:     if(rp->const.ci == 0)
2119:         {
2120:         frexpr(p);
2121:         if( ISINT(ltype) )
2122:             return( ICON(1) );
2123:         else
2124:             return( putconst( mkconv(ltype, ICON(1))) );
2125:         }
2126:     if(rp->const.ci < 0)
2127:         {
2128:         if( ISINT(ltype) )
2129:             {
2130:             frexpr(p);
2131:             error("integer**negative",0,0,ERR);
2132:             return( errnode() );
2133:             }
2134:         rp->const.ci = - rp->const.ci;
2135:         p->leftp = lp = fixexpr(mkexpr(OPSLASH, ICON(1), lp));
2136:         }
2137:     if(rp->const.ci == 1)
2138:         {
2139:         frexpr(rp);
2140:         free(p);
2141:         return(lp);
2142:         }
2143: 
2144:     if( ONEOF(ltype, MSKINT|MSKREAL) )
2145:         {
2146:         p->vtype = ltype;
2147:         return(p);
2148:         }
2149:     }
2150: if( ISINT(rtype) )
2151:     {
2152:     if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
2153:         q = call2(TYSHORT, "pow_hh", lp, rp);
2154:     else    {
2155:         if(ltype == TYSHORT)
2156:             {
2157:             ltype = TYLONG;
2158:             lp = mkconv(TYLONG,lp);
2159:             }
2160:         q = call2(ltype, powint[ltype-TYLONG], lp, mkconv(TYLONG, rp));
2161:         }
2162:     }
2163: else if( ISREAL( (mtype = maxtype(ltype,rtype)) ))
2164:     q = call2(mtype, "pow_dd",
2165:         mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
2166: else    {
2167:     q = call2(TYDCOMPLEX, "pow_zz",
2168:         mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
2169:     if(mtype == TYCOMPLEX)
2170:         q = mkconv(TYCOMPLEX, q);
2171:     }
2172: free(p);
2173: return(q);
2174: }
2175: 
2176: 
2177: 
2178: /* Complex Division.  Same code as in Runtime Library
2179: */
2180: 
2181: struct dcomplex { double dreal, dimag; };
2182: 
2183: 
2184: LOCAL zdiv(c, a, b)
2185: register struct dcomplex *a, *b, *c;
2186: {
2187: double ratio, den;
2188: double abr, abi;
2189: 
2190: if( (abr = b->dreal) < 0.)
2191:     abr = - abr;
2192: if( (abi = b->dimag) < 0.)
2193:     abi = - abi;
2194: if( abr <= abi )
2195:     {
2196:     if(abi == 0)
2197:         error("complex division by zero",0,0,FATAL);
2198:     ratio = b->dreal / b->dimag ;
2199:     den = b->dimag * (1 + ratio*ratio);
2200:     c->dreal = (a->dreal*ratio + a->dimag) / den;
2201:     c->dimag = (a->dimag*ratio - a->dreal) / den;
2202:     }
2203: 
2204: else
2205:     {
2206:     ratio = b->dimag / b->dreal ;
2207:     den = b->dreal * (1 + ratio*ratio);
2208:     c->dreal = (a->dreal + a->dimag*ratio) / den;
2209:     c->dimag = (a->dimag - a->dreal*ratio) / den;
2210:     }
2211: 
2212: }

Defined functions

Defined variables

Defined struct's

Defined macros