format.c

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

		    case STGEQUIV:
		    case STGCOMMON:
			nice_printf (outfile, "static ");
			break;
		    case STGEXT:
			nice_printf (outfile, "extern ");
			break;
		    case STGAUTO:
			break;
		    case STGINIT:
		    case STGUNKNOWN:
			/* Don't want to touch the initialized data, that will
			   be handled elsewhere.  Unknown data have
			   already been complained about, so skip them */
			continue;
		    default:
			erri("list_decls:  can't handle storage class %d",
				stg);
			continue;
		} /* switch */

		if (type == TYCHAR && halign && class != CLPROC
		&& ISICON(var->vleng)) {
			nice_printf(outfile, "struct { %s fill; char val",
				halign);
			x = wr_char_len(outfile, var->vdim,
				var->vleng->constblock.Const.ci, 1);
			if (x %= hsize)
				nice_printf(outfile, "; char fill2[%ld]",
					hsize - x);
			nice_printf(outfile, "; } %s_st;\n", var->cvarname);
			def_start(outfile, var->cvarname, CNULL, var->cvarname);
			margin_printf(outfile, "_st.val\n");
			last_type = -1;
			write_header = 2;
			continue;
			}
		nice_printf(outfile, "%s ",
			c_type_decl(type, class == CLPROC));
	    } /* else */

/* Character type is really a string type.  Put out a '*' for variable
   length strings, and also for equivalences */

	    if (type == TYCHAR && class != CLPROC
		    && (!var->vleng || !ISICON (var -> vleng))
	    || oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON)))
		nice_printf (outfile, "*%s", var->cvarname);
	    else {
		nice_printf (outfile, "%s", var->cvarname);
		if (class == CLPROC) {
			Argtypes *at;
			if (!(at = var->arginfo)
			 && var->vprocclass == PEXTERNAL)
				at = extsymtab[var->vardesc.varno].arginfo;
			proto(outfile, at, var->fvarname);
			}
		else if (type == TYCHAR && ISICON ((var -> vleng)))
			wr_char_len(outfile, var->vdim,
				(int)var->vleng->constblock.Const.ci, 0);
		else if (var -> vdim &&
		    !oneof_stg (var, stg, M(STGEQUIV)|M(STGCOMMON)))
			comment = wr_ardecls(outfile, var->vdim, 1L);
		}

	    if (comment)
		nice_printf (outfile, "%s", comment);
 Alias1:
	    if (Alias) {
		char *amp, *lp, *name, *rp;
		ftnint voff = var -> voffset;
		int et0, expr_type, k;
		Extsym *E;
		struct Equivblock *eb;
		char buf[16];

/* We DON'T want to use oneof_stg here, because we need to distinguish
   between them */

		if (stg == STGEQUIV) {
			name = equiv_name(k = var->vardesc.varno, CNULL);
			eb = eqvclass + k;
			if (eb->eqvinit) {
				amp = "&";
				et0 = TYERROR;
				}
			else {
				amp = "";
				et0 = eb->eqvtype;
				}
			expr_type = et0;
		    }
		else {
			E = &extsymtab[var->vardesc.varno];
			sprintf(name = buf, "%s%d", E->cextname, E->curno);
			expr_type = type;
			et0 = -1;
			amp = "&";
		} /* else */

		if (!Define)
			nice_printf (outfile, " = ");
		if (voff) {
			k = typesize[type];
			switch((int)(voff % k)) {
				case 0:
					voff /= k;
					expr_type = type;
					break;
				case SZSHORT:
				case SZSHORT+SZLONG:
					expr_type = TYSHORT;
					voff /= SZSHORT;
					break;
				case SZLONG:
					expr_type = TYLONG;
					voff /= SZLONG;
					break;
				default:
					expr_type = TYCHAR;
				}
			}

		if (expr_type == type) {
			lp = rp = "";
			if (et0 == -1 && !voff)
				goto cast;
			}
		else {
			lp = "(";
			rp = ")";
 cast:
			nice_printf(outfile, "(%s *)", c_type_decl(type, 0));
			}

/* Now worry about computing the offset */

		if (voff) {
		    if (expr_type == et0)
			nice_printf (outfile, "%s%s + %ld%s",
				lp, name, voff, rp);
		    else
			nice_printf(outfile, "%s(%s *)%s%s + %ld%s", lp,
				c_type_decl (expr_type, 0), amp,
				name, voff, rp);
		} else
		    nice_printf(outfile, "%s%s", amp, name);
/* Always put these at the end of the line */
		last_type = last_class = last_stg = -1;
		write_header = 0;
		if (Define) {
			margin_printf(outfile, ")\n");
			write_header = 2;
			}
		continue;
		}
	    write_header = 0;
	    last_type = type;
	    last_class = class;
	    last_stg = stg;
	} /* if (var) */
    } /* for (entry = hashtab */

    if (!write_header)
	nice_printf (outfile, ";\n\n");
    else if (write_header == 2)
	nice_printf(outfile, "\n");

