output.c

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

	}
    else {
	np = (Namep)name;
	expr_out(outfile, name);
	}

    /* prepare to cast procedure parameters -- set A if we know how */

    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;
    	}

    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 (tyioint == TYLONG)
	   	Longfmt = "%ldL";
	    out_const(outfile, &q->constblock);
	    Longfmt = "%ld";
	    }

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