proc.c

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

#ifdef KR_headers
autovar(nelt0, t, lengp, name)
	register int nelt0;
	register int t;
	expptr lengp;
	char *name;
#else
autovar(register int nelt0, register int t, expptr lengp, char *name)
#endif
{
	ftnint leng;
	register Addrp q;
	register int nelt = nelt0 > 0 ? nelt0 : 1;
	extern char *av_pfix[];

	if(t == TYCHAR)
		if( ISICON(lengp) )
			leng = lengp->constblock.Const.ci;
		else	{
			Fatal("automatic variable of nonconstant length");
		}
	else
		leng = typesize[t];

	q = ALLOC(Addrblock);
	q->tag = TADDR;
	q->vtype = t;
	if(t == TYCHAR)
	{
		q->vleng = ICON(leng);
		q->varleng = leng;
	}
	q->vstg = STGAUTO;
	q->ntempelt = nelt;
	q->isarray = (nelt > 1);
	q->memoffset = ICON(0);

	/* kludge for nls so we can have ret_val rather than ret_val_4 */
	if (*name == ' ')
		unamstring(q, name);
	else {
		q->uname_tag = UNAM_IDENT;
		temp_name(av_pfix[t], ++autonum[t], q->user.ident);
		}
	if (nelt0 > 0)
		declare_new_addr (q);
	return(q);
}


/* Returns a temporary of the appropriate type.  Will reuse existing
   temporaries when possible */

 Addrp
#ifdef KR_headers
mktmpn(nelt, type, lengp)
	int nelt;
	register int type;
	expptr lengp;
#else
mktmpn(int nelt, register int type, expptr lengp)
#endif
{
	ftnint leng;
	chainp p, oldp;
	register Addrp q;
	extern int krparens;

	if(type==TYUNKNOWN || type==TYERROR)
		badtype("mktmpn", type);

	if(type==TYCHAR)
		if(lengp && ISICON(lengp) )
			leng = lengp->constblock.Const.ci;
		else	{
			err("adjustable length");
			return( (Addrp) errnode() );
		}
	else if (type > TYCHAR || type < TYADDR) {
		erri("mktmpn: unexpected type %d", type);
		exit(1);
		}
/*
 * if a temporary of appropriate shape is on the templist,
 * remove it from the list and return it
 */
	if (krparens == 2 && ONEOF(type,M(TYREAL)|M(TYCOMPLEX)))
		type++;
	for(oldp=CHNULL, p=templist[type];  p  ;  oldp=p, p=p->nextp)
	{
		q = (Addrp) (p->datap);
		if(q->ntempelt==nelt &&
		    (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) )
		{
			if(oldp)
				oldp->nextp = p->nextp;
			else
				templist[type] = p->nextp;
			free( (charptr) p);
			return(q);
		}
	}
	q = autovar(nelt, type, lengp, "");
	return(q);
}




/* mktmp -- create new local variable; call it something like   name
   lengp   is taken directly, not copied */

 Addrp
#ifdef KR_headers
mktmp(type, lengp)
	int type;
	expptr lengp;
#else
mktmp(int type, expptr lengp)
#endif
{
	Addrp rv;
	/* arrange for temporaries to be recycled */
	/* at the end of this statement... */
	rv = mktmpn(1,type,lengp);
	frtemp((Addrp)cpexpr((expptr)rv));
	return rv;
}

/* mktmp0 omits frtemp() */
 Addrp
#ifdef KR_headers
mktmp0(type, lengp)
	int type;
	expptr lengp;
#else
mktmp0(int type, expptr lengp)
#endif
{
	Addrp rv;
	/* arrange for temporaries to be recycled */
	/* when this Addrp is freed */
	rv = mktmpn(1,type,lengp);
	rv->istemp = YES;
	return rv;
}

/* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */

/* comblock -- Declare a new common block.  Input parameters name the block;
   s   will be NULL if the block is unnamed */

 Extsym *
#ifdef KR_headers
comblock(s)
	register char *s;
#else
comblock(register char *s)
#endif
{
	Extsym *p;
	register char *t;
	register int c, i;
	char cbuf[256], *s0;

/* Give the unnamed common block a unique name */

	if(*s == 0)
		p = mkext1(s0 = Blank, Blank);
	else {
		s0 = s;
		t = cbuf;
		for(i = 0; c = *t = *s++; t++)
			if (c == '_')
				i = 1;
		if (i)
			*t++ = '_';
		t[0] = '_';
		t[1] = 0;
		p = mkext1(s0,cbuf);
		}
	if(p->extstg == STGUNKNOWN)
		p->extstg = STGCOMMON;
	else if(p->extstg != STGCOMMON)
	{
		errstr("%.52s cannot be a common block: it is a subprogram.",
			s0);
		return(0);
	}

	return( p );
}


/* incomm -- add a new variable to a common declaration */

 void
