format.c

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

	    else {
		nice_printf (outfile, "*");
		out_name (outfile, arg);
		}

	    last_type = type;
	    last_class = class;
	    did_one = done_one;
	    sep = sep1;
	} /* if (arg) */
    } /* for args = entryp -> arglist */

    for (args = lengths; args; args = args -> nextp)
	nice_printf(outfile, "%sftnlen %s", sep,
			new_arg_length((Namep)args->datap));
    if (did_one)
	nice_printf (outfile, ";\n");
    else if (Ansi)
	nice_printf(outfile,
		/*((*/ sep != sep1 && Ansi == 1 ? "void)%s" : ")%s",
		finalnl);
} /* list_arg_types */

 static void
#ifdef KR_headers
write_formats(outfile)
	FILE *outfile;
#else
write_formats(FILE *outfile)
#endif
{
	register struct Labelblock *lp;
	int first = 1;
	char *fs;

	for(lp = labeltab ; lp < highlabtab ; ++lp)
		if (lp->fmtlabused) {
			if (first) {
				first = 0;
				nice_printf(outfile, "/* Format strings */\n");
				}
			nice_printf(outfile, "static char fmt_%ld[] = \"",
				lp->stateno);
			if (!(fs = lp->fmtstring))
				fs = "";
			nice_printf(outfile, "%s\";\n", fs);
			}
	if (!first)
		nice_printf(outfile, "\n");
	}

 static void
#ifdef KR_headers
write_ioblocks(outfile)
	FILE *outfile;
#else
write_ioblocks(FILE *outfile)
#endif
{
	register iob_data *L;
	register char *f, **s, *sep;

	nice_printf(outfile, "/* Fortran I/O blocks */\n");
	L = iob_list = (iob_data *)revchain((chainp)iob_list);
	do {
		nice_printf(outfile, "static %s %s = { ",
			L->type, L->name);
		sep = 0;
		for(s = L->fields; f = *s; s++) {
			if (sep)
				nice_printf(outfile, sep);
			sep = ", ";
			if (*f == '"') {	/* kludge */
				nice_printf(outfile, "\"");
				nice_printf(outfile, "%s\"", f+1);
				}
			else
				nice_printf(outfile, "%s", f);
			}
		nice_printf(outfile, " };\n");
		}
		while(L = L->next);
	nice_printf(outfile, "\n\n");
	}

 static void
#ifdef KR_headers
write_assigned_fmts(outfile)
	FILE *outfile;
#else
write_assigned_fmts(FILE *outfile)
#endif
{
	register chainp cp;
	Namep np;
	int did_one = 0;

	cp = assigned_fmts = revchain(assigned_fmts);
	nice_printf(outfile, "/* Assigned format variables */\nchar ");
	do {
		np = (Namep)cp->datap;
		if (did_one)
			nice_printf(outfile, ", ");
		did_one = 1;
		nice_printf(outfile, "*%s_fmt", np->fvarname);
		}
		while(cp = cp->nextp);
	nice_printf(outfile, ";\n\n");
	}

 static char *
#ifdef KR_headers
to_upper(s)
	register char *s;
#else
to_upper(register char *s)
#endif
{
	static char buf[64];
	register char *t = buf;
	register int c;
	while(*t++ = (c = *s++) >= 'a' && c <= 'z' ? c + 'A' - 'a' : c);
	return buf;
	}


/* This routine creates static structures representing a namelist.
   Declarations of the namelist and related structures are:

	struct Vardesc {
		char *name;
		char *addr;
		ftnlen *dims;	/* laid out as struct dimensions below *//*
		int  type;
		};
	typedef struct Vardesc Vardesc;

	struct Namelist {
		char *name;
		Vardesc **vars;
		int nvars;
		};

	struct dimensions
		{
		ftnlen numberofdimensions;
		ftnlen numberofelements
		ftnlen baseoffset;
		ftnlen span[numberofdimensions-1];
		};

   If dims is not null, then the corner element of the array is at
   addr.  However,  the element with subscripts (i1,...,in) is at
   addr + sizeoftype * (i1+span[0]*(i2+span[1]*...) - dimp->baseoffset)
*/

 static void
#ifdef KR_headers
write_namelists(nmch, outfile)
	chainp nmch;
	FILE *outfile;
