path: root/contrib/tools/f2c/src/output.c

/****************************************************************
Copyright 1990-1996, 2000-2001 by AT&T, Lucent Technologies and Bellcore.

Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T, Bell Laboratories,
Lucent or Bellcore or any of their entities not be used in
advertising or publicity pertaining to distribution of the
software without specific, written prior permission.

AT&T, Lucent and Bellcore disclaim all warranties with regard to
this software, including all implied warranties of
merchantability and fitness.  In no event shall AT&T, Lucent or
Bellcore be liable for any special, indirect or consequential
damages or any damages whatsoever resulting from loss of use,
data or profits, whether in an action of contract, negligence or
other tortious action, arising out of or in connection with the
use or performance of this software.
****************************************************************/

#include "defs.h"
#include "names.h"
#include "output.h"

#ifndef TRUE
#define TRUE 1
#endif
#ifndef FALSE
#define FALSE 0
#endif

char _assoc_table[] = { 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0 };

/* Opcode table -- This array is indexed by the OP_____ macros defined in
   defines.h; these macros are expected to be adjacent integers, so that
   this table is as small as possible. */

table_entry opcode_table[] = {
				{ 0, 0, NULL },
	/* OPPLUS 1 */		{ BINARY_OP, 12, "%l + %r" },
	/* OPMINUS 2 */		{ BINARY_OP, 12, "%l - %r" },
	/* OPSTAR 3 */		{ BINARY_OP, 13, "%l * %r" },
	/* OPSLASH 4 */		{ BINARY_OP, 13, "%l / %r" },
	/* OPPOWER 5 */		{ BINARY_OP,  0, "power (%l, %r)" },
	/* OPNEG 6 */		{ UNARY_OP,  14, "-%l" },
	/* OPOR 7 */		{ BINARY_OP,  4, "%l || %r" },
	/* OPAND 8 */		{ BINARY_OP,  5, "%l && %r" },
	/* OPEQV 9 */		{ BINARY_OP,  9, "%l == %r" },
	/* OPNEQV 10 */		{ BINARY_OP,  9, "%l != %r" },
	/* OPNOT 11 */		{ UNARY_OP,  14, "! %l" },
	/* OPCONCAT 12 */	{ BINARY_OP,  0, "concat (%l, %r)" },
	/* OPLT 13 */		{ BINARY_OP, 10, "%l < %r" },
	/* OPEQ 14 */		{ BINARY_OP,  9, "%l == %r" },
	/* OPGT 15 */		{ BINARY_OP, 10, "%l > %r" },
	/* OPLE 16 */		{ BINARY_OP, 10, "%l <= %r" },
	/* OPNE 17 */		{ BINARY_OP,  9, "%l != %r" },
	/* OPGE 18 */		{ BINARY_OP, 10, "%l >= %r" },
	/* OPCALL 19 */		{ BINARY_OP, 15, SPECIAL_FMT },
	/* OPCCALL 20 */	{ BINARY_OP, 15, SPECIAL_FMT },

/* Left hand side of an assignment cannot have outermost parens */

	/* OPASSIGN 21 */	{ BINARY_OP,  2, "%l = %r" },
	/* OPPLUSEQ 22 */	{ BINARY_OP,  2, "%l += %r" },
	/* OPSTAREQ 23 */	{ BINARY_OP,  2, "%l *= %r" },
	/* OPCONV 24 */		{ BINARY_OP, 14, "%l" },
	/* OPLSHIFT 25 */	{ BINARY_OP, 11, "%l << %r" },
	/* OPMOD 26 */		{ BINARY_OP, 13, "%l %% %r" },
	/* OPCOMMA 27 */	{ BINARY_OP,  1, "%l, %r" },

/* Don't want to nest the colon operator in parens */

	/* OPQUEST 28 */	{ BINARY_OP, 3, "%l ? %r" },
	/* OPCOLON 29 */	{ BINARY_OP, 3, "%l : %r" },
	/* OPABS 30 */		{ UNARY_OP,  0, "abs(%l)" },
	/* OPMIN 31 */		{ BINARY_OP,   0, SPECIAL_FMT },
	/* OPMAX 32 */		{ BINARY_OP,   0, SPECIAL_FMT },
	/* OPADDR 33 */		{ UNARY_OP, 14, "&%l" },

	/* OPCOMMA_ARG 34 */	{ BINARY_OP, 15, SPECIAL_FMT },
	/* OPBITOR 35 */	{ BINARY_OP,  6, "%l | %r" },
	/* OPBITAND 36 */	{ BINARY_OP,  8, "%l & %r" },
	/* OPBITXOR 37 */	{ BINARY_OP,  7, "%l ^ %r" },
	/* OPBITNOT 38 */	{ UNARY_OP,  14, "~ %l" },
	/* OPRSHIFT 39 */	{ BINARY_OP, 11, "%l >> %r" },

/* This isn't quite right -- it doesn't handle arrays, for instance */

	/* OPWHATSIN 40 */	{ UNARY_OP,  14, "*%l" },
	/* OPMINUSEQ 41 */	{ BINARY_OP,  2, "%l -= %r" },
	/* OPSLASHEQ 42 */	{ BINARY_OP,  2, "%l /= %r" },
	/* OPMODEQ 43 */	{ BINARY_OP,  2, "%l %%= %r" },
	/* OPLSHIFTEQ 44 */	{ BINARY_OP,  2, "%l <<= %r" },
	/* OPRSHIFTEQ 45 */	{ BINARY_OP,  2, "%l >>= %r" },
	/* OPBITANDEQ 46 */	{ BINARY_OP,  2, "%l &= %r" },
	/* OPBITXOREQ 47 */	{ BINARY_OP,  2, "%l ^= %r" },
	/* OPBITOREQ 48 */	{ BINARY_OP,  2, "%l |= %r" },
	/* OPPREINC 49 */	{ UNARY_OP,  14, "++%l" },
	/* OPPREDEC 50 */	{ UNARY_OP,  14, "--%l" },
	/* OPDOT 51 */		{ BINARY_OP, 15, "%l.%r" },
	/* OPARROW 52 */	{ BINARY_OP, 15, "%l -> %r"},
	/* OPNEG1 53 */		{ UNARY_OP,  14, "-%l" },
	/* OPDMIN 54 */		{ BINARY_OP, 0, "dmin(%l,%r)" },
	/* OPDMAX 55 */		{ BINARY_OP, 0, "dmax(%l,%r)" },
	/* OPASSIGNI 56 */	{ BINARY_OP,  2, "%l = &%r" },
	/* OPIDENTITY 57 */	{ UNARY_OP, 15, "%l" },
	/* OPCHARCAST 58 */	{ UNARY_OP, 14, "(char *)&%l" },
	/* OPDABS 59 */		{ UNARY_OP, 0, "dabs(%l)" },
	/* OPMIN2 60 */		{ BINARY_OP,   0, "min(%l,%r)" },
	/* OPMAX2 61 */		{ BINARY_OP,   0, "max(%l,%r)" },
	/* OPBITTEST 62 */	{ BINARY_OP,   0, "bit_test(%l,%r)" },
	/* OPBITCLR 63 */	{ BINARY_OP,   0, "bit_clear(%l,%r)" },
	/* OPBITSET 64 */	{ BINARY_OP,   0, "bit_set(%l,%r)" },
#ifdef TYQUAD
	/* OPQBITCLR 65 */	{ BINARY_OP,   0, "qbit_clear(%l,%r)" },
	/* OPQBITSET 66 */	{ BINARY_OP,   0, "qbit_set(%l,%r)" },
#endif

/* kludge to imitate (under forcedouble) f77's bizarre treatement of OPNEG... */

	/* OPNEG KLUDGE */	{ UNARY_OP,  14, "-(doublereal)%l" }
}; /* opcode_table */

