home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / octa21fs.zip / octave / f2c / src / output.c < prev    next >
C/C++ Source or Header  |  2000-01-15  |  41KB  |  1,665 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. #include "defs.h"
  25. #include "names.h"
  26. #include "output.h"
  27.  
  28. #ifndef TRUE
  29. #define TRUE 1
  30. #endif
  31. #ifndef FALSE
  32. #define FALSE 0
  33. #endif
  34.  
  35. char _assoc_table[] = { 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 };
  36.  
  37. /* Opcode table -- This array is indexed by the OP_____ macros defined in
  38.    defines.h; these macros are expected to be adjacent integers, so that
  39.    this table is as small as possible. */
  40.  
  41. table_entry opcode_table[] = {
  42.                 { 0, 0, NULL },
  43.     /* OPPLUS 1 */        { BINARY_OP, 12, "%l + %r" },
  44.     /* OPMINUS 2 */        { BINARY_OP, 12, "%l - %r" },
  45.     /* OPSTAR 3 */        { BINARY_OP, 13, "%l * %r" },
  46.     /* OPSLASH 4 */        { BINARY_OP, 13, "%l / %r" },
  47.     /* OPPOWER 5 */        { BINARY_OP,  0, "power (%l, %r)" },
  48.     /* OPNEG 6 */        { UNARY_OP,  14, "-%l" },
  49.     /* OPOR 7 */        { BINARY_OP,  4, "%l || %r" },
  50.     /* OPAND 8 */        { BINARY_OP,  5, "%l && %r" },
  51.     /* OPEQV 9 */        { BINARY_OP,  9, "%l == %r" },
  52.     /* OPNEQV 10 */        { BINARY_OP,  9, "%l != %r" },
  53.     /* OPNOT 11 */        { UNARY_OP,  14, "! %l" },
  54.     /* OPCONCAT 12 */    { BINARY_OP,  0, "concat (%l, %r)" },
  55.     /* OPLT 13 */        { BINARY_OP, 10, "%l < %r" },
  56.     /* OPEQ 14 */        { BINARY_OP,  9, "%l == %r" },
  57.     /* OPGT 15 */        { BINARY_OP, 10, "%l > %r" },
  58.     /* OPLE 16 */        { BINARY_OP, 10, "%l <= %r" },
  59.     /* OPNE 17 */        { BINARY_OP,  9, "%l != %r" },
  60.     /* OPGE 18 */        { BINARY_OP, 10, "%l >= %r" },
  61.     /* OPCALL 19 */        { BINARY_OP, 15, SPECIAL_FMT },
  62.     /* OPCCALL 20 */    { BINARY_OP, 15, SPECIAL_FMT },
  63.  
  64. /* Left hand side of an assignment cannot have outermost parens */
  65.  
  66.     /* OPASSIGN 21 */    { BINARY_OP,  2, "%l = %r" },
  67.     /* OPPLUSEQ 22 */    { BINARY_OP,  2, "%l += %r" },
  68.     /* OPSTAREQ 23 */    { BINARY_OP,  2, "%l *= %r" },
  69.     /* OPCONV 24 */        { BINARY_OP, 14, "%l" },
  70.     /* OPLSHIFT 25 */    { BINARY_OP, 11, "%l << %r" },
  71.     /* OPMOD 26 */        { BINARY_OP, 13, "%l %% %r" },
  72.     /* OPCOMMA 27 */    { BINARY_OP,  1, "%l, %r" },
  73.  
  74. /* Don't want to nest the colon operator in parens */
  75.  
  76.     /* OPQUEST 28 */    { BINARY_OP, 3, "%l ? %r" },
  77.     /* OPCOLON 29 */    { BINARY_OP, 3, "%l : %r" },
  78.     /* OPABS 30 */        { UNARY_OP,  0, "abs(%l)" },
  79.     /* OPMIN 31 */        { BINARY_OP,   0, SPECIAL_FMT },
  80.     /* OPMAX 32 */        { BINARY_OP,   0, SPECIAL_FMT },
  81.     /* OPADDR 33 */        { UNARY_OP, 14, "&%l" },
  82.  
  83.     /* OPCOMMA_ARG 34 */    { BINARY_OP, 15, SPECIAL_FMT },
  84.     /* OPBITOR 35 */    { BINARY_OP,  6, "%l | %r" },
  85.     /* OPBITAND 36 */    { BINARY_OP,  8, "%l & %r" },
  86.     /* OPBITXOR 37 */    { BINARY_OP,  7, "%l ^ %r" },
  87.     /* OPBITNOT 38 */    { UNARY_OP,  14, "~ %l" },
  88.     /* OPRSHIFT 39 */    { BINARY_OP, 11, "%l >> %r" },
  89.  
  90. /* This isn't quite right -- it doesn't handle arrays, for instance */
  91.  
  92.     /* OPWHATSIN 40 */    { UNARY_OP,  14, "*%l" },
  93.     /* OPMINUSEQ 41 */    { BINARY_OP,  2, "%l -= %r" },
  94.     /* OPSLASHEQ 42 */    { BINARY_OP,  2, "%l /= %r" },
  95.     /* OPMODEQ 43 */    { BINARY_OP,  2, "%l %%= %r" },
  96.     /* OPLSHIFTEQ 44 */    { BINARY_OP,  2, "%l <<= %r" },
  97.     /* OPRSHIFTEQ 45 */    { BINARY_OP,  2, "%l >>= %r" },
  98.     /* OPBITANDEQ 46 */    { BINARY_OP,  2, "%l &= %r" },
  99.     /* OPBITXOREQ 47 */    { BINARY_OP,  2, "%l ^= %r" },
  100.     /* OPBITOREQ 48 */    { BINARY_OP,  2, "%l |= %r" },
  101.     /* OPPREINC 49 */    { UNARY_OP,  14, "++%l" },
  102.     /* OPPREDEC 50 */    { UNARY_OP,  14, "--%l" },
  103.     /* OPDOT 51 */        { BINARY_OP, 15, "%l.%r" },
  104.     /* OPARROW 52 */    { BINARY_OP, 15, "%l -> %r"},
  105.     /* OPNEG1 53 */        { UNARY_OP,  14, "-%l" },
  106.     /* OPDMIN 54 */        { BINARY_OP, 0, "dmin(%l,%r)" },
  107.     /* OPDMAX 55 */        { BINARY_OP, 0, "dmax(%l,%r)" },
  108.     /* OPASSIGNI 56 */    { BINARY_OP,  2, "%l = &%r" },
  109.     /* OPIDENTITY 57 */    { UNARY_OP, 15, "%l" },
  110.     /* OPCHARCAST 58 */    { UNARY_OP, 14, "(char *)&%l" },
  111.     /* OPDABS 59 */        { UNARY_OP, 0, "dabs(%l)" },
  112.     /* OPMIN2 60 */        { BINARY_OP,   0, "min(%l,%r)" },
  113.     /* OPMAX2 61 */        { BINARY_OP,   0, "max(%l,%r)" },
  114.  
  115. /* kludge to imitate (under forcedouble) f77's bizarre treatement of OPNEG... */
  116.  
  117.     /* OPNEG KLUDGE */    { UNARY_OP,  14, "-(doublereal)%l" }
  118. }; /* opcode_table */
  119.  
  120. #define OPNEG_KLUDGE (sizeof(opcode_table)/sizeof(table_entry) - 1)
  121.  
  122. static char opeqable[sizeof(opcode_table)/sizeof(table_entry)];
  123.  
  124.  
  125. static void output_arg_list Argdcl((FILEP, struct Listblock*));
  126. static void output_binary Argdcl((FILEP, Exprp));
  127. static void output_list Argdcl((FILEP, struct Listblock*));
  128. static void output_literal Argdcl((FILEP, int, Constp));
  129. static void output_prim Argdcl((FILEP, struct Primblock*));
  130. static void output_unary Argdcl((FILEP, Exprp));
  131.  
  132.  
  133.  void
  134. #ifdef KR_headers
  135. expr_out(fp, e)
  136.     FILE *fp;
  137.     expptr e;
  138. #else
  139. expr_out(FILE *fp, expptr e)
  140. #endif
  141. {
  142.     if (e == (expptr) NULL)
  143.     return;
  144.  
  145.     switch (e -> tag) {
  146.     case TNAME:    out_name (fp, (struct Nameblock *) e);
  147.             return;
  148.  
  149.     case TCONST:    out_const(fp, &e->constblock);
  150.             goto end_out;
  151.     case TEXPR:
  152.                 break;
  153.  
  154.     case TADDR:    out_addr (fp, &(e -> addrblock));
  155.             goto end_out;
  156.  
  157.     case TPRIM:    warn ("expr_out: got TPRIM");
  158.             output_prim (fp, &(e -> primblock));
  159.             return;
  160.  
  161.     case TLIST:    output_list (fp, &(e -> listblock));
  162.  end_out:        frexpr(e);
  163.             return;
  164.  
  165.     case TIMPLDO:    err ("expr_out: got TIMPLDO");
  166.             return;
  167.  
  168.     case TERROR:
  169.     default:
  170.             erri ("expr_out: bad tag '%d'", e -> tag);
  171.     } /* switch */
  172.  
  173. /* Now we know that the tag is TEXPR */
  174.  
  175. /* Optimize on simple expressions, such as "a = a + b" ==> "a += b" */
  176.  
  177.     if (e -> exprblock.opcode == OPASSIGN && e -> exprblock.rightp &&
  178.     e -> exprblock.rightp -> tag == TEXPR) {
  179.     int opcode;
  180.  
  181.     opcode = e -> exprblock.rightp -> exprblock.opcode;
  182.  
  183.     if (opeqable[opcode]) {
  184.         expptr leftp, rightp;
  185.  
  186.         if ((leftp = e -> exprblock.leftp) &&
  187.         (rightp = e -> exprblock.rightp -> exprblock.leftp)) {
  188.  
  189.         if (same_ident (leftp, rightp)) {
  190.             expptr temp = e -> exprblock.rightp;
  191.  
  192.             e -> exprblock.opcode = op_assign(opcode);
  193.  
  194.             e -> exprblock.rightp = temp -> exprblock.rightp;
  195.             temp->exprblock.rightp = 0;
  196.             frexpr(temp);
  197.         } /* if same_ident (leftp, rightp) */
  198.         } /* if leftp && rightp */
  199.     } /* if opcode == OPPLUS || */
  200.     } /* if e -> exprblock.opcode == OPASSIGN */
  201.  
  202.  
  203. /* Optimize on increment or decrement by 1 */
  204.  
  205.     {
  206.     int opcode = e -> exprblock.opcode;
  207.     expptr leftp = e -> exprblock.leftp;
  208.     expptr rightp = e -> exprblock.rightp;
  209.  
  210.     if (leftp && rightp && (leftp -> headblock.vstg == STGARG ||
  211.         ISINT (leftp -> headblock.vtype)) &&
  212.         (opcode == OPPLUSEQ || opcode == OPMINUSEQ) &&
  213.         ISINT (rightp -> headblock.vtype) &&
  214.         ISICON (e -> exprblock.rightp) &&
  215.         (ISONE (e -> exprblock.rightp) ||
  216.         e -> exprblock.rightp -> constblock.Const.ci == -1)) {
  217.  
  218. /* Allow for the '-1' constant value */
  219.  
  220.         if (!ISONE (e -> exprblock.rightp))
  221.         opcode = (opcode == OPPLUSEQ) ? OPMINUSEQ : OPPLUSEQ;
  222.  
  223. /* replace the existing opcode */
  224.  
  225.         if (opcode == OPPLUSEQ)
  226.         e -> exprblock.opcode = OPPREINC;
  227.         else
  228.         e -> exprblock.opcode = OPPREDEC;
  229.  
  230. /* Free up storage used by the right hand side */
  231.  
  232.         frexpr (e -> exprblock.rightp);
  233.         e->exprblock.rightp = 0;
  234.     } /* if opcode == OPPLUS */
  235.     } /* block */
  236.  
  237.  
  238.     if (is_unary_op (e -> exprblock.opcode))
  239.     output_unary (fp, &(e -> exprblock));
  240.     else if (is_binary_op (e -> exprblock.opcode))
  241.     output_binary (fp, &(e -> exprblock));
  242.     else
  243.     erri ("expr_out: bad opcode '%d'", (int) e -> exprblock.opcode);
  244.  
  245.     free((char *)e);
  246.  
  247. } /* expr_out */
  248.  
  249.  
  250.  void
  251. #ifdef KR_headers
  252. out_and_free_statement(outfile, expr)
  253.     FILE *outfile;
  254.     expptr expr;
  255. #else
  256. out_and_free_statement(FILE *outfile, expptr expr)
  257. #endif
  258. {
  259.     if (expr)
  260.     expr_out (outfile, expr);
  261.  
  262.     nice_printf (outfile, ";\n");
  263. } /* out_and_free_statement */
  264.  
  265.  
  266.  
  267.  int
  268. #ifdef KR_headers
  269. same_ident(left, right)
  270.     expptr left;
  271.     expptr right;
  272. #else
  273. same_ident(expptr left, expptr right)
  274. #endif
  275. {
  276.     if (!left || !right)
  277.     return 0;
  278.  
  279.     if (left -> tag == TNAME && right -> tag == TNAME && left == right)
  280.     return 1;
  281.  
  282.     if (left -> tag == TADDR && right -> tag == TADDR &&
  283.         left -> addrblock.uname_tag == right -> addrblock.uname_tag)
  284.     switch (left -> addrblock.uname_tag) {
  285.         case UNAM_REF:
  286.         case UNAM_NAME:
  287.  
  288. /* Check for array subscripts */
  289.  
  290.         if (left -> addrblock.user.name -> vdim ||
  291.             right -> addrblock.user.name -> vdim)
  292.             if (left -> addrblock.user.name !=
  293.                 right -> addrblock.user.name ||
  294.                 !same_expr (left -> addrblock.memoffset,
  295.                 right -> addrblock.memoffset))
  296.             return 0;
  297.  
  298.         return same_ident ((expptr) (left -> addrblock.user.name),
  299.             (expptr) right -> addrblock.user.name);
  300.         case UNAM_IDENT:
  301.         return strcmp(left->addrblock.user.ident,
  302.                 right->addrblock.user.ident) == 0;
  303.         case UNAM_CHARP:
  304.         return strcmp(left->addrblock.user.Charp,
  305.                 right->addrblock.user.Charp) == 0;
  306.         default:
  307.             return 0;
  308.     } /* switch */
  309.  
  310.     if (left->tag == TEXPR && left->exprblock.opcode == OPWHATSIN
  311.     && right->tag == TEXPR && right->exprblock.opcode == OPWHATSIN)
  312.         return same_ident(left->exprblock.leftp,
  313.                  right->exprblock.leftp);
  314.  
  315.     return 0;
  316. } /* same_ident */
  317.  
  318.  static int
  319. #ifdef KR_headers
  320. samefpconst(c1, c2, n)
  321.     register Constp c1;
  322.     register Constp c2;
  323.     register int n;
  324. #else
  325. samefpconst(register Constp c1, register Constp c2, register int n)
  326. #endif
  327. {
  328.     char *s1, *s2;
  329.     if (!c1->vstg && !c2->vstg)
  330.         return c1->Const.cd[n] == c2->Const.cd[n];
  331.     s1 = c1->vstg ? c1->Const.cds[n] : dtos(c1->Const.cd[n]);
  332.     s2 = c2->vstg ? c2->Const.cds[n] : dtos(c2->Const.cd[n]);
  333.     return !strcmp(s1, s2);
  334.     }
  335.  
  336.  static int
  337. #ifdef KR_headers
  338. sameconst(c1, c2)
  339.     register Constp c1;
  340.     register Constp c2;
  341. #else
  342. sameconst(register Constp c1, register Constp c2)
  343. #endif
  344. {
  345.     switch(c1->vtype) {
  346.         case TYCOMPLEX:
  347.         case TYDCOMPLEX:
  348.             if (!samefpconst(c1,c2,1))
  349.                 return 0;
  350.         case TYREAL:
  351.         case TYDREAL:
  352.             return samefpconst(c1,c2,0);
  353.         case TYCHAR:
  354.             return c1->Const.ccp1.blanks == c2->Const.ccp1.blanks
  355.                 &&       c1->vleng->constblock.Const.ci
  356.                 == c2->vleng->constblock.Const.ci
  357.                 && !memcmp(c1->Const.ccp, c2->Const.ccp,
  358.                     (int)c1->vleng->constblock.Const.ci);
  359.         case TYSHORT:
  360.         case TYINT:
  361.         case TYLOGICAL:
  362.             return c1->Const.ci == c2->Const.ci;
  363.         }
  364.     err("unexpected type in sameconst");
  365.     return 0;
  366.     }
  367.  
  368. /* same_expr -- Returns true only if   e1 and e2   match.  This is
  369.    somewhat pessimistic, but can afford to be because it's just used to
  370.    optimize on the assignment operators (+=, -=, etc). */
  371.  
  372.  int
  373. #ifdef KR_headers
  374. same_expr(e1, e2)
  375.     expptr e1;
  376.     expptr e2;
  377. #else
  378. same_expr(expptr e1, expptr e2)
  379. #endif
  380. {
  381.     if (!e1 || !e2)
  382.     return !e1 && !e2;
  383.  
  384.     if (e1 -> tag != e2 -> tag || e1 -> headblock.vtype != e2 -> headblock.vtype)
  385.     return 0;
  386.  
  387.     switch (e1 -> tag) {
  388.         case TEXPR:
  389.         if (e1 -> exprblock.opcode != e2 -> exprblock.opcode)
  390.         return 0;
  391.  
  392.         return same_expr (e1 -> exprblock.leftp, e2 -> exprblock.leftp) &&
  393.            same_expr (e1 -> exprblock.rightp, e2 -> exprblock.rightp);
  394.     case TNAME:
  395.     case TADDR:
  396.         return same_ident (e1, e2);
  397.     case TCONST:
  398.         return sameconst(&e1->constblock, &e2->constblock);
  399.     default:
  400.         return 0;
  401.     } /* switch */
  402. } /* same_expr */
  403.  
  404.  
  405.  
  406.  void
  407. #ifdef KR_headers
  408. out_name(fp, namep)
  409.     FILE *fp;
  410.     Namep namep;
  411. #else
  412. out_name(FILE *fp, Namep namep)
  413. #endif
  414. {
  415.     extern int usedefsforcommon;
  416.     Extsym *comm;
  417.  
  418.     if (namep == NULL)
  419.     return;
  420.  
  421. /* DON'T want to use oneof_stg() here; need to find the right common name
  422.    */
  423.  
  424.     if (namep->vstg == STGCOMMON && !namep->vcommequiv && !usedefsforcommon) {
  425.     comm = &extsymtab[namep->vardesc.varno];
  426.     extern_out(fp, comm);
  427.     nice_printf(fp, "%d.", comm->curno);
  428.     } /* if namep -> vstg == STGCOMMON */
  429.  
  430.     if (namep->vprocclass == PTHISPROC && namep->vtype != TYSUBR)
  431.     nice_printf(fp, xretslot[namep->vtype]->user.ident);
  432.     else
  433.     nice_printf (fp, "%s", namep->cvarname);
  434. } /* out_name */
  435.  
  436.  
  437. static char *Longfmt = "%ld";
  438.  
  439. #define cpd(n) cp->vstg ? cp->Const.cds[n] : dtos(cp->Const.cd[n])
  440.  
  441.  void
  442. #ifdef KR_headers
  443. out_const(fp, cp)
  444.     FILE *fp;
  445.     register Constp cp;
  446. #else
  447. out_const(FILE *fp, register Constp cp)
  448. #endif
  449. {
  450.     static char real_buf[50], imag_buf[50];
  451.     unsigned int k;
  452.     int type = cp->vtype;
  453.  
  454.     switch (type) {
  455.     case TYINT1:
  456.         case TYSHORT:
  457.         nice_printf (fp, "%ld", cp->Const.ci);    /* don't cast ci! */
  458.         break;
  459.     case TYLONG:
  460. #ifdef TYQUAD
  461.     case TYQUAD:
  462. #endif
  463.         nice_printf (fp, Longfmt, cp->Const.ci);    /* don't cast ci! */
  464.         break;
  465.     case TYREAL:
  466.         nice_printf(fp, "%s", flconst(real_buf, cpd(0)));
  467.         break;
  468.     case TYDREAL:
  469.         nice_printf(fp, "%s", cpd(0));
  470.         break;
  471.     case TYCOMPLEX:
  472.         nice_printf(fp, cm_fmt_string, flconst(real_buf, cpd(0)),
  473.             flconst(imag_buf, cpd(1)));
  474.         break;
  475.     case TYDCOMPLEX:
  476.         nice_printf(fp, dcm_fmt_string, cpd(0), cpd(1));
  477.         break;
  478.     case TYLOGICAL1:
  479.     case TYLOGICAL2:
  480.     case TYLOGICAL:
  481.         nice_printf (fp, "%s", cp->Const.ci ? "TRUE_" : "FALSE_");
  482.         break;
  483.     case TYCHAR: {
  484.         char *c = cp->Const.ccp, *ce;
  485.  
  486.         if (c == NULL) {
  487.         nice_printf (fp, "\"\"");
  488.         break;
  489.         } /* if c == NULL */
  490.  
  491.         nice_printf (fp, "\"");
  492.         ce = c + cp->vleng->constblock.Const.ci;
  493.         while(c < ce) {
  494.         k = *(unsigned char *)c++;
  495.         nice_printf(fp, str_fmt[k], k);
  496.         }
  497.         for(k = cp->Const.ccp1.blanks; k > 0; k--)
  498.         nice_printf(fp, " ");
  499.         nice_printf (fp, "\"");
  500.         break;
  501.     } /* case TYCHAR */
  502.     default:
  503.         erri ("out_const:  bad type '%d'", (int) type);
  504.         break;
  505.     } /* switch */
  506.  
  507. } /* out_const */
  508. #undef cpd
  509.  
  510.  static void
  511. #ifdef KR_headers
  512. out_args(fp, ep)
  513.     FILE *fp;
  514.     expptr ep;
  515. #else
  516. out_args(FILE *fp, expptr ep)
  517. #endif
  518. {
  519.     chainp arglist;
  520.  
  521.     if(ep->tag != TLIST)
  522.         badtag("out_args", ep->tag);
  523.     for(arglist = ep->listblock.listp;;) {
  524.         expr_out(fp, (expptr)arglist->datap);
  525.         arglist->datap = 0;
  526.         if (!(arglist = arglist->nextp))
  527.             break;
  528.         nice_printf(fp, ", ");
  529.         }
  530.     }
  531.  
  532.  
  533. /* out_addr -- this routine isn't local because it is called by the
  534.    system-generated identifier printing routines */
  535.  
  536.  void
  537. #ifdef KR_headers
  538. out_addr(fp, addrp)
  539.     FILE *fp;
  540.     struct Addrblock *addrp;
  541. #else
  542. out_addr(FILE *fp, struct Addrblock *addrp)
  543. #endif
  544. {
  545.     extern Extsym *extsymtab;
  546.     int was_array = 0;
  547.     char *s;
  548.  
  549.  
  550.     if (addrp == NULL)
  551.         return;
  552.     if (doin_setbound
  553.             && addrp->vstg == STGARG
  554.             && addrp->vtype != TYCHAR
  555.             && ISICON(addrp->memoffset)
  556.             && !addrp->memoffset->constblock.Const.ci)
  557.         nice_printf(fp, "*");
  558.  
  559.     switch (addrp -> uname_tag) {
  560.         case UNAM_REF:
  561.         nice_printf(fp, "%s_%s(", addrp->user.name->cvarname,
  562.             addrp->cmplx_sub ? "subscr" : "ref");
  563.         out_args(fp, addrp->memoffset);
  564.         nice_printf(fp, ")");
  565.         return;
  566.         case UNAM_NAME:
  567.         out_name (fp, addrp -> user.name);
  568.         break;
  569.         case UNAM_IDENT:
  570.         if (*(s = addrp->user.ident) == ' ') {
  571.             if (multitype)
  572.                 nice_printf(fp, "%s",
  573.                     xretslot[addrp->vtype]->user.ident);
  574.             else
  575.                 nice_printf(fp, "%s", s+1);
  576.             }
  577.         else {
  578.             nice_printf(fp, "%s", s);
  579.             }
  580.         break;
  581.         case UNAM_CHARP:
  582.         nice_printf(fp, "%s", addrp->user.Charp);
  583.         break;
  584.         case UNAM_EXTERN:
  585.         extern_out (fp, &extsymtab[addrp -> memno]);
  586.         break;
  587.         case UNAM_CONST:
  588.         switch(addrp->vstg) {
  589.             case STGCONST:
  590.                 out_const(fp, (Constp)addrp);
  591.                 break;
  592.             case STGMEMNO:
  593.                 output_literal (fp, (int)addrp->memno,
  594.                     (Constp)addrp);
  595.                 break;
  596.             default:
  597.             Fatal("unexpected vstg in out_addr");
  598.             }
  599.         break;
  600.         case UNAM_UNKNOWN:
  601.         default:
  602.         nice_printf (fp, "Unknown Addrp");
  603.         break;
  604.     } /* switch */
  605.  
  606. /* It's okay to just throw in the brackets here because they have a
  607.    precedence level of 15, the highest value.  */
  608.  
  609.     if ((addrp->uname_tag == UNAM_NAME && addrp->user.name->vdim
  610.             || addrp->ntempelt > 1 || addrp->isarray)
  611.     && addrp->vtype != TYCHAR) {
  612.     expptr offset;
  613.  
  614.     was_array = 1;
  615.  
  616.     offset = addrp -> memoffset;
  617.     addrp->memoffset = 0;
  618.     if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV))
  619.         && addrp -> uname_tag == UNAM_NAME
  620.         && !addrp->skip_offset)
  621.         offset = mkexpr (OPMINUS, offset, mkintcon (
  622.             addrp -> user.name -> voffset));
  623.  
  624.     nice_printf (fp, "[");
  625.  
  626.     offset = mkexpr (OPSLASH, offset,
  627.         ICON (typesize[addrp -> vtype] * (addrp -> Field ? 2 : 1)));
  628.     expr_out (fp, offset);
  629.     nice_printf (fp, "]");
  630.     }
  631.  
  632. /* Check for structure field reference */
  633.  
  634.     if (addrp -> Field && addrp -> uname_tag != UNAM_CONST &&
  635.         addrp -> uname_tag != UNAM_UNKNOWN) {
  636.     if (oneof_stg((addrp -> uname_tag == UNAM_NAME ? addrp -> user.name :
  637.         (Namep) NULL), addrp -> vstg, M(STGARG)|M(STGEQUIV))
  638.         && !was_array && (addrp->vclass != CLPROC || !multitype))
  639.         nice_printf (fp, "->%s", addrp -> Field);
  640.     else
  641.         nice_printf (fp, ".%s", addrp -> Field);
  642.     } /* if */
  643.  
  644. /* Check for character subscripting */
  645.  
  646.     if (addrp->vtype == TYCHAR &&
  647.         (addrp->vclass != CLPROC || addrp->uname_tag == UNAM_NAME
  648.             && addrp->user.name->vprocclass == PTHISPROC) &&
  649.         addrp -> memoffset &&
  650.         (addrp -> uname_tag != UNAM_NAME ||
  651.          addrp -> user.name -> vtype == TYCHAR) &&
  652.         (!ISICON (addrp -> memoffset) ||
  653.          (addrp -> memoffset -> constblock.Const.ci))) {
  654.  
  655.     int use_paren = 0;
  656.     expptr e = addrp -> memoffset;
  657.  
  658.     if (!e)
  659.         return;
  660.     addrp->memoffset = 0;
  661.  
  662.     if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV))
  663.      && addrp -> uname_tag == UNAM_NAME) {
  664.         e = mkexpr (OPMINUS, e, mkintcon (addrp -> user.name -> voffset));
  665.  
  666. /* mkexpr will simplify it to zero if possible */
  667.         if (e->tag == TCONST && e->constblock.Const.ci == 0)
  668.         return;
  669.     } /* if addrp -> vstg == STGCOMMON */
  670.  
  671. /* In the worst case, parentheses might be needed OUTSIDE the expression,
  672.    too.  But since I think this subscripting can only appear as a
  673.    parameter in a procedure call, I don't think outside parens will ever
  674.    be needed.  INSIDE parens are handled below */
  675.  
  676.     nice_printf (fp, " + ");
  677.     if (e -> tag == TEXPR) {
  678.         int arg_prec = op_precedence (e -> exprblock.opcode);
  679.         int prec = op_precedence (OPPLUS);
  680.         use_paren = arg_prec && (arg_prec < prec || (arg_prec == prec &&
  681.             is_left_assoc (OPPLUS)));
  682.     } /* if e -> tag == TEXPR */
  683.     if (use_paren) nice_printf (fp, "(");
  684.     expr_out (fp, e);
  685.     if (use_paren) nice_printf (fp, ")");
  686.     } /* if */
  687. } /* out_addr */
  688.  
  689.  
  690.  static void
  691. #ifdef KR_headers
  692. output_literal(fp, memno, cp)
  693.     FILE *fp;
  694.     int memno;
  695.     Constp cp;
  696. #else
  697. output_literal(FILE *fp, int memno, Constp cp)
  698. #endif
  699. {
  700.     struct Literal *litp, *lastlit;
  701.  
  702.     lastlit = litpool + nliterals;
  703.  
  704.     for (litp = litpool; litp < lastlit; litp++) {
  705.     if (litp -> litnum == memno)
  706.         break;
  707.     } /* for litp */
  708.  
  709.     if (litp >= lastlit)
  710.     out_const (fp, cp);
  711.     else {
  712.     nice_printf (fp, "%s", lit_name (litp));
  713.     litp->lituse++;
  714.     }
  715. } /* output_literal */
  716.  
  717.  
  718.  static void
  719. #ifdef KR_headers
  720. output_prim(fp, primp)
  721.     FILE *fp;
  722.     struct Primblock *primp;
  723. #else
  724. output_prim(FILE *fp, struct Primblock *primp)
  725. #endif
  726. {
  727.     if (primp == NULL)
  728.     return;
  729.  
  730.     out_name (fp, primp -> namep);
  731.     if (primp -> argsp)
  732.     output_arg_list (fp, primp -> argsp);
  733.  
  734.     if (primp -> fcharp != (expptr) NULL || primp -> lcharp != (expptr) NULL)
  735.     nice_printf (fp, "Sorry, no substrings yet");
  736. }
  737.  
  738.  
  739.  
  740.  static void
  741. #ifdef KR_headers
  742. output_arg_list(fp, listp)
  743.     FILE *fp;
  744.     struct Listblock *listp;
  745. #else
  746. output_arg_list(FILE *fp, struct Listblock *listp)
  747. #endif
  748. {
  749.     chainp arg_list;
  750.  
  751.     if (listp == (struct Listblock *) NULL || listp -> listp == (chainp) NULL)
  752.     return;
  753.  
  754.     nice_printf (fp, "(");
  755.  
  756.     for (arg_list = listp -> listp; arg_list; arg_list = arg_list -> nextp) {
  757.     expr_out (fp, (expptr) arg_list -> datap);
  758.     if (arg_list -> nextp != (chainp) NULL)
  759.  
  760. /* Might want to add a hook in here to accomodate the style setting which
  761.    wants spaces after commas */
  762.  
  763.         nice_printf (fp, ",");
  764.     } /* for arg_list */
  765.  
  766.     nice_printf (fp, ")");
  767. } /* output_arg_list */
  768.  
  769.  
  770.  
  771.  static void
  772. #ifdef KR_headers
  773. output_unary(fp, e)
  774.     FILE *fp;
  775.     struct Exprblock *e;
  776. #else
  777. output_unary(FILE *fp, struct Exprblock *e)
  778. #endif
  779. {
  780.     if (e == NULL)
  781.     return;
  782.  
  783.     switch (e -> opcode) {
  784.         case OPNEG:
  785.         if (e->vtype == TYREAL && forcedouble) {
  786.             e->opcode = OPNEG_KLUDGE;
  787.             output_binary(fp,e);
  788.             e->opcode = OPNEG;
  789.             break;
  790.             }
  791.     case OPNEG1:
  792.     case OPNOT:
  793.     case OPABS:
  794.     case OPBITNOT:
  795.     case OPWHATSIN:
  796.     case OPPREINC:
  797.     case OPPREDEC:
  798.     case OPADDR:
  799.     case OPIDENTITY:
  800.     case OPCHARCAST:
  801.     case OPDABS:
  802.         output_binary (fp, e);
  803.         break;
  804.     case OPCALL:
  805.     case OPCCALL:
  806.         nice_printf (fp, "Sorry, no OPCALL yet");
  807.         break;
  808.     default:
  809.         erri ("output_unary: bad opcode", (int) e -> opcode);
  810.         break;
  811.     } /* switch */
  812. } /* output_unary */
  813.  
  814.  
  815.  static char *
  816. #ifdef KR_headers
  817. findconst(m)
  818.     register long m;
  819. #else
  820. findconst(register long m)
  821. #endif
  822. {
  823.     register struct Literal *litp, *litpe;
  824.  
  825.     litp = litpool;
  826.     for(litpe = litp + nliterals; litp < litpe; litp++)
  827.         if (litp->litnum ==  m)
  828.             return litp->cds[0];
  829.     Fatal("findconst failure!");
  830.     return 0;
  831.     }
  832.  
  833.  static int
  834. #ifdef KR_headers
  835. opconv_fudge(fp, e)
  836.     FILE *fp;
  837.     struct Exprblock *e;
  838. #else
  839. opconv_fudge(FILE *fp, struct Exprblock *e)
  840. #endif
  841. {
  842.     /* special handling for ichar and character*1 */
  843.     register expptr lp;
  844.     register union Expression *Offset;
  845.     register char *cp;
  846.     int lt;
  847.     char buf[8];
  848.     unsigned int k;
  849.     Namep np;
  850.  
  851.     if (!(lp = e->leftp))    /* possible with erroneous Fortran */
  852.         return 1;
  853.     lt = lp->headblock.vtype;
  854.     if (lt == TYCHAR) {
  855.         switch(lp->tag) {
  856.             case TNAME:
  857.                 nice_printf(fp, "*");
  858.                 out_name(fp, (Namep)lp);
  859.                 return 1;
  860.             case TCONST:
  861.  tconst:
  862.                 cp = lp->constblock.Const.ccp;
  863.  tconst1:
  864.                 k = *(unsigned char *)cp;
  865.                 sprintf(buf, chr_fmt[k], k);
  866.                 nice_printf(fp, "'%s'", buf);
  867.                 return 1;
  868.             case TADDR:
  869.                 switch(lp->addrblock.vstg) {
  870.                     case STGMEMNO:
  871.                     if (halign && e->vtype != TYCHAR) {
  872.                         nice_printf(fp, "*(%s *)",
  873.                             c_type_decl(e->vtype,0));
  874.                         expr_out(fp, lp);
  875.                         return 1;
  876.                         }
  877.                     cp = findconst(lp->addrblock.memno);
  878.                     goto tconst1;
  879.                     case STGCONST:
  880.                     goto tconst;
  881.                     }
  882.                 lp->addrblock.vtype = tyint;
  883.                 Offset = lp->addrblock.memoffset;
  884.                 switch(lp->addrblock.uname_tag) {
  885.                   case UNAM_REF:
  886.                     nice_printf(fp, "*");
  887.                     return 0;
  888.                   case UNAM_NAME:
  889.                     np = lp->addrblock.user.name;
  890.                     if (ONEOF(np->vstg,
  891.                         M(STGCOMMON)|M(STGEQUIV)))
  892.                         Offset = mkexpr(OPMINUS, Offset,
  893.                             ICON(np->voffset));
  894.                     }
  895.                 lp->addrblock.memoffset = Offset ?
  896.                     mkexpr(OPSTAR, Offset,
  897.                         ICON(typesize[tyint]))
  898.                     : ICON(0);
  899.                 lp->addrblock.isarray = 1;
  900.                 /* STGCOMMON or STGEQUIV would cause */
  901.                 /* voffset to be added in a second time */
  902.                 lp->addrblock.vstg = STGUNKNOWN;
  903.                 break;
  904.             default:
  905.                 badtag("opconv_fudge", lp->tag);
  906.             }
  907.         }
  908.     if (lt != e->vtype)
  909.         nice_printf(fp, "(%s) ",
  910.             c_type_decl(e->vtype, 0));
  911.     return 0;
  912.     }
  913.  
  914.  
  915.  static void
  916. #ifdef KR_headers
  917. output_binary(fp, e)
  918.     FILE *fp;
  919.     struct Exprblock *e;
  920. #else
  921. output_binary(FILE *fp, struct Exprblock *e)
  922. #endif
  923. {
  924.     char *format;
  925.     extern table_entry opcode_table[];
  926.     int prec;
  927.  
  928.     if (e == NULL || e -> tag != TEXPR)
  929.     return;
  930.  
  931. /* Instead of writing a huge switch, I've incorporated the output format
  932.    into a table.  Things like "%l" and "%r" stand for the left and
  933.    right subexpressions.  This should allow both prefix and infix
  934.    functions to be specified (e.g. "(%l * %r", "z_div (%l, %r").  Of
  935.    course, I should REALLY think out the ramifications of writing out
  936.    straight text, as opposed to some intermediate format, which could
  937.    figure out and optimize on the the number of required blanks (we don't
  938.    want "x - (-y)" to become "x --y", for example).  Special cases (such as
  939.    incomplete implementations) could still be implemented as part of the
  940.    switch, they will just have some dummy value instead of the string
  941.    pattern.  Another difficulty is the fact that the complex functions
  942.    will differ from the integer and real ones */
  943.  
  944. /* Handle a special case.  We don't want to output "x + - 4", or "y - - 3"
  945. */
  946.     if ((e -> opcode == OPPLUS || e -> opcode == OPMINUS) &&
  947.         e -> rightp && e -> rightp -> tag == TCONST &&
  948.         isnegative_const (&(e -> rightp -> constblock)) &&
  949.         is_negatable (&(e -> rightp -> constblock))) {
  950.  
  951.     e -> opcode = (e -> opcode == OPPLUS) ? OPMINUS : OPPLUS;
  952.     negate_const (&(e -> rightp -> constblock));
  953.     } /* if e -> opcode == PLUS or MINUS */
  954.  
  955.     prec = op_precedence (e -> opcode);
  956.     format = op_format (e -> opcode);
  957.  
  958.     if (format != SPECIAL_FMT) {
  959.     while (*format) {
  960.         if (*format == '%') {
  961.         int arg_prec, use_paren = 0;
  962.         expptr lp, rp;
  963.  
  964.         switch (*(format + 1)) {
  965.             case 'l':
  966.             lp = e->leftp;
  967.             if (lp && lp->tag == TEXPR) {
  968.                 arg_prec = op_precedence(lp->exprblock.opcode);
  969.  
  970.                 use_paren = arg_prec &&
  971.                     (arg_prec < prec || (arg_prec == prec &&
  972.                     is_right_assoc (prec)));
  973.             } /* if e -> leftp */
  974.             if (e->opcode == OPCONV && opconv_fudge(fp,e))
  975.                 break;
  976.             if (use_paren)
  977.                 nice_printf (fp, "(");
  978.                 expr_out(fp, lp);
  979.             if (use_paren)
  980.                 nice_printf (fp, ")");
  981.                 break;
  982.             case 'r':
  983.             rp = e->rightp;
  984.             if (rp && rp->tag == TEXPR) {
  985.                 arg_prec = op_precedence(rp->exprblock.opcode);
  986.  
  987.                 use_paren = arg_prec &&
  988.                     (arg_prec < prec || (arg_prec == prec &&
  989.                     is_left_assoc (prec)));
  990.                 use_paren = use_paren ||
  991.                 (rp->exprblock.opcode == OPNEG
  992.                 && prec >= op_precedence(OPMINUS));
  993.             } /* if e -> rightp */
  994.             if (use_paren)
  995.                 nice_printf (fp, "(");
  996.                 expr_out(fp, rp);
  997.             if (use_paren)
  998.                 nice_printf (fp, ")");
  999.                 break;
  1000.             case '\0':
  1001.             case '%':
  1002.                 nice_printf (fp, "%%");
  1003.                 break;
  1004.             default:
  1005.                 erri ("output_binary: format err: '%%%c' illegal",
  1006.                 (int) *(format + 1));
  1007.                 break;
  1008.         } /* switch */
  1009.         format += 2;
  1010.         } else
  1011.         nice_printf (fp, "%c", *format++);
  1012.     } /* while *format */
  1013.     } else {
  1014.  
  1015. /* Handle Special cases of formatting */
  1016.  
  1017.     switch (e -> opcode) {
  1018.         case OPCCALL:
  1019.         case OPCALL:
  1020.             out_call (fp, (int) e -> opcode, e -> vtype,
  1021.                     e -> vleng, e -> leftp, e -> rightp);
  1022.             break;
  1023.  
  1024.         case OPCOMMA_ARG:
  1025.             doin_setbound = 1;
  1026.             nice_printf(fp, "(");
  1027.             expr_out(fp, e->leftp);
  1028.             nice_printf(fp, ", &");
  1029.             doin_setbound = 0;
  1030.             expr_out(fp, e->rightp);
  1031.             nice_printf(fp, ")");
  1032.             break;
  1033.  
  1034.         case OPADDR:
  1035.         default:
  1036.                 nice_printf (fp, "Sorry, can't format OPCODE '%d'",
  1037.                 e -> opcode);
  1038.                 break;
  1039.         }
  1040.  
  1041.     } /* else */
  1042. } /* output_binary */
  1043.  
  1044.  void
  1045. #ifdef KR_headers
  1046. out_call(outfile, op, ftype, len, name, args)
  1047.     FILE *outfile;
  1048.     int op;
  1049.     int ftype;
  1050.     expptr len;
  1051.     expptr name;
  1052.     expptr args;
  1053. #else
  1054. out_call(FILE *outfile, int op, int ftype, expptr len, expptr name, expptr args)
  1055. #endif
  1056. {
  1057.     chainp arglist;        /* Pointer to any actual arguments */
  1058.     chainp cp;            /* Iterator over argument lists */
  1059.     Addrp ret_val = (Addrp) NULL;
  1060.                 /* Function return value buffer, if any is
  1061.                    required */
  1062.     int byvalue;        /* True iff we're calling a C library
  1063.                    routine */
  1064.     int done_once;        /* Used for writing commas to   outfile   */
  1065.     int narg, t;
  1066.     register expptr q;
  1067.     long L;
  1068.     Argtypes *at;
  1069.     Atype *A, *Ac;
  1070.     Namep np;
  1071.     extern int forcereal;
  1072.  
  1073. /* Don't use addresses if we're calling a C function */
  1074.  
  1075.     byvalue = op == OPCCALL;
  1076.  
  1077.     if (args)
  1078.     arglist = args -> listblock.listp;
  1079.     else
  1080.     arglist = CHNULL;
  1081.  
  1082. /* If this is a CHARACTER function, the first argument is the result */
  1083.  
  1084.     if (ftype == TYCHAR)
  1085.     if (ISICON (len)) {
  1086.         ret_val = (Addrp) (arglist -> datap);
  1087.         arglist = arglist -> nextp;
  1088.     } else {
  1089.         err ("adjustable character function");
  1090.         return;
  1091.     } /* else */
  1092.  
  1093. /* If this is a COMPLEX function, the first argument is the result */
  1094.  
  1095.     else if (ISCOMPLEX (ftype)) {
  1096.     ret_val = (Addrp) (arglist -> datap);
  1097.     arglist = arglist -> nextp;
  1098.     } /* if ISCOMPLEX */
  1099.  
  1100. /* Now we can actually start to write out the function invocation */
  1101.  
  1102.     if (ftype == TYREAL && forcereal)
  1103.     nice_printf(outfile, "(real)");
  1104.     if (name -> tag == TEXPR && name -> exprblock.opcode == OPWHATSIN) {
  1105.     nice_printf (outfile, "(");
  1106.     np = (Namep)name->exprblock.leftp; /*expr_out will free name */
  1107.     expr_out (outfile, name);
  1108.     nice_printf (outfile, ")");
  1109.     }
  1110.     else {
  1111.     np = (Namep)name;
  1112.     expr_out(outfile, name);
  1113.     }
  1114.  
  1115.     /* prepare to cast procedure parameters -- set A if we know how */
  1116.  
  1117.     A = Ac = 0;
  1118.     if (np->tag == TNAME && (at = np->arginfo)) {
  1119.     if (at->nargs > 0)
  1120.         A = at->atypes;
  1121.     if (Ansi && (at->defined || at->nargs > 0))
  1122.         Ac = at->atypes;
  1123.         }
  1124.  
  1125.     nice_printf(outfile, "(");
  1126.  
  1127.     if (ret_val) {
  1128.     if (ISCOMPLEX (ftype))
  1129.         nice_printf (outfile, "&");
  1130.     expr_out (outfile, (expptr) ret_val);
  1131.     if (Ac)
  1132.         Ac++;
  1133.  
  1134. /* The length of the result of a character function is the second argument */
  1135. /* It should be in place from putcall(), so we won't touch it explicitly */
  1136.  
  1137.     } /* if ret_val */
  1138.     done_once = ret_val ? TRUE : FALSE;
  1139.  
  1140. /* Now run through the named arguments */
  1141.  
  1142.     narg = -1;
  1143.     for (cp = arglist; cp; cp = cp -> nextp, done_once = TRUE) {
  1144.  
  1145.     if (done_once)
  1146.         nice_printf (outfile, ", ");
  1147.     narg++;
  1148.  
  1149.     if (!( q = (expptr)cp->datap) )
  1150.         continue;
  1151.  
  1152.     if (q->tag == TADDR) {
  1153.         if (q->addrblock.vtype > TYERROR) {
  1154.             /* I/O block */
  1155.             nice_printf(outfile, "&%s", q->addrblock.user.ident);
  1156.             continue;
  1157.             }
  1158.         if (!byvalue && q->addrblock.isarray
  1159.         && q->addrblock.vtype != TYCHAR
  1160.         && q->addrblock.memoffset->tag == TCONST) {
  1161.  
  1162.             /* check for 0 offset -- after */
  1163.             /* correcting for equivalence. */
  1164.             L = q->addrblock.memoffset->constblock.Const.ci;
  1165.             if (ONEOF(q->addrblock.vstg, M(STGCOMMON)|M(STGEQUIV))
  1166.                     && q->addrblock.uname_tag == UNAM_NAME)
  1167.                 L -= q->addrblock.user.name->voffset;
  1168.             if (L)
  1169.                 goto skip_deref;
  1170.  
  1171.             if (Ac && narg < at->dnargs
  1172.              && q->headblock.vtype != (t = Ac[narg].type)
  1173.              && t > TYADDR && t < TYSUBR)
  1174.                 nice_printf(outfile, "(%s*)", typename[t]);
  1175.  
  1176.             /* &x[0] == x */
  1177.             /* This also prevents &sizeof(doublereal)[0] */
  1178.  
  1179.             switch(q->addrblock.uname_tag) {
  1180.                 case UNAM_NAME:
  1181.                 out_name(outfile, q->addrblock.user.name);
  1182.                 continue;
  1183.                 case UNAM_IDENT:
  1184.                 nice_printf(outfile, "%s",
  1185.                     q->addrblock.user.ident);
  1186.                 continue;
  1187.                 case UNAM_CHARP:
  1188.                 nice_printf(outfile, "%s",
  1189.                     q->addrblock.user.Charp);
  1190.                 continue;
  1191.                 case UNAM_EXTERN:
  1192.                 extern_out(outfile,
  1193.                     &extsymtab[q->addrblock.memno]);
  1194.                 continue;
  1195.                 }
  1196.             }
  1197.         }
  1198.  
  1199. /* Skip over the dereferencing operator generated only for the
  1200.    intermediate file */
  1201.  skip_deref:
  1202.     if (q -> tag == TEXPR && q -> exprblock.opcode == OPWHATSIN)
  1203.         q = q -> exprblock.leftp;
  1204.  
  1205.     if (q->headblock.vclass == CLPROC) {
  1206.         if (Castargs && (q->tag != TNAME
  1207.                 || q->nameblock.vprocclass != PTHISPROC)
  1208.              && (q->tag != TADDR
  1209.                 || q->addrblock.uname_tag != UNAM_NAME
  1210.                 || q->addrblock.user.name->vprocclass
  1211.                                 != PTHISPROC))
  1212.         {
  1213.         if (A && (t = A[narg].type) >= 200)
  1214.             t %= 100;
  1215.         else {
  1216.             t = q->headblock.vtype;
  1217.             if (q->tag == TNAME && q->nameblock.vimpltype)
  1218.                 t = TYUNKNOWN;
  1219.             }
  1220.         nice_printf(outfile, "(%s)", usedcasts[t] = casttypes[t]);
  1221.         }
  1222.         }
  1223.     else if (Ac && narg < at->dnargs
  1224.         && q->headblock.vtype != (t = Ac[narg].type)
  1225.         && t > TYADDR && t < TYSUBR)
  1226.         nice_printf(outfile, "(%s*)", typename[t]);
  1227.  
  1228.     if ((q -> tag == TADDR || q-> tag == TNAME) &&
  1229.         (byvalue || q -> headblock.vstg != STGREG)) {
  1230.         if (q -> headblock.vtype != TYCHAR)
  1231.           if (byvalue) {
  1232.  
  1233.         if (q -> tag == TADDR &&
  1234.             q -> addrblock.uname_tag == UNAM_NAME &&
  1235.             ! q -> addrblock.user.name -> vdim &&
  1236.             oneof_stg(q -> addrblock.user.name, q -> addrblock.vstg,
  1237.                     M(STGARG)|M(STGEQUIV)) &&
  1238.             ! ISCOMPLEX(q->addrblock.user.name->vtype))
  1239.             nice_printf (outfile, "*");
  1240.         else if (q -> tag == TNAME
  1241.             && oneof_stg(&q->nameblock, q -> nameblock.vstg,
  1242.                 M(STGARG)|M(STGEQUIV))
  1243.             && !(q -> nameblock.vdim))
  1244.             nice_printf (outfile, "*");
  1245.  
  1246.           } else {
  1247.         expptr memoffset;
  1248.  
  1249.         if (q->tag == TADDR &&
  1250.             !ONEOF (q -> addrblock.vstg, M(STGEXT)|M(STGLENG))
  1251.             && (
  1252.             ONEOF(q->addrblock.vstg,
  1253.                 M(STGCOMMON)|M(STGEQUIV)|M(STGMEMNO))
  1254.             || ((memoffset = q->addrblock.memoffset)
  1255.                 && (!ISICON(memoffset)
  1256.                 || memoffset->constblock.Const.ci)))
  1257.             || ONEOF(q->addrblock.vstg,
  1258.                     M(STGINIT)|M(STGAUTO)|M(STGBSS))
  1259.                 && !q->addrblock.isarray)
  1260.             nice_printf (outfile, "&");
  1261.         else if (q -> tag == TNAME
  1262.             && !oneof_stg(&q->nameblock, q -> nameblock.vstg,
  1263.                 M(STGARG)|M(STGEXT)|M(STGEQUIV)))
  1264.             nice_printf (outfile, "&");
  1265.         } /* else */
  1266.  
  1267.         expr_out (outfile, q);
  1268.     } /* if q -> tag == TADDR || q -> tag == TNAME */
  1269.  
  1270. /* Might be a Constant expression, e.g. string length, character constants */
  1271.  
  1272.     else if (q -> tag == TCONST) {
  1273.         if (tyioint == TYLONG)
  1274.            Longfmt = "%ldL";
  1275.         out_const(outfile, &q->constblock);
  1276.         Longfmt = "%ld";
  1277.         }
  1278.  
  1279. /* Must be some other kind of expression, or register var, or constant.
  1280.    In particular, this is likely to be a temporary variable assignment
  1281.    which was generated in p1put_call */
  1282.  
  1283.     else if (!ISCOMPLEX (q -> headblock.vtype) && !ISCHAR (q)){
  1284.         int use_paren = q -> tag == TEXPR &&
  1285.             op_precedence (q -> exprblock.opcode) <=
  1286.             op_precedence (OPCOMMA);
  1287.  
  1288.         if (use_paren) nice_printf (outfile, "(");
  1289.         expr_out (outfile, q);
  1290.         if (use_paren) nice_printf (outfile, ")");
  1291.     } /* if !ISCOMPLEX */
  1292.     else
  1293.         err ("out_call:  unknown parameter");
  1294.  
  1295.     } /* for (cp = arglist */
  1296.  
  1297.     if (arglist)
  1298.     frchain (&arglist);
  1299.  
  1300.     nice_printf (outfile, ")");
  1301.  
  1302. } /* out_call */
  1303.  
  1304.  
  1305.  char *
  1306. #ifdef KR_headers
  1307. flconst(buf, x)
  1308.     char *buf;
  1309.     char *x;
  1310. #else
  1311. flconst(char *buf, char *x)
  1312. #endif
  1313. {
  1314.     sprintf(buf, fl_fmt_string, x);
  1315.     return buf;
  1316.     }
  1317.  
  1318.  char *
  1319. #ifdef KR_headers
  1320. dtos(x)
  1321.     double x;
  1322. #else
  1323. dtos(double x)
  1324. #endif
  1325. {
  1326.     static char buf[64];
  1327. #ifdef USE_DTOA
  1328.     g_fmt(buf, x);
  1329. #else
  1330.     sprintf(buf, db_fmt_string, x);
  1331. #endif
  1332.     return buf;
  1333.     }
  1334.  
  1335. char tr_tab[Table_size];
  1336.  
  1337. /* out_init -- Initialize the data structures used by the routines in
  1338.    output.c.  These structures include the output format to be used for
  1339.    Float, Double, Complex, and Double Complex constants. */
  1340.  
  1341.  void
  1342. out_init(Void)
  1343. {
  1344.     extern int tab_size;
  1345.     register char *s;
  1346.  
  1347.     s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_+-.";
  1348.     while(*s)
  1349.     tr_tab[*s++] = 3;
  1350.     tr_tab['>'] = 1;
  1351.  
  1352.     opeqable[OPPLUS] = 1;
  1353.     opeqable[OPMINUS] = 1;
  1354.     opeqable[OPSTAR] = 1;
  1355.     opeqable[OPSLASH] = 1;
  1356.     opeqable[OPMOD] = 1;
  1357.     opeqable[OPLSHIFT] = 1;
  1358.     opeqable[OPBITAND] = 1;
  1359.     opeqable[OPBITXOR] = 1;
  1360.     opeqable[OPBITOR ] = 1;
  1361.  
  1362.  
  1363. /* Set the output format for both types of floating point constants */
  1364.  
  1365.     if (fl_fmt_string == NULL || *fl_fmt_string == '\0')
  1366.     fl_fmt_string = Ansi == 1 ? "%sf" : "(float)%s";
  1367.  
  1368.     if (db_fmt_string == NULL || *db_fmt_string == '\0')
  1369.     db_fmt_string = "%.17g";
  1370.  
  1371. /* Set the output format for both types of complex constants.  They will
  1372.    have string parameters rather than float or double so that the decimal
  1373.    point may be added to the strings generated by the {db,fl}_fmt_string
  1374.    formats above */
  1375.  
  1376.     if (cm_fmt_string == NULL || *cm_fmt_string == '\0') {
  1377.     cm_fmt_string = "{%s,%s}";
  1378.     } /* if cm_fmt_string == NULL */
  1379.  
  1380.     if (dcm_fmt_string == NULL || *dcm_fmt_string == '\0') {
  1381.     dcm_fmt_string = "{%s,%s}";
  1382.     } /* if dcm_fmt_string == NULL */
  1383.  
  1384.     tab_size = 4;
  1385. } /* out_init */
  1386.  
  1387.  
  1388.  void
  1389. #ifdef KR_headers
  1390. extern_out(fp, extsym)
  1391.     FILE *fp;
  1392.     Extsym *extsym;
  1393. #else
  1394. extern_out(FILE *fp, Extsym *extsym)
  1395. #endif
  1396. {
  1397.     if (extsym == (Extsym *) NULL)
  1398.     return;
  1399.  
  1400.     nice_printf (fp, "%s", extsym->cextname);
  1401.  
  1402. } /* extern_out */
  1403.  
  1404.  
  1405.  
  1406.  static void
  1407. #ifdef KR_headers
  1408. output_list(fp, listp)
  1409.     FILE *fp;
  1410.     struct Listblock *listp;
  1411. #else
  1412. output_list(FILE *fp, struct Listblock *listp)
  1413. #endif
  1414. {
  1415.     int did_one = 0;
  1416.     chainp elts;
  1417.  
  1418.     nice_printf (fp, "(");
  1419.     if (listp)
  1420.     for (elts = listp -> listp; elts; elts = elts -> nextp) {
  1421.         if (elts -> datap) {
  1422.         if (did_one)
  1423.             nice_printf (fp, ", ");
  1424.         expr_out (fp, (expptr) elts -> datap);
  1425.         did_one = 1;
  1426.         } /* if elts -> datap */
  1427.     } /* for elts */
  1428.     nice_printf (fp, ")");
  1429. } /* output_list */
  1430.  
  1431.  
  1432.  void
  1433. #ifdef KR_headers
  1434. out_asgoto(outfile, expr)
  1435.     FILE *outfile;
  1436.     expptr expr;
  1437. #else
  1438. out_asgoto(FILE *outfile, expptr expr)
  1439. #endif
  1440. {
  1441.     chainp value;
  1442.     Namep namep;
  1443.     int k;
  1444.  
  1445.     if (expr == (expptr) NULL) {
  1446.     err ("out_asgoto:  NULL variable expr");
  1447.     return;
  1448.     } /* if expr */
  1449.  
  1450.     nice_printf (outfile, Ansi ? "switch (" : "switch ((int)"); /*)*/
  1451.     expr_out (outfile, expr);
  1452.     nice_printf (outfile, ") {\n");
  1453.     next_tab (outfile);
  1454.  
  1455. /* The initial addrp value will be stored as a namep pointer */
  1456.  
  1457.     switch(expr->tag) {
  1458.     case TNAME:
  1459.         /* local variable */
  1460.         namep = &expr->nameblock;
  1461.         break;
  1462.     case TEXPR:
  1463.         if (expr->exprblock.opcode == OPWHATSIN
  1464.          && expr->exprblock.leftp->tag == TNAME)
  1465.             /* argument */
  1466.             namep = &expr->exprblock.leftp->nameblock;
  1467.         else
  1468.             goto bad;
  1469.         break;
  1470.     case TADDR:
  1471.         if (expr->addrblock.uname_tag == UNAM_NAME) {
  1472.             /* initialized local variable */
  1473.             namep = expr->addrblock.user.name;
  1474.             break;
  1475.             }
  1476.     default:
  1477.  bad:
  1478.         err("out_asgoto:  bad expr");
  1479.         return;
  1480.     }
  1481.  
  1482.     for(k = 0, value = namep -> varxptr.assigned_values; value;
  1483.         value = value->nextp, k++) {
  1484.     nice_printf (outfile, "case %d: goto %s;\n", k,
  1485.         user_label((long)value->datap));
  1486.     } /* for value */
  1487.     prev_tab (outfile);
  1488.  
  1489.     nice_printf (outfile, "}\n");
  1490. } /* out_asgoto */
  1491.  
  1492.  void
  1493. #ifdef KR_headers
  1494. out_if(outfile, expr)
  1495.     FILE *outfile;
  1496.     expptr expr;
  1497. #else
  1498. out_if(FILE *outfile, expptr expr)
  1499. #endif
  1500. {
  1501.     nice_printf (outfile, "if (");
  1502.     expr_out (outfile, expr);
  1503.     nice_printf (outfile, ") {\n");
  1504.     next_tab (outfile);
  1505. } /* out_if */
  1506.  
  1507.  static void
  1508. #ifdef KR_headers
  1509. output_rbrace(outfile, s)
  1510.     FILE *outfile;
  1511.     char *s;
  1512. #else
  1513. output_rbrace(FILE *outfile, char *s)
  1514. #endif
  1515. {
  1516.     extern int last_was_label;
  1517.     register char *fmt;
  1518.  
  1519.     if (last_was_label) {
  1520.         last_was_label = 0;
  1521.         fmt = ";%s";
  1522.         }
  1523.     else
  1524.         fmt = "%s";
  1525.     nice_printf(outfile, fmt, s);
  1526.     }
  1527.  
  1528.  void
  1529. #ifdef KR_headers
  1530. out_else(outfile)
  1531.     FILE *outfile;
  1532. #else
  1533. out_else(FILE *outfile)
  1534. #endif
  1535. {
  1536.     prev_tab (outfile);
  1537.     output_rbrace(outfile, "} else {\n");
  1538.     next_tab (outfile);
  1539. } /* out_else */
  1540.  
  1541.  void
  1542. #ifdef KR_headers
  1543. elif_out(outfile, expr)
  1544.     FILE *outfile;
  1545.     expptr expr;
  1546. #else
  1547. elif_out(FILE *outfile, expptr expr)
  1548. #endif
  1549. {
  1550.     prev_tab (outfile);
  1551.     output_rbrace(outfile, "} else ");
  1552.     out_if (outfile, expr);
  1553. } /* elif_out */
  1554.  
  1555.  void
  1556. #ifdef KR_headers
  1557. endif_out(outfile)
  1558.     FILE *outfile;
  1559. #else
  1560. endif_out(FILE *outfile)
  1561. #endif
  1562. {
  1563.     prev_tab (outfile);
  1564.     output_rbrace(outfile, "}\n");
  1565. } /* endif_out */
  1566.  
  1567.  void
  1568. #ifdef KR_headers
  1569. end_else_out(outfile)
  1570.     FILE *outfile;
  1571. #else
  1572. end_else_out(FILE *outfile)
  1573. #endif
  1574. {
  1575.     prev_tab (outfile);
  1576.     output_rbrace(outfile, "}\n");
  1577. } /* end_else_out */
  1578.  
  1579.  
  1580.  
  1581.  void
  1582. #ifdef KR_headers
  1583. compgoto_out(outfile, index, labels)
  1584.     FILE *outfile;
  1585.     expptr index;
  1586.     expptr labels;
  1587. #else
  1588. compgoto_out(FILE *outfile, expptr index, expptr labels)
  1589. #endif
  1590. {
  1591.     char *s1, *s2;
  1592.  
  1593.     if (index == ENULL)
  1594.     err ("compgoto_out:  null index for computed goto");
  1595.     else if (labels && labels -> tag != TLIST)
  1596.     erri ("compgoto_out:  expected label list, got tag '%d'",
  1597.         labels -> tag);
  1598.     else {
  1599.     chainp elts;
  1600.     int i = 1;
  1601.  
  1602.     s2 = /*(*/ ") {\n"; /*}*/
  1603.     if (Ansi)
  1604.         s1 = "switch ("; /*)*/
  1605.     else if (index->tag == TNAME || index->tag == TEXPR
  1606.                 && index->exprblock.opcode == OPWHATSIN)
  1607.         s1 = "switch ((int)"; /*)*/
  1608.     else {
  1609.         s1 = "switch ((int)(";
  1610.         s2 = ")) {\n"; /*}*/
  1611.         }
  1612.     nice_printf(outfile, s1);
  1613.     expr_out (outfile, index);
  1614.     nice_printf (outfile, s2);
  1615.     next_tab (outfile);
  1616.  
  1617.     for (elts = labels -> listblock.listp; elts; elts = elts -> nextp, i++) {
  1618.         if (elts -> datap) {
  1619.         if (ISICON(((expptr) (elts -> datap))))
  1620.             nice_printf (outfile, "case %d:  goto %s;\n", i,
  1621.             user_label(((expptr)(elts->datap))->constblock.Const.ci));
  1622.         else
  1623.             err ("compgoto_out:  bad label in label list");
  1624.         } /* if (elts -> datap) */
  1625.     } /* for elts */
  1626.     prev_tab (outfile);
  1627.     nice_printf (outfile, /*{*/ "}\n");
  1628.     } /* else */
  1629. } /* compgoto_out */
  1630.  
  1631.  
  1632.  void
  1633. #ifdef KR_headers
  1634. out_for(outfile, init, test, inc)
  1635.     FILE *outfile;
  1636.     expptr init;
  1637.     expptr test;
  1638.     expptr inc;
  1639. #else
  1640. out_for(FILE *outfile, expptr init, expptr test, expptr inc)
  1641. #endif
  1642. {
  1643.     nice_printf (outfile, "for (");
  1644.     expr_out (outfile, init);
  1645.     nice_printf (outfile, "; ");
  1646.     expr_out (outfile, test);
  1647.     nice_printf (outfile, "; ");
  1648.     expr_out (outfile, inc);
  1649.     nice_printf (outfile, ") {\n");
  1650.     next_tab (outfile);
  1651. } /* out_for */
  1652.  
  1653.  
  1654.  void
  1655. #ifdef KR_headers
  1656. out_end_for(outfile)
  1657.     FILE *outfile;
  1658. #else
  1659. out_end_for(FILE *outfile)
  1660. #endif
  1661. {
  1662.     prev_tab (outfile);
  1663.     nice_printf (outfile, "}\n");
  1664. } /* out_end_for */
  1665.