From ddd59edaae68e71d5d3ea2576b3d0d25807fb500 Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Thu, 31 Dec 2009 02:49:04 -0200 Subject: [PATCH] Add basic scheme programmable engravers. * input/regression/scheme-engraver.ly shows a basic example. * extend \consists syntax to accept an alist of callables. * add Scheme_engraver which is the C++ glue to the Scheme callables. * Make get_listener_ in translator_listener_record also pass the listened class, so we can use generic infrastructure for hooking scheme functions to event listeners. * add scheme bindings: - ly:translator-context - ly:context-moment - ly:engraver-make-grob * Remove Translator::must_be_last_. Use virtual method must_be_last () const instead. --- input/regression/scheme-engraver.ly | 76 +++++++++ lily/axis-group-engraver.cc | 7 +- lily/context-def.cc | 6 +- lily/context-scheme.cc | 12 ++ lily/engraver-scheme.cc | 40 +++++ lily/engraver.cc | 21 ++- lily/include/axis-group-engraver.hh | 2 + lily/include/engraver.hh | 4 +- lily/include/lily-proto.hh | 1 + lily/include/scheme-engraver.hh | 79 +++++++++ lily/include/translator.hh | 45 +++-- lily/include/translator.icc | 25 ++- lily/parser.yy | 11 ++ lily/scheme-engraver.cc | 256 ++++++++++++++++++++++++++++ lily/translator-group.cc | 30 +++- lily/translator-scheme.cc | 12 ++ lily/translator.cc | 17 +- 17 files changed, 598 insertions(+), 46 deletions(-) create mode 100644 input/regression/scheme-engraver.ly create mode 100644 lily/engraver-scheme.cc create mode 100644 lily/include/scheme-engraver.hh create mode 100644 lily/scheme-engraver.cc diff --git a/input/regression/scheme-engraver.ly b/input/regression/scheme-engraver.ly new file mode 100644 index 0000000000..ee7f3ea11e --- /dev/null +++ b/input/regression/scheme-engraver.ly @@ -0,0 +1,76 @@ +\header { + + texidoc = "\\consists can take a scheme alist as arguments, which + should be functions, which will be invoked as engraver functions." + +} + +\version "2.13.9" + +\layout { + \context { + \Voice + \consists + #(list + (cons 'initialize + (lambda (trans) + (display (list "initialize" + (ly:context-current-moment + (ly:translator-context trans)) "\n")))) + (cons 'start-translation-timestep + (lambda (trans) + (display (list "start-trans" + (ly:context-current-moment + (ly:translator-context trans)) "\n")))) + (cons 'listeners + (list + (cons 'rest-event (lambda (engraver event) + (let* + ((x (ly:engraver-make-grob engraver 'TextScript event))) + (display (list "caught event" event "\ncreate:\n" x "\n")) + (ly:grob-set-property! x 'text "hi")) + )) + )) + (cons 'acknowledgers + (list + (cons 'note-head-interface + (lambda (engraver grob source-engraver) + (display (list "saw head: " grob " coming from " source-engraver)) + )) + )) + (cons 'end-acknowledgers + (list + (cons 'beam-interface + (lambda (engraver grob source-engraver) + (display (list "saw end of beam: " grob " coming from " source-engraver)) + )) + )) + (cons 'process-music + (lambda (trans) + (display (list "process-music" + (ly:context-current-moment + (ly:translator-context trans)) "\n")))) + (cons 'process-acknowledged + (lambda (trans) + (display (list "process-acknowledged" + (ly:context-current-moment + (ly:translator-context trans)) "\n")))) + (cons 'start-translation-timestep + (lambda (trans) + (display (list "stop-trans" + (ly:context-current-moment + (ly:translator-context trans)) "\n")))) + (cons 'finalize + (lambda (trans) + (display (list "finalize" + (ly:context-current-moment + (ly:translator-context trans)) "\n")))) + ) + + }} + + +\relative { + c8[ r c] + +} diff --git a/lily/axis-group-engraver.cc b/lily/axis-group-engraver.cc index 2fb6b0c17b..aa02845d5c 100644 --- a/lily/axis-group-engraver.cc +++ b/lily/axis-group-engraver.cc @@ -30,10 +30,15 @@ Axis_group_engraver::Axis_group_engraver () { - must_be_last_ = true; staffline_ = 0; } +bool +Axis_group_engraver::must_be_last () const +{ + return true; +} + void Axis_group_engraver::process_music () { diff --git a/lily/context-def.cc b/lily/context-def.cc index 83da70df60..227bc8b3e9 100644 --- a/lily/context-def.cc +++ b/lily/context-def.cc @@ -136,11 +136,7 @@ Context_def::add_context_mod (SCM mod) else if (ly_symbol2scm ("consists") == tag || ly_symbol2scm ("remove") == tag) { - if (!get_translator (sym)) - warning (_f ("program has no such type: `%s'", - ly_symbol2string (sym).c_str ())); - else - translator_mods_ = scm_cons (scm_list_2 (tag, sym), translator_mods_); + translator_mods_ = scm_cons (scm_list_2 (tag, sym), translator_mods_); } else if (ly_symbol2scm ("accepts") == tag || ly_symbol2scm ("denies") == tag) diff --git a/lily/context-scheme.cc b/lily/context-scheme.cc index 5bc3d1d2c5..9e1b4c4f7a 100644 --- a/lily/context-scheme.cc +++ b/lily/context-scheme.cc @@ -22,6 +22,18 @@ #include "context-def.hh" #include "dispatcher.hh" +LY_DEFINE (ly_context_current_moment, + "ly:context-current-moment", + 1, 0, 0, (SCM context), + "Return the current moment of @var{context}.") +{ + Context *tr = unsmob_context (context); + + LY_ASSERT_SMOB (Context, context, 1); + + return tr->now_mom ().smobbed_copy (); +} + LY_DEFINE (ly_context_id, "ly:context-id", 1, 0, 0, (SCM context), "Return the ID string of @var{context}," diff --git a/lily/engraver-scheme.cc b/lily/engraver-scheme.cc new file mode 100644 index 0000000000..00fc5e154d --- /dev/null +++ b/lily/engraver-scheme.cc @@ -0,0 +1,40 @@ +/* + This file is part of LilyPond, the GNU music typesetter. + + Copyright (C) 1997--2009 Han-Wen Nienhuys + + LilyPond is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + LilyPond is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with LilyPond. If not, see . +*/ + +#include "engraver.hh" +#include "grob.hh" + +LY_DEFINE (ly_engraver_make_grob, "ly:engraver-make-grob", + 3, 0, 0, (SCM engraver, SCM grob_name, SCM cause), + "Creates a grob originating from given engraver instance, " + "with give @code{grob_name}, a symbol. " + "@code{cause} should either be another grob " + "or a music event.") +{ + LY_ASSERT_TYPE (unsmob_engraver, engraver, 1); + LY_ASSERT_TYPE (ly_is_symbol, grob_name, 2); + LY_ASSERT_TYPE (ly_is_grob_cause, cause, 3); + + Grob *g = unsmob_engraver (engraver)-> + internal_make_grob(grob_name, cause, + ly_symbol2string (grob_name).c_str (), + "scheme", 0, "scheme"); + return g->self_scm (); +} + diff --git a/lily/engraver.cc b/lily/engraver.cc index 1b83b07a85..9e6b23118c 100644 --- a/lily/engraver.cc +++ b/lily/engraver.cc @@ -70,9 +70,8 @@ Engraver::announce_grob (Grob *e, SCM cause) /* - CAUSE is the object (typically a Music object) that - was the reason for making E. -*/ + CAUSE is the object (typically a grob or stream-event object) that + was the reason for ending E. */ void Engraver::announce_end_grob (Grob *e, SCM cause) { @@ -175,13 +174,26 @@ Engraver::internal_make_column (SCM x, char const *name, } Spanner * -Engraver::internal_make_spanner (SCM x, SCM cause, char const *name, char const *file, int line, char const *fun) +Engraver::internal_make_spanner (SCM x, SCM cause, char const *name, + char const *file, int line, char const *fun) { Spanner *sp = dynamic_cast (internal_make_grob (x, cause, name, file, line, fun)); assert (sp); return sp; } +Engraver* +unsmob_engraver (SCM eng) +{ + return dynamic_cast (unsmob_translator (eng)); +} + +bool +ly_is_grob_cause (SCM obj) +{ + return unsmob_grob (obj) || unsmob_stream_event (obj); +} + #include "translator.icc" ADD_TRANSLATOR (Engraver, @@ -198,3 +210,4 @@ ADD_TRANSLATOR (Engraver, "" ); + diff --git a/lily/include/axis-group-engraver.hh b/lily/include/axis-group-engraver.hh index 68595e0c74..d10f864be1 100644 --- a/lily/include/axis-group-engraver.hh +++ b/lily/include/axis-group-engraver.hh @@ -37,6 +37,8 @@ protected: void process_acknowledged (); virtual Spanner *get_spanner (); virtual void add_element (Grob *); + virtual bool must_be_last () const; + public: TRANSLATOR_DECLARATIONS (Axis_group_engraver); }; diff --git a/lily/include/engraver.hh b/lily/include/engraver.hh index 2254ff5248..d4797b8f9e 100644 --- a/lily/include/engraver.hh +++ b/lily/include/engraver.hh @@ -31,7 +31,7 @@ class Engraver : public Translator { Grob *internal_make_grob (SCM sym, SCM cause, char const *name, char const *f, int l, char const *fun); - + friend SCM ly_engraver_make_grob (SCM, SCM, SCM); friend class Engraver_group; protected: /* @@ -69,5 +69,7 @@ public: #define make_spanner(x, cause) internal_make_spanner (ly_symbol2scm (x), cause, x, __FILE__, __LINE__, __FUNCTION__) #define make_paper_column(x) internal_make_column (ly_symbol2scm (x), x, __FILE__, __LINE__, __FUNCTION__) +Engraver* unsmob_engraver (SCM eng); +bool ly_is_grob_cause (SCM obj); #endif // ENGRAVER_HH diff --git a/lily/include/lily-proto.hh b/lily/include/lily-proto.hh index 138328a26b..19aef0a27a 100644 --- a/lily/include/lily-proto.hh +++ b/lily/include/lily-proto.hh @@ -152,6 +152,7 @@ class Relative_octave_music; class Repeated_music; class Scale; class Scheme_hash_table; +class Scheme_engraver; class Score; class Score_context; class Score_engraver; diff --git a/lily/include/scheme-engraver.hh b/lily/include/scheme-engraver.hh new file mode 100644 index 0000000000..73eff6d576 --- /dev/null +++ b/lily/include/scheme-engraver.hh @@ -0,0 +1,79 @@ +/* + scheme-engraver.hh -- declare Scheme_engraver + + source file of the GNU LilyPond music typesetter + + Copyright (c) 2009 Han-Wen Nienhuys + + LilyPond is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + LilyPond is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with LilyPond. If not, see . + +*/ + +#ifndef SCHEME_ENGRAVER_HH +#define SCHEME_ENGRAVER_HH + +#include "engraver.hh" + +class Scheme_engraver : public Engraver { +public: + void init_from_scheme (SCM definition); + TRANSLATOR_DECLARATIONS_NO_LISTENER (Scheme_engraver); + + static Listener get_listener (void *generic_arg, SCM event); + +protected: + ~Scheme_engraver (); + + void stop_translation_timestep (); + void start_translation_timestep (); + void process_music (); + void process_acknowledged (); + + virtual void initialize (); + virtual void finalize (); + virtual void derived_mark () const; + virtual translator_listener_record *get_listener_list () const; + virtual bool must_be_last () const; + +private: + void acknowledge_grob_by_hash (Grob_info info, SCM iface_function_hash); + void init_acknowledgers (SCM alist, SCM *hash); + + DECLARE_ACKNOWLEDGER (grob); + DECLARE_END_ACKNOWLEDGER (grob); + + bool must_be_last_; + + SCM acknowledge_grob_function_; + SCM stop_translation_timestep_function_; + SCM start_translation_timestep_function_; + SCM process_music_function_; + SCM process_acknowledged_function_; + SCM initialize_function_; + SCM finalize_function_; + + // hashq table of interface-symbol -> scheme-function + SCM interface_acknowledger_hash_; + SCM interface_end_acknowledger_hash_; + + // Alist of listened-symbol . scheme-function + SCM listeners_alist_; + + // We dont use this, but need it for the documentation boilerplate. + static translator_listener_record *listener_list_; + translator_listener_record *per_instance_listeners_; +}; + +#endif /* SCHEME_ENGRAVER_HH */ + diff --git a/lily/include/translator.hh b/lily/include/translator.hh index ea5f07269a..a8e3f1d513 100644 --- a/lily/include/translator.hh +++ b/lily/include/translator.hh @@ -32,6 +32,11 @@ struct Acknowledge_information { SCM symbol_; Engraver_void_function_engraver_grob_info function_; + + Acknowledge_information () { + symbol_ = SCM_EOL; + function_ = 0; + } }; @@ -41,14 +46,21 @@ struct Acknowledge_information listeners to a context. */ typedef struct translator_listener_record { - Listener (*get_listener_) (void *); + Listener (*get_listener_) (void *, SCM event_class); SCM event_class_; struct translator_listener_record *next_; + + translator_listener_record () { + next_ = 0; + event_class_ = SCM_EOL; + get_listener_ = 0; + } + } translator_listener_record; -#define TRANSLATOR_DECLARATIONS(NAME) \ + +#define TRANSLATOR_DECLARATIONS_NO_LISTENER(NAME) \ private: \ - static translator_listener_record *listener_list_; \ public: \ NAME (); \ VIRTUAL_COPY_CONSTRUCTOR (Translator, NAME); \ @@ -57,6 +69,8 @@ private: \ virtual void fetch_precomputable_methods (Translator_void_method_ptr methods[]); \ virtual SCM static_translator_description () const; \ virtual SCM translator_description () const; \ + static Engraver_void_function_engraver_grob_info static_get_acknowledger (SCM sym); \ + static Engraver_void_function_engraver_grob_info static_get_end_acknowledger(SCM); \ virtual Engraver_void_function_engraver_grob_info get_acknowledger (SCM sym) \ { \ return static_get_acknowledger (sym); \ @@ -65,8 +79,12 @@ private: \ { \ return static_get_end_acknowledger (sym); \ } \ - static Engraver_void_function_engraver_grob_info static_get_acknowledger (SCM sym); \ - static Engraver_void_function_engraver_grob_info static_get_end_acknowledger(SCM); \ + /* end #define */ + +#define TRANSLATOR_DECLARATIONS(NAME) \ + TRANSLATOR_DECLARATIONS_NO_LISTENER(NAME) \ +private: \ + static translator_listener_record *listener_list_; \ public: \ virtual translator_listener_record *get_listener_list () const \ { \ @@ -80,7 +98,7 @@ inline void listen_ ## m (Stream_event *); \ /* Should be private */ \ static void _internal_declare_ ## m (); \ private: \ -static Listener _get_ ## m ## _listener (void *); \ + static Listener _get_ ## m ## _listener (void *, SCM); \ DECLARE_LISTENER (_listen_scm_ ## m); #define DECLARE_ACKNOWLEDGER(x) public : void acknowledge_ ## x (Grob_info); protected: @@ -102,12 +120,7 @@ class Translator { void init (); -protected: - bool must_be_last_; - public: - bool must_be_last () const; - Context *context () const { return daddy_context_; } Translator (Translator const &); @@ -117,11 +130,12 @@ public: virtual Output_def *get_output_def () const; virtual Translator_group *get_daddy_translator ()const; virtual Moment now_mom () const; + virtual bool must_be_last () const; virtual void initialize (); virtual void finalize (); - /*should maybe be virtual*/ + /* should maybe be virtual */ void connect_to_context (Context *c); void disconnect_from_context (Context *c); @@ -140,7 +154,10 @@ protected: // should be private. Context *daddy_context_; void protect_event (SCM ev); virtual void derived_mark () const; - static void add_translator_listener (translator_listener_record **listener_list, translator_listener_record *r, Listener (*get_listener) (void *), const char *ev_class); + static void add_translator_listener (translator_listener_record **listener_list, + translator_listener_record *r, + Listener (*get_listener) (void *, SCM), + const char *ev_class); SCM static_translator_description (const char *grobs, const char *desc, translator_listener_record *listener_list, @@ -149,6 +166,7 @@ protected: // should be private. friend class Translator_group; }; + void add_translator (Translator *trans); Translator *get_translator (SCM s); @@ -164,4 +182,5 @@ extern bool internal_event_assignment (Stream_event **old_ev, Stream_event *new_ #define ASSIGN_EVENT_ONCE(o,n) internal_event_assignment (&o, n, __FUNCTION__) + #endif // TRANSLATOR_HH diff --git a/lily/include/translator.icc b/lily/include/translator.icc index 8d96eb20f0..73f8f7bab3 100644 --- a/lily/include/translator.icc +++ b/lily/include/translator.icc @@ -32,7 +32,6 @@ A macro to automate administration of translators. */ #define ADD_THIS_TRANSLATOR(T) \ - translator_listener_record *T::listener_list_; \ SCM T::static_description_ = SCM_EOL; \ static void _ ## T ## _adder () \ { \ @@ -45,12 +44,15 @@ { \ return static_description_; \ } \ - ADD_GLOBAL_CTOR (_ ## T ## _adder); + ADD_GLOBAL_CTOR (_ ## T ## _adder); \ + /* end define */ -#define ADD_TRANSLATOR(classname, desc, grobs, read, write) \ +#define DEFINE_TRANSLATOR_LISTENER_LIST(T) \ + translator_listener_record *T::listener_list_; \ + /* end define */ + +#define DEFINE_ACKNOWLEDGERS(classname) \ Drul_array< vector > classname::acknowledge_static_array_drul_; \ - IMPLEMENT_FETCH_PRECOMPUTABLE_METHODS (classname); \ - ADD_THIS_TRANSLATOR (classname); \ Engraver_void_function_engraver_grob_info \ classname::static_get_acknowledger (SCM sym) \ { \ @@ -61,12 +63,22 @@ { \ return generic_get_acknowledger (sym, &acknowledge_static_array_drul_[STOP]); \ } \ + /* end define */ + +#define DEFINE_TRANSLATOR_DOC(classname, desc, grobs, read, write) \ SCM \ classname::static_translator_description () const \ { \ return Translator::static_translator_description (grobs, desc, listener_list_, read, write); \ } +#define ADD_TRANSLATOR(classname, desc, grobs, read, write) \ + IMPLEMENT_FETCH_PRECOMPUTABLE_METHODS (classname); \ + ADD_THIS_TRANSLATOR (classname); \ + DEFINE_TRANSLATOR_DOC(classname, desc, grobs, read, write) \ + DEFINE_ACKNOWLEDGERS(classname) \ + DEFINE_TRANSLATOR_LISTENER_LIST(classname) \ + #define IMPLEMENT_FETCH_PRECOMPUTABLE_METHODS(T) \ void \ T::fetch_precomputable_methods (Translator_void_method_ptr ptrs[]) \ @@ -130,9 +142,10 @@ cl :: _internal_declare_ ## m () \ ADD_SCM_INIT_FUNC (cl ## _declare_event_ ## m, cl::_internal_declare_ ## m); \ \ Listener \ -cl :: _get_ ## m ## _listener (void *me) \ + cl :: _get_ ## m ## _listener (void *me, SCM unused) \ { \ cl *obj = (cl *) me; \ + (void) unused; \ return obj->GET_LISTENER (_listen_scm_ ## m); \ } \ \ diff --git a/lily/parser.yy b/lily/parser.yy index d2f3a8c4dc..a4ac1ec035 100644 --- a/lily/parser.yy +++ b/lily/parser.yy @@ -1316,6 +1316,17 @@ context_mod: | context_def_mod STRING { $$ = scm_list_2 ($1, $2); } + | context_def_mod embedded_scm { + if (ly_symbol2scm ("consists") != $1) + { + $$ = SCM_EOL; + PARSER->parser_error (@1, _ ("only \\consists takes non-string argument.")); + } + else + { + $$ = scm_list_2 ($1, $2); + } + } ; context_prop_spec: diff --git a/lily/scheme-engraver.cc b/lily/scheme-engraver.cc new file mode 100644 index 0000000000..129362e5a2 --- /dev/null +++ b/lily/scheme-engraver.cc @@ -0,0 +1,256 @@ +/* + scheme-engraver.cc -- implement Scheme_engraver + + source file of the GNU LilyPond music typesetter + + Copyright (c) 2009 Han-Wen Nienhuys + + LilyPond is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + LilyPond is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with LilyPond. If not, see . +*/ + +#include "scheme-engraver.hh" + +#include "grob.hh" + +#include "translator.icc" + +Scheme_engraver::Scheme_engraver () +{ + stop_translation_timestep_function_ = SCM_EOL; + start_translation_timestep_function_ = SCM_EOL; + process_music_function_ = SCM_EOL; + process_acknowledged_function_ = SCM_EOL; + initialize_function_ = SCM_EOL; + finalize_function_ = SCM_EOL; + listeners_alist_ = SCM_EOL; + + interface_acknowledger_hash_ = SCM_EOL; + interface_end_acknowledger_hash_ = SCM_EOL; + + must_be_last_ = false; + per_instance_listeners_ = 0; +} + +Scheme_engraver::~Scheme_engraver () +{ + translator_listener_record *next = 0; + for (translator_listener_record *r = per_instance_listeners_; + r; r = next) + { + next = r->next_; + delete r; + } +} + +// Extracts the value if callable, if not return #f. +static SCM +callable (SCM symbol, SCM defn) +{ + SCM val = ly_assoc_get (symbol, defn, SCM_BOOL_F); + return ly_is_procedure (val) ? val : SCM_BOOL_F; +} + +bool +Scheme_engraver::must_be_last () const +{ + return must_be_last_; +} + +void +Scheme_engraver::init_from_scheme (SCM definition) +{ + start_translation_timestep_function_ = callable (ly_symbol2scm ("start-translation-timestep"), + definition); + stop_translation_timestep_function_ = callable (ly_symbol2scm ("stop-translation-timestep"), + definition); + process_music_function_ = callable (ly_symbol2scm ("process-music"), definition); + process_acknowledged_function_ = callable (ly_symbol2scm ("process-acknowledged"), + definition); + initialize_function_ = callable (ly_symbol2scm ("initialize"), definition); + finalize_function_ = callable (ly_symbol2scm ("finalize"), definition); + + SCM listeners = ly_assoc_get (ly_symbol2scm ("listeners"), definition, SCM_EOL); + + listeners_alist_ = SCM_EOL; + + must_be_last_ = to_boolean (ly_assoc_get (ly_symbol2scm ("must-be-last"), + definition, + SCM_BOOL_F)); + + translator_listener_record **tail = &per_instance_listeners_; + for (SCM p = listeners; scm_is_pair (p); p = scm_cdr (p)) + { + SCM event_class = scm_caar (p); + SCM proc = scm_cdar (p); + + if (!(ly_is_procedure (proc) && ly_is_symbol (event_class))) + continue; + + // We should check the arity of the function? + + // Record for later lookup. + listeners_alist_ = scm_acons (event_class, proc, listeners_alist_); + + translator_listener_record *rec = new translator_listener_record; + *tail = rec; + rec->event_class_ = event_class; + rec->get_listener_ = &Scheme_engraver::get_listener; + tail = &rec->next_; + } + + init_acknowledgers (ly_assoc_get(ly_symbol2scm ("acknowledgers"), + definition, SCM_EOL), + &interface_acknowledger_hash_); + + init_acknowledgers (ly_assoc_get(ly_symbol2scm ("end-acknowledgers"), + definition, SCM_EOL), + &interface_end_acknowledger_hash_); + + // TODO: hook up description, props read/written, grobs created + // etc. to provide automatic documentation. +} + +void +Scheme_engraver::init_acknowledgers (SCM alist, + SCM *hash) +{ + *hash = scm_c_make_hash_table(7); + for (SCM p = alist; scm_is_pair (p); p = scm_cdr (p)) + { + SCM iface = scm_caar (p); + SCM proc = scm_cdar (p); + + if (!(ly_is_procedure (proc) && ly_is_symbol (iface))) + continue; + + scm_hashq_set_x (*hash, iface, proc); + } +} + +// This is the easy way to do it, at the cost of too many invocations +// of Scheme_engraver::acknowledge_grob. The clever dispatching of +// acknowledgers is hardwired to have 1 method per engraver per +// grob-type, which doesn't work for this case. +void +Scheme_engraver::acknowledge_grob (Grob_info info) +{ + acknowledge_grob_by_hash (info, interface_acknowledger_hash_); +} + +void +Scheme_engraver::acknowledge_end_grob (Grob_info info) +{ + acknowledge_grob_by_hash (info, interface_end_acknowledger_hash_); +} + +void +Scheme_engraver::acknowledge_grob_by_hash (Grob_info info, + SCM iface_function_hash) +{ + SCM meta = info.grob ()->internal_get_property (ly_symbol2scm ("meta")); + SCM ifaces = scm_cdr (scm_assoc (ly_symbol2scm ("interfaces"), meta)); + for (SCM s = ifaces; scm_is_pair (s); s = scm_cdr (s)) + { + SCM func = scm_hashq_ref (iface_function_hash, + scm_car (s), SCM_BOOL_F); + + if (ly_is_procedure (func)) + scm_call_3 (func, self_scm (), info.grob ()->self_scm (), + info.origin_translator ()->self_scm ()); + } +} + +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); +} + +Listener_function_table listen_closure = { + call_listen_closure, mark_listen_closure +}; + +/* static */ +Listener +Scheme_engraver::get_listener (void *arg, SCM name) +{ + Scheme_engraver *me = (Scheme_engraver*) arg; + 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); +} + +translator_listener_record * +Scheme_engraver::get_listener_list () const +{ + return per_instance_listeners_; +} + +#define DISPATCH(what) \ + void \ + Scheme_engraver::what () \ + { \ + if (what ## _function_ != SCM_BOOL_F) \ + scm_call_1 (what ## _function_, self_scm ()); \ + } + +DISPATCH(start_translation_timestep); +DISPATCH(stop_translation_timestep); +DISPATCH(initialize); +DISPATCH(finalize); +DISPATCH(process_music); +DISPATCH(process_acknowledged); + +void +Scheme_engraver::derived_mark () const +{ + scm_gc_mark (start_translation_timestep_function_); + scm_gc_mark (stop_translation_timestep_function_); + scm_gc_mark (initialize_function_); + scm_gc_mark (finalize_function_); + scm_gc_mark (process_music_function_); + scm_gc_mark (process_acknowledged_function_); + scm_gc_mark (listeners_alist_); + scm_gc_mark (interface_acknowledger_hash_); + scm_gc_mark (interface_end_acknowledger_hash_); +} + +ADD_ACKNOWLEDGER (Scheme_engraver, grob); +ADD_END_ACKNOWLEDGER (Scheme_engraver, grob); + +ADD_TRANSLATOR (Scheme_engraver, + /* doc */ + "Implement engravers in Scheme. Interprets arguments to @code{\\consists} " + "as callbacks. ", + + /* create */ + "", + + /* read */ + "", + + /* write */ + "" + ); diff --git a/lily/translator-group.cc b/lily/translator-group.cc index 9399dc3bc2..8100a4de17 100644 --- a/lily/translator-group.cc +++ b/lily/translator-group.cc @@ -29,10 +29,10 @@ #include "music.hh" #include "output-def.hh" #include "performer-group.hh" +#include "scheme-engraver.hh" #include "scm-hash.hh" #include "warn.hh" - void translator_each (SCM list, Translator_method method) { @@ -152,15 +152,29 @@ Translator_group::create_child_translator (SCM sev) for (SCM s = trans_names; scm_is_pair (s); s = scm_cdr (s)) { - Translator *type = get_translator (scm_car (s)); + SCM definition = scm_car (s); + + Translator *type = 0; + Translator *instance = type; + if (ly_is_symbol (definition)) + { + type = get_translator (definition); + instance = type->clone (); + } + else if (ly_is_pair (definition)) + { + type = get_translator (ly_symbol2scm ("Scheme_engraver")); + instance = type->clone (); + dynamic_cast (instance)->init_from_scheme (definition); + } + if (!type) warning (_f ("cannot find: `%s'", ly_symbol2string (scm_car (s)).c_str ())); else { - Translator *tr = type->clone (); - SCM str = tr->self_scm (); + SCM str = instance->self_scm (); - if (tr->must_be_last ()) + if (instance->must_be_last ()) { SCM cons = scm_cons (str, SCM_EOL); if (scm_is_pair (trans_list)) @@ -171,13 +185,13 @@ Translator_group::create_child_translator (SCM sev) else trans_list = scm_cons (str, trans_list); - tr->daddy_context_ = new_context; - tr->unprotect (); + instance->daddy_context_ = new_context; + instance->unprotect (); } } /* Filter unwanted translator types. Required to make - \with {\consists "..."} work. */ + \with { \consists "..." } work. */ if (dynamic_cast (g)) g->simple_trans_list_ = filter_performers (trans_list); else if (dynamic_cast (g)) diff --git a/lily/translator-scheme.cc b/lily/translator-scheme.cc index d5615dc03c..a24dc86834 100644 --- a/lily/translator-scheme.cc +++ b/lily/translator-scheme.cc @@ -17,6 +17,7 @@ along with LilyPond. If not, see . */ +#include "context.hh" #include "context-def.hh" #include "translator-group.hh" #include "moment.hh" @@ -41,3 +42,14 @@ LY_DEFINE (ly_translator_description, "ly:translator-description", return tr->translator_description (); } + +LY_DEFINE (ly_translator_context, "ly:translator-context", + 1, 0, 0, (SCM trans), + "Return the context of the translator object @var{trans}.") +{ + LY_ASSERT_SMOB (Translator, trans, 1); + Translator *tr = unsmob_translator (trans); + + Context *c = tr->context (); + return c ? c->self_scm () : SCM_BOOL_F; +} diff --git a/lily/translator.cc b/lily/translator.cc index da3aa8c1af..399ecce602 100644 --- a/lily/translator.cc +++ b/lily/translator.cc @@ -36,7 +36,6 @@ Translator::~Translator () void Translator::init () { - must_be_last_ = false; self_scm_ = SCM_EOL; daddy_context_ = 0; smobify_self (); @@ -59,8 +58,8 @@ Translator::Translator () Translator::Translator (Translator const &src) { + (void) src; init (); - must_be_last_ = src.must_be_last_; } Moment @@ -121,15 +120,17 @@ Translator::finalize () void Translator::connect_to_context (Context *c) { - for (translator_listener_record *r = get_listener_list (); r; r=r->next_) - c->events_below ()->add_listener (r->get_listener_ (this), r->event_class_); + for (translator_listener_record *r = get_listener_list (); r; r = r->next_) + c->events_below ()->add_listener (r->get_listener_ (this, r->event_class_), + r->event_class_); } void Translator::disconnect_from_context (Context *c) { - for (translator_listener_record *r = get_listener_list (); r; r=r->next_) - c->events_below ()->remove_listener (r->get_listener_ (this), r->event_class_); + for (translator_listener_record *r = get_listener_list (); r; r = r->next_) + c->events_below ()->remove_listener (r->get_listener_ (this, r->event_class_), + r->event_class_); } static SCM listened_event_class_table; @@ -177,7 +178,7 @@ add_listened_event_class (SCM sym) void Translator::add_translator_listener (translator_listener_record **listener_list, translator_listener_record *r, - Listener (*get_listener) (void *), + Listener (*get_listener) (void *, SCM), const char *ev_class) { /* ev_class is the C++ identifier name. Convert to scm symbol */ @@ -258,7 +259,7 @@ IMPLEMENT_TYPE_P (Translator, "ly:translator?"); bool Translator::must_be_last () const { - return must_be_last_; + return false; } void -- 2.39.2