static void susp(void){I old=tbase+ttop;C*sp;
suspend=debugb;
scad=0;
while(suspend){
immex(jgets(" ")); jerr=0;
tpop(old);
}
suspend=debugb;
}
int jget(J jt, C* name, VARIANT* v, int dobstr)
{
A a;
char gn[256];
I old;
int er;
if(strlen(name) >= sizeof(gn)) return EVILNAME;
if(valid(name, gn)) return EVILNAME;
RZ(a=symbrd(nfs(strlen(gn),gn)));
old = jt->tnextpushx;
er = a2v (jt, a, v, dobstr);
tpop (old);
return er;
}
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);
}
//! 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;
}
