expr.c

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

	int ltag, rtag;
	long L;
	static long divlineno;

	ltype = lp->headblock.vtype;
	ltag = lp->tag;
	if(rp && opcode!=OPCALL && opcode!=OPCCALL)
	{
		rtype = rp->headblock.vtype;
		rtag = rp->tag;
	}
	else rtype = 0;

	etype = cktype(opcode, ltype, rtype);
	if(etype == TYERROR)
		goto error;

	switch(opcode)
	{
		/* check for multiplication by 0 and 1 and addition to 0 */

	case OPSTAR:
		if( ISCONST(lp) )
			COMMUTE

		if( ISICON(rp) )
			{
				if(rp->constblock.Const.ci == 0)
					goto retright;
				goto mulop;
			}
		break;

	case OPSLASH:
	case OPMOD:
		if( zeroconst(rp) && lineno != divlineno ) {
			warn("attempted division by zero");
			divlineno = lineno;
			}
		if(opcode == OPMOD)
			break;

/* Handle multiplying or dividing by 1, -1 */

mulop:
		if( ISICON(rp) )
		{
			if(rp->constblock.Const.ci == 1)
				goto retleft;

			if(rp->constblock.Const.ci == -1)
			{
				frexpr(rp);
				return( mkexpr(OPNEG, lp, ENULL) );
			}
		}

/* Group all constants together.  In particular,

	(x * CONST1) * CONST2 ==> x * (CONST1 * CONST2)
	(x * CONST1) / CONST2 ==> x * (CONST1 / CONST2)
*/

		if (!ISINT(etype) || lp->tag != TEXPR || !lp->exprblock.rightp
				|| !ISICON(lp->exprblock.rightp))
			break;

		if (lp->exprblock.opcode == OPLSHIFT) {
			L = 1 << lp->exprblock.rightp->constblock.Const.ci;
			if (opcode == OPSTAR || ISICON(rp) &&
					!(L % rp->constblock.Const.ci)) {
				lp->exprblock.opcode = OPSTAR;
				lp->exprblock.rightp->constblock.Const.ci = L;
				}
			}

		if (lp->exprblock.opcode == OPSTAR) {
			if(opcode == OPSTAR)
				e = mkexpr(OPSTAR, lp->exprblock.rightp, rp);
			else if(ISICON(rp) &&
			    (lp->exprblock.rightp->constblock.Const.ci %
			    rp->constblock.Const.ci) == 0)
				e = mkexpr(OPSLASH, lp->exprblock.rightp, rp);
			else	break;

			e1 = lp->exprblock.leftp;
			free( (charptr) lp );
			return( mkexpr(OPSTAR, e1, e) );
			}
		break;


	case OPPLUS:
		if( ISCONST(lp) )
			COMMUTE
			    goto addop;

	case OPMINUS:
		if( ICONEQ(lp, 0) )
		{
			frexpr(lp);
			return( mkexpr(OPNEG, rp, ENULL) );
		}

		if( ISCONST(rp) && is_negatable((Constp)rp))
		{
			opcode = OPPLUS;
			consnegop((Constp)rp);
		}

/* Group constants in an addition expression (also subtraction, since the
   subtracted value was negated above).  In particular,

	(x + CONST1) + CONST2 ==> x + (CONST1 + CONST2)
*/

addop:
		if( ISICON(rp) )
		{
			if(rp->constblock.Const.ci == 0)
				goto retleft;
			if( ISPLUSOP(lp) && ISICON(lp->exprblock.rightp) )
			{
				e = mkexpr(OPPLUS, lp->exprblock.rightp, rp);
				e1 = lp->exprblock.leftp;
				free( (charptr) lp );
				return( mkexpr(OPPLUS, e1, e) );
			}
		}
		if (opcode == OPMINUS && (ISINT(etype) || doing_vleng)) {
			/* check for (i [+const]) - (i [+const]) */
			if (lp->tag == TPRIM)
				e = lp;
			else if (lp->tag == TEXPR && lp->exprblock.opcode == OPPLUS
					&& lp->exprblock.rightp->tag == TCONST) {
				e = lp->exprblock.leftp;
				if (e->tag != TPRIM)
					break;
				}
			else
				break;
			if (e->primblock.argsp)
				break;
			if (rp->tag == TPRIM)
				e1 = rp;
			else if (rp->tag == TEXPR && rp->exprblock.opcode == OPPLUS
					&& rp->exprblock.rightp->tag == TCONST) {
				e1 = rp->exprblock.leftp;
				if (e1->tag != TPRIM)
					break;
				}
			else
				break;
			if (e->primblock.namep != e1->primblock.namep
					|| e1->primblock.argsp)
				break;
			L = e == lp ? 0 : lp->exprblock.rightp->constblock.Const.ci;
			if (e1 != rp)
				L -= rp->exprblock.rightp->constblock.Const.ci;
			frexpr(lp);
			frexpr(rp);
			return ICON(L);
			}

		break;


	case OPPOWER:
		break;

/* Eliminate outermost double negations */

	case OPNEG:
	case OPNEG1:
		if(ltag==TEXPR && lp->exprblock.opcode==OPNEG)
		{
			e = lp->exprblock.leftp;
			free( (charptr) lp );
			return(e);
		}
		break;

/* Eliminate outermost double NOTs */

	case OPNOT:
		if(ltag==TEXPR && lp->exprblock.opcode==OPNOT)
		{
			e = lp->exprblock.leftp;
			free( (charptr) lp );
			return(e);
		}
		break;

	case OPCALL:
	case OPCCALL:
		etype = ltype;
		if(rp!=NULL && rp->listblock.listp==NULL)
		{
			free( (charptr) rp );
			rp = NULL;
		}
		break;

	case OPAND:
	case OPOR:
		if( ISCONST(lp) )
			COMMUTE

			    if( ISCONST(rp) )
			{
				if(rp->constblock.Const.ci == 0)
					if(opcode == OPOR)
						goto retleft;
					else
						goto retright;
				else if(opcode == OPOR)
					goto retright;
				else
					goto retleft;
			}
	case OPEQV:
	case OPNEQV:

	case OPBITAND:
	case OPBITOR:
	case OPBITXOR:
	case OPBITNOT:
	case OPLSHIFT:
	case OPRSHIFT:

	case OPLT:
	case OPGT:
	case OPLE:
	case OPGE:
	case OPEQ:
	case OPNE:

	case OPCONCAT:
		break;
	case OPMIN:
	case OPMAX:
	case OPMIN2:
	case OPMAX2:
	case OPDMIN:
	case OPDMAX:

	case OPASSIGN:
	case OPASSIGNI:
	case OPPLUSEQ:
	case OPSTAREQ:
	case OPMINUSEQ:
	case OPSLASHEQ:
	case OPMODEQ:
	case OPLSHIFTEQ:
	case OPRSHIFTEQ:
	case OPBITANDEQ:
	case OPBITXOREQ:
	case OPBITOREQ:

	case OPCONV:
	case OPADDR:
	case OPWHATSIN:

	case OPCOMMA:
	case OPCOMMA_ARG:
	case OPQUEST:
	case OPCOLON:
	case OPDOT:
	case OPARROW:
	case OPIDENTITY:
	case OPCHARCAST:
	case OPABS:
	case OPDABS:
		break;

	default:
		badop("mkexpr", opcode);
	}

	e = (expptr) ALLOC(Exprblock);
	e->exprblock.tag = TEXPR;
	e->exprblock.opcode = opcode;
	e->exprblock.vtype = etype;
	e->exprblock.leftp = lp;
	e->exprblock.rightp = rp;
	if(ltag==TCONST && (rp==0 || rtag==TCONST) )
		e = fold(e);
	return(e);

