proc.c

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

#endif
{
	register Addrp p;

	switch(t)
	{
	case TYCHAR:
	case TYCOMPLEX:
	case TYDCOMPLEX:
		break;

	case TYLOGICAL:
		t = tylogical;
	case TYINT1:
	case TYADDR:
	case TYSHORT:
	case TYLONG:
#ifdef TYQUAD
	case TYQUAD:
#endif
	case TYREAL:
	case TYDREAL:
	case TYLOGICAL1:
	case TYLOGICAL2:
		p = (Addrp) cpexpr((expptr)retslot);
		p->vtype = t;
		p1_subr_ret (mkconv (t, fixtype((expptr)p)));
		break;

	default:
		badtype("retval", t);
	}
}


/* Do parameter adjustments */

 void
#ifdef KR_headers
procode(outfile)
	FILE *outfile;
#else
procode(FILE *outfile)
#endif
{
	prolog(outfile, allargs);

	if (nentry > 1)
		entry_goto(outfile);
	}

/* Finish bound computations now that all variables are declared.
 * This used to be in setbound(), but under -u the following incurred
 * an erroneous error message:
 *	subroutine foo(x,n)
 *	real x(n)
 *	integer n
 */

 static void
#ifdef KR_headers
dim_finish(v)
	Namep v;
#else
dim_finish(Namep v)
#endif
{
	register struct Dimblock *p;
	register expptr q;
	register int i, nd;

	p = v->vdim;
	v->vdimfinish = 0;
	nd = p->ndim;
	doin_setbound = 1;
	for(i = 0; i < nd; i++)
		if (q = p->dims[i].dimexpr) {
			q = p->dims[i].dimexpr = make_int_expr(putx(fixtype(q)));
			if (!ONEOF(q->headblock.vtype, MSKINT|MSKREAL))
				errstr("bad dimension type for %.70s",
					v->fvarname);
			}
	if (q = p->basexpr)
		p->basexpr = make_int_expr(putx(fixtype(q)));
	doin_setbound = 0;
	}

 static void
#ifdef KR_headers
duparg(q)
	Namep q;
#else
duparg(Namep q)
#endif
{ errstr("duplicate argument %.80s", q->fvarname); }

/*
   manipulate argument lists (allocate argument slot positions)
 * keep track of return types and labels
 */

 LOCAL void
#ifdef KR_headers
doentry(ep)
	struct Entrypoint *ep;
