Logo Search packages:      
Sourcecode: pcc version File versions  Download package

expr.c

/*    $Id: expr.c,v 1.20 2008/05/11 15:28:03 ragge Exp $    */
/*
 * Copyright(C) Caldera International Inc. 2001-2002. All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 *
 * Redistributions of source code and documentation must retain the above
 * copyright notice, this list of conditions and the following disclaimer.
 * Redistributions in binary form must reproduce the above copyright
 * notice, this list of conditionsand the following disclaimer in the
 * documentation and/or other materials provided with the distribution.
 * All advertising materials mentioning features or use of this software
 * must display the following acknowledgement:
 *    This product includes software developed or owned by Caldera
 *    International, Inc.
 * Neither the name of Caldera International, Inc. nor the names of other
 * contributors may be used to endorse or promote products derived from
 * this software without specific prior written permission.
 *
 * USE OF THE SOFTWARE PROVIDED FOR UNDER THIS LICENSE BY CALDERA
 * INTERNATIONAL, INC. AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR
 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
 * DISCLAIMED.  IN NO EVENT SHALL CALDERA INTERNATIONAL, INC. BE LIABLE
 * FOR ANY DIRECT, INDIRECT INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 * HOWEVER CAUSED AND ON ANY THEORY OFLIABILITY, WHETHER IN CONTRACT,
 * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
 * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 
 * POSSIBILITY OF SUCH DAMAGE.
 */
#include <string.h>

#include "defines.h"
#include "defs.h"

/* little routines to create constant blocks */
LOCAL int letter(int c);
LOCAL void conspower(union constant *, struct bigblock *, ftnint);
LOCAL void consbinop(int, int, union constant *, union constant *,
      union constant *);
LOCAL void zdiv(struct dcomplex *, struct dcomplex *, struct dcomplex *);
LOCAL struct bigblock *stfcall(struct bigblock *, struct bigblock *);
LOCAL bigptr mkpower(struct bigblock *p);
LOCAL bigptr fold(struct bigblock *e);
LOCAL bigptr subcheck(struct bigblock *, bigptr);

struct bigblock *mkconst(t)
register int t;
{
register struct bigblock *p;

p = BALLO();
p->tag = TCONST;
p->vtype = t;
return(p);
}


struct bigblock *mklogcon(l)
register int l;
{
register struct bigblock * p;

p = mkconst(TYLOGICAL);
p->b_const.fconst.ci = l;
return(p);
}



struct bigblock *mkintcon(l)
ftnint l;
{
register struct bigblock *p;

p = mkconst(TYLONG);
p->b_const.fconst.ci = l;
#ifdef MAXSHORT
      if(l >= -MAXSHORT   &&   l <= MAXSHORT)
            p->vtype = TYSHORT;
#endif
return(p);
}



struct bigblock *mkaddcon(l)
register int l;
{
register struct bigblock *p;

p = mkconst(TYADDR);
p->b_const.fconst.ci = l;
return(p);
}



struct bigblock *mkrealcon(t, d)
register int t;
double d;
{
register struct bigblock *p;

p = mkconst(t);
p->b_const.fconst.cd[0] = d;
return(p);
}


struct bigblock *mkbitcon(shift, leng, s)
int shift;
int leng;
char *s;
{
register struct bigblock *p;

p = mkconst(TYUNKNOWN);
p->b_const.fconst.ci = 0;
while(--leng >= 0)
      if(*s != ' ')
            p->b_const.fconst.ci = (p->b_const.fconst.ci << shift) | hextoi(*s++);
return(p);
}





struct bigblock *mkstrcon(l,v)
int l;
register char *v;
{
register struct bigblock *p;
register char *s;

p = mkconst(TYCHAR);
p->vleng = MKICON(l);
p->b_const.fconst.ccp = s = (char *) ckalloc(l);
while(--l >= 0)
      *s++ = *v++;
return(p);
}


struct bigblock *mkcxcon(realp,imagp)
register bigptr realp, imagp;
{
int rtype, itype;
register struct bigblock *p;

rtype = realp->vtype;
itype = imagp->vtype;

if( ISCONST(realp) && ISNUMERIC(rtype) && ISCONST(imagp) && ISNUMERIC(itype) )
      {
      p = mkconst( (rtype==TYDREAL||itype==TYDREAL) ? TYDCOMPLEX : TYCOMPLEX );
      if( ISINT(rtype) )
            p->b_const.fconst.cd[0] = realp->b_const.fconst.ci;
      else  p->b_const.fconst.cd[0] = realp->b_const.fconst.cd[0];
      if( ISINT(itype) )
            p->b_const.fconst.cd[1] = imagp->b_const.fconst.ci;
      else  p->b_const.fconst.cd[1] = imagp->b_const.fconst.cd[0];
      }
else
      {
      err("invalid complex constant");
      p = errnode();
      }

frexpr(realp);
frexpr(imagp);
return(p);
}


struct bigblock *errnode()
{
struct bigblock *p;
p = BALLO();
p->tag = TERROR;
p->vtype = TYERROR;
return(p);
}





bigptr mkconv(t, p)
register int t;
register bigptr p;
{
register bigptr q;

if(t==TYUNKNOWN || t==TYERROR)
      fatal1("mkconv of impossible type %d", t);
if(t == p->vtype)
      return(p);

else if( ISCONST(p) && p->vtype!=TYADDR)
      {
      q = mkconst(t);
      consconv(t, &(q->b_const.fconst), p->vtype, &(p->b_const.fconst));
      frexpr(p);
      }
else
      {
      q = mkexpr(OPCONV, p, 0);
      q->vtype = t;
      }
return(q);
}



struct bigblock *addrof(p)
bigptr p;
{
return( mkexpr(OPADDR, p, NULL) );
}



