static SF(jtsortb){A z;B up,*u,*v;I i,s;
GA(z,AT(w),AN(w),AR(w),AS(w)); v=BAV(z);
up=1==jt->compgt; u=BAV(w);
for(i=0;i<m;++i){
s=bsum(n,u);
if(up){memset(v,C0,n-s); memset(v+n-s,C1,s );}
else {memset(v,C1,s ); memset(v+s, C0,n-s);}
u+=n; v+=n;
}
R z;
} /* w grade"1 w on boolean */
static F2(jtpdtby){A z;B b,*u,*v,*wv;C er=0;I at,m,n,p,t,wt,zk;
at=AT(a); wt=AT(w); t=at&B01?wt:at;
RZ(z=ipprep(a,w,t,&m,&n,&p)); zk=n*bp(t); u=BAV(a); v=wv=BAV(w);
NAN0;
switch(t){
default: ASSERT(0,EVDOMAIN);
case CMPX: if(at&B01)PDTBY(Z,Z,ZINC) else PDTXB(Z,Z,ZINC,c=*u++ ); break;
case FL: if(at&B01)PDTBY(D,D,DINC) else PDTXB(D,D,DINC,c=*u++ ); break;
case INT: if(at&B01)PDTBY(I,I,IINC) else PDTXB(I,I,IINC,c=*u++ );
if(er==EWOV){
RZ(z=ipprep(a,w,FL,&m,&n,&p)); zk=n*sizeof(D); u=BAV(a); v=wv=BAV(w);
if(at&B01)PDTBY(D,I,IINC) else PDTXB(D,I,IINC,c=(D)*u++);
}}
static A jtcants(J jt,A a,A w,A z){A a1,q,y;B*b,*c;I*u,wr,zr;P*wp,*zp;
RZ(a&&w&&z);
RZ(a=grade1(a));
wr=AR(w); wp=PAV(w); a1=SPA(wp,a);
zr=AR(z); zp=PAV(z);
ASSERT(wr==zr,EVNONCE);
RZ(b=bfi(wr,a1,1));
GA(q,B01,wr,1,0); c=BAV(q); u=AV(a); DO(wr, c[i]=b[u[i]];);
static F1(jtnvrpush){
if(jt->nvrtop==AN(jt->nvra)){
RZ(jt->nvra=ext(1,jt->nvra)); jt->nvrav=AAV(jt->nvra);
while(AN(jt->nvrb)<AN(jt->nvra))RZ(jt->nvrb=ext(1,jt->nvrb)); jt->nvrbv=BAV(jt->nvrb);
}
jt->nvrav[jt->nvrtop]=w;
jt->nvrbv[jt->nvrtop]=1;
++jt->nvrtop;
R w;
}
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(breduce){A z;B b,*u,*v,*x,*xx;I c,cv,d,m;SF f2;VA*p;
RZ(w); /* AN(w)&&1<IC(w) */
m=IC(w); RZ(z=tail(w)); c=AN(z); x=BAV(z); v=BAV(w);
p=vap(self);
switch(1<c?0:p->bf){
case V0001: *x=memchr(v,C0,m)?0:1; R z;
case V0111: *x=memchr(v,C1,m)?1:0; R z;
case V1110: u=memchr(v,C0,m); d=u?u-v:m; *x=d%2!=d<m-1; R z;
case V1000: u=memchr(v,C1,m); d=u?u-v:m; *x=d%2==d<m-1; R z;
case V0010: u=memchr(v,C0,m); *x=(u?u-v:m)%2?1:0; R z;
case V1011: u=memchr(v,C1,m); *x=(u?u-v:m)%2?0:1; R z;
case V0100: *x= *(v+m-1)&&!memchr(v,C1,m-1)?1:0; R z;
case V1101: *x=!*(v+m-1)&&!memchr(v,C0,m-1)?0:1; R z;
case V0110: b=0; DO(m, b=b!=*v++); *x=b; R z;
case V1001: b=1; DO(m, b=b==*v++); *x=b; R z;
}
switch(p->id){I*x,*xx;
case CPLUS:
RZ(z=cvt(INT,z)); x=AV(z);
if(1==c){d=0; DO(m, if(*v++)d++); *x=d;}
else{xx=x+=c; v+=c*(m-1); DO(m-1, DO(c, --x; *x=*--v+*x); x=xx);}
B jtparseinit(J jt){A x;
GA(x,INT,20,1,0); ra(x); jt->nvra=x; jt->nvrav=AAV(x);
GA(x,B01,20,1,0); ra(x); jt->nvrb=x; jt->nvrbv=BAV(x);
R 1;
}
//! 64 bit problems - com and dll interface is 32 bit - needs test and thought
static int a2v (J jt, A a, VARIANT *v, int dobstrs)
{
SAFEARRAY FAR* psa;
SAFEARRAYBOUND rgsabound[MAXRANK];
int er;
I i,r,k,kw,t,cb,*pi;
VARTYPE vt;
k=AN(a);
pi=AV(a);
r=AR(a);
t=NOUN&AT(a);
if(r>MAXRANK) return EVRANK;
if(dobstrs && r<2 && (t&LIT+C2T+C4T)) // char scalar or vector returned as BSTR
{
WCHAR *wstr;
BSTR bstr;
if (LIT&t) {
wstr = malloc(sizeof(WCHAR)*k);
kw=tounin((C*)pi, k, wstr, k);
bstr = SysAllocStringLen(wstr, (UINT)kw);
} else if (C4T&t) {
kw=utowsize((C4*)pi, k);
kw=(kw<0)?(-kw):kw;
wstr = malloc(sizeof(WCHAR)*kw);
utow((C4*)pi, k, wstr);
bstr = SysAllocStringLen(wstr, (UINT)kw);
} else
bstr = SysAllocStringLen((WCHAR*)pi, (UINT)k);
v->vt=VT_BSTR;
v->bstrVal=bstr;
if (t&LIT+C4T) free(wstr);
R 0;
}
switch(t)
{
case LIT:
if(!r) {v->vt=VT_UI1; v->bVal = *(C*)pi; return 0;}
vt=VT_UI1;
cb=k*sizeof(char);
break;
case C2T:
if(!r) {v->vt=VT_UI2; v->iVal = *(WCHAR*)pi; return 0;}
vt=VT_UI2;
cb=k*sizeof(WCHAR);
break;
case C4T:
if(!r) {v->vt=VT_UI4; v->iVal = *(UI4*)pi; return 0;}
vt=VT_UI4;
cb=k*sizeof(C4);
break;
case B01:
if(!r) {
v->vt=VT_BOOL;
v->boolVal = *(B*)pi ? VARIANT_TRUE : VARIANT_FALSE;
return 0;
}
vt=VT_BOOL;
break;
case INT:
#if SY_64
if(jt->int64flag) {
if(!r) {v->vt=VT_I8; v->llVal = (I)(*pi); return 0;}
vt=VT_I8;
cb=k*sizeof(long long);
} else {
if(!r) {v->vt=VT_I4; v->lVal = (int)(*pi); return 0;}
vt=VT_I4;
cb=k*sizeof(int);
}
#else
if(!r) {v->vt=VT_I4; v->lVal = (I)(*pi); return 0;}
vt=VT_I4;
cb=k*sizeof(int);
#endif
break;
case FL:
if(!r) {v->vt=VT_R8; v->dblVal = *(D*)pi; return 0;}
vt=VT_R8;
cb=k*sizeof(double);
break;
case BOX:
if(!r)
{
// Pass a scalar box as a 1-elem VARIANT VT_ARRAY.
// It's marked as such by a lower bound set at -1.
// (All "true" boxed arrays will have the usual lb 0.)
rgsabound[0].lLbound = -1;
rgsabound[0].cElements = 1;
if ( ! (psa = SafeArrayCreate (VT_VARIANT, 1, rgsabound)))
return EVWSFULL;
if (0!= (er = a2v (jt, *(A*)pi, (VARIANT*)psa->pvData, dobstrs)))
{
SafeArrayDestroy (psa);
return er;
}
v->vt=VT_ARRAY|VT_VARIANT;
v->parray = psa;
return 0;
}
vt=VT_VARIANT;
cb=k*sizeof(A);
break;
default:
return EVDOMAIN;
}
if(1<r && jt->transposeflag)
RE(a=cant1(a)); // undo shape reversal later!
for(i=0; i<r; ++i)
{
rgsabound[i].lLbound = 0;
// undo shape reversal from cant1() here.
// In case of Transpose(0), the shape is
// still passed in Column-major notation.
rgsabound[i].cElements = (ULONG)AS(a)[r-1-i];
}
psa = SafeArrayCreate(vt, (UINT)r, rgsabound);
if(!psa)
{
return EVWSFULL;
}
switch (NOUN&AT(a))
{
case B01:
{
VARIANT_BOOL *pv = (VARIANT_BOOL*) psa->pvData;
B *ap = BAV(a);
while (k--)
*pv++ = *ap++ ? VARIANT_TRUE : VARIANT_FALSE;
break;
}
case BOX:
{
A* ap;
VARIANT *v;
for (ap=AAV(a), SafeArrayAccessData(psa, &v);
ap<AAV(a)+k;
++ap, ++v)
{
PROLOG(0118);
er=a2v (jt, *ap, v, dobstrs);
tpop(_ttop);
if (er!=0)
{
SafeArrayUnaccessData (psa);
SafeArrayDestroy (psa);
return er;
}
}
SafeArrayUnaccessData (psa);
break;
}
#if SY_64
case INT:
{
if (!jt->int64flag) {
long *p1=psa->pvData;
I *p2=AV(a);
while (k--)
*p1++=(long)*p2++;
}
break;
}
#endif
default:
memcpy(psa->pvData, AV(a), cb);
}
v->vt=VT_ARRAY|vt;
v->parray = psa;
return 0;
}
// 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];);
// Create the derived verb for a fork. Insert in-placeable flags based on routine, and asgsafe based on fgh
A jtfolk(J jt,A f,A g,A h){A p,q,x,y;AF f1=jtfolk1,f2=jtfolk2;B b;C c,fi,gi,hi;I flag,j,m=-1;V*fv,*gv,*hv,*v;
RZ(f&&g&&h);
gv=VAV(g); gi=gv->id;
hv=VAV(h); hi=hv->id;
// Start flags with ASGSAFE (if g and h are safe), and with INPLACEOK to match the setting of f1,f2
flag=(VINPLACEOK1|VINPLACEOK2)+((gv->flag&hv->flag)&VASGSAFE); // We accumulate the flags for the derived verb. Start with ASGSAFE if all descendants are.
if(NOUN&AT(f)){ /* y {~ x i. ] */
// Temporarily raise the usecount of the noun. Because we are in the same tstack frame as the parser, the usecount will stay
// raised until any inplace decision has been made regarding this derived verb, protecting the derived verb if the
// assigned name is the same as a name appearing here. If the derived verb is used in another sentence, it must first be
// assigned to a name, which will protects values inside it.
rat1s(f); // This justifies keeping the result ASGSAFE
f1=jtnvv1;
if(LIT&AT(f)&&1==AR(f)&&gi==CTILDE&&CFROM==ID(gv->f)&&hi==CFORK){
x=hv->f;
if(LIT&AT(x)&&1==AR(x)&&CIOTA==ID(hv->g)&&CRIGHT==ID(hv->h)){f1=jtcharmapa; flag &=~(VINPLACEOK1);}
}
R fdef(CFORK,VERB, f1,jtnvv2, f,g,h, flag, RMAX,RMAX,RMAX);
}
fv=VAV(f); fi=fv->id; if(fi!=CCAP)flag &= fv->flag|~VASGSAFE; // remove ASGSAFE if f is unsafe
switch(fi){
case CCAP: f1=jtcork1; f2=jtcork2; break; /* [: g h */
case CTILDE: if(NAME&AT(fv->f)){f1=jtcorx1; f2=jtcorx2;} break; /* name g h */
case CSLASH: if(gi==CDIV&&hi==CPOUND&&CPLUS==ID(fv->f)){f1=jtmean; flag|=VIRS1; flag &=~(VINPLACEOK1);} break; /* +/%# */
case CAMP: /* x&i. { y"_ */
case CFORK: /* (x i. ]) { y"_ */
if(hi==CQQ&&(y=hv->f,LIT&AT(y)&&1==AR(y))&&equ(ainf,hv->g)&&
(x=fv->f,LIT&AT(x)&&1==AR(x))&&CIOTA==ID(fv->g)&&
(fi==CAMP||CRIGHT==ID(fv->h))){f1=jtcharmapb; flag &=~(VINPLACEOK1);} break;
case CAT: /* <"1@[ { ] */
if(gi==CLBRACE&&hi==CRIGHT){
p=fv->f; q=fv->g;
if(CLEFT==ID(q)&&CQQ==ID(p)&&(v=VAV(p),x=v->f,CLT==ID(x)&&equ(one,v->g))){f2=jtsfrom; flag &=~(VINPLACEOK2);}
}}
switch(fi==CCAP?gi:hi){
case CQUERY: if(hi==CDOLLAR||hi==CPOUND){f2=jtrollk; flag &=~(VINPLACEOK2);} break;
case CQRYDOT: if(hi==CDOLLAR||hi==CPOUND){f2=jtrollkx; flag &=~(VINPLACEOK2);} break;
case CICAP: m=7; if(fi==CCAP){if(hi==CNE)f1=jtnubind; else if(FIT0(CNE,hv)){f1=jtnubind0; flag &=~(VINPLACEOK1);}} break;
case CSLASH: c=ID(gv->f); m=c==CPLUS?4:c==CPLUSDOT?5:c==CSTARDOT?6:-1;
if(fi==CCAP&&vaid(gv->f)&&vaid(h)){f2=jtfslashatg; flag &=~(VINPLACEOK2);}
break;
case CFCONS: if(hi==CFCONS){x=hv->h; j=*BAV(x); m=B01&AT(x)?(gi==CIOTA?j:gi==CICO?2+j:-1):-1;} break;
case CRAZE: if(hi==CLBRACE){f2=jtrazefrom; flag &=~(VINPLACEOK2);}
else if(hi==CCUT){
j=i0(hv->g);
if(CBOX==ID(hv->f)&&!j){f2=jtrazecut0; flag &=~(VINPLACEOK2);}
else if(boxatop(h)&&j&&-2<=j&&j<=2){f1=jtrazecut1; f2=jtrazecut2; flag &=~(VINPLACEOK1|VINPLACEOK2);}
}}
if(0<=m){
v=4<=m?hv:fv; b=CFIT==v->id&&equ(zero,v->g);
switch(b?ID(v->f):v->id){
case CEQ: f2=b?jtfolkcomp0:jtfolkcomp; flag|=0+8*m; flag &=~(VINPLACEOK1|VINPLACEOK2); break;
case CNE: f2=b?jtfolkcomp0:jtfolkcomp; flag|=1+8*m; flag &=~(VINPLACEOK1|VINPLACEOK2); break;
case CLT: f2=b?jtfolkcomp0:jtfolkcomp; flag|=2+8*m; flag &=~(VINPLACEOK1|VINPLACEOK2); break;
case CLE: f2=b?jtfolkcomp0:jtfolkcomp; flag|=3+8*m; flag &=~(VINPLACEOK1|VINPLACEOK2); break;
case CGE: f2=b?jtfolkcomp0:jtfolkcomp; flag|=4+8*m; flag &=~(VINPLACEOK1|VINPLACEOK2); break;
case CGT: f2=b?jtfolkcomp0:jtfolkcomp; flag|=5+8*m; flag &=~(VINPLACEOK1|VINPLACEOK2); break;
case CEBAR: f2=b?jtfolkcomp0:jtfolkcomp; flag|=6+8*m; flag &=~(VINPLACEOK1|VINPLACEOK2); break;
case CEPS: f2=b?jtfolkcomp0:jtfolkcomp; flag|=7+8*m; flag &=~(VINPLACEOK1|VINPLACEOK2); break;
}}
// If this fork is not a special form, set the flags to indicate whether the f verb does not use an
// argument. In that case h can inplace the unused aegument.
if(f1==jtfolk1 && f2==jtfolk2) flag |= atoplr(f);
R fdef(CFORK,VERB, f1,f2, f,g,h, flag, RMAX,RMAX,RMAX);
}