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