swig/nlopt-guile.i

   1 // -*- C++ -*-
   2
   3 %{
   4 // work around obsolete stuff used by swig guile
   5 #if SCM_MAJOR_VERSION >= 2
   6 #  define gh_symbol2scm scm_from_latin1_symbol
   7 #else
   8 #  define gh_symbol2scm scm_str2symbol
   9 #endif
  10 %}
  11
  12 %typemap(throws) std::runtime_error %{
  13   scm_throw(gh_symbol2scm("runtime-error"),
  14             scm_list_1(scm_from_locale_string(($1).what())));
  15 %}
  16
  17 %typemap(throws) std::bad_alloc %{
  18   scm_throw(gh_symbol2scm("bad-alloc"),
  19             scm_list_1(scm_from_locale_string(($1).what())));
  20 %}
  21
  22 %typemap(throws) std::invalid_argument %{
  23   scm_throw(gh_symbol2scm("invalid-argument"),
  24             scm_list_1(scm_from_locale_string(($1).what())));
  25 %}
  26
  27 %typemap(throws) nlopt::forced_stop %{
  28   scm_throw(gh_symbol2scm("forced-stop"), SCM_EOL);
  29 %}
  30
  31 %typemap(throws) nlopt::roundoff_limited %{
  32   scm_throw(gh_symbol2scm("roundoff-limited"), SCM_EOL);
  33 %}
  34
  35 %{
  36 // because our f_data pointer to the Scheme function is stored on the
  37 // heap, rather than the stack, it may be missed by the Guile garbage
  38 // collection and be accidentally freed.  Hence, use NLopts munge
  39 // feature to prevent this, by incrementing Guile's reference count.
  40 static void *free_guilefunc(void *p) {
  41   scm_gc_unprotect_object((SCM) p); return p; }
  42 static void *dup_guilefunc(void *p) {
  43   scm_gc_protect_object((SCM) p); return p; }
  44
  45 // func wrapper around Guile function val = f(x, grad)
  46 static double func_guile(unsigned n, const double *x, double *grad, void *f) {
  47   SCM xscm = scm_c_make_vector(n, SCM_UNSPECIFIED);
  48   for (unsigned i = 0; i < n; ++i)
  49     SCM_SIMPLE_VECTOR_SET(xscm, i, scm_make_real(x[i]));
  50   SCM grad_scm = grad ? scm_c_make_vector(n, SCM_UNSPECIFIED) : SCM_BOOL_F;
  51   SCM ret = scm_call_2((SCM) f, xscm, grad_scm);
  52   if (!scm_real_p(ret))
  53     throw std::invalid_argument("invalid result passed to nlopt");
  54   if (grad) {
  55     for (unsigned i = 0; i < n; ++i) {
  56       if (!scm_real_p(ret))
  57         throw std::invalid_argument("invalid gradient passed to nlopt");
  58       grad[i] = scm_to_double(SCM_SIMPLE_VECTOR_REF(grad_scm, i));
  59     }
  60   }
  61   return scm_to_double(ret);
  62 }
  63 %}
  64
  65 %typemap(in)(nlopt::func f, void *f_data, nlopt_munge md, nlopt_munge mc) {
  66   $1 = func_guile;
  67   $2 = dup_guilefunc((void*) $input); // input = SCM pointer to Scheme function
  68   $3 = free_guilefunc;
  69   $4 = dup_guilefunc;
  70 }
  71 %typecheck(SWIG_TYPECHECK_POINTER)(nlopt::func f, void *f_data, nlopt_munge md, nlopt_munge mc) {
  72   $1 = SCM_NFALSEP(scm_procedure_p($input));
  73 }
  74
  75 // export constants as variables, rather than as functions returning the value
  76 %feature("constasvar", "1");
  77
  78 %scheme %{
  79 (load-extension "libnlopt@NLOPT_SUFFIX@_guile.so" "SWIG_init")
  80 %}