bigptr
cpexpr(p)
register bigptr p;
{
register bigptr e;
int tag;
register chainp ep, pp;

#if 0
static int blksize[ ] = { 0, sizeof(struct nameblock), sizeof(struct constblock),
             sizeof(struct exprblock), sizeof(struct addrblock),
             sizeof(struct primblock), sizeof(struct listblock),
             sizeof(struct errorblock)
      };
#endif

if(p == NULL)
      return(NULL);

if( (tag = p->tag) == TNAME)
      return(p);

#if 0
e = cpblock( blksize[p->tag] , p);
#else
e = cpblock( sizeof(struct bigblock) , p);
#endif

switch(tag)
      {
      case TCONST:
            if(e->vtype == TYCHAR)
                  {
                  e->b_const.fconst.ccp = copyn(1+strlen(e->b_const.fconst.ccp), e->b_const.fconst.ccp);
                  e->vleng = cpexpr(e->vleng);
                  }
      case TERROR:
            break;

      case TEXPR:
            e->b_expr.leftp = cpexpr(p->b_expr.leftp);
            e->b_expr.rightp = cpexpr(p->b_expr.rightp);
            break;

      case TLIST:
            if((pp = p->b_list.listp))
                  {
                  ep = e->b_list.listp = mkchain( cpexpr(pp->chain.datap), NULL);
                  for(pp = pp->chain.nextp ; pp ; pp = pp->chain.nextp)
                        ep = ep->chain.nextp = mkchain( cpexpr(pp->chain.datap), NULL);
                  }
            break;

      case TADDR:
            e->vleng = cpexpr(e->vleng);
            e->b_addr.memoffset = cpexpr(e->b_addr.memoffset);
            e->b_addr.istemp = NO;
            break;

      case TPRIM:
            e->b_prim.argsp = cpexpr(e->b_prim.argsp);
            e->b_prim.fcharp = cpexpr(e->b_prim.fcharp);
            e->b_prim.lcharp = cpexpr(e->b_prim.lcharp);
            break;

      default:
            fatal1("cpexpr: impossible tag %d", tag);
      }

return(e);
}

void
frexpr(p)
register bigptr p;
{
register chainp q;

if(p == NULL)
      return;

switch(p->tag)
      {
      case TCONST:
            if( ISCHAR(p) )
                  {
                  ckfree(p->b_const.fconst.ccp);
                  frexpr(p->vleng);
                  }
            break;

      case TADDR:
            if(p->b_addr.istemp)
                  {
                  frtemp(p);
                  return;
                  }
            frexpr(p->vleng);
            frexpr(p->b_addr.memoffset);
            break;

      case TERROR:
            break;

      case TNAME:
            return;

      case TPRIM:
            frexpr(p->b_prim.argsp);
            frexpr(p->b_prim.fcharp);
            frexpr(p->b_prim.lcharp);
            break;

      case TEXPR:
            frexpr(p->b_expr.leftp);
            if(p->b_expr.rightp)
                  frexpr(p->b_expr.rightp);
            break;

      case TLIST:
            for(q = p->b_list.listp ; q ; q = q->chain.nextp)
                  frexpr(q->chain.datap);
            frchain( &(p->b_list.listp) );
            break;

      default:
            fatal1("frexpr: impossible tag %d", p->tag);
      }

ckfree(p);
}

/* fix up types in expression; replace subtrees and convert
   names to address blocks */

bigptr fixtype(p)
register bigptr p;
{

if(p == 0)
      return(0);

switch(p->tag)
      {
      case TCONST:
            if( ! ONEOF(p->vtype, MSKINT|MSKLOGICAL|MSKADDR) )
                  p = putconst(p);
            return(p);

      case TADDR:
            p->b_addr.memoffset = fixtype(p->b_addr.memoffset);
            return(p);

      case TERROR:
            return(p);

      default:
            fatal1("fixtype: impossible tag %d", p->tag);

      case TEXPR:
            return( fixexpr(p) );

      case TLIST:
            return( p );

      case TPRIM:
            if(p->b_prim.argsp && p->b_prim.namep->vclass!=CLVAR)
                  return( mkfunct(p) );
            else  return( mklhs(p) );
      }
}





/* special case tree transformations and cleanups of expression trees */

