BSD 4_1_snap development

[unix-history] / usr / src / cmd / efl / mk.c

#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);
}
\f
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);
}
\f
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;
                               }
                       }
       }
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) );
}