expr.c

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

	int opcode, ltype, rtype, ptype, mtype;

	if( ISERROR(p) || p->typefixed )
		return( (expptr) p );
	else if(p->tag != TEXPR)
		badtag("fixexpr", p->tag);
	opcode = p->opcode;

/* First set the types of the left and right subexpressions */

	lp = p->leftp;
	if (!ISCONST(lp) || lp->constblock.vtype != TYCHAR)
		lp = p->leftp = fixtype(lp);
	ltype = lp->headblock.vtype;

	if(opcode==OPASSIGN && lp->tag!=TADDR)
	{
		err("left side of assignment must be variable");
 eret:
		frexpr((expptr)p);
		return( errnode() );
	}

	if(rp = p->rightp)
	{
		if (!ISCONST(rp) || rp->constblock.vtype != TYCHAR)
			rp = p->rightp = fixtype(rp);
		rtype = rp->headblock.vtype;
	}
	else
		rtype = 0;

	if(ltype==TYERROR || rtype==TYERROR)
		goto eret;

/* Now work on the whole expression */

	/* force folding if possible */

	if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
	{
		q = opcode == OPCONV && lp->constblock.vtype == p->vtype
			? lp : mkexpr(opcode, lp, rp);

/* mkexpr is expected to reduce constant expressions */

		if( ISCONST(q) ) {
			p->leftp = p->rightp = 0;
			frexpr((expptr)p);
			return(q);
			}
		free( (charptr) q );	/* constants did not fold */
	}

	if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
		goto eret;

	if (ltype == TYCHAR && ISCONST(lp))
		p->leftp =  lp = (expptr)putconst((Constp)lp);
	if (rtype == TYCHAR && ISCONST(rp))
		p->rightp = rp = (expptr)putconst((Constp)rp);

	switch(opcode)
	{
	case OPCONCAT:
		if(p->vleng == NULL)
			p->vleng = mkexpr(OPPLUS, cplenexpr(lp),
					cplenexpr(rp) );
		break;

	case OPASSIGN:
		if (rtype == TYREAL || ISLOGICAL(ptype)
		 || rtype == TYDREAL && ltype == TYREAL && !ISCONST(rp))
			break;
	case OPPLUSEQ:
	case OPSTAREQ:
		if(ltype == rtype)
			break;
		if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
			break;
		if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
			break;
		if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
		    && typesize[ltype]>=typesize[rtype] )
			    break;

/* Cast the right hand side to match the type of the expression */

		p->rightp = fixtype( mkconv(ptype, rp) );
		break;

	case OPSLASH:
		if( ISCOMPLEX(rtype) )
		{
			p = (Exprp) call2(ptype,

/* Handle double precision complex variables */

			    ptype == TYCOMPLEX ? "c_div" : "z_div",
			    mkconv(ptype, lp), mkconv(ptype, rp) );
			break;
		}
	case OPPLUS:
	case OPMINUS:
	case OPSTAR:
	case OPMOD:
		if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
		    (rtype==TYREAL && ! ISCONST(rp) ) ))
			break;
		if( ISCOMPLEX(ptype) )
			break;

/* Cast both sides of the expression to match the type of the whole
   expression.  */

		if(ltype != ptype && (ltype < TYINT1 || ptype > TYDREAL))
			p->leftp = fixtype(mkconv(ptype,lp));
		if(rtype != ptype && (rtype < TYINT1 || ptype > TYDREAL))
			p->rightp = fixtype(mkconv(ptype,rp));
		break;

	case OPPOWER:
		rp = mkpower((expptr)p);
		if (rp->tag == TEXPR)
			rp->exprblock.typefixed = 1;
		return rp;

	case OPLT:
	case OPLE:
	case OPGT:
	case OPGE:
	case OPEQ:
	case OPNE:
		if(ltype == rtype)
			break;
		if (htype) {
			if (ltype == TYCHAR) {
				p->leftp = fixtype(mkconv(rtype,lp));
				break;
				}
			if (rtype == TYCHAR) {
				p->rightp = fixtype(mkconv(ltype,rp));
				break;
				}
			}
		mtype = cktype(OPMINUS, ltype, rtype);
		if(mtype==TYDREAL && (ltype==TYREAL || rtype==TYREAL))
			break;
		if( ISCOMPLEX(mtype) )
			break;
		if(ltype != mtype)
			p->leftp = fixtype(mkconv(mtype,lp));
		if(rtype != mtype)
			p->rightp = fixtype(mkconv(mtype,rp));
		break;

	case OPCONV:
		ptype = cktype(OPCONV, p->vtype, ltype);
		if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA
		 && !ISCOMPLEX(ptype))
		{
			lp->exprblock.rightp =
			    fixtype( mkconv(ptype, lp->exprblock.rightp) );
			free( (charptr) p );
			p = (Exprp) lp;
		}
		break;

	case OPADDR:
		if(lp->tag==TEXPR && lp->exprblock.opcode==OPADDR)
			Fatal("addr of addr");
		break;

	case OPCOMMA:
	case OPQUEST:
	case OPCOLON:
		break;

	case OPMIN:
	case OPMAX:
	case OPMIN2:
	case OPMAX2:
	case OPDMIN:
	case OPDMAX:
	case OPABS:
	case OPDABS:
		ptype = p->vtype;
		break;

	default:
		break;
	}

	p->vtype = ptype;
	p->typefixed = 1;
	return((expptr) p);
}