#ifdef KR_headers
incomm(c, v)
	Extsym *c;
	Namep v;
#else
incomm(Extsym *c, Namep v)
#endif
{
	if (!c)
		return;
	if(v->vstg != STGUNKNOWN && !v->vimplstg)
		dclerr(v->vstg == STGARG
			? "dummy arguments cannot be in common"
			: "incompatible common declaration", v);
	else
	{
		v->vstg = STGCOMMON;
		c->extp = mkchain((char *)v, c->extp);
	}
}




/* settype -- set the type or storage class of a Namep object.  If
   v -> vstg == STGUNKNOWN && type < 0,   attempt to reset vstg to be
   -type.  This function will not change any earlier definitions in   v,
   in will only attempt to fill out more information give the other params */

 void
#ifdef KR_headers
settype(v, type, length)
	register Namep v;
	register int type;
	register ftnint length;
#else
settype(register Namep v, register int type, register ftnint length)
#endif
{
	int type1;

	if(type == TYUNKNOWN)
		return;

	if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
	{
		v->vtype = TYSUBR;
		frexpr(v->vleng);
		v->vleng = 0;
		v->vimpltype = 0;
	}
	else if(type < 0)	/* storage class set */
	{
		if(v->vstg == STGUNKNOWN)
			v->vstg = - type;
		else if(v->vstg != -type)
			dclerr("incompatible storage declarations", v);
	}
	else if(v->vtype == TYUNKNOWN || v->vimpltype && v->vtype != type)
	{
		if( (v->vtype = lengtype(type, length))==TYCHAR )
			if (length>=0)
				v->vleng = ICON(length);
			else if (parstate >= INDATA)
				v->vleng = ICON(1);	/* avoid a memory fault */
		v->vimpltype = 0;

		if (v->vclass == CLPROC) {
			if (v->vstg == STGEXT
			 && (type1 = extsymtab[v->vardesc.varno].extype)
			 &&  type1 != v->vtype)
				changedtype(v);
			else if (v->vprocclass == PTHISPROC
					&& (parstate >= INDATA
						|| procclass == CLMAIN)
					&& !xretslot[type]) {
				xretslot[type] = autovar(ONEOF(type,
					MSKCOMPLEX|MSKCHAR) ? 0 : 1, type,
					v->vleng, " ret_val");
				if (procclass == CLMAIN)
					errstr(
				"illegal use of %.60s (main program name)",
					v->fvarname);
				/* not completely right, but enough to */
				/* avoid memory faults; we won't */
				/* emit any C as we have illegal Fortran */
				}
			}
	}
	else if(v->vtype!=type) {
 incompat:
		dclerr("incompatible type declarations", v);
		}
	else if (type==TYCHAR)
		if (v->vleng && v->vleng->constblock.Const.ci != length)
			goto incompat;
		else if (parstate >= INDATA)
			v->vleng = ICON(1);	/* avoid a memory fault */
}





/* lengtype -- returns the proper compiler type, given input of Fortran
   type and length specifier */

 int
#ifdef KR_headers
lengtype(type, len)
	register int type;
	ftnint len;
#else
lengtype(register int type, ftnint len)
#endif
{
	register int length = (int)len;
	switch(type)
	{
	case TYREAL:
		if(length == typesize[TYDREAL])
			return(TYDREAL);
		if(length == typesize[TYREAL])
			goto ret;
		break;

	case TYCOMPLEX:
		if(length == typesize[TYDCOMPLEX])
			return(TYDCOMPLEX);
		if(length == typesize[TYCOMPLEX])
			goto ret;
		break;

	case TYINT1:
	case TYSHORT:
	case TYDREAL:
	case TYDCOMPLEX:
	case TYCHAR:
	case TYLOGICAL1:
	case TYLOGICAL2:
	case TYUNKNOWN:
	case TYSUBR:
	case TYERROR:
#ifdef TYQUAD
	case TYQUAD:
#endif
		goto ret;

	case TYLOGICAL:
		switch(length) {
			case 0: return tylog;
			case 1:	return TYLOGICAL1;
			case 2: return TYLOGICAL2;
			case 4: goto ret;
			}
#if 0 /*!!??!!*/
		if(length == typesize[TYLOGICAL])
			goto ret;
#endif
		break;

	case TYLONG:
		if(length == 0)
			return(tyint);
		if (length == 1)
			return TYINT1;
		if(length == typesize[TYSHORT])
			return(TYSHORT);
#ifdef TYQUAD
		if(length == typesize[TYQUAD] && use_tyquad)
			return(TYQUAD);
#endif
		if(length == typesize[TYLONG])
			goto ret;
		break;
	default:
		badtype("lengtype", type);
	}

	if(len != 0)
		err("incompatible type-length combination");

ret:
	return(type);
}





/* setintr -- Set Intrinsic function */

 void
#ifdef KR_headers
setintr(v)
	register Namep v;
