lily/grob-property.cc

   1 /*
   2   Implement storage and manipulation of grob properties.
   3 */
   4
   5 #include <cstring>
   6
   7 #include "main.hh"
   8 #include "input.hh"
   9 #include "pointer-group-interface.hh"
  10 #include "misc.hh"
  11 #include "paper-score.hh"
  12 #include "output-def.hh"
  13 #include "spanner.hh"
  14 #include "international.hh"
  15 #include "item.hh"
  16 #include "misc.hh"
  17 #include "item.hh"
  18 #include "program-option.hh"
  19 #include "profile.hh"
  20 #include "simple-closure.hh"
  21 #include "warn.hh"
  22 #include "protected-scm.hh"
  23
  24 Protected_scm grob_property_callback_stack = SCM_EOL;
  25
  26 #ifndef NDEBUG
  27 extern bool debug_property_callbacks;
  28
  29 static void
  30 print_property_callback_stack ()
  31 {
  32   int frame = 0;
  33   for (SCM s = grob_property_callback_stack; scm_is_pair (s); s = scm_cdr (s))
  34     message (_f ("%d: %s", frame++, ly_scm_write_string (scm_car (s)).c_str ()));
  35 }
  36
  37
  38 static SCM modification_callback = SCM_EOL;
  39 static SCM cache_callback = SCM_EOL;
  40
  41 LY_DEFINE (ly_set_grob_modification_callback, "ly:set-grob-modification-callback",
  42            1, 0, 0, (SCM cb),
  43            "Specify a procedure that will be called every time lilypond modifies "
  44            "a grob property. The callback will receive as arguments "
  45            "the grob that is being modified, "
  46            "the name of the C++ file in which the modification was requested, "
  47            "the line number in the C++ file in which the modification was requested, "
  48            "the name of the function in which the modification was requested, "
  49            "the property to be changed and "
  50            "the new value for the property.")
  51 {
  52   LY_ASSERT_TYPE (ly_is_procedure, cb, 1);
  53
  54   modification_callback = cb;
  55   return SCM_UNSPECIFIED;
  56 }
  57
  58 LY_DEFINE (ly_set_property_cache_callback, "ly:set-property-cache-callback",
  59            1, 0, 0, (SCM cb),
  60            "Specify a procedure that will be called whenever lilypond calculates "
  61            "a callback function and caches the result. The callback will "
  62            "receive as arguments "
  63            "the grob whose property it is, "
  64            "the name of the property, "
  65            "the name of the callback that calculated the property and "
  66            "the new (cached) value of the property.")
  67 {
  68   LY_ASSERT_TYPE (ly_is_procedure, cb, 1);
  69
  70   cache_callback = cb;
  71   return SCM_UNSPECIFIED;
  72 }
  73 #endif
  74
  75 void
  76 Grob::instrumented_set_property (SCM sym, SCM v,
  77                                  char const *file,
  78                                  int line,
  79                                  char const *fun)
  80 {
  81 #ifndef NDEBUG
  82   if (ly_is_procedure (modification_callback))
  83     scm_apply_0 (modification_callback,
  84                  scm_list_n (self_scm (),
  85                              scm_from_locale_string (file),
  86                              scm_from_int (line),
  87                              scm_from_locale_string (fun),
  88                              sym, v, SCM_UNDEFINED));
  89 #else
  90   (void) file;
  91   (void) line;
  92   (void) fun;
  93 #endif
  94
  95   internal_set_property (sym, v);
  96 }
  97
  98 SCM
  99 Grob::get_property_alist_chain (SCM def) const
 100 {
 101   return scm_list_n (mutable_property_alist_,
 102                      immutable_property_alist_,
 103                      def,
 104                      SCM_UNDEFINED);
 105 }
 106
 107 extern void check_interfaces_for_property (Grob const *me, SCM sym);
 108
 109 void
 110 Grob::internal_set_property (SCM sym, SCM v)
 111 {
 112   internal_set_value_on_alist (&mutable_property_alist_,
 113                                sym, v);
 114
 115 }
 116
 117 void
 118 Grob::internal_set_value_on_alist (SCM *alist, SCM sym, SCM v)
 119 {
 120   /* Perhaps we simply do the assq_set, but what the heck. */
 121   if (!is_live ())
 122     return;
 123
 124   if (do_internal_type_checking_global)
 125     {
 126       if (!ly_is_procedure (v)
 127           && !is_simple_closure (v)
 128           && v != ly_symbol2scm ("calculation-in-progress"))
 129         type_check_assignment (sym, v, ly_symbol2scm ("backend-type?"));
 130
 131       check_interfaces_for_property (this, sym);
 132     }
 133
 134   *alist = scm_assq_set_x (*alist, sym, v);
 135 }
 136
 137 SCM
 138 Grob::internal_get_property_data (SCM sym) const
 139 {
 140 #ifndef NDEBUG
 141   if (profile_property_accesses)
 142     note_property_access (&grob_property_lookup_table, sym);
 143 #endif
 144
 145   SCM handle = scm_sloppy_assq (sym, mutable_property_alist_);
 146   if (handle != SCM_BOOL_F)
 147     return scm_cdr (handle);
 148
 149   handle = scm_sloppy_assq (sym, immutable_property_alist_);
 150
 151   if (do_internal_type_checking_global && scm_is_pair (handle))
 152     {
 153       SCM val = scm_cdr (handle);
 154       if (!ly_is_procedure (val) && !is_simple_closure (val))
 155         type_check_assignment (sym, val, ly_symbol2scm ("backend-type?"));
 156
 157       check_interfaces_for_property (this, sym);
 158     }
 159
 160   return (handle == SCM_BOOL_F) ? SCM_EOL : scm_cdr (handle);
 161 }
 162
 163 SCM
 164 Grob::internal_get_property (SCM sym) const
 165 {
 166   SCM val = get_property_data (sym);
 167
 168 #ifndef NDEBUG
 169   if (val == ly_symbol2scm ("calculation-in-progress"))
 170     {
 171       programming_error (_f ("cyclic dependency: calculation-in-progress encountered for #'%s (%s)",
 172                              ly_symbol2string (sym).c_str (),
 173                              name ().c_str ()));
 174       if (debug_property_callbacks)
 175         {
 176           message ("backtrace: ");
 177           print_property_callback_stack ();
 178         }
 179     }
 180 #endif
 181
 182   if (ly_is_procedure (val)
 183       || is_simple_closure (val))
 184     {
 185       Grob *me = ((Grob*)this);
 186       val = me->try_callback_on_alist (&me->mutable_property_alist_, sym, val);
 187     }
 188
 189   return val;
 190 }
 191
 192 SCM
 193 Grob::try_callback_on_alist (SCM *alist, SCM sym, SCM proc)
 194 {
 195   SCM marker = ly_symbol2scm ("calculation-in-progress");
 196   /*
 197     need to put a value in SYM to ensure that we don't get a
 198     cyclic call chain.
 199   */
 200   *alist = scm_assq_set_x (*alist, sym, marker);
 201
 202 #ifndef NDEBUG
 203   if (debug_property_callbacks)
 204     grob_property_callback_stack = scm_cons (scm_list_3 (self_scm (), sym, proc), grob_property_callback_stack);
 205 #endif
 206
 207   SCM value = SCM_EOL;
 208   if (ly_is_procedure (proc))
 209     value = scm_call_1 (proc, self_scm ());
 210   else if (is_simple_closure (proc))
 211     {
 212       value = evaluate_with_simple_closure (self_scm (),
 213                                             simple_closure_expression (proc),
 214                                             false, 0, 0);
 215     }
 216
 217 #ifndef NDEBUG
 218   if (debug_property_callbacks)
 219     grob_property_callback_stack = scm_cdr (grob_property_callback_stack);
 220 #endif
 221
 222   /*
 223     If the function returns SCM_UNSPECIFIED, we assume the
 224     property has been set with an explicit set_property ()
 225     call.
 226   */
 227   if (value == SCM_UNSPECIFIED)
 228     {
 229       value = get_property_data (sym);
 230       assert (value == SCM_EOL || value == marker);
 231       if (value == marker)
 232         *alist = scm_assq_remove_x (*alist, marker);
 233     }
 234   else
 235     {
 236 #ifndef NDEBUG
 237       if (ly_is_procedure (cache_callback))
 238         scm_apply_0 (cache_callback,
 239                      scm_list_n (self_scm (),
 240                                  sym,
 241                                  proc,
 242                                  value,
 243                                  SCM_UNDEFINED));
 244 #endif
 245       internal_set_value_on_alist (alist, sym, value);
 246     }
 247
 248   return value;
 249 }
 250
 251 void
 252 Grob::internal_set_object (SCM s, SCM v)
 253 {
 254   /* Perhaps we simply do the assq_set, but what the heck. */
 255   if (!is_live ())
 256     return;
 257
 258   object_alist_ = scm_assq_set_x (object_alist_, s, v);
 259 }
 260
 261 void
 262 Grob::internal_del_property (SCM sym)
 263 {
 264   mutable_property_alist_ = scm_assq_remove_x (mutable_property_alist_, sym);
 265 }
 266
 267 SCM
 268 Grob::internal_get_object (SCM sym) const
 269 {
 270   if (profile_property_accesses)
 271     note_property_access (&grob_property_lookup_table, sym);
 272
 273   SCM s = scm_sloppy_assq (sym, object_alist_);
 274
 275   if (s != SCM_BOOL_F)
 276     {
 277       SCM val = scm_cdr (s);
 278       if (ly_is_procedure (val)
 279           || is_simple_closure (val))
 280         {
 281           Grob *me = ((Grob*)this);
 282           val = me->try_callback_on_alist (&me->object_alist_, sym, val);
 283         }
 284
 285       return val;
 286     }
 287
 288   return SCM_EOL;
 289 }
 290
 291 bool
 292 Grob::is_live () const
 293 {
 294   return scm_is_pair (immutable_property_alist_);
 295 }
 296
 297 bool
 298 Grob::internal_has_interface (SCM k)
 299 {
 300   return scm_c_memq (k, interfaces_) != SCM_BOOL_F;
 301 }
 302
 303 SCM
 304 call_pure_function (SCM unpure, SCM args, int start, int end)
 305 {
 306   SCM scm_call_pure_function = ly_lily_module_constant ("call-pure-function");
 307
 308   return scm_apply_0 (scm_call_pure_function,
 309                       scm_list_4 (unpure, args, scm_from_int (start), scm_from_int (end)));
 310 }
 311