UNIX 7th Ed. - /usr/src/cmd/f77/expr.c

   1: #include "defs"
   2: 
   3: /* little routines to create constant blocks */
   4: 
   5: struct constblock *mkconst(t)
   6: register int t;
   7: {
   8: register struct constblock *p;
   9: 
  10: p = ALLOC(constblock);
  11: p->tag = TCONST;
  12: p->vtype = t;
  13: return(p);
  14: }
  15: 
  16: 
  17: struct constblock *mklogcon(l)
  18: register int l;
  19: {
  20: register struct constblock * p;
  21: 
  22: p = mkconst(TYLOGICAL);
  23: p->const.ci = l;
  24: return(p);
  25: }
  26: 
  27: 
  28: 
  29: struct constblock *mkintcon(l)
  30: ftnint l;
  31: {
  32: register struct constblock *p;
  33: 
  34: p = mkconst(TYLONG);
  35: p->const.ci = l;
  36: #ifdef MAXSHORT
  37:     if(l >= -MAXSHORT   &&   l <= MAXSHORT)
  38:         p->vtype = TYSHORT;
  39: #endif
  40: return(p);
  41: }
  42: 
  43: 
  44: 
  45: struct constblock *mkaddcon(l)
  46: register int l;
  47: {
  48: register struct constblock *p;
  49: 
  50: p = mkconst(TYADDR);
  51: p->const.ci = l;
  52: return(p);
  53: }
  54: 
  55: 
  56: 
  57: struct constblock *mkrealcon(t, d)
  58: register int t;
  59: double d;
  60: {
  61: register struct constblock *p;
  62: 
  63: p = mkconst(t);
  64: p->const.cd[0] = d;
  65: return(p);
  66: }
  67: 
  68: 
  69: struct constblock *mkbitcon(shift, leng, s)
  70: int shift;
  71: int leng;
  72: char *s;
  73: {
  74: register struct constblock *p;
  75: 
  76: p = mkconst(TYUNKNOWN);
  77: p->const.ci = 0;
  78: while(--leng >= 0)
  79:     if(*s != ' ')
  80:         p->const.ci = (p->const.ci << shift) | hextoi(*s++);
  81: return(p);
  82: }
  83: 
  84: 
  85: 
  86: 
  87: 
  88: struct constblock *mkstrcon(l,v)
  89: int l;
  90: register char *v;
  91: {
  92: register struct constblock *p;
  93: register char *s;
  94: 
  95: p = mkconst(TYCHAR);
  96: p->vleng = ICON(l);
  97: p->const.ccp = s = (char *) ckalloc(l);
  98: while(--l >= 0)
  99:     *s++ = *v++;
 100: return(p);
 101: }
 102: 
 103: 
 104: struct constblock *mkcxcon(realp,imagp)
 105: register expptr realp, imagp;
 106: {
 107: int rtype, itype;
 108: register struct constblock *p;
 109: 
 110: rtype = realp->vtype;
 111: itype = imagp->vtype;
 112: 
 113: if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
 114:     {
 115:     p = mkconst( (rtype==TYDREAL||itype==TYDREAL) ? TYDCOMPLEX : TYCOMPLEX );
 116:     if( ISINT(rtype) )
 117:         p->const.cd[0] = realp->const.ci;
 118:     else    p->const.cd[0] = realp->const.cd[0];
 119:     if( ISINT(itype) )
 120:         p->const.cd[1] = imagp->const.ci;
 121:     else    p->const.cd[1] = imagp->const.cd[0];
 122:     }
 123: else
 124:     {
 125:     err("invalid complex constant");
 126:     p = errnode();
 127:     }
 128: 
 129: frexpr(realp);
 130: frexpr(imagp);
 131: return(p);
 132: }
 133: 
 134: 
 135: struct errorblock *errnode()
 136: {
 137: struct errorblock *p;
 138: p = ALLOC(errorblock);
 139: p->tag = TERROR;
 140: p->vtype = TYERROR;
 141: return(p);
 142: }
 143: 
 144: 
 145: 
 146: 
 147: 
 148: expptr mkconv(t, p)
 149: register int t;
 150: register expptr p;
 151: {
 152: register expptr q;
 153: register int pt;
 154: expptr opconv();
 155: 
 156: if(t==TYUNKNOWN || t==TYERROR)
 157:     fatal1("mkconv of impossible type %d", t);
 158: pt = p->vtype;
 159: if(t == pt)
 160:     return(p);
 161: 
 162: else if( ISCONST(p) && pt!=TYADDR)
 163:     {
 164:     q = mkconst(t);
 165:     consconv(t, &(q->const), p->vtype, &(p->const));
 166:     frexpr(p);
 167:     }
 168: #if TARGET == PDP11
 169:     else if(ISINT(t) && pt==TYCHAR)
 170:         {
 171:         q = mkexpr(OPBITAND, opconv(p,TYSHORT), ICON(255));
 172:         if(t == TYLONG)
 173:             q = opconv(q, TYLONG);
 174:         }
 175: #endif
 176: else
 177:     q = opconv(p, t);
 178: 
 179: if(t == TYCHAR)
 180:     q->vleng = ICON(1);
 181: return(q);
 182: }
 183: 
 184: 
 185: 
 186: expptr opconv(p, t)
 187: expptr p;
 188: int t;
 189: {
 190: register expptr q;
 191: 
 192: q = mkexpr(OPCONV, p, 0);
 193: q->vtype = t;
 194: return(q);
 195: }
 196: 
 197: 
 198: 
 199: struct exprblock *addrof(p)
 200: expptr p;
 201: {
 202: return( mkexpr(OPADDR, p, NULL) );
 203: }
 204: 
 205: 
 206: 
 207: tagptr cpexpr(p)
 208: register tagptr p;
 209: {
 210: register tagptr e;
 211: int tag;
 212: register chainp ep, pp;
 213: ptr cpblock();
 214: 
 215: static int blksize[ ] =
 216:     {   0,
 217:         sizeof(struct nameblock),
 218:         sizeof(struct constblock),
 219:         sizeof(struct exprblock),
 220:         sizeof(struct addrblock),
 221:         sizeof(struct primblock),
 222:         sizeof(struct listblock),
 223:         sizeof(struct errorblock)
 224:     };
 225: 
 226: if(p == NULL)
 227:     return(NULL);
 228: 
 229: if( (tag = p->tag) == TNAME)
 230:     return(p);
 231: 
 232: e = cpblock( blksize[p->tag] , p);
 233: 
 234: switch(tag)
 235:     {
 236:     case TCONST:
 237:         if(e->vtype == TYCHAR)
 238:             {
 239:             e->const.ccp = copyn(1+strlen(e->const.ccp), e->const.ccp);
 240:             e->vleng = cpexpr(e->vleng);
 241:             }
 242:     case TERROR:
 243:         break;
 244: 
 245:     case TEXPR:
 246:         e->leftp = cpexpr(p->leftp);
 247:         e->rightp = cpexpr(p->rightp);
 248:         break;
 249: 
 250:     case TLIST:
 251:         if(pp = p->listp)
 252:             {
 253:             ep = e->listp = mkchain( cpexpr(pp->datap), NULL);
 254:             for(pp = pp->nextp ; pp ; pp = pp->nextp)
 255:                 ep = ep->nextp = mkchain( cpexpr(pp->datap), NULL);
 256:             }
 257:         break;
 258: 
 259:     case TADDR:
 260:         e->vleng = cpexpr(e->vleng);
 261:         e->memoffset = cpexpr(e->memoffset);
 262:         e->istemp = NO;
 263:         break;
 264: 
 265:     case TPRIM:
 266:         e->argsp = cpexpr(e->argsp);
 267:         e->fcharp = cpexpr(e->fcharp);
 268:         e->lcharp = cpexpr(e->lcharp);
 269:         break;
 270: 
 271:     default:
 272:         fatal1("cpexpr: impossible tag %d", tag);
 273:     }
 274: 
 275: return(e);
 276: }
 277: 
 278: frexpr(p)
 279: register tagptr p;
 280: {
 281: register chainp q;
 282: 
 283: if(p == NULL)
 284:     return;
 285: 
 286: switch(p->tag)
 287:     {
 288:     case TCONST:
 289:         if( ISCHAR(p) )
 290:             {
 291:             free(p->const.ccp);
 292:             frexpr(p->vleng);
 293:             }
 294:         break;
 295: 
 296:     case TADDR:
 297:         if(p->istemp)
 298:             {
 299:             frtemp(p);
 300:             return;
 301:             }
 302:         frexpr(p->vleng);
 303:         frexpr(p->memoffset);
 304:         break;
 305: 
 306:     case TERROR:
 307:         break;
 308: 
 309:     case TNAME:
 310:         return;
 311: 
 312:     case TPRIM:
 313:         frexpr(p->argsp);
 314:         frexpr(p->fcharp);
 315:         frexpr(p->lcharp);
 316:         break;
 317: 
 318:     case TEXPR:
 319:         frexpr(p->leftp);
 320:         if(p->rightp)
 321:             frexpr(p->rightp);
 322:         break;
 323: 
 324:     case TLIST:
 325:         for(q = p->listp ; q ; q = q->nextp)
 326:             frexpr(q->datap);
 327:         frchain( &(p->listp) );
 328:         break;
 329: 
 330:     default:
 331:         fatal1("frexpr: impossible tag %d", p->tag);
 332:     }
 333: 
 334: free(p);
 335: }
 336: 
 337: /* fix up types in expression; replace subtrees and convert
 338:    names to address blocks */
 339: 
 340: expptr fixtype(p)
 341: register tagptr p;
 342: {
 343: 
 344: if(p == 0)
 345:     return(0);
 346: 
 347: switch(p->tag)
 348:     {
 349:     case TCONST:
 350:         if( ! ONEOF(p->vtype, MSKINT|MSKLOGICAL|MSKADDR) )
 351:             p = putconst(p);
 352:         return(p);
 353: 
 354:     case TADDR:
 355:         p->memoffset = fixtype(p->memoffset);
 356:         return(p);
 357: 
 358:     case TERROR:
 359:         return(p);
 360: 
 361:     default:
 362:         fatal1("fixtype: impossible tag %d", p->tag);
 363: 
 364:     case TEXPR:
 365:         return( fixexpr(p) );
 366: 
 367:     case TLIST:
 368:         return( p );
 369: 
 370:     case TPRIM:
 371:         if(p->argsp && p->namep->vclass!=CLVAR)
 372:             return( mkfunct(p) );
 373:         else    return( mklhs(p) );
 374:     }
 375: }
 376: 
 377: 
 378: 
 379: 
 380: 
 381: /* special case tree transformations and cleanups of expression trees */
 382: 
 383: expptr fixexpr(p)
 384: register struct exprblock *p;
 385: {
 386: expptr lp;
 387: register expptr rp;
 388: register expptr q;
 389: int opcode, ltype, rtype, ptype, mtype;
 390: expptr mkpower();
 391: 
 392: if(p->tag == TERROR)
 393:     return(p);
 394: else if(p->tag != TEXPR)
 395:     fatal1("fixexpr: invalid tag %d", p->tag);
 396: opcode = p->opcode;
 397: lp = p->leftp = fixtype(p->leftp);
 398: ltype = lp->vtype;
 399: if(opcode==OPASSIGN && lp->tag!=TADDR)
 400:     {
 401:     err("left side of assignment must be variable");
 402:     frexpr(p);
 403:     return( errnode() );
 404:     }
 405: 
 406: if(p->rightp)
 407:     {
 408:     rp = p->rightp = fixtype(p->rightp);
 409:     rtype = rp->vtype;
 410:     }
 411: else
 412:     {
 413:     rp = NULL;
 414:     rtype = 0;
 415:     }
 416: 
 417: /* force folding if possible */
 418: if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
 419:     {
 420:     q = mkexpr(opcode, lp, rp);
 421:     if( ISCONST(q) )
 422:         return(q);
 423:     free(q);    /* constants did not fold */
 424:     }
 425: 
 426: if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
 427:     {
 428:     frexpr(p);
 429:     return( errnode() );
 430:     }
 431: 
 432: switch(opcode)
 433:     {
 434:     case OPCONCAT:
 435:         if(p->vleng == NULL)
 436:             p->vleng = mkexpr(OPPLUS, cpexpr(lp->vleng),
 437:                 cpexpr(rp->vleng) );
 438:         break;
 439: 
 440:     case OPASSIGN:
 441:     case OPPLUSEQ:
 442:     case OPSTAREQ:
 443:         if(ltype == rtype)
 444:             break;
 445:         if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
 446:             break;
 447:         if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
 448:             break;
 449:         if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
 450: #if FAMILY==SCJ
 451:             && typesize[ltype]>=typesize[rtype] )
 452: #else
 453:             && typesize[ltype]==typesize[rtype] )
 454: #endif
 455:             break;
 456:         p->rightp = fixtype( mkconv(ptype, rp) );
 457:         break;
 458: 
 459:     case OPSLASH:
 460:         if( ISCOMPLEX(rtype) )
 461:             {
 462:             p = call2(ptype, ptype==TYCOMPLEX? "c_div" : "z_div",
 463:                 mkconv(ptype, lp), mkconv(ptype, rp) );
 464:             break;
 465:             }
 466:     case OPPLUS:
 467:     case OPMINUS:
 468:     case OPSTAR:
 469:     case OPMOD:
 470:         if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
 471:             (rtype==TYREAL && ! ISCONST(rp) ) ))
 472:             break;
 473:         if( ISCOMPLEX(ptype) )
 474:             break;
 475:         if(ltype != ptype)
 476:             p->leftp = fixtype(mkconv(ptype,lp));
 477:         if(rtype != ptype)
 478:             p->rightp = fixtype(mkconv(ptype,rp));
 479:         break;
 480: 
 481:     case OPPOWER:
 482:         return( mkpower(p) );
 483: 
 484:     case OPLT:
 485:     case OPLE:
 486:     case OPGT:
 487:     case OPGE:
 488:     case OPEQ:
 489:     case OPNE:
 490:         if(ltype == rtype)
 491:             break;
 492:         mtype = cktype(OPMINUS, ltype, rtype);
 493:         if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) ||
 494:             (rtype==TYREAL && ! ISCONST(rp)) ))
 495:             break;
 496:         if( ISCOMPLEX(mtype) )
 497:             break;
 498:         if(ltype != mtype)
 499:             p->leftp = fixtype(mkconv(mtype,lp));
 500:         if(rtype != mtype)
 501:             p->rightp = fixtype(mkconv(mtype,rp));
 502:         break;
 503: 
 504: 
 505:     case OPCONV:
 506:         ptype = cktype(OPCONV, p->vtype, ltype);
 507:         if(lp->tag==TEXPR && lp->opcode==OPCOMMA)
 508:             {
 509:             lp->rightp = fixtype( mkconv(ptype, lp->rightp) );
 510:             free(p);
 511:             p = lp;
 512:             }
 513:         break;
 514: 
 515:     case OPADDR:
 516:         if(lp->tag==TEXPR && lp->opcode==OPADDR)
 517:             fatal("addr of addr");
 518:         break;
 519: 
 520:     case OPCOMMA:
 521:     case OPQUEST:
 522:     case OPCOLON:
 523:         break;
 524: 
 525:     case OPMIN:
 526:     case OPMAX:
 527:         ptype = p->vtype;
 528:         break;
 529: 
 530:     default:
 531:         break;
 532:     }
 533: 
 534: p->vtype = ptype;
 535: return(p);
 536: }
 537: 
 538: #if SZINT < SZLONG
 539: /*
 540:    for efficient subscripting, replace long ints by shorts
 541:    in easy places
 542: */
 543: 
 544: expptr shorten(p)
 545: register expptr p;
 546: {
 547: register expptr q;
 548: 
 549: if(p->vtype != TYLONG)
 550:     return(p);
 551: 
 552: switch(p->tag)
 553:     {
 554:     case TERROR:
 555:     case TLIST:
 556:         return(p);
 557: 
 558:     case TCONST:
 559:     case TADDR:
 560:         return( mkconv(TYINT,p) );
 561: 
 562:     case TEXPR:
 563:         break;
 564: 
 565:     default:
 566:         fatal1("shorten: invalid tag %d", p->tag);
 567:     }
 568: 
 569: switch(p->opcode)
 570:     {
 571:     case OPPLUS:
 572:     case OPMINUS:
 573:     case OPSTAR:
 574:         q = shorten( cpexpr(p->rightp) );
 575:         if(q->vtype == TYINT)
 576:             {
 577:             p->leftp = shorten(p->leftp);
 578:             if(p->leftp->vtype == TYLONG)
 579:                 frexpr(q);
 580:             else
 581:                 {
 582:                 frexpr(p->rightp);
 583:                 p->rightp = q;
 584:                 p->vtype = TYINT;
 585:                 }
 586:             }
 587:         break;
 588: 
 589:     case OPNEG:
 590:         p->leftp = shorten(p->leftp);
 591:         if(p->leftp->vtype == TYINT)
 592:             p->vtype = TYINT;
 593:         break;
 594: 
 595:     case OPCALL:
 596:     case OPCCALL:
 597:         p = mkconv(TYINT,p);
 598:         break;
 599:     default:
 600:         break;
 601:     }
 602: 
 603: return(p);
 604: }
 605: #endif
 606: 
 607: fixargs(doput, p0)
 608: int doput;
 609: struct listblock *p0;
 610: {
 611: register chainp p;
 612: register tagptr q, t;
 613: register int qtag;
 614: int nargs;
 615: struct addrblock *mkaddr();
 616: 
 617: nargs = 0;
 618: if(p0)
 619:     for(p = p0->listp ; p ; p = p->nextp)
 620:     {
 621:     ++nargs;
 622:     q = p->datap;
 623:     qtag = q->tag;
 624:     if(qtag == TCONST)
 625:         {
 626:         if(q->vtype == TYSHORT)
 627:             q = mkconv(tyint, q);
 628:         if(doput)
 629:             p->datap = putconst(q);
 630:         else
 631:             p->datap = q;
 632:         }
 633:     else if(qtag==TPRIM && q->argsp==0 && q->namep->vclass==CLPROC)
 634:         p->datap = mkaddr(q->namep);
 635:     else if(qtag==TPRIM && q->argsp==0 && q->namep->vdim!=NULL)
 636:         p->datap = mkscalar(q->namep);
 637:     else if(qtag==TPRIM && q->argsp==0 && q->namep->vdovar &&
 638:         (t = memversion(q->namep)) )
 639:             p->datap = fixtype(t);
 640:     else    p->datap = fixtype(q);
 641:     }
 642: return(nargs);
 643: }
 644: 
 645: 
 646: mkscalar(np)
 647: register struct nameblock *np;
 648: {
 649: register struct addrblock *ap;
 650: register struct dimblock *dp;
 651: 
 652: vardcl(np);
 653: ap = mkaddr(np);
 654: 
 655: #if TARGET == VAX
 656:     /* on the VAX, prolog causes array arguments
 657: 	   to point at the (0,...,0) element, except when
 658: 	   subscript checking is on
 659: 	*/
 660:     if( !checksubs && np->vstg==STGARG)
 661:         {
 662:         dp = np->vdim;
 663:         frexpr(ap->memoffset);
 664:         ap->memoffset = mkexpr(OPSTAR, ICON(typesize[np->vtype]),
 665:                     cpexpr(dp->baseoffset) );
 666:         }
 667: #endif
 668: return(ap);
 669: }
 670: 
 671: 
 672: 
 673: 
 674: 
 675: expptr mkfunct(p)
 676: register struct primblock * p;
 677: {
 678: struct entrypoint *ep;
 679: struct addrblock *ap;
 680: struct extsym *mkext(), *extp;
 681: register struct nameblock *np;
 682: register struct exprblock *q;
 683: struct exprblock *intrcall(), *stfcall();
 684: int k, nargs;
 685: int class;
 686: 
 687: np = p->namep;
 688: class = np->vclass;
 689: 
 690: if(class == CLUNKNOWN)
 691:     {
 692:     np->vclass = class = CLPROC;
 693:     if(np->vstg == STGUNKNOWN)
 694:         {
 695:         if(k = intrfunct(np->varname))
 696:             {
 697:             np->vstg = STGINTR;
 698:             np->vardesc.varno = k;
 699:             np->vprocclass = PINTRINSIC;
 700:             }
 701:         else
 702:             {
 703:             extp = mkext( varunder(VL,np->varname) );
 704:             extp->extstg = STGEXT;
 705:             np->vstg = STGEXT;
 706:             np->vardesc.varno = extp - extsymtab;
 707:             np->vprocclass = PEXTERNAL;
 708:             }
 709:         }
 710:     else if(np->vstg==STGARG)
 711:         {
 712:         if(np->vtype!=TYCHAR && !ftn66flag)
 713:             warn("Dummy procedure not declared EXTERNAL. Code may be wrong.");
 714:         np->vprocclass = PEXTERNAL;
 715:         }
 716:     }
 717: 
 718: if(class != CLPROC)
 719:     fatal1("invalid class code for function", class);
 720: if(p->fcharp || p->lcharp)
 721:     {
 722:     err("no substring of function call");
 723:     goto error;
 724:     }
 725: impldcl(np);
 726: nargs = fixargs( np->vprocclass!=PINTRINSIC,  p->argsp);
 727: 
 728: switch(np->vprocclass)
 729:     {
 730:     case PEXTERNAL:
 731:         ap = mkaddr(np);
 732:     call:
 733:         q = mkexpr(OPCALL, ap, p->argsp);
 734:         q->vtype = np->vtype;
 735:         if(np->vleng)
 736:             q->vleng = cpexpr(np->vleng);
 737:         break;
 738: 
 739:     case PINTRINSIC:
 740:         q = intrcall(np, p->argsp, nargs);
 741:         break;
 742: 
 743:     case PSTFUNCT:
 744:         q = stfcall(np, p->argsp);
 745:         break;
 746: 
 747:     case PTHISPROC:
 748:         warn("recursive call");
 749:         for(ep = entries ; ep ; ep = ep->nextp)
 750:             if(ep->enamep == np)
 751:                 break;
 752:         if(ep == NULL)
 753:             fatal("mkfunct: impossible recursion");
 754:         ap = builtin(np->vtype, varstr(XL, ep->entryname->extname) );
 755:         goto call;
 756: 
 757:     default:
 758:         fatal1("mkfunct: impossible vprocclass %d", np->vprocclass);
 759:     }
 760: free(p);
 761: return(q);
 762: 
 763: error:
 764:     frexpr(p);
 765:     return( errnode() );
 766: }
 767: 
 768: 
 769: 
 770: LOCAL struct exprblock *stfcall(np, actlist)
 771: struct nameblock *np;
 772: struct listblock *actlist;
 773: {
 774: register chainp actuals;
 775: int nargs;
 776: chainp oactp, formals;
 777: int type;
 778: struct exprblock *q, *rhs;
 779: expptr ap;
 780: register struct rplblock *rp;
 781: struct rplblock *tlist;
 782: 
 783: if(actlist)
 784:     {
 785:     actuals = actlist->listp;
 786:     free(actlist);
 787:     }
 788: else
 789:     actuals = NULL;
 790: oactp = actuals;
 791: 
 792: nargs = 0;
 793: tlist = NULL;
 794: type = np->vtype;
 795: formals = np->vardesc.vstfdesc->datap;
 796: rhs = np->vardesc.vstfdesc->nextp;
 797: 
 798: /* copy actual arguments into temporaries */
 799: while(actuals!=NULL && formals!=NULL)
 800:     {
 801:     rp = ALLOC(rplblock);
 802:     rp->rplnp = q = formals->datap;
 803:     ap = fixtype(actuals->datap);
 804:     if(q->vtype==ap->vtype && q->vtype!=TYCHAR
 805:        && (ap->tag==TCONST || ap->tag==TADDR) )
 806:         {
 807:         rp->rplvp = ap;
 808:         rp->rplxp = NULL;
 809:         rp->rpltag = ap->tag;
 810:         }
 811:     else    {
 812:         rp->rplvp = mktemp(q->vtype, q->vleng);
 813:         rp->rplxp = fixtype( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap) );
 814:         if( (rp->rpltag = rp->rplxp->tag) == TERROR)
 815:             err("disagreement of argument types in statement function call");
 816:         }
 817:     rp->nextp = tlist;
 818:     tlist = rp;
 819:     actuals = actuals->nextp;
 820:     formals = formals->nextp;
 821:     ++nargs;
 822:     }
 823: 
 824: if(actuals!=NULL || formals!=NULL)
 825:     err("statement function definition and argument list differ");
 826: 
 827: /*
 828:    now push down names involved in formal argument list, then
 829:    evaluate rhs of statement function definition in this environment
 830: */
 831: rpllist = hookup(tlist, rpllist);
 832: q = mkconv(type, fixtype(cpexpr(rhs)) );
 833: 
 834: /* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
 835: while(--nargs >= 0)
 836:     {
 837:     if(rpllist->rplxp)
 838:         q = mkexpr(OPCOMMA, rpllist->rplxp, q);
 839:     rp = rpllist->nextp;
 840:     frexpr(rpllist->rplvp);
 841:     free(rpllist);
 842:     rpllist = rp;
 843:     }
 844: 
 845: frchain( &oactp );
 846: return(q);
 847: }
 848: 
 849: 
 850: 
 851: 
 852: struct addrblock *mklhs(p)
 853: register struct primblock * p;
 854: {
 855: register struct addrblock *s;
 856: expptr suboffset();
 857: struct nameblock *np;
 858: register struct rplblock *rp;
 859: int regn;
 860: 
 861: /* first fixup name */
 862: 
 863: if(p->tag != TPRIM)
 864:     return(p);
 865: np = p->namep;
 866: 
 867: /* is name on the replace list? */
 868: 
 869: for(rp = rpllist ; rp ; rp = rp->nextp)
 870:     {
 871:     if(np == rp->rplnp)
 872:         {
 873:         if(rp->rpltag == TNAME)
 874:             {
 875:             np = p->namep = rp->rplvp;
 876:             break;
 877:             }
 878:         else    return( cpexpr(rp->rplvp) );
 879:         }
 880:     }
 881: 
 882: /* is variable a DO index in a register ? */
 883: 
 884: if(np->vdovar && ( (regn = inregister(np)) >= 0) )
 885:     if(np->vtype == TYERROR)
 886:         return( errnode() );
 887:     else
 888:         {
 889:         s = ALLOC(addrblock);
 890:         s->tag = TADDR;
 891:         s->vstg = STGREG;
 892:         s->vtype = TYIREG;
 893:         s->memno = regn;
 894:         s->memoffset = ICON(0);
 895:         return(s);
 896:         }
 897: 
 898: vardcl(np);
 899: s = mkaddr(np);
 900: s->memoffset = mkexpr(OPPLUS, s->memoffset, suboffset(p) );
 901: frexpr(p->argsp);
 902: p->argsp = NULL;
 903: 
 904: /* now do substring part */
 905: 
 906: if(p->fcharp || p->lcharp)
 907:     {
 908:     if(np->vtype != TYCHAR)
 909:         err1("substring of noncharacter %s", varstr(VL,np->varname));
 910:     else    {
 911:         if(p->lcharp == NULL)
 912:             p->lcharp = cpexpr(s->vleng);
 913:         if(p->fcharp)
 914:             s->vleng = mkexpr(OPMINUS, p->lcharp,
 915:                 mkexpr(OPMINUS, p->fcharp, ICON(1) ));
 916:         else    {
 917:             frexpr(s->vleng);
 918:             s->vleng = p->lcharp;
 919:             }
 920:         }
 921:     }
 922: 
 923: s->vleng = fixtype( s->vleng );
 924: s->memoffset = fixtype( s->memoffset );
 925: free(p);
 926: return(s);
 927: }
 928: 
 929: 
 930: 
 931: 
 932: 
 933: deregister(np)
 934: struct nameblock *np;
 935: {
 936: if(nregvar>0 && regnamep[nregvar-1]==np)
 937:     {
 938:     --nregvar;
 939: #if FAMILY == DMR
 940:     putnreg();
 941: #endif
 942:     }
 943: }
 944: 
 945: 
 946: 
 947: 
 948: struct addrblock *memversion(np)
 949: register struct nameblock *np;
 950: {
 951: register struct addrblock *s;
 952: 
 953: if(np->vdovar==NO || (inregister(np)<0) )
 954:     return(NULL);
 955: np->vdovar = NO;
 956: s = mklhs( mkprim(np, 0,0,0) );
 957: np->vdovar = YES;
 958: return(s);
 959: }
 960: 
 961: 
 962: 
 963: inregister(np)
 964: register struct nameblock *np;
 965: {
 966: register int i;
 967: 
 968: for(i = 0 ; i < nregvar ; ++i)
 969:     if(regnamep[i] == np)
 970:         return( regnum[i] );
 971: return(-1);
 972: }
 973: 
 974: 
 975: 
 976: 
 977: enregister(np)
 978: struct nameblock *np;
 979: {
 980: if( inregister(np) >= 0)
 981:     return(YES);
 982: if(nregvar >= maxregvar)
 983:     return(NO);
 984: vardcl(np);
 985: if( ONEOF(np->vtype, MSKIREG) )
 986:     {
 987:     regnamep[nregvar++] = np;
 988:     if(nregvar > highregvar)
 989:         highregvar = nregvar;
 990: #if FAMILY == DMR
 991:     putnreg();
 992: #endif
 993:     return(YES);
 994:     }
 995: else
 996:     return(NO);
 997: }
 998: 
 999: 