#else
doentry(struct Entrypoint *ep)
#endif
{
	register int type;
	register Namep np;
	chainp p, p1;
	register Namep q;
	Addrp rs;
	int it, k;
	extern char dflttype[26];
	Extsym *entryname = ep->entryname;

	if (++nentry > 1)
		p1_label((long)(extsymtab - entryname - 1));

/* The main program isn't allowed to have parameters, so any given
   parameters are ignored */

	if(procclass == CLMAIN || procclass == CLBLOCK)
		return;

/* So now we're working with something other than CLMAIN or CLBLOCK.
   Determine the type of its return value. */

	impldcl( np = mkname(entryname->fextname) );
	type = np->vtype;
	proc_argchanges = prev_proc && type != entryname->extype;
	entryname->extseen = 1;
	if(proctype == TYUNKNOWN)
		if( (proctype = type) == TYCHAR)
			procleng = np->vleng ? np->vleng->constblock.Const.ci
					     : (ftnint) (-1);

	if(proctype == TYCHAR)
	{
		if(type != TYCHAR)
			err("noncharacter entry of character function");

/* Functions returning type   char   can only have multiple entries if all
   entries return the same length */

		else if( (np->vleng ? np->vleng->constblock.Const.ci :
		    (ftnint) (-1)) != procleng)
			err("mismatched character entry lengths");
	}
	else if(type == TYCHAR)
		err("character entry of noncharacter function");
	else if(type != proctype)
		multitype = YES;
	if(rtvlabel[type] == 0)
		rtvlabel[type] = newlabel();
	ep->typelabel = rtvlabel[type];

	if(type == TYCHAR)
	{
		if(chslot < 0)
		{
			chslot = nextarg(TYADDR);
			chlgslot = nextarg(TYLENG);
		}
		np->vstg = STGARG;

/* Put a new argument in the function, one which will hold the result of
   a character function.  This will have to be named sometime, probably in
   mkarg(). */

		if(procleng < 0) {
			np->vleng = (expptr) mkarg(TYLENG, chlgslot);
			np->vleng->addrblock.uname_tag = UNAM_IDENT;
			strcpy (np -> vleng -> addrblock.user.ident,
				new_func_length());
			}
		if (!xretslot[TYCHAR]) {
			xretslot[TYCHAR] = rs =
				autovar(0, type, ISCONST(np->vleng)
					? np->vleng : ICON(0), "");
			strcpy(rs->user.ident, "ret_val");
			}
	}

/* Handle a   complex   return type -- declare a new parameter (pointer to
   a complex value) */

	else if( ISCOMPLEX(type) ) {
		if (!xretslot[type])
			xretslot[type] =
				autovar(0, type, EXNULL, " ret_val");
				/* the blank is for use in out_addr */
		np->vstg = STGARG;
		if(cxslot < 0)
			cxslot = nextarg(TYADDR);
		}
	else if (type != TYSUBR) {
		if (type == TYUNKNOWN) {
			dclerr("untyped function", np);
			proctype = type = np->vtype =
				dflttype[letter(np->fvarname[0])];
			}
		if (!xretslot[type])
			xretslot[type] = retslot =
				autovar(1, type, EXNULL, " ret_val");
				/* the blank is for use in out_addr */
		np->vstg = STGAUTO;
		}

	for(p = ep->arglist ; p ; p = p->nextp)
		if(! (( q = (Namep) (p->datap) )->vknownarg) ) {
			q->vknownarg = 1;
			q->vardesc.varno = nextarg(TYADDR);
			allargs = mkchain((char *)q, allargs);
			q->argno = nallargs++;
			}
		else if (nentry == 1)
			duparg(q);
		else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp)
			if ((Namep)p1->datap == q)
				duparg(q);

	k = 0;
	for(p = ep->arglist ; p ; p = p->nextp) {
		if(! (( q = (Namep) (p->datap) )->vdcldone) )
			{
			impldcl(q);
			q->vdcldone = YES;
			if(q->vtype == TYCHAR)
				{

/* If we don't know the length of a char*(*) (i.e. a string), we must add
   in this additional length argument. */

				++nallchargs;
				if (q->vclass == CLPROC)
					nallchargs--;
				else if (q->vleng == NULL) {
					/* character*(*) */
					q->vleng = (expptr)
					    mkarg(TYLENG, nextarg(TYLENG) );
					unamstring((Addrp)q->vleng,
						new_arg_length(q));
					}
				}
			}
		if (q->vdimfinish)
			dim_finish(q);
		if (q->vtype == TYCHAR && q->vclass != CLPROC)
			k++;
		}

	if (entryname->extype != type)
		changedtype(np);

	/* save information for checking consistency of arg lists */

	it = infertypes;
	if (entryname->exproto)
		infertypes = 1;
	save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo,
			0, np->fvarname, STGEXT, k, np->vtype, 2);
	infertypes = it;
}



 LOCAL int
#ifdef KR_headers
nextarg(type)
	int type;
#else
nextarg(int type)
#endif
{
	type = type;	/* shut up warning */
	return(lastargslot++);
	}

 LOCAL void
#ifdef KR_headers
dim_check(q)
	Namep q;
#else
dim_check(Namep q)
#endif
{
	register struct Dimblock *vdim = q->vdim;

	if(!vdim->nelt || !ISICON(vdim->nelt))
		dclerr("adjustable dimension on non-argument", q);
	else if (vdim->nelt->constblock.Const.ci <= 0)
		dclerr("nonpositive dimension", q);
	}

 LOCAL void
