mk.c

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

else	{
	q = ALLOC(labelblock);
	p->varp = q;
	q->tag = TLABEL;
	q->subtype = 0;
	q->blklevel = blklevel;
	++ndecl[blklevel];
	q->labdefined = here;
	q->labelno = ( here ? thislab() : nextlab() );
	q->sthead = p;
	}

return(q->labelno);
}


thislab()
{
if(thisexec->labelno == 0)
	thisexec->labelno = nextlab();
return(thisexec->labelno);
}


nextlab()
{
stnos[++labno] = 0;
return( labno );
}


nextindif()
{
if(++nxtindif < MAXINDIFS)
	return(nxtindif);
fatal("too many indifs");
}




mkkeywd(s, n)
char *s;
int n;
{
register ptr p;
register ptr q;

p = name(s, 2);
q = ALLOC(keyblock);
p->tag = TKEYWORD;
q->tag = TKEYWORD;
p->subtype = n;
q->subtype = n;
p->blklevel = 0;
p->varp = q;
q->sthead = p;
}


ptr mkdef(s, v)
char *s, *v;
{
register ptr p;
register ptr q;

if(p = name(s,1))
	if(p->blklevel == 0)
		{
		if(blklevel > 0)
			hide(p);
		else if(p->tag != TDEFINE)
			dclerr("attempt to DEFINE a variable name", s);
		else	{
			if( strcmp(v, (q=p->varp) ->valp) )
				{
				warn("macro value replaced");
				cfree(q->valp);
				q->valp = copys(v);
				}
			return(p);
			}
		}
	else	{
		dclerr("type already defined", s);
		return( errnode() );
		}
else   p = name(s,0);

q = ALLOC(defblock);
p->tag = TDEFINE;
q->tag = TDEFINE;
p->blklevel = q->blklevel = (blklevel==0 ? 0 : 1);
q->sthead = p;
p->varp = q;
p->varp->valp = copys(v);
return(p);
}



mkknown(s,t)
char *s;
int t;
{
register ptr p;

p = ALLOC(knownname);
p->nextfunct = knownlist;
p->tag = TKNOWNFUNCT;
knownlist = p;
p->funcname = s;
p->functype = t;
}







ptr mkint(k)
int k;
{
return( mkconst(TYINT, convic(k) ) );
}


ptr mkconst(t,p)
int t;
ptr p;
{
ptr q;

q = mknode(TCONST, 0, copys(p), PNULL);
q->vtype = t;
if(t == TYCHAR)
	q->vtypep = mkint( strlen(p) );
return(q);
}



ptr mkimcon(t,p)
int t;
char *p;
{
ptr q;
char *zero, buff[100];

zero = (t==TYCOMPLEX ? "0." : "0d0");
sprintf(buff, "(%s,%s)", zero, p);
q = mknode(TCONST, 0, copys(buff), PNULL);
q->vtype = t;
return(q);
}



ptr mkarrow(p,t)
register ptr p;
ptr t;
{
register ptr q, s;

if(p->vsubs == 0)
	if(p->vdim==0 && p->vtype!=TYCHAR && p->vtype!=TYSTRUCT)
		{
		exprerr("need an aggregate to the left of arrow",CNULL);
		frexpr(p);
		return( errnode() );
		}
	else	{
		if(p->vdim)
			{
			s = 0;
			for(q = p->vdim->datap ; q ; q = q->nextp)
				s = mkchain( mkint(1), s);
			subscript(p, mknode(TLIST,0,s,PNULL) );
			}
		}

p->vtype = TYSTRUCT;
p->vtypep = t->varp;
return(p);
}





mkequiv(p)
ptr p;
{
ptr q, t;
int first;

swii(iefile);
putic(ICBEGIN, 0);
putic(ICINDENT, 0);
putic(ICKEYWORD, FEQUIVALENCE);
putic(ICOP, OPLPAR);
first = 1;

for(q = p ; q ; q = q->nextp)
	{
	if(first)  first = 0;
	else putic(ICOP, OPCOMMA);
	prexpr( t =  simple(LVAL,q->datap) );
	frexpr(t);
	}

putic(ICOP, OPRPAR);
swii(icfile);
frchain( &p );
}




mkgeneric(gname,atype,fname,ftype)
char *gname, *fname;
int atype, ftype;
{
register ptr p;
ptr generic();

if(p = generic(gname))
	{
	if(p->genfname[atype])
		fatal1("generic name already defined", gname);
	}
else	{
	p = ALLOC(genblock);
	p->tag = TGENERIC;
	p->nextgenf = generlist;
	generlist = p;
	p->genname = gname;
	}

p->genfname[atype] = fname;
p->genftype[atype] = ftype;
}


ptr generic(s)
char *s;
{
register ptr p;

for(p= generlist; p ; p = p->nextgenf)
	if(equals(s, p->genname))
		return(p);
return(0);
}


knownfunct(s)
char *s;
{
register ptr p;

for(p = knownlist ; p ; p = p->nextfunct)
	if(equals(s, p->funcname))
		return(p->functype);
return(0);
}





