format.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.
****************************************************************/

/* Format.c -- this file takes an intermediate file (generated by pass 1
   of the translator) and some state information about the contents of that
   file, and generates C program text. */

#include "defs.h"
#include "p1defs.h"
#include "format.h"
#include "output.h"
#include "names.h"
#include "iob.h"

int c_output_line_length = DEF_C_LINE_LENGTH;

int last_was_label;	/* Boolean used to generate semicolons
				   when a label terminates a block */
static char this_proc_name[52];	/* Name of the current procedure.  This is
				   probably too simplistic to handle
				   multiple entry points */

static tagptr do_format Argdcl((FILEP, FILEP));
static void do_p1_1while Argdcl((FILEP));
static void do_p1_2while Argdcl((FILEP, FILEP));
static tagptr do_p1_addr Argdcl((FILEP, FILEP));
static void do_p1_asgoto Argdcl((FILEP, FILEP));
static tagptr do_p1_charp Argdcl((FILEP));
static void do_p1_comment Argdcl((FILEP, FILEP));
static void do_p1_comp_goto Argdcl((FILEP, FILEP));
static tagptr do_p1_const Argdcl((FILEP));
static void do_p1_elif Argdcl((FILEP, FILEP));
static void do_p1_else Argdcl((FILEP));
static void do_p1_elseifstart Argdcl((FILEP));
static void do_p1_end_for Argdcl((FILEP));
static void do_p1_endelse Argdcl((FILEP));
static void do_p1_endif Argdcl((FILEP));
static tagptr do_p1_expr Argdcl((FILEP, FILEP));
static tagptr do_p1_extern Argdcl((FILEP));
static void do_p1_for Argdcl((FILEP, FILEP));
static void do_p1_fortran Argdcl((FILEP, FILEP));
static void do_p1_goto Argdcl((FILEP, FILEP));
static tagptr do_p1_head Argdcl((FILEP, FILEP));
static tagptr do_p1_ident Argdcl((FILEP));
static void do_p1_if Argdcl((FILEP, FILEP));
static void do_p1_label Argdcl((FILEP, FILEP));
static tagptr do_p1_list Argdcl((FILEP, FILEP));
static tagptr do_p1_literal Argdcl((FILEP));
static tagptr do_p1_name_pointer Argdcl((FILEP));
static void do_p1_set_line Argdcl((FILEP));
static void do_p1_subr_ret Argdcl((FILEP, FILEP));
static int get_p1_token Argdcl((FILEP));
static int p1get_const Argdcl((FILEP, int, Constp*));
static int p1getd Argdcl((FILEP, long int*));
static int p1getf Argdcl((FILEP, char**));
static int p1getn Argdcl((FILEP, int, char**));
static int p1gets Argdcl((FILEP, char*, int));
static void proto Argdcl((FILEP, Argtypes*, char*));

extern chainp assigned_fmts;
char filename[P1_FILENAME_MAX];
extern int gflag, sharp_line;
int gflag1;
extern char *parens;

 void
