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