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