start_formatting(Void)
{
    FILE *infile;
    static int wrote_one = 0;
    extern int usedefsforcommon;
    extern char *p1_file, *p1_bakfile;

    this_proc_name[0] = '\0';
    last_was_label = 0;
    ei_next = ei_first;
    wh_next = wh_first;

    (void) fclose (pass1_file);
    if ((infile = fopen (p1_file, binread)) == NULL)
	Fatal("start_formatting:  couldn't open the intermediate file\n");

    if (wrote_one)
	nice_printf (c_file, "\n");

    while (!feof (infile)) {
	expptr this_expr;

	this_expr = do_format (infile, c_file);
	if (this_expr) {
	    out_and_free_statement (c_file, this_expr);
	} /* if this_expr */
    } /* while !feof infile */

    (void) fclose (infile);

    if (last_was_label)
	nice_printf (c_file, ";\n");

    prev_tab (c_file);
    gflag1 = sharp_line = 0;
    if (this_proc_name[0])
	nice_printf (c_file, "} /* %s */\n", this_proc_name);


/* Write the #undefs for common variable reference */

    if (usedefsforcommon) {
	Extsym *ext;
	int did_one = 0;

	for (ext = extsymtab; ext < nextext; ext++)
	    if (ext -> extstg == STGCOMMON && ext -> used_here) {
		ext -> used_here = 0;
		if (!did_one)
		    nice_printf (c_file, "\n");
		wr_abbrevs(c_file, 0, ext->extp);
		did_one = 1;
		ext -> extp = CHNULL;
	    } /* if */

	if (did_one)
	    nice_printf (c_file, "\n");
    } /* if usedefsforcommon */

    other_undefs(c_file);

    wrote_one = 1;

/* For debugging only */

    if (debugflag && (pass1_file = fopen (p1_bakfile, binwrite)))
	if (infile = fopen (p1_file, binread)) {
	    ffilecopy (infile, pass1_file);
	    fclose (infile);
	    fclose (pass1_file);
	} /* if infile */

/* End of "debugging only" */

    scrub(p1_file);	/* optionally unlink */

    if ((pass1_file = fopen (p1_file, binwrite)) == NULL)
	err ("start_formatting:  couldn't reopen the pass1 file");

} /* start_formatting */


 static void
#ifdef KR_headers
put_semi(outfile)
	FILE *outfile;
#else
put_semi(FILE *outfile)
#endif
{
	nice_printf (outfile, ";\n");
	last_was_label = 0;
	}

#define SEM_CHECK(x) if (last_was_label) put_semi(x)

/* do_format -- takes an input stream (a file in pass1 format) and writes
   the appropriate C code to   outfile   when possible.  When reading an
   expression, the expression tree is returned instead. */

 static expptr
#ifdef KR_headers
do_format(infile, outfile)
	FILE *infile;
	FILE *outfile;
#else
do_format(FILE *infile, FILE *outfile)
#endif
{
    int token_type, was_c_token;
    expptr retval = ENULL;

    token_type = get_p1_token (infile);
    was_c_token = 1;
    switch (token_type) {
	case P1_COMMENT:
	    do_p1_comment (infile, outfile);
	    was_c_token = 0;
	    break;
	case P1_SET_LINE:
	    do_p1_set_line (infile);
	    was_c_token = 0;
	    break;
	case P1_FILENAME:
	    p1gets(infile, filename, P1_FILENAME_MAX);
	    was_c_token = 0;
	    break;
	case P1_NAME_POINTER:
	    retval = do_p1_name_pointer (infile);
	    break;
	case P1_CONST:
	    retval = do_p1_const (infile);
	    break;
	case P1_EXPR:
	    retval = do_p1_expr (infile, outfile);
	    break;
	case P1_IDENT:
	    retval = do_p1_ident(infile);
	    break;
	case P1_CHARP:
		retval = do_p1_charp(infile);
		break;
	case P1_EXTERN:
	    retval = do_p1_extern (infile);
	    break;
	case P1_HEAD:
	    gflag1 = sharp_line = 0;
	    retval = do_p1_head (infile, outfile);
	    gflag1 = sharp_line = gflag;
	    break;
	case P1_LIST:
	    retval = do_p1_list (infile, outfile);
	    break;
	case P1_LITERAL:
	    retval = do_p1_literal (infile);
	    break;
	case P1_LABEL:
	    do_p1_label (infile, outfile);
	    /* last_was_label = 1; -- now set in do_p1_label */
	    was_c_token = 0;
	    break;
	case P1_ASGOTO:
	    do_p1_asgoto (infile, outfile);
	    break;
	case P1_GOTO:
	    do_p1_goto (infile, outfile);
	    break;
	case P1_IF:
	    do_p1_if (infile, outfile);
	    break;
	case P1_ELSE:
	    SEM_CHECK(outfile);
	    do_p1_else (outfile);
	    break;
	case P1_ELIF:
	    SEM_CHECK(outfile);
	    do_p1_elif (infile, outfile);
	    break;
	case P1_ENDIF:
	    SEM_CHECK(outfile);
	    do_p1_endif (outfile);
	    break;
	case P1_ENDELSE:
	    SEM_CHECK(outfile);
	    do_p1_endelse (outfile);
	    break;
	case P1_ADDR:
	    retval = do_p1_addr (infile, outfile);
	    break;
	case P1_SUBR_RET:
	    do_p1_subr_ret (infile, outfile);
	    break;
	case P1_COMP_GOTO:
	    do_p1_comp_goto (infile, outfile);
	    break;
	case P1_FOR:
	    do_p1_for (infile, outfile);
	    break;
	case P1_ENDFOR:
	    SEM_CHECK(outfile);
	    do_p1_end_for (outfile);
	    break;
	case P1_WHILE1START:
		do_p1_1while(outfile);
		break;
	case P1_WHILE2START:
		do_p1_2while(infile, outfile);
		break;
	case P1_PROCODE:
		procode(outfile);
		break;
	case P1_ELSEIFSTART:
		SEM_CHECK(outfile);
		do_p1_elseifstart(outfile);
		break;
	case P1_FORTRAN:
		do_p1_fortran(infile, outfile);
		/* no break; */
	case P1_EOF:
	    was_c_token = 0;
	    break;
	case P1_UNKNOWN:
	    Fatal("do_format:  Unknown token type in intermediate file");
	    break;
	default:
	    Fatal("do_format:  Bad token type in intermediate file");
	    break;
   } /* switch */

    if (was_c_token)
	last_was_label = 0;
    return retval;
} /* do_format */


 static void