retleft:
	frexpr(rp);
	if (lp->tag == TPRIM)
		lp->primblock.parenused = 1;
	return(lp);

retright:
	frexpr(lp);
	if (rp->tag == TPRIM)
		rp->primblock.parenused = 1;
	return(rp);

error:
	frexpr(lp);
	if(rp && opcode!=OPCALL && opcode!=OPCCALL)
		frexpr(rp);
	return( errnode() );
}

#define ERR(s)   { errs = s; goto error; }

/* cktype -- Check and return the type of the expression */

#ifdef KR_headers
cktype(op, lt, rt)
	register int op;
	register int lt;
	register int rt;
#else
cktype(register int op, register int lt, register int rt)
#endif
{
	char *errs;

	if(lt==TYERROR || rt==TYERROR)
		goto error1;

	if(lt==TYUNKNOWN)
		return(TYUNKNOWN);
	if(rt==TYUNKNOWN)

/* If not unary operation, return UNKNOWN */

		if(!is_unary_op (op) && op != OPCALL && op != OPCCALL)
			return(TYUNKNOWN);

	switch(op)
	{
	case OPPLUS:
	case OPMINUS:
	case OPSTAR:
	case OPSLASH:
	case OPPOWER:
	case OPMOD:
		if( ISNUMERIC(lt) && ISNUMERIC(rt) )
			return( maxtype(lt, rt) );
		ERR("nonarithmetic operand of arithmetic operator")

	case OPNEG:
	case OPNEG1:
		if( ISNUMERIC(lt) )
			return(lt);
		ERR("nonarithmetic operand of negation")

	case OPNOT:
		if(ISLOGICAL(lt))
			return(lt);
		ERR("NOT of nonlogical")

	case OPAND:
	case OPOR:
	case OPEQV:
	case OPNEQV:
		if(ISLOGICAL(lt) && ISLOGICAL(rt))
			return( maxtype(lt, rt) );
		ERR("nonlogical operand of logical operator")

	case OPLT:
	case OPGT:
	case OPLE:
	case OPGE:
	case OPEQ:
	case OPNE:
		if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt))
		{
			if(lt != rt){
				if (htype
					&& (lt == TYCHAR && ISNUMERIC(rt)
					 || rt == TYCHAR && ISNUMERIC(lt)))
						return TYLOGICAL;
				ERR("illegal comparison")
				}
		}

		else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
		{
			if(op!=OPEQ && op!=OPNE)
				ERR("order comparison of complex data")
		}

		else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
			ERR("comparison of nonarithmetic data")
			    return(TYLOGICAL);

	case OPCONCAT:
		if(lt==TYCHAR && rt==TYCHAR)
			return(TYCHAR);
		ERR("concatenation of nonchar data")

	case OPCALL:
	case OPCCALL:
	case OPIDENTITY:
		return(lt);

	case OPADDR:
	case OPCHARCAST:
		return(TYADDR);

	case OPCONV:
		if(rt == 0)
			return(0);
		if(lt==TYCHAR && ISINT(rt) )
			return(TYCHAR);
		if (ISLOGICAL(lt) && ISLOGICAL(rt))
			return lt;
	case OPASSIGN:
	case OPASSIGNI:
	case OPMINUSEQ:
	case OPPLUSEQ:
	case OPSTAREQ:
	case OPSLASHEQ:
	case OPMODEQ:
	case OPLSHIFTEQ:
	case OPRSHIFTEQ:
	case OPBITANDEQ:
	case OPBITXOREQ:
	case OPBITOREQ:
		if( ISINT(lt) && rt==TYCHAR)
			return(lt);
		if (ISLOGICAL(lt) && ISLOGICAL(rt) && op == OPASSIGN)
			return lt;
		if(lt==TYCHAR || rt==TYCHAR || ISLOGICAL(lt) || ISLOGICAL(rt))
			if((op!=OPASSIGN && op != OPPLUSEQ && op != OPMINUSEQ)
			    || (lt!=rt))
			{
				ERR("impossible conversion")
			}
		return(lt);

	case OPMIN:
	case OPMAX:
	case OPDMIN:
	case OPDMAX:
	case OPMIN2:
	case OPMAX2:
	case OPBITOR:
	case OPBITAND:
	case OPBITXOR:
	case OPBITNOT:
	case OPLSHIFT:
	case OPRSHIFT:
	case OPWHATSIN:
	case OPABS:
	case OPDABS:
		return(lt);

	case OPCOMMA:
	case OPCOMMA_ARG:
	case OPQUEST:
	case OPCOLON:		/* Only checks the rightmost type because
				   of C language definition (rightmost
				   comma-expr is the value of the expr) */
		return(rt);

	case OPDOT:
	case OPARROW:
	    return (lt);
	default:
		badop("cktype", op);
	}
