expr.c

unix v7是最后一个广泛发布的研究型UNIX版本

#include "defs"

/* little routines to create constant blocks */

struct constblock *mkconst(t)
register int t;
{
register struct constblock *p;

p = ALLOC(constblock);
p->tag = TCONST;
p->vtype = t;
return(p);
}


struct constblock *mklogcon(l)
register int l;
{
register struct constblock * p;

p = mkconst(TYLOGICAL);
p->const.ci = l;
return(p);
}



struct constblock *mkintcon(l)
ftnint l;
{
register struct constblock *p;

p = mkconst(TYLONG);
p->const.ci = l;
#ifdef MAXSHORT
	if(l >= -MAXSHORT   &&   l <= MAXSHORT)
		p->vtype = TYSHORT;
#endif
return(p);
}



struct constblock *mkaddcon(l)
register int l;
{
register struct constblock *p;

p = mkconst(TYADDR);
p->const.ci = l;
return(p);
}



struct constblock *mkrealcon(t, d)
register int t;
double d;
{
register struct constblock *p;

p = mkconst(t);
p->const.cd[0] = d;
return(p);
}


struct constblock *mkbitcon(shift, leng, s)
int shift;
int leng;
char *s;
{
register struct constblock *p;

p = mkconst(TYUNKNOWN);
p->const.ci = 0;
while(--leng >= 0)
	if(*s != ' ')
		p->const.ci = (p->const.ci << shift) | hextoi(*s++);
return(p);
}





struct constblock *mkstrcon(l,v)
int l;
register char *v;
{
register struct constblock *p;
register char *s;

p = mkconst(TYCHAR);
p->vleng = ICON(l);
p->const.ccp = s = (char *) ckalloc(l);
while(--l >= 0)
	*s++ = *v++;
return(p);
}


struct constblock *mkcxcon(realp,imagp)
register expptr realp, imagp;
{
int rtype, itype;
register struct constblock *p;

rtype = realp->vtype;
itype = imagp->vtype;

if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
	{
	p = mkconst( (rtype==TYDREAL||itype==TYDREAL) ? TYDCOMPLEX : TYCOMPLEX );
	if( ISINT(rtype) )
		p->const.cd[0] = realp->const.ci;
	else	p->const.cd[0] = realp->const.cd[0];
	if( ISINT(itype) )
		p->const.cd[1] = imagp->const.ci;
	else	p->const.cd[1] = imagp->const.cd[0];
	}
else
	{
	err("invalid complex constant");
	p = errnode();
	}

frexpr(realp);
frexpr(imagp);
return(p);
}


struct errorblock *errnode()
{
struct errorblock *p;
p = ALLOC(errorblock);
p->tag = TERROR;
p->vtype = TYERROR;
return(p);
}





expptr mkconv(t, p)
register int t;
register expptr p;
{
register expptr q;
register int pt;
expptr opconv();

if(t==TYUNKNOWN || t==TYERROR)
	fatal1("mkconv of impossible type %d", t);
pt = p->vtype;
if(t == pt)
	return(p);

else if( ISCONST(p) && pt!=TYADDR)
	{
	q = mkconst(t);
	consconv(t, &(q->const), p->vtype, &(p->const));
	frexpr(p);
	}
#if TARGET == PDP11
	else if(ISINT(t) && pt==TYCHAR)
		{
		q = mkexpr(OPBITAND, opconv(p,TYSHORT), ICON(255));
		if(t == TYLONG)
			q = opconv(q, TYLONG);
		}
#endif
else
	q = opconv(p, t);

if(t == TYCHAR)
	q->vleng = ICON(1);
return(q);
}



expptr opconv(p, t)
expptr p;
int t;
{
register expptr q;

q = mkexpr(OPCONV, p, 0);
q->vtype = t;
return(q);
}



struct exprblock *addrof(p)
expptr p;
{
return( mkexpr(OPADDR, p, NULL) );
}



tagptr cpexpr(p)
register tagptr p;
{
register tagptr e;
int tag;
register chainp ep, pp;
ptr cpblock();

static int blksize[ ] =
	{	0,
		sizeof(struct nameblock),
		sizeof(struct constblock),
		sizeof(struct exprblock),
		sizeof(struct addrblock),
		sizeof(struct primblock),
		sizeof(struct listblock),
		sizeof(struct errorblock)
	};

if(p == NULL)
	return(NULL);

if( (tag = p->tag) == TNAME)
	return(p);

e = cpblock( blksize[p->tag] , p);

switch(tag)
	{
	case TCONST:
		if(e->vtype == TYCHAR)
			{
			e->const.ccp = copyn(1+strlen(e->const.ccp), e->const.ccp);
			e->vleng = cpexpr(e->vleng);
			}
	case TERROR:
		break;

	case TEXPR:
		e->leftp = cpexpr(p->leftp);
		e->rightp = cpexpr(p->rightp);
		break;

	case TLIST:
		if(pp = p->listp)
			{
			ep = e->listp = mkchain( cpexpr(pp->datap), NULL);
			for(pp = pp->nextp ; pp ; pp = pp->nextp)
				ep = ep->nextp = mkchain( cpexpr(pp->datap), NULL);
			}
		break;

	case TADDR:
		e->vleng = cpexpr(e->vleng);
		e->memoffset = cpexpr(e->memoffset);
		e->istemp = NO;
		break;

	case TPRIM:
		e->argsp = cpexpr(e->argsp);
		e->fcharp = cpexpr(e->fcharp);
		e->lcharp = cpexpr(e->lcharp);
		break;

	default:
		fatal1("cpexpr: impossible tag %d", tag);
	}

return(e);
}

frexpr(p)
register tagptr p;
{
register chainp q;

if(p == NULL)
	return;

switch(p->tag)
	{
	case TCONST:
		if( ISCHAR(p) )
			{
			free(p->const.ccp);
			frexpr(p->vleng);
			}
		break;

	case TADDR:
		if(p->istemp)
			{
			frtemp(p);
			return;
			}
		frexpr(p->vleng);
		frexpr(p->memoffset);
		break;

	case TERROR:
		break;

	case TNAME:
		return;

	case TPRIM:
		frexpr(p->argsp);
		frexpr(p->fcharp);
		frexpr(p->lcharp);
		break;

	case TEXPR:
		frexpr(p->leftp);
		if(p->rightp)
			frexpr(p->rightp);
		break;

	case TLIST:
		for(q = p->listp ; q ; q = q->nextp)
			frexpr(q->datap);
		frchain( &(p->listp) );
		break;

	default:
		fatal1("frexpr: impossible tag %d", p->tag);
	}

free(p);
}

/* fix up types in expression; replace subtrees and convert
   names to address blocks */

expptr fixtype(p)
register tagptr p;
{

if(p == 0)
	return(0);

switch(p->tag)
	{
	case TCONST:
		if( ! ONEOF(p->vtype, MSKINT|MSKLOGICAL|MSKADDR) )
			p = putconst(p);
		return(p);

	case TADDR:
		p->memoffset = fixtype(p->memoffset);
		return(p);

	case TERROR:
		return(p);

	default:
		fatal1("fixtype: impossible tag %d", p->tag);

	case TEXPR:
		return( fixexpr(p) );

	case TLIST:
		return( p );

	case TPRIM:
		if(p->argsp && p->namep->vclass!=CLVAR)
			return( mkfunct(p) );
		else	return( mklhs(p) );
	}
}





/* special case tree transformations and cleanups of expression trees */

expptr fixexpr(p)
register struct exprblock *p;
{
expptr lp;
register expptr rp;
register expptr q;
int opcode, ltype, rtype, ptype, mtype;
expptr mkpower();

if(p->tag == TERROR)
	return(p);
else if(p->tag != TEXPR)
	fatal1("fixexpr: invalid tag %d", p->tag);
opcode = p->opcode;
lp = p->leftp = fixtype(p->leftp);
ltype = lp->vtype;
if(opcode==OPASSIGN && lp->tag!=TADDR)
	{
	err("left side of assignment must be variable");
	frexpr(p);
	return( errnode() );
	}

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

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

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

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

	case OPASSIGN:
	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)
#if FAMILY==SCJ
		    && typesize[ltype]>=typesize[rtype] )
#else
		    && typesize[ltype]==typesize[rtype] )
#endif
			break;
		p->rightp = fixtype( mkconv(ptype, rp) );
		break;

	case OPSLASH:
		if( ISCOMPLEX(rtype) )
			{
			p = 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 && ! ISCONST(lp) ) ||
		    (rtype==TYREAL && ! ISCONST(rp) ) ))
			break;
		if( ISCOMPLEX(ptype) )
			break;
		if(ltype != ptype)
			p->leftp = fixtype(mkconv(ptype,lp));
		if(rtype != ptype)
			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 && ! ISCONST(lp)) ||
		    (rtype==TYREAL && ! ISCONST(rp)) ))
			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->opcode==OPCOMMA)
			{
			lp->rightp = fixtype( mkconv(ptype, lp->rightp) );
			free(p);
			p = lp;
			}
		break;

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

	case OPCOMMA:
	case OPQUEST:
	case OPCOLON:
		break;

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

	default:
		break;
	}

p->vtype = ptype;
return(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->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:
		fatal1("shorten: invalid tag %d", p->tag);
	}

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

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

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

return(p);
}
#endif

fixargs(doput, p0)
int doput;
struct listblock *p0;
{
register chainp p;
register tagptr q, t;
register int qtag;
int nargs;
struct addrblock *mkaddr();

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


mkscalar(np)
register struct nameblock *np;
{
register struct addrblock *ap;
register struct dimblock *dp;

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
	*/
	if( !checksubs && np->vstg==STGARG)
		{
		dp = np->vdim;
		frexpr(ap->memoffset);
		ap->memoffset = mkexpr(OPSTAR, ICON(typesize[np->vtype]),
					cpexpr(dp->baseoffset) );
		}
#endif
return(ap);
}





expptr mkfunct(p)
register struct primblock * p;
{
struct entrypoint *ep;
struct addrblock *ap;
struct extsym *mkext(), *extp;
register struct nameblock *np;
register struct exprblock *q;
struct exprblock *intrcall(), *stfcall();
int k, nargs;
int class;

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

if(class == CLUNKNOWN)
	{
	np->vclass = class = CLPROC;
	if(np->vstg == STGUNKNOWN)
		{
		if(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)
	fatal1("invalid class code 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);
		q->vtype = np->vtype;
		if(np->vleng)
			q->vleng = cpexpr(np->vleng);
		break;

	case PINTRINSIC: