[unix-history] / usr / 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},

"" };
\f

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"
	};
\f
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);
}
Commit	Line	Data
0d57d6f5 TL	1	#include "defs"
	2
	3	union
	4	{
	5	int ijunk;
	6	struct intrpacked bits;
	7	} packed;
	8
	9	struct intrbits
	10	{
	11	int intrgroup /* :3 */;
	12	int intrstuff /* result type or number of generics */;
	13	int intrno /* :7 */;
	14	};
	15
	16	LOCAL struct intrblock
	17	{
	18	char intrfname[VL];
	19	struct intrbits intrval;
	20	} intrtab[ ] =
	21	{
	22	"int", { INTRCONV, TYLONG },
	23	"real", { INTRCONV, TYREAL },
	24	"dble", { INTRCONV, TYDREAL },
	25	"cmplx", { INTRCONV, TYCOMPLEX },
	26	"dcmplx", { INTRCONV, TYDCOMPLEX },
	27	"ifix", { INTRCONV, TYLONG },
	28	"idint", { INTRCONV, TYLONG },
	29	"float", { INTRCONV, TYREAL },
	30	"dfloat", { INTRCONV, TYDREAL },
	31	"sngl", { INTRCONV, TYREAL },
	32	"ichar", { INTRCONV, TYLONG },
	33	"char", { INTRCONV, TYCHAR },
	34
	35	"max", { INTRMAX, TYUNKNOWN },
	36	"max0", { INTRMAX, TYLONG },
	37	"amax0", { INTRMAX, TYREAL },
	38	"max1", { INTRMAX, TYLONG },
	39	"amax1", { INTRMAX, TYREAL },
	40	"dmax1", { INTRMAX, TYDREAL },
	41
	42	"and", { INTRBOOL, TYUNKNOWN, OPBITAND },
	43	"or", { INTRBOOL, TYUNKNOWN, OPBITOR },
	44	"xor", { INTRBOOL, TYUNKNOWN, OPBITXOR },
	45	"not", { INTRBOOL, TYUNKNOWN, OPBITNOT },
	46	"lshift", { INTRBOOL, TYUNKNOWN, OPLSHIFT },
	47	"rshift", { INTRBOOL, TYUNKNOWN, OPRSHIFT },
	48
	49	"min", { INTRMIN, TYUNKNOWN },
	50	"min0", { INTRMIN, TYLONG },
	51	"amin0", { INTRMIN, TYREAL },
	52	"min1", { INTRMIN, TYLONG },
	53	"amin1", { INTRMIN, TYREAL },
	54	"dmin1", { INTRMIN, TYDREAL },
	55
	56	"aint", { INTRGEN, 2, 0 },
	57	"dint", { INTRSPEC, TYDREAL, 1 },
	58
	59	"anint", { INTRGEN, 2, 2 },
	60	"dnint", { INTRSPEC, TYDREAL, 3 },
	61
	62	"nint", { INTRGEN, 4, 4 },
	63	"idnint", { INTRGEN, 2, 6 },
	64
65	"abs", { INTRGEN, 6, 8 },
66	"iabs", { INTRGEN, 2, 9 },
67	"dabs", { INTRSPEC, TYDREAL, 11 },
68	"cabs", { INTRSPEC, TYREAL, 12 },
69	"zabs", { INTRSPEC, TYDREAL, 13 },
70
71	"mod", { INTRGEN, 4, 14 },
72	"amod", { INTRSPEC, TYREAL, 16 },
73	"dmod", { INTRSPEC, TYDREAL, 17 },
74
75	"sign", { INTRGEN, 4, 18 },
76	"isign", { INTRGEN, 2, 19 },
77	"dsign", { INTRSPEC, TYDREAL, 21 },
78
79	"dim", { INTRGEN, 4, 22 },
80	"idim", { INTRGEN, 2, 23 },
81	"ddim", { INTRSPEC, TYDREAL, 25 },
82
83	"dprod", { INTRSPEC, TYDREAL, 26 },
84
85	"len", { INTRSPEC, TYLONG, 27 },
86	"index", { INTRSPEC, TYLONG, 29 },
87
88	"imag", { INTRGEN, 2, 31 },
89	"aimag", { INTRSPEC, TYREAL, 31 },
90	"dimag", { INTRSPEC, TYDREAL, 32 },
91
92	"conjg", { INTRGEN, 2, 33 },
93	"dconjg", { INTRSPEC, TYDCOMPLEX, 34 },
94
95	"sqrt", { INTRGEN, 4, 35 },
96	"dsqrt", { INTRSPEC, TYDREAL, 36 },
97	"csqrt", { INTRSPEC, TYCOMPLEX, 37 },
98	"zsqrt", { INTRSPEC, TYDCOMPLEX, 38 },
99
100	"exp", { INTRGEN, 4, 39 },
101	"dexp", { INTRSPEC, TYDREAL, 40 },
102	"cexp", { INTRSPEC, TYCOMPLEX, 41 },
103	"zexp", { INTRSPEC, TYDCOMPLEX, 42 },
104
105	"log", { INTRGEN, 4, 43 },
106	"alog", { INTRSPEC, TYREAL, 43 },
107	"dlog", { INTRSPEC, TYDREAL, 44 },
108	"clog", { INTRSPEC, TYCOMPLEX, 45 },
109	"zlog", { INTRSPEC, TYDCOMPLEX, 46 },
110
111	"log10", { INTRGEN, 2, 47 },
112	"alog10", { INTRSPEC, TYREAL, 47 },
113	"dlog10", { INTRSPEC, TYDREAL, 48 },
114
115	"sin", { INTRGEN, 4, 49 },
116	"dsin", { INTRSPEC, TYDREAL, 50 },
117	"csin", { INTRSPEC, TYCOMPLEX, 51 },
118	"zsin", { INTRSPEC, TYDCOMPLEX, 52 },
119
120	"cos", { INTRGEN, 4, 53 },
121	"dcos", { INTRSPEC, TYDREAL, 54 },
122	"ccos", { INTRSPEC, TYCOMPLEX, 55 },
123	"zcos", { INTRSPEC, TYDCOMPLEX, 56 },
124
125	"tan", { INTRGEN, 2, 57 },
126	"dtan", { INTRSPEC, TYDREAL, 58 },
127
128	"asin", { INTRGEN, 2, 59 },
129	"dasin", { INTRSPEC, TYDREAL, 60 },
130
131	"acos", { INTRGEN, 2, 61 },
132	"dacos", { INTRSPEC, TYDREAL, 62 },
133
134	"atan", { INTRGEN, 2, 63 },
135	"datan", { INTRSPEC, TYDREAL, 64 },
136
137	"atan2", { INTRGEN, 2, 65 },
138	"datan2", { INTRSPEC, TYDREAL, 66 },
139
140	"sinh", { INTRGEN, 2, 67 },
141	"dsinh", { INTRSPEC, TYDREAL, 68 },
142
143	"cosh", { INTRGEN, 2, 69 },
144	"dcosh", { INTRSPEC, TYDREAL, 70 },
145
146	"tanh", { INTRGEN, 2, 71 },
147	"dtanh", { INTRSPEC, TYDREAL, 72 },
148
149	"lge", { INTRSPEC, TYLOGICAL, 73},
150	"lgt", { INTRSPEC, TYLOGICAL, 75},
151	"lle", { INTRSPEC, TYLOGICAL, 77},
152	"llt", { INTRSPEC, TYLOGICAL, 79},
153
154	"" };
155	\f
156
157	LOCAL struct specblock
158	{
159	char atype;
160	char rtype;
161	char nargs;
162	char spxname[XL];
163	char othername; /* index into callbyvalue table */
164	} spectab[ ] =
165	{
166	{ TYREAL,TYREAL,1,"r_int" },
167	{ TYDREAL,TYDREAL,1,"d_int" },
168
169	{ TYREAL,TYREAL,1,"r_nint" },
170	{ TYDREAL,TYDREAL,1,"d_nint" },
171
172	{ TYREAL,TYSHORT,1,"h_nint" },
173	{ TYREAL,TYLONG,1,"i_nint" },
174
175	{ TYDREAL,TYSHORT,1,"h_dnnt" },
176	{ TYDREAL,TYLONG,1,"i_dnnt" },
177
178	{ TYREAL,TYREAL,1,"r_abs" },
179	{ TYSHORT,TYSHORT,1,"h_abs" },
180	{ TYLONG,TYLONG,1,"i_abs" },
181	{ TYDREAL,TYDREAL,1,"d_abs" },
182	{ TYCOMPLEX,TYREAL,1,"c_abs" },
183	{ TYDCOMPLEX,TYDREAL,1,"z_abs" },
184
185	{ TYSHORT,TYSHORT,2,"h_mod" },
186	{ TYLONG,TYLONG,2,"i_mod" },
187	{ TYREAL,TYREAL,2,"r_mod" },
188	{ TYDREAL,TYDREAL,2,"d_mod" },
189
190	{ TYREAL,TYREAL,2,"r_sign" },
191	{ TYSHORT,TYSHORT,2,"h_sign" },
192	{ TYLONG,TYLONG,2,"i_sign" },
193	{ TYDREAL,TYDREAL,2,"d_sign" },
194
195	{ TYREAL,TYREAL,2,"r_dim" },
196	{ TYSHORT,TYSHORT,2,"h_dim" },
197	{ TYLONG,TYLONG,2,"i_dim" },
198	{ TYDREAL,TYDREAL,2,"d_dim" },
199
200	{ TYREAL,TYDREAL,2,"d_prod" },
201
202	{ TYCHAR,TYSHORT,1,"h_len" },
203	{ TYCHAR,TYLONG,1,"i_len" },
204
205	{ TYCHAR,TYSHORT,2,"h_indx" },
206	{ TYCHAR,TYLONG,2,"i_indx" },
207
208	{ TYCOMPLEX,TYREAL,1,"r_imag" },
209	{ TYDCOMPLEX,TYDREAL,1,"d_imag" },
210	{ TYCOMPLEX,TYCOMPLEX,1,"r_cnjg" },
211	{ TYDCOMPLEX,TYDCOMPLEX,1,"d_cnjg" },
212
213	{ TYREAL,TYREAL,1,"r_sqrt", 1 },
214	{ TYDREAL,TYDREAL,1,"d_sqrt", 1 },
215	{ TYCOMPLEX,TYCOMPLEX,1,"c_sqrt" },
216	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_sqrt" },
217
218	{ TYREAL,TYREAL,1,"r_exp", 2 },
219	{ TYDREAL,TYDREAL,1,"d_exp", 2 },
220	{ TYCOMPLEX,TYCOMPLEX,1,"c_exp" },
221	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_exp" },
222
223	{ TYREAL,TYREAL,1,"r_log", 3 },
224	{ TYDREAL,TYDREAL,1,"d_log", 3 },
225	{ TYCOMPLEX,TYCOMPLEX,1,"c_log" },
226	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_log" },
227
228	{ TYREAL,TYREAL,1,"r_lg10" },
229	{ TYDREAL,TYDREAL,1,"d_lg10" },
230
231	{ TYREAL,TYREAL,1,"r_sin", 4 },
232	{ TYDREAL,TYDREAL,1,"d_sin", 4 },
233	{ TYCOMPLEX,TYCOMPLEX,1,"c_sin" },
234	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_sin" },
235
236	{ TYREAL,TYREAL,1,"r_cos", 5 },
237	{ TYDREAL,TYDREAL,1,"d_cos", 5 },
238	{ TYCOMPLEX,TYCOMPLEX,1,"c_cos" },
239	{ TYDCOMPLEX,TYDCOMPLEX,1,"z_cos" },
240
241	{ TYREAL,TYREAL,1,"r_tan", 6 },
242	{ TYDREAL,TYDREAL,1,"d_tan", 6 },
243
244	{ TYREAL,TYREAL,1,"r_asin", 7 },
245	{ TYDREAL,TYDREAL,1,"d_asin", 7 },
246
247	{ TYREAL,TYREAL,1,"r_acos", 8 },
248	{ TYDREAL,TYDREAL,1,"d_acos", 8 },
249
250	{ TYREAL,TYREAL,1,"r_atan", 9 },
251	{ TYDREAL,TYDREAL,1,"d_atan", 9 },
252
253	{ TYREAL,TYREAL,2,"r_atn2", 10 },
254	{ TYDREAL,TYDREAL,2,"d_atn2", 10 },
255
256	{ TYREAL,TYREAL,1,"r_sinh", 11 },
257	{ TYDREAL,TYDREAL,1,"d_sinh", 11 },
258
259	{ TYREAL,TYREAL,1,"r_cosh", 12 },
260	{ TYDREAL,TYDREAL,1,"d_cosh", 12 },
261
262	{ TYREAL,TYREAL,1,"r_tanh", 13 },
263	{ TYDREAL,TYDREAL,1,"d_tanh", 13 },
264
265	{ TYCHAR,TYLOGICAL,2,"hl_ge" },
266	{ TYCHAR,TYLOGICAL,2,"l_ge" },
267
268	{ TYCHAR,TYLOGICAL,2,"hl_gt" },
269	{ TYCHAR,TYLOGICAL,2,"l_gt" },
270
271	{ TYCHAR,TYLOGICAL,2,"hl_le" },
272	{ TYCHAR,TYLOGICAL,2,"l_le" },
273
274	{ TYCHAR,TYLOGICAL,2,"hl_lt" },
275	{ TYCHAR,TYLOGICAL,2,"l_lt" }
276	} ;
277
278
279
280
281
282
283	char callbyvalue[ ][XL] =
284	{
285	"sqrt",
286	"exp",
287	"log",
288	"sin",
289	"cos",
290	"tan",
291	"asin",
292	"acos",
293	"atan",
294	"atan2",
295	"sinh",
296	"cosh",
297	"tanh"
298	};
299	\f
300	struct exprblock *intrcall(np, argsp, nargs)
301	struct nameblock *np;
302	struct listblock *argsp;
303	int nargs;
304	{
305	int i, rettype;
306	struct addrblock *ap;
307	register struct specblock *sp;
308	struct exprblock q, inline();
309	register chainp cp;
310	struct constblock *mkcxcon();
311	expptr ep;
312	int mtype;
313	int op;
314
315	packed.ijunk = np->vardesc.varno;
316	if(nargs == 0)
317	goto badnargs;
318
319	mtype = 0;
320	for(cp = argsp->listp ; cp ; cp = cp->nextp)
321	{
322	/* TEMPORARY */ ep = cp->datap;
323	/* TEMPORARY */ if( ISCONST(ep) && ep->vtype==TYSHORT )
324	/* TEMPORARY */ cp->datap = mkconv(tyint, ep);
325	mtype = maxtype(mtype, ep->vtype);
326	}
327
328	switch(packed.bits.f1)
329	{
330	case INTRBOOL:
331	op = packed.bits.f3;
332	if( ! ONEOF(mtype, MSKINT\|MSKLOGICAL) )
333	goto badtype;
334	if(op == OPBITNOT)
335	{
336	if(nargs != 1)
337	goto badnargs;
338	q = mkexpr(OPBITNOT, argsp->listp->datap, NULL);
339	}
340	else
341	{
342	if(nargs != 2)
343	goto badnargs;
344	q = mkexpr(op, argsp->listp->datap,
345	argsp->listp->nextp->datap);
346	}
347	frchain( &(argsp->listp) );
348	free(argsp);
349	return(q);
350
351	case INTRCONV:
352	rettype = packed.bits.f2;
353	if(rettype == TYLONG)
354	rettype = tyint;
355	if( ISCOMPLEX(rettype) && nargs==2)
356	{
357	expptr qr, qi;
358	qr = argsp->listp->datap;
359	qi = argsp->listp->nextp->datap;
360	if(ISCONST(qr) && ISCONST(qi))
361	q = mkcxcon(qr,qi);
362	else q = mkexpr(OPCONV,mkconv(rettype-2,qr),
363	mkconv(rettype-2,qi));
364	}
365	else if(nargs == 1)
366	q = mkconv(rettype, argsp->listp->datap);
367	else goto badnargs;
368
369	q->vtype = rettype;
370	frchain(&(argsp->listp));
371	free(argsp);
372	return(q);
373
374
375	case INTRGEN:
376	sp = spectab + packed.bits.f3;
377	for(i=0; i<packed.bits.f2 ; ++i)
378	if(sp->atype == mtype)
379	goto specfunct;
380	else
381	++sp;
382	goto badtype;
383
384	case INTRSPEC:
385	sp = spectab + packed.bits.f3;
386	if(tyint==TYLONG && sp->rtype==TYSHORT)
387	++sp;
388
389	specfunct:
390	if(nargs != sp->nargs)
391	goto badnargs;
392	if(mtype != sp->atype)
393	goto badtype;
394	fixargs(YES, argsp);
395	if(q = inline(sp-spectab, mtype, argsp->listp))
396	{
397	frchain( &(argsp->listp) );
398	free(argsp);
399	}
400	else if(sp->othername)
401	{
402	ap = builtin(sp->rtype,
403	varstr(XL, callbyvalue[sp->othername-1]) );
404	q = fixexpr( mkexpr(OPCCALL, ap, argsp) );
405	}
406	else
407	{
408	ap = builtin(sp->rtype, varstr(XL, sp->spxname) );
409	q = fixexpr( mkexpr(OPCALL, ap, argsp) );
410	}
411	return(q);
412
413	case INTRMIN:
414	case INTRMAX:
415	if(nargs < 2)
416	goto badnargs;
417	if( ! ONEOF(mtype, MSKINT\|MSKREAL) )
418	goto badtype;
419	argsp->vtype = mtype;
420	q = mkexpr( (packed.bits.f1==INTRMIN ? OPMIN : OPMAX), argsp, NULL);
421
422	q->vtype = mtype;
423	rettype = packed.bits.f2;
424	if(rettype == TYLONG)
425	rettype = tyint;
426	else if(rettype == TYUNKNOWN)
427	rettype = mtype;
428	return( mkconv(rettype, q) );
429
430	default:
431	fatal1("intrcall: bad intrgroup %d", packed.bits.f1);
432	}
433	badnargs:
434	err1("bad number of arguments to intrinsic %s",
435	varstr(VL,np->varname) );
436	goto bad;
437
438	badtype:
439	err1("bad argument type to intrinsic %s", varstr(VL, np->varname) );
440
441	bad:
442	return( errnode() );
443	}
444
445
446
447
448	intrfunct(s)
449	char s[VL];
450	{
451	register struct intrblock *p;
452	char nm[VL];
453	register int i;
454
455	for(i = 0 ; i<VL ; ++s)
456	nm[i++] = (s==' ' ? '\0' : s);
457
458	for(p = intrtab; p->intrval.intrgroup!=INTREND ; ++p)
459	{
460	if( eqn(VL, nm, p->intrfname) )
461	{
462	packed.bits.f1 = p->intrval.intrgroup;
463	packed.bits.f2 = p->intrval.intrstuff;
464	packed.bits.f3 = p->intrval.intrno;
465	return(packed.ijunk);
466	}
467	}
468
469	return(0);
470	}
471
472
473
474
475
476	struct addrblock *intraddr(np)
477	struct nameblock *np;
478	{
479	struct addrblock *q;
480	struct specblock *sp;
481
482	if(np->vclass!=CLPROC \|\| np->vprocclass!=PINTRINSIC)
483	fatal1("intraddr: %s is not intrinsic", varstr(VL,np->varname));
484	packed.ijunk = np->vardesc.varno;
485
486	switch(packed.bits.f1)
487	{
488	case INTRGEN:
489	/* imag, log, and log10 arent specific functions */
490	if(packed.bits.f3==31 \|\| packed.bits.f3==43 \|\| packed.bits.f3==47)
491	goto bad;
492
493	case INTRSPEC:
494	sp = spectab + packed.bits.f3;
495	if(tyint==TYLONG && sp->rtype==TYSHORT)
496	++sp;
497	q = builtin(sp->rtype, varstr(XL,sp->spxname) );
498	return(q);
499
500	case INTRCONV:
501	case INTRMIN:
502	case INTRMAX:
503	case INTRBOOL:
504	bad:
505	err1("cannot pass %s as actual",
506	varstr(VL,np->varname));
507	return( errnode() );
508	}
509	fatal1("intraddr: impossible f1=%d\n", packed.bits.f1);
510	/* NOTREACHED */
511	}
512
513
514
515
516
517	struct exprblock *inline(fno, type, args)
518	int fno;
519	int type;
520	chainp args;
521	{
522	register struct exprblock q, t, *t1;
523
524	switch(fno)
525	{
526	case 8: /* real abs */
527	case 9: /* short int abs */
528	case 10: /* long int abs */
529	case 11: /* double precision abs */
530	if( addressable(q = args->datap) )
531	{
532	t = q;
533	q = NULL;
534	}
535	else
536	t = mktemp(type);
537	t1 = mkexpr(OPQUEST, mkexpr(OPLE, mkconv(type,ICON(0)), cpexpr(t)),
538	mkexpr(OPCOLON, cpexpr(t),
539	mkexpr(OPNEG, cpexpr(t), NULL) ));
540	if(q)
541	t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1);
542	frexpr(t);
543	return(t1);
544
545	case 26: /* dprod */
546	q = mkexpr(OPSTAR, args->datap, args->nextp->datap);
547	q->vtype = TYDREAL;
548	return(q);
549
550	case 27: /* len of character string */
551	q = cpexpr(args->datap->vleng);
552	frexpr(args->datap);
553	return(q);
554
555	case 14: /* half-integer mod */
556	case 15: /* mod */
557	return( mkexpr(OPMOD, args->datap, args->nextp->datap) );
558	}
559	return(NULL);
560	}