/* 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];);