File Coverage

/usr/local/lib/perl5/site_perl/5.42.0/x86_64-linux/PDL/Core/pdlperl.h

Criterion	Covered	Total	%
statement	10	19	52.6
branch	4	14	28.5
condition			n/a
subroutine			n/a
pod			n/a
total	14	33	42.4

#ifndef __PDLPERL_H
#define __PDLPERL_H

#define PDL_XS_PREAMBLE(nret) \
  char *objname = "PDL"; /* XXX maybe that class should actually depend on the value set \
                            by pp_bless ? (CS) */ \
  HV *bless_stash = 0; \
  SV *parent = 0; \
  int   nreturn = (nret); \
  (void)nreturn; \
  /* Check if you can get a package name for this input value. */ \
  /* It can be either a PDL (SVt_PVMG) or a hash which is a */ \
  /* derived PDL subclass (SVt_PVHV) */ \
  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)); /* The package to bless output vars into is taken from the first input var */ \
      } \
    } \
  } 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) { /* shortcut if just PDL */
     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 { \
      if (GIMME_V == G_SCALAR) XSRETURN_UNDEF; /* GH#551 */ \
      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}}; /* guarantee all bits set */ \
  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; \
}

/***************
 * So many ways to be undefined...
 */
#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.H = 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.H = 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)) { /* Perl Double (e.g. 2.0) */ \
        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)) { /* Perl unsigned int */ \
        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 { /* Perl Int (e.g. 2) */ \
        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)

/* only to CD, same as whichdatatype_double only D. only if know is M:C */
#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)

/* Check minimum datatype required to represent number */
#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);
}
/* Check minimum, at least double, datatype required to represent number */
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; /* handles NaN */
}

/* __PDLPERL_H */
#endif