lang/fortran/comp/output.c

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