sources/f2c/output.c

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