proc.c

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

/****************************************************************
Copyright 1990, 1994, 1995 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 "names.h"
#include "output.h"
#include "p1defs.h"

#define EXNULL (union Expression *)0

static void dobss Argdcl((void));
static void docomleng Argdcl((void));
static void docommon Argdcl((void));
static void doentry Argdcl((struct Entrypoint*));
static void epicode Argdcl((void));
static int nextarg Argdcl((int));
static void retval Argdcl((int));

static char Blank[] = BLANKCOMMON;

 static char *postfix[] = { "g", "h", "i",
#ifdef TYQUAD
					"j",
#endif
					"r", "d", "c", "z", "g", "h", "i" };

 chainp new_procs;
 int prev_proc, proc_argchanges, proc_protochanges;

 void
#ifdef KR_headers
changedtype(q)
	Namep q;
#else
changedtype(Namep q)
#endif
{
	char buf[200];
	int qtype, type1;
	register Extsym *e;
	Argtypes *at;

	if (q->vtypewarned)
		return;
	q->vtypewarned = 1;
	qtype = q->vtype;
	e = &extsymtab[q->vardesc.varno];
	if (!(at = e->arginfo)) {
		if (!e->exused)
			return;
		}
	else if (at->changes & 2 && qtype != TYUNKNOWN && !at->defined)
		proc_protochanges++;
	type1 = e->extype;
	if (type1 == TYUNKNOWN)
		return;
	if (qtype == TYUNKNOWN)
		/* e.g.,
			subroutine foo
			end
			external foo
			call goo(foo)
			end
		*/
		return;
	sprintf(buf, "%.90s: inconsistent declarations:\n\
	here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype],
		qtype == TYSUBR ? "" : " function",
		ftn_types[type1], type1 == TYSUBR ? "" : " function");
	warn(buf);
	}

 void
#ifdef KR_headers
unamstring(q, s)
	register Addrp q;
	register char *s;
#else
unamstring(register Addrp q, register char *s)
#endif
{
	register int k;
	register char *t;

	k = strlen(s);
	if (k < IDENT_LEN) {
		q->uname_tag = UNAM_IDENT;
		t = q->user.ident;
		}
	else {
		q->uname_tag = UNAM_CHARP;
		q->user.Charp = t = mem(k+1, 0);
		}
	strcpy(t, s);
	}

 static void
fix_entry_returns(Void)	/* for multiple entry points */
{
	Addrp a;
	int i;
	struct Entrypoint *e;
	Namep np;

	e = entries = (struct Entrypoint *)revchain((chainp)entries);
	allargs = revchain(allargs);
	if (!multitype)
		return;

	/* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */

	for(i = TYINT1; i <= TYLOGICAL; i++)
		if (a = xretslot[i])
			sprintf(a->user.ident, "(*ret_val).%s",
				postfix[i-TYINT1]);

	do {
		np = e->enamep;
		switch(np->vtype) {
			case TYINT1:
			case TYSHORT:
			case TYLONG:
#ifdef TYQUAD
			case TYQUAD:
#endif
			case TYREAL:
			case TYDREAL:
			case TYCOMPLEX:
			case TYDCOMPLEX:
			case TYLOGICAL1:
			case TYLOGICAL2:
			case TYLOGICAL:
				np->vstg = STGARG;
			}
		}
		while(e = e->entnextp);
	}

 static void
#ifdef KR_headers
putentries(outfile)
	FILE *outfile;