#define OPNEG_KLUDGE (sizeof(opcode_table)/sizeof(table_entry) - 1)

extern int dneg, trapuv;
static char opeqable[sizeof(opcode_table)/sizeof(table_entry)];


static void output_arg_list Argdcl((FILEP, struct Listblock*));
static void output_binary Argdcl((FILEP, Exprp));
static void output_list Argdcl((FILEP, struct Listblock*));
static void output_literal Argdcl((FILEP, long, Constp));
static void output_prim Argdcl((FILEP, struct Primblock*));
static void output_unary Argdcl((FILEP, Exprp));


 void
#ifdef KR_headers
expr_out(fp, e)
	FILE *fp;
	expptr e;
#else
expr_out(FILE *fp, expptr e)
#endif
{
	Namep var;
	expptr leftp, rightp;
	int opcode;

    if (e == (expptr) NULL)
	return;

    switch (e -> tag) {
	case TNAME:	out_name (fp, (struct Nameblock *) e);
			return;

	case TCONST:	out_const(fp, &e->constblock);
			goto end_out;
	case TEXPR:
	    		break;

	case TADDR:	out_addr (fp, &(e -> addrblock));
			goto end_out;

	case TPRIM:	if (!nerr)
				warn ("expr_out: got TPRIM");
			output_prim (fp, &(e -> primblock));
			return;

	case TLIST:	output_list (fp, &(e -> listblock));
 end_out:		frexpr(e);
			return;

	case TIMPLDO:	err ("expr_out: got TIMPLDO");
			return;

	case TERROR:
	default:
			erri ("expr_out: bad tag '%d'", e -> tag);
    } /* switch */

/* Now we know that the tag is TEXPR */

/* Optimize on simple expressions, such as "a = a + b" ==> "a += b" */

    if (e -> exprblock.opcode == OPASSIGN && e -> exprblock.rightp)
      switch(e->exprblock.rightp->tag) {
	case TEXPR:
	opcode = e -> exprblock.rightp -> exprblock.opcode;

	if (opeqable[opcode]) {
	    if ((leftp = e -> exprblock.leftp) &&
		(rightp = e -> exprblock.rightp -> exprblock.leftp)) {

		if (same_ident (leftp, rightp)) {
		    expptr temp = e -> exprblock.rightp;

		    e -> exprblock.opcode = op_assign(opcode);

		    e -> exprblock.rightp = temp -> exprblock.rightp;
		    temp->exprblock.rightp = 0;
		    frexpr(temp);
		} /* if same_ident (leftp, rightp) */
	    } /* if leftp && rightp */
	} /* if opcode == OPPLUS || */
	break;

	case TNAME:
	  if (trapuv) {
		var = &e->exprblock.rightp->nameblock;
		if (ISREAL(var->vtype)
		 && var->vclass == CLVAR
		 && ONEOF(var->vstg, M(STGAUTO)|M(STGBSS))
		 && !var->vsave) {
			expr_out(fp, e -> exprblock.leftp);
			nice_printf(fp, " = _0 + ");
			expr_out(fp, e->exprblock.rightp);
			goto done;
			}
		}
      } /* if e -> exprblock.opcode == OPASSIGN */


/* Optimize on increment or decrement by 1 */

    {
	opcode = e -> exprblock.opcode;
	leftp = e -> exprblock.leftp;
	rightp = e -> exprblock.rightp;

	if (leftp && rightp && (leftp -> headblock.vstg == STGARG ||
		ISINT (leftp -> headblock.vtype)) &&
		(opcode == OPPLUSEQ || opcode == OPMINUSEQ) &&
		ISINT (rightp -> headblock.vtype) &&
		ISICON (e -> exprblock.rightp) &&
		(ISONE (e -> exprblock.rightp) ||
		e -> exprblock.rightp -> constblock.Const.ci == -1)) {

/* Allow for the '-1' constant value */

	    if (!ISONE (e -> exprblock.rightp))
		opcode = (opcode == OPPLUSEQ) ? OPMINUSEQ : OPPLUSEQ;

/* replace the existing opcode */

	    if (opcode == OPPLUSEQ)
		e -> exprblock.opcode = OPPREINC;
	    else
		e -> exprblock.opcode = OPPREDEC;

/* Free up storage used by the right hand side */

	    frexpr (e -> exprblock.rightp);
	    e->exprblock.rightp = 0;
	} /* if opcode == OPPLUS */
    } /* block */


    if (is_unary_op (e -> exprblock.opcode))
	output_unary (fp, &(e -> exprblock));
    else if (is_binary_op (e -> exprblock.opcode))
	output_binary (fp, &(e -> exprblock));
    else
	erri ("expr_out: bad opcode '%d'", (int) e -> exprblock.opcode);

 done:
    free((char *)e);

} /* expr_out */


 void
#ifdef KR_headers
out_and_free_statement(outfile, expr)
	FILE *outfile;
	expptr expr;
#else
out_and_free_statement(FILE *outfile, expptr expr)
#endif
{
    if (expr)
	expr_out (outfile, expr);

    nice_printf (outfile, ";\n");
} /* out_and_free_statement */



 int
#ifdef KR_headers
same_ident(left, right)
	expptr left;
	expptr right;
#else
same_ident(expptr left, expptr right)
#endif
{
    if (!left || !right)
	return 0;

    if (left -> tag == TNAME && right -> tag == TNAME && left == right)
	return 1;

    if (left -> tag == TADDR && right -> tag == TADDR &&
	    left -> addrblock.uname_tag == right -> addrblock.uname_tag)
	switch (left -> addrblock.uname_tag) {
	    case UNAM_REF:
	    case UNAM_NAME:

/* Check for array subscripts */

		if (left -> addrblock.user.name -> vdim ||
			right -> addrblock.user.name -> vdim)
		    if (left -> addrblock.user.name !=
			    right -> addrblock.user.name ||
			    !same_expr (left -> addrblock.memoffset,
			    right -> addrblock.memoffset))
			return 0;

		return same_ident ((expptr) (left -> addrblock.user.name),
			(expptr) right -> addrblock.user.name);
	    case UNAM_IDENT:
		return strcmp(left->addrblock.user.ident,
				right->addrblock.user.ident) == 0;
	    case UNAM_CHARP:
		return strcmp(left->addrblock.user.Charp,
				right->addrblock.user.Charp) == 0;
	    default:
	        return 0;
	} /* switch */

    if (left->tag == TEXPR && left->exprblock.opcode == OPWHATSIN
	&& right->tag == TEXPR && right->exprblock.opcode == OPWHATSIN)
		return same_ident(left->exprblock.leftp,
				 right->exprblock.leftp);

    return 0;
} /* same_ident */

 static int
