static DF2(con2){A h,*hv,*x,z;V*sv;
PREF2(con2);
sv=VAV(self); h=sv->h; hv=AAV(h);
GA(z,BOX,AN(h),AR(h),AS(h)); x=AAV(z);
DO(AN(h), RZ(*x++=(VAV(*hv)->f2)(a,w,*hv)); ++hv);
R ope(z);
}
A jtfxeachv(J jt,I r,A w){A*wv,x,z,*zv;I n,wd;
RZ(w);
n=AN(w); wv=AAV(w); wd=(I)w*ARELATIVE(w);
ASSERT(r>=AR(w),EVRANK);
ASSERT(n,EVLENGTH);
ASSERT(BOX&AT(w),EVDOMAIN);
GA(z,BOX,n,AR(w),AS(w)); zv=AAV(z);
DO(n, RZ(zv[i]=x=fx(WVR(i))); ASSERT(VERB&AT(x),EVDOMAIN););
static DF1(jtgsuffix){A h,*hv,z,*zv;I m,n,r;
RZ(w);
if(jt->rank&&jt->rank[1]<AR(w)){r=jt->rank[1]; jt->rank=0; R rank1ex(w,self,jt->rank[1],jtgsuffix);}
jt->rank=0;
n=IC(w);
h=VAV(self)->h; hv=AAV(h); m=AN(h);
GATV(z,BOX,n,1,0); zv=AAV(z);
DO(n, RZ(zv[i]=df1(drop(sc(i),w),hv[i%m])););
static DF1(jtpowseqlim){PROLOG(0039);A x,y,z,*zv;I i,n;
RZ(w);
RZ(z=exta(BOX,1L,1L,20L)); zv=AAV(z); *zv++=x=w;
i=1; n=AN(z);
while(1){
if(n==i){RZ(z=ext(0,z)); zv=i+AAV(z); n=AN(z);}
RZ(*zv++=x=df1(y=x,self));
if(equ(x,y)){AN(z)=*AS(z)=i; break;}
++i;
}
z=ope(z);
EPILOG(z);
} /* f^:(<_) w */
static F1(jtvtokens){A t,*y,z;I n,*s;TA*x;
RZ(t=tokens(vs(w))); n=AN(t); y=AAV(t);
jt->tmonad=1;
GA(z,BOX,WTA*(5+n),2,0); s=AS(z); *s++=5+n; *s=WTA;
x=(TA*)AV(z);
x->a=mark; x->t=0; ++x;
DO(n, x->a=t=*y++; x->t=0; ++x; if(t==xnam||jt->dotnames&&t==xdot)jt->tmonad=0;);
static void jsig(void){
tostdout=1; suspend=1;
if(debugb&&!spc()){
dhead(); jputs("ws full (can not debug suspend)"); jputc(CNL);
debugb=0;
}
dhead(); jputs(AV(*(jerr+AAV(qevm)))); jputc(CNL);
}
A gcinit(VO) { I k=WP(BOX,1,NOBJS); A memory;
nmem=mtop=bytes=totbytes=0;
memory=a_malloc(k);
AT(memory)=BOX; AR(memory)=1;
AN(memory)=*AS(memory)=NOBJS;
objs=AAV(memory);
R memory;
}
A gtest_array(I n, ...) {
va_list ap;
A z = ga(BOX,1,n+5,NULL), *zv = AAV(z);
*zv++ = mark;
va_start(ap, n);
DO(n, zv[i] = va_arg(ap, A));
DO(4, zv[n+i] = mark);
va_end(ap);
R z;
}
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 DF1(insert){PROLOG;A hs,*hv,z;I hn,j,k,m,n;
RZ(w);
m=IC(w); hs=VAV(self)->h; hn=AN(hs); hv=AAV(hs);
if(!m)R df1(w,iden(*hv));
j=n=MAX(hn,m-1);
RZ(z=AR(w)?from(sc(n%m),w):ca(w));
if(1==n)R z;
DO(n, --j; k=j%hn; RZ(z=(VAV(hv[k])->f2)(from(sc(j%m),w),z,hv[k])));
EPILOG(z);
}
static B jtixin(J jt,A w,I s,I*i,I*n){A in,*wv;I j,k,m,*u,wd;
if(AT(w)&BOX){wv=AAV(w); wd=(I)w*ARELATIVE(w); RZ(in=vi(WVR(1))); k=AN(in); u=AV(in);}
else{in=w; k=AN(in)-1; u=1+AV(in);}
ASSERT(1>=AR(in),EVRANK);
ASSERT(k&&k<=(n?2:1),EVLENGTH);
j=u[0]; j=0>j?s+j:j; m=1==k?s-j:u[1];
ASSERT(0<=j&&(!n||j<s&&j+m<=s&&0<=m),EVINDEX);
*i=j; if(n)*n=m;
R 1;
} /* process index file arg for index and length */
A traverse(A y, AF1 f1) { V *v; A *a; SY *sy; I n;
RZ(y); n=AN(y);
switch (AT(y)) {
case ADV:
case CONJ:
case VERB: { v=VAV(y); DO(n, f1(v->f); f1(v->g); f1(v->h)); break; }
case BOX: { a=AAV(y); DO(n, f1(*a++)); break; }
case SYMB: { sy=SYAV(y); DO(n, f1(sy->name); f1(sy->value); sy++); break; }
}
R one;
}
static DF2(xd){PROLOG;DECLFG;A f,*line,loc=local,name,seq,z=0;B b;DC dv;
I i=0,n,old;
b=a&&w; f=*(b+AAV(sv->h));
line=AAV(f); n=nline=AN(f); ASSERT(n,EVDOMAIN);
GA(local,SYMB,twprimes[0],1,0);
symbis(scnm(CALPHA),a,local);
symbis(scnm(COMEGA),w,local);
RZ(dv=debadd(DCDEFN)); dv->p=sv->s; drun=0;
old=tbase+ttop;
ra(self);
for(;0<=i&&i<n;i++){
tpop(old);
dv->ln=i; dv->n=1+(0!=a);
z=parse(ca(line[i]));
if(!debugb&&!z) break;
}
if(debugb&&!z){z=tpush(qpopres); qpopres=0;}
z=car(z); ++AC(local); fa(local); local=loc;
asgn=0;
fa(self);
debz();
if(!z) jsignal(EVRESULT);
EPILOG(z);
}
A jtstcreate(J jt,C k,I p,I n,C*u){A g,*pv,x,y;C s[20];I m,*nv;L*v;
GA(g,SYMB,ptab[p],1,0);
RZ(v=symnew(AV(g))); v->flag|=LINFO; v->sn=jt->symindex++;
switch(k){
case 0: /* named locale */
RZ(x=nfs(n,u));
LOCNAME(g)=x; LOCPATH(g)=ra(1==n&&'z'==*u?vec(BOX,0L,0L):zpath);
symbis(x,g,jt->stloc);
break;
case 1: /* numbered locale */
ASSERT(0<=jt->stmax,EVLOCALE);
sprintf(s,FMTI,n); RZ(x=nfs(strlen(s),s));
LOCNAME(g)=x; LOCPATH(g)=ra(zpath);
++jt->stused;
m=AN(jt->stnum);
if(m<jt->stused){
x=ext(1,jt->stnum); y=ext(1,jt->stptr); RZ(x&&y); jt->stnum=x; jt->stptr=y;
nv=m+AV(jt->stnum); pv=m+AAV(jt->stptr); DO(AN(x)-m, *nv++=-1; *pv++=0;);
}
static I jtfdepger(J jt,A w){A*wv;I d=0,k,wd;
wv=AAV(w); wd=(I)w*ARELATIVE(w);
DO(AN(w), k=fdep(fx(WVR(i))); d=MAX(d,k););
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;
}
case 0: /* named locale */
RZ(x=nfs(n,u));
LOCNAME(g)=x; LOCPATH(g)=ra(1==n&&'z'==*u?vec(BOX,0L,0L):zpath);
symbis(x,g,jt->stloc);
break;
case 1: /* numbered locale */
ASSERT(0<=jt->stmax,EVLOCALE);
sprintf(s,FMTI,n); RZ(x=nfs(strlen(s),s));
LOCNAME(g)=x; LOCPATH(g)=ra(zpath);
++jt->stused;
m=AN(jt->stnum);
if(m<jt->stused){
x=ext(1,jt->stnum); y=ext(1,jt->stptr); RZ(x&&y); jt->stnum=x; jt->stptr=y;
nv=m+AV(jt->stnum); pv=m+AAV(jt->stptr); DO(AN(x)-m, *nv++=-1; *pv++=0;);
}
pv=AAV(jt->stptr);
DO(AN(jt->stnum), if(!pv[i]){pv[i]=ra(g); *(i+AV(jt->stnum))=n; break;});
jt->stmax=n<IMAX?MAX(jt->stmax,1+n):-1;
break;
case 2: /* local symbol table */
;
}
R g;
} /* create locale, named (0==k) or numbered (1==k) */
B jtsymbinit(J jt){A q;I n=40;
jt->locsize[0]=3; /* default hash table size for named locales */
jt->locsize[1]=2; /* default hash table size for numbered locales */
RZ(symext(0)); /* initialize symbol pool */
GA(q,SYMB,ptab[3],1,0); jt->stloc=q;
RZ(q=apv(n,-1L,0L)); jt->stnum=q;
I level(A w){A*wv;I d,j,wd;
if(!(AN(w)&&AT(w)&BOX+SBOX))R 0;
d=0; wv=AAV(w); wd=(I)w*ARELATIVE(w);
DO(AN(w), j=level(WVR(i)); if(d<j)d=j;);
static DF2(gcl2){DECLFG;A*hv=AAV(sv->h);
R df2(df2(a,w,hv[0]),df2(a,w,hv[2]),df2(df2(a,w,hv[1]),gs,ds(sv->id)));
}
static DF1(gcl1){DECLFG;A*hv=AAV(sv->h);
R df1(df1(w,hv[2]),df2(df1(w,hv[1]),gs,ds(sv->id)));
}
// 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];);
//! 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;
}
static DCF(seedebug){A t=*(si->ln+AAV(qevm)); jputs(AV(t));}
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;);
