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