#else
putentries(FILE *outfile)
#endif
	/* put out wrappers for multiple entries */
{
	char base[IDENT_LEN];
	struct Entrypoint *e;
	Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
	chainp args, lengths;
	int i, k, mt, nL, t, type;
	extern char *dfltarg[], **dfltproc;

	e = entries;
	if (!e->enamep) /* only possible with erroneous input */
		return;
	nL = (nallargs + nallchargs) * sizeof(Namep *);
	A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **));
	Ae = A + nallargs;
	Alp = (Namep **)(Ae1 = Ae + nallchargs);
	i = k = 0;
	for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) {
		np = (Namep)args->datap;
		if (np->vtype == TYCHAR && np->vclass != CLPROC)
			*a1 = &Ae[i++];
		}

	mt = multitype;
	multitype = 0;
	sprintf(base, "%s0_", e->enamep->cvarname);
	do {
		np = e->enamep;
		lengths = length_comp(e, 0);
		proctype = type = np->vtype;
		if (protofile)
			protowrite(protofile, type, np->cvarname, e, lengths);
		nice_printf(outfile, "\n%s ", c_type_decl(type, 1));
		nice_printf(outfile, "%s", np->cvarname);
		if (!Ansi) {
			listargs(outfile, e, 0, lengths);
			nice_printf(outfile, "\n");
			}
	    	list_arg_types(outfile, e, lengths, 0, "\n");
		nice_printf(outfile, "{\n");
		frchain(&lengths);
		next_tab(outfile);
		if (mt)
			nice_printf(outfile,
				"Multitype ret_val;\n%s(%d, &ret_val",
				base, k); /*)*/
		else if (ISCOMPLEX(type))
			nice_printf(outfile, "%s(%d,%s", base, k,
				xretslot[type]->user.ident); /*)*/
		else if (type == TYCHAR)
			nice_printf(outfile,
				"%s(%d, ret_val, ret_val_len", base, k); /*)*/
		else
			nice_printf(outfile, "return %s(%d", base, k); /*)*/
		k++;
		memset((char *)A, 0, nL);
		for(args = e->arglist; args; args = args->nextp) {
			np = (Namep)args->datap;
			A[np->argno] = np;
			if (np->vtype == TYCHAR && np->vclass != CLPROC)
				*Alp[np->argno] = np;
			}
		args = allargs;
		for(a = A; a < Ae; a++, args = args->nextp) {
			t = ((Namep)args->datap)->vtype;
			nice_printf(outfile, ", %s", (np = *a)
				? np->cvarname
				: ((Namep)args->datap)->vclass == CLPROC
				? dfltproc[((Namep)args->datap)->vimpltype
					? (Castargs ? TYUNKNOWN : TYSUBR)
					: t == TYREAL && forcedouble && !Castargs
					? TYDREAL : t]
				: dfltarg[((Namep)args->datap)->vtype]);
			}
		for(; a < Ae1; a++)
			if (np = *a)
				nice_printf(outfile, ", %s_len", np->fvarname);
			else
				nice_printf(outfile, ", (ftnint)0");
		nice_printf(outfile, /*(*/ ");\n");
		if (mt) {
			if (type == TYCOMPLEX)
				nice_printf(outfile,
		    "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\n");
			else if (type == TYDCOMPLEX)
				nice_printf(outfile,
		    "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\n");
			else if (type <= TYLOGICAL)
				nice_printf(outfile, "return ret_val.%s;\n",
					postfix[type-TYINT1]);
			}
		nice_printf(outfile, "}\n");
		prev_tab(outfile);
		}
		while(e = e->entnextp);
	free((char *)A);
	}

 static void
#ifdef KR_headers
entry_goto(outfile)
	FILE *outfile;
#else
entry_goto(FILE *outfile)
#endif
{
	struct Entrypoint *e = entries;
	int k = 0;

	nice_printf(outfile, "switch(n__) {\n");
	next_tab(outfile);
	while(e = e->entnextp)
		nice_printf(outfile, "case %d: goto %s;\n", ++k,
			user_label((long)(extsymtab - e->entryname - 1)));
	nice_printf(outfile, "}\n\n");
	prev_tab(outfile);
	}

/* start a new procedure */

 void
newproc(Void)
{
	if(parstate != OUTSIDE)
	{
		execerr("missing end statement", CNULL);
		endproc();
	}

	parstate = INSIDE;
	procclass = CLMAIN;	/* default */
}

 static void
zap_changes(Void)
{
	register chainp cp;
	register Argtypes *at;

	/* arrange to get correct count of prototypes that would
	   change by running f2c again */

	if (prev_proc && proc_argchanges)
		proc_protochanges++;
	prev_proc = proc_argchanges = 0;
	for(cp = new_procs; cp; cp = cp->nextp)
		if (at = ((Namep)cp->datap)->arginfo)
			at->changes &= ~1;
	frchain(&new_procs);
	}

/* end of procedure. generate variables, epilogs, and prologs */

 void
endproc(Void)
{
	struct Labelblock *lp;
	Extsym *ext;

	if(parstate < INDATA)
		enddcl();
	if(ctlstack >= ctls)
		err("DO loop or BLOCK IF not closed");
	for(lp = labeltab ; lp < labtabend ; ++lp)
		if(lp->stateno!=0 && lp->labdefined==NO)
			errstr("missing statement label %s",
				convic(lp->stateno) );

/* Save copies of the common variables in extptr -> allextp */

	for (ext = extsymtab; ext < nextext; ext++)
		if (ext -> extstg == STGCOMMON && ext -> extp) {
			extern int usedefsforcommon;

/* Write out the abbreviations for common block reference */

			copy_data (ext -> extp);
			if (usedefsforcommon) {
				wr_abbrevs (c_file, 1, ext -> extp);
				ext -> used_here = 1;
				}
			else
				ext -> extp = CHNULL;

			}

	if (nentry > 1)
		fix_entry_returns();
	epicode();
	donmlist();
	dobss();
	start_formatting ();
	if (nentry > 1)
		putentries(c_file);

	zap_changes();
	procinit();	/* clean up for next procedure */
}



/* End of declaration section of procedure.  Allocate storage. */

 void
