libgeda/src/scheme_closure.c

   1 /* gEDA - GPL Electronic Design Automation
   2  * libgeda - gEDA's library - Scheme API
   3  * Copyright (C) 2013 Peter Brett <peter@peter-b.co.uk>
   4  *
   5  * This program is free software; you can redistribute it and/or modify
   6  * it under the terms of the GNU General Public License as published by
   7  * the Free Software Foundation; either version 2 of the License, or
   8  * (at your option) any later version.
   9  *
  10  * This program is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13  * GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License
  16  * along with this program; if not, write to the Free Software
  17  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
  18  */
  19
  20 /*!
  21  * \file scheme_closure.c
  22  * \brief Scheme API support for C closures.
  23  */
  24
  25 #include <config.h>
  26
  27 #include "libgeda_priv.h"
  28 #include "libgedaguile_priv.h"
  29
  30 SCM_SYMBOL (lambda_sym, "lambda");
  31 SCM_SYMBOL (args_sym, "args");
  32
  33 static SCM marshal_proc;
  34
  35 /*! \brief Unpack and call a C closure
  36  *
  37  * Unpack the C function pointer and user data pointer from a C
  38  * closure \a smob, and then make a function call of the form:
  39  *
  40  * \code
  41  * func (args, user_data)
  42  * \endcode
  43  *
  44  * \param args   Scheme list of closure arguments.
  45  * \param smob   closure smob containing C function and user data.
  46  *
  47  * \return the result returned by the closure.
  48  */
  49 static SCM
  50 edascm_closure_marshal (SCM args, SCM smob) {
  51 #ifndef NDEBUG
  52   SCM_ASSERT (EDASCM_CLOSUREP (smob), smob, SCM_ARG2,
  53               "edascm_closure_marshal");
  54 #endif
  55   EDASCM_ASSERT_SMOB_VALID (smob);
  56
  57   SCM (*func)(SCM, gpointer) = (SCM (*)(SCM, gpointer)) SCM_SMOB_DATA (smob);
  58   gpointer *user_data = (gpointer) SCM_SMOB_DATA_2 (smob);
  59
  60   return func (args, user_data);
  61 }
  62
  63 /*! \brief Make a C closure.
  64  * \ingroup guile_c_iface
  65  * \par Function Description
  66  * Make and return a Scheme procedure that closes around the provided
  67  * \a func and \a user_data.
  68  *
  69  * The closure that is returned takes an arbitrary number of
  70  * arguments, and makes a function call of the form:
  71  *
  72  * \code
  73  * func (args, user_data)
  74  * \endcode
  75  *
  76  * where \a args is a Scheme list of arguments passed to the closure.
  77  *
  78  * The created closure is not protected from garbage collection;
  79  * depending on the application, it may be necessary to protect it
  80  * with scm_gc_protect_object() or scm_permanent_object().
  81  *
  82  * \param func      C function to close around.
  83  * \param user_data closure context
  84  *
  85  * \return a newly-created closure, or \c SCM_BOOL_F if an error
  86  * occurs.
  87  */
  88 SCM
  89 edascm_c_make_closure (SCM (*func)(SCM, gpointer), gpointer user_data)
  90 {
  91   SCM smob = SCM_UNDEFINED;
  92   SCM expr;
  93   SCM result;
  94   smob = edascm_from_closure (func, user_data);
  95
  96   /* (lambda args (marshal args smob)) */
  97   expr = scm_list_3 (lambda_sym, args_sym,
  98                      scm_list_3 (marshal_proc, args_sym, smob));
  99   result = g_scm_eval_protected (expr, scm_current_module ());
 100   g_warn_if_fail (scm_is_true (scm_procedure_p (result)));
 101   return result;
 102 }
 103
 104 /*!
 105  * \brief Initialise the C closure procedures.
 106  * \par Function Description
 107  * Creates some Scheme values used for creating and working with C
 108  * closures.  Should only be called by edascm_init().
 109  */
 110 void
 111 edascm_init_closure ()
 112 {
 113   /* Register functions and symbols */
 114   #include "scheme_closure.x"
 115
 116   marshal_proc =
 117     scm_permanent_object (scm_c_make_gsubr ("edascm_closure_marshal",
 118                                             2, 0, 0,
 119                                             edascm_closure_marshal));
 120 }