#ifndef __PDLPERL_H
#define __PDLPERL_H
#define PDL_XS_PREAMBLE(nret) \
char
*objname =
"PDL"
;
\
HV *bless_stash = 0; \
SV *parent = 0; \
int
nreturn = (nret); \
(
void
)nreturn; \
\
\
\
do
{ \
if
(SvROK(ST(0)) && ((SvTYPE(SvRV(ST(0))) == SVt_PVMG) || (SvTYPE(SvRV(ST(0))) == SVt_PVHV))) { \
parent = ST(0); \
if
(sv_isobject(parent)){ \
bless_stash = SvSTASH(SvRV(parent)); \
objname = HvNAME((bless_stash));
\
} \
} \
}
while
(0)
static
inline
pdl *PDL_XS_pdlinit(pTHX_
char
*objname, HV *bless_stash, SV *to_push,
char
*method, SV **svp, Core *core) {
dSP;
pdl *ret;
if
(
strcmp
(objname,
"PDL"
) == 0) {
ret = core->pdlnew();
if
(!ret) core->pdl_barf(
"Error making null pdl"
);
if
(svp) {
*svp = sv_newmortal();
core->SetSV_PDL(*svp, ret);
if
(bless_stash) *svp = sv_bless(*svp, bless_stash);
}
}
else
{
PUSHMARK(SP);
XPUSHs(to_push);
PUTBACK;
perl_call_method(method, G_SCALAR);
SPAGAIN;
SV *sv = POPs;
PUTBACK;
ret = core->SvPDLV(sv);
if
(svp) *svp = sv;
}
return
ret;
}
#define PDL_XS_PERLINIT_initsv(sv) \
PDL_XS_pdlinit(aTHX_ objname, bless_stash, parent ? parent : sv_2mortal(newSVpv(objname, 0)),
"initialize"
, &sv, PDL)
#define PDL_XS_RETURN(clause1) \
if
(nreturn) { \
if
(nreturn > 0) EXTEND (SP, nreturn); \
clause1; \
XSRETURN(nreturn); \
}
else
{ \
XSRETURN(0); \
}
#define PDL_IS_INPLACE(in) ((in)->state & PDL_INPLACE)
#define PDL_XS_INPLACE(in, out) \
if
(PDL_IS_INPLACE(in)) { \
if
(out ## _SV) barf(
"inplace input but different output given"
); \
out ## _SV = sv_newmortal(); \
in->state &= ~PDL_INPLACE; \
out = in; \
PDL->SetSV_PDL(out ## _SV,out); \
}
else
\
out = out ## _SV ? PDL_CORE_(SvPDLV)(out ## _SV) : \
PDL_XS_PERLINIT_initsv(out ## _SV);
#define PDL_XS_SCALAR(thistype, ppsym, val) \
PDL_Anyval av = {PDL_CLD, {.H=0}};
\
av.type = thistype; av.value.ppsym=val; \
pdl *b = pdl_scalar(av); \
if
(!b) XSRETURN_UNDEF; \
SV *b_SV = sv_newmortal(); \
pdl_SetSV_PDL(b_SV, b); \
EXTEND(SP, 1); \
ST(0) = b_SV; \
XSRETURN(1);
#define PDL_MAKE_PERL_COMPLEX(output,r,i) { \
dSP; NV rval = r, ival = i; \
perl_require_pv(
"PDL/Complex/Overloads.pm"
); \
ENTER; SAVETMPS; \
PUSHMARK(SP); mXPUSHn(rval); mXPUSHn(ival); PUTBACK; \
int
count = perl_call_pv(
"PDL::Complex::Overloads::cplx"
, G_SCALAR); \
SPAGAIN; \
if
(count != 1) croak(
"Failed to create PDL::Complex::Overloads object (%.9"
NVgf
", %.9"
NVgf
")"
, rval, ival); \
sv_setsv(output, POPs); \
PUTBACK; \
FREETMPS; LEAVE; \
}
#define PDL_SV_IS_UNDEF(sv) ( (!(sv) || ((sv)==&PL_sv_undef)) || !(SvNIOK(sv) || (SvTYPE(sv)==SVt_PVMG) || SvPOK(sv) || SvROK(sv)))
#define ANYVAL_FROM_SV(outany,insv,use_undefval,forced_type,warn_undef) do { \
SV *sv2 = insv; \
if
(PDL_SV_IS_UNDEF(sv2)) { \
if
(!use_undefval) { \
outany.type = forced_type >=0 ? forced_type : -1; \
outany.value.B = 0; \
break
; \
} \
sv2 = get_sv(
"PDL::undefval"
,1); \
if
((warn_undef) && SvIV(get_sv(
"PDL::debug"
,1))) \
fprintf
(stderr,
"Warning: SvPDLV converted undef to $PDL::undefval (%"
NVgf
").\n"
,SvNV(sv2)); \
if
(PDL_SV_IS_UNDEF(sv2)) { \
outany.type = forced_type >=0 ? forced_type : PDL_B; \
outany.value.B = 0; \
break
; \
} \
} \
if
(SvROK(sv2)) { \
if
(sv_derived_from(sv2,
"PDL"
)) { \
pdl *it = PDL_CORE_(SvPDLV)(sv2); \
outany.type = PDL_INVALID; \
if
(it->nvals == 1) \
ANYVAL_FROM_CTYPE_OFFSET(outany, it->datatype, PDL_REPRP(it), PDL_REPROFFS(it)); \
if
(outany.type < 0) PDL_CORE_(pdl_barf)(
"Position out of range"
); \
break
; \
} \
if
(sv_derived_from(sv2,
"Math::Complex"
)) { \
ANYVAL_FROM_MCOMPLEX(outany, sv2); \
break
; \
} \
PDL_CORE_(pdl_barf)(
"Can't convert ref '%s' to Anyval"
, sv_reftype(SvRV(sv2), 1)); \
}
else
if
(!SvIOK(sv2)) {
\
NV tmp_NV = SvNV(sv2); \
int
datatype = forced_type >=0 ? forced_type : _pdl_whichdatatype_double(tmp_NV); \
ANYVAL_FROM_CTYPE(outany, datatype, tmp_NV); \
}
else
if
(SvIsUV(sv2)) {
\
UV tmp_UV = SvUV(sv2); \
int
datatype = forced_type >=0 ? forced_type : _pdl_whichdatatype_uint(tmp_UV); \
ANYVAL_FROM_CTYPE(outany, datatype, tmp_UV); \
}
else
{
\
IV tmp_IV = SvIV(sv2); \
int
datatype = forced_type >=0 ? forced_type : _pdl_whichdatatype_int(tmp_IV); \
ANYVAL_FROM_CTYPE(outany, datatype, tmp_IV); \
} \
}
while
(0)
#define ANYVAL_FROM_MCOMPLEX(outany,insv) do { \
dSP; \
int
i; \
double
vals[2]; \
char
*meths[] = {
"Re"
,
"Im"
}; \
ENTER; SAVETMPS; \
for
(i = 0; i < 2; i++) { \
PUSHMARK(SP); XPUSHs(insv); PUTBACK; \
int
count = perl_call_method(meths[i], G_SCALAR); \
SPAGAIN; \
if
(count != 1) PDL_CORE_(pdl_barf)(
"Failed Math::Complex method '%s'"
, meths[i]); \
vals[i] = (
double
)POPn; \
PUTBACK; \
} \
FREETMPS; LEAVE; \
outany.type = PDL_CD; \
outany.value.C = (PDL_CDouble)(vals[0] + I * vals[1]); \
}
while
(0)
#define ANYVAL_UNSIGNED_X(outsv, inany, sym, ctype, ppsym, ...) \
sv_setuv(outsv, (UV)(inany.value.ppsym));
#define ANYVAL_SIGNED_X(outsv, inany, sym, ctype, ppsym, ...) \
sv_setiv(outsv, (IV)(inany.value.ppsym));
#define ANYVAL_FLOATREAL_X(outsv, inany, sym, ctype, ppsym, ...) \
sv_setnv(outsv, (NV)(inany.value.ppsym));
#define ANYVAL_COMPLEX_X(outsv, inany, sym, ctype, ppsym, shortctype, defbval, realctype, convertfunc, floatsuffix, ...) \
PDL_MAKE_PERL_COMPLEX(outsv, creal ## floatsuffix(inany.value.ppsym), cimag ## floatsuffix(inany.value.ppsym));
#define ANYVAL_TO_SV(outsv,inany) do { switch (inany.type) { \
PDL_TYPELIST_UNSIGNED(PDL_GENERICSWITCH_CASE, ANYVAL_UNSIGNED_X, (outsv,inany,),) \
PDL_TYPELIST_SIGNED(PDL_GENERICSWITCH_CASE, ANYVAL_SIGNED_X, (outsv,inany,),) \
PDL_TYPELIST_FLOATREAL(PDL_GENERICSWITCH_CASE, ANYVAL_FLOATREAL_X, (outsv,inany,),) \
PDL_TYPELIST_COMPLEX(PDL_GENERICSWITCH_CASE, ANYVAL_COMPLEX_X, (outsv,inany,),) \
default
: outsv = &PL_sv_undef; \
} \
}
while
(0)
#define PDL_TESTTYPE(sym, ctype, v) {ctype foo = v; if (v == foo) return sym;}
static
inline
int
_pdl_whichdatatype_uint(UV uv) {
#define X(sym, ctype, ...) PDL_TESTTYPE(sym, ctype, uv)
PDL_TYPELIST_UNSIGNED(X)
#undef X
croak(
"Something's gone wrong: %llu cannot be converted by whichdatatype"
, (unsigned
long
long
)uv);
}
static
inline
int
_pdl_whichdatatype_int(IV iv) {
#define X(sym, ctype, ...) PDL_TESTTYPE(sym, ctype, iv)
PDL_TYPELIST_SIGNED(X)
#undef X
croak(
"Something's gone wrong: %lld cannot be converted by whichdatatype"
, (
long
long
)iv);
}
static
inline
int
_pdl_whichdatatype_double(NV nv) {
PDL_TESTTYPE(PDL_D,PDL_Double, nv)
PDL_TESTTYPE(PDL_D,PDL_LDouble, nv)
#undef PDL_TESTTYPE
return
PDL_D;
}
#endif