expr.c

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

	frexpr(e);
	return( (expptr) p );
 ereturn:
	free((char *)p);
	return e;
}



/* assign constant l = r , doing coercion */

 void
#ifdef KR_headers
consconv(lt, lc, rc)
	int lt;
	register Constp lc;
	register Constp rc;
#else
consconv(int lt, register Constp lc, register Constp rc)
#endif
{
	int rt = rc->vtype;
	register union Constant *lv = &lc->Const, *rv = &rc->Const;

	lc->vtype = lt;
	if (ONEOF(lt, MSKREAL|MSKCOMPLEX) && ONEOF(rt, MSKREAL|MSKCOMPLEX)) {
		memcpy((char *)lv, (char *)rv, sizeof(union Constant));
		lc->vstg = rc->vstg;
		if (ISCOMPLEX(lt) && ISREAL(rt)) {
			if (rc->vstg)
				lv->cds[1] = cds("0",CNULL);
			else
				lv->cd[1] = 0.;
			}
		return;
		}
	lc->vstg = 0;

	switch(lt)
	{

/* Casting to character means just copying the first sizeof (character)
   bytes into a new 1 character string.  This is weird. */

	case TYCHAR:
		*(lv->ccp = (char *) ckalloc(1)) = rv->ci;
		lv->ccp1.blanks = 0;
		break;

	case TYINT1:
	case TYSHORT:
	case TYLONG:
#ifdef TYQUAD
	case TYQUAD:
#endif
		if(rt == TYCHAR)
			lv->ci = rv->ccp[0];
		else if( ISINT(rt) )
			lv->ci = rv->ci;
		else	lv->ci = rc->vstg ? atof(rv->cds[0]) : rv->cd[0];

		break;

	case TYCOMPLEX:
	case TYDCOMPLEX:
		lv->cd[1] = 0.;
		lv->cd[0] = rv->ci;
		break;

	case TYREAL:
	case TYDREAL:
		lv->cd[0] = rv->ci;
		break;

	case TYLOGICAL:
	case TYLOGICAL1:
	case TYLOGICAL2:
		lv->ci = rv->ci;
		break;
	}
}



/* Negate constant value -- changes the input node's value */

 void
#ifdef KR_headers
consnegop(p)
	register Constp p;
#else
consnegop(register Constp p)
#endif
{
	register char *s;

	if (p->vstg) {
		if (ISCOMPLEX(p->vtype)) {
			s = p->Const.cds[1];
			p->Const.cds[1] = *s == '-' ? s+1
					: *s == '0' ? s : s-1;
			}
		s = p->Const.cds[0];
		p->Const.cds[0] = *s == '-' ? s+1
				: *s == '0' ? s : s-1;
		return;
		}
	switch(p->vtype)
	{
	case TYINT1:
	case TYSHORT:
	case TYLONG:
#ifdef TYQUAD
	case TYQUAD:
#endif
		p->Const.ci = - p->Const.ci;
		break;

	case TYCOMPLEX:
	case TYDCOMPLEX:
		p->Const.cd[1] = - p->Const.cd[1];
		/* fall through and do the real parts */
	case TYREAL:
	case TYDREAL:
		p->Const.cd[0] = - p->Const.cd[0];
		break;
	default:
		badtype("consnegop", p->vtype);
	}
}



/* conspower -- Expand out an exponentiation */

 LOCAL void
#ifdef KR_headers
conspower(p, ap, n)
	Constp p;
	Constp ap;
	ftnint n;
