expr.c

来自「<B>Digital的Unix操作系统VAX 4.2源码</B>」· C语言 代码 · 共 2,881 行 · 第 1/4 页

if(p->rightp)
	{
	rp = p->rightp = fixtype(p->rightp);
	rtype = rp->headblock.vtype;
	}
else
	{
	rp = NULL;
	rtype = 0;
	}

if(ltype==TYERROR || rtype==TYERROR)
	{
	frexpr(p);
	frexpr(lconst);
	frexpr(rconst);
	return( errnode() );
	}

/* force folding if possible */
if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
	{
	q = mkexpr(opcode, lp, rp);
	if( ISCONST(q) )
		{
		frexpr(lconst);
		frexpr(rconst);
		return(q);
		}
	free( (charptr) q );	/* constants did not fold */
	}

if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
	{
	frexpr(p);
	frexpr(lconst);
	frexpr(rconst);
	return( errnode() );
	}

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

	case OPASSIGN:
	case OPPLUSEQ:
	case OPSTAREQ:
		if(ltype == rtype)
			break;
		if( ! rconst && ISREAL(ltype) && ISREAL(rtype) )
			break;
		if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
			break;
		if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
#if FAMILY==PCC
		    && typesize[ltype]>=typesize[rtype] )
#else
		    && typesize[ltype]==typesize[rtype] )
#endif
			break;
		if (rconst)
			{
			p->rightp = fixtype( mkconv(ptype, cpexpr(rconst)) );
			frexpr(rp);
			}
		else
			p->rightp = fixtype(mkconv(ptype, rp));
		break;

	case OPSLASH:
		if( ISCOMPLEX(rtype) )
			{
			p = (Exprp) call2(ptype,
				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 && ! lconst ) ||
		    (rtype==TYREAL && ! rconst ) ))
			break;
		if( ISCOMPLEX(ptype) )
			break;
		if(ltype != ptype)
			if (lconst)
				{
				p->leftp = fixtype(mkconv(ptype,
						cpexpr(lconst)));
				frexpr(lp);
				}
			else
				p->leftp = fixtype(mkconv(ptype,lp));
		if(rtype != ptype)
			if (rconst)
				{
				p->rightp = fixtype(mkconv(ptype,
						cpexpr(rconst)));
				frexpr(rp);
				}
			else
				p->rightp = fixtype(mkconv(ptype,rp));
		break;

	case OPPOWER:
		return( mkpower(p) );

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


	case OPCONV:
		if(ISCOMPLEX(p->vtype))
			{
			ptype = cktype(OPCONV, p->vtype, ltype);
			if(p->rightp)
				ptype = cktype(OPCONV, ptype, rtype);
			break;
			}
		ptype = cktype(OPCONV, p->vtype, ltype);
		if(lp->tag==TEXPR && lp->exprblock.opcode==OPCOMMA)
			{
			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 OPPAREN:
		p->vleng = (expptr) cpexpr( lp->headblock.vleng );
		break;

	case OPMIN:
	case OPMAX:
		ptype = p->vtype;
		break;

	default:
		break;
	}

p->vtype = ptype;
frexpr(lconst);
frexpr(rconst);
return((expptr) p);
}

#if SZINT < SZLONG
/*
   for efficient subscripting, replace long ints by shorts
   in easy places
*/

expptr shorten(p)
register expptr p;
{
register expptr q;

if(p->headblock.vtype != TYLONG)
	return(p);

switch(p->tag)
	{
	case TERROR:
	case TLIST:
		return(p);

	case TCONST:
	case TADDR:
		return( mkconv(TYINT,p) );

	case TEXPR:
		break;

	default:
		badtag("shorten", p->tag);
	}

switch(p->exprblock.opcode)
	{
	case OPPLUS:
	case OPMINUS:
	case OPSTAR:
		q = shorten( cpexpr(p->exprblock.rightp) );
		if(q->headblock.vtype == TYINT)
			{
			p->exprblock.leftp = shorten(p->exprblock.leftp);
			if(p->exprblock.leftp->headblock.vtype == TYLONG)
				frexpr(q);
			else
				{
				frexpr(p->exprblock.rightp);
				p->exprblock.rightp = q;
				p->exprblock.vtype = TYINT;
				}
			}
		break;

	case OPNEG:
	case OPPAREN:
		p->exprblock.leftp = shorten(p->exprblock.leftp);
		if(p->exprblock.leftp->headblock.vtype == TYINT)
			p->exprblock.vtype = TYINT;
		break;

	case OPCALL:
	case OPCCALL:
		p = mkconv(TYINT,p);
		break;
	default:
		break;
	}

return(p);
}
#endif

/* fix an argument list, taking due care for special first level cases */

fixargs(doput, p0)
int doput;	/* doput is true if the function is not intrinsic;
		   was used to decide whether to do a putconst,
		   but this is no longer done here (Feb82)*/
struct Listblock *p0;
{
register chainp p;
register tagptr q, t;
register int qtag;
int nargs;
Addrp mkscalar();

nargs = 0;
if(p0)
    for(p = p0->listp ; p ; p = p->nextp)
	{
	++nargs;
	q = p->datap;
	qtag = q->tag;
	if(qtag == TCONST)
		{
		if(q->constblock.vtype == TYSHORT)
			q = (tagptr) mkconv(tyint, q);
		p->datap = q ;
		}
	else if(qtag==TPRIM && q->primblock.argsp==0 &&
		q->primblock.namep->vclass==CLPROC)
			p->datap = (tagptr) mkaddr(q->primblock.namep);
	else if(qtag==TPRIM && q->primblock.argsp==0 &&
		q->primblock.namep->vdim!=NULL)
			p->datap = (tagptr) mkscalar(q->primblock.namep);
	else if(qtag==TPRIM && q->primblock.argsp==0 &&
		q->primblock.namep->vdovar && 
		(t = (tagptr) memversion(q->primblock.namep)) )
			p->datap = (tagptr) fixtype(t);
	else
		p->datap = (tagptr) fixtype(q);
	}
return(nargs);
}


Addrp mkscalar(np)
register Namep np;
{
register Addrp ap;

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

#if TARGET == VAX
	/* on the VAX, prolog causes array arguments
	   to point at the (0,...,0) element, except when
	   subscript checking is on
	*/
#ifdef SDB
	if( !checksubs && !sdbflag && np->vstg==STGARG)
#else
	if( !checksubs && np->vstg==STGARG)
#endif
		{
		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) );
		}
#endif
return(ap);
}





expptr mkfunct(p)
register struct Primblock *p;
{
struct Entrypoint *ep;
Addrp ap;
struct Extsym *extp;
register Namep np;
register expptr q;
expptr intrcall(), stfcall();
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->varname)) )
			{
			np->vstg = STGINTR;
			np->vardesc.varno = k;
			np->vprocclass = PINTRINSIC;
			}
		else
			{
			extp = mkext( varunder(VL,np->varname) );
			extp->extstg = STGEXT;
			np->vstg = STGEXT;
			np->vardesc.varno = extp - extsymtab;
			np->vprocclass = PEXTERNAL;
			}
		}
	else if(np->vstg==STGARG)
		{
		if(np->vtype!=TYCHAR && !ftn66flag)
		    warn("Dummy procedure not declared EXTERNAL. Code may be wrong.");
		np->vprocclass = PEXTERNAL;
		}
	}

if(class != CLPROC)
	fatali("invalid class code %d for function", class);
if(p->fcharp || p->lcharp)
	{
	err("no substring of function call");
	goto error;
	}
impldcl(np);
nargs = fixargs( np->vprocclass!=PINTRINSIC,  p->argsp);

