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   like execute_general_pushpop_property(), but typecheck
  21   grob_property_path and context_property.
  22 */
  23 void
  24 general_pushpop_property (Context *context,
  25                           SCM context_property,
  26                           SCM grob_property_path,
  27                           SCM new_value)
  28 {
  29   if (!scm_is_symbol (context_property)
  30       || !scm_is_symbol (scm_car (grob_property_path)))
  31     {
  32       warning (_ ("need symbol arguments for \\override and \\revert"));
  33       if (do_internal_type_checking_global)
  34         assert (false);
  35     }
  36
  37   execute_general_pushpop_property (context, context_property,
  38                                     grob_property_path, new_value);
  39 }
  40
  41
  42 /*
  43
  44   Grob descriptions (ie. alists with layout properties) are
  45   represented as a (ALIST . BASED-ON) pair, where BASED-ON is the
  46   alist defined in a parent context. BASED-ON should always be a tail
  47   of ALIST.
  48
  49   Push or pop (depending on value of VAL) a single entry entry from a
  50   translator property list by name of PROP.  GROB_PROPERTY_PATH
  51   indicates nested alists, eg. '(beamed-stem-lengths details)
  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_general_pushpop_property (Context *context,
 120                                   SCM context_property,
 121                                   SCM grob_property_path,
 122                                   SCM new_value)
 123 {
 124   if (new_value != SCM_UNDEFINED)
 125     execute_override_property (context, context_property,
 126                                grob_property_path,
 127                                new_value);
 128   else
 129     execute_revert_property (context, context_property,
 130                              grob_property_path);
 131 }
 132
 133 void
 134 execute_revert_property (Context *context,
 135                          SCM context_property,
 136                          SCM grob_property_path)
 137 {
 138   /*
 139     revert.
 140   */
 141   SCM current_context_val = SCM_EOL;
 142   if (context->where_defined (context_property, &current_context_val) == context)
 143     {
 144       SCM current_alist = scm_car (current_context_val);
 145       SCM daddy = scm_cdr (current_context_val);
 146
 147       if (!scm_is_pair (grob_property_path)
 148           || !scm_is_symbol (scm_car (grob_property_path)))
 149         {
 150           programming_error ("Grob property path should be list of symbols.");
 151           return;
 152         }
 153
 154       SCM symbol = scm_car (grob_property_path);
 155
 156       if (scm_is_pair (scm_cdr (grob_property_path)))
 157         {
 158           SCM current_sub_alist = ly_assoc_get (symbol, current_alist, SCM_EOL);
 159           SCM new_val
 160             = nested_property_revert_alist (current_sub_alist,
 161                                             scm_cdr (grob_property_path));
 162
 163           if (scm_is_pair (current_alist)
 164               && scm_caar (current_alist) == symbol
 165               && current_alist != daddy)
 166             current_alist = scm_cdr (current_alist);
 167
 168           current_alist = scm_acons (symbol, new_val, current_alist);
 169           scm_set_car_x (current_context_val, current_alist);
 170         }
 171       else
 172         {
 173           SCM new_alist = evict_from_alist (symbol, current_alist, daddy);
 174
 175           if (new_alist == daddy)
 176             context->unset_property (context_property);
 177           else
 178             context->set_property (context_property,
 179                                    scm_cons (new_alist, daddy));
 180         }
 181     }
 182 }
 183
 184 void
 185 execute_pushpop_property (Context *context,
 186                           SCM context_property,
 187                           SCM grob_property,
 188                           SCM new_value
 189                           )
 190 {
 191   general_pushpop_property (context, context_property,
 192                             scm_list_1 (grob_property),
 193                             new_value);
 194 }
 195
 196 /*
 197   PRE_INIT_OPS is in the order specified, and hence must be reversed.
 198 */
 199 void
 200 apply_property_operations (Context *tg, SCM pre_init_ops)
 201 {
 202   SCM correct_order = scm_reverse (pre_init_ops);
 203   for (SCM s = correct_order; scm_is_pair (s); s = scm_cdr (s))
 204     {
 205       SCM entry = scm_car (s);
 206       SCM type = scm_car (entry);
 207       entry = scm_cdr (entry);
 208
 209       if (type == ly_symbol2scm ("push"))
 210         {
 211           SCM context_prop = scm_car (entry);
 212           SCM val = scm_cadr (entry);
 213           SCM grob_prop_path = scm_cddr (entry);
 214           execute_general_pushpop_property (tg, context_prop, grob_prop_path, val);
 215         }
 216       else if (type == ly_symbol2scm ("pop"))
 217         {
 218           SCM context_prop = scm_car (entry);
 219           SCM val = SCM_UNDEFINED;
 220           SCM grob_prop_path = scm_cdr (entry);
 221           execute_general_pushpop_property (tg, context_prop, grob_prop_path, val);
 222         }
 223       else if (type == ly_symbol2scm ("assign"))
 224         tg->set_property (scm_car (entry), scm_cadr (entry));
 225     }
 226 }
 227
 228 /*
 229   Return the object alist for SYM, checking if its base in enclosing
 230   contexts has changed. The alist is updated if necessary.
 231 */
 232 SCM
 233 updated_grob_properties (Context *tg, SCM sym)
 234 {
 235   assert (scm_is_symbol (sym));
 236
 237   SCM props;
 238   tg = tg->where_defined (sym, &props);
 239   if (!tg)
 240     return SCM_EOL;
 241
 242   SCM daddy_props
 243     = (tg->get_parent_context ())
 244     ? updated_grob_properties (tg->get_parent_context (), sym)
 245     : SCM_EOL;
 246
 247   if (!scm_is_pair (props))
 248     {
 249       programming_error ("grob props not a pair?");
 250       return SCM_EOL;
 251     }
 252
 253   SCM based_on = scm_cdr (props);
 254   if (based_on == daddy_props)
 255     return scm_car (props);
 256   else
 257     {
 258       SCM copy = daddy_props;
 259       SCM *tail = &copy;
 260       SCM p = scm_car (props);
 261       while (p != based_on)
 262         {
 263           *tail = scm_cons (scm_car (p), daddy_props);
 264           tail = SCM_CDRLOC (*tail);
 265           p = scm_cdr (p);
 266         }
 267
 268       scm_set_car_x (props, copy);
 269       scm_set_cdr_x (props, daddy_props);
 270
 271       return copy;
 272     }
 273 }