#else
write_namelists(chainp nmch, FILE *outfile)
#endif
{
	Namep var;
	struct Hashentry *entry;
	struct Dimblock *dimp;
	int i, nd, type;
	char *comma, *name;
	register chainp q;
	register Namep v;
	extern int typeconv[];

	nice_printf(outfile, "/* Namelist stuff */\n\n");
	for (entry = hashtab; entry < lasthash; ++entry) {
		if (!(v = entry->varp) || !v->vnamelist)
			continue;
		type = v->vtype;
		name = v->cvarname;
		if (dimp = v->vdim) {
			nd = dimp->ndim;
			nice_printf(outfile,
				"static ftnlen %s_dims[] = { %d, %ld, %ld",
				name, nd,
				dimp->nelt->constblock.Const.ci,
				dimp->baseoffset->constblock.Const.ci);
			for(i = 0, --nd; i < nd; i++)
				nice_printf(outfile, ", %ld",
				  dimp->dims[i].dimsize->constblock.Const.ci);
			nice_printf(outfile, " };\n");
			}
		nice_printf(outfile, "static Vardesc %s_dv = { \"%s\", %s",
			name, to_upper(v->fvarname),
			type == TYCHAR ? ""
				: (dimp || oneof_stg(v,v->vstg,
					M(STGEQUIV)|M(STGCOMMON)))
				? "(char *)" : "(char *)&");
		out_name(outfile, v);
		nice_printf(outfile, dimp ? ", %s_dims" : ", (ftnlen *)0", name);
		nice_printf(outfile, ", %ld };\n",
			type != TYCHAR  ? (long)typeconv[type]
					: -v->vleng->constblock.Const.ci);
		}

	do {
		var = (Namep)nmch->datap;
		name = var->cvarname;
		nice_printf(outfile, "\nstatic Vardesc *%s_vl[] = ", name);
		comma = "{";
		i = 0;
		for(q = var->varxptr.namelist ; q ; q = q->nextp) {
			v = (Namep)q->datap;
			if (!v->vnamelist)
				continue;
			i++;
			nice_printf(outfile, "%s &%s_dv", comma, v->cvarname);
			comma = ",";
			}
		nice_printf(outfile, " };\n");
		nice_printf(outfile,
			"static Namelist %s = { \"%s\", %s_vl, %d };\n",
			name, to_upper(var->fvarname), name, i);
		}
		while(nmch = nmch->nextp);
	nice_printf(outfile, "\n");
	}

/* fixextype tries to infer from usage in previous procedures
   the type of an external procedure declared
   external and passed as an argument but never typed or invoked.
 */

 static int
#ifdef KR_headers
fixexttype(var)
	Namep var;
#else
fixexttype(Namep var)
#endif
{
	Extsym *e;
	int type, type1;

	type = var->vtype;
	e = &extsymtab[var->vardesc.varno];
	if ((type1 = e->extype) && type == TYUNKNOWN)
		return var->vtype = type1;
	if (var->visused) {
		if (e->exused && type != type1)
			changedtype(var);
		e->exused = 1;
		e->extype = type;
		}
	return type;
	}

 static void
#ifdef KR_headers
ref_defs(outfile, refdefs)
	FILE *outfile;
	chainp refdefs;
#else
ref_defs(FILE *outfile, chainp refdefs)
#endif
{
	chainp cp;
	int eb, i, j, n;
	struct Dimblock *dimp;
	expptr b, vl;
	Namep var;
	char *amp, *comma;

	margin_printf(outfile, "\n");
	for(cp = refdefs = revchain(refdefs); cp; cp = cp->nextp) {
		var = (Namep)cp->datap;
		cp->datap = 0;
		amp = "_subscr";
		if (!(eb = var->vsubscrused)) {
			var->vrefused = 0;
			if (!ISCOMPLEX(var->vtype))
				amp = "_ref";
			}
		def_start(outfile, var->cvarname, amp, CNULL);
		dimp = var->vdim;
		vl = 0;
		comma = "(";
		amp = "";
		if (var->vtype == TYCHAR) {
			amp = "&";
			vl = var->vleng;
			if (ISCONST(vl) && vl->constblock.Const.ci == 1)
				vl = 0;
			nice_printf(outfile, "%sa_0", comma);
			comma = ",";
			}
		n = dimp->ndim;
		for(i = 1; i <= n; i++, comma = ",")
			nice_printf(outfile, "%sa_%d", comma, i);
		nice_printf(outfile, ") %s", amp);
		if (var->vsubscrused)
			var->vsubscrused = 0;
		else if (!ISCOMPLEX(var->vtype)) {
			out_name(outfile, var);
			nice_printf(outfile, "[%s", vl ? "(" : "");
			}
		for(j = 2; j < n; j++)
			nice_printf(outfile, "(");
		while(--i > 1) {
			nice_printf(outfile, "(a_%d)%s*", i, i == n ? "" : ")");
			expr_out(outfile, cpexpr(dimp->dims[i-2].dimsize));
			nice_printf(outfile, " + ");
			}
		nice_printf(outfile, "a_1");
		if (var->vtype == TYCHAR) {
			if (vl) {
				nice_printf(outfile, ")*");
				expr_out(outfile, cpexpr(vl));
				}
			nice_printf(outfile, " + a_0");
			}
		if ((var->vstg != STGARG /* || checksubs */ )
		 && (b = dimp->baseoffset)) {
			b = cpexpr(b);
			if (var->vtype == TYCHAR)
				b = mkexpr(OPSTAR, cpexpr(var->vleng), b);
			nice_printf(outfile, " - ");
			expr_out(outfile, b);
			}
		if (ISCOMPLEX(var->vtype)) {
			margin_printf(outfile, "\n");
			def_start(outfile, var->cvarname, "_ref", CNULL);
			comma = "(";
			for(i = 1; i <= n; i++, comma = ",")
				nice_printf(outfile, "%sa_%d", comma, i);
			nice_printf(outfile, ") %s[%s_subscr",
				var->cvarname, var->cvarname);
			comma = "(";
			for(i = 1; i <= n; i++, comma = ",")
				nice_printf(outfile, "%sa_%d", comma, i);
			nice_printf(outfile, ")");
			}
		margin_printf(outfile, "]\n" + eb);
		}
	nice_printf(outfile, "\n");
	frchain(&refdefs);
	}

 void
