static A jtvaspc(J jt,A a,A w,C id,VF ado,I cv,I t,I zt,I af,I acr,I wf,I wcr,I f,I r){A q;I*as,*v,*ws;
as=AS(a);
ws=AS(w);
GA(q,INT,f+r,1,0); v=AV(q);
if(r>acr){ICPY(v,wf+ws,r); RZ(a=irs2(vec(INT,r-acr,acr+v),a,0L,1L,0L,jtreshape));}
if(r>wcr){ICPY(v,af+as,r); RZ(w=irs2(vec(INT,r-wcr,wcr+v),w,0L,1L,0L,jtreshape));}
R vasp(a,w,id,ado,cv,t,zt,af,r,wf,r,f,r);
} /* prefix agreement on cells */
static A jtipprep(J jt,A a,A w,I zt,I*pm,I*pn,I*pp){A z=mark;I*as,ar,ar1,m,mn,n,p,*ws,wr,wr1;
ar=AR(a); as=AS(a); ar1=ar?ar-1:0; RE(*pm=m=prod(ar1, as));
wr=AR(w); ws=AS(w); wr1=wr?wr-1:0; RE(*pn=n=prod(wr1,1+ws)); RE(mn=mult(m,n));
*pp=p=ar?*(as+ar1):wr?*ws:1;
ASSERT(!(ar&&wr)||p==*ws,EVLENGTH);
GA(z,zt,mn,ar1+wr1,0);
ICPY(AS(z), as,ar1);
ICPY(AS(z)+ar1,1+ws,wr1);
R z;
} /* argument validation & result for an inner product */
// Analysis for inner product
// a,w are arguments
// zt is type of result
// *pm is # 1-cells of a
// *pn is # atoms in an item of w
// *pp is number of inner-product muladds
// (in each, an atom of a multiplies an item of w)
static A jtipprep(J jt,A a,A w,I zt,I*pm,I*pn,I*pp){A z=mark;I*as,ar,ar1,m,mn,n,p,*ws,wr,wr1;
ar=AR(a); as=AS(a); ar1=ar?ar-1:0; RE(*pm=m=prod(ar1,as)); // m=# 1-cells of a. It could overflow, if there are no atoms
wr=AR(w); ws=AS(w); wr1=wr?wr-1:0; RE(*pn=n=prod(wr1,1+ws)); RE(mn=mult(m,n)); // n=#atoms in 1-cell of w; mn = #atoms in result
*pp=p=ar?*(as+ar1):wr?*ws:1; // if a is an array, the length of a 1-cell; otherwise, the number of items of w
ASSERT(!(ar&&wr)||p==*ws,EVLENGTH);
GA(z,zt,mn,ar1+wr1,0); // allocate result area
ICPY(AS(z), as,ar1); // Set shape: 1-frame of a followed by shape of item of w
ICPY(AS(z)+ar1,1+ws,wr1);
R z;
} /* argument validation & result for an inner product */
A ga(I t, I r, I n, I *s) { I k=WP(t,r,n); A z=a_malloc(k);
AT(z)=t; AC(z)=1; AR(z)=r; AN(z)=n;
if (r==1) { *AS(z)=n; }
else if (r&&s) { ICPY(AS(z),s,r); }
gcpush(z);
R z;
}
static A jtunlj(J jt,I j){B b;I*u,*v;
RE(j);
ASSERT(0<=j&&j<jt->flkn,EVINDEX);
u=AV(jt->flkd); v=u+j*LKC;
RE(b=dolock(0,(F)v[0],v[1],v[2]));
if(!b)R zero;
--jt->flkn;
if(j<jt->flkn)ICPY(v,u+jt->flkn*LKC,LKC); else *v=0;
R one;
} /* unlock the j-th entry in jt->flkd */
B jtsymext(J jt,B b){A x,y;I j,m,n,s[2],*v,xn,yn;L*u;
if(b){y=jt->symp; j=((MS*)y-1)->j; n=*AS(y); yn=AN(y);}
else { j=12; n=1; yn=0; }
m=msize[1+j]; /* new size in bytes */
m-=sizeof(MS)+SZI*(AH+2); /* less array overhead */
m/=symcol*SZI; /* new # rows */
s[0]=m; s[1]=symcol; xn=m*symcol; /* new pool array shape */
GA(x,INT,xn,2,s); v=AV(x); /* new pool array */
if(b)ICPY(v,AV(y),yn); /* copy old data to new array */
memset(v+yn,C0,SZI*(xn-yn)); /* 0 unused area for safety */
u=n+(L*)v; j=1+n;
DO(m-n-1, u++->next=j++;); /* build free list extension */
// This is the derived verb for f/. y
static DF1(jtoblique){A x,y;I m,n,r,*u,*v;
RZ(w);
r=AR(w); // r = rank of w
// create y= ,/ w - the _2-cells of w arranged in a list
// we just create a header for y, pointing to the data from w
RZ(y=gah(MAX(r-1,1),w));
u=AS(w); v=AS(y); // u,v->shape of y
if(1>=r){*v=m=AN(w); n=1;}else{m=*u++; n=*u++; *v++=m*n; ICPY(v,u,r-2);} // set shape of y as _2-cells of w
// Create x=+"0 1&i./ 2 {. $y
RZ(x=irs2(IX(m),IX(n),0L,0L,1L,jtplus)); AR(x)=1; *AS(x)=AN(x);
// perform x f/. y, which does the requested operation
RZ(x=df2(x,y,sldot(VAV(self)->f)));
// Final tweak: the result should have (0 >. <: +/ 2 {. $y) cells. It will, as long as
// m and n are both non0: when one is 0, result has 0 cells (but that cell is the correct result
// of execution on a fill-cell). Correct the length of the 0 case, when the result length should be nonzero
// if((m==0 || n==0) && (m+n>0)){R reitem(sc(m+n-1),x);} This change withdrawn pending further deliberation
R x;
}
static F2(jttclosure){A z;B b;I an,*av,c,d,i,wn,wr,wt,*wv,*zu,*zv,*zz;
RZ(a&&w);
wt=AT(w); wn=AN(w); wr=AR(w);
if(B01&wt)RZ(w=cvt(INT,w)); wv=AV(w);
av=AV(a); an=AN(a);
RZ(z=exta(INT,1+wr,wn,20L));
zv=AV(z); zz=zv+AN(z);
if(1==wn){
*zv++=c=*wv; d=1+c;
while(c!=d){
if(zv==zz){i=zv-AV(z); RZ(z=ext(0,z)); zv=AV(z)+i; zz=AV(z)+AN(z);}
d=c; if(0>c)c+=an; ASSERT(0<=c&&c<an,EVINDEX); *zv++=c=av[c];
}}else{
ICPY(zv,wv,wn); zu=zv; zv+=wn;
while(1){
if(zv==zz){i=zv-AV(z); RZ(z=ext(0,z)); zv=AV(z)+i; zz=AV(z)+AN(z); zu=zv-wn;}
b=1; DO(wn, d=c=*zu++; if(0>c)c+=an; ASSERT(0<=c&&c<an,EVINDEX); *zv++=c=av[c]; if(c!=d)b=0;);
if(b)break;
}}
