expr.c

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

		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->nextp)
			if(ep->enamep == np)
				break;
		if(ep == NULL)
			fatal("mkfunct: impossible recursion");
		ap = builtin(np->vtype, varstr(XL, ep->entryname->extname) );
		goto call;

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

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



LOCAL struct exprblock *stfcall(np, actlist)
struct nameblock *np;
struct listblock *actlist;
{
register chainp actuals;
int nargs;
chainp oactp, formals;
int type;
struct exprblock *q, *rhs;
expptr ap;
register struct rplblock *rp;
struct rplblock *tlist;

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

nargs = 0;
tlist = NULL;
type = np->vtype;
formals = np->vardesc.vstfdesc->datap;
rhs = np->vardesc.vstfdesc->nextp;

/* copy actual arguments into temporaries */
while(actuals!=NULL && formals!=NULL)
	{
	rp = ALLOC(rplblock);
	rp->rplnp = q = formals->datap;
	ap = fixtype(actuals->datap);
	if(q->vtype==ap->vtype && q->vtype!=TYCHAR
	   && (ap->tag==TCONST || ap->tag==TADDR) )
		{
		rp->rplvp = ap;
		rp->rplxp = NULL;
		rp->rpltag = ap->tag;
		}
	else	{
		rp->rplvp = mktemp(q->vtype, q->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");
		}
	rp->nextp = 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
*/
rpllist = hookup(tlist, rpllist);
q = 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->nextp;
	frexpr(rpllist->rplvp);
	free(rpllist);
	rpllist = rp;
	}

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




struct addrblock *mklhs(p)
register struct primblock * p;
{
register struct addrblock *s;
expptr suboffset();
struct nameblock *np;
register struct rplblock *rp;
int regn;

/* first fixup name */

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

/* is name on the replace list? */

for(rp = rpllist ; rp ; rp = rp->nextp)
	{
	if(np == rp->rplnp)
		{
		if(rp->rpltag == TNAME)
			{
			np = p->namep = rp->rplvp;
			break;
			}
		else	return( cpexpr(rp->rplvp) );
		}
	}

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

if(np->vdovar && ( (regn = inregister(np)) >= 0) )
	if(np->vtype == TYERROR)
		return( errnode() );
	else
		{
		s = ALLOC(addrblock);
		s->tag = TADDR;
		s->vstg = STGREG;
		s->vtype = TYIREG;
		s->memno = regn;
		s->memoffset = ICON(0);
		return(s);
		}

vardcl(np);
s = mkaddr(np);
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)
		err1("substring of noncharacter %s", varstr(VL,np->varname));
	else	{
		if(p->lcharp == NULL)
			p->lcharp = cpexpr(s->vleng);
		if(p->fcharp)
			s->vleng = mkexpr(OPMINUS, p->lcharp,
				mkexpr(OPMINUS, p->fcharp, ICON(1) ));
		else	{
			frexpr(s->vleng);
			s->vleng = p->lcharp;
			}
		}
	}

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





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




struct addrblock *memversion(np)
register struct nameblock *np;
{
register struct addrblock *s;

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



inregister(np)
register struct nameblock *np;
{
register int i;

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




enregister(np)
struct nameblock *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);
}




expptr suboffset(p)
register struct primblock *p;
{
int n;
expptr size;
chainp cp;
expptr offp, prod;
expptr subcheck();
struct dimblock *dimp;
expptr sub[8];
register struct nameblock *np;

np = p->namep;
offp = ICON(0);
n = 0;
if(p->argsp)
	for(cp = p->argsp->listp ; cp ; cp = cp->nextp)
		{
		sub[n++] = fixtype(cpexpr(cp->datap));
		if(n > 7)
			{
			err("more than 7 subscripts");
			break;
			}
		}

dimp = np->vdim;
if(n>0 && dimp==NULL)
	err("subscripts on scalar variable");
else if(dimp && dimp->ndim!=n)
	err1("wrong number of subscripts on %s",
		varstr(VL, np->varname) );
else if(n > 0)
	{
	prod = sub[--n];
	while( --n >= 0)
		prod = mkexpr(OPPLUS, sub[n],
			mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
#if TARGET == VAX
	if(checksubs || np->vstg!=STGARG)
		prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
#else
	prod = mkexpr(OPMINUS, prod, cpexpr(dimp->baseoffset));
#endif
	if(checksubs)
		prod = subcheck(np, prod);
	if(np->vtype == TYCHAR)
		size = cpexpr(np->vleng);
	else	size = ICON( typesize[np->vtype] );
	prod = mkexpr(OPSTAR, prod, size);
	offp = mkexpr(OPPLUS, offp, prod);
	}

if(p->fcharp && np->vtype==TYCHAR)
	offp = mkexpr(OPPLUS, offp, mkexpr(OPMINUS, cpexpr(p->fcharp), ICON(1) ));

return(offp);
}




expptr subcheck(np, p)
struct nameblock *np;
register expptr p;
{
struct dimblock *dimp;
expptr t, checkvar, checkcond, badcall;

dimp = np->vdim;
if(dimp->nelt == NULL)
	return(p);	/* don't check arrays with * bounds */
checkvar = NULL;
checkcond = NULL;
if( ISICON(p) )
	{
	if(p->const.ci < 0)
		goto badsub;
	if( ISICON(dimp->nelt) )
		if(p->const.ci < dimp->nelt->const.ci)
			return(p);
		else
			goto badsub;
	}
if(p->tag==TADDR && p->vstg==STGREG)
	{
	checkvar = cpexpr(p);
	t = p;
	}
else	{
	checkvar = mktemp(p->vtype, NULL);
	t = mkexpr(OPASSIGN, cpexpr(checkvar), p);
	}
checkcond = mkexpr(OPLT, t, cpexpr(dimp->nelt) );
if( ! ISICON(p) )
	checkcond = mkexpr(OPAND, checkcond,
			mkexpr(OPLE, ICON(0), cpexpr(checkvar)) );

badcall = call4(p->vtype, "s_rnge", mkstrcon(VL, np->varname),
		mkconv(TYLONG,  cpexpr(checkvar)),
		mkstrcon(XL, procname), ICON(lineno));
badcall->opcode = OPCCALL;
p = mkexpr(OPQUEST, checkcond,
	mkexpr(OPCOLON, checkvar, badcall));

return(p);

badsub:
	frexpr(p);
	err1("subscript on variable %s out of range", varstr(VL,np->varname));
	return ( ICON(0) );
}




struct addrblock *mkaddr(p)
register struct nameblock *p;
{
struct extsym *mkext(), *extp;
register struct addrblock *t;
struct addrblock *intraddr();

switch( p->vstg)
	{
	case STGUNKNOWN:
		if(p->vclass != CLPROC)
			break;
		extp = mkext( varunder(VL, p->varname) );
		extp->extstg = STGEXT;
		p->vstg = STGEXT;
		p->vardesc.varno = extp - extsymtab;
		p->vprocclass = PEXTERNAL;

	case STGCOMMON:
	case STGEXT:
	case STGBSS:
	case STGINIT:
	case STGEQUIV:
	case STGARG:
	case STGLENG:
	case STGAUTO:
		t = ALLOC(addrblock);
		t->tag = TADDR;
		if(p->vclass==CLPROC && p->vprocclass==PTHISPROC)
			t->vclass = CLVAR;
		else
			t->vclass = p->vclass;
		t->vtype = p->vtype;
		t->vstg = p->vstg;
		t->memno = p->vardesc.varno;
		t->memoffset = ICON(p->voffset);
		if(p->vleng)
			t->vleng = cpexpr(p->vleng);
		return(t);

	case STGINTR:
		return( intraddr(p) );

	}
/*debug*/ fprintf(diagfile, "mkaddr. vtype=%d, vclass=%d\n", p->vtype, p->vclass);
fatal1("mkaddr: impossible storage tag %d", p->vstg);
/* NOTREACHED */
}




mkarg(type, argno)
int type, argno;
{
register struct addrblock *p;

p = ALLOC(addrblock);
p->tag = TADDR;
p->vtype = type;
p->vclass = CLVAR;
p->vstg = (type==TYLENG ? STGLENG : STGARG);
p->memno = argno;
return(p);
}




tagptr mkprim(v, args, lstr, rstr)
register union { struct paramblock; struct nameblock; } *v;
struct listblock *args;
expptr lstr, rstr;
{
register struct primblock *p;

if(v->vclass == CLPARAM)
	{
	if(args || lstr || rstr)
		{
		err1("no qualifiers on parameter name", varstr(VL,v->varname));
		frexpr(args);
		frexpr(lstr);
		frexpr(rstr);
		frexpr(v);
		return( errnode() );
		}
	return( cpexpr(v->paramval) );
	}

p = ALLOC(primblock);
p->tag = TPRIM;
p->vtype = v->vtype;
p->namep = v;
p->argsp = args;
p->fcharp = lstr;
p->lcharp = rstr;
return(p);
}



vardcl(v)
register struct nameblock *v;
{
int nelt;
struct dimblock *t;
struct addrblock *p;
expptr neltp;

if(v->vdcldone) return;

if(v->vtype == TYUNKNOWN)
	impldcl(v);
if(v->vclass == CLUNKNOWN)
	v->vclass = CLVAR;
else if(v->vclass!=CLVAR && v->vprocclass!=PTHISPROC)
	{
	dclerr("used as variable", v);
	return;
	}
if(v->vstg==STGUNKNOWN)
	v->vstg = implstg[ letter(v->varname[0]) ];

switch(v->vstg)
	{
	case STGBSS:
		v->vardesc.varno = ++lastvarno;
		break;
	case STGAUTO:
		if(v->vclass==CLPROC && v->vprocclass==PTHISPROC)
			break;
		nelt = 1;
		if(t = v->vdim)
			if( (neltp = t->nelt) && ISCONST(neltp) )
				nelt = neltp->const.ci;
			else
				dclerr("adjustable automatic array", v);
		p = autovar(nelt, v->vtype, v->vleng);
		v->voffset = p->memoffset->const.ci;
		frexpr(p);
		break;

	default:
		break;
	}
v->vdcldone = YES;
}




impldcl(p)
register struct nameblock *p;
{
register int k;
int type, leng;

if(p->vdcldone || (p->vclass==CLPROC && p->vprocclass==PINTRINSIC) )
	return;
if(p->vtype == TYUNKNOWN)
	{
	k = letter(p->varname[0]);
	type = impltype[ k ];
	leng = implleng[ k ];
	if(type == TYUNKNOWN)
		{
		if(p->vclass == CLPROC)
			return;
		dclerr("attempt to use undefined variable", p);
		type = TYERROR;
		leng = 1;
		}
	settype(p, type, leng);
	}
}




LOCAL letter(c)
register int c;
{
if( isupper(c) )
	c = tolower(c);
return(c - 'a');
}

#define ICONEQ(z, c)  (ISICON(z) && z->const.ci==c)
#define COMMUTE	{ e = lp;  lp = rp;  rp = e; }


expptr mkexpr(opcode, lp, rp)
int opcode;
register expptr lp, rp;
{
register struct exprblock *e, *e1;
int etype;
int ltype, rtype;
int ltag, rtag;
expptr fold();

ltype = lp->vtype;
ltag = lp->tag;
if(rp && opcode!=OPCALL && opcode!=OPCCALL)
	{
	rtype = rp->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->const.ci == 0)
				goto retright;
			goto mulop;
			}
		break;

	case OPSLASH:
	case OPMOD:
		if( ICONEQ(rp, 0) )
			{
			err("attempted division by zero");
			rp = ICON(1);
			break;
			}
		if(opcode == OPMOD)
			break;


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

			if(rp->const.ci == -1)
				{
				frexpr(rp);
				return( mkexpr(OPNEG, lp, 0) );
				}
			}

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

			e1 = lp->leftp;
			free(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, 0) );
			}

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

	addop:
		if( ISICON(rp) )
			{
			if(rp->const.ci == 0)
				goto retleft;
			if( ISPLUSOP(lp) && ISICON(lp->rightp) )
				{
				e = mkexpr(OPPLUS, lp->rightp, rp);
				e1 = lp->leftp;
				free(lp);
				return( mkexpr(OPPLUS, e1, e) );
				}
			}
		break;


	case OPPOWER:
		break;

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

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

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

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

		if( ISCONST(rp) )
			{
			if(rp->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: