1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
|
#include "EXTERN.h"
#include "perl.h"
#include "pdl.h"
#include "pdlcore.h"
#define PDL PDL_LinearAlgebra_Trans
extern Core *PDL;
typedef PDL_Long integer;
/* replace BLAS one so don't terminate on bad input */
int xerbla_(char *sub, int *info) { return 0; }
void dfunc_wrapper(void *p, integer n, SV* dfunc)
{
dSP ;
PDL_Indx odims[] = {0};
PDL_Indx nat_dims[] = {n};
PDL_Indx *dims = nat_dims;
PDL_Indx ndims = 1;
int type_add = PDL_CF - PDL_F;
pdl *pdl = PDL->pdlnew();
PDL->setdims(pdl, dims, ndims);
pdl->datatype = PDL_D + type_add;
pdl->data = p;
pdl->state |= PDL_DONTTOUCHDATA | PDL_ALLOCATED;
HV *bless_stash = gv_stashpv("PDL", 0);
ENTER ; SAVETMPS ; PUSHMARK(sp) ;
SV *pdl1 = sv_newmortal();
PDL->SetSV_PDL(pdl1, pdl);
pdl1 = sv_bless(pdl1, bless_stash);
XPUSHs(pdl1);
PUTBACK ;
int count = perl_call_sv(dfunc, G_SCALAR);
SPAGAIN;
PDL->setdims(pdl, odims, 1);
pdl->state &= ~(PDL_ALLOCATED |PDL_DONTTOUCHDATA);
pdl->data=NULL;
if (count !=1)
croak("Error calling perl function\n");
PUTBACK ; FREETMPS ; LEAVE ;
}
|
