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

Defined functions