#ifdef KR_headers
list_decls(outfile)
	FILE *outfile;
#else
list_decls(FILE *outfile)
#endif
{
    extern chainp used_builtins;
    extern struct Hashentry *hashtab;
    struct Hashentry *entry;
    int write_header = 1;
    int last_class = -1, last_stg = -1;
    Namep var;
    int Alias, Define, did_one, last_type, type;
    extern int def_equivs, useauto;
    extern chainp new_vars;	/* Compiler-generated locals */
    chainp namelists = 0, refdefs = 0;
    char *ctype;
    int useauto1 = useauto && !saveall;
    long x;
    extern int hsize;

/* First write out the statically initialized data */

    if (initfile)
	list_init_data(&initfile, initfname, outfile);

/* Next come formats */
    write_formats(outfile);

/* Now write out the system-generated identifiers */

    if (new_vars || nequiv) {
	chainp args, next_var, this_var;
	chainp nv[TYVOID], nv1[TYVOID];
	int i, j;
	Addrp Var;
	Namep arg;

	/* zap unused dimension variables */

	for(args = allargs; args; args = args->nextp) {
		arg = (Namep)args->datap;
		if (this_var = arg->vlastdim) {
			frexpr((tagptr)this_var->datap);
			this_var->datap = 0;
			}
		}

	/* sort new_vars by type, skipping entries just zapped */

	for(i = TYADDR; i < TYVOID; i++)
		nv[i] = 0;
	for(this_var = new_vars; this_var; this_var = next_var) {
		next_var = this_var->nextp;
		if (Var = (Addrp)this_var->datap) {
			if (!(this_var->nextp = nv[j = Var->vtype]))
				nv1[j] = this_var;
			nv[j] = this_var;
			}
		else {
			this_var->nextp = 0;
			frchain(&this_var);
			}
		}
	new_vars = 0;
	for(i = TYVOID; --i >= TYADDR;)
		if (this_var = nv[i]) {
			nv1[i]->nextp = new_vars;
			new_vars = this_var;
			}

	/* write the declarations */

	did_one = 0;
	last_type = -1;

	for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
	    Var = (Addrp) this_var->datap;

	    if (Var == (Addrp) NULL)
		err ("list_decls:  null variable");
	    else if (Var -> tag != TADDR)
		erri ("list_decls:  bad tag on new variable '%d'",
			Var -> tag);

	    type = nv_type (Var);
	    if (Var->vstg == STGINIT
	    ||  Var->uname_tag == UNAM_IDENT
			&& *Var->user.ident == ' '
			&& multitype)
		continue;
	    if (!did_one)
		nice_printf (outfile, "/* System generated locals */\n");

	    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, "*");

	    write_nv_ident(outfile, (Addrp)this_var->datap);
	    if (Var -> vtype == TYCHAR && Var->vclass != CLPROC &&
		    ISICON((Var -> vleng))
			&& (i = Var->vleng->constblock.Const.ci) > 0)
		nice_printf (outfile, "[%d]", i);

	    did_one = 1;
	    last_type = nv_type (Var);
	} /* for this_var */

