intr.c

来自「<B>Digital的Unix操作系统VAX 4.2源码</B>」· C语言 代码 · 共 723 行 · 第 1/2 页

} ;

char callbyvalue[ ][XL] =
	{
	"sqrt",
	"exp",
	"log",
	"sin",
	"cos",
	"tan",
	"asin",
	"acos",
	"atan",
	"atan2",
	"sinh",
	"cosh",
	"tanh",
	"log10"
	};

expptr intrcall(np, argsp, nargs)
Namep np;
struct Listblock *argsp;
int nargs;
{
int i, rettype;
Addrp ap;
register struct Specblock *sp;
register struct Chain *cp;
expptr inline(), mkcxcon(), mkrealcon();
expptr q, ep;
int mtype;
int op;
int f1field, f2field, f3field;

packed.ijunk = np->vardesc.varno;
f1field = packed.bits.f1;
f2field = packed.bits.f2;
f3field = packed.bits.f3;
if(nargs == 0)
	goto badnargs;

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

switch(f1field)
	{
	case INTRBOOL:
		op = f3field;
		if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) )
			goto badtype;
		if(op == OPBITNOT)
			{
			if(nargs != 1)
				goto badnargs;
			q = mkexpr(OPBITNOT, argsp->listp->datap, ENULL);
			}
		else
			{
			if(nargs != 2)
				goto badnargs;
			q = mkexpr(op, argsp->listp->datap,
				argsp->listp->nextp->datap);
			}
		frchain( &(argsp->listp) );
		free( (charptr) argsp);
		return(q);

	case INTRCONV:
		if (nargs == 1)
			{
			if(argsp->listp->datap->headblock.vtype == TYERROR)
				{
				free( (charptr) argsp->listp->datap);
				frchain( &(argsp->listp) );
				free( (charptr) argsp);
				return( errnode() );
				}
			}
		else if (nargs == 2)
			{
			if(argsp->listp->nextp->datap->headblock.vtype == 
				TYERROR ||
				argsp->listp->datap->headblock.vtype == TYERROR)
				{
				free( (charptr) argsp->listp->nextp->datap);
				free( (charptr) argsp->listp->datap);
				frchain( &(argsp->listp) );
				free( (charptr) argsp);
				return( errnode() );
				}
			}
		rettype = f2field;
		if( ISCOMPLEX(rettype) && nargs==2)
			{
			expptr qr, qi;
			if(dblflag) rettype = TYDCOMPLEX;
			qr = (expptr) (argsp->listp->datap);
			qi = (expptr) (argsp->listp->nextp->datap);
			if(ISCONST(qr) && ISCONST(qi))
				q = mkcxcon(qr,qi);
			else	q = mkexpr(OPCONV,intrconv(rettype-2,qr),
					intrconv(rettype-2,qi));
			}
		else if(nargs == 1)
			{
			if(rettype == TYLONG) rettype = tyint;
			else if( dblflag )
				{
				if ( rettype == TYREAL )
					rettype = TYDREAL;
				else if( rettype == TYCOMPLEX )
					rettype = TYDCOMPLEX;
				}
			q = intrconv(rettype, argsp->listp->datap);
			}
		else goto badnargs;

		q->headblock.vtype = rettype;
		frchain(&(argsp->listp));
		free( (charptr) argsp);
		return(q);

	case INTRGEN:
		sp = spectab + f3field;
#ifdef ONLY66
		if(no66flag)
			if(sp->atype == mtype)
				goto specfunct;
			else err66("generic function");
#endif

		for(i=0; i<f2field ; ++i)
			if(sp->atype == mtype)
				goto specfunct;
			else
				++sp;
		goto badtype;

	case INTRSPEC:
		sp = spectab + f3field;
		if( dblflag )
			{
			/* convert specific complex functions to double complex:
			 *	 cabs,csqrt,cexp,clog,csin,ccos, aimag
			 * and convert real specifics to double:
			 *	 amod,alog,alog10
			 * (sqrt,cos,sin,... o.k. since go through INTRGEN)
			 */
			if( (sp->atype==TYCOMPLEX && (sp+1)->atype==TYDCOMPLEX)
				||(sp->atype==TYREAL && (sp+1)->atype==TYDREAL))
					sp++;
			}
	specfunct:
		if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL))
			&& (sp+1)->atype==sp->atype)
				++sp;

		if(nargs != sp->nargs)
			goto badnargs;
		if(mtype != sp->atype
			&& (!dblflag || f3field != 26 || mtype != TYDREAL ) )
				goto badtype;
		fixargs(YES, argsp);
		if(q = inline(sp-spectab, mtype, argsp->listp))
			{
			frchain( &(argsp->listp) );
			free( (charptr) argsp);
			}
		else if(sp->othername)
			{
			ap = builtin(TYDREAL,
				varstr(XL, callbyvalue[sp->othername-1]) );
			ap->vstg = STGINTR;
			q = fixexpr( mkexpr(OPCCALL, ap, argsp) );
			if( sp->rtype != TYDREAL )
				q = mkconv( sp->rtype, q );
			}
		else
			{
			ap = builtin(sp->rtype, varstr(XL, sp->spxname) );
			ap->vstg = STGINTR;
			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( (f1field==INTRMIN ? OPMIN : OPMAX), argsp, ENULL);

		q->headblock.vtype = mtype;
		rettype = f2field;
		if(rettype == TYLONG)
			rettype = tyint;
		else if(rettype == TYUNKNOWN)
			rettype = mtype;
		else if( dblflag && rettype == TYREAL )
			rettype = TYDREAL;
		return( intrconv(rettype, q) );

	default:
		fatali("intrcall: bad intrgroup %d", f1field);
	}
badnargs:
	errstr("bad number of arguments to intrinsic %s",
		varstr(VL,np->varname) );
	goto bad;

badtype:
	errstr("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);
}





Addrp intraddr(np)
Namep np;
{
Addrp q;
register struct Specblock *sp;
int f3field;

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

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

	case INTRSPEC:
		sp = spectab + f3field;
		if( dblflag )
			{
			if((sp->atype==TYCOMPLEX && (sp+1)->atype==TYDCOMPLEX)
				||(sp->atype==TYREAL && (sp+1)->atype==TYDREAL))
					sp++;
			else if( f3field==4 )
					sp += 2;  /* h_nint -> h_dnnt */
			else if( f3field==8 || f3field==18 || f3field==22)
					sp += 3;  /* r_{abs,sign,dim} ->d_... */
			else if( f3field==26 )
					sp = spectab + 81; /* dprod */

			}
		if(tyint==TYLONG && sp->rtype==TYSHORT)
			++sp;
		q = builtin(sp->rtype, varstr(XL,sp->spxname) );
		q->vstg = STGINTR;
		return(q);

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





expptr inline(fno, type, args)
int fno;
int type;
struct Chain *args;
{
register expptr 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 = (expptr) (args->datap)) )
			{
			t = q;
			q = NULL;
			}
		else
			t = (expptr) mktemp(type,PNULL);
		t1 = mkexpr(OPQUEST,
			mkexpr(OPLE, intrconv(type,ICON(0)), cpexpr(t)),
			mkexpr(OPCOLON, cpexpr(t),
				mkexpr(OPNEG, cpexpr(t), ENULL) ));
		if(q)
			t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1);
		frexpr(t);
		return(t1);

	case 26:	/* dprod */
		q = mkexpr(OPSTAR, intrconv(TYDREAL,args->datap), args->nextp->datap);
		return(q);

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

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