names.c

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

		size = typesize[type];
	if ((t = v->vdim) && ISCONST(t->nelt))
		size *= t->nelt->constblock.Const.ci;
	return size + v->voffset;
	}

 static void	/* Pad common block if an EQUIVALENCE extended it. */
#ifdef KR_headers
pad_common(c)
	Extsym *c;
#else
pad_common(Extsym *c)
#endif
{
	register chainp cvl;
	register Namep v;
	long L = c->maxleng;
	int type;
	struct Dimblock *t;
	int szshort = typesize[TYSHORT];

	for(cvl = c->allextp; cvl; cvl = cvl->nextp)
		if (commlen((chainp)cvl->datap) >= L)
			return;
	v = ALLOC(Nameblock);
	v->vtype = type = L % szshort ? TYCHAR
				      : type_choice[L/szshort % 4];
	v->vstg = STGCOMMON;
	v->vclass = CLVAR;
	v->tag = TNAME;
	v->vdim = t = ALLOC(Dimblock);
	t->ndim = 1;
	t->dims[0].dimsize = ICON(L / typesize[type]);
	v->fvarname = v->cvarname = "eqv_pad";
	if (type == TYCHAR)
		v->vleng = ICON(1);
	c->allextp = mkchain((char *)mkchain((char *)v, CHNULL), c->allextp);
	}


/* wr_common_decls -- outputs the common declarations in one of three
   formats.  If all references to a common block look the same (field
   names and types agree), only one actual declaration will appear.
   Otherwise, the same block will require many structs.  If there is no
   block data, these structs will be union'ed together (so the linker
   knows the size of the largest one).  If there IS a block data, only
   that version will be associated with the variable, others will only be
   defined as types, so the pointer can be cast to it.  e.g.

	FORTRAN				C
----------------------------------------------------------------------
	common /com1/ a, b, c		struct { real a, b, c; } com1_;

	common /com1/ a, b, c		union {
	common /com1/ i, j, k		    struct { real a, b, c; } _1;
					    struct { integer i, j, k; } _2;
					} com1_;

	common /com1/ a, b, c		struct com1_1_ { real a, b, c; };
	block data			struct { integer i, j, k; } com1_ =
	common /com1/ i, j, k		  { 1, 2, 3 };
	data i/1/, j/2/, k/3/


   All of these versions will be followed by #defines, since the code in
   the function bodies can't know ahead of time which of these options
   will be taken */

/* Macros for deciding the output type */

#define ONE_STRUCT 1
#define UNION_STRUCT 2
#define INIT_STRUCT 3

 void
#ifdef KR_headers
wr_common_decls(outfile)
	FILE *outfile;
#else
wr_common_decls(FILE *outfile)
#endif
{
    Extsym *ext;
    extern int extcomm;
    static char *Extern[4] = {"", "Extern ", "extern "};
    char *E, *E0 = Extern[extcomm];
    int did_one = 0;

    for (ext = extsymtab; ext < nextext; ext++) {
	if (ext -> extstg == STGCOMMON && ext->allextp) {
	    chainp comm;
	    int count = 1;
	    int which;			/* which display to use;
					   ONE_STRUCT, UNION or INIT */

	    if (!did_one)
		nice_printf (outfile, "/* Common Block Declarations */\n\n");

	    pad_common(ext);

/* Construct the proper, condensed list of structs; eliminate duplicates
   from the initial list   ext -> allextp   */

	    comm = ext->allextp = revchain(ext->allextp);

	    if (ext -> extinit)
		which = INIT_STRUCT;
	    else if (comm->nextp) {
		which = UNION_STRUCT;
		nice_printf (outfile, "%sunion {\n", E0);
		next_tab (outfile);
		E = "";
		}
	    else {
		which = ONE_STRUCT;
		E = E0;
		}

	    for (; comm; comm = comm -> nextp, count++) {

		if (which == INIT_STRUCT)
		    nice_printf (outfile, "struct %s%d_ {\n",
			    ext->cextname, count);
		else
		    nice_printf (outfile, "%sstruct {\n", E);

		next_tab (c_file);

		wr_struct (outfile, (chainp) comm -> datap);

		prev_tab (c_file);
		if (which == UNION_STRUCT)
		    nice_printf (outfile, "} _%d;\n", count);
		else if (which == ONE_STRUCT)
		    nice_printf (outfile, "} %s;\n", ext->cextname);
		else
		    nice_printf (outfile, "};\n");
	    } /* for */

	    if (which == UNION_STRUCT) {
		prev_tab (c_file);
		nice_printf (outfile, "} %s;\n", ext->cextname);
	    } /* if */
	    did_one = 1;
	    nice_printf (outfile, "\n");

	    for (count = 1, comm = ext -> allextp; comm;
		    comm = comm -> nextp, count++) {
		def_start(outfile, ext->cextname,
			comm_union_name(count), "");
		switch (which) {
		    case ONE_STRUCT:
		        extern_out (outfile, ext);
		        break;
		    case UNION_STRUCT:
		        nice_printf (outfile, "(");
			extern_out (outfile, ext);
			nice_printf(outfile, "._%d)", count);
		        break;
		    case INIT_STRUCT:
			nice_printf (outfile, "(*(struct ");
			extern_out (outfile, ext);
			nice_printf (outfile, "%d_ *) &", count);
			extern_out (outfile, ext);
			nice_printf (outfile, ")");
		        break;
		} /* switch */
		nice_printf (outfile, "\n");
	    } /* for count = 1, comm = ext -> allextp */
	    nice_printf (outfile, "\n");
	} /* if ext -> extstg == STGCOMMON */
    } /* for ext = extsymtab */
} /* wr_common_decls */

 void
