]> git.donarmstrong.com Git - lilypond.git/commitdiff
Issue 4357/4: Reimplement Listener around generic SCM callback and instance
authorDavid Kastrup <dak@gnu.org>
Tue, 28 Apr 2015 09:19:23 +0000 (11:19 +0200)
committerDavid Kastrup <dak@gnu.org>
Tue, 12 May 2015 12:25:47 +0000 (14:25 +0200)
lily/global-context.cc
lily/include/listener.hh
lily/include/smobs.hh
lily/listener.cc
lily/scheme-engraver.cc
lily/scheme-listener-scheme.cc
lily/smobs.cc

index 9125a7e07ef2e53796e6246aa82c2fae454c4da9..b9afbd7671d51ee680030f14dcf40cb8bdd6586c 100644 (file)
@@ -40,7 +40,7 @@ Global_context::Global_context (Output_def *o)
   prev_mom_.set_infinite (-1);
 
   /* We only need the most basic stuff to bootstrap the context tree */
-  event_source ()->add_listener (GET_LISTENER (create_context_from_event),
+  event_source ()->add_listener (GET_LISTENER (Context, create_context_from_event),
                                  ly_symbol2scm ("CreateContext"));
   event_source ()->add_listener (GET_LISTENER (Global_context, prepare),
                                  ly_symbol2scm ("Prepare"));
index 24407e2939f1dc2859ca3949c2c161bda886563a..a5c0c98bdde447717d8fabe4c95f00dd8ee3bf76 100644 (file)
 /*
   Listeners
 
-  Listeners are used for stream event dispatching. If you want to
-  register a method as an event handler in a dispatcher, then you
-  must:
+  Listeners are used for stream event dispatching.  The usual way to
+  work with them is to use the GET_LISTENER macro which combines the
+  basic Listener algorithm with a Callback_wrapper structure providing
+  a Scheme handle into a member function.
 
-  - declare the method using the DECLARE_LISTENER macro.
+  To register a member function of Foo as an event handler in a
+  dispatcher, you must:
+
+  - declare the function:
   class Foo
   {
     void method (SCM);
     ...
   };
-  This macro declares the method to take a SCM as parameter, and to
-    return void. It also declares some other stuff that shouldn't be
-    touched.
 
-  - implement the method using IMPLEMENT_LISTENER:
-  void method (SCM e)
+  - implement the method::
+  void Foo::method (SCM e)
   {
     write ("Foo hears an event!");
   }
 
-  - Extract a listener using GET_LISTENER (Foo->method)
+  - Extract a listener using GET_LISTENER (Foomethod)
   - Register the method to the dispatcher using Dispatcher::register
 
   Example:
 
   Foo *foo = (...);
-  Stream_distributor *d = (...);
+  Dispatcher *d = (...);
   Listener l = foo->GET_LISTENER (Foo, method);
-  d->register_listener (l, "EventClass");
+  d->add_listener (l, ly_symbol2scm ("EventClass"));
 
   Whenever d hears a stream-event ev of class "EventClass",
   the implemented procedure is called.
 
+  GET_LISTENER actually makes use of a member function
+  get_listener (SCM) available in every Smob<...>-derived class.
+  get_listener receives a function getting an object instance and an
+  event and will turn it into a Listener that will (after turning into
+  Scheme), behave as a function receiving an event as its sole
+  argument, with the object instance being the object from which
+  get_listener was called as a member.
+
+  So (p->get_listener (f)).smobbed_copy () is roughly equivalent to
+  (lambda (ev) (f p->self_scm() ev))
+
   Limitations:
-  - DECLARE_LISTENER currently only works inside smob classes.
+
+  The Callback_wrapper mechanism used in GET_LISTENER works only for
+  classes derived from Smob<...>.
 */
 
 #include "smobs.hh"
 
-typedef struct
-{
-  void (*listen_callback) (void *, SCM);
-  void (*mark_callback) (void *);
-  bool (*equal_callback) (void *, void *);
-} Listener_function_table;
+// A listener is essentially any procedure accepting a single argument
+// (namely an event).  The class Listener (or rather a smobbed_copy of
+// it) behaves like such a procedure and is composed of a generic
+// callback function accepting two arguments, namely a "target"
+// (usually an engraver instance) and the event.  Its Scheme
+// equivalent would be
+//
+// (define (make-listener callback target)
+//   (lambda (event) (callback target event)))
+//
+// The class construction is lightweight: as a Simple_smob, this is
+// only converted into Scheme when a smobbed_copy is created.
 
 class Listener : public Simple_smob<Listener>
 {
-public:
-  static SCM equal_p (SCM, SCM);
-  SCM mark_smob ();
-  static const char type_p_name_[];
 private:
-  void *target_;
-  Listener_function_table *type_;
+  SCM callback_;
+  SCM target_;
 public:
-  Listener (const void *target, Listener_function_table *type);
-  Listener (Listener const &other);
-  Listener ();
+  static const char type_p_name_[];
+
+  Listener (SCM callback, SCM target)
+    : callback_ (callback), target_ (target) { }
 
-  void listen (SCM ev) const;
+  void listen (SCM ev) const { scm_call_2 (callback_, target_, ev); }
 
   LY_DECLARE_SMOB_PROC (1, 0, 0, (SCM self, SCM ev))
   {
@@ -91,49 +108,82 @@ public:
     return SCM_UNSPECIFIED;
   }
 
+  SCM mark_smob ()
+  {
+    scm_gc_mark (callback_);
+    return target_;
+  }
+
   bool operator == (Listener const &other) const
   {
-    return type_ == other.type_
-           && (*type_->equal_callback) ((void *) target_, (void *) other.target_);
+    return scm_is_eq (callback_, other.callback_)
+      && scm_is_eq (target_, other.target_);
   }
 
+  static SCM equal_p (SCM a, SCM b)
+  {
+    return *Listener::unsmob (a) == *Listener::unsmob (b)
+      ? SCM_BOOL_T : SCM_BOOL_F;
+  }
+};
+
+// A callback wrapper creates a Scheme-callable version of a
+// non-static class member function callback which you can call with a
+// class instance and an event.
+//
+// If you have a class member function
+// void T::my_listen (SCM ev)
+// then Callback_wrapper::make_smob<&T::my_listen> ()
+// will return an SCM function roughly defined as
+// (lambda (target ev) (target->my_listen ev))
+//
+// The setup is slightly tricky since the make_smob quasi-constructor
+// call is a template function templated on the given callback, and so
+// is the trampoline it uses for redirecting the callback.  The class
+// itself, however, is not templated as that would create a wagonload
+// of SCM types.
+
+class Callback_wrapper : public Simple_smob<Callback_wrapper>
+{
+  // We use an ordinary function pointer pointing to a trampoline
+  // function (templated on the callback in question) instead of
+  // storing a member function pointer to a common base class like
+  // Smob_core.  The additional code for the trampolines is negligible
+  // and the performance implications of using member function
+  // pointers in connection with inheritance are somewhat opaque as
+  // this involves an adjustment of the this pointer from Smob_core to
+  // the scope containing the callback.
+  void (*trampoline_) (SCM, SCM);
+  template <class T, void (T::*callback)(SCM)>
+  static void trampoline (SCM target, SCM ev)
+  {
+    T *t = derived_unsmob<T> (target);
+    LY_ASSERT_DERIVED_SMOB (T, target, 1);
+
+    (t->*callback) (ev);
+  }
+
+  Callback_wrapper (void (*trampoline) (SCM, SCM)) : trampoline_ (trampoline)
+  { } // Private constructor, use only in make_smob
+public:
+  LY_DECLARE_SMOB_PROC (2, 0, 0, (SCM self, SCM target, SCM ev))
+  {
+    unsmob (self)->trampoline_ (target, ev);
+    return SCM_UNSPECIFIED;
+  }
+  // Callback wrappers are for an unchanging entity, so we do the Lisp
+  // creation just once on the first call of make_smob.  So we only
+  // get a single Callback_wrapper instance for each differently
+  // templated make_smob call.
+  template <class T, void (T::*callback)(SCM)>
+  static SCM make_smob ()
+  {
+    static SCM res = scm_permanent_object
+      (Callback_wrapper (trampoline<T, callback>).smobbed_copy ());
+    return res;
+  }
 };
 
-#define IMPLEMENT_LISTENER(cl, method)                  \
-void                                                    \
-cl :: method ## _callback (void *self, SCM ev)          \
-{                                                       \
-  cl *s = (cl *)self;                                   \
-  s->method (ev);                                       \
-}                                                       \
-void                                                    \
-cl :: method ## _mark (void *self)                      \
-{                                                       \
-  cl *s = (cl *)self;                                   \
-  scm_gc_mark (s->self_scm ());                         \
-}                                                       \
-bool                                                    \
-cl :: method ## _is_equal (void *a, void *b)            \
-{                                                       \
-  return a == b;                                        \
-}                                                       \
-Listener                                                \
-cl :: method ## _listener () const                      \
-{                                                       \
-  static Listener_function_table callbacks;             \
-  callbacks.listen_callback = &cl::method ## _callback; \
-  callbacks.mark_callback = &cl::method ## _mark;       \
-  callbacks.equal_callback = &cl::method ## _is_equal;  \
-  return Listener (this, &callbacks);                   \
-}
-
-#define GET_LISTENER(proc) proc ## _listener ()
-
-#define DECLARE_LISTENER(name)                          \
-  inline void name (SCM);                               \
-  static void name ## _callback (void *self, SCM ev);   \
-  static void name ## _mark (void *self);               \
-  static bool name ## _is_equal (void *a, void *b);     \
-  Listener name ## _listener () const
+#define GET_LISTENER(cl, proc) get_listener (Callback_wrapper::make_smob<cl, &cl::proc> ())
 
 #endif /* LISTENER_HH */
index 62eefeb2cec3c3825dd08da36afefcadd324941a..eb8bb482f002b127bdd3090bd604f2fdaa86ee8c 100644 (file)
@@ -21,6 +21,7 @@
 #define SMOBS_HH
 
 #include "lily-guile.hh"
+#include "lily-proto.hh"
 #include "warn.hh"
 #include <string>
 
@@ -270,6 +271,7 @@ protected:
   Smob_core () : self_scm_ (SCM_UNDEFINED) { };
 public:
   SCM self_scm () const { return self_scm_; }
+  Listener get_listener (SCM callback);
 };
 
 template <class Super>
