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   copy ALIST leaving out SYMBOL. Copying stops at ALIST_END
  21 */
  22 SCM
  23 evict_from_alist (SCM symbol,
  24                   SCM alist,
  25                   SCM alist_end)
  26 {
  27   SCM new_alist = SCM_EOL;
  28   SCM *tail = &new_alist;
  29
  30   while (alist != alist_end)
  31     {
  32       if (ly_is_equal (scm_caar (alist), symbol))
  33         {
  34           alist = scm_cdr (alist);
  35           break;
  36         }
  37
  38       *tail = scm_cons (scm_car (alist), SCM_EOL);
  39       tail = SCM_CDRLOC (*tail);
  40       alist = scm_cdr (alist);
  41     }
  42
  43   *tail = alist;
  44   return new_alist;
  45 }
  46
  47 void
  48 general_pushpop_property (Context *context,
  49                           SCM context_property,
  50                           SCM grob_property_path,
  51                           SCM new_value
  52                           )
  53 {
  54   if (!scm_is_symbol (context_property)
  55       || !scm_is_symbol (scm_car (grob_property_path)))
  56     {
  57       warning (_ ("need symbol arguments for \\override and \\revert"));
  58       if (do_internal_type_checking_global)
  59         assert (false);
  60     }
  61
  62   execute_general_pushpop_property (context, context_property,
  63                                     grob_property_path, new_value);
  64 }
  65
  66
  67 /*
  68
  69   Grob descriptions (ie. alists with layout properties) are
  70   represented as a (ALIST . BASED-ON) pair, where BASED-ON is the
  71   alist defined in a parent context. BASED-ON should always be a tail
  72   of ALIST.
  73
  74   Push or pop (depending on value of VAL) a single entry entry from a
  75   translator property list by name of PROP.  GROB_PROPERTY_PATH
  76   indicates nested alists, eg. '(beamed-stem-lengths details)
  77
  78 */
  79
  80
  81 void
  82 execute_override_property (Context *context,
  83                            SCM context_property,
  84                            SCM grob_property_path,
  85                            SCM new_value)
  86 {
  87   SCM current_context_val = SCM_EOL;
  88
  89   Context *where = context->where_defined (context_property,
  90                                            &current_context_val);
  91
  92   /*
  93     Don't mess with MIDI.
  94   */
  95   if (!where)
  96     return;
  97
  98   if (where != context)
  99     {
 100       SCM base = updated_grob_properties (context, context_property);
 101       current_context_val = scm_cons (base, base);
 102       context->set_property (context_property, current_context_val);
 103     }
 104
 105   if (!scm_is_pair (current_context_val))
 106     {
 107       programming_error ("Grob definition should be cons");
 108       return;
 109     }
 110
 111   SCM symbol = scm_car (grob_property_path);
 112   SCM target_alist = scm_car (current_context_val);
 113   if (scm_is_pair (scm_cdr (grob_property_path)))
 114     {
 115       new_value = nested_property_alist (ly_assoc_get (symbol, target_alist,
 116                                                        SCM_EOL),
 117                                          scm_cdr (grob_property_path),
 118                                          new_value);
 119     }
 120
 121   if (scm_is_pair (target_alist)
 122       && scm_caar (target_alist) == symbol)
 123     target_alist = scm_cdr (target_alist);
 124
 125   target_alist = scm_acons (symbol, new_value, target_alist);
 126
 127   bool ok = true;
 128   if (!ly_is_procedure (new_value)
 129       && !is_simple_closure (new_value))
 130     ok = type_check_assignment (symbol, new_value,
 131                                 ly_symbol2scm ("backend-type?"));
 132
 133   /*
 134     tack onto alist.  We can use set_car, since
 135     updated_grob_properties () in child contexts will check
 136     for changes in the car.
 137   */
 138   if (ok)
 139     {
 140       scm_set_car_x (current_context_val, target_alist);
 141     }
 142 }
 143
 144
 145 void
 146 execute_general_pushpop_property (Context *context,
 147                                   SCM context_property,
 148                                   SCM grob_property_path,
 149                                   SCM new_value
 150                                   )
 151 {
 152   if (new_value != SCM_UNDEFINED)
 153     {
 154       execute_override_property (context, context_property,
 155                                  grob_property_path,
 156                                  new_value);
 157
 158       return;
 159     }
 160
 161   /*
 162     revert.
 163    */
 164   SCM current_context_val = SCM_EOL;
 165   if (context->where_defined (context_property, &current_context_val) == context)
 166     {
 167       SCM current_value = scm_car (current_context_val);
 168       SCM daddy = scm_cdr (current_context_val);
 169
 170       if (!scm_is_pair (grob_property_path)
 171           || !scm_is_symbol (scm_car (grob_property_path)))
 172         {
 173           programming_error ("Grob property path should be list of symbols.");
 174           return;
 175         }
 176
 177       SCM symbol = scm_car (grob_property_path);
 178       SCM new_alist = evict_from_alist (symbol, current_value, daddy);
 179
 180       if (new_alist == daddy)
 181         context->unset_property (context_property);
 182       else
 183         context->set_property (context_property, scm_cons (new_alist, daddy));
 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 }