/* fix an argument list, taking due care for special first level cases */

 int
#ifdef KR_headers
fixargs(doput, p0)
	int doput;
	struct Listblock *p0;
#else
fixargs(int doput, struct Listblock *p0)
#endif
	/* doput is true if constants need to be passed by reference */
{
	register chainp p;
	register tagptr q, t;
	register int qtag;
	int nargs;

	nargs = 0;
	if(p0)
		for(p = p0->listp ; p ; p = p->nextp)
		{
			++nargs;
			q = (tagptr)p->datap;
			qtag = q->tag;
			if(qtag == TCONST)
			{

/* Call putconst() to store values in a constant table.  Since even
   constants must be passed by reference, this can optimize on the storage
   required */

				p->datap = doput ? (char *)putconst((Constp)q)
						 : (char *)q;
			}

/* Take a function name and turn it into an Addr.  This only happens when
   nothing else has figured out the function beforehand */

			else if(qtag==TPRIM && q->primblock.argsp==0 &&
			    q->primblock.namep->vclass==CLPROC &&
			    q->primblock.namep->vprocclass != PTHISPROC)
				p->datap = (char *)mkaddr(q->primblock.namep);

			else if(qtag==TPRIM && q->primblock.argsp==0 &&
			    q->primblock.namep->vdim!=NULL)
				p->datap = (char *)mkscalar(q->primblock.namep);

			else if(qtag==TPRIM && q->primblock.argsp==0 &&
			    q->primblock.namep->vdovar &&
			    (t = (tagptr) memversion(q->primblock.namep)) )
				p->datap = (char *)fixtype(t);
			else
				p->datap = (char *)fixtype(q);
		}
	return(nargs);
}



/* mkscalar -- only called by   fixargs   above, and by some routines in
   io.c */

 Addrp
#ifdef KR_headers
mkscalar(np)
	register Namep np;
#else
mkscalar(register Namep np)
#endif
{
	register Addrp ap;

	vardcl(np);
	ap = mkaddr(np);

	/* The prolog causes array arguments to point to the
	 * (0,...,0) element, unless subscript checking is on.
	 */
	if( !checksubs && np->vstg==STGARG)
	{
		register struct Dimblock *dp;
		dp = np->vdim;
		frexpr(ap->memoffset);
		ap->memoffset = mkexpr(OPSTAR,
		    (np->vtype==TYCHAR ?
		    cpexpr(np->vleng) :
		    (tagptr)ICON(typesize[np->vtype]) ),
		    cpexpr(dp->baseoffset) );
	}
	return(ap);
}


 static void
#ifdef KR_headers
adjust_arginfo(np)
	register Namep np;
#else
adjust_arginfo(register Namep np)
#endif
			/* adjust arginfo to omit the length arg for the
			   arg that we now know to be a character-valued
			   function */
{
	struct Entrypoint *ep;
	register chainp args;
	Argtypes *at;

	for(ep = entries; ep; ep = ep->entnextp)
		for(args = ep->arglist; args; args = args->nextp)
			if (np == (Namep)args->datap
			&& (at = ep->entryname->arginfo))
				--at->nargs;
	}



 expptr
#ifdef KR_headers
mkfunct(p0)
	expptr p0;
