static char rcsid[] = "$Header:mk.c 12.0$";
#include "defs"


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

for(p = (ptr)commonlist ; p ; p = ((struct chain *)p)->nextp)
	if(equals(s, ((struct comentry *)((struct chain *)p)->datap)->comname))
		return(((struct chain *)p)->datap);

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




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

if( (p = (ptr)name(s,1)) == 0)
	{
	p = (ptr)name(s,0);
	((struct headbits *)p)->tag = TNAME;
	((struct headbits *)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 = (struct exprblock *)allexpblock();
TEST fprintf(diagfile, "mknode(%d,%d,%o,%o) = %o\n", t, o, l, r, p);

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

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

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

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

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

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

		break;

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

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

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

	case TCALL:
		((struct exprblock *)p)->vtype = ((struct exprblock *)l)->vtype;
		((struct exprblock *)p)->vtypep = ((struct exprblock *)l)->vtypep;
		break;

	case TASGNOP:
		ckdcl(l);
		ckdcl(r);
		lt = ((struct exprblock *)l)->vtype;
		if(lt==TYFIELD)
			lt = TYINT;
		rt = ((struct exprblock *)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 || ((struct typeblock *)((struct exprblock *)l)->vtypep)->strsize!=((struct typeblock *)((struct exprblock *)r)->vtypep)->strsize
				|| ((struct typeblock *)((struct exprblock *)l)->vtypep)->stralign!=((struct typeblock *)((struct exprblock *)r)->vtypep)->stralign)
				{
				exprerr("illegal structure assignment",CNULL);
				goto err;
				}
			}
		else if ( (lt==TYCOMPLEX || rt==TYCOMPLEX) && lt!=rt)
/*			((struct exprblock *)p)->rightp = r = coerce(lt, r) */ ;

		((struct exprblock *)p)->vtype = lt;
		((struct exprblock *)p)->vtypep = ((struct exprblock *)l)->vtypep;
		break;

	case TCONST:
	case TLIST:
	case TREPOP:
		break;

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

return((ptr)p);

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



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

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

if(((struct headbits *)p)->blklevel > blklevel)
	((struct headbits *)p)->blklevel = blklevel;

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

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

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


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

p = (ptr)ALLOC(typeblock);
((struct varblock *)p)->sthead = v;
((struct headbits *)p)->tag = TSTRUCT;
((struct headbits *)p)->blklevel = blklevel;
((struct typeblock *)p)->strdesc = s;
offsets(p);
if(v)	{
	((struct headbits *)v)->blklevel = blklevel;
	++ndecl[blklevel];
	((struct stentry *)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(((struct headbits *)fn1)->tag == TERROR)
	return( errnode() );
else if(((struct headbits *)fn1)->tag == TNAME)
	{
	funct = ((struct stentry *)((struct varblock *)fn1)->sthead)->varp;
	frexpblock(fn1);
	}
else
	funct = fn1;
if(((struct exprblock *)funct)->vclass!=0 && ((struct exprblock *)funct)->vclass!=CLARG)
	{
	exprerr("invalid invocation of %s",((struct stentry *)((struct varblock *)funct)->sthead)->namep);
	frexpr(args);
	return( errnode() );
	}
else	extname(funct);

if(args)  for(p = ((struct exprblock *)args)->leftp; p ; p = ((struct chain *)p)->nextp)
	{
	q = ((struct chain *)p)->datap;
	if( (((struct headbits *)q)->tag==TCALL&&((struct exprblock *)q)->vtype==TYUNDEFINED) ||
	    (((struct headbits *)q)->tag==TNAME&&((struct varblock *)q)->vdcldone==0) )
		dclit(q);
	if(((struct headbits *)q)->tag==TNAME && ((struct varblock *)q)->vproc==PROCUNKNOWN)
		setvproc(q, PROCNO);
	if( ((struct varblock *)q)->vtype == TYSTRUCT)
		{
		first = 1;
		for(i = 0; i<NFTNTYPES ; ++i)
			if(((struct varblock *)q)->vbase[i] != 0)
				{
				r = cpexpr(q);
				if(first)
					{
					((struct chain *)p)->datap = r;
					first = 0;
					}
				else	p = ((struct chain *)p)->nextp = (ptr)mkchain(r, ((struct chain *)p)->nextp);
				((struct varblock *)r)->vtype = ftnefl[i];
				for(j=0; j<NFTNTYPES; ++j)
					if(i != j) ((struct varblock *)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 && ((struct headbits *)s)->subtype!=STSWITCH ; s = ((struct ctlblock *)s)->prevctl)
	;
if(s==0 || (here && s!=thisctl) )
	{
	laberr("invalid case label location",CNULL);
	return(0);
	}
for(q = ((struct ctlblock *)s)->loopctl ; q!=0 && (((struct caseblock *)!eqcon(p,q))->casexpr) ; q = ((struct caseblock *)q)->nextcase)
	;
if(q == 0)
	{
	q = (ptr)ALLOC(caseblock);
	((struct headbits *)q)->tag = TCASE;
	((struct caseblock *)q)->casexpr = p;
	((struct caseblock *)q)->labelno = ( here ? thislab() : nextlab() );
	((struct caseblock *)q)->nextcase = ((struct ctlblock *)s)->loopctl;
	((struct ctlblock *)s)->loopctl = q;
	}
else if(here)
	if(((struct caseblock *)thisexec)->labelno == 0)
		((struct caseblock *)thisexec)->labelno = ((struct caseblock *)q)->labelno;
	else if(((struct caseblock *)thisexec)->labelno != ((struct caseblock *)q)->labelno)
		{
		exnull();
		((struct caseblock *)thisexec)->labelno = ((struct caseblock *)q)->labelno;
		((struct caseblock *)thisexec)->labused = 0;
		}
if(here)
	if(((struct caseblock *)q)->labdefined)
		laberr("multiply defined case",CNULL);
	else
		((struct caseblock *)q)->labdefined = 1;
return(((struct caseblock *)q)->labelno);
}


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

if(((struct headbits *)p)->tag!=TCONST || ((struct varblock *)p)->vtype!=TYINT)
	{
	execerr("invalid label","");
	s = "";
	}
else	s = (char *)((struct exprblock *)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 = ((struct stentry *)p)->varp)
	{
	if(((struct headbits *)q)->tag != TLABEL)
		laberr("%s is already a nonlabel\n", ((struct stentry *)p)->namep);
	else if(((struct caseblock *)q)->labinacc)
		warn1("label %s is inaccessible", ((struct stentry *)p)->namep);
	else if(here)
		if(((struct caseblock *)q)->labdefined)
			laberr("%s is already defined\n", ((struct stentry *)p)->namep);
		else if(blklevel > ((struct headbits *)q)->blklevel)
			laberr("%s is illegally placed\n",((struct stentry *)p)->namep);
		else	{
			((struct caseblock *)q)->labdefined = 1;
			if(((struct caseblock *)thisexec)->labelno == 0)
				((struct caseblock *)thisexec)->labelno = ((struct caseblock *)q)->labelno;
			else if(((struct caseblock *)thisexec)->labelno != ((struct caseblock *)q)->labelno)
				{
				exnull();
				((struct caseblock *)thisexec)->labelno = ((struct caseblock *)q)->labelno;
				((struct caseblock *)thisexec)->labused = 0;
				}
			}
	}
else	{
	q = (ptr)ALLOC(labelblock);
	((struct stentry *)p)->varp = q;
	((struct headbits *)q)->tag = TLABEL;
	((struct headbits *)q)->subtype = 0;
	((struct headbits *)q)->blklevel = blklevel;
	++ndecl[blklevel];
	((struct caseblock *)q)->labdefined = here;
	((struct caseblock *)q)->labelno = ( here ? thislab() : nextlab() );
	((struct varblock *)q)->sthead = p;
	}

return(((struct caseblock *)q)->labelno);
}


thislab()
{
if(((struct caseblock *)thisexec)->labelno == 0)
	((struct caseblock *)thisexec)->labelno = nextlab();
return(((struct caseblock *)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 = (ptr)name(s, 2);
q = (ptr)ALLOC(keyblock);
((struct headbits *)p)->tag = TKEYWORD;
((struct headbits *)q)->tag = TKEYWORD;
((struct headbits *)p)->subtype = n;
((struct headbits *)q)->subtype = n;
((struct headbits *)p)->blklevel = 0;
((struct stentry *)p)->varp = q;
((struct varblock *)q)->sthead = p;
}


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

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

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



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

p = (ptr)ALLOC(knownname);
((struct knownname *)p)->nextfunct = knownlist;
((struct headbits *)p)->tag = TKNOWNFUNCT;
knownlist = p;
((struct knownname *)p)->funcname = s;
((struct knownname *)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);
((struct varblock *)q)->vtype = t;
if(t == TYCHAR)
	((struct varblock *)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);
((struct varblock *)q)->vtype = t;
return(q);
}



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

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

((struct varblock *)p)->vtype = TYSTRUCT;
((struct varblock *)p)->vtypep = ((struct stentry *)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 = ((struct chain *)q)->nextp)
	{
	if(first)  first = 0;
	else putic(ICOP, OPCOMMA);
	prexpr( t =  simple(LVAL,((struct chain *)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(((struct genblock *)p)->genfname[atype])
		fatal1("generic name already defined", gname);
	}
else	{
	p = (ptr)ALLOC(genblock);
	((struct headbits *)p)->tag = TGENERIC;
	((struct genblock *)p)->nextgenf = generlist;
	generlist = p;
	((struct genblock *)p)->genname = gname;
	}

((struct genblock *)p)->genfname[atype] = fname;
((struct genblock *)p)->genftype[atype] = ftype;
}


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

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


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

for(p = knownlist ; p ; p = ((struct knownname *)p)->nextfunct)
	if(equals(s, ((struct knownname *)p)->funcname))
		return(((struct knownname *)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 = ((struct stentry *)((struct varblock *)((struct exprblock *)p)->leftp)->sthead)->namep))
	{
	if(((struct headbits *)((struct exprblock *)p)->rightp)->tag==TLIST && ((struct exprblock *)((struct exprblock *)p)->rightp)->leftp
		&& ( (vt = typearg(((struct exprblock *)((struct exprblock *)p)->rightp)->leftp)) >=0)
		&& (t = ((struct genblock *)g)->genftype[vt]) )
		{
		((struct exprblock *)p)->leftp = builtin(t, ((struct genblock *)g)->genfname[vt]);
		}
	else	{
		dclerr("improper use of generic function", s);
		frexpr(p);
		return( errnode() );
		}
	}

fp = ((struct exprblock *)p)->leftp;
setvproc(fp, PROCYES);
fp1 = ((struct stentry *)((struct varblock *)fp)->sthead)->varp;
s = ((struct stentry *)((struct varblock *)fp)->sthead)->namep;

if(((struct varblock *)p)->vtype==TYUNDEFINED && ((struct varblock *)fp)->vclass!=CLARG)
	if(t = knownfunct(s))
		{
		((struct varblock *)p)->vtype = t;
		setvproc(fp, PROCINTRINSIC);
		setvproc(fp1, PROCINTRINSIC);
		((struct varblock *)fp1)->vtype = t;
		builtin(t,((struct stentry *)((struct varblock *)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 = ((struct varblock *)((struct chain *)p0)->datap)->vtype;

for(p = (chainp)((struct chain *)p0)->nextp ; p ; p = (chainp)((struct chain *)p)->nextp)
	if( (vt = ((struct varblock *)((struct chain *)p)->datap)->vtype) > maxt)
		maxt = vt;

for(p = p0 ; p ; p = (chainp)((struct chain *)p)->nextp)
	((struct chain *)p)->datap = coerce(maxt, ((struct chain *)p)->datap);

return(maxt);
}




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

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

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

	case TYINT:
	case TYREAL:
	case TYLREAL:
	case TYLOG:
	case TYFIELD:
		e = coerce(((struct atblock *)t)->attype, simple(RVAL, e) );
		etag = ((struct headbits *)e)->tag;
		if(etag==TAROP || etag==TLOGOP || etag==TRELOP)
			((struct varblock *)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 = ((struct exprblock *)p)->leftp;
if(p == 0)
	goto err;
if(((struct varblock *)((struct chain *)p)->datap)->vtype == TYLREAL)
	prec = TYLREAL;
a = coerce(TYLREAL, ((struct chain *)p)->datap);
p = ((struct chain *)p)->nextp;
if(((struct chain *)p)->nextp)
	goto err;
if(((struct varblock *)((struct chain *)p)->datap)->vtype == TYLREAL)
	a = coerce(prec = TYLREAL,a);
b = coerce(TYLREAL, ((struct chain *)p)->datap);

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

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

if(((struct headbits *)a)->tag!=TCONST || ((struct varblock *)a)->vtype!=prec ||
   ((struct headbits *)b)->tag!=TCONST || ((struct varblock *)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));
	((struct varblock *)q)->vtype = TYLREAL;
	dclit(q);
	dp = ALLOC(dimblock);
	((struct dimblock *)dp)->upperb = mkint(2);
	((struct varblock *)q)->vdim = (ptr)mkchain(dp,CHNULL);
	sprintf(msg, "%c%s", as, ((struct exprblock *)a)->leftp);
	e1 = mkconst(TYLREAL, msg);
	sprintf(msg, "%c%s", bs, ((struct exprblock *)b)->leftp);
	e2 = mkconst(TYLREAL, msg);
	mkinit(q, mknode(TLIST,0, mkchain(e1,mkchain(e2,CHNULL)),PNULL) );
	cfree(((struct varblock *)q)->vdim);
	((struct varblock *)q)->vtype = TYLCOMPLEX;
	return(q);
	}
else
	{
	sprintf(msg, "(%c%s, %c%s)", as, ((struct exprblock *)a)->leftp, bs, ((struct exprblock *)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));
((struct varblock *)q)->vtype = TYCHAR;
((struct varblock *)q)->vtypep = mkint(strlen(p));
mkinit(q, mkconst(TYCHAR, p));
return(q);
}



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