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