Remove f2c as its libraries were tossed last April, and f2c has been replaced

with EGCS's f77.

Noticed still alive by:	bde

1 files changed, 0 insertions, 1711 deletions

diff --git a/usr.bin/f2c/output.c b/usr.bin/f2c/output.c
deleted file mode 100644
index 5f650e7..0000000
--- a/usr.bin/f2c/output.c
+++ /dev/null
@@ -1,1711 +0,0 @@
-/****************************************************************
-Copyright 1990 - 1996 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;
-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
-{
-    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 &&
-	e -> exprblock.rightp -> tag == TEXPR) {
-	int opcode;
-
-	opcode = e -> exprblock.rightp -> exprblock.opcode;
-
-	if (opeqable[opcode]) {
-	    expptr leftp, rightp;
-
-	    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 || */
-    } /* if e -> exprblock.opcode == OPASSIGN */
-
-
-/* Optimize on increment or decrement by 1 */
-
-    {
-	int opcode = e -> exprblock.opcode;
-	expptr leftp = e -> exprblock.leftp;
-	expptr 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);
-
-    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];
-    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 TYQUAD
-	case TYQUAD:
-#endif
-	    nice_printf (fp, "%ld", cp->Const.ci);	/* don't cast ci! */
-	    break;
-	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], k);
-		}
-	    for(k = cp->Const.ccp1.blanks; k > 0; k--)
-		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 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;
-    extern table_entry opcode_table[];
-    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 && forcereal) {
-		nice_printf(outfile, "(real)");
-		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 = 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((long)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 */