#ifdef KR_headers
do_p1_comment(infile, outfile)
	FILE *infile;
	FILE *outfile;
#else
do_p1_comment(FILE *infile, FILE *outfile)
#endif
{
    extern int c_output_line_length, in_comment;

    char storage[COMMENT_BUFFER_SIZE + 1];
    int length;

    if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1))
	return;

    length = strlen (storage);

    gflag1 = sharp_line = 0;
    in_comment = 1;
    if (length > c_output_line_length - 6)
	margin_printf(outfile, "/*%s*/\n", storage);
    else
	margin_printf(outfile, length ? "/* %s */\n" : "\n", storage);
    in_comment = 0;
    gflag1 = sharp_line = gflag;
} /* do_p1_comment */

 static void
#ifdef KR_headers
do_p1_set_line(infile)
	FILE *infile;
#else
do_p1_set_line(FILE *infile)
#endif
{
    int status;
    long new_line_number = -1;

    status = p1getd (infile, &new_line_number);

    if (status == EOF)
	err ("do_p1_set_line:  Missing line number at end of file\n");
    else if (status == 0 || new_line_number == -1)
	errl("do_p1_set_line:  Illegal line number in intermediate file: %ld\n",
		new_line_number);
    else {
	lineno = new_line_number;
	}
} /* do_p1_set_line */


 static expptr
#ifdef KR_headers
do_p1_name_pointer(infile)
	FILE *infile;
#else
do_p1_name_pointer(FILE *infile)
#endif
{
    Namep namep = (Namep) NULL;
    int status;

    status = p1getd (infile, (long *) &namep);

    if (status == EOF)
	err ("do_p1_name_pointer:  Missing pointer at end of file\n");
    else if (status == 0 || namep == (Namep) NULL)
	erri ("do_p1_name_pointer:  Illegal name pointer in p1 file: '%x'\n",
		(int) namep);

    return (expptr) namep;
} /* do_p1_name_pointer */



 static expptr
#ifdef KR_headers
do_p1_const(infile)
	FILE *infile;