/* Handle the uninitialized equivalences */

	do_uninit_equivs (outfile, &did_one);

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

/* Write out builtin declarations */

    if (used_builtins) {
	chainp cp;
	Extsym *es;

	last_type = -1;
	did_one = 0;

	nice_printf (outfile, "/* Builtin functions */");

	for (cp = used_builtins; cp; cp = cp -> nextp) {
	    Addrp e = (Addrp)cp->datap;

	    switch(type = e->vtype) {
		case TYDREAL:
		case TYREAL:
			/* if (forcedouble || e->dbl_builtin) */
			/* libF77 currently assumes everything double */
			type = TYDREAL;
			ctype = "double";
			break;
		case TYCOMPLEX:
		case TYDCOMPLEX:
			type = TYVOID;
			/* no break */
		default:
			ctype = c_type_decl(type, 0);
		}

	    if (did_one && last_type == type)
		nice_printf(outfile, ", ");
	    else
		nice_printf(outfile, "%s\n%s ", did_one ? ";" : "", ctype);

	    extern_out(outfile, es = &extsymtab[e -> memno]);
	    proto(outfile, es->arginfo, es->fextname);
	    last_type = type;
	    did_one = 1;
	} /* for cp = used_builtins */

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

    last_type = -1;
    for (entry = hashtab; entry < lasthash; ++entry) {
	var = entry -> varp;

	if (var) {
	    int procclass = var -> vprocclass;
	    char *comment = NULL;
	    int stg = var -> vstg;
	    int class = var -> vclass;
	    type = var -> vtype;

	    if (var->vrefused)
		refdefs = mkchain((char *)var, refdefs);
	    if (var->vsubscrused)
		if (ISCOMPLEX(var->vtype))
			var->vsubscrused = 0;
		else
			refdefs = mkchain((char *)var, refdefs);
	    if (ONEOF(stg, M(STGARG)|M(STGLENG)|M(STGINIT)))
		continue;

	    if (useauto1 && stg == STGBSS && !var->vsave)
		stg = STGAUTO;

	    switch (class) {
	        case CLVAR:
		    break;
		case CLPROC:
		    switch(procclass) {
			case PTHISPROC:
				extsymtab[var->vardesc.varno].extype = type;
				continue;
			case PSTFUNCT:
			case PINTRINSIC:
				continue;
			case PUNKNOWN:
				err ("list_decls:  unknown procedure class");
				continue;
			case PEXTERNAL:
				if (stg == STGUNKNOWN) {
					warn1(
					"%.64s declared EXTERNAL but never used.",
						var->fvarname);
					/* to retain names declared EXTERNAL */
					/* but not referenced, change
					/* "continue" to "stg = STGEXT" */
					continue;
					}
				else
					type = fixexttype(var);
			}
		    break;
		case CLUNKNOWN:
			/* declared but never used */
			continue;
		case CLPARAM:
			continue;
		case CLNAMELIST:
			if (var->visused)
				namelists = mkchain((char *)var, namelists);
			continue;
		default:
		    erri("list_decls:  can't handle class '%d' yet",
			    class);
		    Fatal(var->fvarname);
		    continue;
	    } /* switch */

	    /* Might be equivalenced to a common.  If not, don't process */
	    if (stg == STGCOMMON && !var->vcommequiv)
		continue;

/* Only write the header if system-generated locals, builtins, or
   uninitialized equivs were already output */

	    if (write_header == 1 && (new_vars || nequiv || used_builtins)
		    && oneof_stg ( var, stg,
		    M(STGBSS)|M(STGEXT)|M(STGAUTO)|M(STGCOMMON)|M(STGEQUIV))) {
		nice_printf (outfile, "/* Local variables */\n");
		write_header = 2;
		}


	    Alias = oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON));
	    if (Define = (Alias && def_equivs)) {
		if (!write_header)
			nice_printf(outfile, ";\n");
		def_start(outfile, var->cvarname, CNULL, "(");
		goto Alias1;
		}
	    else if (type == last_type && class == last_class &&
		    stg == last_stg && !write_header)
		nice_printf (outfile, ", ");
	    else {
		if (!write_header && ONEOF(stg, M(STGBSS)|
		    M(STGEXT)|M(STGAUTO)|M(STGEQUIV)|M(STGCOMMON)))
		    nice_printf (outfile, ";\n");

		switch (stg) {
		    case STGARG:
		    case STGLENG:
			/* Part of the argument list, don't write them out
			   again */
			continue;	    /* Go back to top of the loop */
		    case STGBSS: