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

Defined functions