/* Next, namelists, which may reference equivs */

    if (namelists) {
	write_namelists(namelists = revchain(namelists), outfile);
	frchain(&namelists);
	}

/* Finally, ioblocks (which may reference equivs and namelists) */
    if (iob_list)
	write_ioblocks(outfile);
    if (assigned_fmts)
	write_assigned_fmts(outfile);

    if (refdefs)
	ref_defs(outfile, refdefs);

} /* list_decls */

 void
#ifdef KR_headers
do_uninit_equivs(outfile, did_one)
	FILE *outfile;
	int *did_one;
#else
do_uninit_equivs(FILE *outfile, int *did_one)
#endif
{
    extern int nequiv;
    struct Equivblock *eqv, *lasteqv = eqvclass + nequiv;
    int k, last_type = -1, t;

    for (eqv = eqvclass; eqv < lasteqv; eqv++)
	if (!eqv -> eqvinit && eqv -> eqvtop != eqv -> eqvbottom) {
	    if (!*did_one)
		nice_printf (outfile, "/* System generated locals */\n");
	    t = eqv->eqvtype;
	    if (last_type == t)
		nice_printf (outfile, ", ");
	    else {
		if (*did_one)
		    nice_printf (outfile, ";\n");
		nice_printf (outfile, "static %s ", c_type_decl(t, 0));
		k = typesize[t];
	    } /* else */
	    nice_printf(outfile, "%s", equiv_name((int)(eqv - eqvclass), CNULL));
	    nice_printf(outfile, "[%ld]",
		(eqv->eqvtop - eqv->eqvbottom + k - 1) / k);
	    last_type = t;
	    *did_one = 1;
	} /* if !eqv -> eqvinit */
} /* do_uninit_equivs */


/* wr_ardecls -- Writes the brackets and size for an array
   declaration.  Because of the inner workings of the compiler,
   multi-dimensional arrays get mapped directly into a one-dimensional
   array, so we have to compute the size of the array here.  When the
   dimension is greater than 1, a string comment about the original size
   is returned */

 char *
#ifdef KR_headers
wr_ardecls(outfile, dimp, size)
	FILE *outfile;
	struct Dimblock *dimp;
	long size;
#else
wr_ardecls(FILE *outfile, struct Dimblock *dimp, long size)
#endif
{
    int i, k;
    static char buf[1000];

    if (dimp == (struct Dimblock *) NULL)
	return NULL;

    sprintf(buf, "\t/* was ");	/* would like to say  k = sprintf(...), but */
    k = strlen(buf);		/* BSD doesn't return char transmitted count */

    for (i = 0; i < dimp -> ndim; i++) {
	expptr this_size = dimp -> dims[i].dimsize;

	if (!ISICON (this_size))
	    err ("wr_ardecls:  nonconstant array size");
	else {
	    size *= this_size -> constblock.Const.ci;
	    sprintf(buf+k, "[%ld]", this_size -> constblock.Const.ci);
	    k += strlen(buf+k);	/* BSD prevents combining this with prev stmt */
	} /* else */
    } /* for i = 0 */

    nice_printf (outfile, "[%ld]", size);
    strcat(buf+k, " */");

    return (i > 1) ? buf : NULL;
} /* wr_ardecls */



