output.c

来自「把fortran语言编的程序转为c语言编的程序, 运行环境linux」· C语言 代码 · 共 1,671 行 · 第 1/3 页

		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, (int)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;
	int memno;
	Constp cp;
#else
output_literal(FILE *fp, int 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 && forcedouble) {
			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 ichar and character*1 */
	register expptr lp;
	register union Expression *Offset;
	register char *cp;
	int lt;
	char buf[8];
	unsigned int k;
	Namep np;

	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)
		nice_printf(fp, "(%s) ",
			c_type_decl(e->vtype, 0));
	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 */

/* 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, "(");
	np = (Namep)name->exprblock.leftp; /*expr_out will free name */
	expr_out (outfile, name);
	nice_printf (outfile, ")");