Esempio n. 1
0
/* Copyright 1990-2007, Jsoftware Inc.  All rights reserved.               */
/* Licensed use only. Any other use is in violation of copyright.          */
/*                                                                         */
/* Verbs: From & Associates. See Hui, Some Uses of { and }, APL87.         */

#include "j.h"


F1(jtcatalog){PROLOG(0072);A b,*wv,x,z,*zv;C*bu,*bv,**pv;I*cv,i,j,k,m=1,n,p,*qv,r=0,*s,t=0,*u,wd;
 F1RANK(1,jtcatalog,0);
 if(!(AN(w)&&AT(w)&BOX+SBOX))R box(w);
 n=AN(w); wv=AAV(w); wd=(I)w*ARELATIVE(w);
 DO(n, x=WVR(i); if(AN(x)){p=AT(x); t=t?t:p; ASSERT(H**O(t,p),EVDOMAIN); RE(t=maxtype(t,p));});
 RE(t=maxtype(B01,t)); k=bp(t);
 GA(b,t,n,1,0);      bv=CAV(b);
 GATV(x,INT,n,1,0);    qv=AV(x);
 GATV(x,BOX,n,1,0);    pv=(C**)AV(x);
 RZ(x=apv(n,0L,0L)); cv=AV(x);
 DO(n, x=WVR(i); if(TYPESNE(t,AT(x)))RZ(x=cvt(t,x)); r+=AR(x); qv[i]=p=AN(x); RE(m=mult(m,p)); pv[i]=CAV(x););
 GATV(z,BOX,m,r,0);    zv=AAV(z); s=AS(z); 
 DO(n, x=WVR(i); u=AS(x); DO(AR(x),*s++=*u++;););
 for(i=0;i<m;i++){
  bu=bv-k;
  DO(n, MC(bu+=k,pv[i]+k*cv[i],k););
  DO(n, j=n-1-i; if(qv[j]>++cv[j])break; cv[j]=0;);
  RZ(*zv++=ca(b));
 }
 EPILOG(z);
}

#define SETJ(jexp)    {j=(jexp); if(0<=j)ASSERT(j<p,EVINDEX) else{j+=p; ASSERT(0<=j,EVINDEX);}}
Esempio n. 2
0
intrcall(Namep np, struct Listblock *argsp, int nargs)
#endif
{
	int i, rettype;
	Addrp ap;
	register struct Specblock *sp;
	register struct Chain *cp;
	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)
	{
		ep = (expptr)cp->datap;
		if( ISCONST(ep) && ep->headblock.vtype==TYSHORT )
			cp->datap = (char *) 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, (expptr)argsp->listp->datap, ENULL);
		}
		else
		{
			if(nargs != 2)
				goto badnargs;
			q = mkexpr(op, (expptr)argsp->listp->datap,
			    		(expptr)argsp->listp->nextp->datap);
		}
		frchain( &(argsp->listp) );
		free( (charptr) argsp);
		return(q);

	case INTRCONV:
		rettype = f2field;
		switch(rettype) {
		  case TYLONG:
			rettype = tyint;
			break;
		  case TYLOGICAL:
			rettype = tylog;
		  }
		if( ISCOMPLEX(rettype) && nargs==2)
		{
			expptr qr, qi;
			qr = (expptr) argsp->listp->datap;
			qi = (expptr) 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) {
			if (f3field && ((Exprp)argsp->listp->datap)->vtype
					== TYDCOMPLEX)
				rettype = TYDREAL;
			q = mkconv(rettype+100, (expptr)argsp->listp->datap);
			if (q->tag == TADDR)
				q->addrblock.parenused = 1;
			}
		else goto badnargs;

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


#if 0
	case INTRCNST:

/* Machine-dependent f77 stuff that f2c omits:

intcon contains
	radix for short int
	radix for long int
	radix for single precision
	radix for double precision
	precision for short int
	precision for long int
	precision for single precision
	precision for double precision
	emin for single precision
	emin for double precision
	emax for single precision
	emax for double prcision
	largest short int
	largest long int

realcon contains
	tiny for single precision
	tiny for double precision
	huge for single precision
	huge for double precision
	mrsp (epsilon) for single precision
	mrsp (epsilon) for double precision
*/
	{	register struct Incstblock *cstp;
		extern ftnint intcon[14];
		extern double realcon[6];

		cstp = consttab + f3field;
		for(i=0 ; i<f2field ; ++i)
			if(cstp->atype == mtype)
				goto foundconst;
			else
				++cstp;
		goto badtype;

foundconst:
		switch(cstp->rtype)
		{
		case TYLONG:
			return(mkintcon(intcon[cstp->constno]));

		case TYREAL:
		case TYDREAL:
			return(mkrealcon(cstp->rtype,
			    realcon[cstp->constno]) );

		default:
			Fatal("impossible intrinsic constant");
		}
	}
#endif

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

		for(i=0; i<f2field ; ++i)
			if(sp->atype == mtype)
				goto specfunct;
			else
				++sp;
		warn1 ("bad argument type to intrinsic %s", np->fvarname);

/* Made this a warning rather than an error so things like "log (5) ==>
   log (5.0)" can be accommodated.  When none of these cases matches, the
   argument is cast up to the first type in the spectab list; this first
   type is assumed to be the "smallest" type, e.g. REAL before DREAL
   before COMPLEX, before DCOMPLEX */

		sp = spectab + f3field;
		mtype = sp -> atype;
		goto specfunct;

	case INTRSPEC:
		sp = spectab + f3field;
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)
			goto badtype;

/* NOTE!!  I moved fixargs (YES) into the ELSE branch so that constants in
   the inline expression wouldn't get put into the constant table */

		fixargs (NO, argsp);
		cast_args (mtype, argsp -> listp);

		if(q = Inline((int)(sp-spectab), mtype, argsp->listp))
		{
			frchain( &(argsp->listp) );
			free( (charptr) argsp);
		} else {

		    if(sp->othername) {
			/* C library routines that return double... */
			/* sp->rtype might be TYREAL */
			ap = builtin(sp->rtype,
				callbyvalue[sp->othername], 1);
			q = fixexpr((Exprp)
				mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) );
		    } else {
			fixargs(YES, argsp);
			ap = builtin(sp->rtype, sp->spxname, 0);
			q = fixexpr((Exprp)
				mkexpr(OPCALL, (expptr)ap, (expptr)argsp) );
		    } /* else */
		} /* else */
		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), (expptr)argsp, ENULL);

		q->headblock.vtype = mtype;
		rettype = f2field;
		if(rettype == TYLONG)
			rettype = tyint;
		else if(rettype == TYUNKNOWN)
			rettype = mtype;
		return( mkconv(rettype, q) );

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

badtype:
	errstr("bad argument type to intrinsic %s", np->fvarname);

bad:
	return( errnode() );
}