lily/scheme-engraver.cc

   1 /*
   2   scheme-engraver.cc -- implement Scheme_engraver
   3
   4   source file of the GNU LilyPond music typesetter
   5
   6   Copyright (c) 2009--2014 Han-Wen Nienhuys <hanwen@lilypond.org>
   7
   8   LilyPond is free software: you can redistribute it and/or modify
   9   it under the terms of the GNU General Public License as published by
  10   the Free Software Foundation, either version 3 of the License, or
  11   (at your option) any later version.
  12
  13   LilyPond is distributed in the hope that it will be useful,
  14   but WITHOUT ANY WARRANTY; without even the implied warranty of
  15   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16   GNU General Public License for more details.
  17
  18   You should have received a copy of the GNU General Public License
  19   along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  20 */
  21
  22 #include "scheme-engraver.hh"
  23
  24 #include "grob.hh"
  25
  26 #include "translator.icc"
  27
  28 Scheme_engraver::Scheme_engraver ()
  29 {
  30   stop_translation_timestep_function_ = SCM_EOL;
  31   start_translation_timestep_function_ = SCM_EOL;
  32   process_music_function_ = SCM_EOL;
  33   process_acknowledged_function_ = SCM_EOL;
  34   initialize_function_ = SCM_EOL;
  35   finalize_function_ = SCM_EOL;
  36   listeners_alist_ = SCM_EOL;
  37
  38   interface_acknowledger_hash_ = SCM_EOL;
  39   interface_end_acknowledger_hash_ = SCM_EOL;
  40
  41   must_be_last_ = false;
  42   per_instance_listeners_ = 0;
  43 }
  44
  45 Scheme_engraver::~Scheme_engraver ()
  46 {
  47   translator_listener_record *next = 0;
  48   for (translator_listener_record *r = per_instance_listeners_;
  49        r; r = next)
  50     {
  51       next = r->next_;
  52       delete r;
  53     }
  54 }
  55
  56 // Extracts the value if callable, if not return #f.
  57 static SCM
  58 callable (SCM symbol, SCM defn)
  59 {
  60   SCM val = ly_assoc_get (symbol, defn, SCM_BOOL_F);
  61   return ly_is_procedure (val) ? val : SCM_BOOL_F;
  62 }
  63
  64 bool
  65 Scheme_engraver::must_be_last () const
  66 {
  67   return must_be_last_;
  68 }
  69
  70 void
  71 Scheme_engraver::init_from_scheme (SCM definition)
  72 {
  73   start_translation_timestep_function_ = callable (ly_symbol2scm ("start-translation-timestep"),
  74                                                    definition);
  75   stop_translation_timestep_function_ = callable (ly_symbol2scm ("stop-translation-timestep"),
  76                                                   definition);
  77   process_music_function_ = callable (ly_symbol2scm ("process-music"), definition);
  78   process_acknowledged_function_ = callable (ly_symbol2scm ("process-acknowledged"),
  79                                              definition);
  80   initialize_function_ = callable (ly_symbol2scm ("initialize"), definition);
  81   finalize_function_ = callable (ly_symbol2scm ("finalize"), definition);
  82
  83   SCM listeners = ly_assoc_get (ly_symbol2scm ("listeners"), definition, SCM_EOL);
  84
  85   listeners_alist_ = SCM_EOL;
  86
  87   must_be_last_ = to_boolean (ly_assoc_get (ly_symbol2scm ("must-be-last"),
  88                                             definition,
  89                                             SCM_BOOL_F));
  90
  91   translator_listener_record **tail = &per_instance_listeners_;
  92   for (SCM p = listeners; scm_is_pair (p); p = scm_cdr (p))
  93     {
  94       SCM event_class = scm_caar (p);
  95       SCM proc = scm_cdar (p);
  96
  97       if (!(ly_is_procedure (proc) && ly_is_symbol (event_class)))
  98         continue;
  99
 100       // We should check the arity of the function?
 101
 102       // Record for later lookup.
 103       listeners_alist_ = scm_acons (event_class, proc, listeners_alist_);
 104
 105       translator_listener_record *rec = new translator_listener_record;
 106       *tail = rec;
 107       rec->event_class_ = event_class;
 108       rec->get_listener_ = &Scheme_engraver::get_listener;
 109       tail = &rec->next_;
 110     }
 111
 112   init_acknowledgers (ly_assoc_get (ly_symbol2scm ("acknowledgers"),
 113                                     definition, SCM_EOL),
 114                       &interface_acknowledger_hash_);
 115
 116   init_acknowledgers (ly_assoc_get (ly_symbol2scm ("end-acknowledgers"),
 117                                     definition, SCM_EOL),
 118                       &interface_end_acknowledger_hash_);
 119
 120   // TODO: hook up description, props read/written, grobs created
 121   // etc. to provide automatic documentation.
 122 }
 123
 124 void
 125 Scheme_engraver::init_acknowledgers (SCM alist,
 126                                      SCM *hash)
 127 {
 128   *hash = scm_c_make_hash_table (7);
 129   for (SCM p = alist; scm_is_pair (p); p = scm_cdr (p))
 130     {
 131       SCM iface = scm_caar (p);
 132       SCM proc = scm_cdar (p);
 133
 134       if (!(ly_is_procedure (proc) && ly_is_symbol (iface)))
 135         continue;
 136
 137       scm_hashq_set_x (*hash, iface, proc);
 138     }
 139 }
 140
 141 // This is the easy way to do it, at the cost of too many invocations
 142 // of Scheme_engraver::acknowledge_grob.  The clever dispatching of
 143 // acknowledgers is hardwired to have 1 method per engraver per
 144 // grob-type, which doesn't work for this case.
 145 void
 146 Scheme_engraver::acknowledge_grob (Grob_info info)
 147 {
 148   acknowledge_grob_by_hash (info, interface_acknowledger_hash_);
 149 }
 150
 151 void
 152 Scheme_engraver::acknowledge_end_grob (Grob_info info)
 153 {
 154   acknowledge_grob_by_hash (info, interface_end_acknowledger_hash_);
 155 }
 156
 157 void
 158 Scheme_engraver::acknowledge_grob_by_hash (Grob_info info,
 159                                            SCM iface_function_hash)
 160 {
 161   SCM meta = info.grob ()->internal_get_property (ly_symbol2scm ("meta"));
 162   SCM ifaces = scm_cdr (scm_assoc (ly_symbol2scm ("interfaces"), meta));
 163   for (SCM s = ifaces; scm_is_pair (s); s = scm_cdr (s))
 164     {
 165       SCM func = scm_hashq_ref (iface_function_hash,
 166                                 scm_car (s), SCM_BOOL_F);
 167
 168       if (ly_is_procedure (func))
 169         scm_call_3 (func, self_scm (), info.grob ()->self_scm (),
 170                     info.origin_translator ()->self_scm ());
 171     }
 172 }
 173
 174 static
 175 void call_listen_closure (void *target, SCM ev)
 176 {
 177   SCM cl = (SCM) target;
 178   SCM func = scm_car (cl);
 179   SCM engraver = scm_cdr (cl);
 180   scm_call_2 (func, engraver, ev);
 181 }
 182
 183 static
 184 void mark_listen_closure (void *target)
 185 {
 186   scm_gc_mark ((SCM)target);
 187 }
 188
 189 static
 190 bool equal_listen_closure (void *a, void *b)
 191 {
 192   SCM target_a = (SCM) a;
 193   SCM target_b = (SCM) b;
 194
 195   return ly_is_equal (target_a, target_b);
 196 }
 197
 198 Listener_function_table listen_closure
 199 =
 200 {
 201   call_listen_closure, mark_listen_closure, equal_listen_closure
 202 };
 203
 204 /* static */
 205 Listener
 206 Scheme_engraver::get_listener (void *arg, SCM name)
 207 {
 208   Scheme_engraver *me = (Scheme_engraver *) arg;
 209   SCM func = ly_assoc_get (name, me->listeners_alist_, SCM_BOOL_F);
 210   assert (ly_is_procedure (func));
 211
 212   SCM closure = scm_cons (func, me->self_scm ());
 213   return Listener ((void *)closure, &listen_closure);
 214 }
 215
 216 translator_listener_record *
 217 Scheme_engraver::get_listener_list () const
 218 {
 219   return per_instance_listeners_;
 220 }
 221
 222 #define DISPATCH(what)                                  \
 223   void                                                  \
 224   Scheme_engraver::what ()                              \
 225   {                                                     \
 226     if (what ## _function_ != SCM_BOOL_F)               \
 227       scm_call_1 (what ## _function_, self_scm ());     \
 228   }
 229
 230 DISPATCH (start_translation_timestep);
 231 DISPATCH (stop_translation_timestep);
 232 DISPATCH (initialize);
 233 DISPATCH (finalize);
 234 DISPATCH (process_music);
 235 DISPATCH (process_acknowledged);
 236
 237 void
 238 Scheme_engraver::derived_mark () const
 239 {
 240   scm_gc_mark (start_translation_timestep_function_);
 241   scm_gc_mark (stop_translation_timestep_function_);
 242   scm_gc_mark (initialize_function_);
 243   scm_gc_mark (finalize_function_);
 244   scm_gc_mark (process_music_function_);
 245   scm_gc_mark (process_acknowledged_function_);
 246   scm_gc_mark (listeners_alist_);
 247   scm_gc_mark (interface_acknowledger_hash_);
 248   scm_gc_mark (interface_end_acknowledger_hash_);
 249 }
 250
 251 ADD_ACKNOWLEDGER (Scheme_engraver, grob);
 252 ADD_END_ACKNOWLEDGER (Scheme_engraver, grob);
 253
 254 ADD_TRANSLATOR (Scheme_engraver,
 255                 /* doc */
 256                 "Implement engravers in Scheme.  Interprets arguments to"
 257                 " @code{\\consists} as callbacks.",
 258
 259                 /* create */
 260                 "",
 261
 262                 /* read */
 263                 "",
 264
 265                 /* write */
 266                 ""
 267                );