#else
conspower(Constp p, Constp ap, ftnint n)
#endif
{
	register union Constant *powp = &p->Const;
	register int type;
	struct Constblock x, x0;

	if (n == 1) {
		memcpy((char *)powp, (char *)&ap->Const, sizeof(ap->Const));
		return;
		}

	switch(type = ap->vtype)	/* pow = 1 */
	{
	case TYINT1:
	case TYSHORT:
	case TYLONG:
#ifdef TYQUAD
	case TYQUAD:
#endif
		powp->ci = 1;
		break;
	case TYCOMPLEX:
	case TYDCOMPLEX:
		powp->cd[1] = 0;
	case TYREAL:
	case TYDREAL:
		powp->cd[0] = 1;
		break;
	default:
		badtype("conspower", type);
	}

	if(n == 0)
		return;
	switch(type)	/* x0 = ap */
	{
	case TYINT1:
	case TYSHORT:
	case TYLONG:
#ifdef TYQUAD
	case TYQUAD:
#endif
		x0.Const.ci = ap->Const.ci;
		break;
	case TYCOMPLEX:
	case TYDCOMPLEX:
		x0.Const.cd[1] =
			ap->vstg ? atof(ap->Const.cds[1]) : ap->Const.cd[1];
	case TYREAL:
	case TYDREAL:
		x0.Const.cd[0] =
			ap->vstg ? atof(ap->Const.cds[0]) : ap->Const.cd[0];
		break;
	}
	x0.vtype = type;
	x0.vstg = 0;
	if(n < 0)
	{
		if( ISINT(type) )
		{
			err("integer ** negative number");
			return;
		}
		else if (!x0.Const.cd[0]
				&& (!ISCOMPLEX(type) || !x0.Const.cd[1])) {
			err("0.0 ** negative number");
			return;
			}
		n = -n;
		consbinop(OPSLASH, type, &x, p, &x0);
	}
	else
		consbinop(OPSTAR, type, &x, p, &x0);

	for( ; ; )
	{
		if(n & 01)
			consbinop(OPSTAR, type, p, p, &x);
		if(n >>= 1)
			consbinop(OPSTAR, type, &x, &x, &x);
		else
			break;
	}
}



/* do constant operation cp = a op b -- assumes that   ap and bp   have data
   matching the input   type */

 LOCAL void
#ifdef KR_headers
consbinop(opcode, type, cpp, app, bpp)
	int opcode;
	int type;
	Constp cpp;
	Constp app;
	Constp bpp;