1000: 
1001: 
1002: expptr suboffset(p)
1003: register struct primblock *p;
1004: {
1005: int n;
1006: expptr size;
1007: chainp cp;
1008: expptr offp, prod;
1009: expptr subcheck();
1010: struct dimblock *dimp;
1011: expptr sub[8];
1012: register struct nameblock *np;
1013: 
1014: np = p->namep;
1015: offp = ICON(0);
1016: n = 0;
1017: if(p->argsp)
1018:     for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
1019:         {
1020:         sub[n++] = fixtype(cpexpr(cp->datap));
1021:         if(n > 7)
1022:             {
1023:             err("more than 7 subscripts");
1024:             break;
1025:             }
1026:         }
1027: 
1028: dimp = np->vdim;
1029: if(n>0 && dimp==NULL)
1030:     err("subscripts on scalar variable");
1031: else if(dimp && dimp->ndim!=n)
1032:     err1("wrong number of subscripts on %s",
1033:         varstr(VL, np->varname) );
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:     err1("subscript on variable %s out of range", varstr(VL,np->varname));
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: fatal1("mkaddr: impossible storage tag %d", p->vstg);
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:         err1("no qualifiers on parameter name", varstr(VL,v->varname));
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:     dclerr("used as variable", v);
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:                 dclerr("adjustable automatic array", v);
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:         dclerr("attempt to use undefined variable", p);
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 error;
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:             err("attempted division by zero");
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:         fatal1("mkexpr: impossible opcode %d", opcode);
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: error:
1528:     frexpr(lp);
1529:     if(rp && opcode!=OPCALL && opcode!=OPCCALL)
1530:         frexpr(rp);
1531:     return( errnode() );
1532: }
1533: 
1534: #define ERR(s)   { errs = s; goto error; }
1535: 
1536: cktype(op, lt, rt)
1537: register int op, lt, rt;
1538: {
1539: char *errs;
1540: 
1541: if(lt==TYERROR || rt==TYERROR)
1542:     goto error1;
1543: 
1544: if(lt==TYUNKNOWN)
1545:     return(TYUNKNOWN);
1546: if(rt==TYUNKNOWN)
1547:     if(op!=OPNOT && op!=OPBITNOT && op!=OPNEG && op!=OPCALL && op!=OPCCALL && op!=OPADDR)
1548:         return(TYUNKNOWN);
1549: 
1550: switch(op)
1551:     {
1552:     case OPPLUS:
1553:     case OPMINUS:
1554:     case OPSTAR:
1555:     case OPSLASH:
1556:     case OPPOWER:
1557:     case OPMOD:
1558:         if( ISNUMERIC(lt) && ISNUMERIC(rt) )
1559:             return( maxtype(lt, rt) );
1560:         ERR("nonarithmetic operand of arithmetic operator")
1561: 
1562:     case OPNEG:
1563:         if( ISNUMERIC(lt) )
1564:             return(lt);
1565:         ERR("nonarithmetic operand of negation")
1566: 
1567:     case OPNOT:
1568:         if(lt == TYLOGICAL)
1569:             return(TYLOGICAL);
1570:         ERR("NOT of nonlogical")
1571: 
1572:     case OPAND:
1573:     case OPOR:
1574:     case OPEQV:
1575:     case OPNEQV:
1576:         if(lt==TYLOGICAL && rt==TYLOGICAL)
1577:             return(TYLOGICAL);
1578:         ERR("nonlogical operand of logical operator")
1579: 
1580:     case OPLT:
1581:     case OPGT:
1582:     case OPLE:
1583:     case OPGE:
1584:     case OPEQ:
1585:     case OPNE:
1586:         if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
1587:             {
1588:             if(lt != rt)
1589:                 ERR("illegal comparison")
1590:             }
1591: 
1592:         else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
1593:             {
1594:             if(op!=OPEQ && op!=OPNE)
1595:                 ERR("order comparison of complex data")
1596:             }
1597: 
1598:         else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
1599:             ERR("comparison of nonarithmetic data")
1600:         return(TYLOGICAL);
1601: 
1602:     case OPCONCAT:
1603:         if(lt==TYCHAR && rt==TYCHAR)
1604:             return(TYCHAR);
1605:         ERR("concatenation of nonchar data")
1606: 
1607:     case OPCALL:
1608:     case OPCCALL:
1609:         return(lt);
1610: 
1611:     case OPADDR:
1612:         return(TYADDR);
1613: 
1614:     case OPCONV:
1615:         if(rt == 0)
1616:             return(0);
1617:         if(lt==TYCHAR && ISINT(rt) )
1618:             return(TYCHAR);
1619:     case OPASSIGN:
1620:     case OPPLUSEQ:
1621:     case OPSTAREQ:
1622:         if( ISINT(lt) && rt==TYCHAR)
1623:             return(lt);
1624:         if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
1625:             if(op!=OPASSIGN || lt!=rt)
1626:                 {
1627: /* debug fprintf(diagfile, " lt=%d, rt=%d, op=%d\n", lt, rt, op); */
1628: /* debug fatal("impossible conversion.  possible compiler bug"); */
1629:                 ERR("impossible conversion")
1630:                 }
1631:         return(lt);
1632: 
1633:     case OPMIN:
1634:     case OPMAX:
1635:     case OPBITOR:
1636:     case OPBITAND:
1637:     case OPBITXOR:
1638:     case OPBITNOT:
1639:     case OPLSHIFT:
1640:     case OPRSHIFT:
1641:         return(lt);
1642: 
1643:     case OPCOMMA:
1644:     case OPQUEST:
1645:     case OPCOLON:
1646:         return(rt);
1647: 
1648:     default:
1649:         fatal1("cktype: impossible opcode %d", op);
1650:     }
1651: error:  err(errs);
1652: error1: return(TYERROR);
1653: }
1654: 
1655: LOCAL expptr fold(e)
1656: register struct exprblock *e;
1657: {
1658: struct constblock *p;
1659: #ifdef VERSION6
1660:     expptr lp, rp;
1661: #else
1662:     register expptr lp, rp;
1663: #endif
1664: int etype, mtype, ltype, rtype, opcode;
1665: int i, ll, lr;
1666: char *q, *s;
1667: union constant lcon, rcon;
1668: 
1669: opcode = e->opcode;
1670: etype = e->vtype;
1671: 
1672: lp = e->leftp;
1673: ltype = lp->vtype;
1674: rp = e->rightp;
1675: 
1676: if(rp == 0)
1677:     switch(opcode)
1678:         {
1679:         case OPNOT:
1680:             lp->const.ci = ! lp->const.ci;
1681:             return(lp);
1682: 
1683:         case OPBITNOT:
1684:             lp->const.ci = ~ lp->const.ci;
1685:             return(lp);
1686: 
1687:         case OPNEG:
1688:             consnegop(lp);
1689:             return(lp);
1690: 
1691:         case OPCONV:
1692:         case OPADDR:
1693:             return(e);
1694: 
1695:         default:
1696:             fatal1("fold: invalid unary operator %d", opcode);
1697:         }
1698: 
1699: rtype = rp->vtype;
1700: 
1701: p = ALLOC(constblock);
1702: p->tag = TCONST;
1703: p->vtype = etype;
1704: p->vleng = e->vleng;
1705: 
1706: switch(opcode)
1707:     {
1708:     case OPCOMMA:
1709:     case OPQUEST:
1710:     case OPCOLON:
1711:         return(e);
1712: 
1713:     case OPAND:
1714:         p->const.ci = lp->const.ci && rp->const.ci;
1715:         break;
1716: 
1717:     case OPOR:
1718:         p->const.ci = lp->const.ci || rp->const.ci;
1719:         break;
1720: 
1721:     case OPEQV:
1722:         p->const.ci = lp->const.ci == rp->const.ci;
1723:         break;
1724: 
1725:     case OPNEQV:
1726:         p->const.ci = lp->const.ci != rp->const.ci;
1727:         break;
1728: 
1729:     case OPBITAND:
1730:         p->const.ci = lp->const.ci & rp->const.ci;
1731:         break;
1732: 
1733:     case OPBITOR:
1734:         p->const.ci = lp->const.ci | rp->const.ci;
1735:         break;
1736: 
1737:     case OPBITXOR:
1738:         p->const.ci = lp->const.ci ^ rp->const.ci;
1739:         break;
1740: 
1741:     case OPLSHIFT:
1742:         p->const.ci = lp->const.ci << rp->const.ci;
1743:         break;
1744: 
1745:     case OPRSHIFT:
1746:         p->const.ci = lp->const.ci >> rp->const.ci;
1747:         break;
1748: 
1749:     case OPCONCAT:
1750:         ll = lp->vleng->const.ci;
1751:         lr = rp->vleng->const.ci;
1752:         p->const.ccp = q = (char *) ckalloc(ll+lr);
1753:         p->vleng = ICON(ll+lr);
1754:         s = lp->const.ccp;
1755:         for(i = 0 ; i < ll ; ++i)
1756:             *q++ = *s++;
1757:         s = rp->const.ccp;
1758:         for(i = 0; i < lr; ++i)
1759:             *q++ = *s++;
1760:         break;
1761: 
1762: 
1763:     case OPPOWER:
1764:         if( ! ISINT(rtype) )
1765:             return(e);
1766:         conspower(&(p->const), lp, rp->const.ci);
1767:         break;
1768: 
1769: 
1770:     default:
1771:         if(ltype == TYCHAR)
1772:             {
1773:             lcon.ci = cmpstr(lp->const.ccp, rp->const.ccp,
1774:                     lp->vleng->const.ci, rp->vleng->const.ci);
1775:             rcon.ci = 0;
1776:             mtype = tyint;
1777:             }
1778:         else    {
1779:             mtype = maxtype(ltype, rtype);
1780:             consconv(mtype, &lcon, ltype, &(lp->const) );
1781:             consconv(mtype, &rcon, rtype, &(rp->const) );
1782:             }
1783:         consbinop(opcode, mtype, &(p->const), &lcon, &rcon);
1784:         break;
1785:     }
1786: 
1787: frexpr(e);
1788: return(p);
1789: }
1790: 
1791: 
1792: 
1793: /* assign constant l = r , doing coercion */
1794: 
1795: consconv(lt, lv, rt, rv)
1796: int lt, rt;
1797: register union constant *lv, *rv;
1798: {
1799: switch(lt)
1800:     {
1801:     case TYCHAR:
1802:         *(lv->ccp = ckalloc(1)) = rv->ci;
1803:         break;
1804: 
1805:     case TYSHORT:
1806:     case TYLONG:
1807:         if(rt == TYCHAR)
1808:             lv->ci = rv->ccp[0];
1809:         else if( ISINT(rt) )
1810:             lv->ci = rv->ci;
1811:         else    lv->ci = rv->cd[0];
1812:         break;
1813: 
1814:     case TYCOMPLEX:
1815:     case TYDCOMPLEX:
1816:         switch(rt)
1817:             {
1818:             case TYSHORT:
1819:             case TYLONG:
1820:                 /* fall through and do real assignment of
1821: 				   first element
1822: 				*/
1823:             case TYREAL:
1824:             case TYDREAL:
1825:                 lv->cd[1] = 0; break;
1826:             case TYCOMPLEX:
1827:             case TYDCOMPLEX:
1828:                 lv->cd[1] = rv->cd[1]; break;
1829:             }
1830: 
1831:     case TYREAL:
1832:     case TYDREAL:
1833:         if( ISINT(rt) )
1834:             lv->cd[0] = rv->ci;
1835:         else    lv->cd[0] = rv->cd[0];
1836:         break;
1837: 
1838:     case TYLOGICAL:
1839:         lv->ci = rv->ci;
1840:         break;
1841:     }
1842: }
1843: 
1844: 
1845: 
1846: consnegop(p)
1847: register struct constblock *p;
1848: {
1849: switch(p->vtype)
1850:     {
1851:     case TYSHORT:
1852:     case TYLONG:
1853:         p->const.ci = - p->const.ci;
1854:         break;
1855: 
1856:     case TYCOMPLEX:
1857:     case TYDCOMPLEX:
1858:         p->const.cd[1] = - p->const.cd[1];
1859:         /* fall through and do the real parts */
1860:     case TYREAL:
1861:     case TYDREAL:
1862:         p->const.cd[0] = - p->const.cd[0];
1863:         break;
1864:     default:
1865:         fatal1("consnegop: impossible type %d", p->vtype);
1866:     }
1867: }
1868: 
1869: 
1870: 
1871: LOCAL conspower(powp, ap, n)
1872: register union constant *powp;
1873: struct constblock *ap;
1874: ftnint n;
1875: {
1876: register int type;
1877: union constant x;
1878: 
1879: switch(type = ap->vtype)    /* pow = 1 */
1880:     {
1881:     case TYSHORT:
1882:     case TYLONG:
1883:         powp->ci = 1;
1884:         break;
1885:     case TYCOMPLEX:
1886:     case TYDCOMPLEX:
1887:         powp->cd[1] = 0;
1888:     case TYREAL:
1889:     case TYDREAL:
1890:         powp->cd[0] = 1;
1891:         break;
1892:     default:
1893:         fatal1("conspower: invalid type %d", type);
1894:     }
1895: 
1896: if(n == 0)
1897:     return;
1898: if(n < 0)
1899:     {
1900:     if( ISINT(type) )
1901:         {
1902:         err("integer ** negative power ");
1903:         return;
1904:         }
1905:     n = - n;
1906:     consbinop(OPSLASH, type, &x, powp, &(ap->const));
1907:     }
1908: else
1909:     consbinop(OPSTAR, type, &x, powp, &(ap->const));
1910: 
1911: for( ; ; )
1912:     {
1913:     if(n & 01)
1914:         consbinop(OPSTAR, type, powp, powp, &x);
1915:     if(n >>= 1)
1916:         consbinop(OPSTAR, type, &x, &x, &x);
1917:     else
1918:         break;
1919:     }
1920: }
1921: 
1922: 
1923: 
1924: /* do constant operation cp = a op b */
1925: 
1926: 
1927: LOCAL consbinop(opcode, type, cp, ap, bp)
1928: int opcode, type;
1929: register union constant *ap, *bp, *cp;
1930: {
1931: int k;
1932: double temp;
1933: 
1934: switch(opcode)
1935:     {
1936:     case OPPLUS:
1937:         switch(type)
1938:             {
1939:             case TYSHORT:
1940:             case TYLONG:
1941:                 cp->ci = ap->ci + bp->ci;
1942:                 break;
1943:             case TYCOMPLEX:
1944:             case TYDCOMPLEX:
1945:                 cp->cd[1] = ap->cd[1] + bp->cd[1];
1946:             case TYREAL:
1947:             case TYDREAL:
1948:                 cp->cd[0] = ap->cd[0] + bp->cd[0];
1949:                 break;
1950:             }
1951:         break;
1952: 
1953:     case OPMINUS:
1954:         switch(type)
1955:             {
1956:             case TYSHORT:
1957:             case TYLONG:
1958:                 cp->ci = ap->ci - bp->ci;
1959:                 break;
1960:             case TYCOMPLEX:
1961:             case TYDCOMPLEX:
1962:                 cp->cd[1] = ap->cd[1] - bp->cd[1];
1963:             case TYREAL:
1964:             case TYDREAL:
1965:                 cp->cd[0] = ap->cd[0] - bp->cd[0];
1966:                 break;
1967:             }
1968:         break;
1969: 
1970:     case OPSTAR:
1971:         switch(type)
1972:             {
1973:             case TYSHORT:
1974:             case TYLONG:
1975:                 cp->ci = ap->ci * bp->ci;
1976:                 break;
1977:             case TYREAL:
1978:             case TYDREAL:
1979:                 cp->cd[0] = ap->cd[0] * bp->cd[0];
1980:                 break;
1981:             case TYCOMPLEX:
1982:             case TYDCOMPLEX:
1983:                 temp = ap->cd[0] * bp->cd[0] -
1984:                         ap->cd[1] * bp->cd[1] ;
1985:                 cp->cd[1] = ap->cd[0] * bp->cd[1] +
1986:                         ap->cd[1] * bp->cd[0] ;
1987:                 cp->cd[0] = temp;
1988:                 break;
1989:             }
1990:         break;
1991:     case OPSLASH:
1992:         switch(type)
1993:             {
1994:             case TYSHORT:
1995:             case TYLONG:
1996:                 cp->ci = ap->ci / bp->ci;
1997:                 break;
1998:             case TYREAL:
1999:             case TYDREAL:
2000:                 cp->cd[0] = ap->cd[0] / bp->cd[0];
2001:                 break;
2002:             case TYCOMPLEX:
2003:             case TYDCOMPLEX:
2004:                 zdiv(cp,ap,bp);
2005:                 break;
2006:             }
2007:         break;
2008: 
2009:     case OPMOD:
2010:         if( ISINT(type) )
2011:             {
2012:             cp->ci = ap->ci % bp->ci;
2013:             break;
2014:             }
2015:         else
2016:             fatal("inline mod of noninteger");
2017: 
2018:     default:      /* relational ops */
2019:         switch(type)
2020:             {
2021:             case TYSHORT:
2022:             case TYLONG:
2023:                 if(ap->ci < bp->ci)
2024:                     k = -1;
2025:                 else if(ap->ci == bp->ci)
2026:                     k = 0;
2027:                 else    k = 1;
2028:                 break;
2029:             case TYREAL:
2030:             case TYDREAL:
2031:                 if(ap->cd[0] < bp->cd[0])
2032:                     k = -1;
2033:                 else if(ap->cd[0] == bp->cd[0])
2034:                     k = 0;
2035:                 else    k = 1;
2036:                 break;
2037:             case TYCOMPLEX:
2038:             case TYDCOMPLEX:
2039:                 if(ap->cd[0] == bp->cd[0] &&
2040:                    ap->cd[1] == bp->cd[1] )
2041:                     k = 0;
2042:                 else    k = 1;
2043:                 break;
2044:             }
2045: 
2046:         switch(opcode)
2047:             {
2048:             case OPEQ:
2049:                 cp->ci = (k == 0);
2050:                 break;
2051:             case OPNE:
2052:                 cp->ci = (k != 0);
2053:                 break;
2054:             case OPGT:
2055:                 cp->ci = (k == 1);
2056:                 break;
2057:             case OPLT:
2058:                 cp->ci = (k == -1);
2059:                 break;
2060:             case OPGE:
2061:                 cp->ci = (k >= 0);
2062:                 break;
2063:             case OPLE:
2064:                 cp->ci = (k <= 0);
2065:                 break;
2066:             }
2067:         break;
2068:     }
2069: }
2070: 
2071: 
2072: 
2073: 
2074: conssgn(p)
2075: register expptr p;
2076: {
2077: if( ! ISCONST(p) )
2078:     fatal( "sgn(nonconstant)" );
2079: 
2080: switch(p->vtype)
2081:     {
2082:     case TYSHORT:
2083:     case TYLONG:
2084:         if(p->const.ci > 0) return(1);
2085:         if(p->const.ci < 0) return(-1);
2086:         return(0);
2087: 
2088:     case TYREAL:
2089:     case TYDREAL:
2090:         if(p->const.cd[0] > 0) return(1);
2091:         if(p->const.cd[0] < 0) return(-1);
2092:         return(0);
2093: 
2094:     case TYCOMPLEX:
2095:     case TYDCOMPLEX:
2096:         return(p->const.cd[0]!=0 || p->const.cd[1]!=0);
2097: 
2098:     default:
2099:         fatal1( "conssgn(type %d)", p->vtype);
2100:     }
2101: /* NOTREACHED */
2102: }
2103: 
2104: char *powint[ ] = { "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" };
2105: 
2106: 
2107: LOCAL expptr mkpower(p)
2108: register struct exprblock *p;
2109: {
2110: register expptr q, lp, rp;
2111: int ltype, rtype, mtype;
2112: 
2113: lp = p->leftp;
2114: rp = p->rightp;
2115: ltype = lp->vtype;
2116: rtype = rp->vtype;
2117: 
2118: if(ISICON(rp))
2119:     {
2120:     if(rp->const.ci == 0)
2121:         {
2122:         frexpr(p);
2123:         if( ISINT(ltype) )
2124:             return( ICON(1) );
2125:         else
2126:             return( putconst( mkconv(ltype, ICON(1))) );
2127:         }
2128:     if(rp->const.ci < 0)
2129:         {
2130:         if( ISINT(ltype) )
2131:             {
2132:             frexpr(p);
2133:             err("integer**negative");
2134:             return( errnode() );
2135:             }
2136:         rp->const.ci = - rp->const.ci;
2137:         p->leftp = lp = fixexpr(mkexpr(OPSLASH, ICON(1), lp));
2138:         }
2139:     if(rp->const.ci == 1)
2140:         {
2141:         frexpr(rp);
2142:         free(p);
2143:         return(lp);
2144:         }
2145: 
2146:     if( ONEOF(ltype, MSKINT|MSKREAL) )
2147:         {
2148:         p->vtype = ltype;
2149:         return(p);
2150:         }
2151:     }
2152: if( ISINT(rtype) )
2153:     {
2154:     if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
2155:         q = call2(TYSHORT, "pow_hh", lp, rp);
2156:     else    {
2157:         if(ltype == TYSHORT)
2158:             {
2159:             ltype = TYLONG;
2160:             lp = mkconv(TYLONG,lp);
2161:             }
2162:         q = call2(ltype, powint[ltype-TYLONG], lp, mkconv(TYLONG, rp));
2163:         }
2164:     }
2165: else if( ISREAL( (mtype = maxtype(ltype,rtype)) ))
2166:     q = call2(mtype, "pow_dd",
2167:         mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
2168: else    {
2169:     q = call2(TYDCOMPLEX, "pow_zz",
2170:         mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
2171:     if(mtype == TYCOMPLEX)
2172:         q = mkconv(TYCOMPLEX, q);
2173:     }
2174: free(p);
2175: return(q);
2176: }
2177: 
2178: 
2179: 
2180: /* Complex Division.  Same code as in Runtime Library
2181: */
2182: 
2183: struct dcomplex { double dreal, dimag; };
2184: 
2185: 
2186: LOCAL zdiv(c, a, b)
2187: register struct dcomplex *a, *b, *c;
2188: {
2189: double ratio, den;
2190: double abr, abi;
2191: 
2192: if( (abr = b->dreal) < 0.)
2193:     abr = - abr;
2194: if( (abi = b->dimag) < 0.)
2195:     abi = - abi;
2196: if( abr <= abi )
2197:     {
2198:     if(abi == 0)
2199:         fatal("complex division by zero");
2200:     ratio = b->dreal / b->dimag ;
2201:     den = b->dimag * (1 + ratio*ratio);
2202:     c->dreal = (a->dreal*ratio + a->dimag) / den;
2203:     c->dimag = (a->dimag*ratio - a->dreal) / den;
2204:     }
2205: 
2206: else
2207:     {
2208:     ratio = b->dimag / b->dreal ;
2209:     den = b->dreal * (1 + ratio*ratio);
2210:     c->dreal = (a->dreal + a->dimag*ratio) / den;
2211:     c->dimag = (a->dimag - a->dreal*ratio) / den;
2212:     }
2213: 
2214: }

Defined functions

Defined variables

Defined struct's

Defined macros