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

intr.c

/*    $Id: intr.c,v 1.13 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 conditions and 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 "defines.h"
#include "defs.h"


static struct bigblock *finline(int, int, chainp);

union
      {
      int ijunk;
      struct intrpacked bits;
      } packed;

00048 struct intrbits
      {
      int intrgroup /* :3 */;
      int intrstuff /* result type or number of generics */;
      int intrno /* :7 */;
      };

00055 LOCAL struct intrblock
      {
      char intrfname[VL];
      struct intrbits intrval;
      } intrtab[ ] =
{
{ "int",          { INTRCONV, TYLONG }, },
{ "real",   { INTRCONV, TYREAL }, },
{ "dble",   { INTRCONV, TYDREAL }, },
{ "cmplx",  { INTRCONV, TYCOMPLEX }, },
{ "dcmplx",       { INTRCONV, TYDCOMPLEX }, },
{ "ifix",   { INTRCONV, TYLONG }, },
{ "idint",  { INTRCONV, TYLONG }, },
{ "float",  { INTRCONV, TYREAL }, },
{ "dfloat", { INTRCONV, TYDREAL }, },
{ "sngl",   { INTRCONV, TYREAL }, },
{ "ichar",  { INTRCONV, TYLONG }, },
{ "char",   { INTRCONV, TYCHAR }, },

{ "max",          { INTRMAX, TYUNKNOWN }, },
{ "max0",   { INTRMAX, TYLONG }, },
{ "amax0",  { INTRMAX, TYREAL }, },
{ "max1",   { INTRMAX, TYLONG }, },
{ "amax1",  { INTRMAX, TYREAL }, },
{ "dmax1",  { INTRMAX, TYDREAL }, },

{ "and",          { INTRBOOL, TYUNKNOWN, OPBITAND }, },
{ "or",           { INTRBOOL, TYUNKNOWN, OPBITOR }, },
{ "xor",          { INTRBOOL, TYUNKNOWN, OPBITXOR }, },
{ "not",          { INTRBOOL, TYUNKNOWN, OPBITNOT }, },
{ "lshift", { INTRBOOL, TYUNKNOWN, OPLSHIFT }, },
{ "rshift", { INTRBOOL, TYUNKNOWN, OPRSHIFT }, },

{ "min",          { INTRMIN, TYUNKNOWN }, },
{ "min0",   { INTRMIN, TYLONG }, },
{ "amin0",  { INTRMIN, TYREAL }, },
{ "min1",   { INTRMIN, TYLONG }, },
{ "amin1",  { INTRMIN, TYREAL }, },
{ "dmin1",  { INTRMIN, TYDREAL }, },

{ "aint",   { INTRGEN, 2, 0 }, },
{ "dint",   { INTRSPEC, TYDREAL, 1 }, },

{ "anint",  { INTRGEN, 2, 2 }, },
{ "dnint",  { INTRSPEC, TYDREAL, 3 }, },

{ "nint",   { INTRGEN, 4, 4 }, },
{ "idnint",       { INTRGEN, 2, 6 }, },

{ "abs",          { INTRGEN, 6, 8 }, },
{ "iabs",   { INTRGEN, 2, 9 }, },
{ "dabs",   { INTRSPEC, TYDREAL, 11 }, },
{ "cabs",   { INTRSPEC, TYREAL, 12 }, },
{ "zabs",   { INTRSPEC, TYDREAL, 13 }, },

{ "mod",          { INTRGEN, 4, 14 }, },
{ "amod",   { INTRSPEC, TYREAL, 16 }, },
{ "dmod",   { INTRSPEC, TYDREAL, 17 }, },

{ "sign",   { INTRGEN, 4, 18 }, },
{ "isign",  { INTRGEN, 2, 19 }, },
{ "dsign",  { INTRSPEC, TYDREAL, 21 }, },

{ "dim",          { INTRGEN, 4, 22 }, },
{ "idim",   { INTRGEN, 2, 23 }, },
{ "ddim",   { INTRSPEC, TYDREAL, 25 }, },

{ "dprod",  { INTRSPEC, TYDREAL, 26 }, },

{ "len",          { INTRSPEC, TYLONG, 27 }, },
{ "index",  { INTRSPEC, TYLONG, 29 }, },

{ "imag",   { INTRGEN, 2, 31 }, },
{ "aimag",  { INTRSPEC, TYREAL, 31 }, },
{ "dimag",  { INTRSPEC, TYDREAL, 32 }, },

{ "conjg",  { INTRGEN, 2, 33 }, },
{ "dconjg",       { INTRSPEC, TYDCOMPLEX, 34 }, },

{ "sqrt",   { INTRGEN, 4, 35 }, },
{ "dsqrt",  { INTRSPEC, TYDREAL, 36 }, },
{ "csqrt",  { INTRSPEC, TYCOMPLEX, 37 }, },
{ "zsqrt",  { INTRSPEC, TYDCOMPLEX, 38 }, },

{ "exp",          { INTRGEN, 4, 39 }, },
{ "dexp",   { INTRSPEC, TYDREAL, 40 }, },
{ "cexp",   { INTRSPEC, TYCOMPLEX, 41 }, },
{ "zexp",   { INTRSPEC, TYDCOMPLEX, 42 }, },

{ "log",          { INTRGEN, 4, 43 }, },
{ "alog",   { INTRSPEC, TYREAL, 43 }, },
{ "dlog",   { INTRSPEC, TYDREAL, 44 }, },
{ "clog",   { INTRSPEC, TYCOMPLEX, 45 }, },
{ "zlog",   { INTRSPEC, TYDCOMPLEX, 46 }, },

{ "log10",  { INTRGEN, 2, 47 }, },
{ "alog10",       { INTRSPEC, TYREAL, 47 }, },
{ "dlog10",       { INTRSPEC, TYDREAL, 48 }, },

{ "sin",          { INTRGEN, 4, 49 }, },
{ "dsin",   { INTRSPEC, TYDREAL, 50 }, },
{ "csin",   { INTRSPEC, TYCOMPLEX, 51 }, },
{ "zsin",   { INTRSPEC, TYDCOMPLEX, 52 }, },

{ "cos",          { INTRGEN, 4, 53 }, },
{ "dcos",   { INTRSPEC, TYDREAL, 54 }, },
{ "ccos",   { INTRSPEC, TYCOMPLEX, 55 }, },
{ "zcos",   { INTRSPEC, TYDCOMPLEX, 56 }, },

{ "tan",          { INTRGEN, 2, 57 }, },
{ "dtan",   { INTRSPEC, TYDREAL, 58 }, },

{ "asin",   { INTRGEN, 2, 59 }, },
{ "dasin",  { INTRSPEC, TYDREAL, 60 }, },

{ "acos",   { INTRGEN, 2, 61 }, },
{ "dacos",  { INTRSPEC, TYDREAL, 62 }, },

{ "atan",   { INTRGEN, 2, 63 }, },
{ "datan",  { INTRSPEC, TYDREAL, 64 }, },

{ "atan2",  { INTRGEN, 2, 65 }, },
{ "datan2",       { INTRSPEC, TYDREAL, 66 }, },

{ "sinh",   { INTRGEN, 2, 67 }, },
{ "dsinh",  { INTRSPEC, TYDREAL, 68 }, },

{ "cosh",   { INTRGEN, 2, 69 }, },
{ "dcosh",  { INTRSPEC, TYDREAL, 70 }, },

{ "tanh",   { INTRGEN, 2, 71 }, },
{ "dtanh",  { INTRSPEC, TYDREAL, 72 }, },

{ "lge",          { INTRSPEC, TYLOGICAL, 73}, },
{ "lgt",          { INTRSPEC, TYLOGICAL, 75}, },
{ "lle",          { INTRSPEC, TYLOGICAL, 77}, },
{ "llt",          { INTRSPEC, TYLOGICAL, 79}, },

{ "" }, };