/* ----------------------------------------------------------------------

	The following routines read from the p1 intermediate file.  If
   that format changes, only these routines need be changed

   ---------------------------------------------------------------------- */

 static int
#ifdef KR_headers
get_p1_token(infile)
	FILE *infile;
#else
get_p1_token(FILE *infile)
#endif
{
    int token = P1_UNKNOWN;

/* NOT PORTABLE!! */

    if (fscanf (infile, "%d", &token) == EOF)
	return P1_EOF;

/* Skip over the ": " */

    if (getc (infile) != '\n')
	getc (infile);

    return token;
} /* get_p1_token */



/* Returns a (null terminated) string from the input file */

 static int
#ifdef KR_headers
p1gets(fp, str, size)
	FILE *fp;
	char *str;
	int size;
#else
p1gets(FILE *fp, char *str, int size)
#endif
{
    char c;

    if (str == NULL)
	return 0;

    if ((c = getc (fp)) != ' ')
	ungetc (c, fp);

    if (fgets (str, size, fp)) {
	int length;

	str[size - 1] = '\0';
	length = strlen (str);

/* Get rid of the newline */

	if (str[length - 1] == '\n')
	    str[length - 1] = '\0';
	return 1;

    } else if (feof (fp))
	return EOF;
    else
	return 0;
} /* p1gets */


 static int
#ifdef KR_headers
p1get_const(infile, type, resultp)
	FILE *infile;
	int type;
	struct Constblock **resultp;
#else
p1get_const(FILE *infile, int type, struct Constblock **resultp)
#endif
{
    int status;
    struct Constblock *result;

	if (type != TYCHAR) {
		*resultp = result = ALLOC(Constblock);
		result -> tag = TCONST;
		result -> vtype = type;
		}

    switch (type) {
	case TYINT1:
        case TYSHORT:
	case TYLONG:
	case TYLOGICAL:
#ifdef TYQUAD
	case TYQUAD:
#endif
	case TYLOGICAL1:
	case TYLOGICAL2:
	    status = p1getd (infile, &(result -> Const.ci));
	    break;
	case TYREAL:
	case TYDREAL:
	    status = p1getf(infile, &result->Const.cds[0]);
	    result->vstg = 1;
	    break;
	case TYCOMPLEX:
	case TYDCOMPLEX:
	    status = p1getf(infile, &result->Const.cds[0]);
	    if (status && status != EOF)
		status = p1getf(infile, &result->Const.cds[1]);
	    result->vstg = 1;
	    break;
	case TYCHAR:
	    status = fscanf(infile, "%lx", resultp);
	    break;
	default:
	    erri ("p1get_const:  bad constant type '%d'", type);
	    status = 0;
	    break;
    } /* switch */

    return status;
} /* p1get_const */

 static int
#ifdef KR_headers
p1getd(infile, result)
	FILE *infile;
	long *result;
#else
p1getd(FILE *infile, long *result)
#endif
{
    return fscanf (infile, "%ld", result);
} /* p1getd */

 static int
#ifdef KR_headers
p1getf(infile, result)
	FILE *infile;
	char **result;
#else
p1getf(FILE *infile, char **result)
#endif
{

	char buf[1324];
	register int k;

	k = fscanf (infile, "%s", buf);
	if (k < 1)
		k = EOF;
	else
		strcpy(*result = mem(strlen(buf)+1,0), buf);
	return k;
}

 static int
#ifdef KR_headers
p1getn(infile, count, result)
	FILE *infile;
	int count;
	char **result;
#else
p1getn(FILE *infile, int count, char **result)
#endif
{

    char *bufptr;

    bufptr = (char *) ckalloc (count);

    if (result)
	*result = bufptr;

    for (; !feof (infile) && count > 0; count--)
	*bufptr++ = getc (infile);

    return feof (infile) ? EOF : 1;
} /* p1getn */

 static void
#ifdef KR_headers
proto(outfile, at, fname)
	FILE *outfile;
	Argtypes *at;
	char *fname;