#else
consbinop(int opcode, int type, Constp cpp, Constp app, Constp bpp)
#endif
{
	register union Constant *ap = &app->Const,
				*bp = &bpp->Const,
				*cp = &cpp->Const;
	int k;
	double ad[2], bd[2], temp;

	cpp->vstg = 0;

	if (ONEOF(type, MSKREAL|MSKCOMPLEX)) {
		ad[0] = app->vstg ? atof(ap->cds[0]) : ap->cd[0];
		bd[0] = bpp->vstg ? atof(bp->cds[0]) : bp->cd[0];
		if (ISCOMPLEX(type)) {
			ad[1] = app->vstg ? atof(ap->cds[1]) : ap->cd[1];
			bd[1] = bpp->vstg ? atof(bp->cds[1]) : bp->cd[1];
			}
		}
	switch(opcode)
	{
	case OPPLUS:
		switch(type)
		{
		case TYINT1:
		case TYSHORT:
		case TYLONG:
#ifdef TYQUAD
		case TYQUAD:
#endif
			cp->ci = ap->ci + bp->ci;
			break;
		case TYCOMPLEX:
		case TYDCOMPLEX:
			cp->cd[1] = ad[1] + bd[1];
		case TYREAL:
		case TYDREAL:
			cp->cd[0] = ad[0] + bd[0];
			break;
		}
		break;

	case OPMINUS:
		switch(type)
		{
		case TYINT1:
		case TYSHORT:
		case TYLONG:
#ifdef TYQUAD
		case TYQUAD:
#endif
			cp->ci = ap->ci - bp->ci;
			break;
		case TYCOMPLEX:
		case TYDCOMPLEX:
			cp->cd[1] = ad[1] - bd[1];
		case TYREAL:
		case TYDREAL:
			cp->cd[0] = ad[0] - bd[0];
			break;
		}
		break;

	case OPSTAR:
		switch(type)
		{
		case TYINT1:
		case TYSHORT:
		case TYLONG:
#ifdef TYQUAD
		case TYQUAD:
#endif
			cp->ci = ap->ci * bp->ci;
			break;
		case TYREAL:
		case TYDREAL:
			cp->cd[0] = ad[0] * bd[0];
			break;
		case TYCOMPLEX:
		case TYDCOMPLEX:
			temp = ad[0] * bd[0]  -  ad[1] * bd[1] ;
			cp->cd[1] = ad[0] * bd[1]  +  ad[1] * bd[0] ;
			cp->cd[0] = temp;
			break;
		}
		break;
	case OPSLASH:
		switch(type)
		{
		case TYINT1:
		case TYSHORT:
		case TYLONG:
#ifdef TYQUAD
		case TYQUAD:
#endif
			cp->ci = ap->ci / bp->ci;
			break;
		case TYREAL:
		case TYDREAL:
			cp->cd[0] = ad[0] / bd[0];
			break;
		case TYCOMPLEX:
		case TYDCOMPLEX:
			zdiv((dcomplex*)cp, (dcomplex*)ad, (dcomplex*)bd);
			break;
		}
		break;

	case OPMOD:
		if( ISINT(type) )
		{
			cp->ci = ap->ci % bp->ci;
			break;
		}
		else
			Fatal("inline mod of noninteger");

	case OPMIN2:
	case OPDMIN:
		switch(type)
		{
		case TYINT1:
		case TYSHORT:
		case TYLONG:
#ifdef TYQUAD
		case TYQUAD:
#endif
			cp->ci = ap->ci <= bp->ci ? ap->ci : bp->ci;
			break;
		case TYREAL:
		case TYDREAL:
			cp->cd[0] = ad[0] <= bd[0] ? ad[0] : bd[0];
			break;
		default:
			Fatal("inline min of exected type");
		}
		break;

	case OPMAX2:
	case OPDMAX:
		switch(type)
		{
		case TYINT1:
		case TYSHORT:
		case TYLONG:
#ifdef TYQUAD
		case TYQUAD:
#endif
			cp->ci = ap->ci >= bp->ci ? ap->ci : bp->ci;
			break;
		case TYREAL:
		case TYDREAL:
			cp->cd[0] = ad[0] >= bd[0] ? ad[0] : bd[0];
			break;
		default:
			Fatal("inline max of exected type");
		}
		break;

	default:	  /* relational ops */
		switch(type)
		{
		case TYINT1:
		case TYSHORT:
		case TYLONG:
#ifdef TYQUAD
		case TYQUAD:
#endif
			if(ap->ci < bp->ci)
				k = -1;
			else if(ap->ci == bp->ci)
				k = 0;
			else	k = 1;
			break;
		case TYREAL:
		case TYDREAL:
			if(ad[0] < bd[0])
				k = -1;
			else if(ad[0] == bd[0])
				k = 0;
			else	k = 1;
			break;
		case TYCOMPLEX:
		case TYDCOMPLEX:
			if(ad[0] == bd[0] &&
			    ad[1] == bd[1] )
				k = 0;
			else	k = 1;
			break;
		}

		switch(opcode)
		{
		case OPEQ:
			cp->ci = (k == 0);
			break;
		case OPNE:
			cp->ci = (k != 0);
			break;
		case OPGT:
			cp->ci = (k == 1);
			break;
		case OPLT:
			cp->ci = (k == -1);
			break;
		case OPGE:
			cp->ci = (k >= 0);
			break;
		case OPLE:
			cp->ci = (k <= 0);
			break;
		}
		break;
	}
}



/* conssgn - returns the sign of a Fortran constant */

#ifdef KR_headers
conssgn(p)
	register expptr p;
#else
conssgn(register expptr p)
#endif
{
	register char *s;

	if( ! ISCONST(p) )
		Fatal( "sgn(nonconstant)" );

	switch(p->headblock.vtype)
	{
	case TYINT1:
	case TYSHORT:
	case TYLONG:
#ifdef TYQUAD
	case TYQUAD:
#endif
		if(p->constblock.Const.ci > 0) return(1);
		if(p->constblock.Const.ci < 0) return(-1);
		return(0);

	case TYREAL:
	case TYDREAL:
		if (p->constblock.vstg) {
			s = p->constblock.Const.cds[0];
			if (*s == '-')
				return -1;
			if (*s == '0')
				return 0;
			return 1;
			}
		if(p->constblock.Const.cd[0] > 0) return(1);
		if(p->constblock.Const.cd[0] < 0) return(-1);
		return(0);


/* The sign of a complex number is 0 iff the number is 0 + 0i, else it's 1 */

	case TYCOMPLEX:
	case TYDCOMPLEX:
		if (p->constblock.vstg)
			return *p->constblock.Const.cds[0] != '0'
			    && *p->constblock.Const.cds[1] != '0';
		return(p->constblock.Const.cd[0]!=0 || p->constblock.Const.cd[1]!=0);

	default:
		badtype( "conssgn", p->constblock.vtype);
	}
	/* NOT REACHED */ return 0;
}

