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