00196 LOCAL struct specblock
      {
      char atype;
      char rtype;
      char nargs;
      char spxname[XL];
      char othername;   /* index into callbyvalue table */
      } spectab[ ] =
{
      { TYREAL,TYREAL,1,"r_int" },
      { TYDREAL,TYDREAL,1,"d_int" },

      { TYREAL,TYREAL,1,"r_nint" },
      { TYDREAL,TYDREAL,1,"d_nint" },

      { TYREAL,TYSHORT,1,"h_nint" },
      { TYREAL,TYLONG,1,"i_nint" },

      { TYDREAL,TYSHORT,1,"h_dnnt" },
      { TYDREAL,TYLONG,1,"i_dnnt" },

      { TYREAL,TYREAL,1,"r_abs" },
      { TYSHORT,TYSHORT,1,"h_abs" },
      { TYLONG,TYLONG,1,"i_abs" },
      { TYDREAL,TYDREAL,1,"d_abs" },
      { TYCOMPLEX,TYREAL,1,"c_abs" },
      { TYDCOMPLEX,TYDREAL,1,"z_abs" },

      { TYSHORT,TYSHORT,2,"h_mod" },
      { TYLONG,TYLONG,2,"i_mod" },
      { TYREAL,TYREAL,2,"r_mod" },
      { TYDREAL,TYDREAL,2,"d_mod" },

      { TYREAL,TYREAL,2,"r_sign" },
      { TYSHORT,TYSHORT,2,"h_sign" },
      { TYLONG,TYLONG,2,"i_sign" },
      { TYDREAL,TYDREAL,2,"d_sign" },

      { TYREAL,TYREAL,2,"r_dim" },
      { TYSHORT,TYSHORT,2,"h_dim" },
      { TYLONG,TYLONG,2,"i_dim" },
      { TYDREAL,TYDREAL,2,"d_dim" },

      { TYREAL,TYDREAL,2,"d_prod" },

      { TYCHAR,TYSHORT,1,"h_len" },
      { TYCHAR,TYLONG,1,"i_len" },

      { TYCHAR,TYSHORT,2,"h_indx" },
      { TYCHAR,TYLONG,2,"i_indx" },

      { TYCOMPLEX,TYREAL,1,"r_imag" },
      { TYDCOMPLEX,TYDREAL,1,"d_imag" },
      { TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" },
      { TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" },

      { TYREAL,TYREAL,1,"r_sqrt", 1 },
      { TYDREAL,TYDREAL,1,"d_sqrt", 1 },
      { TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" },
      { TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" },

      { TYREAL,TYREAL,1,"r_exp", 2 },
      { TYDREAL,TYDREAL,1,"d_exp", 2 },
      { TYCOMPLEX,TYCOMPLEX,1,"c_exp" },
      { TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" },

      { TYREAL,TYREAL,1,"r_log", 3 },
      { TYDREAL,TYDREAL,1,"d_log", 3 },
      { TYCOMPLEX,TYCOMPLEX,1,"c_log" },
      { TYDCOMPLEX,TYDCOMPLEX,1,"z_log" },

      { TYREAL,TYREAL,1,"r_lg10" },
      { TYDREAL,TYDREAL,1,"d_lg10" },

      { TYREAL,TYREAL,1,"r_sin", 4 },
      { TYDREAL,TYDREAL,1,"d_sin", 4 },
      { TYCOMPLEX,TYCOMPLEX,1,"c_sin" },
      { TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" },

      { TYREAL,TYREAL,1,"r_cos", 5 },
      { TYDREAL,TYDREAL,1,"d_cos", 5 },
      { TYCOMPLEX,TYCOMPLEX,1,"c_cos" },
      { TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" },

      { TYREAL,TYREAL,1,"r_tan", 6 },
      { TYDREAL,TYDREAL,1,"d_tan", 6 },

      { TYREAL,TYREAL,1,"r_asin", 7 },
      { TYDREAL,TYDREAL,1,"d_asin", 7 },

      { TYREAL,TYREAL,1,"r_acos", 8 },
      { TYDREAL,TYDREAL,1,"d_acos", 8 },

      { TYREAL,TYREAL,1,"r_atan", 9 },
      { TYDREAL,TYDREAL,1,"d_atan", 9 },

      { TYREAL,TYREAL,2,"r_atn2", 10 },
      { TYDREAL,TYDREAL,2,"d_atn2", 10 },

      { TYREAL,TYREAL,1,"r_sinh", 11 },
      { TYDREAL,TYDREAL,1,"d_sinh", 11 },

      { TYREAL,TYREAL,1,"r_cosh", 12 },
      { TYDREAL,TYDREAL,1,"d_cosh", 12 },

      { TYREAL,TYREAL,1,"r_tanh", 13 },
      { TYDREAL,TYDREAL,1,"d_tanh", 13 },

      { TYCHAR,TYLOGICAL,2,"hl_ge" },
      { TYCHAR,TYLOGICAL,2,"l_ge" },

      { TYCHAR,TYLOGICAL,2,"hl_gt" },
      { TYCHAR,TYLOGICAL,2,"l_gt" },

      { TYCHAR,TYLOGICAL,2,"hl_le" },
      { TYCHAR,TYLOGICAL,2,"l_le" },

      { TYCHAR,TYLOGICAL,2,"hl_lt" },
      { TYCHAR,TYLOGICAL,2,"l_lt" }
} ;






char callbyvalue[ ][XL] =
      {
      "sqrt",
      "exp",
      "log",
      "sin",
      "cos",
      "tan",
      "asin",
      "acos",
      "atan",
      "atan2",
      "sinh",
      "cosh",
      "tanh"
      };

struct bigblock *
intrcall(np, argsp, nargs)
struct bigblock *np;
struct bigblock *argsp;
int nargs;
{
int i, rettype;
struct bigblock *ap;
register struct specblock *sp;
struct bigblock *q;
register chainp cp;
bigptr ep;
int mtype;
int op;

packed.ijunk = np->b_name.vardesc.varno;
if(nargs == 0)
      goto badnargs;

mtype = 0;
for(cp = argsp->b_list.listp ; cp ; cp = cp->chain.nextp)
      {
/* TEMPORARY */ ep = cp->chain.datap;
/* TEMPORARY */   if( ISCONST(ep) && ep->vtype==TYSHORT )
/* TEMPORARY */         cp->chain.datap = mkconv(tyint, ep);
      mtype = maxtype(mtype, ep->vtype);
      }

switch(packed.bits.f1)
      {
      case INTRBOOL:
            op = packed.bits.f3;
            if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
                  goto badtype;
            if(op == OPBITNOT)
                  {
                  if(nargs != 1)
                        goto badnargs;
                  q = mkexpr(OPBITNOT, argsp->b_list.listp->chain.datap, NULL);
                  }
            else
                  {
                  if(nargs != 2)
                        goto badnargs;
                  q = mkexpr(op, argsp->b_list.listp->chain.datap,
                        argsp->b_list.listp->chain.nextp->chain.datap);
                  }
            frchain( &(argsp->b_list.listp) );
            ckfree(argsp);
            return(q);

      case INTRCONV:
            rettype = packed.bits.f2;
            if(rettype == TYLONG)
                  rettype = tyint;
            if( ISCOMPLEX(rettype) && nargs==2)
                  {
                  bigptr qr, qi;
                  qr = argsp->b_list.listp->chain.datap;
                  qi = argsp->b_list.listp->chain.nextp->chain.datap;
                  if(ISCONST(qr) && ISCONST(qi))
                        q = mkcxcon(qr,qi);
                  else  q = mkexpr(OPCONV,mkconv(rettype-2,qr),
                              mkconv(rettype-2,qi));
                  }
            else if(nargs == 1)
                  q = mkconv(rettype, argsp->b_list.listp->chain.datap);
            else goto badnargs;

            q->vtype = rettype;
            frchain(&(argsp->b_list.listp));
            ckfree(argsp);
            return(q);


      case INTRGEN:
            sp = spectab + packed.bits.f3;
            for(i=0; i<packed.bits.f2 ; ++i)
                  if(sp->atype == mtype) {
                        if (tyint == TYLONG &&
                            sp->rtype == TYSHORT && 
                            sp[1].atype == mtype)
                              sp++; /* use long int */
                        goto specfunct;
                  } else
                        ++sp;
            goto badtype;

      case INTRSPEC:
            sp = spectab + packed.bits.f3;
            if(tyint==TYLONG && sp->rtype==TYSHORT)
                  ++sp;

      specfunct:
            if(nargs != sp->nargs)
                  goto badnargs;
            if(mtype != sp->atype)
                  goto badtype;
            fixargs(YES, argsp);
            if((q = finline(sp-spectab, mtype, argsp->b_list.listp)))
                  {
                  frchain( &(argsp->b_list.listp) );
                  ckfree(argsp);
                  }
            else if(sp->othername)
                  {
                  ap = builtin(sp->rtype,
                        varstr(XL, callbyvalue[sp->othername-1]) );
                  q = fixexpr( mkexpr(OPCCALL, ap, argsp) );
                  }
            else
                  {
                  ap = builtin(sp->rtype, varstr(XL, sp->spxname) );
                  q = fixexpr( mkexpr(OPCALL, ap, argsp) );
                  }
            return(q);

      case INTRMIN:
      case INTRMAX:
            if(nargs < 2)
                  goto badnargs;
            if( ! ONEOF(mtype, MSKINT|MSKREAL) )
                  goto badtype;
            argsp->vtype = mtype;
            q = mkexpr( (packed.bits.f1==INTRMIN ? OPMIN : OPMAX), argsp, NULL);

            q->vtype = mtype;
            rettype = packed.bits.f2;
            if(rettype == TYLONG)
                  rettype = tyint;
            else if(rettype == TYUNKNOWN)
                  rettype = mtype;
            return( mkconv(rettype, q) );

      default:
            fatal1("intrcall: bad intrgroup %d", packed.bits.f1);
      }
badnargs:
      err1("bad number of arguments to intrinsic %s",
            varstr(VL,np->b_name.varname) );
      goto bad;

badtype:
      err1("bad argument type to intrinsic %s", varstr(VL, np->b_name.varname) );

bad:
      return( errnode() );
}



int
intrfunct(s)
char s[VL];
{
register struct intrblock *p;
char nm[VL];
register int i;

for(i = 0 ; i<VL ; ++s)
      nm[i++] = (*s==' ' ? '\0' : *s);

for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p)
      {
      if( eqn(VL, nm, p->intrfname) )
            {
            packed.bits.f1 = p->intrval.intrgroup;
            packed.bits.f2 = p->intrval.intrstuff;
            packed.bits.f3 = p->intrval.intrno;
            return(packed.ijunk);
            }
      }

return(0);
}





struct bigblock *
intraddr(np)
struct bigblock *np;
{
struct bigblock *q;
struct specblock *sp;

if(np->vclass!=CLPROC || np->b_name.vprocclass!=PINTRINSIC)
      fatal1("intraddr: %s is not intrinsic", varstr(VL,np->b_name.varname));
packed.ijunk = np->b_name.vardesc.varno;

switch(packed.bits.f1)
      {
      case INTRGEN:
            /* imag, log, and log10 arent specific functions */
            if(packed.bits.f3==31 || packed.bits.f3==43 || packed.bits.f3==47)
                  goto bad;

      case INTRSPEC:
            sp = spectab + packed.bits.f3;
            if(tyint==TYLONG && sp->rtype==TYSHORT)
                  ++sp;
            q = builtin(sp->rtype, varstr(XL,sp->spxname) );
            return(q);

      case INTRCONV:
      case INTRMIN:
      case INTRMAX:
      case INTRBOOL:
      bad:
            err1("cannot pass %s as actual",
                  varstr(VL,np->b_name.varname));
            return( errnode() );
      }
fatal1("intraddr: impossible f1=%d\n", packed.bits.f1);
/* NOTREACHED */
return 0; /* XXX gcc */
}




/*
 * Try to inline simple function calls.
 */
struct bigblock *
finline(int fno, int type, chainp args)
{
      register struct bigblock *q, *t;
      struct bigblock *x1;
      int l1;

      switch(fno) {
      case 8:     /* real abs */
      case 9:     /* short int abs */
      case 10:    /* long int abs */
      case 11:    /* double precision abs */
            t = fmktemp(type, NULL);
            putexpr(mkexpr(OPASSIGN, cpexpr(t), args->chain.datap));
            /* value now in t */

            /* if greater, jump to return */
            x1 = mkexpr(OPLE, cpexpr(t), mkconv(type,MKICON(0)));
            l1 = newlabel();
            putif(x1, l1);

            /* negate */
            putexpr(mkexpr(OPASSIGN, cpexpr(t),
                mkexpr(OPNEG, cpexpr(t), NULL)));
            putlabel(l1);
            return(t);
            
      case 26:    /* dprod */
            q = mkexpr(OPSTAR, args->chain.datap, args->chain.nextp->chain.datap);
            q->vtype = TYDREAL;
            return(q);

      case 27:    /* len of character string */
            q = cpexpr(args->chain.datap->vleng);
            frexpr(args->chain.datap);
            return(q);

      case 14:    /* half-integer mod */
      case 15:    /* mod */
            return( mkexpr(OPMOD, args->chain.datap, args->chain.nextp->chain.datap) );
      }
return(NULL);
}

Generated by  Doxygen 1.6.0   Back to index