output.c

把fortran语言编的程序转为c语言编的程序, 运行环境linux

/****************************************************************
Copyright 1990 - 1994 by AT&T Bell Laboratories 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 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 and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness.  In no event shall AT&T 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)" },

/* 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)

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, int, 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 */


static char *Longfmt = "%ld";

#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, Longfmt, 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)