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