#ifdef KR_headers
samefpconst(c1, c2, n)
	register Constp c1;
	register Constp c2;
	register int n;
#else
samefpconst(register Constp c1, register Constp c2, register int n)
#endif
{
	char *s1, *s2;
	if (!c1->vstg && !c2->vstg)
		return c1->Const.cd[n] == c2->Const.cd[n];
	s1 = c1->vstg ? c1->Const.cds[n] : dtos(c1->Const.cd[n]);
	s2 = c2->vstg ? c2->Const.cds[n] : dtos(c2->Const.cd[n]);
	return !strcmp(s1, s2);
	}

 static int
#ifdef KR_headers
sameconst(c1, c2)
	register Constp c1;
	register Constp c2;
#else
sameconst(register Constp c1, register Constp c2)
#endif
{
	switch(c1->vtype) {
		case TYCOMPLEX:
		case TYDCOMPLEX:
			if (!samefpconst(c1,c2,1))
				return 0;
		case TYREAL:
		case TYDREAL:
			return samefpconst(c1,c2,0);
		case TYCHAR:
			return c1->Const.ccp1.blanks == c2->Const.ccp1.blanks
			    &&	   c1->vleng->constblock.Const.ci
				== c2->vleng->constblock.Const.ci
			    && !memcmp(c1->Const.ccp, c2->Const.ccp,
					(int)c1->vleng->constblock.Const.ci);
		case TYSHORT:
		case TYINT:
		case TYLOGICAL:
			return c1->Const.ci == c2->Const.ci;
		}
	err("unexpected type in sameconst");
	return 0;
	}

/* same_expr -- Returns true only if   e1 and e2   match.  This is
   somewhat pessimistic, but can afford to be because it's just used to
   optimize on the assignment operators (+=, -=, etc). */

 int
#ifdef KR_headers
same_expr(e1, e2)
	expptr e1;
	expptr e2;
#else
same_expr(expptr e1, expptr e2)
#endif
{
    if (!e1 || !e2)
	return !e1 && !e2;

    if (e1 -> tag != e2 -> tag || e1 -> headblock.vtype != e2 -> headblock.vtype)
	return 0;

    switch (e1 -> tag) {
        case TEXPR:
	    if (e1 -> exprblock.opcode != e2 -> exprblock.opcode)
		return 0;

	    return same_expr (e1 -> exprblock.leftp, e2 -> exprblock.leftp) &&
		   same_expr (e1 -> exprblock.rightp, e2 -> exprblock.rightp);
	case TNAME:
	case TADDR:
	    return same_ident (e1, e2);
	case TCONST:
	    return sameconst(&e1->constblock, &e2->constblock);
	default:
	    return 0;
    } /* switch */
} /* same_expr */



 void
#ifdef KR_headers
out_name(fp, namep)
	FILE *fp;
	Namep namep;
#else
out_name(FILE *fp, Namep namep)
#endif
{
    extern int usedefsforcommon;
    Extsym *comm;

    if (namep == NULL)
	return;

/* DON'T want to use oneof_stg() here; need to find the right common name
   */

    if (namep->vstg == STGCOMMON && !namep->vcommequiv && !usedefsforcommon) {
	comm = &extsymtab[namep->vardesc.varno];
	extern_out(fp, comm);
	nice_printf(fp, "%d.", comm->curno);
    } /* if namep -> vstg == STGCOMMON */

    if (namep->vprocclass == PTHISPROC && namep->vtype != TYSUBR)
	nice_printf(fp, xretslot[namep->vtype]->user.ident);
    else
	nice_printf (fp, "%s", namep->cvarname);
} /* out_name */


#define cpd(n) cp->vstg ? cp->Const.cds[n] : dtos(cp->Const.cd[n])

 void
#ifdef KR_headers
out_const(fp, cp)
	FILE *fp;
	register Constp cp;
#else
out_const(FILE *fp, register Constp cp)
#endif
{
    static char real_buf[50], imag_buf[50];
    ftnint j;
    unsigned int k;
    int type = cp->vtype;

    switch (type) {
	case TYINT1:
        case TYSHORT:
	    nice_printf (fp, "%ld", cp->Const.ci);	/* don't cast ci! */
	    break;
	case TYLONG:
#ifdef TYQUAD0
	case TYQUAD:
#endif
	    nice_printf (fp, "%ld", cp->Const.ci);	/* don't cast ci! */
	    break;
#ifndef NO_LONG_LONG
	case TYQUAD:
		if (cp->Const.cd[1] == 123.456)
			nice_printf (fp, "%s", cp->Const.cds[0]);
		else
			nice_printf (fp, "%lld", cp->Const.cq);
		break;
#endif
	case TYREAL:
	    nice_printf(fp, "%s", flconst(real_buf, cpd(0)));
	    break;
	case TYDREAL:
	    nice_printf(fp, "%s", cpd(0));
	    break;
	case TYCOMPLEX:
	    nice_printf(fp, cm_fmt_string, flconst(real_buf, cpd(0)),
			flconst(imag_buf, cpd(1)));
	    break;
	case TYDCOMPLEX:
	    nice_printf(fp, dcm_fmt_string, cpd(0), cpd(1));
	    break;
	case TYLOGICAL1:
	case TYLOGICAL2:
	case TYLOGICAL:
	    nice_printf (fp, "%s", cp->Const.ci ? "TRUE_" : "FALSE_");
	    break;
	case TYCHAR: {
	    char *c = cp->Const.ccp, *ce;

	    if (c == NULL) {
		nice_printf (fp, "\"\"");
		break;
	    } /* if c == NULL */

	    nice_printf (fp, "\"");
	    ce = c + cp->vleng->constblock.Const.ci;
	    while(c < ce) {
		k = *(unsigned char *)c++;
		nice_printf(fp, str_fmt[k]);
		}
	    for(j = cp->Const.ccp1.blanks; j > 0; j--)
		nice_printf(fp, " ");
	    nice_printf (fp, "\"");
	    break;
	} /* case TYCHAR */
	default:
	    erri ("out_const:  bad type '%d'", (int) type);
	    break;
    } /* switch */

} /* out_const */
#undef cpd

 static void
#ifdef KR_headers
out_args(fp, ep)
	FILE *fp;
	expptr ep;
#else
out_args(FILE *fp, expptr ep)
#endif
{
	chainp arglist;

	if(ep->tag != TLIST)
		badtag("out_args", ep->tag);
	for(arglist = ep->listblock.listp;;) {
		expr_out(fp, (expptr)arglist->datap);
		arglist->datap = 0;
		if (!(arglist = arglist->nextp))
			break;
		nice_printf(fp, ", ");
		}
	}


