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