format.c

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

do_p1_endelse(outfile)
	FILE *outfile;
#else
do_p1_endelse(FILE *outfile)
#endif
{
    end_else_out (outfile);
} /* do_p1_endelse */


 static expptr
#ifdef KR_headers
do_p1_addr(infile, outfile)
	FILE *infile;
	FILE *outfile;
#else
do_p1_addr(FILE *infile, FILE *outfile)
#endif
{
    Addrp addrp = (Addrp) NULL;
    int status;

    status = p1getn (infile, (int)sizeof(struct Addrblock), (char **) &addrp);

    if (status == EOF)
	err ("do_p1_addr:  Missing Addrp at end of file");
    else if (status == 0)
	err ("do_p1_addr:  Missing Addrp in p1 file");
    else if (addrp == (Addrp) NULL)
	err ("do_p1_addr:  Null addrp in p1 file");
    else if (addrp -> tag != TADDR)
	erri ("do_p1_addr: bad tag in p1 file '%d'", addrp -> tag);
    else {
	addrp -> vleng = do_format (infile, outfile);
	addrp -> memoffset = do_format (infile, outfile);
    }

    return (expptr) addrp;
} /* do_p1_addr */



 static void
#ifdef KR_headers
do_p1_subr_ret(infile, outfile)
	FILE *infile;
	FILE *outfile;