/* out_addr -- this routine isn't local because it is called by the
   system-generated identifier printing routines */

 void
#ifdef KR_headers
out_addr(fp, addrp)
	FILE *fp;
	struct Addrblock *addrp;
#else
out_addr(FILE *fp, struct Addrblock *addrp)
#endif
{
	extern Extsym *extsymtab;
	int was_array = 0;
	char *s;


	if (addrp == NULL)
		return;
	if (doin_setbound
			&& addrp->vstg == STGARG
			&& addrp->vtype != TYCHAR
			&& ISICON(addrp->memoffset)
			&& !addrp->memoffset->constblock.Const.ci)
		nice_printf(fp, "*");

	switch (addrp -> uname_tag) {
	    case UNAM_REF:
		nice_printf(fp, "%s_%s(", addrp->user.name->cvarname,
			addrp->cmplx_sub ? "subscr" : "ref");
		out_args(fp, addrp->memoffset);
		nice_printf(fp, ")");
		return;
	    case UNAM_NAME:
		out_name (fp, addrp -> user.name);
		break;
	    case UNAM_IDENT:
		if (*(s = addrp->user.ident) == ' ') {
			if (multitype)
				nice_printf(fp, "%s",
					xretslot[addrp->vtype]->user.ident);
			else
				nice_printf(fp, "%s", s+1);
			}
		else {
			nice_printf(fp, "%s", s);
			}
		break;
	    case UNAM_CHARP:
		nice_printf(fp, "%s", addrp->user.Charp);
		break;
	    case UNAM_EXTERN:
		extern_out (fp, &extsymtab[addrp -> memno]);
		break;
	    case UNAM_CONST:
		switch(addrp->vstg) {
			case STGCONST:
				out_const(fp, (Constp)addrp);
				break;
			case STGMEMNO:
				output_literal (fp, addrp->memno,
					(Constp)addrp);
				break;
			default:
			Fatal("unexpected vstg in out_addr");
			}
		break;
	    case UNAM_UNKNOWN:
	    default:
		nice_printf (fp, "Unknown Addrp");
		break;
	} /* switch */

/* It's okay to just throw in the brackets here because they have a
   precedence level of 15, the highest value.  */

    if ((addrp->uname_tag == UNAM_NAME && addrp->user.name->vdim
			|| addrp->ntempelt > 1 || addrp->isarray)
	&& addrp->vtype != TYCHAR) {
	expptr offset;

	was_array = 1;

	offset = addrp -> memoffset;
	addrp->memoffset = 0;
	if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV))
		&& addrp -> uname_tag == UNAM_NAME
		&& !addrp->skip_offset)
	    offset = mkexpr (OPMINUS, offset, mkintcon (
		    addrp -> user.name -> voffset));

	nice_printf (fp, "[");

	offset = mkexpr (OPSLASH, offset,
		ICON (typesize[addrp -> vtype] * (addrp -> Field ? 2 : 1)));
	expr_out (fp, offset);
	nice_printf (fp, "]");
	}

/* Check for structure field reference */

    if (addrp -> Field && addrp -> uname_tag != UNAM_CONST &&
	    addrp -> uname_tag != UNAM_UNKNOWN) {
	if (oneof_stg((addrp -> uname_tag == UNAM_NAME ? addrp -> user.name :
		(Namep) NULL), addrp -> vstg, M(STGARG)|M(STGEQUIV))
		&& !was_array && (addrp->vclass != CLPROC || !multitype))
	    nice_printf (fp, "->%s", addrp -> Field);
	else
	    nice_printf (fp, ".%s", addrp -> Field);
    } /* if */

/* Check for character subscripting */

    if (addrp->vtype == TYCHAR &&
	    (addrp->vclass != CLPROC || addrp->uname_tag == UNAM_NAME
			&& addrp->user.name->vprocclass == PTHISPROC) &&
	    addrp -> memoffset &&
	    (addrp -> uname_tag != UNAM_NAME ||
	     addrp -> user.name -> vtype == TYCHAR) &&
	    (!ISICON (addrp -> memoffset) ||
	     (addrp -> memoffset -> constblock.Const.ci))) {

	int use_paren = 0;
	expptr e = addrp -> memoffset;

	if (!e)
		return;
	addrp->memoffset = 0;

	if (ONEOF(addrp->vstg, M(STGCOMMON)|M(STGEQUIV))
	 && addrp -> uname_tag == UNAM_NAME) {
	    e = mkexpr (OPMINUS, e, mkintcon (addrp -> user.name -> voffset));

/* mkexpr will simplify it to zero if possible */
	    if (e->tag == TCONST && e->constblock.Const.ci == 0)
		return;
	} /* if addrp -> vstg == STGCOMMON */

/* In the worst case, parentheses might be needed OUTSIDE the expression,
   too.  But since I think this subscripting can only appear as a
   parameter in a procedure call, I don't think outside parens will ever
   be needed.  INSIDE parens are handled below */

	nice_printf (fp, " + ");
	if (e -> tag == TEXPR) {
	    int arg_prec = op_precedence (e -> exprblock.opcode);
	    int prec = op_precedence (OPPLUS);
	    use_paren = arg_prec && (arg_prec < prec || (arg_prec == prec &&
		    is_left_assoc (OPPLUS)));
	} /* if e -> tag == TEXPR */
	if (use_paren) nice_printf (fp, "(");
	expr_out (fp, e);
	if (use_paren) nice_printf (fp, ")");
    } /* if */
} /* out_addr */


 static void
#ifdef KR_headers
output_literal(fp, memno, cp)
	FILE *fp;
	long memno;
	Constp cp;
#else
output_literal(FILE *fp, long memno, Constp cp)
#endif
{
    struct Literal *litp, *lastlit;

    lastlit = litpool + nliterals;

    for (litp = litpool; litp < lastlit; litp++) {
	if (litp -> litnum == memno)
	    break;
    } /* for litp */

    if (litp >= lastlit)
	out_const (fp, cp);
    else {
	nice_printf (fp, "%s", lit_name (litp));
	litp->lituse++;
	}
} /* output_literal */


 static void
#ifdef KR_headers
output_prim(fp, primp)
	FILE *fp;
	struct Primblock *primp;
#else
output_prim(FILE *fp, struct Primblock *primp)
#endif
{
    if (primp == NULL)
	return;

    out_name (fp, primp -> namep);
    if (primp -> argsp)
	output_arg_list (fp, primp -> argsp);

    if (primp -> fcharp != (expptr) NULL || primp -> lcharp != (expptr) NULL)
	nice_printf (fp, "Sorry, no substrings yet");
}



 static void
#ifdef KR_headers
output_arg_list(fp, listp)
	FILE *fp;
	struct Listblock *listp;
#else
output_arg_list(FILE *fp, struct Listblock *listp)
#endif
{
    chainp arg_list;

    if (listp == (struct Listblock *) NULL || listp -> listp == (chainp) NULL)
	return;

    nice_printf (fp, "(");

    for (arg_list = listp -> listp; arg_list; arg_list = arg_list -> nextp) {
	expr_out (fp, (expptr) arg_list -> datap);
	if (arg_list -> nextp != (chainp) NULL)

/* Might want to add a hook in here to accomodate the style setting which
   wants spaces after commas */

	    nice_printf (fp, ",");
    } /* for arg_list */

    nice_printf (fp, ")");
} /* output_arg_list */



 static void
