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
  74 void
  75 Grob::instrumented_set_property (SCM sym, SCM v,
  76                                  char const *file,
  77                                  int line,
  78                                  char const *fun)
  79 {
  80   if (ly_is_procedure (modification_callback))
  81     scm_apply_0 (modification_callback,
  82                  scm_list_n (self_scm (),
  83                              scm_from_locale_string (file),
  84                              scm_from_int (line),
  85                              scm_from_locale_string (fun),
  86                              sym, v, SCM_UNDEFINED));
  87   internal_set_property (sym, v);
  88 }
  89 #endif
  90
  91 SCM
  92 Grob::get_property_alist_chain (SCM def) const
  93 {
  94   return scm_list_n (mutable_property_alist_,
  95                      immutable_property_alist_,
  96                      def,
  97                      SCM_UNDEFINED);
  98 }
  99
 100 extern void check_interfaces_for_property (Grob const *me, SCM sym);
 101
 102 void
 103 Grob::internal_set_property (SCM sym, SCM v)
 104 {
 105   internal_set_value_on_alist (&mutable_property_alist_,
 106                                sym, v);
 107
 108 }
 109
 110 void
 111 Grob::internal_set_value_on_alist (SCM *alist, SCM sym, SCM v)
 112 {
 113   /* Perhaps we simply do the assq_set, but what the heck. */
 114   if (!is_live ())
 115     return;
 116
 117   if (do_internal_type_checking_global)
 118     {
 119       if (!ly_is_procedure (v)
 120           && !is_simple_closure (v)
 121           && v != ly_symbol2scm ("calculation-in-progress"))
 122         type_check_assignment (sym, v, ly_symbol2scm ("backend-type?"));
 123
 124       check_interfaces_for_property (this, sym);
 125     }
 126
 127   *alist = scm_assq_set_x (*alist, sym, v);
 128 }
 129
 130 SCM
 131 Grob::internal_get_property_data (SCM sym) const
 132 {
 133 #ifndef NDEBUG
 134   if (profile_property_accesses)
 135     note_property_access (&grob_property_lookup_table, sym);
 136 #endif
 137
 138   SCM handle = scm_sloppy_assq (sym, mutable_property_alist_);
 139   if (handle != SCM_BOOL_F)
 140     return scm_cdr (handle);
 141
 142   handle = scm_sloppy_assq (sym, immutable_property_alist_);
 143
 144   if (do_internal_type_checking_global && scm_is_pair (handle))
 145     {
 146       SCM val = scm_cdr (handle);
 147       if (!ly_is_procedure (val) && !is_simple_closure (val))
 148         type_check_assignment (sym, val, ly_symbol2scm ("backend-type?"));
 149
 150       check_interfaces_for_property (this, sym);
 151     }
 152
 153   return (handle == SCM_BOOL_F) ? SCM_EOL : scm_cdr (handle);
 154 }
 155
 156 SCM
 157 Grob::internal_get_property (SCM sym) const
 158 {
 159   SCM val = get_property_data (sym);
 160
 161 #ifndef NDEBUG
 162   if (val == ly_symbol2scm ("calculation-in-progress"))
 163     {
 164       programming_error (_f ("cyclic dependency: calculation-in-progress encountered for #'%s (%s)",
 165                              ly_symbol2string (sym).c_str (),
 166                              name ().c_str ()));
 167       if (debug_property_callbacks)
 168         {
 169           message ("backtrace: ");
 170           print_property_callback_stack ();
 171         }
 172     }
 173 #endif
 174
 175   if (ly_is_procedure (val)
 176       || is_simple_closure (val))
 177     {
 178       Grob *me = ((Grob*)this);
 179       val = me->try_callback_on_alist (&me->mutable_property_alist_, sym, val);
 180     }
 181
 182   return val;
 183 }
 184
 185 SCM
 186 Grob::try_callback_on_alist (SCM *alist, SCM sym, SCM proc)
 187 {
 188   SCM marker = ly_symbol2scm ("calculation-in-progress");
 189   /*
 190     need to put a value in SYM to ensure that we don't get a
 191     cyclic call chain.
 192   */
 193   *alist = scm_assq_set_x (*alist, sym, marker);
 194
 195 #ifndef NDEBUG
 196   if (debug_property_callbacks)
 197     grob_property_callback_stack = scm_cons (scm_list_3 (self_scm (), sym, proc), grob_property_callback_stack);
 198 #endif
 199
 200   SCM value = SCM_EOL;
 201   if (ly_is_procedure (proc))
 202     value = scm_call_1 (proc, self_scm ());
 203   else if (is_simple_closure (proc))
 204     {
 205       value = evaluate_with_simple_closure (self_scm (),
 206                                             simple_closure_expression (proc),
 207                                             false, 0, 0);
 208     }
 209
 210 #ifndef NDEBUG
 211   if (debug_property_callbacks)
 212     grob_property_callback_stack = scm_cdr (grob_property_callback_stack);
 213 #endif
 214
 215   /*
 216     If the function returns SCM_UNSPECIFIED, we assume the
 217     property has been set with an explicit set_property ()
 218     call.
 219   */
 220   if (value == SCM_UNSPECIFIED)
 221     {
 222       value = get_property_data (sym);
 223       assert (value == SCM_EOL || value == marker);
 224       if (value == marker)
 225         *alist = scm_assq_remove_x (*alist, marker);
 226     }
 227   else
 228     {
 229 #ifndef NDEBUG
 230       if (ly_is_procedure (cache_callback))
 231         scm_apply_0 (cache_callback,
 232                      scm_list_n (self_scm (),
 233                                  sym,
 234                                  proc,
 235                                  value,
 236                                  SCM_UNDEFINED));
 237 #endif
 238       internal_set_value_on_alist (alist, sym, value);
 239     }
 240
 241   return value;
 242 }
 243
 244 void
 245 Grob::internal_set_object (SCM s, SCM v)
 246 {
 247   /* Perhaps we simply do the assq_set, but what the heck. */
 248   if (!is_live ())
 249     return;
 250
 251   object_alist_ = scm_assq_set_x (object_alist_, s, v);
 252 }
 253
 254 void
 255 Grob::internal_del_property (SCM sym)
 256 {
 257   mutable_property_alist_ = scm_assq_remove_x (mutable_property_alist_, sym);
 258 }
 259
 260 SCM
 261 Grob::internal_get_object (SCM sym) const
 262 {
 263   if (profile_property_accesses)
 264     note_property_access (&grob_property_lookup_table, sym);
 265
 266   SCM s = scm_sloppy_assq (sym, object_alist_);
 267
 268   if (s != SCM_BOOL_F)
 269     {
 270       SCM val = scm_cdr (s);
 271       if (ly_is_procedure (val)
 272           || is_simple_closure (val))
 273         {
 274           Grob *me = ((Grob*)this);
 275           val = me->try_callback_on_alist (&me->object_alist_, sym, val);
 276         }
 277
 278       return val;
 279     }
 280
 281   return SCM_EOL;
 282 }
 283
 284 bool
 285 Grob::is_live () const
 286 {
 287   return scm_is_pair (immutable_property_alist_);
 288 }
 289
 290 bool
 291 Grob::internal_has_interface (SCM k)
 292 {
 293   return scm_c_memq (k, interfaces_) != SCM_BOOL_F;
 294 }
 295
 296 SCM
 297 call_pure_function (SCM unpure, SCM args, int start, int end)
 298 {
 299   SCM scm_call_pure_function = ly_lily_module_constant ("call-pure-function");
 300
 301   return scm_apply_0 (scm_call_pure_function,
 302                       scm_list_4 (unpure, args, scm_from_int (start), scm_from_int (end)));
 303 }
 304