formatdata.c

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

/****************************************************************
Copyright 1990, 1991, 1993, 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.
****************************************************************/

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

#define MAX_INIT_LINE 100
#define NAME_MAX 64

static int memno2info Argdcl((int, Namep*));

 extern char *initbname;

 void
#ifdef KR_headers
list_init_data(Infile, Inname, outfile)
	FILE **Infile;
	char *Inname;
	FILE *outfile;
#else
list_init_data(FILE **Infile, char *Inname, FILE *outfile)
#endif
{
    FILE *sortfp;
    int status;

    fclose(*Infile);
    *Infile = 0;

    if (status = dsort(Inname, sortfname))
	fatali ("sort failed, status %d", status);

    scrub(Inname); /* optionally unlink Inname */

    if ((sortfp = fopen(sortfname, textread)) == NULL)
	Fatal("Couldn't open sorted initialization data");

    do_init_data(outfile, sortfp);
    fclose(sortfp);
    scrub(sortfname);

/* Insert a blank line after any initialized data */

	nice_printf (outfile, "\n");

    if (debugflag && infname)
	 /* don't back block data file up -- it won't be overwritten */
	backup(initfname, initbname);
} /* list_init_data */



/* do_init_data -- returns YES when at least one declaration has been
   written */

 int
#ifdef KR_headers
do_init_data(outfile, infile)
	FILE *outfile;
	FILE *infile;
#else
do_init_data(FILE *outfile, FILE *infile)
#endif
{
    char varname[NAME_MAX], ovarname[NAME_MAX];
    ftnint offset;
    ftnint type;
    int vargroup;	/* 0 --> init, 1 --> equiv, 2 --> common */
    int did_one = 0;		/* True when one has been output */
    chainp values = CHNULL;	/* Actual data values */
    int keepit = 0;
    Namep np;

    ovarname[0] = '\0';

    while (rdname (infile, &vargroup, varname) && rdlong (infile, &offset)
	    && rdlong (infile, &type)) {
	if (strcmp (varname, ovarname)) {

	/* If this is a new variable name, the old initialization has been
	   completed */

		wr_one_init(outfile, ovarname, &values, keepit);

		strcpy (ovarname, varname);
		values = CHNULL;
		if (vargroup == 0) {
			if (memno2info(atoi(varname+2), &np)) {
				if (((Addrp)np)->uname_tag != UNAM_NAME) {
					err("do_init_data: expected NAME");
					goto Keep;
					}
				np = ((Addrp)np)->user.name;
				}
			if (!(keepit = np->visused) && !np->vimpldovar)
				warn1("local variable %s never used",
					np->fvarname);
			}
		else {
 Keep:
			keepit = 1;
			}
		if (keepit && !did_one) {
			nice_printf (outfile, "/* Initialized data */\n\n");
			did_one = YES;
			}
	} /* if strcmp */

	values = mkchain((char *)data_value(infile, offset, (int)type), values);
    } /* while */

/* Write out the last declaration */

    wr_one_init (outfile, ovarname, &values, keepit);

    return did_one;
} /* do_init_data */


 ftnint
#ifdef KR_headers
wr_char_len(outfile, dimp, n, extra1)
	FILE *outfile;
	struct Dimblock *dimp;
	int n;
	int extra1;
#else
wr_char_len(FILE *outfile, struct Dimblock *dimp, int n, int extra1)
#endif
{
	int i, nd;
	expptr e;
	ftnint rv;

	if (!dimp) {
		nice_printf (outfile, extra1 ? "[%d+1]" : "[%d]", n);
		return n + extra1;
		}
	nice_printf(outfile, "[%d", n);
	nd = dimp->ndim;
	rv = n;
	for(i = 0; i < nd; i++) {
		e = dimp->dims[i].dimsize;
		if (!ISICON (e))
			err ("wr_char_len:  nonconstant array size");
		else {
			nice_printf(outfile, "*%ld", e->constblock.Const.ci);
			rv *= e->constblock.Const.ci;
			}
		}
	/* extra1 allows for stupid C compilers that complain about
	 * too many initializers in
	 *	char x[2] = "ab";
	 */
	nice_printf(outfile, extra1 ? "+1]" : "]");
	return extra1 ? rv+1 : rv;
	}

 static int ch_ar_dim = -1; /* length of each element of char string array */
 static int eqvmemno;	/* kludge */

 static void
