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--2015 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
  37   interface_acknowledger_hash_ = SCM_EOL;
  38   interface_end_acknowledger_hash_ = SCM_EOL;
  39
  40   must_be_last_ = false;
  41   per_instance_listeners_ = SCM_EOL;
  42 }
  43
  44 Scheme_engraver::~Scheme_engraver ()
  45 {
  46 }
  47
  48 // Extracts the value if callable, if not return #f.
  49 static SCM
  50 callable (SCM symbol, SCM defn)
  51 {
  52   SCM val = ly_assoc_get (symbol, defn, SCM_BOOL_F);
  53   return ly_is_procedure (val) ? val : SCM_BOOL_F;
  54 }
  55
  56 bool
  57 Scheme_engraver::must_be_last () const
  58 {
  59   return must_be_last_;
  60 }
  61
  62 void
  63 Scheme_engraver::init_from_scheme (SCM definition)
  64 {
  65   start_translation_timestep_function_ = callable (ly_symbol2scm ("start-translation-timestep"),
  66                                                    definition);
  67   stop_translation_timestep_function_ = callable (ly_symbol2scm ("stop-translation-timestep"),
  68                                                   definition);
  69   process_music_function_ = callable (ly_symbol2scm ("process-music"), definition);
  70   process_acknowledged_function_ = callable (ly_symbol2scm ("process-acknowledged"),
  71                                              definition);
  72   initialize_function_ = callable (ly_symbol2scm ("initialize"), definition);
  73   finalize_function_ = callable (ly_symbol2scm ("finalize"), definition);
  74
  75   SCM listeners = ly_assoc_get (ly_symbol2scm ("listeners"), definition, SCM_EOL);
  76
  77   per_instance_listeners_ = SCM_EOL;
  78
  79   must_be_last_ = to_boolean (ly_assoc_get (ly_symbol2scm ("must-be-last"),
  80                                             definition,
  81                                             SCM_BOOL_F));
  82
  83   for (SCM p = listeners; scm_is_pair (p); p = scm_cdr (p))
  84     {
  85       SCM event_class = scm_caar (p);
  86       SCM proc = scm_cdar (p);
  87
  88       if (!(ly_is_procedure (proc) && ly_is_symbol (event_class)))
  89         continue;
  90
  91       // We should check the arity of the function?
  92
  93       // Record for later lookup.
  94       per_instance_listeners_ = scm_acons (event_class, proc, per_instance_listeners_);
  95     }
  96
  97   init_acknowledgers (ly_assoc_get (ly_symbol2scm ("acknowledgers"),
  98                                     definition, SCM_EOL),
  99                       &interface_acknowledger_hash_);
 100
 101   init_acknowledgers (ly_assoc_get (ly_symbol2scm ("end-acknowledgers"),
 102                                     definition, SCM_EOL),
 103                       &interface_end_acknowledger_hash_);
 104
 105   // TODO: hook up description, props read/written, grobs created
 106   // etc. to provide automatic documentation.
 107 }
 108
 109 void
 110 Scheme_engraver::init_acknowledgers (SCM alist,
 111                                      SCM *hash)
 112 {
 113   *hash = scm_c_make_hash_table (7);
 114   for (SCM p = alist; scm_is_pair (p); p = scm_cdr (p))
 115     {
 116       SCM iface = scm_caar (p);
 117       SCM proc = scm_cdar (p);
 118
 119       if (!(ly_is_procedure (proc) && ly_is_symbol (iface)))
 120         continue;
 121
 122       scm_hashq_set_x (*hash, iface, proc);
 123     }
 124 }
 125
 126 // This is the easy way to do it, at the cost of too many invocations
 127 // of Scheme_engraver::acknowledge_grob.  The clever dispatching of
 128 // acknowledgers is hardwired to have 1 method per engraver per
 129 // grob-type, which doesn't work for this case.
 130 void
 131 Scheme_engraver::acknowledge_grob (Grob_info info)
 132 {
 133   acknowledge_grob_by_hash (info, interface_acknowledger_hash_);
 134 }
 135
 136 void
 137 Scheme_engraver::acknowledge_end_grob (Grob_info info)
 138 {
 139   acknowledge_grob_by_hash (info, interface_end_acknowledger_hash_);
 140 }
 141
 142 void
 143 Scheme_engraver::acknowledge_grob_by_hash (Grob_info info,
 144                                            SCM iface_function_hash)
 145 {
 146   SCM meta = info.grob ()->get_property ("meta");
 147   SCM ifaces = scm_cdr (scm_assoc (ly_symbol2scm ("interfaces"), meta));
 148   for (SCM s = ifaces; scm_is_pair (s); s = scm_cdr (s))
 149     {
 150       SCM func = scm_hashq_ref (iface_function_hash,
 151                                 scm_car (s), SCM_BOOL_F);
 152
 153       if (ly_is_procedure (func))
 154         scm_call_3 (func, self_scm (), info.grob ()->self_scm (),
 155                     info.origin_translator ()->self_scm ());
 156     }
 157 }
 158
 159 SCM
 160 Scheme_engraver::get_listener_list () const
 161 {
 162   return per_instance_listeners_;
 163 }
 164
 165 #define DISPATCH(what)                                  \
 166   void                                                  \
 167   Scheme_engraver::what ()                              \
 168   {                                                     \
 169     if (what ## _function_ != SCM_BOOL_F)               \
 170       scm_call_1 (what ## _function_, self_scm ());     \
 171   }
 172
 173 DISPATCH (start_translation_timestep);
 174 DISPATCH (stop_translation_timestep);
 175 DISPATCH (initialize);
 176 DISPATCH (finalize);
 177 DISPATCH (process_music);
 178 DISPATCH (process_acknowledged);
 179
 180 void
 181 Scheme_engraver::derived_mark () const
 182 {
 183   scm_gc_mark (start_translation_timestep_function_);
 184   scm_gc_mark (stop_translation_timestep_function_);
 185   scm_gc_mark (initialize_function_);
 186   scm_gc_mark (finalize_function_);
 187   scm_gc_mark (process_music_function_);
 188   scm_gc_mark (process_acknowledged_function_);
 189   scm_gc_mark (per_instance_listeners_);
 190   scm_gc_mark (interface_acknowledger_hash_);
 191   scm_gc_mark (interface_end_acknowledger_hash_);
 192 }
 193
 194 ADD_ACKNOWLEDGER (Scheme_engraver, grob);
 195 ADD_END_ACKNOWLEDGER (Scheme_engraver, grob);
 196
 197 ADD_TRANSLATOR (Scheme_engraver,
 198                 /* doc */
 199                 "Implement engravers in Scheme.  Interprets arguments to"
 200                 " @code{\\consists} as callbacks.",
 201
 202                 /* create */
 203                 "",
 204
 205                 /* read */
 206                 "",
 207
 208                 /* write */
 209                 ""
 210                );