char *powint[ ] = {
	"pow_ii",
#ifdef TYQUAD
		  "pow_qi",
#endif
		  "pow_ri", "pow_di", "pow_ci", "pow_zi" };

 LOCAL expptr
#ifdef KR_headers
mkpower(p)
	register expptr p;
#else
mkpower(register expptr p)
#endif
{
	register expptr q, lp, rp;
	int ltype, rtype, mtype, tyi;

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

	if (lp->tag == TADDR)
		lp->addrblock.parenused = 0;

	if (rp->tag == TADDR)
		rp->addrblock.parenused = 0;

	if(ISICON(rp))
	{
		if(rp->constblock.Const.ci == 0)
		{
			frexpr(p);
			if( ISINT(ltype) )
				return( ICON(1) );
			else if (ISREAL (ltype))
				return mkconv (ltype, ICON (1));
			else
				return( (expptr) putconst((Constp)
					mkconv(ltype, ICON(1))) );
		}
		if(rp->constblock.Const.ci < 0)
		{
			if( ISINT(ltype) )
			{
				frexpr(p);
				err("integer**negative");
				return( errnode() );
			}
			rp->constblock.Const.ci = - rp->constblock.Const.ci;
			p->exprblock.leftp = lp
				= fixexpr((Exprp)mkexpr(OPSLASH, ICON(1), lp));
		}
		if(rp->constblock.Const.ci == 1)
		{
			frexpr(rp);
			free( (charptr) p );
			return(lp);
		}

		if( ONEOF(ltype, MSKINT|MSKREAL) ) {
			p->exprblock.vtype = ltype;
			return(p);
		}
	}
	if( ISINT(rtype) )
	{
		if(ltype==TYSHORT && rtype==TYSHORT && (!ISCONST(lp) || tyint==TYSHORT) )
			q = call2(TYSHORT, "pow_hh", lp, rp);
		else	{
			if(ONEOF(ltype,M(TYINT1)|M(TYSHORT)))
			{
				ltype = TYLONG;
				lp = mkconv(TYLONG,lp);
			}
#ifdef TYQUAD
			if (ltype == TYQUAD)
				rp = mkconv(TYQUAD,rp);
			else
#endif
			rp = mkconv(TYLONG,rp);
			if (ISCONST(rp)) {
				tyi = tyint;
				tyint = TYLONG;
				rp = (expptr)putconst((Constp)rp);
				tyint = tyi;
				}
			q = call2(ltype, powint[ltype-TYLONG], lp, rp);
		}
	}
	else if( ISREAL( (mtype = maxtype(ltype,rtype)) )) {
		extern int callk_kludge;
		callk_kludge = TYDREAL;
		q = call2(mtype, "pow_dd", mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
		callk_kludge = 0;
		}
	else	{
		q  = call2(TYDCOMPLEX, "pow_zz",
		    mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
		if(mtype == TYCOMPLEX)
			q = mkconv(TYCOMPLEX, q);
	}
	free( (charptr) p );
	return(q);
}


/* Complex Division.  Same code as in Runtime Library
*/


 LOCAL void
#ifdef KR_headers
zdiv(c, a, b)
	register dcomplex *c;
	register dcomplex *a;
	register dcomplex *b;
#else
zdiv(register dcomplex *c, register dcomplex *a, register dcomplex *b)
#endif
{
	double ratio, den;
	double abr, abi;

	if( (abr = b->dreal) < 0.)
		abr = - abr;
	if( (abi = b->dimag) < 0.)
		abi = - abi;
	if( abr <= abi )
	{
		if(abi == 0)
			Fatal("complex division by zero");
		ratio = b->dreal / b->dimag ;
		den = b->dimag * (1 + ratio*ratio);
		c->dreal = (a->dreal*ratio + a->dimag) / den;
		c->dimag = (a->dimag*ratio - a->dreal) / den;
	}

	else
	{
		ratio = b->dimag / b->dreal ;
		den = b->dreal * (1 + ratio*ratio);
		c->dreal = (a->dreal + a->dimag*ratio) / den;
		c->dimag = (a->dimag - a->dreal*ratio) / den;
	}
}