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

   1: /*  INTERMEDIATE CODE GENERATION FOR D. M. RITCHIE C COMPILERS */
   2: #if FAMILY != DMR
   3:     WRONG put FILE !!!!
   4: #endif
   5: 
   6: #include "defs"
   7: #include "dmrdefs"
   8: 
   9: 
  10: extern int ops2[];
  11: extern int types2[];
  12: 
  13: 
  14: puthead(s, class)
  15: char *s;
  16: int class;
  17: {
  18: if( ! headerdone )
  19:     {
  20:     p2op2(P2SETREG, ARGREG-maxregvar);
  21:     p2op(P2PROG);
  22:     headerdone = YES;
  23: #if TARGET == PDP11
  24:     /* fake jump to start the optimizer */
  25:     if(class != CLBLOCK)
  26:         putgoto( fudgelabel = newlabel() );
  27: #endif
  28:     }
  29: }
  30: 
  31: 
  32: 
  33: 
  34: putnreg()
  35: {
  36: p2op2(P2SETREG, ARGREG-nregvar);
  37: }
  38: 
  39: 
  40: 
  41: 
  42: 
  43: 
  44: puteof()
  45: {
  46: p2op(P2EOF);
  47: }
  48: 
  49: 
  50: 
  51: putstmt()
  52: {
  53: p2op2(P2EXPR, lineno);
  54: }
  55: 
  56: 
  57: 
  58: 
  59: /* put out code for if( ! p) goto l  */
  60: putif(p,l)
  61: register expptr p;
  62: int l;
  63: {
  64: register int k;
  65: if( (k = (p = fixtype(p))->vtype) != TYLOGICAL)
  66:     {
  67:     if(k != TYERROR)
  68:         err("non-logical expression in IF statement");
  69:     frexpr(p);
  70:     }
  71: else
  72:     {
  73:     putex1(p);
  74:     p2op2(P2CBRANCH, l);
  75:     p2i(0);
  76:     p2i(lineno);
  77:     }
  78: }
  79: 
  80: 
  81: 
  82: 
  83: 
  84: /* put out code for  goto l   */
  85: putgoto(label)
  86: int label;
  87: {
  88: p2op2(P2GOTO, label);
  89: }
  90: 
  91: 
  92: /* branch to address constant or integer variable */
  93: putbranch(p)
  94: register struct addrblock *p;
  95: {
  96: register int type;
  97: 
  98: type = p->vtype;
  99: if(p->tag != TADDR)
 100:     fatal("invalid goto label");
 101: putaddr(p, YES);
 102: if(type != TYINT)
 103:     p2op2(P2LTOI, P2INT);
 104: p2op2(P2INDIRECT, P2INT);
 105: p2op2(P2JUMP, P2INT);
 106: putstmt();
 107: }
 108: 
 109: 
 110: 
 111: /* put out label  l:     */
 112: putlabel(label)
 113: int label;
 114: {
 115: p2op2(P2LABEL, label);
 116: }
 117: 
 118: 
 119: 
 120: 
 121: putexpr(p)
 122: expptr p;
 123: {
 124: putex1(p);
 125: putstmt();
 126: }
 127: 
 128: 
 129: 
 130: 
 131: 
 132: prarif(p, neg, zero, pos)
 133: expptr p;
 134: int neg ,zero, pos;
 135: {
 136: putx(p);
 137: p2op(P2ARIF);
 138: p2i(neg);
 139: p2i(zero);
 140: p2i(pos);
 141: p2i(lineno);
 142: }
 143: 
 144: 
 145: 
 146: putcmgo(index, nlab, labs)
 147: expptr index;
 148: int nlab;
 149: struct labelblock *labs[];
 150: {
 151: register int i;
 152: int skiplabel;
 153: 
 154: if(! ISINT(index->vtype) )
 155:     {
 156:     execerr("computed goto index must be integer", NULL);
 157:     return;
 158:     }
 159: 
 160: putforce(TYINT, mkconv(TYINT, index) );
 161: p2op(P2SWITCH);
 162: p2i(skiplabel = newlabel() );
 163: p2i(lineno);
 164: for(i = 0 ; i<nlab ; ++i)
 165:     {
 166:     p2i(labs[i]->labelno);
 167:     p2i(i+1);
 168:     }
 169: p2i(0);
 170: putlabel(skiplabel);
 171: }
 172: 
 173: putx(p)
 174: register expptr p;
 175: {
 176: struct addrblock *putcall(), *putcx1(), *realpart();
 177: char *memname();
 178: int opc;
 179: int type, ncomma;
 180: 
 181: switch(p->tag)
 182:     {
 183:     case TERROR:
 184:         free(p);
 185:         break;
 186: 
 187:     case TCONST:
 188:         switch(type = p->vtype)
 189:             {
 190:             case TYLOGICAL:
 191:                 type = tylogical;
 192:             case TYLONG:
 193:             case TYSHORT:
 194:                 if(type == TYSHORT)
 195:                     {
 196:                     p2op2(P2ICON, P2SHORT);
 197:                     p2i( (short)(p->const.ci) );
 198:                     }
 199:                 else
 200:                     {
 201:                     p2op2(P2LCON, P2LONG);
 202:                     p2li(p->const.ci);
 203:                     }
 204:                 free(p);
 205:                 break;
 206: 
 207:             case TYADDR:
 208:                 p2op(P2NAME);
 209:                 p2i(P2STATIC);
 210:                 p2i(P2INT);
 211:                 p2i( (int) p->const.ci);
 212:                 p2op2(P2ADDR, P2PTR);
 213:                 free(p);
 214:                 break;
 215: 
 216:             default:
 217:                 putx( putconst(p) );
 218:                 break;
 219:             }
 220:         break;
 221: 
 222:     case TEXPR:
 223:         switch(opc = p->opcode)
 224:             {
 225:             case OPCALL:
 226:             case OPCCALL:
 227:                 if( ISCOMPLEX(p->vtype) )
 228:                     putcxop(p);
 229:                 else    putcall(p);
 230:                 break;
 231: 
 232:             case OPMIN:
 233:             case OPMAX:
 234:                 putmnmx(p);
 235:                 break;
 236: 
 237: 
 238:             case OPASSIGN:
 239:                 if( ISCOMPLEX(p->leftp->vtype) || ISCOMPLEX(p->rightp->vtype) )
 240:                     frexpr( putcxeq(p) );
 241:                 else if( ISCHAR(p) )
 242:                     putcheq(p);
 243:                 else
 244:                     goto putopp;
 245:                 break;
 246: 
 247:             case OPEQ:
 248:             case OPNE:
 249:                 if( ISCOMPLEX(p->leftp->vtype) || ISCOMPLEX(p->rightp->vtype) )
 250:                     {
 251:                     putcxcmp(p);
 252:                     break;
 253:                     }
 254:             case OPLT:
 255:             case OPLE:
 256:             case OPGT:
 257:             case OPGE:
 258:                 if(ISCHAR(p->leftp))
 259:                     putchcmp(p);
 260:                 else
 261:                     goto putopp;
 262:                 break;
 263: 
 264:             case OPPOWER:
 265:                 putpower(p);
 266:                 break;
 267: 
 268:             case OPMOD:
 269:                 goto putopp;
 270:             case OPSTAR:
 271: 
 272:             case OPPLUS:
 273:             case OPMINUS:
 274:             case OPSLASH:
 275:             case OPNEG:
 276:                 if( ISCOMPLEX(p->vtype) )
 277:                     putcxop(p);
 278:                 else    goto putopp;
 279:                 break;
 280: 
 281:             case OPCONV:
 282:                 if( ISCOMPLEX(p->vtype) )
 283:                     putcxop(p);
 284:                 else if( ISCOMPLEX(p->leftp->vtype) )
 285:                     {
 286:                     ncomma = 0;
 287:                     putx( mkconv(p->vtype,
 288:                         realpart(putcx1(p->leftp, &ncomma))));
 289:                     putcomma(ncomma, p->vtype, NO);
 290:                     free(p);
 291:                     }
 292:                 else    goto putopp;
 293:                 break;
 294: 
 295:             case OPNOT:
 296:             case OPOR:
 297:             case OPAND:
 298:             case OPEQV:
 299:             case OPNEQV:
 300:             case OPADDR:
 301:             case OPPLUSEQ:
 302:             case OPSTAREQ:
 303:             case OPCOMMA:
 304:             case OPQUEST:
 305:             case OPCOLON:
 306:             case OPBITOR:
 307:             case OPBITAND:
 308:             case OPBITXOR:
 309:             case OPBITNOT:
 310:             case OPLSHIFT:
 311:             case OPRSHIFT:
 312:         putopp:
 313:                 putop(p);
 314:                 break;
 315: 
 316:             default:
 317:                 fatal1("putx: invalid opcode %d", opc);
 318:             }
 319:         break;
 320: 
 321:     case TADDR:
 322:         putaddr(p, YES);
 323:         break;
 324: 
 325:     default:
 326:         fatal1("putx: impossible tag %d", p->tag);
 327:     }
 328: }
 329: 
 330: 
 331: 
 332: LOCAL putop(p)
 333: register expptr p;
 334: {
 335: int k, ncomma;
 336: int type2, ptype, ltype;
 337: int convop;
 338: register expptr lp, tp;
 339: 
 340: switch(p->opcode)   /* check for special cases and rewrite */
 341:     {
 342: 
 343:     case OPCONV:
 344:         lp = p->leftp;
 345:         while(p->tag==TEXPR && p->opcode==OPCONV &&
 346:              (  ( (ptype = p->vtype) == (ltype = lp->vtype) ) ||
 347:              (ISREAL(ptype)&&ISREAL(ltype)) ||
 348:              (ONEOF(ptype, M(TYSHORT)|M(TYADDR)) &&
 349:             ONEOF(ltype, M(TYSHORT)|M(TYADDR))) ||
 350:                 (ptype==TYINT && ONEOF(ltype, M(TYSUBR)|M(TYCHAR))) ))
 351:                 {
 352:                 free(p);
 353:                 p = lp;
 354:                 lp = p->leftp;
 355:                 }
 356:         if(p->tag!=TEXPR || p->opcode!=OPCONV || ISCOMPLEX((ltype = lp->vtype)) )
 357:             {
 358:             putx(p);
 359:             return;
 360:             }
 361:         ltype = lp->vtype;
 362:         switch(ptype = p->vtype)
 363:             {
 364:             case TYCHAR:
 365:                 p->leftp = lp = mkconv(TYSHORT, lp);
 366:                 convop = P2ITOC;
 367:                 break;
 368: 
 369:             case TYSHORT:
 370:             case TYADDR:
 371:                 switch(ltype)
 372:                     {
 373:                     case TYLONG:
 374:                         convop = P2LTOI; break;
 375:                     case TYREAL:
 376:                     case TYDREAL:
 377:                         convop = P2FTOI; break;
 378:                     default:
 379:                         goto badconv;
 380:                     }
 381:                 break;
 382: 
 383:             case TYLONG:
 384:                 switch(ltype)
 385:                     {
 386:                     case TYCHAR:
 387:                     case TYSHORT:
 388:                     case TYADDR:
 389:                         convop = P2ITOL; break;
 390:                     case TYREAL:
 391:                     case TYDREAL:
 392:                         convop = P2FTOL; break;
 393:                     default:
 394:                         goto badconv;
 395:                     }
 396:                 break;
 397: 
 398:             case TYREAL:
 399:             case TYDREAL:
 400:                 switch(ltype)
 401:                     {
 402:                     case TYCHAR:
 403:                     case TYSHORT:
 404:                     case TYADDR:
 405:                         convop = P2ITOF; break;
 406:                     case TYLONG:
 407:                         convop = P2LTOF; break;
 408:                     default:
 409:                         goto badconv;
 410:                     }
 411:                 break;
 412: 
 413:             default:
 414:             badconv:
 415:                 fatal("putop: impossible conversion");
 416:             }
 417:         putx(lp);
 418:         p2op2(convop, types2[ptype]);
 419:         free(p);
 420:         return;
 421: 
 422:     case OPADDR:
 423:         lp = p->leftp;
 424:         if(lp->tag != TADDR)
 425:             {
 426:             tp = mktemp(lp->vtype, lp->vleng);
 427:             putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
 428:             ncomma = 1;
 429:             lp = tp;
 430:             }
 431:         else    ncomma = 0;
 432:         putaddr(lp, NO);
 433:         putcomma(ncomma, TYINT, NO);
 434:         free(p);
 435:         return;
 436: 
 437:     case OPASSIGN:
 438:         if(p->vtype==TYLOGICAL && tylogical!=TYINT &&
 439:            p->rightp->tag==TEXPR && p->rightp->opcode!=OPCALL && p->rightp->opcode!=OPCCALL)
 440:             {
 441:             p->rightp->vtype = TYINT;
 442:             p->rightp = mkconv(tylogical, p->rightp);
 443:             }
 444:         break;
 445:     }
 446: 
 447: if( (k = ops2[p->opcode]) <= 0)
 448:     fatal1("putop: invalid opcode %d", p->opcode);
 449: putx(p->leftp);
 450: if(p->rightp)
 451:     putx(p->rightp);
 452: type2 = (p->vtype==TYLOGICAL ? P2INT : types2[p->vtype]);
 453: p2op2(k, type2);
 454: 
 455: if(p->vleng)
 456:     frexpr(p->vleng);
 457: free(p);
 458: }
 459: 
 460: putforce(t, p)
 461: int t;
 462: expptr p;
 463: {
 464: p = mkconv(t, fixtype(p));
 465: putx(p);
 466: p2op2(P2FORCE, (t==TYSHORT ? P2SHORT : (t==TYLONG ? P2LONG : P2DREAL)) );
 467: putstmt();
 468: }
 469: 
 470: 
 471: 
 472: LOCAL putpower(p)
 473: expptr p;
 474: {
 475: expptr base;
 476: struct addrblock *t1, *t2;
 477: ftnint k;
 478: int type;
 479: int ncomma;
 480: 
 481: if(!ISICON(p->rightp) || (k = p->rightp->const.ci)<2)
 482:     fatal("putpower: bad call");
 483: base = p->leftp;
 484: type = base->vtype;
 485: t1 = mktemp(type, NULL);
 486: t2 = NULL;
 487: ncomma = 1;
 488: putassign(cpexpr(t1), cpexpr(base) );
 489: 
 490: for( ; (k&1)==0 && k>2 ; k>>=1 )
 491:     {
 492:     ++ncomma;
 493:     putsteq(t1, t1);
 494:     }
 495: 
 496: if(k == 2)
 497:     putx( mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) );
 498: else
 499:     {
 500:     t2 = mktemp(type, NULL);
 501:     ++ncomma;
 502:     putassign(cpexpr(t2), cpexpr(t1));
 503: 
 504:     for(k>>=1 ; k>1 ; k>>=1)
 505:         {
 506:         ++ncomma;
 507:         putsteq(t1, t1);
 508:         if(k & 1)
 509:             {
 510:             ++ncomma;
 511:             putsteq(t2, t1);
 512:             }
 513:         }
 514:     putx( mkexpr(OPSTAR, cpexpr(t2),
 515:         mkexpr(OPSTAR, cpexpr(t1), cpexpr(t1)) ));
 516:     }
 517: putcomma(ncomma, type, NO);
 518: frexpr(t1);
 519: if(t2)
 520:     frexpr(t2);
 521: frexpr(p);
 522: }
 523: 
 524: 
 525: 
 526: 
 527: LOCAL struct addrblock *intdouble(p, ncommap)
 528: struct addrblock *p;
 529: int *ncommap;
 530: {
 531: register struct addrblock *t;
 532: 
 533: t = mktemp(TYDREAL, NULL);
 534: ++*ncommap;
 535: putassign(cpexpr(t), p);
 536: return(t);
 537: }
 538: 
 539: 
 540: 
 541: 
 542: 
 543: LOCAL putcxeq(p)
 544: register struct exprblock *p;
 545: {
 546: register struct addrblock *lp, *rp;
 547: int ncomma;
 548: 
 549: ncomma = 0;
 550: lp = putcx1(p->leftp, &ncomma);
 551: rp = putcx1(p->rightp, &ncomma);
 552: putassign(realpart(lp), realpart(rp));
 553: if( ISCOMPLEX(p->vtype) )
 554:     {
 555:     ++ncomma;
 556:     putassign(imagpart(lp), imagpart(rp));
 557:     }
 558: putcomma(ncomma, TYREAL, NO);
 559: frexpr(rp);
 560: free(p);
 561: return(lp);
 562: }
 563: 
 564: 
 565: 
 566: LOCAL putcxop(p)
 567: expptr p;
 568: {
 569: struct addrblock *putcx1();
 570: int ncomma;
 571: 
 572: ncomma = 0;
 573: putaddr( putcx1(p, &ncomma), NO);
 574: putcomma(ncomma, TYINT, NO);
 575: }
 576: 
 577: 
 578: 
 579: LOCAL struct addrblock *putcx1(p, ncommap)
 580: register expptr p;
 581: int *ncommap;
 582: {
 583: struct addrblock *q, *lp, *rp;
 584: register struct addrblock *resp;
 585: int opcode;
 586: int ltype, rtype;
 587: 
 588: if(p == NULL)
 589:     return(NULL);
 590: 
 591: switch(p->tag)
 592:     {
 593:     case TCONST:
 594:         if( ISCOMPLEX(p->vtype) )
 595:             p = putconst(p);
 596:         return( p );
 597: 
 598:     case TADDR:
 599:         if( ! addressable(p) )
 600:             {
 601:             ++*ncommap;
 602:             resp = mktemp(tyint, NULL);
 603:             putassign( cpexpr(resp), p->memoffset );
 604:             p->memoffset = resp;
 605:             }
 606:         return( p );
 607: 
 608:     case TEXPR:
 609:         if( ISCOMPLEX(p->vtype) )
 610:             break;
 611:         ++*ncommap;
 612:         resp = mktemp(TYDREAL, NO);
 613:         putassign( cpexpr(resp), p);
 614:         return(resp);
 615: 
 616:     default:
 617:         fatal1("putcx1: bad tag %d", p->tag);
 618:     }
 619: 
 620: opcode = p->opcode;
 621: if(opcode==OPCALL || opcode==OPCCALL)
 622:     {
 623:     ++*ncommap;
 624:     return( putcall(p) );
 625:     }
 626: else if(opcode == OPASSIGN)
 627:     {
 628:     ++*ncommap;
 629:     return( putcxeq(p) );
 630:     }
 631: resp = mktemp(p->vtype, NULL);
 632: if(lp = putcx1(p->leftp, ncommap) )
 633:     ltype = lp->vtype;
 634: if(rp = putcx1(p->rightp, ncommap) )
 635:     rtype = rp->vtype;
 636: 
 637: switch(opcode)
 638:     {
 639:     case OPCOMMA:
 640:         frexpr(resp);
 641:         resp = rp;
 642:         rp = NULL;
 643:         break;
 644: 
 645:     case OPNEG:
 646:         putassign( realpart(resp), mkexpr(OPNEG, realpart(lp), NULL) );
 647:         putassign( imagpart(resp), mkexpr(OPNEG, imagpart(lp), NULL) );
 648:         *ncommap += 2;
 649:         break;
 650: 
 651:     case OPPLUS:
 652:     case OPMINUS:
 653:         putassign( realpart(resp), mkexpr(opcode, realpart(lp), realpart(rp) ));
 654:         if(rtype < TYCOMPLEX)
 655:             putassign( imagpart(resp), imagpart(lp) );
 656:         else if(ltype < TYCOMPLEX)
 657:             {
 658:             if(opcode == OPPLUS)
 659:                 putassign( imagpart(resp), imagpart(rp) );
 660:             else    putassign( imagpart(resp), mkexpr(OPNEG, imagpart(rp), NULL) );
 661:             }
 662:         else
 663:             putassign( imagpart(resp), mkexpr(opcode, imagpart(lp), imagpart(rp) ));
 664: 
 665:         *ncommap += 2;
 666:         break;
 667: 
 668:     case OPSTAR:
 669:         if(ltype < TYCOMPLEX)
 670:             {
 671:             if( ISINT(ltype) )
 672:                 lp = intdouble(lp, ncommap);
 673:             putassign( realpart(resp), mkexpr(OPSTAR, cpexpr(lp), realpart(rp) ));
 674:             putassign( imagpart(resp), mkexpr(OPSTAR, cpexpr(lp), imagpart(rp) ));
 675:             }
 676:         else if(rtype < TYCOMPLEX)
 677:             {
 678:             if( ISINT(rtype) )
 679:                 rp = intdouble(rp, ncommap);
 680:             putassign( realpart(resp), mkexpr(OPSTAR, cpexpr(rp), realpart(lp) ));
 681:             putassign( imagpart(resp), mkexpr(OPSTAR, cpexpr(rp), imagpart(lp) ));
 682:             }
 683:         else    {
 684:             putassign( realpart(resp), mkexpr(OPMINUS,
 685:                 mkexpr(OPSTAR, realpart(lp), realpart(rp)),
 686:                 mkexpr(OPSTAR, imagpart(lp), imagpart(rp)) ));
 687:             putassign( imagpart(resp), mkexpr(OPPLUS,
 688:                 mkexpr(OPSTAR, realpart(lp), imagpart(rp)),
 689:                 mkexpr(OPSTAR, imagpart(lp), realpart(rp)) ));
 690:             }
 691:         *ncommap += 2;
 692:         break;
 693: 
 694:     case OPSLASH:
 695:         /* fixexpr has already replaced all divisions
 696: 		 * by a complex by a function call
 697: 		 */
 698:         if( ISINT(rtype) )
 699:             rp = intdouble(rp, ncommap);
 700:         putassign( realpart(resp), mkexpr(OPSLASH, realpart(lp), cpexpr(rp)) );
 701:         putassign( imagpart(resp), mkexpr(OPSLASH, imagpart(lp), cpexpr(rp)) );
 702:         *ncommap += 2;
 703:         break;
 704: 
 705:     case OPCONV:
 706:         putassign( realpart(resp), realpart(lp) );
 707:         if( ISCOMPLEX(lp->vtype) )
 708:             q = imagpart(lp);
 709:         else if(rp != NULL)
 710:             q = realpart(rp);
 711:         else
 712:             q = mkrealcon(TYDREAL, 0.0);
 713:         putassign( imagpart(resp), q);
 714:         *ncommap += 2;
 715:         break;
 716: 
 717:     default:
 718:         fatal1("putcx1 of invalid opcode %d", opcode);
 719:     }
 720: 
 721: frexpr(lp);
 722: frexpr(rp);
 723: free(p);
 724: return(resp);
 725: }
 726: 
 727: 
 728: 
 729: 
 730: LOCAL putcxcmp(p)
 731: register struct exprblock *p;
 732: {
 733: int opcode;
 734: int ncomma;
 735: register struct addrblock *lp, *rp;
 736: struct exprblock *q;
 737: 
 738: ncomma = 0;
 739: opcode = p->opcode;
 740: lp = putcx1(p->leftp, &ncomma);
 741: rp = putcx1(p->rightp, &ncomma);
 742: 
 743: q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
 744:     mkexpr(opcode, realpart(lp), realpart(rp)),
 745:     mkexpr(opcode, imagpart(lp), imagpart(rp)) );
 746: putx( fixexpr(q) );
 747: putcomma(ncomma, TYINT, NO);
 748: 
 749: free(lp);
 750: free(rp);
 751: free(p);
 752: }
 753: 
 754: LOCAL struct addrblock *putch1(p, ncommap)
 755: register expptr p;
 756: int * ncommap;
 757: {
 758: register struct addrblock *t;
 759: struct addrblock *mktemp(), *putconst();
 760: 
 761: switch(p->tag)
 762:     {
 763:     case TCONST:
 764:         return( putconst(p) );
 765: 
 766:     case TADDR:
 767:         return(p);
 768: 
 769:     case TEXPR:
 770:         ++*ncommap;
 771: 
 772:         switch(p->opcode)
 773:             {
 774:             case OPCALL:
 775:             case OPCCALL:
 776:                 t = putcall(p);
 777:                 break;
 778: 
 779:             case OPCONCAT:
 780:                 t = mktemp(TYCHAR, cpexpr(p->vleng) );
 781:                 putcat( cpexpr(t), p );
 782:                 break;
 783: 
 784:             case OPCONV:
 785:                 if(!ISICON(p->vleng) || p->vleng->const.ci!=1
 786:                    || ! INT(p->leftp->vtype) )
 787:                     fatal("putch1: bad character conversion");
 788:                 t = mktemp(TYCHAR, ICON(1) );
 789:                 putop( mkexpr(OPASSIGN, cpexpr(t), p) );
 790:                 break;
 791:             default:
 792:                 fatal1("putch1: invalid opcode %d", p->opcode);
 793:             }
 794:         return(t);
 795: 
 796:     default:
 797:         fatal1("putch1: bad tag %d", p->tag);
 798:     }
 799: /* NOTREACHED */
 800: }
 801: 
 802: 
 803: 
 804: 
 805: LOCAL putchop(p)
 806: expptr p;
 807: {
 808: int ncomma;
 809: 
 810: ncomma = 0;
 811: putaddr( putch1(p, &ncomma) , NO );
 812: putcomma(ncomma, TYCHAR, YES);
 813: }
 814: 
 815: 
 816: 
 817: 
 818: LOCAL putcheq(p)
 819: register struct exprblock *p;
 820: {
 821: int ncomma;
 822: 
 823: ncomma = 0;
 824: if( p->rightp->tag==TEXPR && p->rightp->opcode==OPCONCAT )
 825:     putcat(p->leftp, p->rightp);
 826: else if( ISONE(p->leftp->vleng) && ISONE(p->rightp->vleng) )
 827:     {
 828:     putaddr( putch1(p->leftp, &ncomma) , YES );
 829:     putaddr( putch1(p->rightp, &ncomma) , YES );
 830:     putcomma(ncomma, TYINT, NO);
 831:     p2op2(P2ASSIGN, P2CHAR);
 832:     }
 833: else
 834:     {
 835:     putx( call2(TYINT, "s_copy", p->leftp, p->rightp) );
 836:     putcomma(ncomma, TYINT, NO);
 837:     }
 838: frexpr(p->vleng);
 839: free(p);
 840: }
 841: 
 842: 
 843: 
 844: 
 845: LOCAL putchcmp(p)
 846: register struct exprblock *p;
 847: {
 848: int ncomma;
 849: 
 850: ncomma = 0;
 851: if(ISONE(p->leftp->vleng) && ISONE(p->rightp->vleng) )
 852:     {
 853:     putaddr( putch1(p->leftp, &ncomma) , YES );
 854:     putaddr( putch1(p->rightp, &ncomma) , YES );
 855:     p2op2(ops2[p->opcode], P2CHAR);
 856:     free(p);
 857:     putcomma(ncomma, TYINT, NO);
 858:     }
 859: else
 860:     {
 861:     p->leftp = call2(TYINT,"s_cmp", p->leftp, p->rightp);
 862:     p->rightp = ICON(0);
 863:     putop(p);
 864:     }
 865: }
 866: 
 867: 
 868: 
 869: 
 870: 
 871: LOCAL putcat(lhs, rhs)
 872: register struct addrblock *lhs;
 873: register expptr rhs;
 874: {
 875: int n, ncomma;
 876: struct addrblock *lp, *cp;
 877: 
 878: ncomma = 0;
 879: n = ncat(rhs);
 880: lp = mktmpn(n, TYLENG, NULL);
 881: cp = mktmpn(n, TYADDR, NULL);
 882: 
 883: n = 0;
 884: putct1(rhs, lp, cp, &n, &ncomma);
 885: 
 886: putx( call4(TYSUBR, "s_cat", lhs, cp, lp, mkconv(TYLONG, ICON(n)) ) );
 887: putcomma(ncomma, TYINT, NO);
 888: }
 889: 
 890: 
 891: 
 892: 
 893: 
 894: LOCAL ncat(p)
 895: register expptr p;
 896: {
 897: if(p->tag==TEXPR && p->opcode==OPCONCAT)
 898:     return( ncat(p->leftp) + ncat(p->rightp) );
 899: else    return(1);
 900: }
 901: 
 902: 
 903: 
 904: 
 905: LOCAL putct1(q, lp, cp, ip, ncommap)
 906: register expptr q;
 907: register struct addrblock *lp, *cp;
 908: int *ip, *ncommap;
 909: {
 910: int i;
 911: struct addrblock *lp1, *cp1;
 912: 
 913: if(q->tag==TEXPR && q->opcode==OPCONCAT)
 914:     {
 915:     putct1(q->leftp, lp, cp, ip, ncommap);
 916:     putct1(q->rightp, lp, cp , ip, ncommap);
 917:     frexpr(q->vleng);
 918:     free(q);
 919:     }
 920: else
 921:     {
 922:     i = (*ip)++;
 923:     lp1 = cpexpr(lp);
 924:     lp1->memoffset = mkexpr(OPPLUS, lp1->memoffset, ICON(i*SZLENG));
 925:     cp1 = cpexpr(cp);
 926:     cp1->memoffset = mkexpr(OPPLUS, cp1->memoffset, ICON(i*SZADDR));
 927:     putassign( lp1, cpexpr(q->vleng) );
 928:     putassign( cp1, addrof(putch1(q,ncommap)) );
 929:     *ncommap += 2;
 930:     }
 931: }
 932: 
 933: LOCAL putaddr(p, indir)
 934: register struct addrblock *p;
 935: int indir;
 936: {
 937: int type, type2, funct;
 938: expptr offp;
 939: 
 940: type = p->vtype;
 941: type2 = types2[type];
 942: if(p->vclass == CLPROC)
 943:     {
 944:     funct = P2FUNCT;
 945:     if(type == TYUNKNOWN)
 946:         type2 = P2INT;
 947:     }
 948: else
 949:     funct = 0;
 950: if(p->memoffset && (!ISICON(p->memoffset) || p->memoffset->const.ci!=0) )
 951:     offp = cpexpr(p->memoffset);
 952: else
 953:     offp = NULL;
 954: 
 955: #if FUDGEOFFSET != 1
 956: if(offp)
 957:     offp = mkexpr(OPSTAR, ICON(FUDGEOFFSET), offp);
 958: #endif
 959: 
 960: switch(p->vstg)
 961:     {
 962:     case STGAUTO:
 963:         p2reg(AUTOREG, P2PTR);
 964:         p2offset(type2|P2PTR, offp);
 965:         if(indir)
 966:             p2op2(P2INDIRECT, type2);
 967:         break;
 968: 
 969:     case STGLENG:
 970:     case STGARG:
 971:         p2reg(ARGREG, type2|P2PTR|((funct?funct:P2PTR)<<2));
 972:         if(p->memno)
 973:             {
 974:             putx( ICON(p->memno) );
 975:             p2op2(P2PLUS, type2|P2PTR|(funct<<2));
 976:             }
 977:         if(p->vstg == STGARG)
 978:             {
 979:             p2op2(P2INDIRECT, type2|P2PTR);
 980:             p2offset(type2|P2PTR|(funct<<2), offp);
 981:             }
 982:         if(indir)
 983:             p2op2(P2INDIRECT, type2|funct);
 984:         break;
 985: 
 986:     case STGBSS:
 987:     case STGINIT:
 988:     case STGEXT:
 989:     case STGCOMMON:
 990:     case STGEQUIV:
 991:     case STGCONST:
 992:         p2op(P2NAME);
 993:         p2i(P2EXTERN);
 994:         p2i(type2|funct);
 995:         p2str( memname(p->vstg,p->memno) );
 996:         if(!indir || offp!=NULL)
 997:             p2op2(P2ADDR, type2|P2PTR);
 998:         p2offset(type2|P2PTR, offp);
 999:         if(indir && offp!=NULL)
1000:             p2op2(P2INDIRECT, type2);
1001:         break;
1002: 
1003:     case STGREG:
1004:         if(indir)
1005:             p2reg(p->memno, type2);
1006:         break;
1007: 
1008:     default:
1009:         fatal1("putaddr: invalid vstg %d", p->vstg);
1010:     }
1011: frexpr(p);
1012: }
1013: 
1014: 
1015: 
1016: 
1017: 
1018: LOCAL struct addrblock *putcall(p)
1019: register struct exprblock *p;
1020: {
1021: chainp arglist, charsp, cp;
1022: int first;
1023: struct addrblock *t;
1024: register struct exprblock *q;
1025: struct exprblock *fval;
1026: int type, type2, ctype, indir;
1027: 
1028: if( (type = p->vtype) == TYLOGICAL)
1029:     type = tylogical;
1030: type2 = types2[type];
1031: charsp = NULL;
1032: first = YES;
1033: indir =  (p->opcode == OPCCALL);
1034: 
1035: if(p->rightp)
1036:     {
1037:     arglist = p->rightp->listp;
1038:     free(p->rightp);
1039:     }
1040: else
1041:     arglist = NULL;
1042: 
1043: if(!indir)  for(cp = arglist ; cp ; cp = cp->nextp)
1044:     {
1045:     q = cp->datap;
1046:     if( ISCONST(q) )
1047:         {
1048:         if(q->vtype == TYSHORT)
1049:             q = mkconv(tyint, q);
1050:         cp->datap = q = putconst(q);
1051:         }
1052:     if( ISCHAR(q) )
1053:         charsp = hookup(charsp, mkchain(cpexpr(q->vleng), 0) );
1054:     else if(q->vclass == CLPROC)
1055:         charsp = hookup(charsp, mkchain( ICON(0) , 0));
1056:     }
1057: 
1058: if(type == TYCHAR)
1059:     {
1060:     if( ISICON(p->vleng) )
1061:         fval = mktemp(TYCHAR, p->vleng);
1062:     else    {
1063:         err("adjustable character function");
1064:         return(NULL);
1065:         }
1066:     }
1067: else if( ISCOMPLEX(type) )
1068:     fval = mktemp(type, NULL);
1069: else
1070:     fval = NULL;
1071: 
1072: ctype = (fval ? P2INT : type2);
1073: putaddr(p->leftp, YES);
1074: 
1075: if(fval)
1076:     {
1077:     first = NO;
1078:     putaddr( cpexpr(fval), NO);
1079:     if(type==TYCHAR)
1080:         {
1081:         putx( mkconv(TYLENG, p->vleng) );
1082:         p2op2(P2LISTOP, P2INT);
1083:         }
1084:     }
1085: 
1086: for(cp = arglist ; cp ; cp = cp->nextp)
1087:     {
1088:     q = cp->datap;
1089:     if(q->tag==TADDR && (indir || q->vstg!=STGREG) )
1090:         putaddr(q, indir && q->vtype!=TYCHAR);
1091:     else if( ISCOMPLEX(q->vtype) )
1092:         putcxop(q);
1093:     else if (ISCHAR(q) )
1094:         putchop(q);
1095:     else if( ! ISERROR(q) )
1096:         {
1097:         if(indir)
1098:             putx(q);
1099:         else    {
1100:             t = mktemp(q->vtype, q->vleng);
1101:             putassign( cpexpr(t), q );
1102:             putaddr(t, NO);
1103:             putcomma(1, q->vtype, YES);
1104:             }
1105:         }
1106:     if(first)
1107:         first = NO;
1108:     else
1109:         p2op2(P2LISTOP, P2INT);
1110:     }
1111: 
1112: if(arglist)
1113:     frchain(&arglist);
1114: for(cp = charsp ; cp ; cp = cp->nextp)
1115:     {
1116:     putx( mkconv(TYLENG, cp->datap) );
1117:     if(first)
1118:         first = NO;
1119:     else
1120:         p2op2(P2LISTOP, P2INT);
1121:     }
1122: frchain(&charsp);
1123: 
1124: if(first)
1125:     p2op(P2NULL);
1126: p2op2(P2CALL, ctype);
1127: free(p);
1128: return(fval);
1129: }
1130: 
1131: 
1132: 
1133: LOCAL putmnmx(p)
1134: register struct exprblock *p;
1135: {
1136: int op, type;
1137: int ncomma;
1138: struct exprblock *qp;
1139: chainp p0, p1;
1140: struct addrblock *sp, *tp;
1141: 
1142: type = p->vtype;
1143: op = (p->opcode==OPMIN ? OPLT : OPGT );
1144: p0 = p->leftp->listp;
1145: free(p->leftp);
1146: free(p);
1147: 
1148: sp = mktemp(type, NULL);
1149: tp = mktemp(type, NULL);
1150: qp = mkexpr(OPCOLON, cpexpr(tp), cpexpr(sp));
1151: qp = mkexpr(OPQUEST, mkexpr(op, cpexpr(tp),cpexpr(sp)), qp);
1152: qp = fixexpr(qp);
1153: 
1154: ncomma = 1;
1155: putassign( cpexpr(sp), p0->datap );
1156: 
1157: for(p1 = p0->nextp ; p1 ; p1 = p1->nextp)
1158:     {
1159:     ++ncomma;
1160:     putassign( cpexpr(tp), p1->datap );
1161:     if(p1->nextp)
1162:         {
1163:         ++ncomma;
1164:         putassign( cpexpr(sp), cpexpr(qp) );
1165:         }
1166:     else
1167:         putx(qp);
1168:     }
1169: 
1170: putcomma(ncomma, type, NO);
1171: frtemp(sp);
1172: frtemp(tp);
1173: frchain( &p0 );
1174: }
1175: 
1176: 
1177: 
1178: 
1179: LOCAL putcomma(n, type, indir)
1180: int n, type, indir;
1181: {
1182: type = types2[type];
1183: if(indir)
1184:     type |= P2PTR;
1185: while(--n >= 0)
1186:     p2op2(P2COMOP, type);
1187: }
1188: 
1189: /*
1190:  *  routines that put bytes on the pass2 input stream
1191: */
1192: 
1193: 
1194: p2i(k)
1195: int k;
1196: {
1197: register char *s;
1198: s = &k;
1199: 
1200: putc(*s++, textfile);
1201: putc(*s, textfile);
1202: }
1203: 
1204: 
1205: 
1206: 
1207: p2op(op)
1208: int op;
1209: {
1210: putc(op, textfile);
1211: putc(0376, textfile);   /* MAGIC NUMBER */
1212: }
1213: 
1214: 
1215: 
1216: 
1217: p2str(s)
1218: register char *s;
1219: {
1220: do
1221:     putc(*s, textfile);
1222:         while(*s++);
1223: }
1224: 
1225: 
1226: 
1227: p2op2(op, i)
1228: int op, i;
1229: {
1230: p2op(op);
1231: p2i(i);
1232: }
1233: 
1234: 
1235: 
1236: p2reg(k, type)
1237: int k;
1238: {
1239: p2op2(P2NAME, P2REG);
1240: p2i(type);
1241: p2i(k);
1242: }
1243: 
1244: 
1245: 
1246: LOCAL p2li(n)
1247: long int n;
1248: {
1249: register int *p, i;
1250: 
1251: p = &n;
1252: for(i = 0 ; i< sizeof(long int)/sizeof(int) ; ++i)
1253:     p2i(*p++);
1254: }
1255: 
1256: 
1257: 
1258: LOCAL p2offset(type, offp)
1259: int type;
1260: register expptr offp;
1261: {
1262: expptr shorten();
1263: 
1264: if(offp)
1265:     {
1266: #if SZINT < SZLONG
1267:     if(shortsubs)
1268:         offp = shorten(offp);
1269: #endif
1270:     if(offp->vtype != TYLONG)
1271:         offp = mkconv(TYINT, offp);
1272:     if(offp->vtype == TYLONG)
1273:         {
1274:         putx(offp);
1275:         p2op2(P2LTOI, P2INT);
1276:         }
1277:     else
1278:         putx( offp );
1279:     p2op2(P2PLUS, type);
1280:     }
1281: }

Defined functions