# 2.11BSD#431 - /usr/src/usr.bin/f77/putdmr.c

##### Functions

    intdouble         X
    ncat              X
    p2i               X
    p2li              X
    p2offset          X
    p2op              X
    p2op2             X
    p2reg             X
    p2str             X
    prarif            X
    putaddr           X
    putbranch         X
    putcall           X
    putcat            X
    putch1            X
    putchcmp          X
    putcheq           X
    putchop           X
    putcmgo           X
    putcomma          X
    putct1            X
    putcx1            X
    putcxcmp          X
    putcxeq           X
    putcxop           X
    puteof            X
    putexpr           X
    putforce          X
    putgoto           X
    puthead           X
    putif             X
    putlabel          X
    putmnmx           X
    putnreg           X
    putop             X
    putpower          X
    putstmt           X
    putx              X

       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

intdouble defined in line 543; used 3 times

- in line 688, 695, 715

ncat defined in line 910; used 3 times

- in line 895, 914(2)

p2i defined in line 1210; used 24 times

- in line 91-92(2), 154-157(4), 178-185(5), 213, 225-227(3), 1009-1010(2), 1247, 1256-1257(2), 1269
- in /usr/src/usr.bin/f77/pdp11.c line 67-72(2), 432

p2li defined in line 1262; used 1 times

- in line 218

p2offset defined in line 1274; used 3 times

- in line 980, 996, 1014

p2op defined in line 1223; used 13 times

- in line 23, 32, 62, 153, 177, 224, 1008, 1141, 1246
- in /usr/src/usr.bin/f77/pdp11.c line 34, 295, 340, 411

p2op2 defined in line 1243; used 43 times

- in line 22, 52, 69, 90, 104, 119-121(3), 131, 212-217(2), 228, 434, 469, 482, 847, 871, 982, 991-999(3), 1013-1016(2), 1098, 1125, 1136, 1142, 1202, 1255, 1297-1301(2)
- in /usr/src/usr.bin/f77/pdp11.c line 66-75(7), 342-345(2), 431-434(3)

p2reg defined in line 1252; used 7 times

- in line 979, 987, 1021
- in /usr/src/usr.bin/f77/pdp11.c line 65-70(2), 429-430(2)

p2str defined in line 1233; used 4 times

- in line 35, 1011
- in /usr/src/usr.bin/f77/pdp11.c line 343, 413

prarif defined in line 148; used 1 times

- in /usr/src/usr.bin/f77/exec.c line 510

putaddr defined in line 949; used 13 times

- in line 117, 338, 448, 589, 827, 844-845(2), 869-870(2), 1089-1094(2), 1106, 1118

putbranch defined in line 109; used 2 times

- in /usr/src/usr.bin/f77/exec.c line 557
- in /usr/src/usr.bin/f77/proc.c line 189

putcall defined in line 1034; used 4 times

- in line 192, 245, 640, 792

putcat defined in line 887; used 2 times

- in line 797, 841

putch1 defined in line 770; used 6 times

- in line 827, 844-845(2), 869-870(2), 944

putchcmp defined in line 861; used 1 times

- in line 275

putcheq defined in line 834; used 1 times

- in line 258

putchop defined in line 821; used 1 times

- in line 1110

putcmgo defined in line 162; used 2 times

- in /usr/src/usr.bin/f77/exec.c line 206
- in /usr/src/usr.bin/f77/gram.exec line 71

putcomma defined in line 1195; used 13 times

- in line 305, 449, 533, 574, 590, 763, 828, 846, 852, 873, 903, 1119, 1186

putct1 defined in line 921; used 3 times

- in line 900, 931-932(2)

putcx1 defined in line 595; used 10 times

- in line 192, 304, 566-567(2), 585-589(2), 648-650(2), 756-757(2)

putcxcmp defined in line 746; used 1 times

- in line 267

putcxeq defined in line 559; used 2 times

- in line 256, 645

putcxop defined in line 582; used 4 times

- in line 244, 293, 299, 1108

puteof defined in line 60; used 1 times

- in /usr/src/usr.bin/f77/main.c line 123

putexpr defined in line 137; used 4 times

- in /usr/src/usr.bin/f77/exec.c line 207, 250
- in /usr/src/usr.bin/f77/io.c line 559
- in /usr/src/usr.bin/f77/put.c line 83

putforce defined in line 476; used 7 times

- in line 176
- in /usr/src/usr.bin/f77/exec.c line 539
- in /usr/src/usr.bin/f77/pdp11.c line 159, 189
- in /usr/src/usr.bin/f77/proc.c line 180, 231, 238

putgoto defined in line 101; used 10 times

- in line 42
- in /usr/src/usr.bin/f77/exec.c line 25, 44, 123, 371, 403, 522, 540-543(2)
- in /usr/src/usr.bin/f77/pdp11.c line 399

puthead defined in line 15; used 4 times

- in /usr/src/usr.bin/f77/gram.head line 83
- in /usr/src/usr.bin/f77/proc.c line 74-76(2), 127

putif defined in line 76; used 12 times

- in /usr/src/usr.bin/f77/exec.c line 13, 28, 385, 405-408(2), 439-444(3), 521
- in /usr/src/usr.bin/f77/io.c line 536-537(2), 557

putlabel defined in line 128; used 21 times

- in line 186
- in /usr/src/usr.bin/f77/exec.c line 26, 45, 57-64(3), 407, 413, 440, 447
- in /usr/src/usr.bin/f77/gram.head line 95
- in /usr/src/usr.bin/f77/io.c line 535-540(2)
- in /usr/src/usr.bin/f77/proc.c line 178-185(3), 193, 204, 268, 297, 371

putmnmx defined in line 1149; used 1 times

- in line 250

putnreg defined in line 50; used 2 times

- in /usr/src/usr.bin/f77/expr.c line 941, 992

putop defined in line 348; used 3 times

- in line 329, 805, 879

putpower defined in line 488; used 1 times

- in line 281

putstmt defined in line 67; used 5 times

- in line 122, 141, 483
- in /usr/src/usr.bin/f77/pdp11.c line 76, 435

putx defined in line 189; used 24 times

- in line 152, 233, 303, 374, 433, 443, 465-467(2), 481, 513, 530, 762, 851, 902, 990, 1097, 1114, 1132, 1183, 1296-1300(2)
- in /usr/src/usr.bin/f77/put.c line 62, 74, 94

Last modified: 1992-11-13 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 2838 |