#ifdef KR_headers
wr_struct(outfile, var_list)
	FILE *outfile;
	chainp var_list;
#else
wr_struct(FILE *outfile, chainp var_list)
#endif
{
    int last_type = -1;
    int did_one = 0;
    chainp this_var;

    for (this_var = var_list; this_var; this_var = this_var -> nextp) {
	Namep var = (Namep) this_var -> datap;
	int type;
	char *comment = NULL;

	if (var == (Namep) NULL)
	    err ("wr_struct:  null variable");
	else if (var -> tag != TNAME)
	    erri ("wr_struct:  bad tag on variable '%d'",
		    var -> tag);

	type = var -> vtype;

	if (last_type == type && did_one)
	    nice_printf (outfile, ", ");
	else {
	    if (did_one)
		nice_printf (outfile, ";\n");
	    nice_printf (outfile, "%s ",
		    c_type_decl (type, var -> vclass == CLPROC));
	} /* else */

/* Character type is really a string type.  Put out a '*' for parameters
   with unknown length and functions returning character */

	if (var -> vtype == TYCHAR && (!ISICON ((var -> vleng))
		|| var -> vclass == CLPROC))
	    nice_printf (outfile, "*");

	var -> vstg = STGAUTO;
	out_name (outfile, var);
	if (var -> vclass == CLPROC)
	    nice_printf (outfile, "()");
	else if (var -> vdim)
	    comment = wr_ardecls(outfile, var->vdim,
				var->vtype == TYCHAR && ISICON(var->vleng)
				? var->vleng->constblock.Const.ci : 1L);
	else if (var -> vtype == TYCHAR && var -> vclass != CLPROC &&
	    ISICON ((var -> vleng)))
	    nice_printf (outfile, "[%ld]",
		    var -> vleng -> constblock.Const.ci);

	if (comment)
	    nice_printf (outfile, "%s", comment);
	did_one = 1;
	last_type = type;
    } /* for this_var */

    if (did_one)
	nice_printf (outfile, ";\n");
} /* wr_struct */


 char *
#ifdef KR_headers
user_label(stateno)
	ftnint stateno;
#else
user_label(ftnint stateno)
#endif
{
	static char buf[USER_LABEL_MAX + 1];
	static char *Lfmt[2] = { "L_%ld", "L%ld" };

	if (stateno >= 0)
		sprintf(buf, Lfmt[shiftcase], stateno);
	else
		sprintf(buf, "L_%s", extsymtab[-1-stateno].fextname);
	return buf;
} /* user_label */


 char *
#ifdef KR_headers
temp_name(starter, num, storage)
	char *starter;
	int num;
	char *storage;
#else
temp_name(char *starter, int num, char *storage)
#endif
{
    static char buf[IDENT_LEN];
    char *pointer = buf;
    char *prefix = "t";

    if (storage)
	pointer = storage;

    if (starter && *starter)
	prefix = starter;

    sprintf (pointer, "%s__%d", prefix, num);
    return pointer;
} /* temp_name */


 char *
#ifdef KR_headers
equiv_name(memno, store)
	int memno;
	char *store;
#else
equiv_name(int memno, char *store)
#endif
{
    static char buf[IDENT_LEN];
    char *pointer = buf;

    if (store)
	pointer = store;

    sprintf (pointer, "%s_%d", EQUIV_INIT_NAME, memno);
    return pointer;
} /* equiv_name */

 void
