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