lily/context-property.cc

   1 /*
   2   context-property.cc -- implement manipulation of immutable Grob
   3   property lists.
   4
   5   source file of the GNU LilyPond music typesetter
   6
   7   (c) 2004--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
   8 */
   9
  10 #include "context.hh"
  11 #include "engraver.hh"
  12 #include "international.hh"
  13 #include "item.hh"
  14 #include "main.hh"
  15 #include "simple-closure.hh"
  16 #include "spanner.hh"
  17 #include "warn.hh"
  18
  19
  20 void
  21 general_pushpop_property (Context *context,
  22                           SCM context_property,
  23                           SCM grob_property_path,
  24                           SCM new_value
  25                           )
  26 {
  27   if (!scm_is_symbol (context_property)
  28       || !scm_is_symbol (scm_car (grob_property_path)))
  29     {
  30       warning (_ ("need symbol arguments for \\override and \\revert"));
  31       if (do_internal_type_checking_global)
  32         assert (false);
  33     }
  34
  35   execute_general_pushpop_property (context, context_property,
  36                                     grob_property_path, new_value);
  37 }
  38
  39
  40 /*
  41
  42   Grob descriptions (ie. alists with layout properties) are
  43   represented as a (ALIST . BASED-ON) pair, where BASED-ON is the
  44   alist defined in a parent context. BASED-ON should always be a tail
  45   of ALIST.
  46
  47   Push or pop (depending on value of VAL) a single entry entry from a
  48   translator property list by name of PROP.  GROB_PROPERTY_PATH
  49   indicates nested alists, eg. '(beamed-stem-lengths details)
  50
  51 */
  52
  53
  54 void
  55 execute_override_property (Context *context,
  56                            SCM context_property,
  57                            SCM grob_property_path,
  58                            SCM new_value)
  59 {
  60   SCM current_context_val = SCM_EOL;
  61
  62   Context *where = context->where_defined (context_property,
  63                                            &current_context_val);
  64
  65   /*
  66     Don't mess with MIDI.
  67   */
  68   if (!where)
  69     return;
  70
  71   if (where != context)
  72     {
  73       SCM base = updated_grob_properties (context, context_property);
  74       current_context_val = scm_cons (base, base);
  75       context->set_property (context_property, current_context_val);
  76     }
  77
  78   if (!scm_is_pair (current_context_val))
  79     {
  80       programming_error ("Grob definition should be cons");
  81       return;
  82     }
  83
  84   SCM target_alist = scm_car (current_context_val);
  85
  86   SCM symbol = scm_car (grob_property_path);
  87   if (scm_is_pair (scm_cdr (grob_property_path)))
  88     {
  89       new_value = nested_property_alist (ly_assoc_get (symbol, target_alist,
  90                                                        SCM_EOL),
  91                                          scm_cdr (grob_property_path),
  92                                          new_value);
  93     }
  94
  95   // it's tempting to replace the head of the list if it's the same
  96   // property. However, we have to keep this info around, in case we have to
  97   // \revert back to it.
  98
  99   target_alist = scm_acons (symbol, new_value, target_alist);
 100
 101   bool ok = true;
 102   if (!ly_is_procedure (new_value)
 103       && !is_simple_closure (new_value))
 104     ok = type_check_assignment (symbol, new_value,
 105                                 ly_symbol2scm ("backend-type?"));
 106
 107   /*
 108     tack onto alist.  We can use set_car, since
 109     updated_grob_properties () in child contexts will check
 110     for changes in the car.
 111   */
 112   if (ok)
 113     {
 114       scm_set_car_x (current_context_val, target_alist);
 115     }
 116 }
 117
 118 void
 119 execute_revert_property (Context *context,
 120                          SCM context_property,
 121                          SCM grob_property_path);
 122
 123 void
 124 execute_general_pushpop_property (Context *context,
 125                                   SCM context_property,
 126                                   SCM grob_property_path,
 127                                   SCM new_value
 128                                   )
 129 {
 130   if (new_value != SCM_UNDEFINED)
 131     execute_override_property (context, context_property,
 132                                grob_property_path,
 133                                new_value);
 134   else
 135     execute_revert_property (context, context_property,
 136                              grob_property_path);
 137 }
 138
 139 void
 140 execute_revert_property (Context *context,
 141                          SCM context_property,
 142                          SCM grob_property_path)
 143 {
 144   /*
 145     revert.
 146   */
 147   SCM current_context_val = SCM_EOL;
 148   if (context->where_defined (context_property, &current_context_val) == context)
 149     {
 150       SCM current_alist = scm_car (current_context_val);
 151       SCM daddy = scm_cdr (current_context_val);
 152
 153       if (!scm_is_pair (grob_property_path)
 154           || !scm_is_symbol (scm_car (grob_property_path)))
 155         {
 156           programming_error ("Grob property path should be list of symbols.");
 157           return;
 158         }
 159
 160       SCM symbol = scm_car (grob_property_path);
 161
 162       if (scm_is_pair (scm_cdr (grob_property_path)))
 163         {
 164           SCM current_sub_alist = ly_assoc_get (symbol, current_alist, SCM_EOL);
 165           SCM new_val = nested_property_revert_alist (current_sub_alist, scm_cdr (grob_property_path));
 166
 167           if (scm_is_pair (current_alist)
 168               && scm_caar (current_alist) == symbol
 169               && current_alist != daddy)
 170             current_alist = scm_cdr (current_alist);
 171
 172           current_alist = scm_acons (symbol, new_val, current_alist);
 173           scm_set_car_x (current_context_val, current_alist);
 174         }
 175       else
 176         {
 177           SCM new_alist = evict_from_alist (symbol, current_alist, daddy);
 178
 179           if (new_alist == daddy)
 180             context->unset_property (context_property);
 181           else
 182             context->set_property (context_property, scm_cons (new_alist, daddy));
 183         }
 184     }
 185 }
 186
 187 void
 188 execute_pushpop_property (Context *context,
 189                           SCM context_property,
 190                           SCM grob_property,
 191                           SCM new_value
 192                           )
 193 {
 194   general_pushpop_property (context, context_property,
 195                             scm_list_1 (grob_property),
 196                             new_value);
 197 }
 198
 199 /*
 200   PRE_INIT_OPS is in the order specified, and hence must be reversed.
 201 */
 202 void
 203 apply_property_operations (Context *tg, SCM pre_init_ops)
 204 {
 205   SCM correct_order = scm_reverse (pre_init_ops);
 206   for (SCM s = correct_order; scm_is_pair (s); s = scm_cdr (s))
 207     {
 208       SCM entry = scm_car (s);
 209       SCM type = scm_car (entry);
 210       entry = scm_cdr (entry);
 211
 212       if (type == ly_symbol2scm ("push"))
 213         {
 214           SCM context_prop = scm_car (entry);
 215           SCM val = scm_cadr (entry);
 216           SCM grob_prop_path = scm_cddr (entry);
 217           execute_general_pushpop_property (tg, context_prop, grob_prop_path, val);
 218         }
 219       else if (type == ly_symbol2scm ("pop"))
 220         {
 221           SCM context_prop = scm_car (entry);
 222           SCM val = SCM_UNDEFINED;
 223           SCM grob_prop_path = scm_cdr (entry);
 224           execute_general_pushpop_property (tg, context_prop, grob_prop_path, val);
 225         }
 226       else if (type == ly_symbol2scm ("assign"))
 227         tg->set_property (scm_car (entry), scm_cadr (entry));
 228     }
 229 }
 230
 231 /*
 232   Return the object alist for SYM, checking if its base in enclosing
 233   contexts has changed. The alist is updated if necessary.
 234 */
 235 SCM
 236 updated_grob_properties (Context *tg, SCM sym)
 237 {
 238   assert (scm_is_symbol (sym));
 239
 240   SCM props;
 241   tg = tg->where_defined (sym, &props);
 242   if (!tg)
 243     return SCM_EOL;
 244
 245   SCM daddy_props
 246     = (tg->get_parent_context ())
 247     ? updated_grob_properties (tg->get_parent_context (), sym)
 248     : SCM_EOL;
 249
 250   if (!scm_is_pair (props))
 251     {
 252       programming_error ("grob props not a pair?");
 253       return SCM_EOL;
 254     }
 255
 256   SCM based_on = scm_cdr (props);
 257   if (based_on == daddy_props)
 258     return scm_car (props);
 259   else
 260     {
 261       SCM copy = daddy_props;
 262       SCM *tail = &copy;
 263       SCM p = scm_car (props);
 264       while (p != based_on)
 265         {
 266           *tail = scm_cons (scm_car (p), daddy_props);
 267           tail = SCM_CDRLOC (*tail);
 268           p = scm_cdr (p);
 269         }
 270
 271       scm_set_car_x (props, copy);
 272       scm_set_cdr_x (props, daddy_props);
 273
 274       return copy;
 275     }
 276 }