#else
mkfunct(expptr p0)
#endif
{
	register struct Primblock *p = (struct Primblock *)p0;
	struct Entrypoint *ep;
	Addrp ap;
	Extsym *extp;
	register Namep np;
	register expptr q;
	extern chainp new_procs;
	int k, nargs;
	int class;

	if(p->tag != TPRIM)
		return( errnode() );

	np = p->namep;
	class = np->vclass;


	if(class == CLUNKNOWN)
	{
		np->vclass = class = CLPROC;
		if(np->vstg == STGUNKNOWN)
		{
			if(np->vtype!=TYSUBR && (k = intrfunct(np->fvarname))
				&& (zflag || !(*(struct Intrpacked *)&k).f4
					|| dcomplex_seen))
			{
				np->vstg = STGINTR;
				np->vardesc.varno = k;
				np->vprocclass = PINTRINSIC;
			}
			else
			{
				extp = mkext(np->fvarname,
					addunder(np->cvarname));
				extp->extstg = STGEXT;
				np->vstg = STGEXT;
				np->vardesc.varno = extp - extsymtab;
				np->vprocclass = PEXTERNAL;
			}
		}
		else if(np->vstg==STGARG)
		{
		    if(np->vtype == TYCHAR) {
			adjust_arginfo(np);
			if (np->vpassed) {
				char wbuf[160], *who;
				who = np->fvarname;
				sprintf(wbuf, "%s%s%s\n\t%s%s%s",
					"Character-valued dummy procedure ",
					who, " not declared EXTERNAL.",
			"Code may be wrong for previous function calls having ",
					who, " as a parameter.");
				warn(wbuf);
				}
			}
		    np->vprocclass = PEXTERNAL;
		}
	}

	if(class != CLPROC) {
		if (np->vstg == STGCOMMON)
			fatalstr(
			 "Cannot invoke common variable %.50s as a function.",
				np->fvarname);
		errstr("%.80s cannot be called.", np->fvarname);
		goto error;
		}

/* F77 doesn't allow subscripting of function calls */

	if(p->fcharp || p->lcharp)
	{
		err("no substring of function call");
		goto error;
	}
	impldcl(np);
	np->vimpltype = 0;	/* invoking as function ==> inferred type */
	np->vcalled = 1;
	nargs = fixargs( np->vprocclass!=PINTRINSIC,  p->argsp);

	switch(np->vprocclass)
	{
	case PEXTERNAL:
		if(np->vtype == TYUNKNOWN)
		{
			dclerr("attempt to use untyped function", np);
			np->vtype = dflttype[letter(np->fvarname[0])];
		}
		ap = mkaddr(np);
		if (!extsymtab[np->vardesc.varno].extseen) {
			new_procs = mkchain((char *)np, new_procs);
			extsymtab[np->vardesc.varno].extseen = 1;
			}
call:
		q = mkexpr(OPCALL, (expptr)ap, (expptr)p->argsp);
		q->exprblock.vtype = np->vtype;
		if(np->vleng)
			q->exprblock.vleng = (expptr) cpexpr(np->vleng);
		break;

	case PINTRINSIC:
		q = intrcall(np, p->argsp, nargs);
		break;

	case PSTFUNCT:
		q = stfcall(np, p->argsp);
		break;

	case PTHISPROC:
		warn("recursive call");

/* entries   is the list of multiple entry points */

		for(ep = entries ; ep ; ep = ep->entnextp)
			if(ep->enamep == np)
				break;
		if(ep == NULL)
			Fatal("mkfunct: impossible recursion");

		ap = builtin(np->vtype, ep->entryname->cextname, -2);
		/* the negative last arg prevents adding */
		/* this name to the list of used builtins */
		goto call;

	default:
		fatali("mkfunct: impossible vprocclass %d",
		    (int) (np->vprocclass) );
	}
	free( (charptr) p );
	return(q);

error:
	frexpr((expptr)p);
	return( errnode() );
}



 static expptr
#ifdef KR_headers
stfcall(np, actlist)
	Namep np;
	struct Listblock *actlist;