ptr funcinv(p)
register ptr p;
{
ptr fp, fp1;
register ptr g;
char *s;
register int t;
int vt;

if(g = generic(s = p->leftp->sthead->namep))
	{
	if(p->rightp->tag==TLIST && p->rightp->leftp
		&& ( (vt = typearg(p->rightp->leftp)) >=0)
		&& (t = g->genftype[vt]) )
		{
		p->leftp = builtin(t, g->genfname[vt]);
		}
	else	{
		dclerr("improper use of generic function", s);
		frexpr(p);
		return( errnode() );
		}
	}

fp = p->leftp;
setvproc(fp, PROCYES);
fp1 = fp->sthead->varp;
s = fp->sthead->namep;

if(p->vtype==TYUNDEFINED && fp->vclass!=CLARG)
	if(t = knownfunct(s))
		{
		p->vtype = t;
		setvproc(fp, PROCINTRINSIC);
		setvproc(fp1, PROCINTRINSIC);
		fp1->vtype = t;
		builtin(t,fp1->sthead->namep);
		cpblock(fp1, fp, sizeof(struct exprblock));
		}

dclit(p);
return(p);
}




typearg(p0)
register chainp p0;
{
register chainp p;
register int vt, maxt;

if(p0 == NULL)
	return(-1);
maxt = p0->datap->vtype;

for(p = p0->nextp ; p ; p = p->nextp)
	if( (vt = p->datap->vtype) > maxt)
		maxt = vt;

for(p = p0 ; p ; p = p->nextp)
	p->datap = coerce(maxt, p->datap);

return(maxt);
}




ptr typexpr(t,e)
register ptr t, e;
{
ptr e1;
int etag;

if(t->atdim!=0 || (e->tag==TLIST && t->attype!=TYCOMPLEX) )
	goto typerr;

switch(t->attype)
	{
	case TYCOMPLEX:
		if(e->tag==TLIST)
			if(e->leftp==0 || e->leftp->nextp==0
			    || e->leftp->nextp->nextp!=0)
				{
				exprerr("bad conversion to complex", "");
				return( errnode() );
				}
			else	{
				e->leftp->datap = simple(RVAL,
						e->leftp->datap);
				e->leftp->nextp->datap = simple(RVAL,
						e->leftp->nextp->datap);
				if(isconst(e->leftp->datap) &&
				   isconst(e->leftp->nextp->datap) )
					return( compconst(e) );
				e1 = mkcall(builtin(TYCOMPLEX,"cmplx"),
					arg2( coerce(TYREAL,e->leftp->datap),
					coerce(TYREAL,e->leftp->nextp->datap)));
				frchain( &(e->leftp) );
				frexpblock(e);
				return(e1);
				}

	case TYINT:
	case TYREAL:
	case TYLREAL:
	case TYLOG:
	case TYFIELD:
		e = coerce(t->attype, simple(RVAL, e) );
		etag = e->tag;
		if(etag==TAROP || etag==TLOGOP || etag==TRELOP)
			e->needpar = YES;
		return(e);

	case TYCHAR:
	case TYSTRUCT:
		goto typerr;
	}

typerr:
	exprerr("typexpr not fully implemented", "");
	frexpr(e);
	return( errnode() );
}




ptr compconst(p)
register ptr p;
{
register ptr a, b;
int as, bs;
int prec;

prec = TYREAL;
p = p->leftp;
if(p == 0)
	goto err;
if(p->datap->vtype == TYLREAL)
	prec = TYLREAL;
a = coerce(TYLREAL, p->datap);
p = p->nextp;
if(p->nextp)
	goto err;
if(p->datap->vtype == TYLREAL)
	a = coerce(prec = TYLREAL,a);
b = coerce(TYLREAL, p->datap);

if(a->tag==TNEGOP)
	{
	as = '-';
	a = a->leftp;
	}
else	as = ' ';

if(b->tag==TNEGOP)
	{
	bs = '-';
	b = b->leftp;
	}
else	bs = ' ';

if(a->tag!=TCONST || a->vtype!=prec ||
   b->tag!=TCONST || b->vtype!=prec )
		goto err;

if(prec==TYLREAL && tailor.lngcxtype==NULL)
	{
	ptr q, e1, e2;
	struct dimblock *dp;
	sprintf(msg, "_const%d", ++constno);
	q = mkvar(mkname(msg));
	q->vtype = TYLREAL;
	dclit(q);
	dp = ALLOC(dimblock);
	dp->upperb = mkint(2);
	q->vdim = mkchain(dp,CHNULL);
	sprintf(msg, "%c%s", as, a->leftp);
	e1 = mkconst(TYLREAL, msg);
	sprintf(msg, "%c%s", bs, b->leftp);
	e2 = mkconst(TYLREAL, msg);
	mkinit(q, mknode(TLIST,0, mkchain(e1,mkchain(e2,CHNULL)),PNULL) );
	cfree(q->vdim);
	q->vtype = TYLCOMPLEX;
	return(q);
	}
else
	{
	sprintf(msg, "(%c%s, %c%s)", as, a->leftp, bs, b->leftp);
	return( mkconst(TYCOMPLEX, msg) );
	}

err:	exprerr("invalid complex constant", "");
	return( errnode() );
}




ptr mkchcon(p)
char *p;
{
register ptr q;
char buf[10];

sprintf(buf, "_const%d", ++constno);
q = mkvar(mkname(buf));
q->vtype = TYCHAR;
q->vtypep = mkint(strlen(p));
mkinit(q, mkconst(TYCHAR, p));
return(q);
}



ptr mksub1()
{
return( mknode(TLIST,0, mkchain(mkint(1),CHNULL), PNULL) );
}