mk.c

<B>Digital的Unix操作系统VAX 4.2源码</B>

#include "defs"


ptr mkcomm(s)
register char *s;
{
register ptr p;
register char *t;

for(p = commonlist ; p ; p = p->nextp)
	if(equals(s, p->datap->comname))
		return(p->datap);

p = ALLOC(comentry);
for(t = p->comname ; *t++ = *s++ ; ) ;
p->tag = TCOMMON;
p->blklevel = (blklevel>0? 1 : 0);
commonlist = mkchain(p, commonlist);
return(commonlist->datap);
}




ptr mkname(s)
char *s;
{
char *copys();
register ptr p;

if( (p = name(s,1)) == 0)
	{
	p = name(s,0);
	p->tag = TNAME;
	p->blklevel = blklevel;
	}
return(p);
}

ptr mknode(t, o, l, r)
int t,o;
register ptr l;
register ptr r;
{
register struct exprblock *p;
ptr q;
int lt, rt;
int ll, rl;
ptr mksub1(), mkchcon();

p = allexpblock();
TEST fprintf(diagfile, "mknode(%d,%d,%o,%o) = %o\n", t, o, l, r, p);

top:
	if(t!=TLIST && t!=TCONST && l!=0 && l->tag==TERROR)
		{
		frexpr(r);
		frexpblock(p);
		return(l);
		}

	if(r!=0 && r->tag==TERROR)
		{
		frexpr(l);
		frexpblock(p);
		return(r);
		}
	p->tag = t;
	p->subtype = o;
	p->leftp = l;
	p->rightp = r;

switch(t)
	{
	case TAROP:
		ckdcl(l);
		ckdcl(r);
		switch(lt = l->vtype)
			{
			case TYCHAR:
			case TYSTRUCT:
			case TYLOG:
				exprerr("non-arithmetic operand of arith op","");
				goto err;
			}

		switch(rt = r->vtype)
			{
			case TYCHAR:
			case TYSTRUCT:
			case TYLOG:
				exprerr("non-arithmetic operand of arith op","");
				goto err;
			}
		if(lt==rt || (o==OPPOWER && rt==TYINT) )
			p->vtype = lt;
		else if( (lt==TYREAL && rt==TYLREAL) ||
			(lt==TYLREAL && rt==TYREAL) )
				p->vtype = TYLREAL;
		else if(lt==TYINT)
			{
			l = coerce(rt,l);
			goto top;
			}
		else if(rt==TYINT)
			{
			r = coerce(lt,r);
			goto top;
			}
		else if( (lt==TYREAL && rt==TYCOMPLEX) ||
			 (lt==TYCOMPLEX && rt==TYREAL) )
			p->vtype = TYCOMPLEX;
		else if( (lt==TYLREAL && rt==TYCOMPLEX) ||
			 (lt==TYCOMPLEX && rt==TYLREAL) )
			p->vtype = TYLCOMPLEX;
		else	{
			exprerr("mixed mode", CNULL);
			goto err;
			}

		if( (o==OPPLUS||o==OPSTAR) && l->tag==TCONST && r->tag!=TCONST )
			{
			p->leftp = r;
			p->rightp = l;
			}

		if(o==OPPLUS && l->tag==TNEGOP &&
		  (r->tag!=TCONST || l->leftp->tag==TCONST) )
			{
			p->subtype = OPMINUS;
			p->leftp = r;
			p->rightp = l->leftp;
			}

		break;

	case TRELOP:
		ckdcl(l);
		ckdcl(r);
		p->vtype = TYLOG;
		lt = l->vtype;
		rt = r->vtype;
		if(lt==TYCHAR || rt==TYCHAR)
			{
			if(l->vtype != r->vtype)
				{
				exprerr("comparison of character and noncharacter data",CNULL);
				goto err;
				}
			ll = conval(l->vtypep);
			rl = conval(r->vtypep);
			if( (o==OPEQ || o==OPNE) &&
				( (ll==1 && rl==1 && tailor.charcomp==1)
				|| (ll<=tailor.ftnchwd && rl<=tailor.ftnchwd
				&& tailor.charcomp==2) ))
				{
				if(l->tag == TCONST)
					{
					q = cpexpr( mkchcon(l->leftp) );
					frexpr(l);
					l = q;
					}
				if(r->tag == TCONST)
					{
					q = cpexpr( mkchcon(r->leftp) );
					frexpr(r);
					r = q;
					}
				if(l->vsubs == 0)
					l->vsubs = mksub1();
				if(r->vsubs == 0)
					r->vsubs = mksub1();
				p->leftp = l;
				p->rightp = r;
				}
			else	{
				p->leftp = mkcall(builtin(TYINT,"ef1cmc"), arg4(l,r));
				p->rightp = mkint(0);
				}
			}

		else if(lt==TYLOG || rt==TYLOG)
			exprerr("relational involving logicals", CNULL);
		else if( (lt==TYCOMPLEX || rt==TYCOMPLEX) &&
			o!=OPEQ && o!=OPNE)
				exprerr("order comparison of complex numbers", CNULL);
		else if(lt != rt)
			{
			if(lt==TYINT)
				p->leftp = coerce(rt, l);
			else if(rt == TYINT)
				p->rightp = coerce(lt, r);
			}
		break;

	case TLOGOP:
		ckdcl(l);
		ckdcl(r);
		if(r->vtype != TYLOG)
			{
			exprerr("non-logical operand of logical operator",CNULL);
			goto err;
			}
	case TNOTOP:
		ckdcl(l);
		if(l->vtype != TYLOG)
			{
			exprerr("non-logical operand of logical operator",CNULL);
			}
		p->vtype = TYLOG;
		break;

	case TNEGOP:
		ckdcl(l);
		lt = l->vtype;
		if(lt!=TYINT && lt!=TYREAL && lt!=TYLREAL && lt!=TYCOMPLEX)
			{
			exprerr("impossible unary + or - operation",CNULL);
			goto err;
			}
		p->vtype = lt;
		break;

	case TCALL:
		p->vtype = l->vtype;
		p->vtypep = l->vtypep;
		break;

	case TASGNOP:
		ckdcl(l);
		ckdcl(r);
		lt = l->vtype;
		if(lt==TYFIELD)
			lt = TYINT;
		rt = r->vtype;
		if(lt==TYCHAR || rt==TYCHAR || lt==TYLOG || rt==TYLOG)
			{
			if(lt != rt)
				{
				exprerr("illegal assignment",CNULL);
				goto err;
				}
			}
		else if(lt==TYSTRUCT || rt==TYSTRUCT)
			{
			if(lt!=rt || l->vtypep->strsize!=r->vtypep->strsize
				|| l->vtypep->stralign!=r->vtypep->stralign)
				{
				exprerr("illegal structure assignment",CNULL);
				goto err;
				}
			}
		else if ( (lt==TYCOMPLEX || rt==TYCOMPLEX) && lt!=rt)
/*			p->rightp = r = coerce(lt, r) */ ;

		p->vtype = lt;
		p->vtypep = l->vtypep;
		break;

	case TCONST:
	case TLIST:
	case TREPOP:
		break;

	default:
		badtag("mknode", t);
	}

return(p);

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



ckdcl(p)
ptr p;
{
if(p->vtype==TYUNDEFINED || (p->tag==TNAME&&p->vdcldone==0&&p->vadjdim==0))
	{
/*debug*/ printf("tag=%d, typed=%d\n", p->tag, p->vtype);
	fatal("untyped subexpression");
	}
if(p->tag==TNAME) setvproc(p,PROCNO);
}

ptr mkvar(p)
register ptr p;
{
register ptr q;

TEST fprintf(diagfile, "mkvar(%s), blk %d\n", p->namep, blklevel);

if(p->blklevel > blklevel)
	p->blklevel = blklevel;

if(instruct || p->varp==0 || p->varp->blklevel<blklevel)
	{
	q = allexpblock();
	q->tag = TNAME;
	q->sthead = p;
	q->blklevel = blklevel;
	if(! instruct)
		++ndecl[blklevel];
	}
else q = p->varp;

if(!instruct)
	{
	if(p->varp && p->varp->blklevel<blklevel)
		hide(p);
	if(p->varp == 0)
		p->varp = q;
	}

p->tag = TNAME;
return(q);
}


ptr mkstruct(v,s)
register ptr v;
ptr s;
{
register ptr p;

p = ALLOC(typeblock);
p->sthead = v;
p->tag = TSTRUCT;
p->blklevel = blklevel;
p->strdesc = s;
offsets(p);
if(v)	{
	v->blklevel = blklevel;
	++ndecl[blklevel];
	v->varp = p;
	}
else	temptypelist = mkchain(p, temptypelist);
return(p);
}


ptr mkcall(fn1, args)
ptr fn1, args;
{
int i, j, first;
register ptr funct, p, q;
ptr r;

if(fn1->tag == TERROR)
	return( errnode() );
else if(fn1->tag == TNAME)
	{
	funct = fn1->sthead->varp;
	frexpblock(fn1);
	}
else
	funct = fn1;
if(funct->vclass!=0 && funct->vclass!=CLARG)
	{
	exprerr("invalid invocation of %s",funct->sthead->namep);
	frexpr(args);
	return( errnode() );
	}
else	extname(funct);

if(args)  for(p = args->leftp; p ; p = p->nextp)
	{
	q = p->datap;
	if( (q->tag==TCALL&&q->vtype==TYUNDEFINED) ||
	    (q->tag==TNAME&&q->vdcldone==0) )
		dclit(q);
	if(q->tag==TNAME && q->vproc==PROCUNKNOWN)
		setvproc(q, PROCNO);
	if( q->vtype == TYSTRUCT)
		{
		first = 1;
		for(i = 0; i<NFTNTYPES ; ++i)
			if(q->vbase[i] != 0)
				{
				r = cpexpr(q);
				if(first)
					{
					p->datap = r;
					first = 0;
					}
				else	p = p->nextp = mkchain(r, p->nextp);
				r->vtype = ftnefl[i];
				for(j=0; j<NFTNTYPES; ++j)
					if(i != j) r->vbase[j] = 0;
				}
		frexpblock(q);
		}
	}

return( mknode(TCALL,0,cpexpr(funct), args) );
}



mkcase(p,here)
ptr p;
int here;
{
register ptr q, s;

for(s = thisctl ; s!=0 && s->subtype!=STSWITCH ; s = s->prevctl)
	;
if(s==0 || (here && s!=thisctl) )
	{
	laberr("invalid case label location",CNULL);
	return(0);
	}
for(q = s->loopctl ; q!=0 && !eqcon(p,q->casexpr) ; q = q->nextcase)
	;
if(q == 0)
	{
	q = ALLOC(caseblock);
	q->tag = TCASE;
	q->casexpr = p;
	q->labelno = ( here ? thislab() : nextlab() );
	q->nextcase = s->loopctl;
	s->loopctl = q;
	}
else if(here)
	if(thisexec->labelno == 0)
		thisexec->labelno = q->labelno;
	else if(thisexec->labelno != q->labelno)
		{
		exnull();
		thisexec->labelno = q->labelno;
		thisexec->labused = 0;
		}
if(here)
	if(q->labdefined)
		laberr("multiply defined case",CNULL);
	else
		q->labdefined = 1;
return(q->labelno);
}


ptr mkilab(p)
ptr p;
{
char *s, l[30];

if(p->tag!=TCONST || p->vtype!=TYINT)
	{
	execerr("invalid label","");
	s = "";
	}
else	s = p->leftp;

while(*s == '0')
	++s;
sprintf(l,"#%s", s);


TEST fprintf(diagfile,"numeric label = %s\n", l);
return( mkname(l) );
}




mklabel(p,here)
ptr p;
int here;
{
register ptr q;

if(q = p->varp)
	{
	if(q->tag != TLABEL)
		laberr("%s is already a nonlabel\n", p->namep);
	else if(q->labinacc)
		warn1("label %s is inaccessible", p->namep);
	else if(here)
		if(q->labdefined)
			laberr("%s is already defined\n", p->namep);
		else if(blklevel > q->blklevel)
			laberr("%s is illegally placed\n",p->namep);
		else	{
			q->labdefined = 1;
			if(thisexec->labelno == 0)
				thisexec->labelno = q->labelno;
			else if(thisexec->labelno != q->labelno)
				{
				exnull();
				thisexec->labelno = q->labelno;
				thisexec->labused = 0;
				}
			}
	}