#ifdef KR_headers
output_unary(fp, e)
	FILE *fp;
	struct Exprblock *e;
#else
output_unary(FILE *fp, struct Exprblock *e)
#endif
{
    if (e == NULL)
	return;

    switch (e -> opcode) {
        case OPNEG:
		if (e->vtype == TYREAL && dneg) {
			e->opcode = OPNEG_KLUDGE;
			output_binary(fp,e);
			e->opcode = OPNEG;
			break;
			}
	case OPNEG1:
	case OPNOT:
	case OPABS:
	case OPBITNOT:
	case OPWHATSIN:
	case OPPREINC:
	case OPPREDEC:
	case OPADDR:
	case OPIDENTITY:
	case OPCHARCAST:
	case OPDABS:
	    output_binary (fp, e);
	    break;
	case OPCALL:
	case OPCCALL:
	    nice_printf (fp, "Sorry, no OPCALL yet");
	    break;
	default:
	    erri ("output_unary: bad opcode", (int) e -> opcode);
	    break;
    } /* switch */
} /* output_unary */


 static char *
#ifdef KR_headers
findconst(m)
	register long m;
#else
findconst(register long m)
#endif
{
	register struct Literal *litp, *litpe;

	litp = litpool;
	for(litpe = litp + nliterals; litp < litpe; litp++)
		if (litp->litnum ==  m)
			return litp->cds[0];
	Fatal("findconst failure!");
	return 0;
	}

 static int
#ifdef KR_headers
opconv_fudge(fp, e)
	FILE *fp;
	struct Exprblock *e;
#else
opconv_fudge(FILE *fp, struct Exprblock *e)
#endif
{
	/* special handling for conversions, ichar and character*1 */
	register expptr lp;
	register union Expression *Offset;
	register char *cp;
	int lt;
	char buf[8], *s;
	unsigned int k;
	Namep np;
	Addrp ap;

	if (!(lp = e->leftp))	/* possible with erroneous Fortran */
		return 1;
	lt = lp->headblock.vtype;
	if (lt == TYCHAR) {
		switch(lp->tag) {
			case TNAME:
				nice_printf(fp, "*(unsigned char *)");
				out_name(fp, (Namep)lp);
				return 1;
			case TCONST:
 tconst:
				cp = lp->constblock.Const.ccp;
 tconst1:
				k = *(unsigned char *)cp;
				if (k < 128) { /* ASCII character */
					sprintf(buf, chr_fmt[k], k);
					nice_printf(fp, "'%s'", buf);
					}
				else
					nice_printf(fp, "%d", k);
				return 1;
			case TADDR:
				switch(lp->addrblock.vstg) {
				    case STGMEMNO:
					if (halign && e->vtype != TYCHAR) {
						nice_printf(fp, "*(%s *)",
						    c_type_decl(e->vtype,0));
						expr_out(fp, lp);
						return 1;
						}
					cp = findconst(lp->addrblock.memno);
					goto tconst1;
				    case STGCONST:
					goto tconst;
				    }
				lp->addrblock.vtype = tyint;
				Offset = lp->addrblock.memoffset;
				switch(lp->addrblock.uname_tag) {
				  case UNAM_REF:
					nice_printf(fp, "*(unsigned char *)");
					return 0;
				  case UNAM_NAME:
					np = lp->addrblock.user.name;
					if (ONEOF(np->vstg,
					    M(STGCOMMON)|M(STGEQUIV)))
						Offset = mkexpr(OPMINUS, Offset,
							ICON(np->voffset));
					}
				lp->addrblock.memoffset = Offset ?
					mkexpr(OPSTAR, Offset,
						ICON(typesize[tyint]))
					: ICON(0);
				lp->addrblock.isarray = 1;
				/* STGCOMMON or STGEQUIV would cause */
				/* voffset to be added in a second time */
				lp->addrblock.vstg = STGUNKNOWN;
				nice_printf(fp, "*(unsigned char *)&");
				return 0;
			default:
				badtag("opconv_fudge", lp->tag);
			}
		}
	if (lt != e->vtype) {
		s = c_type_decl(e->vtype, 0);
		if (ISCOMPLEX(lt)) {
 tryagain:
			np = (Namep)e->leftp;
			switch(np->tag) {
			  case TNAME:
				nice_printf(fp, "(%s) %s%sr", s,
					np->cvarname,
					np->vstg == STGARG ? "->" : ".");
				return 1;
			  case TADDR:
				ap = (Addrp)np;
				switch(ap->uname_tag) {
				  case UNAM_IDENT:
					nice_printf(fp, "(%s) %s.r", s,
						ap->user.ident);
					return 1;
				  case UNAM_NAME:
					nice_printf(fp, "(%s) ", s);
					out_addr(fp, ap);
					nice_printf(fp, ".r");
					return 1;
				  case UNAM_REF:
					nice_printf(fp, "(%s) %s_%s(",
					 s, ap->user.name->cvarname,
					 ap->cmplx_sub ? "subscr" : "ref");
					out_args(fp, ap->memoffset);
					nice_printf(fp, ").r");
					return 1;
				  default:
					fatali(
					 "Bad uname_tag %d in opconv_fudge",
						ap->uname_tag);
				  }
			  case TEXPR:
				e = (Exprp)np;
				if (e->opcode == OPWHATSIN)
					goto tryagain;
			  default:
				fatali("Unexpected tag %d in opconv_fudge",
					np->tag);
			  }
			}
		nice_printf(fp, "(%s) ", s);
		}
	return 0;
	}


 static void
#ifdef KR_headers
output_binary(fp, e)
	FILE *fp;
	struct Exprblock *e;
#else
output_binary(FILE *fp, struct Exprblock *e)
#endif
{
    char *format;
    int prec;

    if (e == NULL || e -> tag != TEXPR)
	return;

/* Instead of writing a huge switch, I've incorporated the output format
   into a table.  Things like "%l" and "%r" stand for the left and
   right subexpressions.  This should allow both prefix and infix
   functions to be specified (e.g. "(%l * %r", "z_div (%l, %r").  Of
   course, I should REALLY think out the ramifications of writing out
   straight text, as opposed to some intermediate format, which could
   figure out and optimize on the the number of required blanks (we don't
   want "x - (-y)" to become "x --y", for example).  Special cases (such as
   incomplete implementations) could still be implemented as part of the
   switch, they will just have some dummy value instead of the string
   pattern.  Another difficulty is the fact that the complex functions
   will differ from the integer and real ones */

/* Handle a special case.  We don't want to output "x + - 4", or "y - - 3"
*/
    if ((e -> opcode == OPPLUS || e -> opcode == OPMINUS) &&
	    e -> rightp && e -> rightp -> tag == TCONST &&
	    isnegative_const (&(e -> rightp -> constblock)) &&
	    is_negatable (&(e -> rightp -> constblock))) {

	e -> opcode = (e -> opcode == OPPLUS) ? OPMINUS : OPPLUS;
	negate_const (&(e -> rightp -> constblock));
    } /* if e -> opcode == PLUS or MINUS */

    prec = op_precedence (e -> opcode);
    format = op_format (e -> opcode);

    if (format != SPECIAL_FMT) {
	while (*format) {
	    if (*format == '%') {
		int arg_prec, use_paren = 0;
		expptr lp, rp;

		switch (*(format + 1)) {
		    case 'l':
			lp = e->leftp;
			if (lp && lp->tag == TEXPR) {
			    arg_prec = op_precedence(lp->exprblock.opcode);

			    use_paren = arg_prec &&
			        (arg_prec < prec || (arg_prec == prec &&
				    is_right_assoc (prec)));
			} /* if e -> leftp */
			if (e->opcode == OPCONV && opconv_fudge(fp,e))
				break;
			if (use_paren)
			    nice_printf (fp, "(");
		        expr_out(fp, lp);
			if (use_paren)
			    nice_printf (fp, ")");
		        break;
		    case 'r':
			rp = e->rightp;
			if (rp && rp->tag == TEXPR) {
			    arg_prec = op_precedence(rp->exprblock.opcode);

			    use_paren = arg_prec &&
			        (arg_prec < prec || (arg_prec == prec &&
				    is_left_assoc (prec)));
			    use_paren = use_paren ||
				(rp->exprblock.opcode == OPNEG
				&& prec >= op_precedence(OPMINUS));
			} /* if e -> rightp */
			if (use_paren)
			    nice_printf (fp, "(");
		        expr_out(fp, rp);
			if (use_paren)
			    nice_printf (fp, ")");
		        break;
		    case '\0':
		    case '%':
		        nice_printf (fp, "%%");
		        break;
		    default:
		        erri ("output_binary: format err: '%%%c' illegal",
				(int) *(format + 1));
		        break;
		} /* switch */
		format += 2;
	    } else
		nice_printf (fp, "%c", *format++);
	} /* while *format */
    } else {

/* Handle Special cases of formatting */

	switch (e -> opcode) {
		case OPCCALL:
		case OPCALL:
			out_call (fp, (int) e -> opcode, e -> vtype,
					e -> vleng, e -> leftp, e -> rightp);
			break;

		case OPCOMMA_ARG:
			doin_setbound = 1;
			nice_printf(fp, "(");
			expr_out(fp, e->leftp);
			nice_printf(fp, ", &");
			doin_setbound = 0;
			expr_out(fp, e->rightp);
			nice_printf(fp, ")");
			break;

		case OPADDR:
		default:
	        	nice_printf (fp, "Sorry, can't format OPCODE '%d'",
				e -> opcode);
	        	break;
		}

    } /* else */
} /* output_binary */

 void
#ifdef KR_headers
out_call(outfile, op, ftype, len, name, args)
	FILE *outfile;
	int op;
	int ftype;
	expptr len;
	expptr name;
	expptr args;