#else
do_p1_subr_ret(FILE *infile, FILE *outfile)
#endif
{
    expptr retval;

    nice_printf (outfile, "return ");
    retval = do_format (infile, outfile);
    if (!multitype)
	if (retval)
		expr_out (outfile, retval);

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



 static void
#ifdef KR_headers
do_p1_comp_goto(infile, outfile)
	FILE *infile;
	FILE *outfile;
#else
do_p1_comp_goto(FILE *infile, FILE *outfile)
#endif
{
    expptr index;
    expptr labels;

    index = do_format (infile, outfile);

    if (index == ENULL) {
	err ("do_p1_comp_goto:  no expression for computed goto");
	return;
    } /* if index == ENULL */

    labels = do_format (infile, outfile);

    if (labels && labels -> tag != TLIST)
	erri ("do_p1_comp_goto:  expected list, got tag '%d'", labels -> tag);
    else
	compgoto_out (outfile, index, labels);
} /* do_p1_comp_goto */


 static void
#ifdef KR_headers
do_p1_for(infile, outfile)
	FILE *infile;
	FILE *outfile;
#else
do_p1_for(FILE *infile, FILE *outfile)
#endif
{
    expptr init, test, inc;

    init = do_format (infile, outfile);
    test = do_format (infile, outfile);
    inc = do_format (infile, outfile);

    out_for (outfile, init, test, inc);
} /* do_p1_for */

 static void
#ifdef KR_headers
do_p1_end_for(outfile)
	FILE *outfile;
#else
do_p1_end_for(FILE *outfile)
#endif
{
    out_end_for (outfile);
} /* do_p1_end_for */


 static void
#ifdef KR_headers
do_p1_fortran(infile, outfile)
	FILE *infile;
	FILE *outfile;
#else
do_p1_fortran(FILE *infile, FILE *outfile)
#endif
{
	char buf[P1_STMTBUFSIZE];
	if (!p1gets(infile, buf, P1_STMTBUFSIZE))
		return;
	/* bypass nice_printf nonsense */
	fprintf(outfile, "/*< %s >*/\n", buf+1);	/* + 1 to skip by '$' */
	}


 static expptr
#ifdef KR_headers
do_p1_expr(infile, outfile)
	FILE *infile;
	FILE *outfile;
#else
do_p1_expr(FILE *infile, FILE *outfile)
#endif
{
    int status;
    long opcode, type;
    struct Exprblock *result = (struct Exprblock *) NULL;

    status = p1getd (infile, &opcode);

    if (status == EOF)
	err ("do_p1_expr:  Missing expr opcode at end of file");
    else if (status == 0)
	err ("do_p1_expr:  Missing expr opcode in p1 file");
    else {

	status = p1getd (infile, &type);

	if (status == EOF)
	    err ("do_p1_expr:  Missing expr type at end of file");
	else if (status == 0)
	    err ("do_p1_expr:  Missing expr type in p1 file");
	else if (opcode == 0)
	    return ENULL;
	else {
	    result = ALLOC (Exprblock);

	    result -> tag = TEXPR;
	    result -> vtype = type;
	    result -> opcode = opcode;
	    result -> vleng = do_format (infile, outfile);

	    if (is_unary_op (opcode))
		result -> leftp = do_format (infile, outfile);
	    else if (is_binary_op (opcode)) {
		result -> leftp = do_format (infile, outfile);
		result -> rightp = do_format (infile, outfile);
	    } else
		errl("do_p1_expr:  Illegal opcode %ld", opcode);
	} /* else */
    } /* else */

    return (expptr) result;
} /* do_p1_expr */


 static expptr
#ifdef KR_headers
do_p1_ident(infile)
	FILE *infile;
#else
do_p1_ident(FILE *infile)
#endif
{
	Addrp addrp;
	int status;
	long vtype, vstg;

	addrp = ALLOC (Addrblock);
	addrp -> tag = TADDR;

	status = p1getd (infile, &vtype);
	if (status == EOF)
	    err ("do_p1_ident:  Missing identifier type at end of file\n");
	else if (status == 0 || vtype < 0 || vtype >= NTYPES)
	    errl("do_p1_ident:  Bad type in intermediate file: %ld\n", vtype);
	else
	    addrp -> vtype = vtype;

	status = p1getd (infile, &vstg);
	if (status == EOF)
	    err ("do_p1_ident:  Missing identifier storage at end of file\n");
	else if (status == 0 || vstg < 0 || vstg > STGNULL)
	    errl("do_p1_ident:  Bad storage in intermediate file: %ld\n", vtype);
	else
	    addrp -> vstg = vstg;

	status = p1gets(infile, addrp->user.ident, IDENT_LEN);

	if (status == EOF)
	    err ("do_p1_ident:  Missing ident string at end of file");
	else if (status == 0)
	    err ("do_p1_ident:  Missing ident string in intermediate file");
	addrp->uname_tag = UNAM_IDENT;
	return (expptr) addrp;
} /* do_p1_ident */

 static expptr
#ifdef KR_headers
do_p1_charp(infile)
	FILE *infile;
#else
do_p1_charp(FILE *infile)
#endif
{
	Addrp addrp;
	int status;
	long vtype, vstg;
	char buf[64];

	addrp = ALLOC (Addrblock);
	addrp -> tag = TADDR;

	status = p1getd (infile, &vtype);
	if (status == EOF)
	    err ("do_p1_ident:  Missing identifier type at end of file\n");
	else if (status == 0 || vtype < 0 || vtype >= NTYPES)
	    errl("do_p1_ident:  Bad type in intermediate file: %ld\n", vtype);
	else
	    addrp -> vtype = vtype;

	status = p1getd (infile, &vstg);
	if (status == EOF)
	    err ("do_p1_ident:  Missing identifier storage at end of file\n");
	else if (status == 0 || vstg < 0 || vstg > STGNULL)
	    errl("do_p1_ident:  Bad storage in intermediate file: %ld\n", vtype);
	else
	    addrp -> vstg = vstg;

	status = p1gets(infile, buf, (int)sizeof(buf));

	if (status == EOF)
	    err ("do_p1_ident:  Missing charp ident string at end of file");
	else if (status == 0)
	    err ("do_p1_ident:  Missing charp ident string in intermediate file");
	addrp->uname_tag = UNAM_CHARP;
	addrp->user.Charp = strcpy(mem(strlen(buf)+1,0), buf);
	return (expptr) addrp;
}


 static expptr
#ifdef KR_headers
do_p1_extern(infile)
	FILE *infile;
#else
do_p1_extern(FILE *infile)
#endif
{
    Addrp addrp;

    addrp = ALLOC (Addrblock);
    if (addrp) {
	int status;

	addrp->tag = TADDR;
	addrp->vstg = STGEXT;
	addrp->uname_tag = UNAM_EXTERN;
	status = p1getd (infile, &(addrp -> memno));
	if (status == EOF)
	    err ("do_p1_extern:  Missing memno at end of file");
	else if (status == 0)
	    err ("do_p1_extern:  Missing memno in intermediate file");
	if (addrp->vtype = extsymtab[addrp->memno].extype)
		addrp->vclass = CLPROC;
    } /* if addrp */

    return (expptr) addrp;
} /* do_p1_extern */



 static expptr
#ifdef KR_headers
do_p1_head(infile, outfile)
	FILE *infile;
	FILE *outfile;
#else
do_p1_head(FILE *infile, FILE *outfile)
#endif
{
    int status;
    int add_n_;
    long class;
    char storage[256];

    status = p1getd (infile, &class);
    if (status == EOF)
	err ("do_p1_head:  missing header class at end of file");
    else if (status == 0)
	err ("do_p1_head:  missing header class in p1 file");
    else {
	status = p1gets (infile, storage, (int)sizeof(storage));
	if (status == EOF || status == 0)
	    storage[0] = '\0';
    } /* else */

    if (class == CLPROC || class == CLMAIN) {
	chainp lengths;

	add_n_ = nentry > 1;
	lengths = length_comp(entries, add_n_);

	if (!add_n_ && protofile && class != CLMAIN)
		protowrite(protofile, proctype, storage, entries, lengths);

	if (class == CLMAIN)
	    nice_printf (outfile, "/* Main program */ ");
	else
	    nice_printf(outfile, "%s ", multitype ? "VOID"
			: c_type_decl(proctype, 1));

	nice_printf(outfile, add_n_ ? "%s0_" : "%s", storage);
	if (!Ansi) {
		listargs(outfile, entries, add_n_, lengths);
		nice_printf (outfile, "\n");
		}
	list_arg_types (outfile, entries, lengths, add_n_, "\n");
	nice_printf (outfile, "{\n");
	frchain(&lengths);
	next_tab (outfile);
	strcpy(this_proc_name, storage);
	list_decls (outfile);

    } else if (class == CLBLOCK)
        next_tab (outfile);
    else
	errl("do_p1_head: got class %ld", class);

    return NULL;
} /* do_p1_head */


 static expptr
#ifdef KR_headers
do_p1_list(infile, outfile)
	FILE *infile;
	FILE *outfile;
#else
do_p1_list(FILE *infile, FILE *outfile)
#endif
{
    long tag, type, count;
    int status;
    expptr result;

    status = p1getd (infile, &tag);
    if (status == EOF)
	err ("do_p1_list:  missing list tag at end of file");
    else if (status == 0)
	err ("do_p1_list:  missing list tag in p1 file");
    else {
	status = p1getd (infile, &type);
	if (status == EOF)
	    err ("do_p1_list:  missing list type at end of file");
	else if (status == 0)
	    err ("do_p1_list:  missing list type in p1 file");
	else {
	    status = p1getd (infile, &count);
	    if (status == EOF)
		err ("do_p1_list:  missing count at end of file");
	    else if (status == 0)
		err ("do_p1_list:  missing count in p1 file");
	} /* else */
    } /* else */

    result = (expptr) ALLOC (Listblock);
    if (result) {
	chainp pointer;

	result -> tag = tag;
	result -> listblock.vtype = type;

/* Assume there will be enough data */

	if (count--) {
	    pointer = result->listblock.listp =
		mkchain((char *)do_format(infile, outfile), CHNULL);
	    while (count--) {
		pointer -> nextp =
			mkchain((char *)do_format(infile, outfile), CHNULL);
		pointer = pointer -> nextp;
	    } /* while (count--) */
	} /* if (count) */
    } /* if (result) */

    return result;
} /* do_p1_list */


 chainp
#ifdef KR_headers
length_comp(e, add_n)
	struct Entrypoint *e;
	int add_n;
#else
length_comp(struct Entrypoint *e, int add_n)
#endif
		/* get lengths of characters args */
{
	chainp lengths;
	chainp args, args1;
	Namep arg, np;
	int nchargs;
	Argtypes *at;
	Atype *a;
	extern int init_ac[TYSUBR+1];

	if (!e)
		return 0;	/* possible only with errors */
	args = args1 = add_n ? allargs : e->arglist;
	nchargs = 0;
	for (lengths = NULL; args; args = args -> nextp)
		if (arg = (Namep)args->datap) {
			if (arg->vclass == CLUNKNOWN)
				arg->vclass = CLVAR;
			if (arg->vtype == TYCHAR && arg->vclass != CLPROC) {
				lengths = mkchain((char *)arg, lengths);
				nchargs++;
				}
			}
	if (!add_n && (np = e->enamep)) {
		/* one last check -- by now we know all we ever will
		 * about external args...
		 */
		save_argtypes(e->arglist, &e->entryname->arginfo,
			&np->arginfo, 0, np->fvarname, STGEXT, nchargs,
			np->vtype, 1);
		at = e->entryname->arginfo;
		a = at->atypes + init_ac[np->vtype];
		for(; args1; a++, args1 = args1->nextp) {
			frchain(&a->cp);
			if (arg = (Namep)args1->datap)
			    switch(arg->vclass) {
				case CLPROC:
					if (arg->vimpltype
					&& a->type >= 300)
						a->type = TYUNKNOWN + 200;
					break;
				case CLUNKNOWN:
					a->type %= 100;
				}
			}
		}
	return revchain(lengths);
	}

 void
#ifdef KR_headers
listargs(outfile, entryp, add_n_, lengths)
	FILE *outfile;
	struct Entrypoint *entryp;
	int add_n_;
	chainp lengths;
#else
listargs(FILE *outfile, struct Entrypoint *entryp, int add_n_, chainp lengths)
#endif
{
	chainp args;
	char *s;
	Namep arg;
	int did_one = 0;

	nice_printf (outfile, "(");

	if (add_n_) {
		nice_printf(outfile, "n__");
		did_one = 1;
		args = allargs;
		}
	else {
		if (!entryp)
			return;	/* possible only with errors */
		args = entryp->arglist;
		}

	if (multitype)
		{
		nice_printf(outfile, ", ret_val");
		did_one = 1;
		args = allargs;
		}
	else if (ONEOF(proctype, MSKCOMPLEX|MSKCHAR))
		{
		s = xretslot[proctype]->user.ident;
		nice_printf(outfile, did_one ? ", %s" : "%s",
			*s == '(' /*)*/ ? "r_v" : s);
		did_one = 1;
		if (proctype == TYCHAR)
			nice_printf (outfile, ", ret_val_len");
		}
	for (; args; args = args -> nextp)
		if (arg = (Namep)args->datap) {
			nice_printf (outfile, "%s", did_one ? ", " : "");
			out_name (outfile, arg);
			did_one = 1;
			}

	for (args = lengths; args; args = args -> nextp)
		nice_printf(outfile, ", %s",
			new_arg_length((Namep)args->datap));
	nice_printf (outfile, ")");
} /* listargs */


 void
#ifdef KR_headers
list_arg_types(outfile, entryp, lengths, add_n_, finalnl)
	FILE *outfile;
	struct Entrypoint *entryp;
	chainp lengths;
	int add_n_;
	char *finalnl;
#else
list_arg_types(FILE *outfile, struct Entrypoint *entryp, chainp lengths, int add_n_, char *finalnl)
#endif
{
    chainp args;
    int last_type = -1, last_class = -1;
    int did_one = 0, done_one, is_ext;
    char *s, *sep = "", *sep1;

    if (outfile == (FILE *) NULL) {
	err ("list_arg_types:  null output file");
	return;
    } else if (entryp == (struct Entrypoint *) NULL) {
	err ("list_arg_types:  null procedure entry pointer");
	return;
    } /* else */

    if (Ansi) {
	done_one = 0;
	sep1 = ", ";
	nice_printf(outfile, "(" /*)*/);
	}
    else {
	done_one = 1;
	sep1 = ";\n";
	}
    args = entryp->arglist;
    if (add_n_) {
	nice_printf(outfile, "int n__");
	did_one = done_one;
	sep = sep1;
	args = allargs;
	}
    if (multitype) {
	nice_printf(outfile, "%sMultitype *ret_val", sep);
	did_one = done_one;
	sep = sep1;
	}
    else if (ONEOF (proctype, MSKCOMPLEX|MSKCHAR)) {
	s = xretslot[proctype]->user.ident;
	nice_printf(outfile, "%s%s *%s", sep, c_type_decl(proctype, 0),
			*s == '(' /*)*/ ? "r_v" : s);
	did_one = done_one;
	sep = sep1;
	if (proctype == TYCHAR)
	    nice_printf (outfile, "%sftnlen ret_val_len", sep);
    } /* if ONEOF proctype */
    for (; args; args = args -> nextp) {
	Namep arg = (Namep) args->datap;

/* Scalars are passed by reference, and arrays will have their lower bound
   adjusted, so nearly everything is printed with a star in front.  The
   exception is character lengths, which are passed by value. */

	if (arg) {
	    int type = arg -> vtype, class = arg -> vclass;

	    if (class == CLPROC)
		if (arg->vimpltype)
			type = Castargs ? TYUNKNOWN : TYSUBR;
		else if (type == TYREAL && forcedouble && !Castargs)
			type = TYDREAL;

	    if (type == last_type && class == last_class && did_one)
		nice_printf (outfile, ", ");
	    else
		if ((is_ext = class == CLPROC) && Castargs)
			nice_printf(outfile, "%s%s ", sep,
				usedcasts[type] = casttypes[type]);
		else
			nice_printf(outfile, "%s%s ", sep,
				c_type_decl(type, is_ext));
	    if (class == CLPROC)
		if (Castargs)
			out_name(outfile, arg);
		else {
			nice_printf(outfile, "(*");
			out_name(outfile, arg);
			nice_printf(outfile, ") %s", parens);
			}