V7M/src/cmd/f77/intr.c
#include "defs"
union
{
int ijunk;
struct intrpacked bits;
} packed;
struct intrbits
{
int intrgroup /* :3 */;
int intrstuff /* result type or number of generics */;
int intrno /* :7 */;
};
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},
"" };
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 exprblock *intrcall(np, argsp, nargs)
struct nameblock *np;
struct listblock *argsp;
int nargs;
{
int i, rettype;
struct addrblock *ap;
register struct specblock *sp;
struct exprblock *q, *inline();
register chainp cp;
struct constblock *mkcxcon();
expptr ep;
int mtype;
int op;
packed.ijunk = np->vardesc.varno;
if(nargs == 0)
goto badnargs;
mtype = 0;
for(cp = argsp->listp ; cp ; cp = cp->nextp)
{
/* TEMPORARY */ ep = cp->datap;
/* TEMPORARY */ if( ISCONST(ep) && ep->vtype==TYSHORT )
/* TEMPORARY */ cp->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->listp->datap, NULL);
}
else
{
if(nargs != 2)
goto badnargs;
q = mkexpr(op, argsp->listp->datap,
argsp->listp->nextp->datap);
}
frchain( &(argsp->listp) );
free(argsp);
return(q);
case INTRCONV:
rettype = packed.bits.f2;
if(rettype == TYLONG)
rettype = tyint;
if( ISCOMPLEX(rettype) && nargs==2)
{
expptr qr, qi;
qr = argsp->listp->datap;
qi = argsp->listp->nextp->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->listp->datap);
else goto badnargs;
q->vtype = rettype;
frchain(&(argsp->listp));
free(argsp);
return(q);
case INTRGEN:
sp = spectab + packed.bits.f3;
for(i=0; i<packed.bits.f2 ; ++i)
if(sp->atype == mtype)
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 = inline(sp-spectab, mtype, argsp->listp))
{
frchain( &(argsp->listp) );
free(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->varname) );
goto bad;
badtype:
err1("bad argument type to intrinsic %s", varstr(VL, np->varname) );
bad:
return( errnode() );
}
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 addrblock *intraddr(np)
struct nameblock *np;
{
struct addrblock *q;
struct specblock *sp;
if(np->vclass!=CLPROC || np->vprocclass!=PINTRINSIC)
fatal1("intraddr: %s is not intrinsic", varstr(VL,np->varname));
packed.ijunk = np->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->varname));
return( errnode() );
}
fatal1("intraddr: impossible f1=%d\n", packed.bits.f1);
/* NOTREACHED */
}
struct exprblock *inline(fno, type, args)
int fno;
int type;
chainp args;
{
register struct exprblock *q, *t, *t1;
switch(fno)
{
case 8: /* real abs */
case 9: /* short int abs */
case 10: /* long int abs */
case 11: /* double precision abs */
if( addressable(q = args->datap) )
{
t = q;
q = NULL;
}
else
t = mktemp(type);
t1 = mkexpr(OPQUEST, mkexpr(OPLE, mkconv(type,ICON(0)), cpexpr(t)),
mkexpr(OPCOLON, cpexpr(t),
mkexpr(OPNEG, cpexpr(t), NULL) ));
if(q)
t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1);
frexpr(t);
return(t1);
case 26: /* dprod */
q = mkexpr(OPSTAR, args->datap, args->nextp->datap);
q->vtype = TYDREAL;
return(q);
case 27: /* len of character string */
q = cpexpr(args->datap->vleng);
frexpr(args->datap);
return(q);
case 14: /* half-integer mod */
case 15: /* mod */
return( mkexpr(OPMOD, args->datap, args->nextp->datap) );
}
return(NULL);
}