bigptr fixexpr(p)
register struct bigblock *p;
{
bigptr lp;
register bigptr rp;
register bigptr q;
int opcode, ltype, rtype, ptype, mtype;

if(p->tag == TERROR)
      return(p);
else if(p->tag != TEXPR)
      fatal1("fixexpr: invalid tag %d", p->tag);
opcode = p->b_expr.opcode;
lp = p->b_expr.leftp = fixtype(p->b_expr.leftp);
ltype = lp->vtype;
if(opcode==OPASSIGN && lp->tag!=TADDR)
      {
      err("left side of assignment must be variable");
      frexpr(p);
      return( errnode() );
      }

if(p->b_expr.rightp)
      {
      rp = p->b_expr.rightp = fixtype(p->b_expr.rightp);
      rtype = rp->vtype;
      }
else
      {
      rp = NULL;
      rtype = 0;
      }

/* force folding if possible */
if( ISCONST(lp) && (rp==NULL || ISCONST(rp)) )
      {
      q = mkexpr(opcode, lp, rp);
      if( ISCONST(q) )
            return(q);
      ckfree(q);  /* constants did not fold */
      }

if( (ptype = cktype(opcode, ltype, rtype)) == TYERROR)
      {
      frexpr(p);
      return( errnode() );
      }

switch(opcode)
      {
      case OPCONCAT:
            if(p->vleng == NULL)
                  p->vleng = mkexpr(OPPLUS, cpexpr(lp->vleng),
                        cpexpr(rp->vleng) );
            break;

      case OPASSIGN:
            if(ltype == rtype)
                  break;
            if( ! ISCONST(rp) && ISREAL(ltype) && ISREAL(rtype) )
                  break;
            if( ISCOMPLEX(ltype) || ISCOMPLEX(rtype) )
                  break;
            if( ONEOF(ltype, MSKADDR|MSKINT) && ONEOF(rtype, MSKADDR|MSKINT)
                && typesize[ltype]>=typesize[rtype] )
                  break;
            p->b_expr.rightp = fixtype( mkconv(ptype, rp) );
            break;

      case OPSLASH:
            if( ISCOMPLEX(rtype) )
                  {
                  p = call2(ptype, ptype==TYCOMPLEX? "c_div" : "z_div",
                        mkconv(ptype, lp), mkconv(ptype, rp) );
                  break;
                  }
      case OPPLUS:
      case OPMINUS:
      case OPSTAR:
      case OPMOD:
            if(ptype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp) ) ||
                (rtype==TYREAL && ! ISCONST(rp) ) ))
                  break;
            if( ISCOMPLEX(ptype) )
                  break;
            if(ltype != ptype)
                  p->b_expr.leftp = fixtype(mkconv(ptype,lp));
            if(rtype != ptype)
                  p->b_expr.rightp = fixtype(mkconv(ptype,rp));
            break;

      case OPPOWER:
            return( mkpower(p) );

      case OPLT:
      case OPLE:
      case OPGT:
      case OPGE:
      case OPEQ:
      case OPNE:
            if(ltype == rtype)
                  break;
            mtype = cktype(OPMINUS, ltype, rtype);
            if(mtype==TYDREAL && ( (ltype==TYREAL && ! ISCONST(lp)) ||
                (rtype==TYREAL && ! ISCONST(rp)) ))
                  break;
            if( ISCOMPLEX(mtype) )
                  break;
            if(ltype != mtype)
                  p->b_expr.leftp = fixtype(mkconv(mtype,lp));
            if(rtype != mtype)
                  p->b_expr.rightp = fixtype(mkconv(mtype,rp));
            break;


      case OPCONV:
            ptype = cktype(OPCONV, p->vtype, ltype);
            if(lp->tag==TEXPR && lp->b_expr.opcode==OPCOMMA)
                  {
                  lp->b_expr.rightp = fixtype( mkconv(ptype, lp->b_expr.rightp) );
                  ckfree(p);
                  p = lp;
                  }
            break;

      case OPADDR:
            if(lp->tag==TEXPR && lp->b_expr.opcode==OPADDR)
                  fatal("addr of addr");
            break;

      case OPCOMMA:
            break;

      case OPMIN:
      case OPMAX:
            ptype = p->vtype;
            break;

      default:
            break;
      }

p->vtype = ptype;
return(p);
}

#if SZINT < SZLONG
/*
   for efficient subscripting, replace long ints by shorts
   in easy places
*/

bigptr shorten(p)
register bigptr p;
{
register bigptr q;

if(p->vtype != TYLONG)
      return(p);

switch(p->tag)
      {
      case TERROR:
      case TLIST:
            return(p);

      case TCONST:
      case TADDR:
            return( mkconv(TYINT,p) );

      case TEXPR:
            break;

      default:
            fatal1("shorten: invalid tag %d", p->tag);
      }

switch(p->opcode)
      {
      case OPPLUS:
      case OPMINUS:
      case OPSTAR:
            q = shorten( cpexpr(p->rightp) );
            if(q->vtype == TYINT)
                  {
                  p->leftp = shorten(p->leftp);
                  if(p->leftp->vtype == TYLONG)
                        frexpr(q);
                  else
                        {
                        frexpr(p->rightp);
                        p->rightp = q;
                        p->vtype = TYINT;
                        }
                  }
            break;

      case OPNEG:
            p->leftp = shorten(p->leftp);
            if(p->leftp->vtype == TYINT)
                  p->vtype = TYINT;
            break;

      case OPCALL:
      case OPCCALL:
            p = mkconv(TYINT,p);
            break;
      default:
            break;
      }

return(p);
}
#endif

int
fixargs(doput, p0)
int doput;
struct bigblock *p0;
{
register chainp p;
register bigptr q, t;
register int qtag;
int nargs;

nargs = 0;
if(p0)
    for(p = p0->b_list.listp ; p ; p = p->chain.nextp)
      {
      ++nargs;
      q = p->chain.datap;
      qtag = q->tag;
      if(qtag == TCONST)
            {
            if(q->vtype == TYSHORT)
                  q = mkconv(tyint, q);
            if(doput)
                  p->chain.datap = putconst(q);
            else
                  p->chain.datap = q;
            }
      else if(qtag==TPRIM && q->b_prim.argsp==0 && q->b_prim.namep->vclass==CLPROC)
            p->chain.datap = mkaddr(q->b_prim.namep);
      else if(qtag==TPRIM && q->b_prim.argsp==0 && q->b_prim.namep->b_name.vdim!=NULL)
            p->chain.datap = mkscalar(q->b_prim.namep);
      else if(qtag==TPRIM && q->b_prim.argsp==0 && q->b_prim.namep->b_name.vdovar && 
            (t = memversion(q->b_prim.namep)) )
                  p->chain.datap = fixtype(t);
      else  p->chain.datap = fixtype(q);
      }
return(nargs);
}

struct bigblock *
mkscalar(np)
register struct bigblock *np;
{
register struct bigblock *ap;

vardcl(np);
ap = mkaddr(np);

#ifdef __vax__
      /* on the VAX, prolog causes array arguments
         to point at the (0,...,0) element, except when
         subscript checking is on
      */
      if( !checksubs && np->vstg==STGARG)
            {
            register struct dimblock *dp;
            dp = np->vdim;
            frexpr(ap->memoffset);
            ap->memoffset = mkexpr(OPSTAR, MKICON(typesize[np->vtype]),
                              cpexpr(dp->baseoffset) );
            }
#endif
return(ap);
}





