formatdata.c

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

	if (index < main_index)
		overlapping();
	else switch (type) {
	    case TYCHAR:
		{ int this_char;

		if (k == ch_ar_dim) {
			nice_printf(outfile, "\" \"");
			k = 0;
			}
		this_char = (int) ((chainp) values->datap)->
				nextp->nextp->datap;
		if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
			main_index += this_char;
			k += this_char;
			while(--this_char >= 0)
				nice_printf(outfile, " ");
			values = values -> nextp;
			continue;
			}
		nice_printf(outfile, str_fmt[this_char], this_char);
		k++;
		} /* case TYCHAR */
	        break;

	    case TYINT1:
	    case TYSHORT:
	    case TYLONG:
#ifdef TYQUAD
	    case TYQUAD:
#endif
	    case TYREAL:
	    case TYDREAL:
	    case TYLOGICAL:
	    case TYLOGICAL1:
	    case TYLOGICAL2:
	    case TYCOMPLEX:
	    case TYDCOMPLEX:
		make_one_const(type, &Const.Const, values);
		Const.vtype = type;
		Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0;
		out_const(outfile, &Const);
	        break;
	    default:
	        erri("wr_array_init: bad type '%d'", type);
	        break;
	} /* switch */
	values = values->nextp;

	main_index++;
	if (values && type != TYCHAR)
	    nice_printf (outfile, ",");
    } /* while values */

    if (type == TYCHAR) {
	nice_printf(outfile, "\"");
	}
    else
	nice_printf (outfile, " }");
} /* wr_array_init */


 static void
#ifdef KR_headers
make_one_const(type, storage, values)
	int type;
	union Constant *storage;
	chainp values;
#else
make_one_const(int type, union Constant *storage, chainp values)
#endif
{
    union Constant *Const;
    register char **L;

    if (type == TYCHAR) {
	char *str, *str_ptr;
	chainp v, prev;
	int b = 0, k, main_index = 0;

/* Find the max length of init string, by finding the highest offset
   value stored in the list of initial values */

	for(k = 1, prev = CHNULL, v = values; v; prev = v, v = v->nextp)
	    ;
	if (prev != CHNULL)
	    k = ((int) (((chainp) prev->datap)->datap)) + 2;
		/* + 2 above for null char at end */
	str = Alloc (k);
	for (str_ptr = str; values; str_ptr++) {
	    int index = (int) (((chainp) values->datap)->datap);

	    if (index < main_index)
		overlapping();
	    while (index > main_index++)
		*str_ptr++ = ' ';

		k = (int) (((chainp) values->datap)->nextp->nextp->datap);
		if ((int)((chainp)values->datap)->nextp->datap == TYBLANK) {
			b = k;
			break;
			}
		*str_ptr = k;
		values = values -> nextp;
	} /* for str_ptr */
	*str_ptr = '\0';
	Const = storage;
	Const -> ccp = str;
	Const -> ccp1.blanks = b;
	charlen = str_ptr - str;
    } else {
	int i = 0;
	chainp vals;

	vals = ((chainp)values->datap)->nextp->nextp;
	if (vals) {
		L = (char **)storage;
		do L[i++] = vals->datap;
			while(vals = vals->nextp);
		}

    } /* else */

} /* make_one_const */


 int
#ifdef KR_headers
rdname(infile, vargroupp, name)
	FILE *infile;
	int *vargroupp;
	char *name;
#else
rdname(FILE *infile, int *vargroupp, char *name)
#endif
{
    register int i, c;

    c = getc (infile);

    if (feof (infile))
	return NO;

    *vargroupp = c - '0';
    for (i = 1;; i++) {
	if (i >= NAME_MAX)
		Fatal("rdname: oversize name");
	c = getc (infile);
	if (feof (infile))
	    return NO;
	if (c == '\t')
		break;
	*name++ = c;
    }
    *name = 0;
    return YES;
} /* rdname */

 int
#ifdef KR_headers
rdlong(infile, n)
	FILE *infile;
	ftnint *n;
