static F2(jtpdtspvv){A x;D*av,s,t,*wv,z;I i,*u,*u0,*uu,*v,*v0,*vv;P*ap,*wp;
RZ(a&&w);
ap=PAV(a); x=SPA(ap,i); u=u0=AV(x); uu=u+AN(x); x=SPA(ap,x); av=DAV(x);
wp=PAV(w); x=SPA(wp,i); v=v0=AV(x); vv=v+AN(x); x=SPA(wp,x); wv=DAV(x);
z=0.0;
NAN0;
while(1){
i=*u; while(i>*v&&v<vv)++v; if(v==vv)break;
if(i==*v){s=av[u-u0]; t=wv[v-v0]; z+=s&&t?s*t:0; ++u; ++v; continue;}
i=*v; while(i>*u&&u<uu)++u; if(u==uu)break;
if(i==*u){s=av[u-u0]; t=wv[v-v0]; z+=s&&t?s*t:0; ++u; ++v; continue;}
}
NAN1;
R scf(z);
}
static F2(jtfitct){D d;V*sv;
RZ(a&&w);
ASSERT(!AR(w),EVRANK);
sv=VAV(a);
RZ(w=cvt(FL,w)); d=*DAV(w); ASSERT(0<=d&&d<5.82076609134675e-11,EVDOMAIN);
R CDERIV(CFIT,jtfitct1,jtfitct2,sv->mr,sv->lr,sv->rr);
}
static DF1(jtbasis1){DECLF;A z;D*x;I j;V*v;
PREF1(jtbasis1);
RZ(w=vi(w));
switch(*AV(w)){
case 0:
GA(z,FL,3,1,0); x=DAV(z); v=VAV(fs);
j=v->mr; x[0]=j<=-RMAX?-inf:j>=RMAX?inf:j;
j=v->lr; x[1]=j<=-RMAX?-inf:j>=RMAX?inf:j;
j=v->rr; x[2]=j<=-RMAX?-inf:j>=RMAX?inf:j;
R pcvt(INT,z);
case -1: R lrep(inv (fs));
case 1: R lrep(iden(fs));
default: ASSERT(0,EVDOMAIN);
}}
A gfarray(D *d, I n) { A z; D *zv;
z=ga(FLT,1,n,NULL);
zv=DAV(z);
DO(n, zv[i]=d[i]);
R z;
}
// 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];);
/*
** set_tag_arg
**
** parse & set one single tag argument
**
*/
static BOOL set_tag_arg( HSCPRC *hp, DLLIST *varlist, STRPTR varname )
{
HSCATTR *var = find_varname( varlist, varname );
INFILE *inpf = hp->inpf;
STRPTR arg = NULL;
BOOL ok = FALSE;
STRPTR nw;
HSCATTR skipvar; /* dummy attribute to skip unkown */
EXPSTR *attr_str = init_estr( 40 ); /* string for attribute name */
EXPSTR *val_str = init_estr( 40 ); /* string for "=" and value */
DAV( fprintf( stderr, DHL " set attr %s\n", varname ) );
/* append attribute name to attr_str */
app_estr( attr_str, infgetcws( inpf ) );
app_estr( attr_str, infgetcw( inpf ) );
if ( !var ) { /* attribute not found */
/* assign to pseudo-attribute */
var = &skipvar;
var->name = varname;
var->deftext = NULL;
var->text = NULL;
var->enumstr = NULL;
var->vartype = VT_STRING;
var->varflag = 0;
/* message: unknown attribute */
hsc_msg_unkn_attr( hp, varname );
}
/* get argument */
nw = infgetw( inpf );
if ( nw )
if ( !strcmp( nw, "=" ) ) {
/* append "=" to log */
app_estr( val_str, infgetcws( inpf ) );
app_estr( val_str, infgetcw( inpf ) );
/* parse expression */
arg = eval_expression( hp, var, NULL );
/* append value to log */
if ( var->quote != VQ_NO_QUOTE )
app_estrch( val_str, var->quote );
if ( get_vartext( var ) )
app_estr( val_str, get_vartext( var ) );
if ( var->quote != VQ_NO_QUOTE )
app_estrch( val_str, var->quote );
if ( arg ) {
DAV( fprintf( stderr, DHL " `%s'\n", arg ) );
ok = TRUE;
}
} else {
arg = NULL;
inungetcwws( inpf );
ok = TRUE;
}
else
hsc_msg_eof( hp, "read attribute value" );
if ( ok )
if ( arg ) {
if ( var->vartype == VT_BOOL ) {
/* set boolean attribute depending on expression */
set_vartext_bool( var, get_varbool( var ) );
/* if the expression returned FALSE, remove
** the boolean switch from the call
*/
if ( !get_varbool( var ) )
clr_estr( attr_str );
} else
/* append value to attribute string */
app_estr( attr_str, estr2str( val_str ) );
} else {
/* no value has been passed to the attribute */
if ( var->vartype == VT_BOOL ) {
/* for boolean attributes, this is legal,
** and enables the attribute
*/
set_vartext_bool( var, TRUE );
} else {
/* for non-boolean attributes, display
** error message
*/
hsc_message( hp, MSG_NOARG_ATTR,
"missing value for %A", var );
}
}
#if 0
if ( arg ) {
if ( var->vartype == VT_BOOL ) {
message( MSG_ARG_BOOL_ATTR, inpf );
errstr( "value for boolean" );
errsym( var->name );
errlf();
}
} else {
if ( var->vartype == VT_BOOL ) {
/* set boolean attribute */
DAV( fprintf( stderr, " (bool)\n", var->name ) );
set_vartext( var, var->name );
var->quote = VQ_NO_QUOTE;
} else {
}
}
#endif
/* cleanup pseudo-attr */
if ( var == &skipvar )
clr_vartext( var );
/* append & cleanup attribute and value string */
app_estr( hp->tag_attr_str, estr2str( attr_str ) );
del_estr( attr_str );
del_estr( val_str );
return( ok );
}
static DF2(jtfitct2){DECLFG;A z;D old=jt->ct; jt->ct=*DAV(gs); z=CALL2(f2,a,w,fs); jt->ct=old; R z;}
static DF1(jtfitct1){DECLFG;A z;D old=jt->ct; jt->ct=*DAV(gs); z=CALL1(f1, w,fs); jt->ct=old; R z;}