#else
stfcall(Namep np, struct Listblock *actlist)
#endif
{
	register chainp actuals;
	int nargs;
	chainp oactp, formals;
	int type;
	expptr Ln, Lq, q, q1, rhs, ap;
	Namep tnp;
	register struct Rplblock *rp;
	struct Rplblock *tlist;

	if (np->arginfo) {
		errstr("statement function %.66s calls itself.",
			np->fvarname);
		return ICON(0);
		}
	np->arginfo = (Argtypes *)np;	/* arbitrary nonzero value */
	if(actlist)
	{
		actuals = actlist->listp;
		free( (charptr) actlist);
	}
	else
		actuals = NULL;
	oactp = actuals;

	nargs = 0;
	tlist = NULL;
	if( (type = np->vtype) == TYUNKNOWN)
	{
		dclerr("attempt to use untyped statement function", np);
		type = np->vtype = dflttype[letter(np->fvarname[0])];
	}
	formals = (chainp) np->varxptr.vstfdesc->datap;
	rhs = (expptr) (np->varxptr.vstfdesc->nextp);

	/* copy actual arguments into temporaries */
	while(actuals!=NULL && formals!=NULL)
	{
		if (!(tnp = (Namep) formals->datap)) {
			/* buggy statement function declaration */
			q = ICON(1);
			goto done;
			}
		rp = ALLOC(Rplblock);
		rp->rplnp = tnp;
		ap = fixtype((tagptr)actuals->datap);
		if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR
		    && (ap->tag==TCONST || ap->tag==TADDR) )
		{

/* If actuals are constants or variable names, no temporaries are required */
			rp->rplvp = (expptr) ap;
			rp->rplxp = NULL;
			rp->rpltag = ap->tag;
		}
		else	{
			rp->rplvp = (expptr) mktmp(tnp->vtype, tnp->vleng);
			rp -> rplxp = NULL;
			putexpr ( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap));
			if((rp->rpltag = rp->rplvp->tag) == TERROR)
				err("disagreement of argument types in statement function call");
		}
		rp->rplnextp = tlist;
		tlist = rp;
		actuals = actuals->nextp;
		formals = formals->nextp;
		++nargs;
	}

	if(actuals!=NULL || formals!=NULL)
		err("statement function definition and argument list differ");

	/*
   now push down names involved in formal argument list, then
   evaluate rhs of statement function definition in this environment
*/

	if(tlist)	/* put tlist in front of the rpllist */
	{
		for(rp = tlist; rp->rplnextp; rp = rp->rplnextp)
			;
		rp->rplnextp = rpllist;
		rpllist = tlist;
	}

/* So when the expression finally gets evaled, that evaluator must read
   from the globl   rpllist   14-jun-88 mwm */

	q = (expptr) mkconv(type, fixtype(cpexpr(rhs)) );

	/* get length right of character-valued statement functions... */
	if (type == TYCHAR
	 && (Ln = np->vleng)
	 && q->tag != TERROR
	 && (Lq = q->exprblock.vleng)
	 && (Lq->tag != TCONST
		|| Ln->constblock.Const.ci != Lq->constblock.Const.ci)) {
		q1 = (expptr) mktmp(type, Ln);
		putexpr ( mkexpr(OPASSIGN, cpexpr(q1), q));
		q = q1;
		}

	/* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
	while(--nargs >= 0)
	{
		if(rpllist->rplxp)
			q = mkexpr(OPCOMMA, rpllist->rplxp, q);
		rp = rpllist->rplnextp;
		frexpr(rpllist->rplvp);
		free((char *)rpllist);
		rpllist = rp;
	}
 done:
	frchain( &oactp );
	np->arginfo = 0;
	return(q);
}


static int replaced;

/* mkplace -- Figure out the proper storage class for the input name and
   return an addrp with the appropriate stuff */

 Addrp
#ifdef KR_headers
mkplace(np)
	register Namep np;
#else
mkplace(register Namep np)
#endif
{
	register Addrp s;
	register struct Rplblock *rp;
	int regn;

	/* is name on the replace list? */

	for(rp = rpllist ; rp ; rp = rp->rplnextp)
	{
		if(np == rp->rplnp)
		{
			replaced = 1;
			if(rp->rpltag == TNAME)
			{
				np = (Namep) (rp->rplvp);
				break;
			}
			else	return( (Addrp) cpexpr(rp->rplvp) );
		}
	}

	/* is variable a DO index in a register ? */

	if(np->vdovar && ( (regn = inregister(np)) >= 0) )
		if(np->vtype == TYERROR)
			return((Addrp) errnode() );
		else
		{
			s = ALLOC(Addrblock);
			s->tag = TADDR;
			s->vstg = STGREG;
			s->vtype = TYIREG;
			s->memno = regn;
			s->memoffset = ICON(0);
			s -> uname_tag = UNAM_NAME;
			s -> user.name = np;
			return(s);
		}

	if (np->vclass == CLPROC && np->vprocclass != PTHISPROC)
		errstr("external %.60s used as a variable", np->fvarname);
	vardcl(np);
	return(mkaddr(np));
}

 static expptr
#ifdef KR_headers
subskept(p, a)
	struct Primblock *p;
	Addrp a;
#else
subskept(struct Primblock *p, Addrp a)
#endif
{
	expptr ep;
	struct Listblock *Lb;
	chainp cp;

	if (a->uname_tag != UNAM_NAME)
		erri("subskept: uname_tag %d", a->uname_tag);
	a->user.name->vrefused = 1;
	a->user.name->visused = 1;
	a->uname_tag = UNAM_REF;