dobss(Void)
{
	register struct Hashentry *p;
	register Namep q;
	int qstg, qclass, qtype;
	Extsym *e;

	for(p = hashtab ; p<lasthash ; ++p)
		if(q = p->varp)
		{
			qstg = q->vstg;
			qtype = q->vtype;
			qclass = q->vclass;

			if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
			    (qclass==CLVAR && qstg==STGUNKNOWN) ) {
				if (!(q->vis_assigned | q->vimpldovar))
					warn1("local variable %s never used",
						q->fvarname);
				}
			else if(qclass==CLVAR && qstg==STGBSS)
			{ ; }

/* Give external procedures the proper storage class */

			else if(qclass==CLPROC && q->vprocclass==PEXTERNAL
					&& qstg!=STGARG) {
				e = mkext(q->fvarname,addunder(q->cvarname));
				e->extstg = STGEXT;
				q->vardesc.varno = e - extsymtab;
				if (e->extype != qtype)
					changedtype(q);
				}
			if(qclass==CLVAR) {
			    if (qstg != STGARG && q->vdim)
				dim_check(q);
			} /* if qclass == CLVAR */
		}

}


 void
donmlist(Void)
{
	register struct Hashentry *p;
	register Namep q;

	for(p=hashtab; p<lasthash; ++p)
		if( (q = p->varp) && q->vclass==CLNAMELIST)
			namelist(q);
}


/* iarrlen -- Returns the size of the array in bytes, or -1 */

 ftnint
#ifdef KR_headers
iarrlen(q)
	register Namep q;
#else
iarrlen(register Namep q)
#endif
{
	ftnint leng;

	leng = typesize[q->vtype];
	if(leng <= 0)
		return(-1);
	if(q->vdim)
		if( ISICON(q->vdim->nelt) )
			leng *= q->vdim->nelt->constblock.Const.ci;
		else	return(-1);
	if(q->vleng)
		if( ISICON(q->vleng) )
			leng *= q->vleng->constblock.Const.ci;
		else return(-1);
	return(leng);
}

 void
#ifdef KR_headers
namelist(np)
	Namep np;
#else
namelist(Namep np)
#endif
{
	register chainp q;
	register Namep v;
	int y;

	if (!np->visused)
		return;
	y = 0;

	for(q = np->varxptr.namelist ; q ; q = q->nextp)
	{
		vardcl( v = (Namep) (q->datap) );
		if( !ONEOF(v->vstg, MSKSTATIC) )
			dclerr("may not appear in namelist", v);
		else {
			v->vnamelist = 1;
			v->visused = 1;
			v->vsave = 1;
			y = 1;
			}
	np->visused = y;
	}
}

/* docommon -- called at the end of procedure declarations, before
   equivalences and the procedure body */

 LOCAL void
