return SCM_UNDEFINED;
}
+LY_DEFINE (ly_listened_event_types, "ly:listened-event-types",
+ 1, 0, 0, (SCM disp),
+ "Return a list of all event types that @var{disp} listens"
+ " to.")
+{
+ LY_ASSERT_SMOB (Dispatcher, disp, 1);
+
+ SCM result = unsmob_dispatcher (disp)->listened_types ();
+
+ scm_remember_upto_here_1 (disp);
+
+ return result;
+}
+
+LY_DEFINE (ly_listened_event_class_p, "ly:listened-event-class?",
+ 2, 0, 0, (SCM disp, SCM cl),
+ "Does @var{disp} listen to any event type in the list"
+ " @var{cl}?")
+{
+ LY_ASSERT_SMOB (Dispatcher, disp, 1);
+ LY_ASSERT_TYPE (scm_is_pair, cl, 2);
+
+ bool result = unsmob_dispatcher (disp)->is_listened_class (cl);
+
+ scm_remember_upto_here_1 (disp);
+
+ return scm_from_bool (result);
+}
+
+
LY_DEFINE (ly_broadcast, "ly:broadcast",
2, 0, 0, (SCM disp, SCM ev),
"Send the stream event @var{ev} to the dispatcher @var{disp}.")
}
bool
-Dispatcher::is_listened (Stream_event *ev)
+Dispatcher::is_listened_class (SCM cl)
{
- for (SCM cl = ev->get_property ("class"); scm_is_pair (cl); cl = scm_cdr (cl))
+ for (; scm_is_pair (cl); cl = scm_cdr (cl))
{
SCM list = scm_hashq_ref (listeners_, scm_car (cl), SCM_EOL);
if (scm_is_pair (list))
return false;
}
+static SCM
+accumulate_types (void * /* closure */,
+ SCM key,
+ SCM val,
+ SCM result)
+{
+ if (scm_is_pair (val))
+ return scm_cons (key, result);
+ return result;
+}
+
+SCM
+Dispatcher::listened_types ()
+{
+ return scm_internal_hash_fold ((scm_t_hash_fold_fn) &accumulate_types,
+ NULL, SCM_EOL, listeners_);
+}
void
Dispatcher::broadcast (Stream_event *ev)
public:
Dispatcher ();
void broadcast (Stream_event *ev);
- bool is_listened (Stream_event *ev);
+ bool is_listened_class (SCM);
+ SCM listened_types ();
void add_listener (Listener, SCM event_class);
void remove_listener (Listener, SCM event_class);
void register_as_listener (Dispatcher *dist);
static void _ ## T ## _adder () \
{ \
T *t = new T; \
- T::static_description_ = t->static_translator_description (); \
- scm_permanent_object (T::static_description_); \
+ T::static_description_ = \
+ scm_permanent_object (t->static_translator_description ()); \
add_translator (t); \
} \
SCM T::translator_description () const \
{
SCM art = scm_car (arts);
- if (c->event_source ()->is_listened (unsmob_stream_event (art)))
+ if (c->event_source ()->is_listened_class
+ (unsmob_stream_event (art)->get_property ("class")))
listened = scm_cons (art, listened);
else
unlistened = scm_cons (art, unlistened);
r->event_class_);
}
-static SCM listened_event_class_table;
-void
-ensure_listened_hash ()
-{
- if (!listened_event_class_table)
- listened_event_class_table = scm_permanent_object (scm_c_make_hash_table (61));
-}
-
-LY_DEFINE (ly_get_listened_event_classes, "ly:get-listened-event-classes",
- 0, 0, 0, (),
- "Return a list of all event classes that some translator listens"
- " to.")
-{
- ensure_listened_hash ();
- return ly_hash_table_keys (listened_event_class_table);
-}
-
-LY_DEFINE (ly_is_listened_event_class, "ly:is-listened-event-class",
- 1, 0, 0, (SCM sym),
- "Is @var{sym} a listened event class?")
-{
- ensure_listened_hash ();
- return scm_hashq_ref (listened_event_class_table, sym, SCM_BOOL_F);
-}
-
-void
-add_listened_event_class (SCM sym)
-{
- ensure_listened_hash ();
- scm_hashq_set_x (listened_event_class_table, sym, SCM_BOOL_T);
-}
-
/*
internally called once, statically, for each translator
listener. Connects the name of an event class with a procedure that
name = replace_all (&name, '_', '-');
name += "-event";
- SCM class_sym = scm_from_locale_symbol (name.c_str ());
+ // we make the symbol permanent in order not to have to bother about
+ // the static translator_listener_record chains while garbage
+ // collecting.
- add_listened_event_class (class_sym);
+ SCM class_sym = scm_permanent_object (scm_from_locale_symbol (name.c_str ()));
r->event_class_ = class_sym;
r->get_listener_ = get_listener;
(cons root (map expand-event-tree (cdr children)))
root)))
-;; All leaf event classes that no translator listens to
-;; directly. Avoids printing a warning.
-(define unlistened-music-event-classes
- '(harmonic-event line-break-event page-break-event page-turn-event label-event
- solo-one-event solo-two-event skip-event unisono-event
- part-combine-force-event break-dynamic-span-event
- stroke-finger-event))
-
;; produce neater representation of music event tree.
;; TODO: switch to this representation for the event-classes list?
(define music-event-tree (expand-event-tree 'music-event))
;;(use-modules (ice-9 pretty-print))
;;(pretty-print (cons (car music-event-tree) (sort-tree (cdr music-event-tree))))
-;; check that the music event tree corresponds well with the set of
-;; available translators; print warnings otherwise.
-(map-tree (lambda (sym)
- (if (and (symbol? sym)
- (not (ly:is-listened-event-class sym))
- (not (assq sym event-classes))
- (not (memq sym unlistened-music-event-classes)))
- (ly:programming-error (_ "event class ~A seems to be unused") sym)))
- music-event-tree)
-
-(map (lambda (sym)
- (if (not (pair? (ly:make-event-class sym)))
- ;; should be programming-error
- (ly:error (_ "translator listens to nonexisting event class ~A") sym)))
- (ly:get-listened-event-classes))
-
(defmacro-public make-stream-event (expr)
(Stream_event::undump (primitive-eval (list 'quasiquote expr))))