swig/gsl_typemaps.i

   1 %include "system.i"
   2 %include "gsl/gsl_nan.h"
   3 #if defined(GSL_MINOR_VERSION) &&  GSL_MINOR_VERSION >= 12
   4     %include "gsl/gsl_inline.h"
   5 #endif
   6
   7 %{
   8     #include "gsl/gsl_nan.h"
   9     #include "gsl/gsl_math.h"
  10     #include "gsl/gsl_monte.h"
  11 %}
  12
  13 /*****************************
  14  * handle 'double const []' as an input array of doubles
  15  * We allocate the C array at the begining and free it at the end
  16  */
  17 %typemap(in) double const [] {
  18     AV *tempav;
  19     I32 len;
  20     int i;
  21     SV **tv;
  22     if (!SvROK($input))
  23         croak("Math::GSL : $$1_name is not a reference!");
  24     if (SvTYPE(SvRV($input)) != SVt_PVAV)
  25         croak("Math::GSL : $$1_name is not an array ref!");
  26
  27     tempav = (AV*)SvRV($input);
  28     len = av_len(tempav);
  29     $1 = (double *) malloc((len+1)*sizeof(double));
  30     for (i = 0; i <= len; i++) {
  31         tv = av_fetch(tempav, i, 0);
  32         $1[i] = (double) SvNV(*tv);
  33     }
  34 }
  35 /*  This caused gsl_vector_view  functions to fail, can we
  36  *  turn this off for those functions?
  37 %typemap(freearg) double const [] {
  38         if ($1) free($1);
  39 }
  40 */
  41
  42 %apply double const [] {
  43     double *data, double *dest, double *f_in, double *f_out,
  44     double data[], const double * src, double x[], double a[], double b[],
  45     const double * x, const double * y, const double * w , const double x_array[],
  46     const double xrange[], const double yrange[], double * base,
  47     const double * base, const double xrange[], const double yrange[] ,
  48     const double * array , const double data2[], const double w[] ,
  49     double *v,
  50     gsl_complex_packed_array data
  51 };
  52
  53 /*****************************
  54  * handle 'float const []' as an input array of floats
  55  * We allocate the C array at the begining and free it at the end
  56  */
  57 %typemap(in) float const [] {
  58     AV *tempav;
  59     I32 len;
  60     int i;
  61     SV **tv;
  62     if (!SvROK($input))
  63         croak("Math::GSL : $$1_name is not a reference!");
  64     if (SvTYPE(SvRV($input)) != SVt_PVAV)
  65         croak("Math::GSL : $$1_name is not an array ref!");
  66
  67     tempav = (AV*)SvRV($input);
  68     len = av_len(tempav);
  69     $1 = (float *) malloc((len+1)*sizeof(float));
  70     for (i = 0; i <= len; i++) {
  71         tv = av_fetch(tempav, i, 0);
  72         $1[i] = (float)(double) SvNV(*tv);
  73     }
  74 }
  75
  76 %typemap(freearg) float const [] {
  77         if ($1) free($1);
  78 }
  79
  80 %apply float const [] {
  81     float const *A, float const *B, float const *C, float *C
  82 };
  83
  84 /*****************************
  85  * handle 'size_t const []' as an input array of size_t
  86  * We allocate the C array at the begining and free it at the end
  87  */
  88 %typemap(in) size_t const [] {
  89     AV *tempav;
  90     I32 len;
  91     int i;
  92     SV **tv;
  93     if (!SvROK($input))
  94         croak("Math::GSL : $$1_name is not a reference!");
  95     if (SvTYPE(SvRV($input)) != SVt_PVAV)
  96         croak("Math::GSL : $$1_name is not an array ref!");
  97
  98     tempav = (AV*)SvRV($input);
  99     len = av_len(tempav);
 100     $1 = (size_t *) malloc((len+1)*sizeof(size_t));
 101     for (i = 0; i <= len; i++) {
 102         tv = av_fetch(tempav, i, 0);
 103         $1[i] = SvIV(*tv);
 104     }
 105 }
 106
 107 %typemap(freearg) size_t const [] {
 108         if ($1) free($1);
 109 }
 110
 111 %apply size_t const [] {
 112     size_t *p
 113 }
 114
 115 /*****************************
 116  * handle some parameters as input or output
 117  */
 118 %apply int *OUTPUT { size_t *imin, size_t *imax, size_t *neval };
 119 %apply double * OUTPUT {
 120     double * min_out, double * max_out,
 121     double *abserr, double *result
 122 };
 123
 124 /*****************************
 125  * Callback managment
 126  */
 127 %{
 128     /* structure to hold required information while the gsl function call
 129        for each callback
 130      */
 131     struct gsl_function_perl {
 132         gsl_function C_gsl_function;
 133         SV * function;
 134         SV * params;
 135     };
 136     struct gsl_monte_function_perl {
 137         gsl_monte_function C_gsl_monte_function;
 138         SV * f;
 139         SV * dim;
 140         SV * params;
 141     };
 142
 143
 144     /* These functions (C callbacks) calls the perl callbacks.
 145        Info for perl callback can be found using the 'void*params' parameter
 146     */
 147     double call_gsl_function(double x , void *params){
 148         struct gsl_function_perl *F=(struct gsl_function_perl*)params;
 149         unsigned int count;
 150         double y;
 151         dSP;
 152
 153         //fprintf(stderr, "LOOKUP CALLBACK\n");
 154         ENTER;
 155         SAVETMPS;
 156
 157         PUSHMARK(SP);
 158         XPUSHs(sv_2mortal(newSVnv((double)x)));
 159         XPUSHs(F->params);
 160         PUTBACK;                                /* make local stack pointer global */
 161
 162         count = call_sv(F->function, G_SCALAR);
 163         SPAGAIN;
 164
 165         if (count != 1)
 166                 croak("Expected to call subroutine in scalar context!");
 167
 168         y = POPn;
 169
 170         PUTBACK;                                /* make local stack pointer global */
 171         FREETMPS;
 172         LEAVE;
 173
 174         return y;
 175     }
 176     double call_gsl_monte_function(double *x_array , size_t dim, void *params){
 177         struct gsl_monte_function_perl *F=(struct gsl_monte_function_perl*)params;
 178         unsigned int count;
 179         unsigned int i;
 180         AV* perl_array;
 181         double y;
 182         dSP;
 183
 184         //fprintf(stderr, "LOOKUP CALLBACK\n");
 185         ENTER;
 186         SAVETMPS;
 187
 188         PUSHMARK(SP);
 189         perl_array=newAV();
 190         sv_2mortal((SV*)perl_array);
 191         XPUSHs(sv_2mortal(newRV((SV *)perl_array)));
 192         for(i=0; i<dim; i++) {
 193                 /* no mortal : it is referenced by the array */
 194                 av_push(perl_array, newSVnv(x_array[i]));
 195         }
 196         XPUSHs(sv_2mortal(newSViv(dim)));
 197         XPUSHs(F->params);
 198         PUTBACK;                                /* make local stack pointer global */
 199
 200         count = call_sv(F->f, G_SCALAR);
 201         SPAGAIN;
 202
 203         if (count != 1)
 204                 croak("Expected to call subroutine in scalar context!");
 205
 206         y = POPn;
 207
 208         PUTBACK;                                /* make local stack pointer global */
 209         FREETMPS;
 210         LEAVE;
 211
 212         return y;
 213     }
 214 %}
 215
 216 %typemap(in) gsl_monte_function * (struct gsl_monte_function_perl w_gsl_monte_function) {
 217     SV * f = 0;
 218     SV * dim = 0;
 219     SV * params = 0;
 220     size_t C_dim;
 221
 222     if (SvROK($input) && (SvTYPE(SvRV($input)) == SVt_PVAV)) {
 223         AV* array=(AV*)SvRV($input);
 224         SV ** p_f = 0;
 225         if (av_len(array)<0) {
 226             croak("Math::GSL : $$1_name is an empty array!");
 227         }
 228         if (av_len(array)>2) {
 229             croak("Math::GSL : $$1_name is an array with more than 3 elements!");
 230         }
 231         p_f = av_fetch(array, 0, 0);
 232         f = *p_f;
 233         if (av_len(array)>0) {
 234             SV ** p_dim = 0;
 235             p_dim = av_fetch(array, 1, 0);
 236             dim = *p_dim;
 237         }
 238         if (av_len(array)>1) {
 239             SV ** p_params = 0;
 240             p_params = av_fetch(array, 1, 0);
 241             params = *p_params;
 242         }
 243     } else {
 244         f = $input;
 245     }
 246
 247     if (!f || !(SvPOK(f) || (SvROK(f) && (SvTYPE(SvRV(f)) == SVt_PVCV)))) {
 248         croak("Math::GSL : $$1_name is not a reference to code!");
 249     }
 250
 251     f = newSVsv(f);
 252
 253     if (! dim) {
 254         dim=&PL_sv_undef;
 255         C_dim=0;
 256     } else {
 257         if (!SvIOK(dim)) {
 258             croak("Math::GSL : $$1_name is not an integer for dim!");
 259         }
 260         C_dim=SvIV(dim);
 261     }
 262     dim = newSVsv(dim);
 263
 264     if (! params) {
 265         params=&PL_sv_undef;
 266     }
 267     params = newSVsv(params);
 268
 269     w_gsl_monte_function.f = f;
 270     w_gsl_monte_function.dim = dim;
 271     w_gsl_monte_function.params = params;
 272     w_gsl_monte_function.C_gsl_monte_function.f = &call_gsl_monte_function;
 273     w_gsl_monte_function.C_gsl_monte_function.dim = C_dim;
 274     w_gsl_monte_function.C_gsl_monte_function.params   = &w_gsl_monte_function;
 275     $1         = &w_gsl_monte_function.C_gsl_monte_function;
 276 };
 277
 278 %typemap(in) gsl_function * (struct gsl_function_perl w_gsl_function) {
 279     SV * function = 0;
 280     SV * params = 0;
 281
 282     if (SvROK($input) && (SvTYPE(SvRV($input)) == SVt_PVAV)) {
 283         AV* array=(AV*)SvRV($input);
 284         SV ** p_function = 0;
 285         if (av_len(array)<0) {
 286             croak("Math::GSL : $$1_name is an empty array!");
 287         }
 288         if (av_len(array)>1) {
 289             croak("Math::GSL : $$1_name is an array with more than 2 elements!");
 290         }
 291         p_function = av_fetch(array, 0, 0);
 292         function = *p_function;
 293         if (av_len(array)>0) {
 294             SV ** p_params = 0;
 295             p_params = av_fetch(array, 1, 0);
 296             params = *p_params;
 297         }
 298     } else {
 299         function = $input;
 300     }
 301
 302     if (!function || !(SvPOK(function) || (SvROK(function) && (SvTYPE(SvRV(function)) == SVt_PVCV)))) {
 303         croak("Math::GSL : $$1_name is not a reference to code!");
 304     }
 305
 306     function = newSVsv(function);
 307
 308     if (! params) {
 309         params=&PL_sv_undef;
 310     }
 311     params = newSVsv(params);
 312
 313     w_gsl_function.params = params;
 314     w_gsl_function.function = function;
 315     w_gsl_function.C_gsl_function.params   = &w_gsl_function;
 316     w_gsl_function.C_gsl_function.function = &call_gsl_function;
 317     $1         = &w_gsl_function.C_gsl_function;
 318 };
 319
 320 %typemap(freearg) gsl_monte_function * {
 321     struct gsl_monte_function_perl *p=(struct gsl_monte_function_perl *) $1->params;
 322     SvREFCNT_dec(p->f);
 323     SvREFCNT_dec(p->dim);
 324     SvREFCNT_dec(p->params);
 325 };
 326
 327 %typemap(freearg) gsl_function * {
 328     struct gsl_function_perl *p=(struct gsl_function_perl *) $1->params;
 329     SvREFCNT_dec(p->function);
 330     SvREFCNT_dec(p->params);
 331 };
 332
 333 /* TODO: same thing should be done for these kinds of callbacks */
 334 %typemap(in) gsl_function_fdf * {
 335     fprintf(stderr, 'FDF_FUNC');
 336     return GSL_NAN;
 337 }