#else
out_call(FILE *outfile, int op, int ftype, expptr len, expptr name, expptr args)
#endif
{
    chainp arglist;		/* Pointer to any actual arguments */
    chainp cp;			/* Iterator over argument lists */
    Addrp ret_val = (Addrp) NULL;
				/* Function return value buffer, if any is
				   required */
    int byvalue;		/* True iff we're calling a C library
				   routine */
    int done_once;		/* Used for writing commas to   outfile   */
    int narg, t;
    register expptr q;
    long L;
    Argtypes *at;
    Atype *A, *Ac;
    Namep np;
    extern int forcereal;

/* Don't use addresses if we're calling a C function */

    byvalue = op == OPCCALL;

    if (args)
	arglist = args -> listblock.listp;
    else
	arglist = CHNULL;

/* If this is a CHARACTER function, the first argument is the result */

    if (ftype == TYCHAR)
	if (ISICON (len)) {
	    ret_val = (Addrp) (arglist -> datap);
	    arglist = arglist -> nextp;
	} else {
	    err ("adjustable character function");
	    return;
	} /* else */

/* If this is a COMPLEX function, the first argument is the result */

    else if (ISCOMPLEX (ftype)) {
	ret_val = (Addrp) (arglist -> datap);
	arglist = arglist -> nextp;
    } /* if ISCOMPLEX */

    /* prepare to cast procedure parameters -- set A if we know how */
    np = name->tag == TEXPR && name->exprblock.opcode == OPWHATSIN
	? (Namep)name->exprblock.leftp : (Namep)name;

    A = Ac = 0;
    if (np->tag == TNAME && (at = np->arginfo)) {
	if (at->nargs > 0)
		A = at->atypes;
	if (Ansi && (at->defined || at->nargs > 0))
		Ac = at->atypes;
    	}

/* Now we can actually start to write out the function invocation */

    if (ftype == TYREAL && forcereal)
	nice_printf(outfile, "(real)");
    if (name -> tag == TEXPR && name -> exprblock.opcode == OPWHATSIN) {
	nice_printf (outfile, "(");
	expr_out (outfile, name);
	nice_printf (outfile, ")");
	}
    else
	expr_out(outfile, name);

    nice_printf(outfile, "(");

    if (ret_val) {
	if (ISCOMPLEX (ftype))
	    nice_printf (outfile, "&");
	expr_out (outfile, (expptr) ret_val);
	if (Ac)
		Ac++;

/* The length of the result of a character function is the second argument */
/* It should be in place from putcall(), so we won't touch it explicitly */

    } /* if ret_val */
    done_once = ret_val ? TRUE : FALSE;

/* Now run through the named arguments */

    narg = -1;
    for (cp = arglist; cp; cp = cp -> nextp, done_once = TRUE) {

	if (done_once)
	    nice_printf (outfile, ", ");
	narg++;

	if (!( q = (expptr)cp->datap) )
		continue;

	if (q->tag == TADDR) {
		if (q->addrblock.vtype > TYERROR) {
			/* I/O block */
			nice_printf(outfile, "&%s", q->addrblock.user.ident);
			continue;
			}
		if (!byvalue && q->addrblock.isarray
		&& q->addrblock.vtype != TYCHAR
		&& q->addrblock.memoffset->tag == TCONST) {

			/* check for 0 offset -- after */
			/* correcting for equivalence. */
			L = q->addrblock.memoffset->constblock.Const.ci;
			if (ONEOF(q->addrblock.vstg, M(STGCOMMON)|M(STGEQUIV))
					&& q->addrblock.uname_tag == UNAM_NAME)
				L -= q->addrblock.user.name->voffset;
			if (L)
				goto skip_deref;

			if (Ac && narg < at->dnargs
			 && q->headblock.vtype != (t = Ac[narg].type)
			 && t > TYADDR && t < TYSUBR)
				nice_printf(outfile, "(%s*)", Typename[t]);

			/* &x[0] == x */
			/* This also prevents &sizeof(doublereal)[0] */

			switch(q->addrblock.uname_tag) {
			    case UNAM_NAME:
				out_name(outfile, q->addrblock.user.name);
				continue;
			    case UNAM_IDENT:
				nice_printf(outfile, "%s",
					q->addrblock.user.ident);
				continue;
			    case UNAM_CHARP:
				nice_printf(outfile, "%s",
					q->addrblock.user.Charp);
				continue;
			    case UNAM_EXTERN:
				extern_out(outfile,
					&extsymtab[q->addrblock.memno]);
				continue;
			    }
			}
		}

/* Skip over the dereferencing operator generated only for the
   intermediate file */
 skip_deref:
	if (q -> tag == TEXPR && q -> exprblock.opcode == OPWHATSIN)
	    q = q -> exprblock.leftp;

	if (q->headblock.vclass == CLPROC) {
	    if (Castargs && (q->tag != TNAME
				|| q->nameblock.vprocclass != PTHISPROC)
			 && (q->tag != TADDR
				|| q->addrblock.uname_tag != UNAM_NAME
				|| q->addrblock.user.name->vprocclass
								!= PTHISPROC))
		{
		if (A && (t = A[narg].type) >= 200)
			t %= 100;
		else {
			t = q->headblock.vtype;
			if (q->tag == TNAME && q->nameblock.vimpltype)
				t = TYUNKNOWN;
			}
		nice_printf(outfile, "(%s)", usedcasts[t] = casttypes[t]);
		}
	    }
	else if (Ac && narg < at->dnargs
		&& q->headblock.vtype != (t = Ac[narg].type)
		&& t > TYADDR && t < TYSUBR)
		nice_printf(outfile, "(%s*)", Typename[t]);

	if ((q -> tag == TADDR || q-> tag == TNAME) &&
		(byvalue || q -> headblock.vstg != STGREG)) {
	    if (q -> headblock.vtype != TYCHAR)
	      if (byvalue) {

		if (q -> tag == TADDR &&
			q -> addrblock.uname_tag == UNAM_NAME &&
			! q -> addrblock.user.name -> vdim &&
			oneof_stg(q -> addrblock.user.name, q -> addrblock.vstg,
					M(STGARG)|M(STGEQUIV)) &&
			! ISCOMPLEX(q->addrblock.user.name->vtype))
		    nice_printf (outfile, "*");
		else if (q -> tag == TNAME
			&& oneof_stg(&q->nameblock, q -> nameblock.vstg,
				M(STGARG)|M(STGEQUIV))
			&& !(q -> nameblock.vdim))
		    nice_printf (outfile, "*");

	      } else {
		expptr memoffset;

		if (q->tag == TADDR && (
			!ONEOF (q -> addrblock.vstg, M(STGEXT)|M(STGLENG))
			&& (ONEOF(q->addrblock.vstg,
				M(STGCOMMON)|M(STGEQUIV)|M(STGMEMNO))
			    || ((memoffset = q->addrblock.memoffset)
				&& (!ISICON(memoffset)
				|| memoffset->constblock.Const.ci)))
			|| ONEOF(q->addrblock.vstg,
					M(STGINIT)|M(STGAUTO)|M(STGBSS))
				&& !q->addrblock.isarray))
		    nice_printf (outfile, "&");
		else if (q -> tag == TNAME
			&& !oneof_stg(&q->nameblock, q -> nameblock.vstg,
				M(STGARG)|M(STGEXT)|M(STGEQUIV)))
		    nice_printf (outfile, "&");
	    } /* else */

	    expr_out (outfile, q);
	} /* if q -> tag == TADDR || q -> tag == TNAME */

/* Might be a Constant expression, e.g. string length, character constants */

	else if (q -> tag == TCONST) {
		if (q->constblock.vtype == TYLONG)
			nice_printf(outfile, "(ftnlen)%ld",
				q->constblock.Const.ci);
		else
			out_const(outfile, &q->constblock);
	    }

/* Must be some other kind of expression, or register var, or constant.
   In particular, this is likely to be a temporary variable assignment
   which was generated in p1put_call */

	else if (!ISCOMPLEX (q -> headblock.vtype) && !ISCHAR (q)){
	    int use_paren = q -> tag == TEXPR &&
		    op_precedence (q -> exprblock.opcode) <=
		    op_precedence (OPCOMMA);
	    if (q->headblock.vtype == TYREAL) {
		if (forcereal) {
			nice_printf(outfile, "(real)");
			use_paren = 1;
			}
		}
	    else if (!Ansi && ISINT(q->headblock.vtype)) {
		nice_printf(outfile, "(ftnlen)");
		use_paren = 1;
		}
	    if (use_paren) nice_printf (outfile, "(");
	    expr_out (outfile, q);
	    if (use_paren) nice_printf (outfile, ")");
	} /* if !ISCOMPLEX */
	else
	    err ("out_call:  unknown parameter");

    } /* for (cp = arglist */

    if (arglist)
	frchain (&arglist);

    nice_printf (outfile, ")");

} /* out_call */


 char *
#ifdef KR_headers
flconst(buf, x)
	char *buf;
	char *x;
#else
flconst(char *buf, char *x)
#endif
{
	sprintf(buf, fl_fmt_string, x);
	return buf;
	}

 char *
#ifdef KR_headers
dtos(x)
	double x;
#else
dtos(double x)
#endif
{
	static char buf[64];
#ifdef USE_DTOA
	g_fmt(buf, x);
#else
	sprintf(buf, db_fmt_string, x);
#endif
	return strcpy(mem(strlen(buf)+1,0), buf);
	}

char tr_tab[Table_size];

/* out_init -- Initialize the data structures used by the routines in
   output.c.  These structures include the output format to be used for
   Float, Double, Complex, and Double Complex constants. */

 void
out_init(Void)
{
    extern int tab_size;
    register char *s;

    s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_+-.";
    while(*s)
	tr_tab[*s++] = 3;
    tr_tab['>'] = 1;

	opeqable[OPPLUS] = 1;
	opeqable[OPMINUS] = 1;
	opeqable[OPSTAR] = 1;
	opeqable[OPSLASH] = 1;
	opeqable[OPMOD] = 1;
	opeqable[OPLSHIFT] = 1;
	opeqable[OPBITAND] = 1;
	opeqable[OPBITXOR] = 1;
	opeqable[OPBITOR ] = 1;


/* Set the output format for both types of floating point constants */

    if (fl_fmt_string == NULL || *fl_fmt_string == '\0')
	fl_fmt_string = (char*)(Ansi == 1 ? "%sf" : "(float)%s");

    if (db_fmt_string == NULL || *db_fmt_string == '\0')
	db_fmt_string = "%.17g";

/* Set the output format for both types of complex constants.  They will
   have string parameters rather than float or double so that the decimal
   point may be added to the strings generated by the {db,fl}_fmt_string
   formats above */

    if (cm_fmt_string == NULL || *cm_fmt_string == '\0') {
	cm_fmt_string = "{%s,%s}";
    } /* if cm_fmt_string == NULL */

    if (dcm_fmt_string == NULL || *dcm_fmt_string == '\0') {
	dcm_fmt_string = "{%s,%s}";
    } /* if dcm_fmt_string == NULL */

    tab_size = 4;
} /* out_init */


 void
