home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / f2csrc.zip / f2csrc / src / putpcc.c < prev    next >
C/C++ Source or Header  |  1994-05-10  |  45KB  |  2,005 lines
  1. /****************************************************************
  2. Copyright 1990 - 1994 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. /* INTERMEDIATE CODE GENERATION FOR S. C. JOHNSON C COMPILERS */
  25. /* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
  26.  
  27. #include "defs.h"
  28. #include "pccdefs.h"
  29. #include "output.h"        /* for nice_printf */
  30. #include "names.h"
  31. #include "p1defs.h"
  32.  
  33. static Addrp intdouble Argdcl((Addrp));
  34. static Addrp putcx1 Argdcl((tagptr));
  35. static tagptr putaddr Argdcl((tagptr));
  36. static tagptr putcall Argdcl((tagptr, Addrp*));
  37. static tagptr putcat Argdcl((tagptr, tagptr));
  38. static Addrp putch1 Argdcl((tagptr));
  39. static tagptr putchcmp Argdcl((tagptr));
  40. static tagptr putcheq Argdcl((tagptr));
  41. static void putct1 Argdcl((tagptr, Addrp, Addrp, ptr));
  42. static tagptr putcxcmp Argdcl((tagptr));
  43. static Addrp putcxeq Argdcl((tagptr));
  44. static tagptr putmnmx Argdcl((tagptr));
  45. static tagptr putop Argdcl((tagptr));
  46. static tagptr putpower Argdcl((tagptr));
  47.  
  48. #define FOUR 4
  49. extern int ops2[];
  50. extern int proc_argchanges, proc_protochanges;
  51. extern int krparens;
  52.  
  53. #define P2BUFFMAX 128
  54.  
  55. /* Puthead -- output the header information about subroutines, functions
  56.    and entry points */
  57.  
  58.  void
  59. #ifdef KR_headers
  60. puthead(s, class)
  61.     char *s;
  62.     int class;
  63. #else
  64. puthead(char *s, int class)
  65. #endif
  66. {
  67.     if (headerdone == NO) {
  68.         if (class == CLMAIN)
  69.             s = "MAIN__";
  70.         p1_head (class, s);
  71.         headerdone = YES;
  72.         }
  73. }
  74.  
  75.  void
  76. #ifdef KR_headers
  77. putif(p, else_if_p)
  78.     register expptr p;
  79.     int else_if_p;
  80. #else
  81. putif(register expptr p, int else_if_p)
  82. #endif
  83. {
  84.     register int k;
  85.     int n;
  86.     long where;
  87.  
  88.     if (else_if_p) {
  89.         p1put(P1_ELSEIFSTART);
  90.         where = ftell(pass1_file);
  91.         }
  92.     if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype )) )
  93.     {
  94.         if(k != TYERROR)
  95.             err("non-logical expression in IF statement");
  96.         }
  97.     else {
  98.         if (else_if_p) {
  99.             if (ei_next >= ei_last)
  100.                 {
  101.                 k = ei_last - ei_first;
  102.                 n = k + 100;
  103.                 ei_next = mem(n,0);
  104.                 ei_last = ei_first + n;
  105.                 if (k)
  106.                     memcpy(ei_next, ei_first, k);
  107.                 ei_first =  ei_next;
  108.                 ei_next += k;
  109.                 ei_last = ei_first + n;
  110.                 }
  111.             p = putx(p);
  112.             if (*ei_next++ = ftell(pass1_file) > where) {
  113.                 p1_if(p);
  114.                 new_endif();
  115.                 }
  116.             else
  117.                 p1_elif(p);
  118.             }
  119.         else {
  120.             p = putx(p);
  121.             p1_if(p);
  122.             }
  123.         }
  124.     }
  125.  
  126.  void
  127. #ifdef KR_headers
  128. putout(p)
  129.     expptr p;
  130. #else
  131. putout(expptr p)
  132. #endif
  133. {
  134.     p1_expr (p);
  135.  
  136. /* Used to make temporaries in holdtemps available here, but they */
  137. /* may be reused too soon (e.g. when multiple **'s are involved). */
  138. }
  139.  
  140.  
  141.  void
  142. #ifdef KR_headers
  143. putcmgo(index, nlab, labs)
  144.     expptr index;
  145.     int nlab;
  146.     struct Labelblock **labs;
  147. #else
  148. putcmgo(expptr index, int nlab, struct Labelblock **labs)
  149. #endif
  150. {
  151.     if(! ISINT(index->headblock.vtype) )
  152.     {
  153.         execerr("computed goto index must be integer", CNULL);
  154.         return;
  155.     }
  156.  
  157.     p1comp_goto (index, nlab, labs);
  158. }
  159.  
  160.  static expptr
  161. #ifdef KR_headers
  162. krput(p)
  163.     register expptr p;
  164. #else
  165. krput(register expptr p)
  166. #endif
  167. {
  168.     register expptr e, e1;
  169.     register unsigned op;
  170.     int t = krparens == 2 ? TYDREAL : p->exprblock.vtype;
  171.  
  172.     op = p->exprblock.opcode;
  173.     e = p->exprblock.leftp;
  174.     if (e->tag == TEXPR && e->exprblock.opcode == op) {
  175.         e1 = (expptr)mktmp(t, ENULL);
  176.         putout(putassign(cpexpr(e1), e));
  177.         p->exprblock.leftp = e1;
  178.         }
  179.     else
  180.         p->exprblock.leftp = putx(e);
  181.  
  182.     e = p->exprblock.rightp;
  183.     if (e->tag == TEXPR && e->exprblock.opcode == op) {
  184.         e1 = (expptr)mktmp(t, ENULL);
  185.         putout(putassign(cpexpr(e1), e));
  186.         p->exprblock.rightp = e1;
  187.         }
  188.     else
  189.         p->exprblock.rightp = putx(e);
  190.     return p;
  191.     }
  192.  
  193.  expptr
  194. #ifdef KR_headers
  195. putx(p)
  196.     register expptr p;
  197. #else
  198. putx(register expptr p)
  199. #endif
  200. {
  201.     int opc;
  202.     int k;
  203.  
  204.     if (p)
  205.       switch(p->tag)
  206.     {
  207.     case TERROR:
  208.         break;
  209.  
  210.     case TCONST:
  211.         switch(p->constblock.vtype)
  212.         {
  213.         case TYLOGICAL1:
  214.         case TYLOGICAL2:
  215.         case TYLOGICAL:
  216. #ifdef TYQUAD
  217.         case TYQUAD:
  218. #endif
  219.         case TYLONG:
  220.         case TYSHORT:
  221.         case TYINT1:
  222.             break;
  223.  
  224.         case TYADDR:
  225.             break;
  226.         case TYREAL:
  227.         case TYDREAL:
  228.  
  229. /* Don't write it out to the p2 file, since you'd need to call putconst,
  230.    which is just what we need to avoid in the translator */
  231.  
  232.             break;
  233.         default:
  234.             p = putx( (expptr)putconst((Constp)p) );
  235.             break;
  236.         }
  237.         break;
  238.  
  239.     case TEXPR:
  240.         switch(opc = p->exprblock.opcode)
  241.         {
  242.         case OPCALL:
  243.         case OPCCALL:
  244.             if( ISCOMPLEX(p->exprblock.vtype) )
  245.                 p = putcxop(p);
  246.             else    p = putcall(p, (Addrp *)NULL);
  247.             break;
  248.  
  249.         case OPMIN:
  250.         case OPMAX:
  251.             p = putmnmx(p);
  252.             break;
  253.  
  254.  
  255.         case OPASSIGN:
  256.             if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype)
  257.                 || ISCOMPLEX(p->exprblock.rightp->headblock.vtype)) {
  258.                 (void) putcxeq(p);
  259.                 p = ENULL;
  260.             } else if( ISCHAR(p) )
  261.                 p = putcheq(p);
  262.             else
  263.                 goto putopp;
  264.             break;
  265.  
  266.         case OPEQ:
  267.         case OPNE:
  268.             if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ||
  269.                 ISCOMPLEX(p->exprblock.rightp->headblock.vtype) )
  270.             {
  271.                 p = putcxcmp(p);
  272.                 break;
  273.             }
  274.         case OPLT:
  275.         case OPLE:
  276.         case OPGT:
  277.         case OPGE:
  278.             if(ISCHAR(p->exprblock.leftp))
  279.             {
  280.                 p = putchcmp(p);
  281.                 break;
  282.             }
  283.             goto putopp;
  284.  
  285.         case OPPOWER:
  286.             p = putpower(p);
  287.             break;
  288.  
  289.         case OPSTAR:
  290.             /*   m * (2**k) -> m<<k   */
  291.             if(INT(p->exprblock.leftp->headblock.vtype) &&
  292.                 ISICON(p->exprblock.rightp) &&
  293.                 ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) )
  294.             {
  295.                 p->exprblock.opcode = OPLSHIFT;
  296.                 frexpr(p->exprblock.rightp);
  297.                 p->exprblock.rightp = ICON(k);
  298.                 goto putopp;
  299.             }
  300.             if (krparens && ISREAL(p->exprblock.vtype))
  301.                 return krput(p);
  302.  
  303.         case OPMOD:
  304.             goto putopp;
  305.         case OPPLUS:
  306.             if (krparens && ISREAL(p->exprblock.vtype))
  307.                 return krput(p);
  308.         case OPMINUS:
  309.         case OPSLASH:
  310.         case OPNEG:
  311.         case OPNEG1:
  312.         case OPABS:
  313.         case OPDABS:
  314.             if( ISCOMPLEX(p->exprblock.vtype) )
  315.                 p = putcxop(p);
  316.             else    goto putopp;
  317.             break;
  318.  
  319.         case OPCONV:
  320.             if( ISCOMPLEX(p->exprblock.vtype) )
  321.                 p = putcxop(p);
  322.             else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) )
  323.             {
  324.                 p = putx( mkconv(p->exprblock.vtype,
  325.                     (expptr)realpart(putcx1(p->exprblock.leftp))));
  326.             }
  327.             else    goto putopp;
  328.             break;
  329.  
  330.         case OPNOT:
  331.         case OPOR:
  332.         case OPAND:
  333.         case OPEQV:
  334.         case OPNEQV:
  335.         case OPADDR:
  336.         case OPPLUSEQ:
  337.         case OPSTAREQ:
  338.         case OPCOMMA:
  339.         case OPQUEST:
  340.         case OPCOLON:
  341.         case OPBITOR:
  342.         case OPBITAND:
  343.         case OPBITXOR:
  344.         case OPBITNOT:
  345.         case OPLSHIFT:
  346.         case OPRSHIFT:
  347.         case OPASSIGNI:
  348.         case OPIDENTITY:
  349.         case OPCHARCAST:
  350.         case OPMIN2:
  351.         case OPMAX2:
  352.         case OPDMIN:
  353.         case OPDMAX:
  354. putopp:
  355.             p = putop(p);
  356.             break;
  357.  
  358.         case OPCONCAT:
  359.             /* weird things like ichar(a//a) */
  360.             p = (expptr)putch1(p);
  361.             break;
  362.  
  363.         default:
  364.             badop("putx", opc);
  365.             p = errnode ();
  366.         }
  367.         break;
  368.  
  369.     case TADDR:
  370.         p = putaddr(p);
  371.         break;
  372.  
  373.     default:
  374.         badtag("putx", p->tag);
  375.         p = errnode ();
  376.     }
  377.  
  378.     return p;
  379. }
  380.  
  381.  
  382.  
  383.  LOCAL expptr
  384. #ifdef KR_headers
  385. putop(p)
  386.     expptr p;
  387. #else
  388. putop(expptr p)
  389. #endif
  390. {
  391.     expptr lp, tp;
  392.     int pt, lt, lt1;
  393.     int comma;
  394.  
  395.     switch(p->exprblock.opcode)    /* check for special cases and rewrite */
  396.     {
  397.     case OPCONV:
  398.         pt = p->exprblock.vtype;
  399.         lp = p->exprblock.leftp;
  400.         lt = lp->headblock.vtype;
  401.  
  402. /* Simplify nested type casts */
  403.  
  404.         while(p->tag==TEXPR && p->exprblock.opcode==OPCONV &&
  405.             ( (ISREAL(pt)&&ONEOF(lt,MSKREAL|MSKCOMPLEX)) ||
  406.             (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) ))
  407.         {
  408.             if(pt==TYDREAL && lt==TYREAL)
  409.             {
  410.                 if(lp->tag==TEXPR
  411.                 && lp->exprblock.opcode == OPCONV) {
  412.                     lt1 = lp->exprblock.leftp->headblock.vtype;
  413.                     if (lt1 == TYDREAL) {
  414.                     lp->exprblock.leftp =
  415.                         putx(lp->exprblock.leftp);
  416.                     return p;
  417.                     }
  418.                     if (lt1 == TYDCOMPLEX) {
  419.                     lp->exprblock.leftp = putx(
  420.                         (expptr)realpart(
  421.                         putcx1(lp->exprblock.leftp)));
  422.                     return p;
  423.                     }
  424.                     }
  425.                 break;
  426.             }
  427.             else if (ISREAL(pt) && ISCOMPLEX(lt)) {
  428.                 p->exprblock.leftp = putx(mkconv(pt,
  429.                     (expptr)realpart(
  430.                         putcx1(p->exprblock.leftp))));
  431.                 break;
  432.                 }
  433.             if(lt==TYCHAR && lp->tag==TEXPR &&
  434.                 lp->exprblock.opcode==OPCALL)
  435.             {
  436.  
  437. /* May want to make a comma expression here instead.  I had one, but took
  438.    it out for my convenience, not for the convenience of the end user */
  439.  
  440.                 putout (putcall (lp, (Addrp *) &(p ->
  441.                     exprblock.leftp)));
  442.                 return putop (p);
  443.             }
  444.             if (lt == TYCHAR) {
  445.                 p->exprblock.leftp = putx(p->exprblock.leftp);
  446.                 return p;
  447.                 }
  448.             frexpr(p->exprblock.vleng);
  449.             free( (charptr) p );
  450.             p = lp;
  451.             if (p->tag != TEXPR)
  452.                 goto retputx;
  453.             pt = lt;
  454.             lp = p->exprblock.leftp;
  455.             lt = lp->headblock.vtype;
  456.         } /* while */
  457.         if(p->tag==TEXPR && p->exprblock.opcode==OPCONV)
  458.             break;
  459.  retputx:
  460.         return putx(p);
  461.  
  462.     case OPADDR:
  463.         comma = NO;
  464.         lp = p->exprblock.leftp;
  465.         free( (charptr) p );
  466.         if(lp->tag != TADDR)
  467.         {
  468.             tp = (expptr)
  469.                 mktmp(lp->headblock.vtype,lp->headblock.vleng);
  470.             p = putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
  471.             lp = tp;
  472.             comma = YES;
  473.         }
  474.         if(comma)
  475.             p = mkexpr(OPCOMMA, p, putaddr(lp));
  476.         else
  477.             p = (expptr)putaddr(lp);
  478.         return p;
  479.  
  480.     case OPASSIGN:
  481.     case OPASSIGNI:
  482.     case OPLT:
  483.     case OPLE:
  484.     case OPGT:
  485.     case OPGE:
  486.     case OPEQ:
  487.     case OPNE:
  488.         ;
  489.     }
  490.  
  491.     if( ops2[p->exprblock.opcode] <= 0)
  492.         badop("putop", p->exprblock.opcode);
  493.     lp = p->exprblock.leftp = putx(p->exprblock.leftp);
  494.     if (p -> exprblock.rightp) {
  495.         tp = p->exprblock.rightp = putx(p->exprblock.rightp);
  496.         if (ISCONST(tp) && ISCONST(lp))
  497.             p = fold(p);
  498.         }
  499.     return p;
  500. }
  501.  
  502.  LOCAL expptr
  503. #ifdef KR_headers
  504. putpower(p)
  505.     expptr p;
  506. #else
  507. putpower(expptr p)
  508. #endif
  509. {
  510.     expptr base;
  511.     Addrp t1, t2;
  512.     ftnint k;
  513.     int type;
  514.     char buf[80];            /* buffer for text of comment */
  515.  
  516.     if(!ISICON(p->exprblock.rightp) ||
  517.         (k = p->exprblock.rightp->constblock.Const.ci)<2)
  518.         Fatal("putpower: bad call");
  519.     base = p->exprblock.leftp;
  520.     type = base->headblock.vtype;
  521.     t1 = mktmp(type, ENULL);
  522.     t2 = NULL;
  523.  
  524.     free ((charptr) p);
  525.     p = putassign (cpexpr((expptr) t1), base);
  526.  
  527.     sprintf (buf, "Computing %ld%s power", k,
  528.         k == 2 ? "nd" : k == 3 ? "rd" : "th");
  529.     p1_comment (buf);
  530.  
  531.     for( ; (k&1)==0 && k>2 ; k>>=1 )
  532.     {
  533.         p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
  534.     }
  535.  
  536.     if(k == 2) {
  537.  
  538. /* Write the power computation out immediately */
  539.         putout (p);
  540.         p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)));
  541.     } else {
  542.         t2 = mktmp(type, ENULL);
  543.         p = mkexpr (OPCOMMA, p, putassign(cpexpr((expptr)t2),
  544.                         cpexpr((expptr)t1)));
  545.  
  546.         for(k>>=1 ; k>1 ; k>>=1)
  547.         {
  548.             p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
  549.             if(k & 1)
  550.             {
  551.                 p = mkexpr (OPCOMMA, p, putsteq(t2, t1));
  552.             }
  553.         }
  554. /* Write the power computation out immediately */
  555.         putout (p);
  556.         p = putx( mkexpr(OPSTAR, cpexpr((expptr)t2),
  557.             mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))));
  558.     }
  559.     frexpr((expptr)t1);
  560.     if(t2)
  561.         frexpr((expptr)t2);
  562.     return p;
  563. }
  564.  
  565.  
  566.  
  567.  
  568.  LOCAL Addrp
  569. #ifdef KR_headers
  570. intdouble(p)
  571.     Addrp p;
  572. #else
  573. intdouble(Addrp p)
  574. #endif
  575. {
  576.     register Addrp t;
  577.  
  578.     t = mktmp(TYDREAL, ENULL);
  579.     putout (putassign(cpexpr((expptr)t), (expptr)p));
  580.     return(t);
  581. }
  582.  
  583.  
  584.  
  585.  
  586.  
  587. /* Complex-type variable assignment */
  588.  
  589.  LOCAL Addrp
  590. #ifdef KR_headers
  591. putcxeq(p)
  592.     register expptr p;
  593. #else
  594. putcxeq(register expptr p)
  595. #endif
  596. {
  597.     register Addrp lp, rp;
  598.     expptr code;
  599.  
  600.     if(p->tag != TEXPR)
  601.         badtag("putcxeq", p->tag);
  602.  
  603.     lp = putcx1(p->exprblock.leftp);
  604.     rp = putcx1(p->exprblock.rightp);
  605.     code = putassign ( (expptr)realpart(lp), (expptr)realpart(rp));
  606.  
  607.     if( ISCOMPLEX(p->exprblock.vtype) )
  608.     {
  609.         code = mkexpr (OPCOMMA, code, putassign
  610.             (imagpart(lp), imagpart(rp)));
  611.     }
  612.     putout (code);
  613.     frexpr((expptr)rp);
  614.     free ((charptr) p);
  615.     return lp;
  616. }
  617.  
  618.  
  619.  
  620. /* putcxop -- used to write out embedded calls to complex functions, and
  621.    complex arguments to procedures */
  622.  
  623.  expptr
  624. #ifdef KR_headers
  625. putcxop(p)
  626.     expptr p;
  627. #else
  628. putcxop(expptr p)
  629. #endif
  630. {
  631.     return (expptr)putaddr((expptr)putcx1(p));
  632. }
  633.  
  634. #define PAIR(x,y) mkexpr (OPCOMMA, (x), (y))
  635.  
  636.  LOCAL Addrp
  637. #ifdef KR_headers
  638. putcx1(p)
  639.     register expptr p;
  640. #else
  641. putcx1(register expptr p)
  642. #endif
  643. {
  644.     expptr q;
  645.     Addrp lp, rp;
  646.     register Addrp resp;
  647.     int opcode;
  648.     int ltype, rtype;
  649.     long ts, tskludge;
  650.  
  651.     if(p == NULL)
  652.         return(NULL);
  653.  
  654.     switch(p->tag)
  655.     {
  656.     case TCONST:
  657.         if( ISCOMPLEX(p->constblock.vtype) )
  658.             p = (expptr) putconst((Constp)p);
  659.         return( (Addrp) p );
  660.  
  661.     case TADDR:
  662.         resp = &p->addrblock;
  663.         if (addressable(p))
  664.             return (Addrp) p;
  665.         ts = tskludge = 0;
  666.         if (q = resp->memoffset) {
  667.             if (resp->uname_tag == UNAM_REF) {
  668.                 q = cpexpr((tagptr)resp);
  669.                 q->addrblock.vtype = tyint;
  670.                 q->addrblock.cmplx_sub = 1;
  671.                 p->addrblock.skip_offset = 1;
  672.                 resp->user.name->vsubscrused = 1;
  673.                 resp->uname_tag = UNAM_NAME;
  674.                 tskludge = typesize[resp->vtype]
  675.                     * (resp->Field ? 2 : 1);
  676.                 }
  677.             else if (resp->isarray
  678.                     && resp->vtype != TYCHAR) {
  679.                 if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
  680.                       && resp->uname_tag == UNAM_NAME)
  681.                     q = mkexpr(OPMINUS, q,
  682.                       mkintcon(resp->user.name->voffset));
  683.                 ts = typesize[resp->vtype]
  684.                     * (resp->Field ? 2 : 1);
  685.                 q = resp->memoffset = mkexpr(OPSLASH, q,
  686.                                 ICON(ts));
  687.                 }
  688.             }
  689.         resp = mktmp(tyint, ENULL);
  690.         putout(putassign(cpexpr((expptr)resp), q));
  691.         p->addrblock.memoffset = tskludge
  692.             ? mkexpr(OPSTAR, (expptr)resp, ICON(tskludge))
  693.             : (expptr)resp;
  694.         if (ts) {
  695.             resp = &p->addrblock;
  696.             q = mkexpr(OPSTAR, resp->memoffset, ICON(ts));
  697.             if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
  698.                 && resp->uname_tag == UNAM_NAME)
  699.                 q = mkexpr(OPPLUS, q,
  700.                     mkintcon(resp->user.name->voffset));
  701.             resp->memoffset = q;
  702.             }
  703.         return (Addrp) p;
  704.  
  705.     case TEXPR:
  706.         if( ISCOMPLEX(p->exprblock.vtype) )
  707.             break;
  708.         resp = mktmp(TYDREAL, ENULL);
  709.         putout (putassign( cpexpr((expptr)resp), p));
  710.         return(resp);
  711.  
  712.     default:
  713.         badtag("putcx1", p->tag);
  714.     }
  715.  
  716.     opcode = p->exprblock.opcode;
  717.     if(opcode==OPCALL || opcode==OPCCALL)
  718.     {
  719.         Addrp t;
  720.         p = putcall(p, &t);
  721.         putout(p);
  722.         return t;
  723.     }
  724.     else if(opcode == OPASSIGN)
  725.     {
  726.         return putcxeq (p);
  727.     }
  728.  
  729. /* BUG  (inefficient)  Generates too many temporary variables */
  730.  
  731.     resp = mktmp(p->exprblock.vtype, ENULL);
  732.     if(lp = putcx1(p->exprblock.leftp) )
  733.         ltype = lp->vtype;
  734.     if(rp = putcx1(p->exprblock.rightp) )
  735.         rtype = rp->vtype;
  736.  
  737.     switch(opcode)
  738.     {
  739.     case OPCOMMA:
  740.         frexpr((expptr)resp);
  741.         resp = rp;
  742.         rp = NULL;
  743.         break;
  744.  
  745.     case OPNEG:
  746.     case OPNEG1:
  747.         putout (PAIR (
  748.             putassign( (expptr)realpart(resp),
  749.                 mkexpr(OPNEG, (expptr)realpart(lp), ENULL)),
  750.             putassign( imagpart(resp),
  751.                 mkexpr(OPNEG, imagpart(lp), ENULL))));
  752.         break;
  753.  
  754.     case OPPLUS:
  755.     case OPMINUS: { expptr r;
  756.         r = putassign( (expptr)realpart(resp),
  757.             mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp) ));
  758.         if(rtype < TYCOMPLEX)
  759.             q = putassign( imagpart(resp), imagpart(lp) );
  760.         else if(ltype < TYCOMPLEX)
  761.         {
  762.             if(opcode == OPPLUS)
  763.                 q = putassign( imagpart(resp), imagpart(rp) );
  764.             else
  765.                 q = putassign( imagpart(resp),
  766.                     mkexpr(OPNEG, imagpart(rp), ENULL) );
  767.         }
  768.         else
  769.             q = putassign( imagpart(resp),
  770.                 mkexpr(opcode, imagpart(lp), imagpart(rp) ));
  771.         r = PAIR (r, q);
  772.         putout (r);
  773.         break;
  774.         } /* case OPPLUS, OPMINUS: */
  775.     case OPSTAR:
  776.         if(ltype < TYCOMPLEX)
  777.         {
  778.             if( ISINT(ltype) )
  779.                 lp = intdouble(lp);
  780.             putout (PAIR (
  781.                 putassign( (expptr)realpart(resp),
  782.                     mkexpr(OPSTAR, cpexpr((expptr)lp),
  783.                     (expptr)realpart(rp))),
  784.                 putassign( imagpart(resp),
  785.                     mkexpr(OPSTAR, cpexpr((expptr)lp), imagpart(rp)))));
  786.         }
  787.         else if(rtype < TYCOMPLEX)
  788.         {
  789.             if( ISINT(rtype) )
  790.                 rp = intdouble(rp);
  791.             putout (PAIR (
  792.                 putassign( (expptr)realpart(resp),
  793.                     mkexpr(OPSTAR, cpexpr((expptr)rp),
  794.                     (expptr)realpart(lp))),
  795.                 putassign( imagpart(resp),
  796.                     mkexpr(OPSTAR, cpexpr((expptr)rp), imagpart(lp)))));
  797.         }
  798.         else    {
  799.             putout (PAIR (
  800.                 putassign( (expptr)realpart(resp), mkexpr(OPMINUS,
  801.                     mkexpr(OPSTAR, (expptr)realpart(lp),
  802.                     (expptr)realpart(rp)),
  803.                     mkexpr(OPSTAR, imagpart(lp), imagpart(rp)))),
  804.                 putassign( imagpart(resp), mkexpr(OPPLUS,
  805.                     mkexpr(OPSTAR, (expptr)realpart(lp), imagpart(rp)),
  806.                     mkexpr(OPSTAR, imagpart(lp),
  807.                     (expptr)realpart(rp))))));
  808.         }
  809.         break;
  810.  
  811.     case OPSLASH:
  812.         /* fixexpr has already replaced all divisions
  813.          * by a complex by a function call
  814.          */
  815.         if( ISINT(rtype) )
  816.             rp = intdouble(rp);
  817.         putout (PAIR (
  818.             putassign( (expptr)realpart(resp),
  819.                 mkexpr(OPSLASH, (expptr)realpart(lp), cpexpr((expptr)rp))),
  820.             putassign( imagpart(resp),
  821.                 mkexpr(OPSLASH, imagpart(lp), cpexpr((expptr)rp)))));
  822.         break;
  823.  
  824.     case OPCONV:
  825.         if( ISCOMPLEX(lp->vtype) )
  826.             q = imagpart(lp);
  827.         else if(rp != NULL)
  828.             q = (expptr) realpart(rp);
  829.         else
  830.             q = mkrealcon(TYDREAL, "0");
  831.         putout (PAIR (
  832.             putassign( (expptr)realpart(resp), (expptr)realpart(lp)),
  833.             putassign( imagpart(resp), q)));
  834.         break;
  835.  
  836.     default:
  837.         badop("putcx1", opcode);
  838.     }
  839.  
  840.     frexpr((expptr)lp);
  841.     frexpr((expptr)rp);
  842.     free( (charptr) p );
  843.     return(resp);
  844. }
  845.  
  846.  
  847.  
  848.  
  849. /* Only .EQ. and .NE. may be performed on COMPLEX data, other relations
  850.    are not defined */
  851.  
  852.  LOCAL expptr
  853. #ifdef KR_headers
  854. putcxcmp(p)
  855.     register expptr p;
  856. #else
  857. putcxcmp(register expptr p)
  858. #endif
  859. {
  860.     int opcode;
  861.     register Addrp lp, rp;
  862.     expptr q;
  863.  
  864.     if(p->tag != TEXPR)
  865.         badtag("putcxcmp", p->tag);
  866.  
  867.     opcode = p->exprblock.opcode;
  868.     lp = putcx1(p->exprblock.leftp);
  869.     rp = putcx1(p->exprblock.rightp);
  870.  
  871.     q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
  872.         mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp)),
  873.         mkexpr(opcode, imagpart(lp), imagpart(rp)) );
  874.  
  875.     free( (charptr) lp);
  876.     free( (charptr) rp);
  877.     free( (charptr) p );
  878.     if (ISCONST(q))
  879.         return q;
  880.     return     putx( fixexpr((Exprp)q) );
  881. }
  882.  
  883. /* putch1 -- Forces constants into the literal pool, among other things */
  884.  
  885.  LOCAL Addrp
  886. #ifdef KR_headers
  887. putch1(p)
  888.     register expptr p;
  889. #else
  890. putch1(register expptr p)
  891. #endif
  892. {
  893.     Addrp t;
  894.     expptr e;
  895.  
  896.     switch(p->tag)
  897.     {
  898.     case TCONST:
  899.         return( putconst((Constp)p) );
  900.  
  901.     case TADDR:
  902.         return( (Addrp) p );
  903.  
  904.     case TEXPR:
  905.         switch(p->exprblock.opcode)
  906.         {
  907.             expptr q;
  908.  
  909.         case OPCALL:
  910.         case OPCCALL:
  911.  
  912.             p = putcall(p, &t);
  913.             putout (p);
  914.             break;
  915.  
  916.         case OPCONCAT:
  917.             t = mktmp(TYCHAR, ICON(lencat(p)));
  918.             q = (expptr) cpexpr(p->headblock.vleng);
  919.             p = putcat( cpexpr((expptr)t), p );
  920.             /* put the correct length on the block */
  921.             frexpr(t->vleng);
  922.             t->vleng = q;
  923.             putout (p);
  924.             break;
  925.  
  926.         case OPCONV:
  927.             if(!ISICON(p->exprblock.vleng)
  928.                 || p->exprblock.vleng->constblock.Const.ci!=1
  929.                 || ! INT(p->exprblock.leftp->headblock.vtype) )
  930.                 Fatal("putch1: bad character conversion");
  931.             t = mktmp(TYCHAR, ICON(1));
  932.             e = mkexpr(OPCONV, (expptr)t, ENULL);
  933.             e->headblock.vtype = TYCHAR;
  934.             p = putop( mkexpr(OPASSIGN, cpexpr(e), p));
  935.             putout (p);
  936.             break;
  937.         default:
  938.             badop("putch1", p->exprblock.opcode);
  939.         }
  940.         return(t);
  941.  
  942.     default:
  943.         badtag("putch1", p->tag);
  944.     }
  945.     /* NOT REACHED */ return 0;
  946. }
  947.  
  948.  
  949. /* putchop -- Write out a character actual parameter; that is, this is
  950.    part of a procedure invocation */
  951.  
  952.  Addrp
  953. #ifdef KR_headers
  954. putchop(p)
  955.     expptr p;
  956. #else
  957. putchop(expptr p)
  958. #endif
  959. {
  960.     p = putaddr((expptr)putch1(p));
  961.     return (Addrp)p;
  962. }
  963.  
  964.  
  965.  
  966.  
  967.  LOCAL expptr
  968. #ifdef KR_headers
  969. putcheq(p)
  970.     register expptr p;
  971. #else
  972. putcheq(register expptr p)
  973. #endif
  974. {
  975.     expptr lp, rp;
  976.     int nbad;
  977.  
  978.     if(p->tag != TEXPR)
  979.         badtag("putcheq", p->tag);
  980.  
  981.     lp = p->exprblock.leftp;
  982.     rp = p->exprblock.rightp;
  983.     frexpr(p->exprblock.vleng);
  984.     free( (charptr) p );
  985.  
  986. /* If s = t // u, don't bother copying the result, write it directly into
  987.    this buffer */
  988.  
  989.     nbad = badchleng(lp) + badchleng(rp);
  990.     if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT )
  991.         p = putcat(lp, rp);
  992.     else if( !nbad
  993.         && ISONE(lp->headblock.vleng)
  994.         && ISONE(rp->headblock.vleng) ) {
  995.         lp = mkexpr(OPCONV, lp, ENULL);
  996.         rp = mkexpr(OPCONV, rp, ENULL);
  997.         lp->headblock.vtype = rp->headblock.vtype = TYCHAR;
  998.         p = putop(mkexpr(OPASSIGN, lp, rp));
  999.         }
  1000.     else
  1001.         p = putx( call2(TYSUBR, "s_copy", lp, rp) );
  1002.     return p;
  1003. }
  1004.  
  1005.  
  1006.  
  1007.  
  1008.  LOCAL expptr
  1009. #ifdef KR_headers
  1010. putchcmp(p)
  1011.     register expptr p;
  1012. #else
  1013. putchcmp(register expptr p)
  1014. #endif
  1015. {
  1016.     expptr lp, rp;
  1017.  
  1018.     if(p->tag != TEXPR)
  1019.         badtag("putchcmp", p->tag);
  1020.  
  1021.     lp = p->exprblock.leftp;
  1022.     rp = p->exprblock.rightp;
  1023.  
  1024.     if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) {
  1025.         lp = mkexpr(OPCONV, lp, ENULL);
  1026.         rp = mkexpr(OPCONV, rp, ENULL);
  1027.         lp->headblock.vtype = rp->headblock.vtype = TYCHAR;
  1028.         }
  1029.     else {
  1030.         lp = call2(TYINT,"s_cmp", lp, rp);
  1031.         rp = ICON(0);
  1032.         }
  1033.     p->exprblock.leftp = lp;
  1034.     p->exprblock.rightp = rp;
  1035.     p = putop(p);
  1036.     return p;
  1037. }
  1038.  
  1039.  
  1040.  
  1041.  
  1042.  
  1043. /* putcat -- Writes out a concatenation operation.  Two temporary arrays
  1044.    are allocated,   putct1()   is called to initialize them, and then a
  1045.    call to runtime library routine   s_cat()   is inserted.
  1046.  
  1047.     This routine generates code which will perform an  (nconc lhs rhs)
  1048.    at runtime.  The runtime funciton does not return a value, the routine
  1049.    that calls this   putcat   must remember the name of   lhs.
  1050. */
  1051.  
  1052.  
  1053.  LOCAL expptr
  1054. #ifdef KR_headers
  1055. putcat(lhs0, rhs)
  1056.     expptr lhs0;
  1057.     register expptr rhs;
  1058. #else
  1059. putcat(expptr lhs0, register expptr rhs)
  1060. #endif
  1061. {
  1062.     register Addrp lhs = (Addrp)lhs0;
  1063.     int n, tyi;
  1064.     Addrp length_var, string_var;
  1065.     expptr p;
  1066.     static char Writing_concatenation[] = "Writing concatenation";
  1067.  
  1068. /* Create the temporary arrays */
  1069.  
  1070.     n = ncat(rhs);
  1071.     length_var = mktmpn(n, tyioint, ENULL);
  1072.     string_var = mktmpn(n, TYADDR, ENULL);
  1073.     frtemp((Addrp)cpexpr((expptr)length_var));
  1074.     frtemp((Addrp)cpexpr((expptr)string_var));
  1075.  
  1076. /* Initialize the arrays */
  1077.  
  1078.     n = 0;
  1079.     /* p1_comment scribbles on its argument, so we
  1080.      * cannot safely pass a string literal here. */
  1081.     p1_comment(Writing_concatenation);
  1082.     putct1(rhs, length_var, string_var, &n);
  1083.  
  1084. /* Create the invocation */
  1085.  
  1086.     tyi = tyint;
  1087.     tyint = tyioint;    /* for -I2 */
  1088.     p = putx (call4 (TYSUBR, "s_cat",
  1089.                 (expptr)lhs,
  1090.                 (expptr)string_var,
  1091.                 (expptr)length_var,
  1092.                 (expptr)putconst((Constp)ICON(n))));
  1093.     tyint = tyi;
  1094.  
  1095.     return p;
  1096. }
  1097.  
  1098.  
  1099.  
  1100.  
  1101.  
  1102.  LOCAL void
  1103. #ifdef KR_headers
  1104. putct1(q, length_var, string_var, ip)
  1105.     register expptr q;
  1106.     register Addrp length_var;
  1107.     register Addrp string_var;
  1108.     int *ip;
  1109. #else
  1110. putct1(register expptr q, register Addrp length_var, register Addrp string_var, int *ip)
  1111. #endif
  1112. {
  1113.     int i;
  1114.     Addrp length_copy, string_copy;
  1115.     expptr e;
  1116.     extern int szleng;
  1117.  
  1118.     if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT)
  1119.     {
  1120.         putct1(q->exprblock.leftp, length_var, string_var,
  1121.             ip);
  1122.         putct1(q->exprblock.rightp, length_var, string_var,
  1123.             ip);
  1124.         frexpr (q -> exprblock.vleng);
  1125.         free ((charptr) q);
  1126.     }
  1127.     else
  1128.     {
  1129.         i = (*ip)++;
  1130.         e = cpexpr(q->headblock.vleng);
  1131.         if (!e)
  1132.             return; /* error -- character*(*) */
  1133.         length_copy = (Addrp) cpexpr((expptr)length_var);
  1134.         length_copy->memoffset =
  1135.             mkexpr(OPPLUS,length_copy->memoffset, ICON(i*szleng));
  1136.         string_copy = (Addrp) cpexpr((expptr)string_var);
  1137.         string_copy->memoffset =
  1138.             mkexpr(OPPLUS, string_copy->memoffset,
  1139.             ICON(i*typesize[TYADDR]));
  1140.         putout (PAIR (putassign((expptr)length_copy, e),
  1141.             putassign((expptr)string_copy, addrof((expptr)putch1(q)))));
  1142.     }
  1143. }
  1144.  
  1145. /* putaddr -- seems to write out function invocation actual parameters */
  1146.  
  1147.     LOCAL expptr
  1148. #ifdef KR_headers
  1149. putaddr(p0)
  1150.     expptr p0;
  1151. #else
  1152. putaddr(expptr p0)
  1153. #endif
  1154. {
  1155.     register Addrp p;
  1156.     chainp cp;
  1157.  
  1158.     if (!(p = (Addrp)p0))
  1159.         return ENULL;
  1160.  
  1161.     if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) )
  1162.     {
  1163.         frexpr((expptr)p);
  1164.         return ENULL;
  1165.     }
  1166.     if (p->isarray && p->memoffset)
  1167.         if (p->uname_tag == UNAM_REF) {
  1168.             cp = p->memoffset->listblock.listp;
  1169.             for(; cp; cp = cp->nextp)
  1170.                 cp->datap = (char *)fixtype((tagptr)cp->datap);
  1171.             }
  1172.         else
  1173.             p->memoffset = putx(p->memoffset);
  1174.     return (expptr) p;
  1175. }
  1176.  
  1177.  LOCAL expptr
  1178. #ifdef KR_headers
  1179. addrfix(e)
  1180.     expptr e;
  1181. #else
  1182. addrfix(expptr e)
  1183. #endif
  1184.         /* fudge character string length if it's a TADDR */
  1185. {
  1186.     return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e;
  1187.     }
  1188.  
  1189.  LOCAL int
  1190. #ifdef KR_headers
  1191. typekludge(ccall, q, at, j)
  1192.     int ccall;
  1193.     register expptr q;
  1194.     Atype *at;
  1195.     int j;
  1196. #else
  1197. typekludge(int ccall, register expptr q, Atype *at, int j)
  1198. #endif
  1199.  /* j = alternate type */
  1200. {
  1201.     register int i, k;
  1202.     extern int iocalladdr;
  1203.     register Namep np;
  1204.  
  1205.     /* Return value classes:
  1206.      *    < 100 ==> Fortran arg (pointer to type)
  1207.      *    < 200 ==> C arg
  1208.      *    < 300 ==> procedure arg
  1209.      *    < 400 ==> external, no explicit type
  1210.      *    < 500 ==> arg that may turn out to be
  1211.      *          either a variable or a procedure
  1212.      */
  1213.  
  1214.     k = q->headblock.vtype;
  1215.     if (ccall) {
  1216.         if (k == TYREAL)
  1217.             k = TYDREAL;    /* force double for library routines */
  1218.         return k + 100;
  1219.         }
  1220.     if (k == TYADDR)
  1221.         return iocalladdr;
  1222.     i = q->tag;
  1223.     if ((i == TEXPR && q->exprblock.opcode != OPCOMMA_ARG)
  1224.     ||  (i == TADDR && q->addrblock.charleng)
  1225.     ||   i == TCONST)
  1226.         k = TYFTNLEN + 100;
  1227.     else if (i == TADDR)
  1228.         switch(q->addrblock.vclass) {
  1229.         case CLPROC:
  1230.             if (q->addrblock.uname_tag != UNAM_NAME)
  1231.                 k += 200;
  1232.             else if ((np = q->addrblock.user.name)->vprocclass
  1233.                     != PTHISPROC) {
  1234.                 if (k && !np->vimpltype)
  1235.                     k += 200;
  1236.                 else {
  1237.                     if (j > 200 && infertypes && j < 300) {
  1238.                         k = j;
  1239.                         inferdcl(np, j-200);
  1240.                         }
  1241.                     else k = (np->vstg == STGEXT
  1242.                         ? extsymtab[np->vardesc.varno].extype
  1243.                         : 0) + 200;
  1244.                     at->cp = mkchain((char *)np, at->cp);
  1245.                     }
  1246.                 }
  1247.             else if (k == TYSUBR)
  1248.                 k += 200;
  1249.             break;
  1250.  
  1251.         case CLUNKNOWN:
  1252.             if (q->addrblock.vstg == STGARG
  1253.              && q->addrblock.uname_tag == UNAM_NAME) {
  1254.                 k += 400;
  1255.                 at->cp = mkchain((char *)q->addrblock.user.name,
  1256.                         at->cp);
  1257.                 }
  1258.         }
  1259.     else if (i == TNAME && q->nameblock.vstg == STGARG) {
  1260.         np = &q->nameblock;
  1261.         switch(np->vclass) {
  1262.             case CLPROC:
  1263.             if (!np->vimpltype)
  1264.                 k += 200;
  1265.             else if (j <= 200 || !infertypes || j >= 300)
  1266.                 k += 300;
  1267.             else {
  1268.                 k = j;
  1269.                 inferdcl(np, j-200);
  1270.                 }
  1271.             goto add2chain;
  1272.  
  1273.             case CLUNKNOWN:
  1274.             /* argument may be a scalar variable or a function */
  1275.             if (np->vimpltype && j && infertypes
  1276.             && j < 300) {
  1277.                 inferdcl(np, j % 100);
  1278.                 k = j;
  1279.                 }
  1280.             else
  1281.                 k += 400;
  1282.  
  1283.             /* to handle procedure args only so far known to be
  1284.              * external, save a pointer to the symbol table entry...
  1285.               */
  1286.  add2chain:
  1287.             at->cp = mkchain((char *)np, at->cp);
  1288.             }
  1289.         }
  1290.     return k;
  1291.     }
  1292.  
  1293.  char *
  1294. #ifdef KR_headers
  1295. Argtype(k, buf)
  1296.     int k;
  1297.     char *buf;
  1298. #else
  1299. Argtype(int k, char *buf)
  1300. #endif
  1301. {
  1302.     if (k < 100) {
  1303.         sprintf(buf, "%s variable", ftn_types[k]);
  1304.         return buf;
  1305.         }
  1306.     if (k < 200) {
  1307.         k -= 100;
  1308.         return ftn_types[k];
  1309.         }
  1310.     if (k < 300) {
  1311.         k -= 200;
  1312.         if (k == TYSUBR)
  1313.             return ftn_types[TYSUBR];
  1314.         sprintf(buf, "%s function", ftn_types[k]);
  1315.         return buf;
  1316.         }
  1317.     if (k < 400)
  1318.         return "external argument";
  1319.     k -= 400;
  1320.     sprintf(buf, "%s argument", ftn_types[k]);
  1321.     return buf;
  1322.     }
  1323.  
  1324.  static void
  1325. #ifdef KR_headers
  1326. atype_squawk(at, msg)
  1327.     Argtypes *at;
  1328.     char *msg;
  1329. #else
  1330. atype_squawk(Argtypes *at, char *msg)
  1331. #endif
  1332. {
  1333.     register Atype *a, *ae;
  1334.     warn(msg);
  1335.     for(a = at->atypes, ae = a + at->nargs; a < ae; a++)
  1336.         frchain(&a->cp);
  1337.     at->nargs = -1;
  1338.     if (at->changes & 2 && !at->defined)
  1339.         proc_protochanges++;
  1340.     }
  1341.  
  1342.  static char inconsist[] = "inconsistent calling sequences for ";
  1343.  
  1344.  void
  1345. #ifdef KR_headers
  1346. bad_atypes(at, fname, i, j, k, here, prev)
  1347.     Argtypes *at;
  1348.     char *fname;
  1349.     int i;
  1350.     int j;
  1351.     int k;
  1352.     char *here;
  1353.     char *prev;
  1354. #else
  1355. bad_atypes(Argtypes *at, char *fname, int i, int j, int k, char *here, char *prev)
  1356. #endif
  1357. {
  1358.     char buf[208], buf1[32], buf2[32];
  1359.  
  1360.     sprintf(buf, "%s%.90s,\n\targ %d: %s%s%s %s.",
  1361.         inconsist, fname, i, here, Argtype(k, buf1),
  1362.         prev, Argtype(j, buf2));
  1363.     atype_squawk(at, buf);
  1364.     }
  1365.  
  1366.  int
  1367. #ifdef KR_headers
  1368. type_fixup(at, a, k)
  1369.     Argtypes *at;
  1370.     Atype *a;
  1371.     int k;
  1372. #else
  1373. type_fixup(Argtypes *at,  Atype *a,  int k)
  1374. #endif
  1375. {
  1376.     register struct Entrypoint *ep;
  1377.     if (!infertypes)
  1378.         return 0;
  1379.     for(ep = entries; ep; ep = ep->entnextp)
  1380.         if (at == ep->entryname->arginfo) {
  1381.             a->type = k % 100;
  1382.             return proc_argchanges = 1;
  1383.             }
  1384.     return 0;
  1385.     }
  1386.  
  1387.  
  1388.  void
  1389. #ifdef KR_headers
  1390. save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type, zap)
  1391.     chainp arglist;
  1392.     Argtypes **at0;
  1393.     Argtypes **at1;
  1394.     int ccall;
  1395.     char *fname;
  1396.     int stg;
  1397.     int nchargs;
  1398.     int type;
  1399.     int zap;
  1400. #else
  1401. save_argtypes(chainp arglist, Argtypes **at0, Argtypes **at1, int ccall, char *fname, int stg, int nchargs, int type, int zap)
  1402. #endif
  1403. {
  1404.     Argtypes *at;
  1405.     chainp cp;
  1406.     int i, i0, j, k, nargs, nbad, *t, *te;
  1407.     Atype *atypes;
  1408.     expptr q;
  1409.     char buf[208], buf1[32], buf2[32];
  1410.     static int initargs[4] = {TYCOMPLEX, TYDCOMPLEX, TYCHAR, TYFTNLEN+100};
  1411.     static int *init_ap[TYSUBR+1] = {0,0,0,0,0,0,0,
  1412. #ifdef TYQUAD
  1413.                             0,
  1414. #endif
  1415.                 initargs, initargs+1,0,0,0,initargs+2};
  1416.     extern int init_ac[TYSUBR+1];
  1417.  
  1418.     i0 = init_ac[type];
  1419.     t = init_ap[type];
  1420.     te = t + i0;
  1421.     if (at = *at0) {
  1422.         *at1 = at;
  1423.         nargs = at->nargs;
  1424.         if (nargs < 0 && type && at->changes & 2 && !at->defined)
  1425.             --proc_protochanges;
  1426.         if (at->dnargs >= 0 && zap != 2)
  1427.             type = 0;
  1428.         if (nargs < 0) { /* inconsistent usage seen */
  1429.             if (type)
  1430.                 goto newlist;
  1431.             return;
  1432.             }
  1433.         atypes = at->atypes;
  1434.         i = nchargs;
  1435.         for(nbad = 0; t < te; atypes++) {
  1436.             if (++i > nargs) {
  1437.  toomany:
  1438.                 i = nchargs + i0;
  1439.                 for(cp = arglist; cp; cp = cp->nextp)
  1440.                     i++;
  1441.  toofew:
  1442.                 switch(zap) {
  1443.                     case 2:    zap = 6; break;
  1444.                     case 1:    if (at->defined & 4)
  1445.                             return;
  1446.                     }
  1447.                 sprintf(buf,
  1448.         "%s%.90s:\n\there %d, previously %d args and string lengths.",
  1449.                     inconsist, fname, i, nargs);
  1450.                 atype_squawk(at, buf);
  1451.                 if (type)
  1452.                     goto newlist;
  1453.                 return;
  1454.                 }
  1455.             j = atypes->type;
  1456.             k = *t++;
  1457.             if (j != k)
  1458.                 goto badtypes;
  1459.             }
  1460.         for(cp = arglist; cp; atypes++, cp = cp->nextp) {
  1461.             if (++i > nargs)
  1462.                 goto toomany;
  1463.             j = atypes->type;
  1464.             if (!(q = (expptr)cp->datap))
  1465.                 continue;
  1466.             k = typekludge(ccall, q, atypes, j);
  1467.             if (k >= 300 || k == j)
  1468.                 continue;
  1469.             if (j >= 300) {
  1470.                 if (k >= 200) {
  1471.                     if (k == TYUNKNOWN + 200)
  1472.                         continue;
  1473.                     if (j % 100 != k - 200
  1474.                      && k != TYSUBR + 200
  1475.                      && j != TYUNKNOWN + 300
  1476.                      && !type_fixup(at,atypes,k))
  1477.                         goto badtypes;
  1478.                     }
  1479.                 else if (j % 100 % TYSUBR != k % TYSUBR
  1480.                         && !type_fixup(at,atypes,k))
  1481.                     goto badtypes;
  1482.                 }
  1483.             else if (k < 200 || j < 200)
  1484.                 if (j) {
  1485.                     if (k == TYUNKNOWN
  1486.                      && q->tag == TNAME
  1487.                      && q->nameblock.vinfproc) {
  1488.                         q->nameblock.vdcldone = 0;
  1489.                         impldcl((Namep)q);
  1490.                         }
  1491.                     goto badtypes;
  1492.                     }
  1493.                 else ; /* fall through to update */
  1494.             else if (k == TYUNKNOWN+200)
  1495.                 continue;
  1496.             else if (j != TYUNKNOWN+200)
  1497.                 {
  1498.  badtypes:
  1499.                 if (++nbad == 1)
  1500.                     bad_atypes(at, fname, i - nchargs,
  1501.                         j, k, "here ", ", previously");
  1502.                 else
  1503.                     fprintf(stderr,
  1504.                      "\targ %d: here %s, previously %s.\n",
  1505.                         i - nchargs, Argtype(k,buf1),
  1506.                         Argtype(j,buf2));
  1507.                 continue;
  1508.                 }
  1509.             /* We've subsequently learned the right type,
  1510.                as in the call on zoo below...
  1511.  
  1512.                 subroutine foo(x, zap)
  1513.                 external zap
  1514.                 call goo(zap)
  1515.                 x = zap(3)
  1516.                 call zoo(zap)
  1517.                 end
  1518.              */
  1519.             if (!nbad) {
  1520.                 atypes->type = k;
  1521.                 at->changes |= 1;
  1522.                 }
  1523.             }
  1524.         if (i < nargs)
  1525.             goto toofew;
  1526.         if (nbad) {
  1527.             if (type) {
  1528.                 /* we're defining the procedure */
  1529.                 t = init_ap[type];
  1530.                 te = t + i0;
  1531.                 proc_argchanges = 1;
  1532.                 goto newlist;
  1533.                 }
  1534.             return;
  1535.             }
  1536.         if (zap == 1 && (at->changes & 5) != 5)
  1537.             at->changes = 0;
  1538.         return;
  1539.         }
  1540.  newlist:
  1541.     i = i0 + nchargs;
  1542.     for(cp = arglist; cp; cp = cp->nextp)
  1543.         i++;
  1544.     k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
  1545.     *at0 = *at1 = at = stg == STGEXT ? (Argtypes *)gmem(k,1)
  1546.                      : (Argtypes *) mem(k,1);
  1547.     at->dnargs = at->nargs = i;
  1548.     at->defined = zap & 6;
  1549.     at->changes = type ? 0 : 4;
  1550.     atypes = at->atypes;
  1551.     for(; t < te; atypes++) {
  1552.         atypes->type = *t++;
  1553.         atypes->cp = 0;
  1554.         }
  1555.     for(cp = arglist; cp; atypes++, cp = cp->nextp) {
  1556.         atypes->cp = 0;
  1557.         atypes->type = (q = (expptr)cp->datap)
  1558.             ? typekludge(ccall, q, atypes, 0)
  1559.             : 0;
  1560.         }
  1561.     for(; --nchargs >= 0; atypes++) {
  1562.         atypes->type = TYFTNLEN + 100;
  1563.         atypes->cp = 0;
  1564.         }
  1565.     }
  1566.  
  1567.  void
  1568. #ifdef KR_headers
  1569. saveargtypes(p)
  1570.     register Exprp p;
  1571. #else
  1572. saveargtypes(register Exprp p)
  1573. #endif
  1574.                 /* for writing prototypes */
  1575. {
  1576.     Addrp a;
  1577.     Argtypes **at0, **at1;
  1578.     Namep np;
  1579.     chainp arglist;
  1580.     expptr rp;
  1581.     Extsym *e;
  1582.     char *fname;
  1583.  
  1584.     a = (Addrp)p->leftp;
  1585.     switch(a->vstg) {
  1586.         case STGEXT:
  1587.             switch(a->uname_tag) {
  1588.                 case UNAM_EXTERN:    /* e.g., sqrt() */
  1589.                     e = extsymtab + a->memno;
  1590.                     at0 = at1 = &e->arginfo;
  1591.                     fname = e->fextname;
  1592.                     break;
  1593.                 case UNAM_NAME:
  1594.                     np = a->user.name;
  1595.                     at0 = &extsymtab[np->vardesc.varno].arginfo;
  1596.                     at1 = &np->arginfo;
  1597.                     fname = np->fvarname;
  1598.                     break;
  1599.                 default:
  1600.                     goto bug;
  1601.                 }
  1602.             break;
  1603.         case STGARG:
  1604.             if (a->uname_tag != UNAM_NAME)
  1605.                 goto bug;
  1606.             np = a->user.name;
  1607.             at0 = at1 = &np->arginfo;
  1608.             fname = np->fvarname;
  1609.             break;
  1610.         default:
  1611.      bug:
  1612.             Fatal("Confusion in saveargtypes");
  1613.         }
  1614.     rp = p->rightp;
  1615.     arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0;
  1616.     save_argtypes(arglist, at0, at1, p->opcode == OPCCALL,
  1617.         fname, a->vstg, 0, 0, 0);
  1618.     }
  1619.  
  1620. /* putcall - fix up the argument list, and write out the invocation.   p
  1621.    is expected to be initialized and point to an OPCALL or OPCCALL
  1622.    expression.  The return value is a pointer to a temporary holding the
  1623.    result of a COMPLEX or CHARACTER operation, or NULL. */
  1624.  
  1625.  LOCAL expptr
  1626. #ifdef KR_headers
  1627. putcall(p0, temp)
  1628.     expptr p0;
  1629.     Addrp *temp;
  1630. #else
  1631. putcall(expptr p0, Addrp *temp)
  1632. #endif
  1633. {
  1634.     register Exprp p = (Exprp)p0;
  1635.     chainp arglist;        /* Pointer to actual arguments, if any */
  1636.     chainp charsp;        /* List of copies of the variables which
  1637.                    hold the lengths of character
  1638.                    parameters (other than procedure
  1639.                    parameters) */
  1640.     chainp cp;            /* Iterator over argument lists */
  1641.     register expptr q;        /* Pointer to the current argument */
  1642.     Addrp fval;            /* Function return value */
  1643.     int type;            /* type of the call - presumably this was
  1644.                    set elsewhere */
  1645.     int byvalue;        /* True iff we don't want to massage the
  1646.                    parameter list, since we're calling a C
  1647.                    library routine */
  1648.     char *s;
  1649.  
  1650.     type = p -> vtype;
  1651.     charsp = NULL;
  1652.     byvalue =  (p->opcode == OPCCALL);
  1653.  
  1654. /* Verify the actual parameters */
  1655.  
  1656.     if (p == (Exprp) NULL)
  1657.     err ("putcall:  NULL call expression");
  1658.     else if (p -> tag != TEXPR)
  1659.     erri ("putcall:  expected TEXPR, got '%d'", p -> tag);
  1660.  
  1661. /* Find the argument list */
  1662.  
  1663.     if(p->rightp && p -> rightp -> tag == TLIST)
  1664.     arglist = p->rightp->listblock.listp;
  1665.     else
  1666.     arglist = NULL;
  1667.  
  1668. /* Count the number of explicit arguments, including lengths of character
  1669.    variables */
  1670.  
  1671.     for(cp = arglist ; cp ; cp = cp->nextp)
  1672.     if(!byvalue) {
  1673.         q = (expptr) cp->datap;
  1674.         if( ISCONST(q) )
  1675.         {
  1676.  
  1677. /* Even constants are passed by reference, so we need to put them in the
  1678.    literal table */
  1679.  
  1680.         q = (expptr) putconst((Constp)q);
  1681.         cp->datap = (char *) q;
  1682.         }
  1683.  
  1684. /* Save the length expression of character variables (NOT character
  1685.    procedures) for the end of the argument list */
  1686.  
  1687.         if( ISCHAR(q) &&
  1688.         (q->headblock.vclass != CLPROC
  1689.         || q->headblock.vstg == STGARG
  1690.             && q->tag == TADDR
  1691.             && q->addrblock.uname_tag == UNAM_NAME
  1692.             && q->addrblock.user.name->vprocclass == PTHISPROC))
  1693.         {
  1694.         p0 = cpexpr(q->headblock.vleng);
  1695.         charsp = mkchain((char *)p0, charsp);
  1696.         if (q->headblock.vclass == CLUNKNOWN
  1697.          && q->headblock.vstg == STGARG)
  1698.             q->addrblock.user.name->vpassed = 1;
  1699.         else if (q->tag == TADDR
  1700.                 && q->addrblock.uname_tag == UNAM_CONST)
  1701.             p0->constblock.Const.ci
  1702.                 += q->addrblock.user.Const.ccp1.blanks;
  1703.         }
  1704.     }
  1705.     charsp = revchain(charsp);
  1706.  
  1707. /* If the routine is a CHARACTER function ... */
  1708.  
  1709.     if(type == TYCHAR)
  1710.     {
  1711.     if( ISICON(p->vleng) )
  1712.     {
  1713.  
  1714. /* Allocate a temporary to hold the return value of the function */
  1715.  
  1716.         fval = mktmp(TYCHAR, p->vleng);
  1717.     }
  1718.     else    {
  1719.         err("adjustable character function");
  1720.         if (temp)
  1721.             *temp = 0;
  1722.         return 0;
  1723.         }
  1724.     }
  1725.  
  1726. /* If the routine is a COMPLEX function ... */
  1727.  
  1728.     else if( ISCOMPLEX(type) )
  1729.     fval = mktmp(type, ENULL);
  1730.     else
  1731.     fval = NULL;
  1732.  
  1733. /* Write the function name, without taking its address */
  1734.  
  1735.     p -> leftp = putx(fixtype(putaddr(p->leftp)));
  1736.  
  1737.     if(fval)
  1738.     {
  1739.     chainp prepend;
  1740.  
  1741. /* Prepend a copy of the function return value buffer out as the first
  1742.    argument. */
  1743.  
  1744.     prepend = mkchain((char *)putx(putaddr(cpexpr((expptr)fval))), arglist);
  1745.  
  1746. /* If it's a character function, also prepend the length of the result */
  1747.  
  1748.     if(type==TYCHAR)
  1749.     {
  1750.  
  1751.         prepend->nextp = mkchain((char *)putx(mkconv(TYLENG,
  1752.                     p->vleng)), arglist);
  1753.     }
  1754.     if (!(q = p->rightp))
  1755.         p->rightp = q = (expptr)mklist(CHNULL);
  1756.     q->listblock.listp = prepend;
  1757.     }
  1758.  
  1759. /* Scan through the fortran argument list */
  1760.  
  1761.     for(cp = arglist ; cp ; cp = cp->nextp)
  1762.     {
  1763.     q = (expptr) (cp->datap);
  1764.     if (q == ENULL)
  1765.         err ("putcall:  NULL argument");
  1766.  
  1767. /* call putaddr only when we've got a parameter for a C routine or a
  1768.    memory resident parameter */
  1769.  
  1770.     if (q -> tag == TCONST && !byvalue)
  1771.         q = (expptr) putconst ((Constp)q);
  1772.  
  1773.     if(q->tag==TADDR && (byvalue || q->addrblock.vstg!=STGREG) ) {
  1774.         if (q->addrblock.parenused
  1775.          && !byvalue && q->headblock.vtype != TYCHAR)
  1776.             goto make_copy;
  1777.         cp->datap = (char *)putaddr(q);
  1778.         }
  1779.     else if( ISCOMPLEX(q->headblock.vtype) )
  1780.         cp -> datap = (char *) putx (fixtype(putcxop(q)));
  1781.     else if (ISCHAR(q) )
  1782.         cp -> datap = (char *) putx (fixtype((expptr)putchop(q)));
  1783.     else if( ! ISERROR(q) )
  1784.     {
  1785.         if(byvalue
  1786.         || q->tag == TEXPR && q->exprblock.opcode == OPCHARCAST)
  1787.         cp -> datap = (char *) putx(q);
  1788.         else {
  1789.         expptr t, t1;
  1790.  
  1791. /* If we've got a register parameter, or (maybe?) a constant, save it in a
  1792.    temporary first */
  1793.  make_copy:
  1794.         t = (expptr) mktmp(q->headblock.vtype, q->headblock.vleng);
  1795.  
  1796. /* Assign to temporary variables before invoking the subroutine or
  1797.    function */
  1798.  
  1799.         t1 = putassign( cpexpr(t), q );
  1800.         if (doin_setbound)
  1801.             t = mkexpr(OPCOMMA_ARG, t1, t);
  1802.         else
  1803.             putout(t1);
  1804.         cp -> datap = (char *) t;
  1805.         } /* else */
  1806.     } /* if !ISERROR(q) */
  1807.     }
  1808.  
  1809. /* Now adjust the lengths of the CHARACTER parameters */
  1810.  
  1811.     for(cp = charsp ; cp ; cp = cp->nextp)
  1812.     cp->datap = (char *)addrfix(putx(
  1813.             /* in case MAIN has a character*(*)... */
  1814.             (s = cp->datap) ? mkconv(TYLENG,(expptr)s)
  1815.                      : ICON(0)));
  1816.  
  1817. /* ... and add them to the end of the argument list */
  1818.  
  1819.     hookup (arglist, charsp);
  1820.  
  1821. /* Return the name of the temporary used to hold the results, if any was
  1822.    necessary. */
  1823.  
  1824.     if (temp) *temp = fval;
  1825.     else frexpr ((expptr)fval);
  1826.  
  1827.     saveargtypes(p);
  1828.  
  1829.     return (expptr) p;
  1830. }
  1831.  
  1832.  
  1833.  
  1834. /* putmnmx -- Put min or max.   p   must point to an EXPR, not just a
  1835.    CONST */
  1836.  
  1837.  LOCAL expptr
  1838. #ifdef KR_headers
  1839. putmnmx(p)
  1840.     register expptr p;
  1841. #else
  1842. putmnmx(register expptr p)
  1843. #endif
  1844. {
  1845.     int op, op2, type;
  1846.     expptr arg, qp, temp;
  1847.     chainp p0, p1;
  1848.     Addrp sp, tp;
  1849.     char comment_buf[80];
  1850.     char *what;
  1851.  
  1852.     if(p->tag != TEXPR)
  1853.         badtag("putmnmx", p->tag);
  1854.  
  1855.     type = p->exprblock.vtype;
  1856.     op = p->exprblock.opcode;
  1857.     op2 = op == OPMIN ? OPMIN2 : OPMAX2;
  1858.     p0 = p->exprblock.leftp->listblock.listp;
  1859.     free( (charptr) (p->exprblock.leftp) );
  1860.     free( (charptr) p );
  1861.  
  1862.     /* special case for two addressable operands */
  1863.  
  1864.     if (addressable((expptr)p0->datap)
  1865.      && (p1 = p0->nextp)
  1866.      && addressable((expptr)p1->datap)
  1867.      && !p1->nextp) {
  1868.         if (type == TYREAL && forcedouble)
  1869.             op2 = op == OPMIN ? OPDMIN : OPDMAX;
  1870.         p = mkexpr(op2, mkconv(type, cpexpr((expptr)p0->datap)),
  1871.                 mkconv(type, cpexpr((expptr)p1->datap)));
  1872.         frchain(&p0);
  1873.         return p;
  1874.         }
  1875.  
  1876.     /* general case */
  1877.  
  1878.     sp = mktmp(type, ENULL);
  1879.  
  1880. /* We only need a second temporary if the arg list has an unaddressable
  1881.    value */
  1882.  
  1883.     tp = (Addrp) NULL;
  1884.     qp = ENULL;
  1885.     for (p1 = p0 -> nextp; p1; p1 = p1 -> nextp)
  1886.         if (!addressable ((expptr) p1 -> datap)) {
  1887.             tp = mktmp(type, ENULL);
  1888.             qp = mkexpr(op2, cpexpr((expptr)sp), cpexpr((expptr)tp));
  1889.             qp = fixexpr((Exprp)qp);
  1890.             break;
  1891.         } /* if */
  1892.  
  1893. /* Now output the appropriate number of assignments and comparisons.  Min
  1894.    and max are implemented by the simple O(n) algorithm:
  1895.  
  1896.     min (a, b, c, d) ==>
  1897.     { <type> t1, t2;
  1898.  
  1899.         t1 = a;
  1900.         t2 = b; t1 = (t1 < t2) ? t1 : t2;
  1901.         t2 = c; t1 = (t1 < t2) ? t1 : t2;
  1902.         t2 = d; t1 = (t1 < t2) ? t1 : t2;
  1903.     }
  1904. */
  1905.  
  1906.     if (!doin_setbound) {
  1907.         switch(op) {
  1908.             case OPLT:
  1909.             case OPMIN:
  1910.             case OPDMIN:
  1911.             case OPMIN2:
  1912.                 what = "IN";
  1913.                 break;
  1914.             default:
  1915.                 what = "AX";
  1916.             }
  1917.         sprintf (comment_buf, "Computing M%s", what);
  1918.         p1_comment (comment_buf);
  1919.         }
  1920.  
  1921.     p1 = p0->nextp;
  1922.     temp = (expptr)p0->datap;
  1923.     if (addressable(temp) && addressable((expptr)p1->datap)) {
  1924.         p = mkconv(type, cpexpr(temp));
  1925.         arg = mkconv(type, cpexpr((expptr)p1->datap));
  1926.         temp = mkexpr(op2, p, arg);
  1927.         if (!ISCONST(temp))
  1928.             temp = fixexpr((Exprp)temp);
  1929.         p1 = p1->nextp;
  1930.         }
  1931.     p = putassign (cpexpr((expptr)sp), temp);
  1932.  
  1933.     for(; p1 ; p1 = p1->nextp)
  1934.     {
  1935.         if (addressable ((expptr) p1 -> datap)) {
  1936.             arg = mkconv(type, cpexpr((expptr)p1->datap));
  1937.             temp = mkexpr(op2, cpexpr((expptr)sp), arg);
  1938.             temp = fixexpr((Exprp)temp);
  1939.         } else {
  1940.             temp = (expptr) cpexpr (qp);
  1941.             p = mkexpr(OPCOMMA, p,
  1942.                 putassign(cpexpr((expptr)tp), (expptr)p1->datap));
  1943.         } /* else */
  1944.  
  1945.         if(p1->nextp)
  1946.             p = mkexpr(OPCOMMA, p,
  1947.                 putassign(cpexpr((expptr)sp), temp));
  1948.         else {
  1949.             if (type == TYREAL && forcedouble)
  1950.                 temp->exprblock.opcode =
  1951.                     op == OPMIN ? OPDMIN : OPDMAX;
  1952.             if (doin_setbound)
  1953.                 p = mkexpr(OPCOMMA, p, temp);
  1954.             else {
  1955.                 putout (p);
  1956.                 p = putx(temp);
  1957.                 }
  1958.             if (qp)
  1959.                 frexpr (qp);
  1960.         } /* else */
  1961.     } /* for */
  1962.  
  1963.     frchain( &p0 );
  1964.     return p;
  1965. }
  1966.  
  1967.  
  1968.  void
  1969. #ifdef KR_headers
  1970. putwhile(p)
  1971.     expptr p;
  1972. #else
  1973. putwhile(expptr p)
  1974. #endif
  1975. {
  1976.     long where;
  1977.     int k, n;
  1978.  
  1979.     if (wh_next >= wh_last)
  1980.         {
  1981.         k = wh_last - wh_first;
  1982.         n = k + 100;
  1983.         wh_next = mem(n,0);
  1984.         wh_last = wh_first + n;
  1985.         if (k)
  1986.             memcpy(wh_next, wh_first, k);
  1987.         wh_first =  wh_next;
  1988.         wh_next += k;
  1989.         wh_last = wh_first + n;
  1990.         }
  1991.     p1put(P1_WHILE1START);
  1992.     where = ftell(pass1_file);
  1993.     if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype)))
  1994.         {
  1995.         if(k != TYERROR)
  1996.             err("non-logical expression in DO WHILE statement");
  1997.         }
  1998.     else    {
  1999.         p = putx(p);
  2000.         *wh_next++ = ftell(pass1_file) > where;
  2001.         p1put(P1_WHILE2START);
  2002.         p1_expr(p);
  2003.         }
  2004.     }
  2005.