index 50f1969ecb418c4735715fc8c77bf9f08963b080..2a8d28d8cbb6daa0d287eeccded86624f75fbb9d 100644 (file)
 */
 
 #include "listener.hh"
-#include "warn.hh"
-
-Listener::Listener ()
-{
-  target_ = 0;
-  type_ = 0;
-}
-
-Listener::Listener (const void *target, Listener_function_table *type)
-{
-  target_ = (void *)target;
-  type_ = type;
-}
-
-Listener::Listener (Listener const &other)
-{
-  target_ = other.target_;
-  type_ = other.type_;
-}
-
-void Listener::listen (SCM ev) const
-{
-  (type_->listen_callback) (target_, ev);
-}
-
-SCM
-Listener::mark_smob ()
-{
-  if (type_)
-    (type_->mark_callback) (target_);
-  return SCM_EOL;
-}
-
-SCM
-Listener::equal_p (SCM a, SCM b)
-{
-  Listener *l1 = Listener::unsmob (a);
-  Listener *l2 = Listener::unsmob (b);
-
-  return (*l1 == *l2) ? SCM_BOOL_T : SCM_BOOL_F;
-}
 
 const char Listener::type_p_name_[] = "ly:listener?";
index 8d2054161bf716b577c4f4a4c61442cbd584cd13..5ab14ce414a7d896ecb3b10b3658100ce0c02de7 100644 (file)
@@ -171,36 +171,6 @@ Scheme_engraver::acknowledge_grob_by_hash (Grob_info info,
     }
 }
 
