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
  36 %typemap(freearg) double const [] {
  37         if ($1) free($1);
  38 }
  39
  40 %apply double const [] {
  41     double *data, double *dest, double *f_in, double *f_out,
  42     double data[], const double * src, double x[], double a[], double b[],
  43     const double * x, const double * y, const double * w , const double x_array[],
  44     const double xrange[], const double yrange[], double * base,
  45     const double * base, const double xrange[], const double yrange[] ,
  46     const double * array , const double data2[], const double w[] ,
  47     double *v,
  48     gsl_complex_packed_array data
  49 };
  50
  51 /*****************************
  52  * handle 'float const []' as an input array of floats
  53  * We allocate the C array at the begining and free it at the end
  54  */
  55 %typemap(in) float const [] {
  56     AV *tempav;
  57     I32 len;
  58     int i;
  59     SV **tv;
  60     if (!SvROK($input))
  61         croak("Math::GSL : $$1_name is not a reference!");
  62     if (SvTYPE(SvRV($input)) != SVt_PVAV)
  63         croak("Math::GSL : $$1_name is not an array ref!");
  64
  65     tempav = (AV*)SvRV($input);
  66     len = av_len(tempav);
  67     $1 = (float *) malloc((len+1)*sizeof(float));
  68     for (i = 0; i <= len; i++) {
  69         tv = av_fetch(tempav, i, 0);
  70         $1[i] = (float)(double) SvNV(*tv);
  71     }
  72 }
  73
  74 %typemap(freearg) float const [] {
  75         if ($1) free($1);
  76 }
  77
  78 %apply float const [] {
  79     float const *A, float const *B, float const *C
  80 };
  81
  82 /*****************************
  83  * handle 'float []' as an in/out array of floats
  84  * We allocate the C array at the begining and free it at the end
  85  * We modify the perl array IN PLACE (not sure other langage can do that
  86  *   but perl can)
  87  * Note the trick to store some private info before the C array
  88  * as swig require that $1 points to the C array (as it uses it
  89  * when calling the gsl function)
  90  */
  91 %{
  92     struct perl_array {
  93         I32 len;
  94         AV *array;
  95     };
  96 %}
  97
  98 %typemap(in) float [] {
  99     struct perl_array * p_array = 0;
 100     I32 len;
 101     AV *array;
 102     int i;
 103     SV **tv;
 104     if (!SvROK($input))
 105         croak("Math::GSL : $$1_name is not a reference!");
 106     if (SvTYPE(SvRV($input)) != SVt_PVAV)
 107         croak("Math::GSL : $$1_name is not an array ref!");
 108
 109     array = (AV*)SvRV($input);
 110     len = av_len(array);
 111     p_array = (struct perl_array *) malloc((len+1)*sizeof(float)+sizeof(struct perl_array));
 112     p_array->len=len;
 113     p_array->array=array;
 114     $1 = (float *)&p_array[1];
 115     for (i = 0; i <= len; i++) {
 116         tv = av_fetch(array, i, 0);
 117         $1[i] = (float)(double) SvNV(*tv);
 118     }
 119 }
 120
 121 %typemap(argout) float [] {
 122     struct perl_array * p_array = 0;
 123     int i;
 124     SV **tv;
 125     p_array=(struct perl_array *)(((char*)$1)-sizeof(struct perl_array));
 126     for (i = 0; i <= p_array->len; i++) {
 127         double val=(double)(float)($1[i]);
 128         tv = av_fetch(p_array->array, i, 0);
 129         sv_setnv(*tv, val);
 130         if (argvi >= items) {
 131             EXTEND(sp,1);              /* Extend the stack by 1 object */
 132         }
 133         $result = sv_newmortal();
 134         sv_setnv($result, val);
 135         argvi++;
 136     }
 137 }
 138
 139 %typemap(freearg) float [] {
 140     if ($1) free(((char*)$1)-sizeof(struct perl_array));
 141 }
 142
 143 %apply float const [] {
 144     float *C
 145 };
 146
 147 /*****************************
 148  * handle 'size_t const []' as an input array of size_t
 149  * We allocate the C array at the begining and free it at the end
 150  */
 151 %typemap(in) size_t const [] {
 152     AV *tempav;
 153     I32 len;
 154     int i;
 155     SV **tv;
 156     if (!SvROK($input))
 157         croak("Math::GSL : $$1_name is not a reference!");
 158     if (SvTYPE(SvRV($input)) != SVt_PVAV)
 159         croak("Math::GSL : $$1_name is not an array ref!");
 160
 161     tempav = (AV*)SvRV($input);
 162     len = av_len(tempav);
 163     $1 = (size_t *) malloc((len+1)*sizeof(size_t));
 164     for (i = 0; i <= len; i++) {
 165         tv = av_fetch(tempav, i, 0);
 166         $1[i] = SvIV(*tv);
 167     }
 168 }
 169
 170 %typemap(freearg) size_t const [] {
 171         if ($1) free($1);
 172 }
 173
 174 %apply double const [] {
 175     double *data, double *dest, double *f_in, double *f_out,
 176     double data[], const double * src, double x[], double a[], double b[],
 177     double xu[], double xl[],
 178     const double * x, const double * y, const double * w , const double x_array[],
 179     const double xrange[], const double yrange[], double * base,
 180     const double * base, const double xrange[], const double yrange[] ,
 181     const double * array , const double data2[], const double w[] ,
 182     double *v,
 183     gsl_complex_packed_array data
 184 };
 185
 186 %apply float const [] {
 187     float const *A, float const *B, float const *C, float *C
 188 };
 189
 190 %apply size_t const [] {
 191     size_t *p
 192 }
 193
 194 /*****************************
 195  * handle some parameters as input or output
 196  */
 197 %apply int *OUTPUT { size_t *imin, size_t *imax, size_t *neval };
 198 %apply double * OUTPUT {
 199     double * min_out, double * max_out,
 200     double *abserr, double *result
 201 };
 202
 203 /*****************************
 204  * Callback managment
 205  */
 206 %{
 207     /* structure to hold required information while the gsl function call
 208        for each callback
 209      */
 210     struct gsl_function_perl {
 211         gsl_function C_gsl_function;
 212         SV * function;
 213         SV * params;
 214     };
 215     struct gsl_monte_function_perl {
 216         gsl_monte_function C_gsl_monte_function;
 217         SV * f;
 218         SV * dim;
 219         SV * params;
 220     };
 221
 222
 223     /* These functions (C callbacks) calls the perl callbacks.
 224        Info for perl callback can be found using the 'void*params' parameter
 225     */
 226     double call_gsl_function(double x , void *params){
 227         struct gsl_function_perl *F=(struct gsl_function_perl*)params;
 228         unsigned int count;
 229         double y;
 230         dSP;
 231
 232         //fprintf(stderr, "LOOKUP CALLBACK\n");
 233         ENTER;
 234         SAVETMPS;
 235
 236         PUSHMARK(SP);
 237         XPUSHs(sv_2mortal(newSVnv((double)x)));
 238         XPUSHs(F->params);
 239         PUTBACK;                                /* make local stack pointer global */
 240
 241         count = call_sv(F->function, G_SCALAR);
 242         SPAGAIN;
 243
 244         if (count != 1)
 245                 croak("Expected to call subroutine in scalar context!");
 246
 247         y = POPn;
 248
 249         PUTBACK;                                /* make local stack pointer global */
 250         FREETMPS;
 251         LEAVE;
 252
 253         return y;
 254     }
 255     double call_gsl_monte_function(double *x_array , size_t dim, void *params){
 256         struct gsl_monte_function_perl *F=(struct gsl_monte_function_perl*)params;
 257         unsigned int count;
 258         unsigned int i;
 259         AV* perl_array;
 260         double y;
 261         dSP;
 262
 263         //fprintf(stderr, "LOOKUP CALLBACK\n");
 264         ENTER;
 265         SAVETMPS;
 266
 267         PUSHMARK(SP);
 268         perl_array=newAV();
 269         sv_2mortal((SV*)perl_array);
 270         XPUSHs(sv_2mortal(newRV((SV *)perl_array)));
 271         for(i=0; i<dim; i++) {
 272                 /* no mortal : it is referenced by the array */
 273                 av_push(perl_array, newSVnv(x_array[i]));
 274         }
 275         XPUSHs(sv_2mortal(newSViv(dim)));
 276         XPUSHs(F->params);
 277         PUTBACK;                                /* make local stack pointer global */
 278
 279         count = call_sv(F->f, G_SCALAR);
 280         SPAGAIN;
 281
 282         if (count != 1)
 283                 croak("Expected to call subroutine in scalar context!");
 284
 285         y = POPn;
 286
 287         PUTBACK;                                /* make local stack pointer global */
 288         FREETMPS;
 289         LEAVE;
 290
 291         return y;
 292     }
 293 %}
 294
 295 %typemap(in) gsl_monte_function * (struct gsl_monte_function_perl w_gsl_monte_function) {
 296     SV * f = 0;
 297     SV * dim = 0;
 298     SV * params = 0;
 299     size_t C_dim;
 300
 301     if (SvROK($input) && (SvTYPE(SvRV($input)) == SVt_PVAV)) {
 302         AV* array=(AV*)SvRV($input);
 303         SV ** p_f = 0;
 304         if (av_len(array)<0) {
 305             croak("Math::GSL : $$1_name is an empty array!");
 306         }
 307         if (av_len(array)>2) {
 308             croak("Math::GSL : $$1_name is an array with more than 3 elements!");
 309         }
 310         p_f = av_fetch(array, 0, 0);
 311         f = *p_f;
 312         if (av_len(array)>0) {
 313             SV ** p_dim = 0;
 314             p_dim = av_fetch(array, 1, 0);
 315             dim = *p_dim;
 316         }
 317         if (av_len(array)>1) {
 318             SV ** p_params = 0;
 319             p_params = av_fetch(array, 1, 0);
 320             params = *p_params;
 321         }
 322     } else {
 323         f = $input;
 324     }
 325
 326     if (!f || !(SvPOK(f) || (SvROK(f) && (SvTYPE(SvRV(f)) == SVt_PVCV)))) {
 327         croak("Math::GSL : $$1_name is not a reference to code!");
 328     }
 329
 330     f = newSVsv(f);
 331
 332     if (! dim) {
 333         dim=&PL_sv_undef;
 334         C_dim=0;
 335     } else {
 336         if (!SvIOK(dim)) {
 337             croak("Math::GSL : $$1_name is not an integer for dim!");
 338         }
 339         C_dim=SvIV(dim);
 340     }
 341     dim = newSVsv(dim);
 342
 343     if (! params) {
 344         params=&PL_sv_undef;
 345     }
 346     params = newSVsv(params);
 347
 348     w_gsl_monte_function.f = f;
 349     w_gsl_monte_function.dim = dim;
 350     w_gsl_monte_function.params = params;
 351     w_gsl_monte_function.C_gsl_monte_function.f = &call_gsl_monte_function;
 352     w_gsl_monte_function.C_gsl_monte_function.dim = C_dim;
 353     w_gsl_monte_function.C_gsl_monte_function.params   = &w_gsl_monte_function;
 354     $1         = &w_gsl_monte_function.C_gsl_monte_function;
 355 };
 356
 357 %typemap(in) gsl_function * (struct gsl_function_perl w_gsl_function) {
 358     SV * function = 0;
 359     SV * params = 0;
 360
 361     if (SvROK($input) && (SvTYPE(SvRV($input)) == SVt_PVAV)) {
 362         AV* array=(AV*)SvRV($input);
 363         SV ** p_function = 0;
 364         if (av_len(array)<0) {
 365             croak("Math::GSL : $$1_name is an empty array!");
 366         }
 367         if (av_len(array)>1) {
 368             croak("Math::GSL : $$1_name is an array with more than 2 elements!");
 369         }
 370         p_function = av_fetch(array, 0, 0);
 371         function = *p_function;
 372         if (av_len(array)>0) {
 373             SV ** p_params = 0;
 374             p_params = av_fetch(array, 1, 0);
 375             params = *p_params;
 376         }
 377     } else {
 378         function = $input;
 379     }
 380
 381     if (!function || !(SvPOK(function) || (SvROK(function) && (SvTYPE(SvRV(function)) == SVt_PVCV)))) {
 382         croak("Math::GSL : $$1_name is not a reference to code!");
 383     }
 384
 385     function = newSVsv(function);
 386
 387     if (! params) {
 388         params=&PL_sv_undef;
 389     }
 390     params = newSVsv(params);
 391
 392     w_gsl_function.params = params;
 393     w_gsl_function.function = function;
 394     w_gsl_function.C_gsl_function.params   = &w_gsl_function;
 395     w_gsl_function.C_gsl_function.function = &call_gsl_function;
 396     $1         = &w_gsl_function.C_gsl_function;
 397 };
 398
 399 %typemap(freearg) gsl_monte_function * {
 400     struct gsl_monte_function_perl *p=(struct gsl_monte_function_perl *) $1->params;
 401     SvREFCNT_dec(p->f);
 402     SvREFCNT_dec(p->dim);
 403     SvREFCNT_dec(p->params);
 404 };
 405
 406 %typemap(freearg) gsl_function * {
 407     struct gsl_function_perl *p=(struct gsl_function_perl *) $1->params;
 408     SvREFCNT_dec(p->function);
 409     SvREFCNT_dec(p->params);
 410 };
 411
 412 /* TODO: same thing should be done for these kinds of callbacks */
 413 %typemap(in) gsl_function_fdf * {
 414     fprintf(stderr, 'FDF_FUNC');
 415     return GSL_NAN;
 416 }