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