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