#else
rdlong(FILE *infile, ftnint *n)
#endif
{
    register int c;

    for (c = getc (infile); !feof (infile) && isspace (c); c = getc (infile))
	;

    if (feof (infile))
	return NO;

    for (*n = 0; isdigit (c); c = getc (infile))
	*n = 10 * (*n) + c - '0';
    return YES;
} /* rdlong */


 static int
#ifdef KR_headers
memno2info(memno, info)
	int memno;
	Namep *info;
#else
memno2info(int memno, Namep *info)
#endif
{
    chainp this_var;
    extern chainp new_vars;
    extern struct Hashentry *hashtab, *lasthash;
    struct Hashentry *entry;

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

	if (var == (Addrp) NULL)
	    Fatal("memno2info:  null variable");
	else if (var -> tag != TADDR)
	    Fatal("memno2info:  bad tag");
	if (memno == var -> memno) {
	    *info = (Namep) var;
	    return 1;
	} /* if memno == var -> memno */
    } /* for this_var = new_vars */

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

	if (var && var -> vardesc.varno == memno && var -> vstg == STGINIT) {
	    *info = (Namep) var;
	    return 0;
	} /* if entry -> vardesc.varno == memno */
    } /* for entry = hashtab */

    Fatal("memno2info:  couldn't find memno");
    return 0;
} /* memno2info */

 static chainp
#ifdef KR_headers
do_string(outfile, v, nloc)
	FILE *outfile;
	register chainp v;
	ftnint *nloc;
#else
do_string(FILE *outfile, register chainp v, ftnint *nloc)
#endif
{
	register chainp cp, v0;
	ftnint dloc, k, loc;
	unsigned long uk;
	char buf[8], *comma;

	nice_printf(outfile, "{");
	cp = (chainp)v->datap;
	loc = (ftnint)cp->datap;
	comma = "";
	for(v0 = v;;) {
		switch((int)cp->nextp->datap) {
			case TYBLANK:
				k = (ftnint)cp->nextp->nextp->datap;
				loc += k;
				while(--k >= 0) {
					nice_printf(outfile, "%s' '", comma);
					comma = ", ";
					}
				break;
			case TYCHAR:
				uk = (ftnint)cp->nextp->nextp->datap;
				sprintf(buf, chr_fmt[uk], uk);
				nice_printf(outfile, "%s'%s'", comma, buf);
				comma = ", ";
				loc++;
				break;
			default:
				goto done;
			}
		v0 = v;
		if (!(v = v->nextp))
			break;
		cp = (chainp)v->datap;
		dloc = (ftnint)cp->datap;
		if (loc != dloc)
			break;
		}
 done:
	nice_printf(outfile, "}");
	*nloc = loc;
	return v0;
	}

 static chainp
#ifdef KR_headers
Ado_string(outfile, v, nloc)
	FILE *outfile;
	register chainp v;
	ftnint *nloc;
#else
Ado_string(FILE *outfile, register chainp v, ftnint *nloc)
#endif
{
	register chainp cp, v0;
	ftnint dloc, k, loc;

	nice_printf(outfile, "\"");
	cp = (chainp)v->datap;
	loc = (ftnint)cp->datap;
	for(v0 = v;;) {
		switch((int)cp->nextp->datap) {
			case TYBLANK:
				k = (ftnint)cp->nextp->nextp->datap;
				loc += k;
				while(--k >= 0)
					nice_printf(outfile, " ");
				break;
			case TYCHAR:
				k = (ftnint)cp->nextp->nextp->datap;
				nice_printf(outfile, str_fmt[k], k);
				loc++;
				break;
			default:
				goto done;
			}
		v0 = v;
		if (!(v = v->nextp))
			break;
		cp = (chainp)v->datap;
		dloc = (ftnint)cp->datap;
		if (loc != dloc)
			break;
		}
 done:
	nice_printf(outfile, "\"");
	*nloc = loc;
	return v0;
	}

 static char *
#ifdef KR_headers
Len(L, type)
	long L;
	int type;
