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   SCM parent_alist = scm_cdr (current_context_val);
  86
  87   SCM symbol = scm_car (grob_property_path);
  88   if (scm_is_pair (scm_cdr (grob_property_path)))
  89     {
  90       new_value = nested_property_alist (ly_assoc_get (symbol, target_alist,
  91                                                        SCM_EOL),
  92                                          scm_cdr (grob_property_path),
  93                                          new_value);
  94     }
  95
  96   if (scm_is_pair (target_alist)
  97       && scm_caar (target_alist) == symbol
  98       && target_alist != parent_alist)
  99     target_alist = scm_cdr (target_alist);
 100
 101   target_alist = scm_acons (symbol, new_value, target_alist);
 102
 103   bool ok = true;
 104   if (!ly_is_procedure (new_value)
 105       && !is_simple_closure (new_value))
 106     ok = type_check_assignment (symbol, new_value,
 107                                 ly_symbol2scm ("backend-type?"));
 108
 109   /*
 110     tack onto alist.  We can use set_car, since
 111     updated_grob_properties () in child contexts will check
 112     for changes in the car.
 113   */
 114   if (ok)
 115     {
 116       scm_set_car_x (current_context_val, target_alist);
 117     }
 118 }
 119
 120 void
 121 execute_revert_property (Context *context,
 122                          SCM context_property,
 123                          SCM grob_property_path);
 124
 125 void
 126 execute_general_pushpop_property (Context *context,
 127                                   SCM context_property,
 128                                   SCM grob_property_path,
 129                                   SCM new_value
 130                                   )
 131 {
 132   if (new_value != SCM_UNDEFINED)
 133     execute_override_property (context, context_property,
 134                                grob_property_path,
 135                                new_value);
 136   else
 137     execute_revert_property (context, context_property,
 138                              grob_property_path);
 139 }
 140
 141 void
 142 execute_revert_property (Context *context,
 143                          SCM context_property,
 144                          SCM grob_property_path)
 145 {
 146   /*
 147     revert.
 148   */
 149   SCM current_context_val = SCM_EOL;
 150   if (context->where_defined (context_property, &current_context_val) == context)
 151     {
 152       SCM current_alist = scm_car (current_context_val);
 153       SCM daddy = scm_cdr (current_context_val);
 154
 155       if (!scm_is_pair (grob_property_path)
 156           || !scm_is_symbol (scm_car (grob_property_path)))
 157         {
 158           programming_error ("Grob property path should be list of symbols.");
 159           return;
 160         }
 161
 162       SCM symbol = scm_car (grob_property_path);
 163
 164       if (scm_is_pair (scm_cdr (grob_property_path)))
 165         {
 166           SCM current_sub_alist = ly_assoc_get (symbol, current_alist, SCM_EOL);
 167           SCM new_val = nested_property_revert_alist (current_sub_alist, scm_cdr (grob_property_path));
 168
 169           if (scm_is_pair (current_alist)
 170               && scm_caar (current_alist) == symbol
 171               && current_alist != daddy)
 172             current_alist = scm_cdr (current_alist);
 173
 174           current_alist = scm_acons (symbol, new_val, current_alist);
 175           scm_set_car_x (current_context_val, current_alist);
 176         }
 177       else
 178         {
 179           SCM new_alist = evict_from_alist (symbol, current_alist, daddy);
 180
 181           if (new_alist == daddy)
 182             context->unset_property (context_property);
 183           else
 184             context->set_property (context_property, scm_cons (new_alist, daddy));
 185         }
 186     }
 187 }
 188
 189 void
 190 execute_pushpop_property (Context *context,
 191                           SCM context_property,
 192                           SCM grob_property,
 193                           SCM new_value
 194                           )
 195 {
 196   general_pushpop_property (context, context_property,
 197                             scm_list_1 (grob_property),
 198                             new_value);
 199 }
 200
 201 /*
 202   PRE_INIT_OPS is in the order specified, and hence must be reversed.
 203 */
 204 void
 205 apply_property_operations (Context *tg, SCM pre_init_ops)
 206 {
 207   SCM correct_order = scm_reverse (pre_init_ops);
 208   for (SCM s = correct_order; scm_is_pair (s); s = scm_cdr (s))
 209     {
 210       SCM entry = scm_car (s);
 211       SCM type = scm_car (entry);
 212       entry = scm_cdr (entry);
 213
 214       if (type == ly_symbol2scm ("push"))
 215         {
 216           SCM context_prop = scm_car (entry);
 217           SCM val = scm_cadr (entry);
 218           SCM grob_prop_path = scm_cddr (entry);
 219           execute_general_pushpop_property (tg, context_prop, grob_prop_path, val);
 220         }
 221       else if (type == ly_symbol2scm ("pop"))
 222         {
 223           SCM context_prop = scm_car (entry);
 224           SCM val = SCM_UNDEFINED;
 225           SCM grob_prop_path = scm_cdr (entry);
 226           execute_general_pushpop_property (tg, context_prop, grob_prop_path, val);
 227         }
 228       else if (type == ly_symbol2scm ("assign"))
 229         tg->set_property (scm_car (entry), scm_cadr (entry));
 230     }
 231 }
 232
 233 /*
 234   Return the object alist for SYM, checking if its base in enclosing
 235   contexts has changed. The alist is updated if necessary.
 236 */
 237 SCM
 238 updated_grob_properties (Context *tg, SCM sym)
 239 {
 240   assert (scm_is_symbol (sym));
 241
 242   SCM props;
 243   tg = tg->where_defined (sym, &props);
 244   if (!tg)
 245     return SCM_EOL;
 246
 247   SCM daddy_props
 248     = (tg->get_parent_context ())
 249     ? updated_grob_properties (tg->get_parent_context (), sym)
 250     : SCM_EOL;
 251
 252   if (!scm_is_pair (props))
 253     {
 254       programming_error ("grob props not a pair?");
 255       return SCM_EOL;
 256     }
 257
 258   SCM based_on = scm_cdr (props);
 259   if (based_on == daddy_props)
 260     return scm_car (props);
 261   else
 262     {
 263       SCM copy = daddy_props;
 264       SCM *tail = &copy;
 265       SCM p = scm_car (props);
 266       while (p != based_on)
 267         {
 268           *tail = scm_cons (scm_car (p), daddy_props);
 269           tail = SCM_CDRLOC (*tail);
 270           p = scm_cdr (p);
 271         }
 272
 273       scm_set_car_x (props, copy);
 274       scm_set_cdr_x (props, daddy_props);
 275
 276       return copy;
 277     }
 278 }