#ifdef KR_headers
extern_out(fp, extsym)
	FILE *fp;
	Extsym *extsym;
#else
extern_out(FILE *fp, Extsym *extsym)
#endif
{
    if (extsym == (Extsym *) NULL)
	return;

    nice_printf (fp, "%s", extsym->cextname);

} /* extern_out */



 static void
#ifdef KR_headers
output_list(fp, listp)
	FILE *fp;
	struct Listblock *listp;
#else
output_list(FILE *fp, struct Listblock *listp)
#endif
{
    int did_one = 0;
    chainp elts;

    nice_printf (fp, "(");
    if (listp)
	for (elts = listp -> listp; elts; elts = elts -> nextp) {
	    if (elts -> datap) {
		if (did_one)
		    nice_printf (fp, ", ");
		expr_out (fp, (expptr) elts -> datap);
		did_one = 1;
	    } /* if elts -> datap */
	} /* for elts */
    nice_printf (fp, ")");
} /* output_list */


 void
#ifdef KR_headers
out_asgoto(outfile, expr)
	FILE *outfile;
	expptr expr;
#else
out_asgoto(FILE *outfile, expptr expr)
#endif
{
    chainp value;
    Namep namep;
    int k;

    if (expr == (expptr) NULL) {
	err ("out_asgoto:  NULL variable expr");
	return;
    } /* if expr */

    nice_printf (outfile, Ansi ? "switch (" : "switch ((int)"); /*)*/
    expr_out (outfile, expr);
    nice_printf (outfile, ") {\n");
    next_tab (outfile);

/* The initial addrp value will be stored as a namep pointer */

    switch(expr->tag) {
	case TNAME:
		/* local variable */
		namep = &expr->nameblock;
		break;
	case TEXPR:
		if (expr->exprblock.opcode == OPWHATSIN
		 && expr->exprblock.leftp->tag == TNAME)
			/* argument */
			namep = &expr->exprblock.leftp->nameblock;
		else
			goto bad;
		break;
	case TADDR:
		if (expr->addrblock.uname_tag == UNAM_NAME) {
			/* initialized local variable */
			namep = expr->addrblock.user.name;
			break;
			}
	default:
 bad:
		err("out_asgoto:  bad expr");
		return;
	}

    for(k = 0, value = namep -> varxptr.assigned_values; value;
	    value = value->nextp, k++) {
	nice_printf (outfile, "case %d: goto %s;\n", k,
		user_label((Addr)value->datap));
    } /* for value */
    prev_tab (outfile);

    nice_printf (outfile, "}\n");
} /* out_asgoto */

 void
#ifdef KR_headers
out_if(outfile, expr)
	FILE *outfile;
	expptr expr;
#else
out_if(FILE *outfile, expptr expr)
#endif
{
    nice_printf (outfile, "if (");
    expr_out (outfile, expr);
    nice_printf (outfile, ") {\n");
    next_tab (outfile);
} /* out_if */

 static void
#ifdef KR_headers
output_rbrace(outfile, s)
	FILE *outfile;
	char *s;
#else
output_rbrace(FILE *outfile, char *s)
#endif
{
	extern int last_was_label;
	register char *fmt;

	if (last_was_label) {
		last_was_label = 0;
		fmt = ";%s";
		}
	else
		fmt = "%s";
	nice_printf(outfile, fmt, s);
	}

 void
#ifdef KR_headers
out_else(outfile)
	FILE *outfile;
#else
out_else(FILE *outfile)
#endif
{
    prev_tab (outfile);
    output_rbrace(outfile, "} else {\n");
    next_tab (outfile);
} /* out_else */

 void
#ifdef KR_headers
elif_out(outfile, expr)
	FILE *outfile;
	expptr expr;
#else
elif_out(FILE *outfile, expptr expr)
#endif
{
    prev_tab (outfile);
    output_rbrace(outfile, "} else ");
    out_if (outfile, expr);
} /* elif_out */

 void
#ifdef KR_headers
endif_out(outfile)
	FILE *outfile;
#else
endif_out(FILE *outfile)
#endif
{
    prev_tab (outfile);
    output_rbrace(outfile, "}\n");
} /* endif_out */

 void
#ifdef KR_headers
end_else_out(outfile)
	FILE *outfile;
#else
end_else_out(FILE *outfile)
#endif
{
    prev_tab (outfile);
    output_rbrace(outfile, "}\n");
} /* end_else_out */



 void
#ifdef KR_headers
compgoto_out(outfile, index, labels)
	FILE *outfile;
	expptr index;
	expptr labels;
#else
compgoto_out(FILE *outfile, expptr index, expptr labels)
#endif
{
    char *s1, *s2;

    if (index == ENULL)
	err ("compgoto_out:  null index for computed goto");
    else if (labels && labels -> tag != TLIST)
	erri ("compgoto_out:  expected label list, got tag '%d'",
		labels -> tag);
    else {
	chainp elts;
	int i = 1;

	s2 = /*(*/ ") {\n"; /*}*/
	if (Ansi)
		s1 = "switch ("; /*)*/
	else if (index->tag == TNAME || index->tag == TEXPR
				&& index->exprblock.opcode == OPWHATSIN)
		s1 = "switch ((int)"; /*)*/
	else {
		s1 = "switch ((int)(";
		s2 = ")) {\n"; /*}*/
		}
	nice_printf(outfile, s1);
	expr_out (outfile, index);
	nice_printf (outfile, s2);
	next_tab (outfile);

	for (elts = labels -> listblock.listp; elts; elts = elts -> nextp, i++) {
	    if (elts -> datap) {
		if (ISICON(((expptr) (elts -> datap))))
		    nice_printf (outfile, "case %d:  goto %s;\n", i,
			user_label(((expptr)(elts->datap))->constblock.Const.ci));
		else
		    err ("compgoto_out:  bad label in label list");
	    } /* if (elts -> datap) */
	} /* for elts */
	prev_tab (outfile);
	nice_printf (outfile, /*{*/ "}\n");
    } /* else */
} /* compgoto_out */


 void
#ifdef KR_headers
out_for(outfile, init, test, inc)
	FILE *outfile;
	expptr init;
	expptr test;
	expptr inc;
#else
out_for(FILE *outfile, expptr init, expptr test, expptr inc)
#endif
{
    nice_printf (outfile, "for (");
    expr_out (outfile, init);
    nice_printf (outfile, "; ");
    expr_out (outfile, test);
    nice_printf (outfile, "; ");
    expr_out (outfile, inc);
    nice_printf (outfile, ") {\n");
    next_tab (outfile);
} /* out_for */


 void
#ifdef KR_headers
out_end_for(outfile)
	FILE *outfile;
#else
out_end_for(FILE *outfile)
#endif
{
    prev_tab (outfile);
    nice_printf (outfile, "}\n");
} /* out_end_for */