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