enddcl(Void)
{
	register struct Entrypoint *ep;
	struct Entrypoint *ep0;
	chainp cp;
	extern char *err_proc;
	static char comblks[] = "common blocks";

	err_proc = comblks;
	docommon();

/* Now the hash table entries for fields of common blocks have STGCOMMON,
   vdcldone, voffset, and varno.  And the common blocks themselves have
   their full sizes in extleng. */

	err_proc = "equivalences";
	doequiv();

	err_proc = comblks;
	docomleng();

/* This implies that entry points in the declarations are buffered in
   entries   but not written out */

	err_proc = "entries";
	if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
		/* entries could be 0 in case of an error */
		do doentry(ep);
			while(ep = ep->entnextp);
		entries = (struct Entrypoint *)revchain((chainp)ep0);
		}

	err_proc = 0;
	parstate = INEXEC;
	p1put(P1_PROCODE);
	freetemps();
	if (earlylabs) {
		for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
			p1_label((long)cp->datap);
		frchain(&earlylabs);
		}
	p1_line_number(lineno); /* for files that start with a MAIN program */
				/* that starts with an executable statement */
}

/* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */

/* Main program or Block data */

 void
#ifdef KR_headers
startproc(progname, class)
	Extsym *progname;
	int class;
#else
startproc(Extsym *progname, int class)
#endif
{
	register struct Entrypoint *p;

	p = ALLOC(Entrypoint);
	if(class == CLMAIN) {
		puthead(CNULL, CLMAIN);
		if (progname)
		    strcpy (main_alias, progname->cextname);
	} else
		puthead(CNULL, CLBLOCK);
	if(class == CLMAIN)
		newentry( mkname(" MAIN"), 0 )->extinit = 1;
	p->entryname = progname;
	entries = p;

	procclass = class;
	fprintf(diagfile, "   %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
	if(progname) {
		fprintf(diagfile, " %s", progname->fextname);
		procname = progname->cextname;
		}
	fprintf(diagfile, ":\n");
	fflush(diagfile);
}

/* subroutine or function statement */

 Extsym *
#ifdef KR_headers
newentry(v, substmsg)
	register Namep v;
	int substmsg;
#else
newentry(register Namep v, int substmsg)
#endif
{
	register Extsym *p;
	char buf[128], badname[64];
	static int nbad = 0;
	static char already[] = "external name already used";

	p = mkext(v->fvarname, addunder(v->cvarname));

	if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
	{
		sprintf(badname, "%s_bad%d", v->fvarname, ++nbad);
		if (substmsg) {
			sprintf(buf,"%s\n\tsubstituting \"%s\"",
				already, badname);
			dclerr(buf, v);
			}
		else
			dclerr(already, v);
		p = mkext(v->fvarname, badname);
	}
	v->vstg = STGAUTO;
	v->vprocclass = PTHISPROC;
	v->vclass = CLPROC;
	if (p->extstg == STGEXT)
		prev_proc = 1;
	else
		p->extstg = STGEXT;
	p->extinit = YES;
	v->vardesc.varno = p - extsymtab;
	return(p);
}

 void
#ifdef KR_headers
entrypt(class, type, length, entry, args)
	int class;
	int type;
	ftnint length;
	Extsym *entry;
	chainp args;
#else
entrypt(int class, int type, ftnint length, Extsym *entry, chainp args)
#endif
{
	register Namep q;
	register struct Entrypoint *p;

	if(class != CLENTRY)
		puthead( procname = entry->cextname, class);
	else
		fprintf(diagfile, "       entry ");
	fprintf(diagfile, "   %s:\n", entry->fextname);
	fflush(diagfile);
	q = mkname(entry->fextname);
	if (type == TYSUBR)
		q->vstg = STGEXT;

	type = lengtype(type, length);
	if(class == CLPROC)
	{
		procclass = CLPROC;
		proctype = type;
		procleng = type == TYCHAR ? length : 0;
	}

	p = ALLOC(Entrypoint);

	p->entnextp = entries;
	entries = p;

	p->entryname = entry;
	p->arglist = revchain(args);
	p->enamep = q;

	if(class == CLENTRY)
	{
		class = CLPROC;
		if(proctype == TYSUBR)
			type = TYSUBR;
	}

	q->vclass = class;
	q->vprocclass = 0;
	settype(q, type, length);
	q->vprocclass = PTHISPROC;
	/* hold all initial entry points till end of declarations */
	if(parstate >= INDATA)
		doentry(p);
}

/* generate epilogs */

/* epicode -- write out the proper function return mechanism at the end of
   the procedure declaration.  Handles multiple return value types, as
   well as cooercion into the proper value */

 LOCAL void
epicode(Void)
{
	extern int lastwasbranch;

	if(procclass==CLPROC)
	{
		if(proctype==TYSUBR)
		{

/* Return a zero only when the alternate return mechanism has been
   specified in the function header */

			if ((substars || Ansi) && lastwasbranch != YES)
			    p1_subr_ret (ICON(0));
		}
		else if (!multitype && lastwasbranch != YES)
			retval(proctype);
	}
	else if (procclass == CLMAIN && Ansi && lastwasbranch != YES)
		p1_subr_ret (ICON(0));
	lastwasbranch = NO;
}


/* generate code to return value of type  t */

 LOCAL void
#ifdef KR_headers
retval(t)
	register int t;
#else
retval(register int t)