#else
proto(FILE *outfile,  Argtypes *at,  char *fname)
#endif
{
	int i, j, k, n;
	char *comma;
	Atype *atypes;
	Namep np;
	chainp cp;

	if (at) {
		/* Correct types that we learn on the fly, e.g.
			subroutine gotcha(foo)
			external foo
			call zap(...,foo,...)
			call foo(...)
		*/
		atypes = at->atypes;
		n = at->defined ? at->dnargs : at->nargs;
		for(i = 0; i++ < n; atypes++) {
			if (!(cp = atypes->cp))
				continue;
			j = atypes->type;
			do {
				np = (Namep)cp->datap;
				k = np->vtype;
				if (np->vclass == CLPROC) {
					if (!np->vimpltype && k)
						k += 200;
					else {
						if (j >= 300)
							j = TYUNKNOWN + 200;
						continue;
						}
					}
				if (j == k)
					continue;
				if (j >= 300
				||  j == 200 && k >= 200)
					j = k;
				else {
					if (at->nargs >= 0)
					   bad_atypes(at,fname,i,j,k,""," and");
					goto break2;
					}
				}
				while(cp = cp->nextp);
			atypes->type = j;
			frchain(&atypes->cp);
			}
		}
 break2:
	if (parens) {
		nice_printf(outfile, parens);
		return;
		}

	if (!at || (n = at-> defined ? at->dnargs : at->nargs) < 0) {
		nice_printf(outfile, Ansi == 1 ? "()" : "(...)");
		return;
		}

	if (n == 0) {
		nice_printf(outfile, Ansi == 1 ? "(void)" : "()");
		return;
		}

	atypes = at->atypes;
	nice_printf(outfile, "(");
	comma = "";
	for(; --n >= 0; atypes++) {
		k = atypes->type;
		if (k == TYADDR)
			nice_printf(outfile, "%schar **", comma);
		else if (k >= 200) {
			k -= 200;
			nice_printf(outfile, "%s%s", comma,
				usedcasts[k] = casttypes[k]);
			}
		else if (k >= 100)
			nice_printf(outfile,
					k == TYCHAR + 100 ? "%s%s *" : "%s%s",
					comma, c_type_decl(k-100, 0));
		else
			nice_printf(outfile, "%s%s *", comma,
					c_type_decl(k, 0));
		comma = ", ";
		}
	nice_printf(outfile, ")");
	}

 void
#ifdef KR_headers
protowrite(protofile, type, name, e, lengths)
	FILE *protofile;
	int type;
	char *name;
	struct Entrypoint *e;
	chainp lengths;
#else
protowrite(FILE *protofile, int type, char *name, struct Entrypoint *e, chainp lengths)
#endif
{
	extern char used_rets[];
	int asave;

	if (!(asave = Ansi))
		Castargs = Ansi = 1;
	nice_printf(protofile, "extern %s %s", protorettypes[type], name);
	list_arg_types(protofile, e, lengths, 0, ";\n");
	used_rets[type] = 1;
	if (!(Ansi = asave))
		Castargs = 0;
	}

 static void
#ifdef KR_headers
do_p1_1while(outfile)
	FILE *outfile;
#else
do_p1_1while(FILE *outfile)
#endif
{
	if (*wh_next) {
		nice_printf(outfile,
			"for(;;) { /* while(complicated condition) */\n" /*}*/ );
		next_tab(outfile);
		}
	else
		nice_printf(outfile, "while(" /*)*/ );
	}

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

	test = do_format(infile, outfile);
	if (*wh_next)
		nice_printf(outfile, "if (!(");
	expr_out(outfile, test);
	if (*wh_next++)
		nice_printf(outfile, "))\n\tbreak;\n");
	else {
		nice_printf(outfile, /*(*/ ") {\n");
		next_tab(outfile);
		}
	}

 static void
#ifdef KR_headers
do_p1_elseifstart(outfile)
	FILE *outfile;
#else
do_p1_elseifstart(FILE *outfile)
#endif
{
	if (*ei_next++) {
		prev_tab(outfile);
		nice_printf(outfile, /*{*/
			"} else /* if(complicated condition) */ {\n" /*}*/ );
		next_tab(outfile);
		}
	}