switch(np->vprocclass)
	{
	case PEXTERNAL:
		ap = mkaddr(np);
	call:
		q = mkexpr(OPCALL, ap, p->argsp);
		if( (q->exprblock.vtype = np->vtype) == TYUNKNOWN)
			{
			err("attempt to use untyped function");
			goto error;
			}
		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");
		for(ep = entries ; ep ; ep = ep->entnextp)
			if(ep->enamep == np)
				break;
		if(ep == NULL)
			fatal("mkfunct: impossible recursion");
		ap = builtin(np->vtype, varstr(XL, ep->entryname->extname) );
		goto call;

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

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



LOCAL expptr stfcall(np, actlist)
Namep np;
struct Listblock *actlist;
{
register chainp actuals;
int nargs;
chainp oactp, formals;
int type;
expptr q, rhs, ap;
Namep tnp;
register struct Rplblock *rp;
struct Rplblock *tlist;

if(actlist)
	{
	actuals = actlist->listp;
	free( (charptr) actlist);
	}
else
	actuals = NULL;
oactp = actuals;

nargs = 0;
tlist = NULL;
if( (type = np->vtype) == TYUNKNOWN)
	{
	err("attempt to use untyped statement function");
	q = errnode();
	goto ret;
	}
formals = (chainp) (np->varxptr.vstfdesc->datap);
rhs = (expptr) (np->varxptr.vstfdesc->nextp);

/* copy actual arguments into temporaries */
while(actuals!=NULL && formals!=NULL)
	{
	rp = ALLOC(Rplblock);
	rp->rplnp = tnp = (Namep) (formals->datap);
	ap = fixtype(actuals->datap);
	if(tnp->vtype==ap->headblock.vtype && tnp->vtype!=TYCHAR
	   && (ap->tag==TCONST || ap->tag==TADDR || ap->tag==TTEMP) )
		{
		rp->rplvp = (expptr) ap;
		rp->rplxp = NULL;
		rp->rpltag = ap->tag;
		}
	else	{
		rp->rplvp = (expptr) mktemp(tnp->vtype, tnp->vleng);
		rp->rplxp = fixtype( mkexpr(OPASSIGN, cpexpr(rp->rplvp), ap) );
		if( (rp->rpltag = rp->rplxp->tag) == TERROR)
			err("disagreement of argument types in statement function call");
		else if(tnp->vtype!=ap->headblock.vtype)
			warn("argument type mismatch in statement function");
		}
	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;
	}

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

/* 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(rpllist);
	rpllist = rp;
	}

ret:
	frchain( &oactp );
	return(q);
}




Addrp mkplace(np)
register Namep np;
{
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)
		{
		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->issaved = np->vsave;
		s->memno = regn;
		s->memoffset = ICON(0);
		return(s);
		}

vardcl(np);
return(mkaddr(np));
}




expptr mklhs(p)
register struct Primblock *p;
{
expptr suboffset();
register Addrp s;
Namep np;

if(p->tag != TPRIM)
	return( (expptr) p );
np = p->namep;

s = mkplace(np);
if(s->tag!=TADDR || s->vstg==STGREG)
	{
	free( (charptr) p );
	return( (expptr) s );
	}

/* compute the address modified by subscripts */

s->memoffset = mkexpr(OPPLUS, s->memoffset, suboffset(p) );
frexpr(p->argsp);
p->argsp = NULL;

/* now do substring part */

if(p->fcharp || p->lcharp)
	{
	if(np->vtype != TYCHAR)
		errstr("substring of noncharacter %s", varstr(VL,np->varname));
	else	{
		if(p->lcharp == NULL)
			p->lcharp = (expptr) cpexpr(s->vleng);
		frexpr(s->vleng);
		if(p->fcharp)
			{
			if(p->fcharp->tag == TPRIM && p->lcharp->tag == TPRIM
			&& p->fcharp->primblock.namep == p->lcharp->primblock.namep)
				/* A trivial optimization -- upper == lower */
				s->vleng = ICON(1);
			else
				s->vleng = mkexpr(OPMINUS, p->lcharp,
					mkexpr(OPMINUS, p->fcharp, ICON(1) ));
			}
		else
			s->vleng = p->lcharp;
		}
	}

s->vleng = fixtype( s->vleng );
s->memoffset = fixtype( s->memoffset );
free( (charptr) p );
return( (expptr) s );
}





deregister(np)
Namep np;
{
if(nregvar>0 && regnamep[nregvar-1]==np)
	{
	--nregvar;
#if FAMILY == DMR
	putnreg();
#endif
	}
}




Addrp memversion(np)
register Namep np;
{
register Addrp s;

if(np->vdovar==NO || (inregister(np)<0) )
	return(NULL);
np->vdovar = NO;
s = mkplace(np);
np->vdovar = YES;
return(s);
}



inregister(np)
register Namep np;
{
register int i;

for(i = 0 ; i < nregvar ; ++i)
	if(regnamep[i] == np)
		return( regnum[i] );
return(-1);
}




enregister(np)
Namep np;
{
if( inregister(np) >= 0)
	return(YES);
if(nregvar >= maxregvar)
	return(NO);
vardcl(np);
if( ONEOF(np->vtype, MSKIREG) )
	{
	regnamep[nregvar++] = np;
	if(nregvar > highregvar)
		highregvar = nregvar;
#if FAMILY == DMR
	putnreg();
#endif
	return(YES);
	}
else
	return(NO);
}