#else
setintr(register Namep v)
#endif
{
	int k;

	if(k = intrfunct(v->fvarname)) {
		if ((*(struct Intrpacked *)&k).f4)
			if (noextflag)
				goto unknown;
			else
				dcomplex_seen++;
		v->vardesc.varno = k;
		}
	else {
 unknown:
		dclerr("unknown intrinsic function", v);
		return;
		}
	if(v->vstg == STGUNKNOWN)
		v->vstg = STGINTR;
	else if(v->vstg!=STGINTR)
		dclerr("incompatible use of intrinsic function", v);
	if(v->vclass==CLUNKNOWN)
		v->vclass = CLPROC;
	if(v->vprocclass == PUNKNOWN)
		v->vprocclass = PINTRINSIC;
	else if(v->vprocclass != PINTRINSIC)
		dclerr("invalid intrinsic declaration", v);
}



/* setext -- Set External declaration -- assume that unknowns will become
   procedures */

 void
#ifdef KR_headers
setext(v)
	register Namep v;
#else
setext(register Namep v)
#endif
{
	if(v->vclass == CLUNKNOWN)
		v->vclass = CLPROC;
	else if(v->vclass != CLPROC)
		dclerr("invalid external declaration", v);

	if(v->vprocclass == PUNKNOWN)
		v->vprocclass = PEXTERNAL;
	else if(v->vprocclass != PEXTERNAL)
		dclerr("invalid external declaration", v);
} /* setext */




/* create dimensions block for array variable */

 void
#ifdef KR_headers
setbound(v, nd, dims)
	register Namep v;
	int nd;
	struct Dims *dims;
#else
setbound(register Namep v, int nd, struct Dims *dims)
#endif
{
	register expptr q, t;
	register struct Dimblock *p;
	int i;
	extern chainp new_vars;
	char buf[256];

	if(v->vclass == CLUNKNOWN)
		v->vclass = CLVAR;
	else if(v->vclass != CLVAR)
	{
		dclerr("only variables may be arrays", v);
		return;
	}

	v->vdim = p = (struct Dimblock *)
	    ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) );
	p->ndim = nd--;
	p->nelt = ICON(1);
	doin_setbound = 1;

	for(i = 0; i <= nd; ++i)
	{
		if( (q = dims[i].ub) == NULL)
		{
			if(i == nd)
			{
				frexpr(p->nelt);
				p->nelt = NULL;
			}
			else
				err("only last bound may be asterisk");
			p->dims[i].dimsize = ICON(1);
			p->dims[i].dimexpr = NULL;
		}
		else
		{

			if(dims[i].lb)
			{
				q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
				q = mkexpr(OPPLUS, q, ICON(1) );
			}
			if( ISCONST(q) )
			{
				p->dims[i].dimsize = q;
				p->dims[i].dimexpr = (expptr) PNULL;
			}
			else {
				sprintf(buf, " %s_dim%d", v->fvarname, i+1);
				p->dims[i].dimsize = (expptr)
					autovar(1, tyint, EXNULL, buf);
				p->dims[i].dimexpr = q;
				if (i == nd)
					v->vlastdim = new_vars;
				v->vdimfinish = 1;
			}
			if(p->nelt)
				p->nelt = mkexpr(OPSTAR, p->nelt,
				    cpexpr(p->dims[i].dimsize) );
		}
	}

	q = dims[nd].lb;
	if(q == NULL)
		q = ICON(1);

	for(i = nd-1 ; i>=0 ; --i)
	{
		t = dims[i].lb;
		if(t == NULL)
			t = ICON(1);
		if(p->dims[i].dimsize)
			q = mkexpr(OPPLUS, t,
				mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q));
	}

	if( ISCONST(q) )
	{
		p->baseoffset = q;
		p->basexpr = NULL;
	}
	else
	{
		sprintf(buf, " %s_offset", v->fvarname);
		p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf);
		p->basexpr = q;
		v->vdimfinish = 1;
	}
	doin_setbound = 0;
}


 void
#ifdef KR_headers
wr_abbrevs(outfile, function_head, vars)
	FILE *outfile;
	int function_head;
	chainp vars;
#else
wr_abbrevs(FILE *outfile, int function_head, chainp vars)
#endif
{
    for (; vars; vars = vars -> nextp) {
	Namep name = (Namep) vars -> datap;
	if (!name->visused)
		continue;

	if (function_head)
	    nice_printf (outfile, "#define ");
	else
	    nice_printf (outfile, "#undef ");
	out_name (outfile, name);

	if (function_head) {
	    Extsym *comm = &extsymtab[name -> vardesc.varno];

	    nice_printf (outfile, " (");
	    extern_out (outfile, comm);
	    nice_printf (outfile, "%d.", comm->curno);
	    nice_printf (outfile, "%s)", name->cvarname);
	} /* if function_head */
	nice_printf (outfile, "\n");
    } /* for */
} /* wr_abbrevs */