#ifdef KR_headers
write_char_init(outfile, Values, namep)
	FILE *outfile;
	chainp *Values;
	Namep namep;
#else
write_char_init(FILE *outfile, chainp *Values, Namep namep)
#endif
{
	struct Equivblock *eqv;
	long size;
	struct Dimblock *dimp;
	int i, nd, type;
	expptr ds;

	if (!namep)
		return;
	if(nequiv >= maxequiv)
		many("equivalences", 'q', maxequiv);
	eqv = &eqvclass[nequiv];
	eqv->eqvbottom = 0;
	type = namep->vtype;
	size = type == TYCHAR
		? namep->vleng->constblock.Const.ci
		: typesize[type];
	if (dimp = namep->vdim)
		for(i = 0, nd = dimp->ndim; i < nd; i++) {
			ds = dimp->dims[i].dimsize;
			if (!ISICON(ds))
				err("write_char_values: nonconstant array size");
			else
				size *= ds->constblock.Const.ci;
			}
	*Values = revchain(*Values);
	eqv->eqvtop = size;
	eqvmemno = ++lastvarno;
	eqv->eqvtype = type;
	wr_equiv_init(outfile, nequiv, Values, 0);
	def_start(outfile, namep->cvarname, CNULL, "");
	if (type == TYCHAR)
		margin_printf(outfile, "((char *)&equiv_%d)\n\n", eqvmemno);
	else
		margin_printf(outfile, dimp
			? "((%s *)&equiv_%d)\n\n" : "(*(%s *)&equiv_%d)\n\n",
			c_type_decl(type,0), eqvmemno);
	}

/* wr_one_init -- outputs the initialization of the variable pointed to
   by   info.   When   is_addr   is true,   info   is an Addrp; otherwise,
   treat it as a Namep */

 void
#ifdef KR_headers
wr_one_init(outfile, varname, Values, keepit)
	FILE *outfile;
	char *varname;
	chainp *Values;
	int keepit;