-static
-void call_listen_closure (void *target, SCM ev)
-{
-  SCM cl = (SCM) target;
-  SCM func = scm_car (cl);
-  SCM engraver = scm_cdr (cl);
-  scm_call_2 (func, engraver, ev);
-}
-
-static
-void mark_listen_closure (void *target)
-{
-  scm_gc_mark ((SCM)target);
-}
-
-static
-bool equal_listen_closure (void *a, void *b)
-{
-  SCM target_a = (SCM) a;
-  SCM target_b = (SCM) b;
-
-  return ly_is_equal (target_a, target_b);
-}
-
-Listener_function_table listen_closure
-=
-{
-  call_listen_closure, mark_listen_closure, equal_listen_closure
-};
-
 /* static */
 Listener
 Scheme_engraver::get_listener (void *arg, SCM name)
@@ -209,8 +179,7 @@ Scheme_engraver::get_listener (void *arg, SCM name)
   SCM func = ly_assoc_get (name, me->listeners_alist_, SCM_BOOL_F);
   assert (ly_is_procedure (func));
 
-  SCM closure = scm_cons (func, me->self_scm ());
-  return Listener ((void *)closure, &listen_closure);
+  return me->get_listener (func);
 }
 
 translator_listener_record *
index 8a3930c6fb230a433026c5325ec7d73ee5a826ec..730c075c59b572d1e5980ff79d1956579b1f4bda 100644 (file)
@@ -28,7 +28,7 @@ LY_DEFINE (ly_make_listener, "ly:make-listener",
 {
   LY_ASSERT_TYPE (ly_is_procedure, callback, 1);
   Scheme_listener *l = new Scheme_listener (callback);
-  SCM listener = GET_LISTENER (l->call).smobbed_copy ();
+  SCM listener = l->GET_LISTENER (Scheme_listener, call).smobbed_copy ();
   l->unprotect ();
   return listener;
 }
index d36c9be7dc6f6ec560839c6c0b1c8c64c5941739..c700ea0d9b0f0a81d7e3f5d40774f5a85236b756 100644 (file)
 */
 
 #include "smobs.hh"
+#include "listener.hh"
+
+Listener
+Smob_core::get_listener (SCM callback)
+{
+  return Listener (callback, self_scm ());
+}
 
 /*
   The CDR contains the actual protected list.