docommon(Void)
{
    register Extsym *extptr;
    register chainp q, q1;
    struct Dimblock *t;
    expptr neltp;
    register Namep comvar;
    ftnint size;
    int i, k, pref, type;
    extern int type_pref[];

    for(extptr = extsymtab ; extptr<nextext ; ++extptr)
	if (extptr->extstg == STGCOMMON && (q = extptr->extp)) {

/* If a common declaration also had a list of variables ... */

	    q = extptr->extp = revchain(q);
	    pref = 1;
	    for(k = TYCHAR; q ; q = q->nextp)
	    {
		comvar = (Namep) (q->datap);

		if(comvar->vdcldone == NO)
		    vardcl(comvar);
		type = comvar->vtype;
		if (pref < type_pref[type])
			pref = type_pref[k = type];
		if(extptr->extleng % typealign[type] != 0) {
		    dclerr("common alignment", comvar);
		    --nerr; /* don't give bad return code for this */
#if 0
		    extptr->extleng = roundup(extptr->extleng, typealign[type]);
#endif
		} /* if extptr -> extleng % */

/* Set the offset into the common block */

		comvar->voffset = extptr->extleng;
		comvar->vardesc.varno = extptr - extsymtab;
		if(type == TYCHAR)
		    size = comvar->vleng->constblock.Const.ci;
		else
		    size = typesize[type];
		if(t = comvar->vdim)
		    if( (neltp = t->nelt) && ISCONST(neltp) )
			size *= neltp->constblock.Const.ci;
		    else
			dclerr("adjustable array in common", comvar);

/* Adjust the length of the common block so far */

		extptr->extleng += size;
	    } /* for */

	    extptr->extype = k;

/* Determine curno and, if new, save this identifier chain */

	    q1 = extptr->extp;
	    for (q = extptr->allextp, i = 0; q; i++, q = q->nextp)
		if (struct_eq((chainp)q->datap, q1))
			break;
	    if (q)
		extptr->curno = extptr->maxno - i;
	    else {
		extptr->curno = ++extptr->maxno;
		extptr->allextp = mkchain((char *)extptr->extp,
						extptr->allextp);
		}
	} /* if extptr -> extstg == STGCOMMON */

/* Now the hash table entries have STGCOMMON, vdcldone, voffset, and
   varno.  And the common block itself has its full size in extleng. */

} /* docommon */


/* copy_data -- copy the Namep entries so they are available even after
   the hash table is empty */

 void
#ifdef KR_headers
copy_data(list)
	chainp list;
#else
copy_data(chainp list)
#endif
{
    for (; list; list = list -> nextp) {
	Namep namep = ALLOC (Nameblock);
	int size, nd, i;
	struct Dimblock *dp;

	cpn(sizeof(struct Nameblock), list->datap, (char *)namep);
	namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0),
		namep->fvarname);
	namep->cvarname = strcmp(namep->fvarname, namep->cvarname)
		? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname)
		: namep->fvarname;
	if (namep -> vleng)
	    namep -> vleng = (expptr) cpexpr (namep -> vleng);
	if (namep -> vdim) {
	    nd = namep -> vdim -> ndim;
	    size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr);
	    dp = (struct Dimblock *) ckalloc (size);
	    cpn(size, (char *)namep->vdim, (char *)dp);
	    namep -> vdim = dp;
	    dp->nelt = (expptr)cpexpr(dp->nelt);
	    for (i = 0; i < nd; i++) {
		dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize);
	    } /* for */
	} /* if */
	list -> datap = (char *) namep;
    } /* for */
} /* copy_data */



 LOCAL void
docomleng(Void)
{
	register Extsym *p;

	for(p = extsymtab ; p < nextext ; ++p)
		if(p->extstg == STGCOMMON)
		{
			if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
			    && strcmp(Blank, p->cextname) )
				warn1("incompatible lengths for common block %.60s",
				    p->fextname);
			if(p->maxleng < p->extleng)
				p->maxleng = p->extleng;
			p->extleng = 0;
		}
}


/* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */

 void
#ifdef KR_headers
frtemp(p)
	Addrp p;
#else
frtemp(Addrp p)
#endif
{
	/* put block on chain of temps to be reclaimed */
	holdtemps = mkchain((char *)p, holdtemps);
}

 void
freetemps(Void)
{
	register chainp p, p1;
	register Addrp q;
	register int t;

	p1 = holdtemps;
	while(p = p1) {
		q = (Addrp)p->datap;
		t = q->vtype;
		if (t == TYCHAR && q->varleng != 0) {
			/* restore clobbered character string lengths */
			frexpr(q->vleng);
			q->vleng = ICON(q->varleng);
			}
		p1 = p->nextp;
		p->nextp = templist[t];
		templist[t] = p;
		}
	holdtemps = 0;
	}

/* allocate an automatic variable slot for each of   nelt   variables */

 Addrp