#else
Len(long L, int type)
#endif
{
	static char buf[24];
	if (L == 1 && type != TYCHAR)
		return "";
	sprintf(buf, "[%ld]", L);
	return buf;
	}

 void
#ifdef KR_headers
wr_equiv_init(outfile, memno, Values, iscomm)
	FILE *outfile;
	int memno;
	chainp *Values;
	int iscomm;
#else
wr_equiv_init(FILE *outfile, int memno, chainp *Values, int iscomm)
#endif
{
	struct Equivblock *eqv;
	int btype, curtype, dtype, filltype, filltype1, j, k, wasblank, xtype;
	static char Blank[] = "";
	register char *comma = Blank;
	register chainp cp, v;
	chainp sentinel, values, v1, vlast;
	ftnint L, L1, dL, dloc, loc, loc0;
	union Constant Const;
	char imag_buf[50], real_buf[50];
	int szshort = typesize[TYSHORT];
	static char typepref[] = {0, 0, TYINT1, TYSHORT, TYLONG,
#ifdef TYQUAD
				  TYQUAD,
#endif
				  TYREAL, TYDREAL, TYREAL, TYDREAL,
				  TYLOGICAL1, TYLOGICAL2,
				  TYLOGICAL, TYCHAR};
	static char basetype[] = {0, 0, TYCHAR, TYSHORT, TYLONG,
#ifdef TYQUAD
				  TYDREAL,
#endif
				  TYLONG, TYDREAL, TYLONG, TYDREAL,
				  TYCHAR, TYSHORT,
				  TYLONG, TYCHAR};
	extern int htype;
	char *z;

	/* add sentinel */
	if (iscomm) {
		L = extsymtab[memno].maxleng;
		xtype = extsymtab[memno].extype;
		}
	else {
		eqv = &eqvclass[memno];
		L = eqv->eqvtop - eqv->eqvbottom;
		xtype = eqv->eqvtype;
		}

	if (halign && typealign[typepref[xtype]] < typealign[htype])
		xtype = htype;
	*Values = values = revchain(vlast = *Values);

	if (xtype != TYCHAR) {

		/* unless the data include a value of the appropriate
		 * type, we add an extra element in an attempt
		 * to force correct alignment */

		btype = basetype[xtype];
		loc = 0;
		for(v = *Values;;v = v->nextp) {
			if (!v) {
				dtype = typepref[xtype];
				z = ISREAL(dtype) ? cpstring("0.") : (char *)0;
				k = typesize[dtype];
				if (j = L % k)
					L += k - j;
				v = mkchain((char *)L,
					mkchain((char *)LONG_CAST dtype,
						mkchain(z, CHNULL)));
				vlast = vlast->nextp =
					mkchain((char *)v, CHNULL);
				L += k;
				break;
				}
			cp = (chainp)v->datap;
			if (basetype[(int)cp->nextp->datap] == btype)
				break;
			dloc = (ftnint)cp->datap;
			L1 = dloc - loc;
			if (L1 > 0
			 && !(L1 % szshort)
			 && !(loc % szshort)
			 && btype <= type_choice[L1/szshort % 4]
			 && btype <= type_choice[loc/szshort % 4])
				break;
			dtype = (int)cp->nextp->datap;
			loc = dloc + dtype == TYBLANK
					? (ftnint)cp->nextp->nextp->datap
					: typesize[dtype];
			}
		}
	sentinel = mkchain((char *)L, mkchain((char *)TYERROR,CHNULL));
	vlast->nextp = mkchain((char *)sentinel, CHNULL);

	/* use doublereal fillers only if there are doublereal values */

	k = TYLONG;
	for(v = values; v; v = v->nextp)
		if (ONEOF((int)((chainp)v->datap)->nextp->datap,
				M(TYDREAL)|M(TYDCOMPLEX))) {
			k = TYDREAL;
			break;
			}
	type_choice[0] = k;

	nice_printf(outfile, "%sstruct {\n", iscomm ? "" : "static ");
	next_tab(outfile);
	loc = loc0 = k = 0;
	curtype = -1;
	for(v = values; v; v = v->nextp) {
		cp = (chainp)v->datap;
		dloc = (ftnint)cp->datap;
		L = dloc - loc;
		if (L < 0) {
			overlapping();
			if ((int)cp->nextp->datap != TYERROR) {
				v1 = cp;
				frchain(&v1);
				v->datap = 0;
				}
			continue;
			}
		dtype = (int)cp->nextp->datap;
		if (dtype == TYBLANK) {
			dtype = TYCHAR;
			wasblank = 1;
			}
		else
			wasblank = 0;
		if (curtype != dtype || L > 0) {
			if (curtype != -1) {
				L1 = (loc - loc0)/dL;
				nice_printf(outfile, "%s e_%d%s;\n",
					typename[curtype], ++k,
					Len(L1,curtype));
				}
			curtype = dtype;
			loc0 = dloc;
			}
		if (L > 0) {
			if (xtype == TYCHAR)
				filltype = TYCHAR;
			else {
				filltype = L % szshort ? TYCHAR
						: type_choice[L/szshort % 4];
				filltype1 = loc % szshort ? TYCHAR
						: type_choice[loc/szshort % 4];
				if (typesize[filltype] > typesize[filltype1])
					filltype = filltype1;
				}
			L1 = L / typesize[filltype];
			nice_printf(outfile, "%s fill_%d[%ld];\n",
				typename[filltype], ++k, L1);
			loc = dloc;
			}
		if (wasblank) {
			loc += (ftnint)cp->nextp->nextp->datap;
			dL = 1;
			}
		else {
			dL = typesize[dtype];
			loc += dL;
			}
		}
	nice_printf(outfile, "} %s = { ", iscomm
		? extsymtab[memno].cextname
		: equiv_name(eqvmemno, CNULL));
	loc = 0;
	for(v = values; ; v = v->nextp) {
		cp = (chainp)v->datap;
		if (!cp)
			continue;
		dtype = (int)cp->nextp->datap;
		if (dtype == TYERROR)
			break;
		dloc = (ftnint)cp->datap;
		if (dloc > loc) {
			nice_printf(outfile, "%s{0}", comma);
			comma = ", ";
			loc = dloc;
			}
		if (comma != Blank)
			nice_printf(outfile, ", ");
		comma = ", ";
		if (dtype == TYCHAR || dtype == TYBLANK) {
			v =  Ansi == 1  ? Ado_string(outfile, v, &loc)
					:  do_string(outfile, v, &loc);
			continue;
			}
		make_one_const(dtype, &Const, v);
		switch(dtype) {
			case TYLOGICAL:
			case TYLOGICAL2:
			case TYLOGICAL1:
				if (Const.ci < 0 || Const.ci > 1)
					errl(
			  "wr_equiv_init: unexpected logical value %ld",
						Const.ci);
				nice_printf(outfile,
					Const.ci ? "TRUE_" : "FALSE_");
				break;
			case TYINT1:
			case TYSHORT:
			case TYLONG:
#ifdef TYQUAD
			case TYQUAD:
#endif
				nice_printf(outfile, "%ld", Const.ci);
				break;
			case TYREAL:
				nice_printf(outfile, "%s",
					flconst(real_buf, Const.cds[0]));
				break;
			case TYDREAL:
				nice_printf(outfile, "%s", Const.cds[0]);
				break;
			case TYCOMPLEX:
				nice_printf(outfile, "%s, %s",
					flconst(real_buf, Const.cds[0]),
					flconst(imag_buf, Const.cds[1]));
				break;
			case TYDCOMPLEX:
				nice_printf(outfile, "%s, %s",
					Const.cds[0], Const.cds[1]);
				break;
			default:
				erri("unexpected type %d in wr_equiv_init",
					dtype);
			}
		loc += typesize[dtype];
		}
	nice_printf(outfile, " };\n\n");
	prev_tab(outfile);
	frchain(&sentinel);
	}