#else
wr_one_init(FILE *outfile, char *varname, chainp *Values, int keepit)
#endif
{
    static int memno;
    static union {
	Namep name;
	Addrp addr;
    } info;
    Namep namep;
    int is_addr, size, type;
    ftnint last, loc;
    int is_scalar = 0;
    char *array_comment = NULL, *name;
    chainp cp, values;
    extern char datachar[];
    static int e1[3] = {1, 0, 1};
    ftnint x;
    extern int hsize;

    if (!keepit)
	goto done;
    if (varname == NULL || varname[1] != '.')
	goto badvar;

/* Get back to a meaningful representation; find the given   memno in one
   of the appropriate tables (user-generated variables in the hash table,
   system-generated variables in a separate list */

    memno = atoi(varname + 2);
    switch(varname[0]) {
	case 'q':
		/* Must subtract eqvstart when the source file
		 * contains more than one procedure.
		 */
		wr_equiv_init(outfile, eqvmemno = memno - eqvstart, Values, 0);
		goto done;
	case 'Q':
		/* COMMON initialization (BLOCK DATA) */
		wr_equiv_init(outfile, memno, Values, 1);
		goto done;
	case 'v':
		break;
	default:
 badvar:
		errstr("wr_one_init:  unknown variable name '%s'", varname);
		goto done;
	}

    is_addr = memno2info (memno, &info.name);
    if (info.name == (Namep) NULL) {
	err ("wr_one_init -- unknown variable");
	return;
	}
    if (is_addr) {
	if (info.addr -> uname_tag != UNAM_NAME) {
	    erri ("wr_one_init -- couldn't get name pointer; tag is %d",
		    info.addr -> uname_tag);
	    namep = (Namep) NULL;
	    nice_printf (outfile, " /* bad init data */");
	} else
	    namep = info.addr -> user.name;
    } else
	namep = info.name;

	/* check for character initialization */

    *Values = values = revchain(*Values);
    type = info.name->vtype;
    if (type == TYCHAR) {
	for(last = 0; values; values = values->nextp) {
		cp = (chainp)values->datap;
		loc = (ftnint)cp->datap;
		if (loc > last) {
			write_char_init(outfile, Values, namep);
			goto done;
			}
		last = (int)cp->nextp->datap == TYBLANK
			? loc + (int)cp->nextp->nextp->datap
			: loc + 1;
		}
	if (halign && info.name->tag == TNAME) {
		nice_printf(outfile, "static struct { %s fill; char val",
			halign);
		x = wr_char_len(outfile, namep->vdim, ch_ar_dim =
			info.name -> vleng -> constblock.Const.ci, 1);
		if (x %= hsize)
			nice_printf(outfile, "; char fill2[%ld]", hsize - x);
		name = info.name->cvarname;
		nice_printf(outfile, "; } %s_st = { 0,", name);
		wr_output_values(outfile, namep, *Values);
		nice_printf(outfile, " };\n");
		ch_ar_dim = -1;
		def_start(outfile, name, CNULL, name);
		margin_printf(outfile, "_st.val\n");
		goto done;
		}
	}
    else {
	size = typesize[type];
	loc = 0;
	for(; values; values = values->nextp) {
		if ((int)((chainp)values->datap)->nextp->datap == TYCHAR) {
			write_char_init(outfile, Values, namep);
			goto done;
			}
		last = ((long) ((chainp) values->datap)->datap) / size;
		if (last - loc > 4) {
			write_char_init(outfile, Values, namep);
			goto done;
			}
		loc = last;
		}
	}
    values = *Values;

    nice_printf (outfile, "static %s ", c_type_decl (type, 0));

    if (is_addr)
	write_nv_ident (outfile, info.addr);
    else
	out_name (outfile, info.name);

    if (namep)
	is_scalar = namep -> vdim == (struct Dimblock *) NULL;

    if (namep && !is_scalar)
	array_comment = type == TYCHAR
		? 0 : wr_ardecls(outfile, namep->vdim, 1L);

    if (type == TYCHAR)
	if (ISICON (info.name -> vleng))

/* We'll make single strings one character longer, so that we can use the
   standard C initialization.  All this does is pad an extra zero onto the
   end of the string */
		wr_char_len(outfile, namep->vdim, ch_ar_dim =
			info.name -> vleng -> constblock.Const.ci, e1[Ansi]);
	else
		err ("variable length character initialization");

    if (array_comment)
	nice_printf (outfile, "%s", array_comment);

    nice_printf (outfile, " = ");
    wr_output_values (outfile, namep, values);
    ch_ar_dim = -1;
    nice_printf (outfile, ";\n");
 done:
    frchain(Values);
} /* wr_one_init */




 chainp
#ifdef KR_headers
data_value(infile, offset, type)
	FILE *infile;
	ftnint offset;
	int type;