bigptr mkfunct(p)
register struct bigblock * p;
{
chainp ep;
struct bigblock *ap;
struct extsym *extp;
register struct bigblock *np;
register struct bigblock *q;
int k, nargs;
int class;

np = p->b_prim.namep;
class = np->vclass;

if(class == CLUNKNOWN)
      {
      np->vclass = class = CLPROC;
      if(np->vstg == STGUNKNOWN)
            {
            if((k = intrfunct(np->b_name.varname)))
                  {
                  np->vstg = STGINTR;
                  np->b_name.vardesc.varno = k;
                  np->b_name.vprocclass = PINTRINSIC;
                  }
            else
                  {
                  extp = mkext( varunder(VL,np->b_name.varname) );
                  extp->extstg = STGEXT;
                  np->vstg = STGEXT;
                  np->b_name.vardesc.varno = extp - extsymtab;
                  np->b_name.vprocclass = PEXTERNAL;
                  }
            }
      else if(np->vstg==STGARG)
            {
            if(np->vtype!=TYCHAR && !ftn66flag)
                warn("Dummy procedure not declared EXTERNAL. Code may be wrong.");
            np->b_name.vprocclass = PEXTERNAL;
            }
      }

if(class != CLPROC)
      fatal1("invalid class code for function", class);
if(p->b_prim.fcharp || p->b_prim.lcharp)
      {
      err("no substring of function call");
      goto error;
      }
impldcl(np);
nargs = fixargs( np->b_name.vprocclass!=PINTRINSIC,  p->b_prim.argsp);

switch(np->b_name.vprocclass)
      {
      case PEXTERNAL:
            ap = mkaddr(np);
      call:
            q = mkexpr(OPCALL, ap, p->b_prim.argsp);
            q->vtype = np->vtype;
            if(np->vleng)
                  q->vleng = cpexpr(np->vleng);
            break;

      case PINTRINSIC:
            q = intrcall(np, p->b_prim.argsp, nargs);
            break;

      case PSTFUNCT:
            q = stfcall(np, p->b_prim.argsp);
            break;

      case PTHISPROC:
            warn("recursive call");
            for(ep = entries ; ep ; ep = ep->entrypoint.nextp)
                  if(ep->entrypoint.enamep == np)
                        break;
            if(ep == NULL)
                  fatal("mkfunct: impossible recursion");
            ap = builtin(np->vtype, varstr(XL, ep->entrypoint.entryname->extname) );
            goto call;

      default:
            fatal1("mkfunct: impossible vprocclass %d", np->b_name.vprocclass);
            q = 0; /* XXX gcc */
      }
ckfree(p);
return(q);

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



LOCAL struct bigblock *
stfcall(struct bigblock *np, struct bigblock *actlist)
{
      register chainp actuals;
      int nargs;
      chainp oactp, formals;
      int type;
      struct bigblock *q, *rhs;
      bigptr ap;
      register chainp rp;
      chainp tlist;

      if(actlist) {
            actuals = actlist->b_list.listp;
            ckfree(actlist);
      } else
            actuals = NULL;
      oactp = actuals;

      nargs = 0;
      tlist = NULL;
      type = np->vtype;

      formals = (chainp)np->b_name.vardesc.vstfdesc->chain.datap;
      rhs = (bigptr)np->b_name.vardesc.vstfdesc->chain.nextp;

      /* copy actual arguments into temporaries */
      while(actuals!=NULL && formals!=NULL) {
            rp = ALLOC(rplblock);
            rp->rplblock.rplnp = q = formals->chain.datap;
            ap = fixtype(actuals->chain.datap);
            if(q->vtype==ap->vtype && q->vtype!=TYCHAR
               && (ap->tag==TCONST || ap->tag==TADDR) ) {
                  rp->rplblock.rplvp = ap;
                  rp->rplblock.rplxp = NULL;
                  rp->rplblock.rpltag = ap->tag;
            } else      {
                  rp->rplblock.rplvp = fmktemp(q->vtype, q->vleng);
                  rp->rplblock.rplxp = fixtype( mkexpr(OPASSIGN,
                      cpexpr(rp->rplblock.rplvp), ap) );
                  if( (rp->rplblock.rpltag =
                      rp->rplblock.rplxp->tag) == TERROR)
                        err("disagreement of argument types in statement function call");
            }
            rp->rplblock.nextp = tlist;
            tlist = rp;
            actuals = actuals->chain.nextp;
            formals = formals->chain.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->rplblock.rplxp)
                  q = mkexpr(OPCOMMA, rpllist->rplblock.rplxp, q);
            rp = rpllist->rplblock.nextp;
            frexpr(rpllist->rplblock.rplvp);
            ckfree(rpllist);
            rpllist = rp;
      }

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




struct bigblock *
mklhs(struct bigblock *p)
{
      struct bigblock *s;
      struct bigblock *np;
      chainp rp;
      int regn;

      /* first fixup name */

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

      np = p->b_prim.namep;

      /* is name on the replace list? */

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

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

      if(np->b_name.vdovar && ( (regn = inregister(np)) >= 0) ) {
            if(np->vtype == TYERROR)
                  return( errnode() );
            else {
                  s = BALLO();
                  s->tag = TADDR;
                  s->vstg = STGREG;
                  s->vtype = TYIREG;
                  s->b_addr.memno = regn;
                  s->b_addr.memoffset = MKICON(0);
                  return(s);
            }
      }

      vardcl(np);
      s = mkaddr(np);
      s->b_addr.memoffset = mkexpr(OPPLUS, s->b_addr.memoffset, suboffset(p) );
      frexpr(p->b_prim.argsp);
      p->b_prim.argsp = NULL;

      /* now do substring part */

      if(p->b_prim.fcharp || p->b_prim.lcharp) {
            if(np->vtype != TYCHAR)
                  err1("substring of noncharacter %s",
                      varstr(VL,np->b_name.varname));
            else  {
                  if(p->b_prim.lcharp == NULL)
                        p->b_prim.lcharp = cpexpr(s->vleng);
                  if(p->b_prim.fcharp)
                        s->vleng = mkexpr(OPMINUS, p->b_prim.lcharp,
                              mkexpr(OPMINUS, p->b_prim.fcharp, MKICON(1) ));
                  else  {
                        frexpr(s->vleng);
                        s->vleng = p->b_prim.lcharp;
                  }
            }
      }

      s->vleng = fixtype( s->vleng );
      s->b_addr.memoffset = fixtype( s->b_addr.memoffset );
      ckfree(p);
      return(s);
}




void
deregister(np)
struct bigblock *np;
{
}




struct bigblock *memversion(np)
register struct bigblock *np;
{
register struct bigblock *s;

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


int
inregister(np)
register struct bigblock *np;
{
return(-1);
}



int
enregister(np)
struct bigblock *np;
{
      return(NO);
}




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

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

dimp = np->b_name.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->b_name.varname) );
else if(n > 0)
      {
      prod = sub[--n];
      while( --n >= 0)
            prod = mkexpr(OPPLUS, sub[n],
                  mkexpr(OPSTAR, prod, cpexpr(dimp->dims[n].dimsize)) );
#ifdef __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 = MKICON( typesize[np->vtype] );
      prod = mkexpr(OPSTAR, prod, size);
      offp = mkexpr(OPPLUS, offp, prod);
      }

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

return(offp);
}


/*
 * Check if an array is addressed out of bounds.
 */
bigptr
subcheck(struct bigblock *np, bigptr p)
{
      struct dimblock *dimp;
      bigptr t, badcall;
      int l1, l2;

      dimp = np->b_name.vdim;
      if(dimp->nelt == NULL)
            return(p);  /* don't check arrays with * bounds */
      if( ISICON(p) ) {
            if(p->b_const.fconst.ci < 0)
                  goto badsub;
            if( ISICON(dimp->nelt) ) {
                  if(p->b_const.fconst.ci < dimp->nelt->b_const.fconst.ci)
                        return(p);
                  else
                        goto badsub;
            }
      }

      if (p->tag==TADDR && p->vstg==STGREG) {
            t = p;
      } else {
            t = fmktemp(p->vtype, NULL);
            putexpr(mkexpr(OPASSIGN, cpexpr(t), p));
      }
      /* t now cotains evaluated expression */

      l1 = newlabel();
      l2 = newlabel();
      putif(mkexpr(OPLT, cpexpr(t), cpexpr(dimp->nelt)), l1);
      putif(mkexpr(OPGE, cpexpr(t), MKICON(0)), l1);
      putgoto(l2);
      putlabel(l1);
      
      badcall = call4(t->vtype, "s_rnge", mkstrcon(VL, np->b_name.varname),
            mkconv(TYLONG,  cpexpr(t)),
            mkstrcon(XL, procname), MKICON(lineno));
      badcall->b_expr.opcode = OPCCALL;

      putexpr(badcall);
      putlabel(l2);
      return t;

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




struct bigblock *mkaddr(p)
register struct bigblock *p;
{
struct extsym *extp;
register struct bigblock *t;

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

      case STGCOMMON:
      case STGEXT:
      case STGBSS:
      case STGINIT:
      case STGEQUIV:
      case STGARG:
      case STGLENG:
      case STGAUTO:
            t = BALLO();
            t->tag = TADDR;
            t->vclass = p->vclass;
            t->vtype = p->vtype;
            t->vstg = p->vstg;
            t->b_addr.memno = p->b_name.vardesc.varno;
            t->b_addr.memoffset = MKICON(p->b_name.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 */
return 0; /* XXX gcc */
}



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

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




bigptr mkprim(v, args, lstr, rstr)
register bigptr v;
struct bigblock *args;
bigptr lstr, rstr;
{
register struct bigblock *p;

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

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


void
vardcl(v)
register struct bigblock *v;
{
int nelt;
struct dimblock *t;
struct bigblock *p;
bigptr neltp;

if(v->b_name.vdcldone) return;

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

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

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



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

if(p->b_name.vdcldone || (p->vclass==CLPROC && p->b_name.vprocclass==PINTRINSIC) )
      return;
if(p->vtype == TYUNKNOWN)
      {
      k = letter(p->b_name.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 int
letter(c)
register int c;
{
if( isupper(c) )
      c = tolower(c);
return(c - 'a');
}

#define ICONEQ(z, c)  (ISICON(z) && z->b_const.fconst.ci==c)
#define COMMUTE   { e = lp;  lp = rp;  rp = e; }


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

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

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


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

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

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

                  e1 = lp->b_expr.leftp;
                  ckfree(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->b_const.fconst.ci == 0)
                        goto retleft;
                  if( ISPLUSOP(lp) && ISICON(lp->b_expr.rightp) )
                        {
                        e = mkexpr(OPPLUS, lp->b_expr.rightp, rp);
                        e1 = lp->b_expr.leftp;
                        ckfree(lp);
                        return( mkexpr(OPPLUS, e1, e) );
                        }
                  }
            break;


      case OPPOWER:
            break;

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

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

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

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

            if( ISCONST(rp) )
                  {
                  if(rp->b_const.fconst.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:
      case OPRSHIFT:

      case OPLT:
      case OPGT:
      case OPLE:
      case OPGE:
      case OPEQ:
      case OPNE:

      case OPCONCAT:
            break;
      case OPMIN:
      case OPMAX:

      case OPASSIGN:

      case OPCONV:
      case OPADDR:

      case OPCOMMA:
            break;

      default:
            fatal1("mkexpr: impossible opcode %d", opcode);
      }

e = BALLO();
e->tag = TEXPR;
e->b_expr.opcode = opcode;
e->vtype = etype;
e->b_expr.leftp = lp;
e->b_expr.rightp = rp;
if(ltag==TCONST && (rp==0 || rtag==TCONST) )
      e = fold(e);
return(e);

retleft:
      frexpr(rp);
      return(lp);

retright:
      frexpr(lp);
      return(rp);

error:
      frexpr(lp);
      if(rp && opcode!=OPCALL && opcode!=OPCCALL)
            frexpr(rp);
      return( errnode() );
}

#define ERR(s)   { errs = s; goto error; }

int
cktype(op, lt, rt)
register int op, lt, rt;
{
char *errs = NULL; /* XXX gcc */

if(lt==TYERROR || rt==TYERROR)
      goto error1;

if(lt==TYUNKNOWN)
      return(TYUNKNOWN);
if(rt==TYUNKNOWN)
      if(op!=OPNOT && op!=OPBITNOT && op!=OPNEG && op!=OPCALL && op!=OPCCALL && op!=OPADDR)
            return(TYUNKNOWN);

switch(op)
      {
      case OPPLUS:
      case OPMINUS:
      case OPSTAR:
      case OPSLASH:
      case OPPOWER:
      case OPMOD:
            if( ISNUMERIC(lt) && ISNUMERIC(rt) )
                  return( maxtype(lt, rt) );
            ERR("nonarithmetic operand of arithmetic operator")

      case OPNEG:
            if( ISNUMERIC(lt) )
                  return(lt);
            ERR("nonarithmetic operand of negation")

      case OPNOT:
            if(lt == TYLOGICAL)
                  return(TYLOGICAL);
            ERR("NOT of nonlogical")

      case OPAND:
      case OPOR:
      case OPEQV:
      case OPNEQV:
            if(lt==TYLOGICAL && rt==TYLOGICAL)
                  return(TYLOGICAL);
            ERR("nonlogical operand of logical operator")

      case OPLT:
      case OPGT:
      case OPLE:
      case OPGE:
      case OPEQ:
      case OPNE:
            if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
                  {
                  if(lt != rt)
                        ERR("illegal comparison")
                  }

            else if( ISCOMPLEX(lt) || ISCOMPLEX(rt) )
                  {
                  if(op!=OPEQ && op!=OPNE)
                        ERR("order comparison of complex data")
                  }

            else if( ! ISNUMERIC(lt) || ! ISNUMERIC(rt) )
                  ERR("comparison of nonarithmetic data")
            return(TYLOGICAL);

      case OPCONCAT:
            if(lt==TYCHAR && rt==TYCHAR)
                  return(TYCHAR);
            ERR("concatenation of nonchar data")

      case OPCALL:
      case OPCCALL:
            return(lt);

      case OPADDR:
            return(TYADDR);

      case OPCONV:
            if(rt == 0)
                  return(0);
      case OPASSIGN:
            if( ISINT(lt) && rt==TYCHAR)
                  return(lt);
            if(lt==TYCHAR || rt==TYCHAR || lt==TYLOGICAL || rt==TYLOGICAL)
                  if(op!=OPASSIGN || lt!=rt)
                        {
/* debug fprintf(diagfile, " lt=%d, rt=%d, op=%d\n", lt, rt, op); */
/* debug fatal("impossible conversion.  possible compiler bug"); */
                        ERR("impossible conversion")
                        }
            return(lt);

      case OPMIN:
      case OPMAX:
      case OPBITOR:
      case OPBITAND:
      case OPBITXOR:
      case OPBITNOT:
      case OPLSHIFT:
      case OPRSHIFT:
            return(lt);

      case OPCOMMA:
            return(rt);

      default:
            fatal1("cktype: impossible opcode %d", op);
      }
error:      err(errs);
error1:     return(TYERROR);
}

LOCAL bigptr fold(e)
register struct bigblock *e;
{
struct bigblock *p;
register bigptr lp, rp;
int etype, mtype, ltype, rtype, opcode;
int i, ll, lr;
char *q, *s;
union constant lcon, rcon;

opcode = e->b_expr.opcode;
etype = e->vtype;

lp = e->b_expr.leftp;
ltype = lp->vtype;
rp = e->b_expr.rightp;

if(rp == 0)
      switch(opcode)
            {
            case OPNOT:
                  lp->b_const.fconst.ci = ! lp->b_const.fconst.ci;
                  return(lp);

            case OPBITNOT:
                  lp->b_const.fconst.ci = ~ lp->b_const.fconst.ci;
                  return(lp);

            case OPNEG:
                  consnegop(lp);
                  return(lp);

            case OPCONV:
            case OPADDR:
                  return(e);

            default:
                  fatal1("fold: invalid unary operator %d", opcode);
            }

rtype = rp->vtype;

p = BALLO();
p->tag = TCONST;
p->vtype = etype;
p->vleng = e->vleng;

switch(opcode)
      {
      case OPCOMMA:
            return(e);

      case OPAND:
            p->b_const.fconst.ci = lp->b_const.fconst.ci && rp->b_const.fconst.ci;
            break;

      case OPOR:
            p->b_const.fconst.ci = lp->b_const.fconst.ci || rp->b_const.fconst.ci;
            break;

      case OPEQV:
            p->b_const.fconst.ci = lp->b_const.fconst.ci == rp->b_const.fconst.ci;
            break;

      case OPNEQV:
            p->b_const.fconst.ci = lp->b_const.fconst.ci != rp->b_const.fconst.ci;
            break;

      case OPBITAND:
            p->b_const.fconst.ci = lp->b_const.fconst.ci & rp->b_const.fconst.ci;
            break;

      case OPBITOR:
            p->b_const.fconst.ci = lp->b_const.fconst.ci | rp->b_const.fconst.ci;
            break;

      case OPBITXOR:
            p->b_const.fconst.ci = lp->b_const.fconst.ci ^ rp->b_const.fconst.ci;
            break;

      case OPLSHIFT:
            p->b_const.fconst.ci = lp->b_const.fconst.ci << rp->b_const.fconst.ci;
            break;

      case OPRSHIFT:
            p->b_const.fconst.ci = lp->b_const.fconst.ci >> rp->b_const.fconst.ci;
            break;

      case OPCONCAT:
            ll = lp->vleng->b_const.fconst.ci;
            lr = rp->vleng->b_const.fconst.ci;
            p->b_const.fconst.ccp = q = (char *) ckalloc(ll+lr);
            p->vleng = MKICON(ll+lr);
            s = lp->b_const.fconst.ccp;
            for(i = 0 ; i < ll ; ++i)
                  *q++ = *s++;
            s = rp->b_const.fconst.ccp;
            for(i = 0; i < lr; ++i)
                  *q++ = *s++;
            break;


      case OPPOWER:
            if( ! ISINT(rtype) )
                  return(e);
            conspower(&(p->b_const.fconst), lp, rp->b_const.fconst.ci);
            break;


      default:
            if(ltype == TYCHAR)
                  {
                  lcon.ci = cmpstr(lp->b_const.fconst.ccp, rp->b_const.fconst.ccp,
                              lp->vleng->b_const.fconst.ci, rp->vleng->b_const.fconst.ci);
                  rcon.ci = 0;
                  mtype = tyint;
                  }
            else  {
                  mtype = maxtype(ltype, rtype);
                  consconv(mtype, &lcon, ltype, &(lp->b_const.fconst) );
                  consconv(mtype, &rcon, rtype, &(rp->b_const.fconst) );
                  }
            consbinop(opcode, mtype, &(p->b_const.fconst), &lcon, &rcon);
            break;
      }

frexpr(e);
return(p);
}



/* assign constant l = r , doing coercion */
void
consconv(lt, lv, rt, rv)
int lt, rt;
register union constant *lv, *rv;
{
switch(lt)
      {
      case TYSHORT:
      case TYLONG:
            if( ISINT(rt) )
                  lv->ci = rv->ci;
            else  lv->ci = rv->cd[0];
            break;

      case TYCOMPLEX:
      case TYDCOMPLEX:
            switch(rt)
                  {
                  case TYSHORT:
                  case TYLONG:
                        /* fall through and do real assignment of
                           first element
                        */
                  case TYREAL:
                  case TYDREAL:
                        lv->cd[1] = 0; break;
                  case TYCOMPLEX:
                  case TYDCOMPLEX:
                        lv->cd[1] = rv->cd[1]; break;
                  }

      case TYREAL:
      case TYDREAL:
            if( ISINT(rt) )
                  lv->cd[0] = rv->ci;
            else  lv->cd[0] = rv->cd[0];
            break;

      case TYLOGICAL:
            lv->ci = rv->ci;
            break;
      }
}


void
consnegop(p)
register struct bigblock *p;
{
switch(p->vtype)
      {
      case TYSHORT:
      case TYLONG:
            p->b_const.fconst.ci = - p->b_const.fconst.ci;
            break;

      case TYCOMPLEX:
      case TYDCOMPLEX:
            p->b_const.fconst.cd[1] = - p->b_const.fconst.cd[1];
            /* fall through and do the real parts */
      case TYREAL:
      case TYDREAL:
            p->b_const.fconst.cd[0] = - p->b_const.fconst.cd[0];
            break;
      default:
            fatal1("consnegop: impossible type %d", p->vtype);
      }
}



LOCAL void
conspower(powp, ap, n)
register union constant *powp;
struct bigblock *ap;
ftnint n;
{
register int type;
union constant x;

switch(type = ap->vtype)      /* pow = 1 */ 
      {
      case TYSHORT:
      case TYLONG:
            powp->ci = 1;
            break;
      case TYCOMPLEX:
      case TYDCOMPLEX:
            powp->cd[1] = 0;
      case TYREAL:
      case TYDREAL:
            powp->cd[0] = 1;
            break;
      default:
            fatal1("conspower: invalid type %d", type);
      }

if(n == 0)
      return;
if(n < 0)
      {
      if( ISINT(type) )
            {
            err("integer ** negative power ");
            return;
            }
      n = - n;
      consbinop(OPSLASH, type, &x, powp, &(ap->b_const.fconst));
      }
else
      consbinop(OPSTAR, type, &x, powp, &(ap->b_const.fconst));

for( ; ; )
      {
      if(n & 01)
            consbinop(OPSTAR, type, powp, powp, &x);
      if(n >>= 1)
            consbinop(OPSTAR, type, &x, &x, &x);
      else
            break;
      }
}



/* do constant operation cp = a op b */


LOCAL void
consbinop(opcode, type, cp, ap, bp)
int opcode, type;
register union constant *ap, *bp, *cp;
{
int k;
double temp;

switch(opcode)
      {
      case OPPLUS:
            switch(type)
                  {
                  case TYSHORT:
                  case TYLONG:
                        cp->ci = ap->ci + bp->ci;
                        break;
                  case TYCOMPLEX:
                  case TYDCOMPLEX:
                        cp->cd[1] = ap->cd[1] + bp->cd[1];
                  case TYREAL:
                  case TYDREAL:
                        cp->cd[0] = ap->cd[0] + bp->cd[0];
                        break;
                  }
            break;

      case OPMINUS:
            switch(type)
                  {
                  case TYSHORT:
                  case TYLONG:
                        cp->ci = ap->ci - bp->ci;
                        break;
                  case TYCOMPLEX:
                  case TYDCOMPLEX:
                        cp->cd[1] = ap->cd[1] - bp->cd[1];
                  case TYREAL:
                  case TYDREAL:
                        cp->cd[0] = ap->cd[0] - bp->cd[0];
                        break;
                  }
            break;

      case OPSTAR:
            switch(type)
                  {
                  case TYSHORT:
                  case TYLONG:
                        cp->ci = ap->ci * bp->ci;
                        break;
                  case TYREAL:
                  case TYDREAL:
                        cp->cd[0] = ap->cd[0] * bp->cd[0];
                        break;
                  case TYCOMPLEX:
                  case TYDCOMPLEX:
                        temp = ap->cd[0] * bp->cd[0] -
                                  ap->cd[1] * bp->cd[1] ;
                        cp->cd[1] = ap->cd[0] * bp->cd[1] +
                                  ap->cd[1] * bp->cd[0] ;
                        cp->cd[0] = temp;
                        break;
                  }
            break;
      case OPSLASH:
            switch(type)
                  {
                  case TYSHORT:
                  case TYLONG:
                        cp->ci = ap->ci / bp->ci;
                        break;
                  case TYREAL:
                  case TYDREAL:
                        cp->cd[0] = ap->cd[0] / bp->cd[0];
                        break;
                  case TYCOMPLEX:
                  case TYDCOMPLEX:
                        zdiv(&cp->dc, &ap->dc, &bp->dc);
                        break;
                  }
            break;

      case OPMOD:
            if( ISINT(type) )
                  {
                  cp->ci = ap->ci % bp->ci;
                  break;
                  }
            else
                  fatal("inline mod of noninteger");

      default:      /* relational ops */
            switch(type)
                  {
                  case TYSHORT:
                  case TYLONG:
                        if(ap->ci < bp->ci)
                              k = -1;
                        else if(ap->ci == bp->ci)
                              k = 0;
                        else  k = 1;
                        break;
                  case TYREAL:
                  case TYDREAL:
                        if(ap->cd[0] < bp->cd[0])
                              k = -1;
                        else if(ap->cd[0] == bp->cd[0])
                              k = 0;
                        else  k = 1;
                        break;
                  case TYCOMPLEX:
                  case TYDCOMPLEX:
                        if(ap->cd[0] == bp->cd[0] &&
                           ap->cd[1] == bp->cd[1] )
                              k = 0;
                        else  k = 1;
                        break;
                  default: /* XXX gcc */
                        k = 0;
                        break;
                  }

            switch(opcode)
                  {
                  case OPEQ:
                        cp->ci = (k == 0);
                        break;
                  case OPNE:
                        cp->ci = (k != 0);
                        break;
                  case OPGT:
                        cp->ci = (k == 1);
                        break;
                  case OPLT:
                        cp->ci = (k == -1);
                        break;
                  case OPGE:
                        cp->ci = (k >= 0);
                        break;
                  case OPLE:
                        cp->ci = (k <= 0);
                        break;
                  }
            break;
      }
}



int
conssgn(p)
register bigptr p;
{
if( ! ISCONST(p) )
      fatal( "sgn(nonconstant)" );

switch(p->vtype)
      {
      case TYSHORT:
      case TYLONG:
            if(p->b_const.fconst.ci > 0) return(1);
            if(p->b_const.fconst.ci < 0) return(-1);
            return(0);

      case TYREAL:
      case TYDREAL:
            if(p->b_const.fconst.cd[0] > 0) return(1);
            if(p->b_const.fconst.cd[0] < 0) return(-1);
            return(0);

      case TYCOMPLEX:
      case TYDCOMPLEX:
            return(p->b_const.fconst.cd[0]!=0 || p->b_const.fconst.cd[1]!=0);

      default:
            fatal1( "conssgn(type %d)", p->vtype);
      }
/* NOTREACHED */
return 0; /* XXX gcc */
}

char *powint[ ] = { "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" };


LOCAL bigptr mkpower(p)
register struct bigblock *p;
{
register bigptr q, lp, rp;
int ltype, rtype, mtype;

lp = p->b_expr.leftp;
rp = p->b_expr.rightp;
ltype = lp->vtype;
rtype = rp->vtype;

if(ISICON(rp))
      {
      if(rp->b_const.fconst.ci == 0)
            {
            frexpr(p);
            if( ISINT(ltype) )
                  return( MKICON(1) );
            else
                  return( putconst( mkconv(ltype, MKICON(1))) );
            }
      if(rp->b_const.fconst.ci < 0)
            {
            if( ISINT(ltype) )
                  {
                  frexpr(p);
                  err("integer**negative");
                  return( errnode() );
                  }
            rp->b_const.fconst.ci = - rp->b_const.fconst.ci;
            p->b_expr.leftp = lp = fixexpr(mkexpr(OPSLASH, MKICON(1), lp));
            }
      if(rp->b_const.fconst.ci == 1)
            {
            frexpr(rp);
            ckfree(p);
            return(lp);
            }

      if( ONEOF(ltype, MSKINT|MSKREAL) )
            {
            p->vtype = ltype;
            return(p);
            }
      }
if( ISINT(rtype) )
      {
      if(ltype==TYSHORT && rtype==TYSHORT)
            q = call2(TYSHORT, "pow_hh", lp, rp);
      else  {
            if(ltype == TYSHORT)
                  {
                  ltype = TYLONG;
                  lp = mkconv(TYLONG,lp);
                  }
            q = call2(ltype, powint[ltype-TYLONG], lp, mkconv(TYLONG, rp));
            }
      }
else if( ISREAL( (mtype = maxtype(ltype,rtype)) ))
      q = call2(mtype, "pow_dd",
            mkconv(TYDREAL,lp), mkconv(TYDREAL,rp));
else  {
      q = call2(TYDCOMPLEX, "pow_zz",
            mkconv(TYDCOMPLEX,lp), mkconv(TYDCOMPLEX,rp));
      if(mtype == TYCOMPLEX)
            q = mkconv(TYCOMPLEX, q);
      }
ckfree(p);
return(q);
}



/* Complex Division.  Same code as in Runtime Library
*/



LOCAL void
zdiv(c, a, b)
register struct dcomplex *a, *b, *c;
{
double ratio, den;
double abr, abi;

if( (abr = b->dreal) < 0.)
      abr = - abr;
if( (abi = b->dimag) < 0.)
      abi = - abi;
if( abr <= abi )
      {
      if(abi == 0)
            fatal("complex division by zero");
      ratio = b->dreal / b->dimag ;
      den = b->dimag * (1 + ratio*ratio);
      c->dreal = (a->dreal*ratio + a->dimag) / den;
      c->dimag = (a->dimag*ratio - a->dreal) / den;
      }

else
      {
      ratio = b->dimag / b->dreal ;
      den = b->dreal * (1 + ratio*ratio);
      c->dreal = (a->dreal + a->dimag*ratio) / den;
      c->dimag = (a->dimag - a->dreal*ratio) / den;
      }

}

Generated by  Doxygen 1.6.0   Back to index