error:
	err(errs);
error1:
	return(TYERROR);
}

/* fold -- simplifies constant expressions; it assumes that e -> leftp and
   e -> rightp are TCONST or NULL */

 expptr
#ifdef KR_headers
fold(e)
	register expptr e;
#else
fold(register expptr e)
#endif
{
	Constp p;
	register expptr lp, rp;
	int etype, mtype, ltype, rtype, opcode;
	int i, bl, ll, lr;
	char *q, *s;
	struct Constblock lcon, rcon;
	long L;
	double d;

	opcode = e->exprblock.opcode;
	etype = e->exprblock.vtype;

	lp = e->exprblock.leftp;
	ltype = lp->headblock.vtype;
	rp = e->exprblock.rightp;

	if(rp == 0)
		switch(opcode)
		{
		case OPNOT:
			lp->constblock.Const.ci = ! lp->constblock.Const.ci;
 retlp:
			e->exprblock.leftp = 0;
			frexpr(e);
			return(lp);

		case OPBITNOT:
			lp->constblock.Const.ci = ~ lp->constblock.Const.ci;
			goto retlp;

		case OPNEG:
		case OPNEG1:
			consnegop((Constp)lp);
			goto retlp;

		case OPCONV:
		case OPADDR:
			return(e);

		case OPABS:
		case OPDABS:
			switch(ltype) {
			    case TYINT1:
			    case TYSHORT:
			    case TYLONG:
#ifdef TYQUAD
			    case TYQUAD:
#endif
				if ((L = lp->constblock.Const.ci) < 0)
					lp->constblock.Const.ci = -L;
				goto retlp;
			    case TYREAL:
			    case TYDREAL:
				if (lp->constblock.vstg) {
				    s = lp->constblock.Const.cds[0];
				    if (*s == '-')
					lp->constblock.Const.cds[0] = s + 1;
				    goto retlp;
				}
				if ((d = lp->constblock.Const.cd[0]) < 0.)
					lp->constblock.Const.cd[0] = -d;
			    case TYCOMPLEX:
			    case TYDCOMPLEX:
				return e;	/* lazy way out */
			    }
		default:
			badop("fold", opcode);
		}

	rtype = rp->headblock.vtype;

	p = ALLOC(Constblock);
	p->tag = TCONST;
	p->vtype = etype;
	p->vleng = e->exprblock.vleng;

	switch(opcode)
	{
	case OPCOMMA:
	case OPCOMMA_ARG:
	case OPQUEST:
	case OPCOLON:
		goto ereturn;

	case OPAND:
		p->Const.ci = lp->constblock.Const.ci &&
		    rp->constblock.Const.ci;
		break;

	case OPOR:
		p->Const.ci = lp->constblock.Const.ci ||
		    rp->constblock.Const.ci;
		break;

	case OPEQV:
		p->Const.ci = lp->constblock.Const.ci ==
		    rp->constblock.Const.ci;
		break;

	case OPNEQV:
		p->Const.ci = lp->constblock.Const.ci !=
		    rp->constblock.Const.ci;
		break;

	case OPBITAND:
		p->Const.ci = lp->constblock.Const.ci &
		    rp->constblock.Const.ci;
		break;

	case OPBITOR:
		p->Const.ci = lp->constblock.Const.ci |
		    rp->constblock.Const.ci;
		break;

	case OPBITXOR:
		p->Const.ci = lp->constblock.Const.ci ^
		    rp->constblock.Const.ci;
		break;

	case OPLSHIFT:
		p->Const.ci = lp->constblock.Const.ci <<
		    rp->constblock.Const.ci;
		break;

	case OPRSHIFT:
		p->Const.ci = lp->constblock.Const.ci >>
		    rp->constblock.Const.ci;
		break;

	case OPCONCAT:
		ll = lp->constblock.vleng->constblock.Const.ci;
		lr = rp->constblock.vleng->constblock.Const.ci;
		bl = lp->constblock.Const.ccp1.blanks;
		p->Const.ccp = q = (char *) ckalloc(ll+lr+bl);
		p->Const.ccp1.blanks = rp->constblock.Const.ccp1.blanks;
		p->vleng = ICON(ll+lr+bl);
		s = lp->constblock.Const.ccp;
		for(i = 0 ; i < ll ; ++i)
			*q++ = *s++;
		for(i = 0 ; i < bl ; i++)
			*q++ = ' ';
		s = rp->constblock.Const.ccp;
		for(i = 0; i < lr; ++i)
			*q++ = *s++;
		break;


	case OPPOWER:
		if( !ISINT(rtype)
		 || rp->constblock.Const.ci < 0 && zeroconst(lp))
			goto ereturn;
		conspower(p, (Constp)lp, rp->constblock.Const.ci);
		break;

	case OPSLASH:
		if (zeroconst(rp))
			goto ereturn;
		/* no break */

	default:
		if(ltype == TYCHAR)
		{
			lcon.Const.ci = cmpstr(lp->constblock.Const.ccp,
			    rp->constblock.Const.ccp,
			    lp->constblock.vleng->constblock.Const.ci,
			    rp->constblock.vleng->constblock.Const.ci);
			rcon.Const.ci = 0;
			mtype = tyint;
		}
		else	{
			mtype = maxtype(ltype, rtype);
			consconv(mtype, &lcon, &lp->constblock);
			consconv(mtype, &rcon, &rp->constblock);
		}
		consbinop(opcode, mtype, p, &lcon, &rcon);
		break;
	}