#ifdef KR_headers
def_commons(of)
	FILE *of;
#else
def_commons(FILE *of)
#endif
{
	Extsym *ext;
	int c, onefile, Union;
	chainp comm;
	extern int ext1comm;
	FILE *c_filesave = c_file;

	if (ext1comm == 1) {
		onefile = 1;
		c_file = of;
		fprintf(of, "/*>>>'/dev/null'<<<*/\n\
#ifdef Define_COMMONs\n\
/*<<</dev/null>>>*/\n");
		}
	else
		onefile = 0;
	for(ext = extsymtab; ext < nextext; ext++)
		if (ext->extstg == STGCOMMON
		&& !ext->extinit && (comm = ext->allextp)) {
			sprintf(outbtail, "%scom.c", ext->cextname);
			if (onefile)
				fprintf(of, "/*>>>'%s'<<<*/\n",
					outbtail);
			else {
				c_file = of = fopen(outbuf,textwrite);
				if (!of)
					fatalstr("can't open %s", outbuf);
				}
			fprintf(of, "#include \"f2c.h\"\n");
			if (comm->nextp) {
				Union = 1;
				nice_printf(of, "union {\n");
				next_tab(of);
				}
			else
				Union = 0;
			for(c = 1; comm; comm = comm->nextp) {
				nice_printf(of, "struct {\n");
				next_tab(of);
				wr_struct(of, (chainp)comm->datap);
				prev_tab(of);
				if (Union)
					nice_printf(of, "} _%d;\n", c++);
				}
			if (Union)
				prev_tab(of);
			nice_printf(of, "} %s;\n", ext->cextname);
			if (onefile)
				fprintf(of, "/*<<<%s>>>*/\n", outbtail);
			else
				fclose(of);
			}
	if (onefile)
		fprintf(of, "/*>>>'/dev/null'<<<*/\n#endif\n\
/*<<</dev/null>>>*/\n");
	c_file = c_filesave;
	}

/* C Language keywords.  Needed to filter unwanted fortran identifiers like
 * "int", etc.  Source:  Kernighan & Ritchie, eds. 1 and 2; Stroustrup.
 * Also includes C++ keywords and types used for I/O in f2c.h .
 * These keywords must be in alphabetical order (as defined by strcmp()).
 */

char *c_keywords[] = {
	"Long", "Multitype", "Namelist", "Vardesc",
	"abs", "acos", "address", "alist", "asin", "asm",
	"atan", "atan2", "auto", "break",
	"case", "catch", "char", "cilist", "class", "cllist",
	"complex", "const", "continue", "cos", "cosh",
	"dabs", "default", "defined", "delete",
	"dmax", "dmin", "do", "double", "doublecomplex", "doublereal",
	"else", "entry", "enum", "exp", "extern",
	"flag", "float", "for", "friend", "ftnint", "ftnlen", "goto",
	"icilist", "if", "include", "inline", "inlist", "int", "integer",
	"integer1", "log", "logical", "logical1", "long", "longint",
	"max", "min", "new",
	"olist", "operator", "overload", "private", "protected", "public",
	"real", "register", "return",
	"short", "shortint", "shortlogical", "signed", "sin", "sinh",
	"sizeof", "sqrt", "static", "struct", "switch",
	"tan", "tanh", "template", "this", "try", "typedef",
	"union", "unsigned", "virtual", "void", "volatile", "while"
}; /* c_keywords */

int n_keywords = sizeof(c_keywords)/sizeof(char *);

char *st_fields[] = {
	"addr", "aerr", "aunit", "c", "cerr", "ciend", "cierr",
	"cifmt", "cirec", "ciunit", "csta", "cunit", "d", "dims",
	"h", "i", "iciend", "icierr", "icifmt", "icirlen",
	"icirnum", "iciunit", "inacc", "inacclen", "inblank",
	"inblanklen", "indir", "indirlen", "inerr", "inex",
	"infile", "infilen", "infmt", "infmtlen", "inform",
	"informlen", "inname", "innamed", "innamlen", "innrec",
	"innum", "inopen", "inrecl", "inseq", "inseqlen", "inunf",
	"inunflen", "inunit", "name", "nvars", "oacc", "oblnk",
	"oerr", "ofm", "ofnm", "ofnmlen", "orl", "osta", "ounit",
	"r", "type", "vars", "z"
	};
int n_st_fields = sizeof(st_fields)/sizeof(char *);