/* J calls for wd commands - 3 is EVDOMAIN
x - 11!:x
w - A* argument
p1 - result (if not 0)
p2 - result (if p1==0)
p2==0 - result is mtm
p2 -> int type, int element count, integer or char data
type==0 - char result
type==1 - char result (to be cut and boxed on 0)
type==2 - int result
return error code (3 EVDOMAIN)
*/
int _stdcall JwdS(J jt, int x, A w, A* p1, int** p2)
{
int type;
SOCKBUF* pb;
/* binrep of user arg has 4 byte ints */
int* pi=(int*)CAV(w);
/* test for wd'q' - depends on 3!:1 format */
if(x==0 && LIT&pi[1] && 1==pi[2] && 0==pi[3] && 'q'==*(16+(C*)pi))
{
int* pi=geteventdata();
if(0==pi) return EVDOMAIN;
*p2=pi;
return 0; /* wd'q' result is ready */
}
if(x==0)
{
char* pl=JGetLocale(jt);
putdata(JCMDWD,x,AN(w),CAV(w),strlen(pl),pl);
}
else
putdata(JCMDWD,x,AN(w),CAV(w),0,0);
if(!(pb=getdata())) errorm("jwds getdata failed");
if(pb->cmd!=JCMDWDZ) errorm("jwds not wdz");
type = pb->type;
if(type>CTERR) return type-CTERR;
if(type==CTMTM) return 0;
*p2=(int*)&pb->type;
return 0;
}
// General setup for verbs with IRS that do not go through jtirs[12]
// A verb u["n] using this function checks to see whether it has multiple cells; if so,
// it calls here, giving a callback; we split the arguents into cells and call the callback,
// which is often the same original function that called here.
A jtrank2ex(J jt,A a,A w,A fs,I lr,I rr,AF f2){PROLOG(0042);A y,y0,ya,yw,z;B ab,b,wb;
C*u,*uu,*v,*vv;I acn,acr,af,ak,ar,*as,at,k,mn,n=1,p,q,*s,wcn,wcr,wf,wk,wr,*ws,wt,yn,yr,*ys,yt;
RZ(a&&w);
at=AT(a); wt=AT(w);
if(at&SPARSE||wt&SPARSE)R sprank2(a,w,fs,lr,rr,f2);
// ?r=rank, ?s->shape, ?cr=effective rank, ?f=#frame, ?b=relative flag, for each argument
ar=AR(a); as=AS(a); acr=efr(ar,lr); af=ar-acr; ab=ARELATIVE(a);
wr=AR(w); ws=AS(w); wcr=efr(wr,rr); wf=wr-wcr; wb=ARELATIVE(w);
if(!af&&!wf)R CALL2(f2,a,w,fs); // if there's only one cell, run on it, that's the result
// multiple cells. Loop through them.
// ?cn=number of atoms in a cell, ?k=#bytes in a cell, uv point to one cell before aw data
// Allocate y? to hold one cell of ?, with uu,vv pointing to the data of y?
RE(acn=prod(acr,as+af)); ak=acn*bp(at); u=CAV(a)-ak; NEWYA;
RE(wcn=prod(wcr,ws+wf)); wk=wcn*bp(wt); v=CAV(w)-wk; NEWYW;
// b means 'w frame is larger'; p=#larger frame; q=#shorter frame; s->larger frame
// mn=#cells in larger frame (& therefore #cells in result); n=# times to repeat each cell
// from shorter-frame argument
b=af<=wf; p=b?wf:af; q=b?af:wf; s=b?ws:as; RE(mn=prod(p,s)); RE(n=prod(p-q,s+q));
ASSERT(!ICMP(as,ws,q),EVLENGTH); // error if frames are not same as prefix
// Initialize y? to hold data for the first cell; but if ? is empty, set y? to a cell of fills
if(AN(a))MOVEYA else RZ(ya=reshape(vec(INT,acr,as+af),filler(a)));
if(AN(w))MOVEYW else RZ(yw=reshape(vec(INT,wcr,ws+wf),filler(w)));
#define VALENCE 2
#define TEMPLATE 0
#include "cr_t.h"
}
static A jtrdns(J jt,F f){A za,z;I n;size_t r,tr=0;
GA(za,LIT,n=1024,1,0); clearerr(f);
while(!feof(f) && (r=fread(CAV(za)+tr,sizeof(C),n-tr,f))){
tr+=r; if(tr==(U)n){RZ(za=ext(0,za));n*=2;}
}
if(tr==(U)n)z=za;
else {GA(z,LIT,tr,1,0); MC(CAV(z),CAV(za),tr);}
R z;
} /* read entire file stream (non-seekable) */
static F2(jtebarmat){A ya,yw,z;B b,*zv;C*au,*av,*u,*v,*v0,*wu,*wv;I*as,c,i,k,m,n,r,s,si,sj,t,*ws;
RZ(a&&w);
as=AS(a); av=CAV(a);
ws=AS(w); v=v0=wv=CAV(w);
si=as[0]; m=1+ws[0]-si;
sj=as[1]; n=1+ws[1]-sj;
t=AT(w); k=bp(t); c=ws[1]; r=k*c; s=k*sj;
GA(z,B01,AN(w),2,ws); zv=BAV(z); memset(zv,C0,AN(z));
if(t&B01+LIT+INT||0==jt->ct&&t&FL+CMPX)
for(i=0;i<m;++i){
DO(n, u=av; b=0; DO(si, if(b=memcmp(u,v,s))break; u+=s; v+=r;); v=v0+=k; zv[i]=!b;);
static DF1(reduce){PROLOG;DECLF;A y,z;C*u,*v;I c,k,m,old,t;
RZ(w);
m=IC(w);
if(!m)R df1(w,iden(fs));
RZ(z=tail(w));
if(1==m)R z;
t=AT(w); c=AN(z);
GA(y,t,c,AR(z),AS(z)); u=CAV(y); k=SZT(t,c); v=CAV(w)+k*(m-1);
old=tbase+ttop;
DO(m-1, MC(u,v-=k,k); RZ(z=f2(y,z,fs)); gc(z,old));
EPILOG(z);
}
static void dwrq(A w){
if(all1(match(alp,w)))jputs(nflag?" a.":"a.");
else{C q=CQUOTE;
jputc(q);
if(w){C*p=CAV(w); DO(AN(w), if(q==p[i])jputc(q); jputc(p[i]));}
jputc(q);
}}
A jtrank1ex(J jt,A w,A fs,I mr,AF f1) {
PROLOG;
A y,y0,yw,z;
B wb;
C*v,*vv;
I k,mn,n=1,p,*s,wcn,wcr,wf,wk,wr,*ws,wt,yn,yr,*ys,yt;
RZ(w);
wt=AT(w);
if(wt&SPARSE)R sprank1(w,fs,mr,f1);
wr=AR(w);
ws=AS(w);
wcr=efr(wr,mr);
wf=wr-wcr;
wb=ARELATIVE(w);
if(!wf)R CALL1(f1,w,fs);
RE(wcn=prod(wcr,wf+ws));
wk=wcn*bp(wt);
v=CAV(w)-wk;
NEWYW;
p=wf;
s=ws;
RE(mn=prod(wf,ws));
if(AN(w))MOVEYW else RZ(yw=reshape(vec(INT,wcr,ws+wf),filler(w)));
#define VALENCE 1
#define TEMPLATE 0
#include "cr_t.h"
}
static I jtcongoto(J jt,I n,CW*con,A*lv){A x,z;C*s;CW*d=con,*e;I i,j,k,m;
RZ(z=congotoblk(n,con));
for(i=0;i<n;++i,++d)
if(CGOTO==d->type){
x=lv[d->i]; s=5+CAV(x); m=0; while('.'!=s[m])++m; ++m;
e=con-1; j=-1;
DO(n, ++e; if(LABELEQU(m,s,e)){j=1+i; d->go=(US)j; break;});
/* f m:d function name; monad line #s; dyad line #s. * means all */
B dbcheck(void){A t;C nw[10],*s,*tv;DC dv;I md,tn;
if(!qstops)R 0;
if(!sitop->lnk)R 0;
dv=sitop->lnk;
if(DCDEFN!=dv->t)R 0;
if(drun){drun=0; R 0;}
t=dv->p;
if(!t)R 0;
tn=AN(t); tv=CAV(t); s=CAV(qstops); md=dv->n; sprintf(nw,"%ld",dv->ln);
while(s){
while(' '==*s)++s;
if('*'==*s){s++; if(stopsub(s,nw,md))R 1;}
else if(!strncmp(s,tv,tn)){s+=tn; if(' '==*s&&stopsub(s,nw,md))R 1;}
s=strchr(s,';'); if(s)++s;
}
R 0;
}
static A jtattv(J jt,U x){A z;C*s;
GAT(z,LIT,6,1,0); s=CAV(z);
s[0]=x&_A_RDONLY?'r':'-';
s[1]=x&_A_HIDDEN?'h':'-';
s[2]=x&_A_SYSTEM?'s':'-';
s[3]=x&_A_VOLID ?'v':'-';
s[4]=x&_A_SUBDIR?'d':'-';
s[5]=x&_A_ARCH ?'a':'-';
R z;
} /* convert from 16-bit attributes x into 6-element string */
A jtrank2ex(J jt,A a,A w,A fs,I lr,I rr,AF f2) {
PROLOG;
A y,y0,ya,yw,z;
B ab,b,wb;
C*u,*uu,*v,*vv;
I acn,acr,af,ak,ar,*as,at,k,mn,n=1,p,q,*s,wcn,wcr,wf,wk,wr,*ws,wt,yn,yr,*ys,yt;
RZ(a&&w);
at=AT(a);
wt=AT(w);
if(at&SPARSE||wt&SPARSE)R sprank2(a,w,fs,lr,rr,f2);
ar=AR(a);
as=AS(a);
acr=efr(ar,lr);
af=ar-acr;
ab=ARELATIVE(a);
wr=AR(w);
ws=AS(w);
wcr=efr(wr,rr);
wf=wr-wcr;
wb=ARELATIVE(w);
if(!af&&!wf)R CALL2(f2,a,w,fs);
RE(acn=prod(acr,as+af));
ak=acn*bp(at);
u=CAV(a)-ak;
NEWYA;
RE(wcn=prod(wcr,ws+wf));
wk=wcn*bp(wt);
v=CAV(w)-wk;
NEWYW;
b=af<=wf;
p=b?wf:af;
q=b?af:wf;
s=b?ws:as;
RE(mn=prod(p,s));
RE(n=prod(p-q,s+q));
ASSERT(!ICMP(as,ws,q),EVLENGTH);
if(AN(a))MOVEYA else RZ(ya=reshape(vec(INT,acr,as+af),filler(a)));
if(AN(w))MOVEYW else RZ(yw=reshape(vec(INT,wcr,ws+wf),filler(w)));
#define VALENCE 2
#define TEMPLATE 0
#include "cr_t.h"
}
static F1(lparen) {
A z;
C*v;
I n;
RZ(w);
n=AN(w);
GA(z,CHAR,2+n,1,0);
v=CAV(z);
*v='(';
*(v+n+1)=')';
MC(1+v,AV(w),n);
R z;
}
static S jtattu(J jt,A w){C*s;I i,n;S z=0;
RZ(w=vs(w));
n=AN(w); s=CAV(w);
for(i=0;i<n;++i)switch(s[i]){
case 'r': z^=_A_RDONLY; break;
case 'h': z^=_A_HIDDEN; break;
case 's': z^=_A_SYSTEM; break;
case 'v': z^=_A_VOLID; break;
case 'd': z^=_A_SUBDIR; break;
case 'a': z^=_A_ARCH; break;
case '-': break;
default: ASSERT(0,EVDOMAIN);
}
R z;
} /* convert from 6-element string into 16-bit attributes */
void run(void* jt)
{
I r,n,len;A a;SOCKBUF* pb;static C setname[nsz+1]="";
while(1)
{
pb=getdata();
if(!pb) errorm("run getdata failed");
len = pb->len;
switch(pb->cmd)
{
case JCMDDO:
if(pb->type==1) /* input and event data */
{
seteventdata();
len=strlen(pb->d);
}
if(len<sizeof(input)-1)
{
memcpy(input, pb->d, len);
input[len]=0;
r=JDo(jt,input);
}
else
r=EVLENGTH;
putdata(JCMDDOZ,r,0,0,0,0);
break;
case JCMDSETN:
n=len<nsz?len:nsz;
memcpy(setname, pb->d, n);
setname[n]=0;
break;
case JCMDSET:
r=JSetA(jt,strlen(setname),setname,len,pb->d);
putdata(JCMDSETZ,r,0,0,0,0);
break;
case JCMDGET:
a=JGetA(jt,len,pb->d);
if(a==0)
putdata(JCMDGETZ,EVVALUE,0,0,0,0);
else
putdata(JCMDGETZ,0,AN(a),CAV(a),0,0);
break;
default:
errorm("unknown command");
}
}
}
static B jtwa(J jt,F f,I j,A w){C*x;I n,p=0;size_t q=1;
RZ(f&&w);
n=AN(w)*(C2T&AT(w)?2:1); x=CAV(w);
#if !SY_WINCE
{INT64 v; v= j+((0>j)?fsize(f):0); fsetpos(f,(fpos_t*)&v);}
#else
fseek(f,(long)(0>j?1+j:j),0>j?SEEK_END:SEEK_SET);
#endif
clearerr(f);
while(q&&n>p){
p+=q=fwrite(p+x,sizeof(C),(size_t)(n-p),f);
if(ferror(f))R jerrno()?1:0;
}
R 1;
} /* write/append string w to file f at j */
A jtrd(J jt,F f,I j,I n){A z;C*x;I p=0;size_t q=1;
RZ(f);
if(0>n){if(j<0) n=-j; else n=fsize(f)-j;}
#if !SY_WINCE
{INT64 v; v= j+((0>j)?fsize(f):0); fsetpos(f,(fpos_t*)&v);}
#else
fseek(f,(long)(0>j?1+j:j),0>j?SEEK_END:SEEK_SET);
#endif
clearerr(f);
GA(z,LIT,n,1,0); x=CAV(z);
while(q&&n>p){
p+=q=fread(p+x,sizeof(C),(size_t)(n-p),f);
if(ferror(f))R jerrno();
}
R z;
} /* read file f for n bytes at j */
// Derived verb for f//. y
static DF1(jtobqfslash){A y,z;B b=0,p;C er,id,*wv;I c,d,k,m,m1,mn,n,n1,r,*s,wt;
RZ(w);
r=AR(w); s=AS(w); wt=AT(w); wv=CAV(w);
if(!(AN(w)&&1<r&&DENSE&wt))R oblique(w,self); // revert to default if rank<2, empty, or sparse
y=VAV(self)->f; y=VAV(y)->f; id=vaid(y);
m=s[0]; m1=m-1;
n=s[1]; n1=n-1; mn=m*n; d=m+n-1; PROD(c,r-2,2+s);
if(1==m||1==n){GA(z,wt,AN(w),r-1,1+s); *AS(z)=d; MC(AV(z),wv,AN(w)*bp(wt)); R z;}
if(wt&FL+CMPX)NAN0;
if(1==c)switch(OBQCASE(CTTZ(wt),id)){
case OBQCASE(B01X, CNE ): OBQLOOP(B,B,wt,x=*u, x^=*u ); break;
case OBQCASE(B01X, CEQ ): OBQLOOP(B,B,wt,x=*u, x=x==*u ); break;
case OBQCASE(B01X, CMAX ):
case OBQCASE(B01X, CPLUSDOT): OBQLOOP(B,B,wt,x=*u, x|=*u ); break;
case OBQCASE(B01X, CMIN ):
case OBQCASE(B01X, CSTAR ):
case OBQCASE(B01X, CSTARDOT): OBQLOOP(B,B,wt,x=*u, x&=*u ); break;
case OBQCASE(B01X, CLT ): OBQLOOP(B,B,wt,x=*u, x=*u< x ); break;
case OBQCASE(B01X, CLE ): OBQLOOP(B,B,wt,x=*u, x=*u<=x ); break;
case OBQCASE(B01X, CGT ): OBQLOOP(B,B,wt,x=*u, x=*u> x ); break;
case OBQCASE(B01X, CGE ): OBQLOOP(B,B,wt,x=*u, x=*u>=x ); break;
case OBQCASE(B01X, CPLUS ): OBQLOOP(B,I,INT,x=*u, x+=*u ); break;
case OBQCASE(SBTX, CMAX ): OBQLOOP(SB,SB,wt,x=*u, x=SBGT(x,*u)?x:*u ); break;
case OBQCASE(SBTX, CMIN ): OBQLOOP(SB,SB,wt,x=*u, x=SBLT(x,*u)?x:*u ); break;
case OBQCASE(FLX, CMAX ): OBQLOOP(D,D,wt,x=*u, x=MAX(x,*u) ); break;
case OBQCASE(FLX, CMIN ): OBQLOOP(D,D,wt,x=*u, x=MIN(x,*u) ); break;
case OBQCASE(FLX, CPLUS ): OBQLOOP(D,D,wt,x=*u, x+=*u ); break;
case OBQCASE(CMPXX,CPLUS ): OBQLOOP(Z,Z,wt,x=*u, x=zplus(x,*u)); break;
case OBQCASE(XNUMX,CMAX ): OBQLOOP(X,X,wt,x=*u, x=1==xcompare(x,*u)? x:*u); break;
case OBQCASE(XNUMX,CMIN ): OBQLOOP(X,X,wt,x=*u, x=1==xcompare(x,*u)?*u: x); break;
case OBQCASE(XNUMX,CPLUS ): OBQLOOP(X,X,wt,x=*u, x=xplus(x,*u)); break;
case OBQCASE(RATX, CMAX ): OBQLOOP(Q,Q,wt,x=*u, x=1==QCOMP(x,*u)? x:*u); break;
case OBQCASE(RATX, CMIN ): OBQLOOP(Q,Q,wt,x=*u, x=1==QCOMP(x,*u)?*u: x); break;
case OBQCASE(RATX, CPLUS ): OBQLOOP(Q,Q,wt,x=*u, x=qplus(x,*u)); break;
case OBQCASE(INTX, CBW0001 ): OBQLOOP(I,I,wt,x=*u, x&=*u ); break;
case OBQCASE(INTX, CBW0110 ): OBQLOOP(I,I,wt,x=*u, x^=*u ); break;
case OBQCASE(INTX, CBW0111 ): OBQLOOP(I,I,wt,x=*u, x|=*u ); break;
case OBQCASE(INTX, CMAX ): OBQLOOP(I,I,wt,x=*u, x=MAX(x,*u) ); break;
case OBQCASE(INTX, CMIN ): OBQLOOP(I,I,wt,x=*u, x=MIN(x,*u) ); break;
case OBQCASE(INTX, CPLUS ):
er=0; OBQLOOP(I,I,wt,x=*u, {p=0>x; x+=*u; BOV(p==0>*u&&p!=0>x);});
if(er>=EWOV)OBQLOOP(I,D,FL,x=(D)*u, x+=*u);
}
static A jtrankingb(J jt,A w,I wf,I wcr,I m,I n,I k){A z;C*wv;I i,j,p,t,yv[16],*zv;
p=2==k?4:16; wv=CAV(w);
GATV(z,INT,m*n,1+wf,AS(w)); if(!wcr)*(AS(z)+wf)=1; zv=AV(z);
if(2==k){US*v;
for(i=0;i<m;++i){
memset(yv,C0,p*SZI);
for(j=0,v=(US*)wv;j<n;++j)switch(*v++){
case BS00: ++yv[0]; break;
case BS01: ++yv[1]; break;
case BS10: ++yv[2]; break;
case BS11: ++yv[3]; break;
}
RANKINGSUMSCAN;
for(j=0,v=(US*)wv;j<n;++j)switch(*v++){
case BS00: *zv++=yv[0]++; break;
case BS01: *zv++=yv[1]++; break;
case BS10: *zv++=yv[2]++; break;
case BS11: *zv++=yv[3]++; break;
}
wv+=n*k;
}}else{int*v;
for(i=0;i<m;++i){
memset(yv,C0,p*SZI);
for(j=0,v=(int*)wv;j<n;++j)switch(*v++){
case B0000: ++yv[ 0]; break;
case B0001: ++yv[ 1]; break;
case B0010: ++yv[ 2]; break;
case B0011: ++yv[ 3]; break;
case B0100: ++yv[ 4]; break;
case B0101: ++yv[ 5]; break;
case B0110: ++yv[ 6]; break;
case B0111: ++yv[ 7]; break;
case B1000: ++yv[ 8]; break;
case B1001: ++yv[ 9]; break;
case B1010: ++yv[10]; break;
case B1011: ++yv[11]; break;
case B1100: ++yv[12]; break;
case B1101: ++yv[13]; break;
case B1110: ++yv[14]; break;
case B1111: ++yv[15]; break;
}
RANKINGSUMSCAN;
for(j=0,v=(int*)wv;j<n;++j)switch(*v++){
case B0000: *zv++=yv[ 0]++; break;
case B0001: *zv++=yv[ 1]++; break;
case B0010: *zv++=yv[ 2]++; break;
case B0011: *zv++=yv[ 3]++; break;
case B0100: *zv++=yv[ 4]++; break;
case B0101: *zv++=yv[ 5]++; break;
case B0110: *zv++=yv[ 6]++; break;
case B0111: *zv++=yv[ 7]++; break;
case B1000: *zv++=yv[ 8]++; break;
case B1001: *zv++=yv[ 9]++; break;
case B1010: *zv++=yv[10]++; break;
case B1011: *zv++=yv[11]++; break;
case B1100: *zv++=yv[12]++; break;
case B1101: *zv++=yv[13]++; break;
case B1110: *zv++=yv[14]++; break;
case B1111: *zv++=yv[15]++; break;
}
wv+=n*k;
}}
R z;
} /* /:@/: w where w is boolean and items have length 2 or 4 */
/* 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);}}
B jtpinit(J jt){A t;C*s;
MC(wtype,ctype,256L); wtype['N']=CN; wtype['B']=CB;
GA(alp,LIT,NALP,1,0); s=CAV(alp); DO(NALP,*s++=(C)i;);
static void dname(A w){C c=*CAV(w);
if(nflag)jputc(' ');
if(c==CALPHA)jputs("x");
else if(c==COMEGA)jputs("y");
else dwr(w);
}
int javaWd(JNIEnv *env, jobject obj, J jt,int type, A w, A *pz, const char*locale)
{
LOGD("javaWd");
int i,j,len,rc=0;
if(wdId == 0) {
jclass the_class = (*env)->GetObjectClass(env,obj);
wdId = (*env)->GetMethodID(env,the_class,"wd","(I[I[Ljava/lang/Object;[Ljava/lang/Object;Ljava/lang/String;)I" );
(*env)->DeleteLocalRef(env,the_class);
}
if(wdId == 0) {
LOGD("failed to get the method id for wd" );
return 3;
}
// check argument type
if (BOX&AT(w)) {
A* wi= (A*)AV(w);
for (i=0; i<AN(w); i++)
if(!(INT&AT(*(wi+i))||LIT&AT(*(wi+i)))) {
LOGD("argument error for wd box" );
rc=3;
break;
}
} else if (AN(w) && !(INT&AT(w)||LIT&AT(w))) {
LOGD("argument error for wd non-box" );
rc=3;
}
if (rc) {
return rc;
}
// inta: type shape0 shape1 .... repeat for each inarr element
int ninarr=(BOX&AT(w))?AN(w):1;
jclass objcls = (*env)->FindClass(env,"java/lang/Object");
jobject inarr= (*env)->NewObjectArray(env, ninarr, objcls, 0);
jobject outarr= (*env)->NewObjectArray(env, 2, objcls, 0);
(*env)->DeleteLocalRef(env,objcls);
jintArray inta= (*env)->NewIntArray(env, 3*ninarr);
jint* pinta = (*env)->GetIntArrayElements(env, inta, 0);
A* w1;
if (BOX&AT(w))
w1= (A*)AV(w);
else
w1= &w;
for (i=0; i<ninarr; i++) {
if (LIT&AT(*w1) || 0==AN(*w1)) {
pinta[3*i] = LIT;
if (AR(*w1)>1 && AN(*w1)) {
pinta[3*i+1] = (AS(*w1))[0];
pinta[3*i+2] = (AS(*w1))[1];
} else {
pinta[3*i+1] = -1;
pinta[3*i+2] = -1;
}
jbyteArray bytea= (*env)->NewByteArray(env, AN(*w1));
jbyte* pbytea = (*env)->GetByteArrayElements(env, bytea, 0);
memcpy(pbytea, CAV(*w1), AN(*w1));
(*env)->ReleaseByteArrayElements(env, bytea, pbytea, 0);
(*env)->SetObjectArrayElement(env, inarr, i, bytea);
(*env)->DeleteLocalRef(env,bytea);
} else if (INT&AT(*w1)) {
pinta[3*i] = INT;
if (AR(*w1)>1) {
pinta[3*i+1] = (AS(*w1))[0];
pinta[3*i+2] = (AS(*w1))[1];
} else {
pinta[3*i+1] = -1;
pinta[3*i+2] = -1;
}
jintArray intb= (*env)->NewIntArray(env, AN(*w1));
#if SY_64
jint *pintb = (*env)->GetIntArrayElements(env, intb, 0);
for (j=0; j<AN(*w1); j++) pintb[j]=(jint)*(AV(*w1)+j);
(*env)->ReleaseIntArrayElements(env, intb, pintb, 0);
#else
(*env)->SetIntArrayRegion(env, intb, 0, AN(*w1), (jint*)AV(*w1));
#endif
(*env)->SetObjectArrayElement(env, inarr, i, intb);
(*env)->DeleteLocalRef(env,intb);
}
w1++;
}
(*env)->ReleaseIntArrayElements(env, inta, pinta, 0);
jstring slocale = (*env)->NewStringUTF(env,locale);
rc = (*env)->CallIntMethod(env,obj,wdId,(jint)type,inta,inarr,outarr,slocale);
(*env)->DeleteLocalRef(env,inta);
(*env)->DeleteLocalRef(env,inarr);
(*env)->DeleteLocalRef(env,slocale);
// (*env)->ExceptionClear(env);
if (rc<0) {
jobject array = (*env)->GetObjectArrayElement(env, outarr, 0);
jobject inta = (*env)->GetObjectArrayElement(env, outarr, 1);
if (0==array || 0==inta) {
if (0==array) LOGD("array null");
if (0==inta) LOGD("inta null");
rc=3;
} else {
int leni= (*env)->GetArrayLength(env, inta);
jint *pinta = (*env)->GetIntArrayElements(env, inta, 0);
I itype= pinta[0];
I ishape[2];
ishape[0]= pinta[1]; // -1 if not rank-2
ishape[1]= pinta[2];
(*env)->ReleaseIntArrayElements(env, inta, pinta, 0);
len= (*env)->GetArrayLength(env, array);
if (itype==LIT) {
if (ishape[0]==-1) {
GATV(*pz,LIT,len,1,0);
} else {
GATV(*pz,LIT,len,2,ishape);
}
(*env)->GetByteArrayRegion(env, array, 0, len, CAV(*pz));
} else if (itype==INT) {
if (ishape[0]==-1) {
GATV(*pz,INT,len,1,0);
} else {
GATV(*pz,INT,len,2,ishape);
}
#if SY_64
jint *parray = (*env)->GetIntArrayElements(env, array, 0);
for (j=0; j<len; j++) *(AV(*pz)+j)=parray[j];
(*env)->ReleaseIntArrayElements(env, array, parray, 0);
#else
(*env)->GetIntArrayRegion(env, array, 0, len, (jint*)AV(*pz));
#endif
} else {
LOGD("result not string or integers");
rc=3;
}
}
(*env)->DeleteLocalRef(env,array);
(*env)->DeleteLocalRef(env,inta);
}
(*env)->DeleteLocalRef(env,outarr);
return (rc>0)?3:rc;
}
static void dwr(A w){if(w){C*p=CAV(w); DO(AN(w), jputc(p[i]));}}
A gnm(I n, C *s) { A z;
ASSERT(vldnm(n,s),ERILLNAME);
z=ga(NAME,1,n,NULL);
strncpy(CAV(z),s,n);
R z;
}
A gstr(I n, const C *s) { A z;
ASSERT(n>0,ERDOM);
if (n==1) { z=schar(*s); }
else { z=ga(CHAR,1,n,NULL); strncpy(CAV(z),s,n); }
R z;
}
/* License in license.txt. */
/* */
/* Representations: Tree */
#include "j.h"
static F1(jttrr);
static F1(jttrc){A bot,p,*v,x,y;B b;C*bv,c,ul,ll,*pv;I j,k,m,*s,xn,*xv,yn,*yv;
RZ(w);
s=AS(w); v=AAV(w);
xn=s[0]; RZ(x=apv(xn,0L,0L)); xv=AV(x);
yn=s[1]; RZ(y=apv(yn,0L,0L)); yv=AV(y);
j=0; DO(xn, xv[i]=IC(v[j]); j+=yn;);
GA(bot,LIT,yn,1,0); bv=CAV(bot);
ul=jt->bx[0]; ll=jt->bx[6];
for(j=b=0;j<xn;++j,b=0<j)
for(k=0;k<yn;++k){
p=*v++;
if(AN(p)){
m=*(1+AS(p)); yv[k]=MAX(yv[k],m);
pv=CAV(p); c=*pv;
if(b&&(c==ul&&' '!=bv[k]||c!=' '&&ll==bv[k])){xv[j-1]+=1; b=0;}
bv[k]=*(pv+AN(p)-m);
}else bv[k]=' ';
}
R link(x,y);
}
static I jtpad(J jt,A a,A w,C*zv){C dash,*u,*v,*wv;I c,d,r,*s;
static B jtlp(J jt,A w){B b=1,p=0;C c,d,q=CQUOTE,*v;I j=0,n;
RZ(w);
n=AN(w); v=CAV(w); c=*v; d=*(v+n-1);
if(1==n||(2==n||3>=n&&' '==c)&&(d==CESC1||d==CESC2)||vnm(n,v))R 0;
if(C9==ctype[c])DO(n-1, d=c; c=ctype[*++v]; if(b=!NUMV(c)||d==CS&&c!=C9)break;)
else if(c==q) DO(n-1, c=*v++; if(c==q)p=!p; if(b=p?0:c!=q)break;)
// convert a VARIANT to a J array
// returns 0 on error with detail in jerr.
static A v2a(J jt, VARIANT* v, int dobstrs)
{
A a;
SAFEARRAY* psa;
SAFEARRAYBOUND* pb;
I shape[MAXRANK];
I k=1,n,r,i;
I* pintsnk;
#if SY_64
int* pint32src;
#else
long long* pint64src;
#endif
short* pshortsrc;
unsigned short* pboolsrc;
char* pboolsnk;
VARTYPE t;
int byref;
double* pdoublesnk;
float* pfloatsrc;
#define OPTREF(v,field) (byref ? *v->p##field : v->field)
t=v->vt;
byref = t & VT_BYREF;
t = t & ~VT_BYREF;
if(dobstrs && t == VT_BSTR)
{
BSTR bstr; int len;
bstr = OPTREF(v,bstrVal);
if(uniflag)
// len=SysStringLen(bstr);
len=WideCharToMultiByte(CP_UTF8,0,bstr,(int)SysStringLen(bstr),0,0,0,0);
else
len=SysStringByteLen(bstr);
RE(a=ga(LIT, len, 1, 0));
if(uniflag)
toutf8n(bstr, (C*)AV(a), len);
else
memcpy((C*)AV(a), (C*)bstr, len);
R a;
}
if(t & VT_ARRAY)
{
psa = OPTREF(v,parray);
pb = psa->rgsabound;
r=psa->cDims;
ASSERT(r<=MAXRANK,EVRANK);
for(i=0; i<r; ++i)
{
n = pb[i].cElements;
shape[i] = n;
k *= n;
}
}
else
r = 0;
switch(t)
{
case VT_VARIANT | VT_ARRAY:
{
A *boxes;
VARIANT* pv;
// fixup scalar boxes which arrive
// as a 1-elem vector with a lower bound at -1, not 0.
if (pb[0].lLbound == -1)
{
ASSERT(psa->cDims==1 && pb[0].cElements==1, EVDOMAIN);
r = 0;
}
RE(a=ga(BOX, k, r, (I*)&shape));
ASSERT(S_OK==SafeArrayAccessData(psa, &pv),EVFACE);
boxes = AAV(a);
while(k--)
{
A z;
// Don't use a PROLOG/EPILOG during v2a.
// The z's are not getting their reference
// count set until everything is in place
// and the jset() is done in Jset().
z = *boxes++ = v2a(jt, pv++, dobstrs);
if (!z) break;
}
SafeArrayUnaccessData(psa);
if (jt->jerr) return 0;
break;
}
case VT_BOOL | VT_ARRAY:
RE(a=ga(B01, k, r, (I*)&shape));
pboolsrc = (VARIANT_BOOL*)psa->pvData;
pboolsnk = BAV(a);
// J bool returned from VB boolean, a -1 and 0 mess.
// It wouldn't be that bad if the Microsoft folks used their own macros
// and kept an eye an sign extensions. But the way they are
// doing it they are returning at least some TRUEs as value 255
// instead of VARIANT_TRUE. Therefore, we have to compare against
// VARIANT_FALSE which -we hope- is consistently defined (as 0).
while(k--)
*pboolsnk++ = (*pboolsrc++)!=VARIANT_FALSE;
break;
case VT_UI1 | VT_ARRAY:
RE(a=ga(LIT, k, r, (I*)&shape));
memcpy(AV(a), psa->pvData, k * sizeof(char));
break;
case VT_UI2 | VT_ARRAY:
RE(a=ga(C2T, k, r, (I*)&shape));
memcpy(AV(a), psa->pvData, k * sizeof(short));
break;
case VT_UI4 | VT_ARRAY:
RE(a=ga(C4T, k, r, (I*)&shape));
memcpy(AV(a), psa->pvData, k * sizeof(int));
break;
case VT_I2 | VT_ARRAY:
RE(a=ga(INT, k, r, (I*)&shape));
pshortsrc = (short*)psa->pvData;
pintsnk = AV(a);
while(k--)
*pintsnk++ = *pshortsrc++;
break;
case VT_I4 | VT_ARRAY:
RE(a=ga(INT, k, r, (I*)&shape));
#if SY_64
pint32src = (long*)psa->pvData;
pintsnk = AV(a);
while(k--)
*pintsnk++ = *pint32src++;
#else
memcpy(AV(a), psa->pvData, k * sizeof(int));
#endif
break;
case VT_I8 | VT_ARRAY:
RE(a=ga(INT, k, r, (I*)&shape));
#if SY_64
memcpy(AV(a), psa->pvData, k * sizeof(I));
#else
pint64src = (long long*)psa->pvData;
pintsnk = AV(a);
while(k--)
*pintsnk++ = (I)*pint64src++;
#endif
break;
case VT_R4 | VT_ARRAY:
RE(a=ga(FL, k, r, (I*)&shape));
pfloatsrc = (float*)psa->pvData;
pdoublesnk = (double*)AV(a);
while(k--)
*pdoublesnk++ = *pfloatsrc++;
break;
case VT_R8 | VT_ARRAY:
RE(a=ga(FL, k, r, (I*)&shape));
memcpy(AV(a), psa->pvData, k * sizeof(double));
break;
case VT_UI1:
RE(a=ga(LIT, 1, 0, 0));
*CAV(a) = OPTREF(v,bVal);
break;
case VT_UI2:
RE(a=ga(C2T, 1, 0, 0));
*USAV(a) = (US)OPTREF(v,iVal);
break;
case VT_UI4:
RE(a=ga(C4T, 1, 0, 0));
*C4AV(a) = (C4)OPTREF(v,lVal);
break;
case VT_BOOL:
RE(a=ga(B01, 1, 0, 0));
// array case above explains this messy phrase:
*BAV(a) = OPTREF(v,boolVal)!=VARIANT_FALSE;
break;
case VT_I2:
RE(a=ga(INT, 1, 0, 0));
*IAV(a) = OPTREF(v,iVal);
break;
case VT_I4:
RE(a=ga(INT, 1, 0, 0));
*IAV(a) = OPTREF(v,lVal);
break;
case VT_I8:
RE(a=ga(INT, 1, 0, 0));
*IAV(a) = (I)OPTREF(v,llVal);
break;
case VT_R4:
RE(a=ga(FL, 1, 0, 0));
*DAV(a) = OPTREF(v,fltVal);
break;
case VT_R8:
RE(a=ga(FL, 1, 0, 0));
*DAV(a) = OPTREF(v,dblVal);
break;
default:
ASSERT(0,EVDOMAIN);
}
if(1<r && jt->transposeflag)
{
RE(a=cant1(a));
DO(r, AS(a)[i]=shape[r-1-i];);
