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