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 = type_check_assignment (symbol, new_value, ly_symbol2scm ("backend-type?"));
 140
 141           /*
 142             tack onto alist.  We can use set_car, since
 143             updated_grob_properties() in child contexts will check
 144             for changes in the car.
 145           */
 146           if (ok)
 147             {
 148               scm_set_car_x (current_context_val, target_alist);
 149             }
 150         }
 151       else
 152         {
 153           execute_general_pushpop_property (context,
 154                                             context_property,
 155                                             scm_cdr (grob_property_path),
 156                                             target_alist
 157                                             );
 158         }
 159     }
 160   else if (context->where_defined (context_property, &current_context_val) == context)
 161     {
 162       SCM current_value = scm_car (current_context_val);
 163       SCM daddy = scm_cdr (current_context_val);
 164       SCM symbol = scm_car (grob_property_path);
 165       SCM new_alist = evict_from_alist (symbol, current_value, daddy);
 166
 167       if (new_alist == daddy)
 168         context->unset_property (context_property);
 169       else
 170         context->internal_set_property (context_property, scm_cons (new_alist, daddy));
 171     }
 172 }
 173
 174 void
 175 execute_pushpop_property (Context *context,
 176                           SCM context_property,
 177                           SCM grob_property,
 178                           SCM new_value
 179                           )
 180 {
 181   general_pushpop_property (context, context_property,
 182                             scm_list_1 (grob_property),
 183                             new_value);
 184 }
 185
 186 /*
 187   PRE_INIT_OPS is in the order specified, and hence must be reversed.
 188 */
 189 void
 190 apply_property_operations (Context *tg, SCM pre_init_ops)
 191 {
 192   SCM correct_order = scm_reverse (pre_init_ops);
 193   for (SCM s = correct_order; scm_is_pair (s); s = scm_cdr (s))
 194     {
 195       SCM entry = scm_car (s);
 196       SCM type = scm_car (entry);
 197       entry = scm_cdr (entry);
 198
 199       if (type == ly_symbol2scm ("push"))
 200         {
 201           SCM context_prop = scm_car (entry);
 202           SCM val = scm_cadr (entry);
 203           SCM grob_prop_path = scm_cddr (entry);
 204           execute_general_pushpop_property (tg, context_prop, grob_prop_path, val);
 205         }
 206       else if (type == ly_symbol2scm ("pop"))
 207         {
 208           SCM context_prop = scm_car (entry);
 209           SCM val = SCM_UNDEFINED;
 210           SCM grob_prop_path = scm_cdr (entry);
 211           execute_general_pushpop_property (tg, context_prop, grob_prop_path, val);
 212         }
 213       else if (type == ly_symbol2scm ("assign"))
 214         tg->internal_set_property (scm_car (entry), scm_cadr (entry));
 215     }
 216 }
 217
 218 /*
 219   Return the object alist for SYM, checking if its base in enclosing
 220   contexts has changed. The alist is updated if necessary.
 221 */
 222 SCM
 223 updated_grob_properties (Context *tg, SCM sym)
 224 {
 225   assert (scm_is_symbol (sym));
 226
 227   SCM props;
 228   tg = tg->where_defined (sym, &props);
 229   if (!tg)
 230     return SCM_EOL;
 231
 232   SCM daddy_props
 233     = (tg->get_parent_context ())
 234     ? updated_grob_properties (tg->get_parent_context (), sym)
 235     : SCM_EOL;
 236
 237   if (!scm_is_pair (props))
 238     {
 239       programming_error ("grob props not a pair?");
 240       return SCM_EOL;
 241     }
 242
 243   SCM based_on = scm_cdr (props);
 244   if (based_on == daddy_props)
 245     return scm_car (props);
 246   else
 247     {
 248       SCM copy = daddy_props;
 249       SCM *tail = &copy;
 250       SCM p = scm_car (props);
 251       while (p != based_on)
 252         {
 253           *tail = scm_cons (scm_car (p), daddy_props);
 254           tail = SCM_CDRLOC (*tail);
 255           p = scm_cdr (p);
 256         }
 257
 258       scm_set_car_x (props, copy);
 259       scm_set_cdr_x (props, daddy_props);
 260
 261       return copy;
 262     }
 263 }
 264
 265 Grob *
 266 make_grob_from_properties (Engraver *tr, SCM symbol, SCM cause, char const *name)
 267 {
 268   Context *context = tr->context ();
 269
 270   SCM props = updated_grob_properties (context, symbol);
 271
 272   Object_key const *key = context->get_grob_key (name);
 273   Grob *grob = 0;
 274
 275   SCM handle = scm_sloppy_assq (ly_symbol2scm ("meta"), props);
 276   SCM klass = scm_cdr (scm_sloppy_assq (ly_symbol2scm ("class"), scm_cdr (handle)));
 277
 278   if (klass == ly_symbol2scm ("Item"))
 279     grob = new Item (props, key);
 280   else if (klass == ly_symbol2scm ("Spanner"))
 281     grob = new Spanner (props, key);
 282   else if (klass == ly_symbol2scm ("Paper_column"))
 283     grob = new Paper_column (props, key);
 284
 285   assert (grob);
 286   dynamic_cast<Engraver *> (tr)->announce_grob (grob, cause);
 287
 288   return grob;
 289 }
 290
 291 Item *
 292 make_item_from_properties (Engraver *tr, SCM x, SCM cause, char const *name)
 293 {
 294   Item *it = dynamic_cast<Item *> (make_grob_from_properties (tr, x, cause, name));
 295   assert (it);
 296   return it;
 297 }
 298
 299 Paper_column *
 300 make_paper_column_from_properties (Engraver *tr, SCM x, char const *name)
 301 {
 302   return dynamic_cast<Paper_column *> (make_grob_from_properties (tr, x, SCM_EOL, name));
 303 }
 304
 305 Spanner *
 306 make_spanner_from_properties (Engraver *tr, SCM x, SCM cause, char const *name)
 307 {
 308   Spanner *sp = dynamic_cast<Spanner *> (make_grob_from_properties (tr, x, cause, name));
 309   assert (sp);
 310   return sp;
 311 }