From: David Kastrup Date: Tue, 28 Apr 2015 09:19:23 +0000 (+0200) Subject: Issue 4357/4: Reimplement Listener around generic SCM callback and instance X-Git-Tag: release/2.19.21-1~42^2 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=8aba4d8ad4cbc830dafc268ce66d4caf3798ff23;p=lilypond.git Issue 4357/4: Reimplement Listener around generic SCM callback and instance --- diff --git a/lily/global-context.cc b/lily/global-context.cc index 9125a7e07e..b9afbd7671 100644 --- a/lily/global-context.cc +++ b/lily/global-context.cc @@ -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")); diff --git a/lily/include/listener.hh b/lily/include/listener.hh index 24407e2939..a5c0c98bdd 100644 --- a/lily/include/listener.hh +++ b/lily/include/listener.hh @@ -23,67 +23,84 @@ /* 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 (Foo, method) - 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 { -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 +{ + // 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 + static void trampoline (SCM target, SCM ev) + { + T *t = derived_unsmob (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 + static SCM make_smob () + { + static SCM res = scm_permanent_object + (Callback_wrapper (trampoline).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 ()) #endif /* LISTENER_HH */ diff --git a/lily/include/smobs.hh b/lily/include/smobs.hh index 62eefeb2ce..eb8bb482f0 100644 --- a/lily/include/smobs.hh +++ b/lily/include/smobs.hh @@ -21,6 +21,7 @@ #define SMOBS_HH #include "lily-guile.hh" +#include "lily-proto.hh" #include "warn.hh" #include @@ -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 diff --git a/lily/listener.cc b/lily/listener.cc index 50f1969ecb..2a8d28d8cb 100644 --- a/lily/listener.cc +++ b/lily/listener.cc @@ -18,46 +18,5 @@ */ #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?"; diff --git a/lily/scheme-engraver.cc b/lily/scheme-engraver.cc index 8d2054161b..5ab14ce414 100644 --- a/lily/scheme-engraver.cc +++ b/lily/scheme-engraver.cc @@ -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 * diff --git a/lily/scheme-listener-scheme.cc b/lily/scheme-listener-scheme.cc index 8a3930c6fb..730c075c59 100644 --- a/lily/scheme-listener-scheme.cc +++ b/lily/scheme-listener-scheme.cc @@ -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; } diff --git a/lily/smobs.cc b/lily/smobs.cc index d36c9be7dc..c700ea0d9b 100644 --- a/lily/smobs.cc +++ b/lily/smobs.cc @@ -18,6 +18,13 @@ */ #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.