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 "program-option.hh"
  17 #include "profile.hh"
  18 #include "unpure-pure-container.hh"
  19 #include "warn.hh"
  20 #include "protected-scm.hh"
  21
  22 Protected_scm grob_property_callback_stack (SCM_EOL);
  23
  24 extern bool debug_property_callbacks;
  25
  26 #ifdef DEBUG
  27 static void
  28 print_property_callback_stack ()
  29 {
  30   int frame = 0;
  31   for (SCM s = grob_property_callback_stack; scm_is_pair (s); s = scm_cdr (s))
  32     message (_f ("%d: %s", frame++, ly_scm_write_string (scm_car (s)).c_str ()));
  33 }
  34 #endif
  35
  36 static Protected_scm modification_callback (SCM_EOL);
  37 static Protected_scm cache_callback (SCM_EOL);
  38
  39 /*
  40 FIXME: this should use ly:set-option interface instead.
  41 */
  42
  43 LY_DEFINE (ly_set_grob_modification_callback, "ly:set-grob-modification-callback",
  44            1, 0, 0, (SCM cb),
  45            "Specify a procedure that will be called every time LilyPond"
  46            " modifies a grob property.  The callback will receive as"
  47            " arguments the grob that is being modified, the name of the"
  48            " C++ file in which the modification was requested, the line"
  49            " number in the C++ file in which the modification was requested,"
  50            " the name of the function in which the modification was"
  51            " requested, the property to be changed, and the new value for"
  52            " the property.")
  53 {
  54   modification_callback = (ly_is_procedure (cb)) ? cb : SCM_BOOL_F;
  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"
  61            " calculates a callback function and caches the result.  The"
  62            " callback will receive as arguments the grob whose property it"
  63            " is, the name of the property, the name of the callback that"
  64            " calculated the property, and the new (cached) value of the"
  65            " property.")
  66 {
  67   cache_callback = (ly_is_procedure (cb)) ? cb : SCM_BOOL_F;
  68   return SCM_UNSPECIFIED;
  69 }
  70
  71 void
  72 Grob::instrumented_set_property (SCM sym, SCM v,
  73                                  char const *file,
  74                                  int line,
  75                                  char const *fun)
  76 {
  77 #ifdef DEBUG
  78   if (ly_is_procedure (modification_callback))
  79     scm_apply_0 (modification_callback,
  80                  scm_list_n (self_scm (),
  81                              scm_from_locale_string (file),
  82                              scm_from_int (line),
  83                              scm_from_ascii_string (fun),
  84                              sym, v, SCM_UNDEFINED));
  85 #else
  86   (void) file;
  87   (void) line;
  88   (void) fun;
  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           && !unsmob<Unpure_pure_container> (v)
 124           && !scm_is_eq (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 #ifdef DEBUG
 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 (scm_is_true (handle))
 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)
 151           && !unsmob<Unpure_pure_container> (val))
 152         type_check_assignment (sym, val, ly_symbol2scm ("backend-type?"));
 153
 154       check_interfaces_for_property (this, sym);
 155     }
 156
 157   return scm_is_false (handle) ? SCM_EOL : scm_cdr (handle);
 158 }
 159
 160 SCM
 161 Grob::internal_get_property (SCM sym) const
 162 {
 163   SCM val = get_property_data (sym);
 164
 165 #ifdef DEBUG
 166   if (scm_is_eq (val, ly_symbol2scm ("calculation-in-progress")))
 167     {
 168       programming_error (to_string ("cyclic dependency: calculation-in-progress encountered for #'%s (%s)",
 169                                     ly_symbol2string (sym).c_str (),
 170                                     name ().c_str ()));//assert (1==0);
 171       if (debug_property_callbacks)
 172         {
 173           message ("backtrace: ");
 174           print_property_callback_stack ();
 175         }
 176     }
 177 #endif
 178
 179   if (Unpure_pure_container *upc = unsmob<Unpure_pure_container> (val))
 180     val = upc->unpure_part ();
 181
 182   if (ly_is_procedure (val))
 183     {
 184       Grob *me = ((Grob *)this);
 185       val = me->try_callback_on_alist (&me->mutable_property_alist_, sym, val);
 186     }
 187
 188   return val;
 189 }
 190
 191 /* Unlike internal_get_property, this function does no caching. Use it, therefore, with caution. */
 192 SCM
 193 Grob::internal_get_pure_property (SCM sym, int start, int end) const
 194 {
 195   SCM val = internal_get_property_data (sym);
 196   if (ly_is_procedure (val))
 197     return call_pure_function (val, scm_list_1 (self_scm ()), start, end);
 198
 199   if (Unpure_pure_container *upc = unsmob<Unpure_pure_container> (val)) {
 200     // Do cache, if the function ignores 'start' and 'end'
 201     if (upc->is_unchanging ())
 202       return internal_get_property (sym);
 203     else
 204       return call_pure_function (val, scm_list_1 (self_scm ()), start, end);
 205   }
 206
 207   return val;
 208 }
 209
 210 SCM
 211 Grob::internal_get_maybe_pure_property (SCM sym, bool pure, int start, int end) const
 212 {
 213   return pure ? internal_get_pure_property (sym, start, end) : internal_get_property (sym);
 214 }
 215
 216 SCM
 217 Grob::try_callback_on_alist (SCM *alist, SCM sym, SCM proc)
 218 {
 219   SCM marker = ly_symbol2scm ("calculation-in-progress");
 220   /*
 221     need to put a value in SYM to ensure that we don't get a
 222     cyclic call chain.
 223   */
 224   *alist = scm_assq_set_x (*alist, sym, marker);
 225
 226 #ifdef DEBUG
 227   if (debug_property_callbacks)
 228     grob_property_callback_stack = scm_cons (scm_list_3 (self_scm (), sym, proc), grob_property_callback_stack);
 229 #endif
 230
 231   SCM value = SCM_EOL;
 232   if (ly_is_procedure (proc))
 233     value = scm_call_1 (proc, self_scm ());
 234
 235 #ifdef DEBUG
 236   if (debug_property_callbacks)
 237     grob_property_callback_stack = scm_cdr (grob_property_callback_stack);
 238 #endif
 239
 240   if (scm_is_eq (value, SCM_UNSPECIFIED))
 241     {
 242       value = get_property_data (sym);
 243       assert (scm_is_null (value) || scm_is_eq (value, marker));
 244       if (scm_is_eq (value, marker))
 245         *alist = scm_assq_remove_x (*alist, sym);
 246     }
 247   else
 248     {
 249 #ifdef DEBUG
 250       if (ly_is_procedure (cache_callback))
 251         scm_apply_0 (cache_callback,
 252                      scm_list_n (self_scm (),
 253                                  sym,
 254                                  proc,
 255                                  value,
 256                                  SCM_UNDEFINED));
 257 #endif
 258       internal_set_value_on_alist (alist, sym, value);
 259     }
 260
 261   return value;
 262 }
 263
 264 void
 265 Grob::internal_set_object (SCM s, SCM v)
 266 {
 267   /* Perhaps we simply do the assq_set, but what the heck. */
 268   if (!is_live ())
 269     return;
 270
 271   object_alist_ = scm_assq_set_x (object_alist_, s, v);
 272 }
 273
 274 void
 275 Grob::internal_del_property (SCM sym)
 276 {
 277   mutable_property_alist_ = scm_assq_remove_x (mutable_property_alist_, sym);
 278 }
 279
 280 SCM
 281 Grob::internal_get_object (SCM sym) const
 282 {
 283   if (profile_property_accesses)
 284     note_property_access (&grob_property_lookup_table, sym);
 285
 286   SCM s = scm_sloppy_assq (sym, object_alist_);
 287
 288   if (scm_is_true (s))
 289     {
 290       SCM val = scm_cdr (s);
 291       if (ly_is_procedure (val)
 292           || unsmob<Unpure_pure_container> (val))
 293         {
 294           Grob *me = ((Grob *)this);
 295           val = me->try_callback_on_alist (&me->object_alist_, sym, val);
 296         }
 297
 298       return val;
 299     }
 300
 301   return SCM_EOL;
 302 }
 303
 304 bool
 305 Grob::is_live () const
 306 {
 307   return scm_is_pair (immutable_property_alist_);
 308 }
 309
 310 bool
 311 Grob::internal_has_interface (SCM k)
 312 {
 313   return scm_is_true (scm_c_memq (k, interfaces_));
 314 }
 315
 316 SCM
 317 call_pure_function (SCM value, SCM args, int start, int end)
 318 {
 319   if (Unpure_pure_container *upc = unsmob<Unpure_pure_container> (value))
 320     {
 321       if (upc->is_unchanging ())
 322         {
 323           // Don't bother forming an Unpure_pure_call here.
 324           value = upc->unpure_part ();
 325
 326           if (ly_is_procedure (value))
 327             return scm_apply_0 (value, args);
 328           return value;
 329         }
 330
 331       value = upc->pure_part ();
 332
 333       if (ly_is_procedure (value))
 334         return scm_apply_3 (value,
 335                             scm_car (args),
 336                             scm_from_int (start),
 337                             scm_from_int (end),
 338                             scm_cdr (args));
 339
 340       return value;
 341     }
 342
 343   if (!ly_is_procedure (value))
 344     return value;
 345
 346   return SCM_BOOL_F;
 347 }