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--2006 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 "paper-column.hh"
  16 #include "simple-closure.hh"
  17 #include "spanner.hh"
  18 #include "warn.hh"
  19
  20 SCM
  21 lookup_nested_property (SCM alist,
  22                         SCM grob_property_path)
  23 {
  24   if (scm_is_pair (grob_property_path))
  25     {
  26       SCM sym = scm_car (grob_property_path);
  27       SCM handle = scm_assq (sym, alist);
  28
  29       if (handle == SCM_BOOL_F)
  30         return SCM_EOL;
  31       else
  32         return lookup_nested_property (scm_cdr (handle),
  33                                        scm_cdr (grob_property_path));
  34     }
  35   else
  36     return alist;
  37 }
  38
  39 /*
  40   copy ALIST leaving out SYMBOL. Copying stops at ALIST_END
  41 */
  42 SCM
  43 evict_from_alist (SCM symbol,
  44                   SCM alist,
  45                   SCM alist_end)
  46 {
  47   SCM new_alist = SCM_EOL;
  48   SCM *tail = &new_alist;
  49
  50   while (alist != alist_end)
  51     {
  52       if (ly_is_equal (scm_caar (alist), symbol))
  53         {
  54           alist = scm_cdr (alist);
  55           break;
  56         }
  57
  58       *tail = scm_cons (scm_car (alist), SCM_EOL);
  59       tail = SCM_CDRLOC (*tail);
  60       alist = scm_cdr (alist);
  61     }
  62
  63   *tail = alist;
  64   return new_alist;
  65 }
  66
  67 void
  68 general_pushpop_property (Context *context,
  69                           SCM context_property,
  70                           SCM grob_property_path,
  71                           SCM new_value
  72                           )
  73 {
  74   if (!scm_is_symbol (context_property)
  75       || !scm_is_symbol (scm_car (grob_property_path)))
  76     {
  77       warning (_ ("need symbol arguments for \\override and \\revert"));
  78       if (do_internal_type_checking_global)
  79         assert (false);
  80     }
  81
  82   execute_general_pushpop_property (context, context_property,
  83                                     grob_property_path, new_value);
  84 }
  85
  86
  87 /*
  88
  89   Grob descriptions (ie. alists with layout properties) are
  90   represented as a (ALIST . BASED-ON) pair, where BASED-ON is the
  91   alist defined in a parent context. BASED-ON should always be a tail
  92   of ALIST.
  93
  94   Push or pop (depending on value of VAL) a single entry entry from a
  95   translator property list by name of PROP.  GROB_PROPERTY_PATH
  96   indicates nested alists, eg. '(beamed-stem-lengths details)
  97
  98 */
  99 void
 100 execute_general_pushpop_property (Context *context,
 101                                   SCM context_property,
 102                                   SCM grob_property_path,
 103                                   SCM new_value
 104                                   )
 105 {
 106   SCM current_context_val = SCM_EOL;
 107   if (new_value != SCM_UNDEFINED)
 108     {
 109       Context *where = context->where_defined (context_property, &current_context_val);
 110
 111       /*
 112         Don't mess with MIDI.
 113       */
 114       if (!where)
 115         return;
 116
 117       if (where != context)
 118         {
 119           SCM base = updated_grob_properties (context, context_property);
 120           current_context_val = scm_cons (base, base);
 121           context->internal_set_property (context_property, current_context_val);
 122         }
 123
 124       if (!scm_is_pair (current_context_val))
 125         {
 126           programming_error ("Grob definition should be cons");
 127           return;
 128         }
 129
 130       SCM prev_alist = scm_car (current_context_val);
 131       SCM symbol = scm_car (grob_property_path);
 132       SCM target_alist
 133         = lookup_nested_property (prev_alist,
 134                                   scm_reverse (scm_cdr (grob_property_path)));
 135
 136       target_alist = scm_acons (symbol, new_value, target_alist);
 137
 138       bool ok = true;
 139       if (!scm_is_pair (scm_cdr (grob_property_path)))
 140         {
 141           if (!ly_is_procedure (new_value)
 142               && !is_simple_closure (new_value))
 143             ok = type_check_assignment (symbol, new_value,
 144                                         ly_symbol2scm ("backend-type?"));
 145
 146           /*
 147             tack onto alist.  We can use set_car, since
 148             updated_grob_properties() in child contexts will check
 149             for changes in the car.
 150           */
 151           if (ok)
 152             {
 153               scm_set_car_x (current_context_val, target_alist);
 154             }
 155         }
 156       else
 157         {
 158           execute_general_pushpop_property (context,
 159                                             context_property,
 160                                             scm_cdr (grob_property_path),
 161                                             target_alist
 162                                             );
 163         }
 164     }
 165   else 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->internal_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->internal_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 }
 277
 278 Grob *
 279 make_grob_from_properties (Engraver *tr, SCM symbol, SCM cause, char const *name)
 280 {
 281   Context *context = tr->context ();
 282
 283   SCM props = updated_grob_properties (context, symbol);
 284
 285   Object_key const *key = context->get_grob_key (name);
 286   Grob *grob = 0;
 287
 288   SCM handle = scm_sloppy_assq (ly_symbol2scm ("meta"), props);
 289   SCM klass = scm_cdr (scm_sloppy_assq (ly_symbol2scm ("class"), scm_cdr (handle)));
 290
 291   if (klass == ly_symbol2scm ("Item"))
 292     grob = new Item (props, key);
 293   else if (klass == ly_symbol2scm ("Spanner"))
 294     grob = new Spanner (props, key);
 295   else if (klass == ly_symbol2scm ("Paper_column"))
 296     grob = new Paper_column (props, key);
 297
 298   assert (grob);
 299   dynamic_cast<Engraver *> (tr)->announce_grob (grob, cause);
 300
 301   return grob;
 302 }
 303
 304 Item *
 305 make_item_from_properties (Engraver *tr, SCM x, SCM cause, char const *name)
 306 {
 307   Item *it = dynamic_cast<Item *> (make_grob_from_properties (tr, x, cause, name));
 308   assert (it);
 309   return it;
 310 }
 311
 312 Paper_column *
 313 make_paper_column_from_properties (Engraver *tr, SCM x, char const *name)
 314 {
 315   return dynamic_cast<Paper_column *> (make_grob_from_properties (tr, x, SCM_EOL, name));
 316 }
 317
 318 Spanner *
 319 make_spanner_from_properties (Engraver *tr, SCM x, SCM cause, char const *name)
 320 {
 321   Spanner *sp = dynamic_cast<Spanner *> (make_grob_from_properties (tr, x, cause, name));
 322   assert (sp);
 323   return sp;
 324 }