#else
data_value(FILE *infile, ftnint offset, int type)
#endif
{
    char line[MAX_INIT_LINE + 1], *pointer;
    chainp vals, prev_val;
    char *newval;

    if (fgets (line, MAX_INIT_LINE, infile) == NULL) {
	err ("data_value:  error reading from intermediate file");
	return CHNULL;
    } /* if fgets */

/* Get rid of the trailing newline */

    if (line[0])
	line[strlen (line) - 1] = '\0';

#define iswhite(x) (isspace (x) || (x) == ',')

    pointer = line;
    prev_val = vals = CHNULL;

    while (*pointer) {
	register char *end_ptr, old_val;

/* Move   pointer   to the start of the next word */

	while (*pointer && iswhite (*pointer))
	    pointer++;
	if (*pointer == '\0')
	    break;

/* Move   end_ptr   to the end of the current word */

	for (end_ptr = pointer + 1; *end_ptr && !iswhite (*end_ptr);
		end_ptr++)
	    ;

	old_val = *end_ptr;
	*end_ptr = '\0';

/* Add this value to the end of the list */

	if (ONEOF(type, MSKREAL|MSKCOMPLEX))
		newval = cpstring(pointer);
	else
		newval = (char *)atol(pointer);
	if (vals) {
	    prev_val->nextp = mkchain(newval, CHNULL);
	    prev_val = prev_val -> nextp;
	} else
	    prev_val = vals = mkchain(newval, CHNULL);
	*end_ptr = old_val;
	pointer = end_ptr;
    } /* while *pointer */

    return mkchain((char *)offset, mkchain((char *)LONG_CAST type, vals));
} /* data_value */

 static void
overlapping(Void)
{
	extern char *filename0;
	static int warned = 0;

	if (warned)
		return;
	warned = 1;

	fprintf(stderr, "Error");
	if (filename0)
		fprintf(stderr, " in file %s", filename0);
	fprintf(stderr, ": overlapping initializations\n");
	nerr++;
	}

 static void make_one_const Argdcl((int, union Constant*, chainp));
 static long charlen;

 void
#ifdef KR_headers
wr_output_values(outfile, namep, values)
	FILE *outfile;
	Namep namep;
	chainp values;
#else
wr_output_values(FILE *outfile, Namep namep, chainp values)
#endif
{
	int type = TYUNKNOWN;
	struct Constblock Const;
	static expptr Vlen;

	if (namep)
		type = namep -> vtype;

/* Handle array initializations away from scalars */

	if (namep && namep -> vdim)
		wr_array_init (outfile, namep -> vtype, values);

	else if (values->nextp && type != TYCHAR)
		overlapping();

	else {
		make_one_const(type, &Const.Const, values);
		Const.vtype = type;
		Const.vstg = ONEOF(type, MSKREAL|MSKCOMPLEX) != 0;
		if (type== TYCHAR) {
			if (!Vlen)
				Vlen = ICON(0);
			Const.vleng = Vlen;
			Vlen->constblock.Const.ci = charlen;
			out_const (outfile, &Const);
			free (Const.Const.ccp);
			}
		else
			out_const (outfile, &Const);
		}
	}


 void
#ifdef KR_headers
wr_array_init(outfile, type, values)
	FILE *outfile;
	int type;
	chainp values;
#else
wr_array_init(FILE *outfile, int type, chainp values)
#endif
{
    int size = typesize[type];
    long index, main_index = 0;
    int k;

    if (type == TYCHAR) {
	nice_printf(outfile, "\"");
	k = 0;
	if (Ansi != 1)
		ch_ar_dim = -1;
	}
    else
	nice_printf (outfile, "{ ");
    while (values) {
	struct Constblock Const;

	index = ((long) ((chainp) values->datap)->datap) / size;
	while (index > main_index) {

/* Fill with zeros.  The structure shorthand works because the compiler
   will expand the "0" in braces to fill the size of the entire structure
   */

	    switch (type) {
	        case TYREAL:
		case TYDREAL:
		    nice_printf (outfile, "0.0,");
		    break;
		case TYCOMPLEX:
		case TYDCOMPLEX:
		    nice_printf (outfile, "{0},");
		    break;
		case TYCHAR:
			nice_printf(outfile, " ");
			break;
		default:
		    nice_printf (outfile, "0,");
		    break;
	    } /* switch */
	    main_index++;
	} /* while index > main_index */