#else
do_p1_const(FILE *infile)
#endif
{
    struct Constblock *c = (struct Constblock *) NULL;
    long type = -1;
    int status;

    status = p1getd (infile, &type);

    if (status == EOF)
	err ("do_p1_const:  Missing constant type at end of file\n");
    else if (status == 0)
	errl("do_p1_const:  Illegal constant type in p1 file: %ld\n", type);
    else {
	status = p1get_const (infile, (int)type, &c);

	if (status == EOF) {
	    err ("do_p1_const:  Missing constant value at end of file\n");
	    c = (struct Constblock *) NULL;
	} else if (status == 0) {
	    err ("do_p1_const:  Illegal constant value in p1 file\n");
	    c = (struct Constblock *) NULL;
	} /* else */
    } /* else */
    return (expptr) c;
} /* do_p1_const */

 void
#ifdef KR_headers
addrlit(addrp)
	Addrp addrp;
#else
addrlit(Addrp addrp)
#endif
{
	int memno = addrp->memno;
	struct Literal *litp, *lastlit;

	lastlit = litpool + nliterals;
	for (litp = litpool; litp < lastlit; litp++)
	    if (litp->litnum == memno) {
		addrp->vtype = litp->littype;
		*((union Constant *) &(addrp->user)) =
			*((union Constant *) &(litp->litval));
		addrp->vstg = STGMEMNO;
		return;
		}
	err("addrlit failure!");
	}

 static expptr
#ifdef KR_headers
do_p1_literal(infile)
	FILE *infile;
#else
do_p1_literal(FILE *infile)
#endif
{
    int status;
    long memno;
    Addrp addrp;

    status = p1getd (infile, &memno);

    if (status == EOF)
	err ("do_p1_literal:  Missing memno at end of file");
    else if (status == 0)
	err ("do_p1_literal:  Missing memno in p1 file");
    else {
	addrp = ALLOC (Addrblock);
	addrp -> tag = TADDR;
	addrp -> vtype = TYUNKNOWN;
	addrp -> Field = NULL;
	addrp -> memno = memno;
	addrlit(addrp);
	addrp -> uname_tag = UNAM_CONST;
    } /* else */

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


 static void
#ifdef KR_headers
do_p1_label(infile, outfile)
	FILE *infile;
	FILE *outfile;
#else
do_p1_label(FILE *infile, FILE *outfile)
#endif
{
    int status;
    ftnint stateno;
    struct Labelblock *L;
    char *fmt;

    status = p1getd (infile, &stateno);

    if (status == EOF)
	err ("do_p1_label:  Missing label at end of file");
    else if (status == 0)
	err ("do_p1_label:  Missing label in p1 file ");
    else if (stateno < 0) {	/* entry */
	margin_printf(outfile, "\n%s:\n", user_label(stateno));
	last_was_label = 1;
	}
    else {
	L = labeltab + stateno;
	if (L->labused) {
		fmt = "%s:\n";
		last_was_label = 1;
		}
	else
		fmt = "/* %s: */\n";
	margin_printf(outfile, fmt, user_label(L->stateno));
    } /* else */
} /* do_p1_label */



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

    expr = do_format (infile, outfile);
    out_asgoto (outfile, expr);

} /* do_p1_asgoto */


 static void
#ifdef KR_headers
do_p1_goto(infile, outfile)
	FILE *infile;
	FILE *outfile;
#else
do_p1_goto(FILE *infile, FILE *outfile)
#endif
{
    int status;
    long stateno;

    status = p1getd (infile, &stateno);

    if (status == EOF)
	err ("do_p1_goto:  Missing goto label at end of file");
    else if (status == 0)
	err ("do_p1_goto:  Missing goto label in p1 file");
    else {
	nice_printf (outfile, "goto %s;\n", user_label (stateno));
    } /* else */
} /* do_p1_goto */


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

    do {
        cond = do_format (infile, outfile);
    } while (cond == ENULL);

    out_if (outfile, cond);
} /* do_p1_if */


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


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

    do {
        cond = do_format (infile, outfile);
    } while (cond == ENULL);

    elif_out (outfile, cond);
} /* do_p1_elif */

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


 static void
#ifdef KR_headers