lily/translator-property.cc

   1 /*
   2    translator-property.cc --  implement manipulation of
   3
   4    immutable Grob property lists.
   5
   6    source file of the GNU LilyPond music typesetter
   7
   8    (c) 2004 Han-Wen Nienhuys <hanwen@xs4all.nl>
   9  */
  10
  11 #include "main.hh"
  12 #include "context.hh"
  13 #include "warn.hh"
  14 #include "item.hh"
  15 #include "spanner.hh"
  16
  17 /*
  18   Grob descriptions (ie. alists with layout properties) are
  19   represented as a (ALIST . BASED-ON) pair, where BASED-ON is the
  20   alist defined in a parent context. BASED-ON should always be a tail
  21   of ALIST.
  22
  23   */
  24
  25 /*
  26   Push or pop (depending on value of VAL) a single entry (ELTPROP . VAL)
  27   entry from a translator property list by name of PROP
  28 */
  29
  30
  31 void
  32 execute_pushpop_property (Context * trg,
  33                           SCM prop, SCM eltprop, SCM val)
  34 {
  35   if (gh_symbol_p (prop) && gh_symbol_p (eltprop))
  36     {
  37       if (val != SCM_UNDEFINED)
  38         {
  39           SCM prev = SCM_EOL;
  40           Context * where = trg->where_defined (prop);
  41
  42           /*
  43             Don't mess with MIDI.
  44            */
  45           if (!where)
  46             return ;
  47
  48           if (where != trg)
  49             {
  50               SCM base = updated_grob_properties (trg, prop);
  51               prev = gh_cons (base, base);
  52               trg->internal_set_property (prop, prev);
  53             }
  54           else
  55             prev = trg->internal_get_property (prop);
  56
  57           if (!gh_pair_p (prev))
  58             {
  59               programming_error ("Grob definition should be cons.");
  60               return ;
  61             }
  62
  63           SCM prev_alist = gh_car (prev);
  64
  65           if (gh_pair_p (prev_alist) || prev_alist == SCM_EOL)
  66             {
  67               bool ok = type_check_assignment (eltprop, val, ly_symbol2scm ("backend-type?"));
  68
  69               /*
  70                tack onto alist:
  71               */
  72               if (ok)
  73                 gh_set_car_x (prev, scm_acons (eltprop, val, prev_alist));
  74             }
  75           else
  76             {
  77               // warning here.
  78             }
  79         }
  80       else if (trg->where_defined (prop) == trg)
  81         {
  82           SCM prev = trg->internal_get_property (prop);
  83           SCM prev_alist = gh_car (prev);
  84           SCM daddy = gh_cdr (prev);
  85
  86           SCM new_alist = SCM_EOL;
  87           SCM *tail = &new_alist;
  88
  89           while (prev_alist != daddy)
  90             {
  91               if (!gh_equal_p (gh_caar (prev_alist), eltprop))
  92                 {
  93                   *tail = gh_cons (gh_car (prev_alist), daddy);
  94                   tail = SCM_CDRLOC (*tail);
  95                 }
  96               prev_alist = gh_cdr (prev_alist);
  97             }
  98
  99           if (new_alist == SCM_EOL)
 100             trg->unset_property (prop);
 101           else
 102             trg->internal_set_property (prop, gh_cons (new_alist, daddy));
 103         }
 104     }
 105   else
 106     {
 107       warning ("Need symbol arguments for \\override and \\revert");
 108       if (internal_type_checking_global_b)
 109         assert (false);
 110     }
 111 }
 112
 113 /*
 114   PRE_INIT_OPS is in the order specified, and hence must be reversed.
 115  */
 116 void
 117 apply_property_operations (Context *tg, SCM pre_init_ops)
 118 {
 119   SCM correct_order = scm_reverse (pre_init_ops);
 120   for (SCM s = correct_order; gh_pair_p (s); s = ly_cdr (s))
 121     {
 122       SCM entry = ly_car (s);
 123       SCM type = ly_car (entry);
 124       entry = ly_cdr (entry);
 125
 126       if (type == ly_symbol2scm ("push") || type == ly_symbol2scm ("poppush"))
 127         {
 128           SCM val = ly_cddr (entry);
 129           val = gh_pair_p (val) ? ly_car (val) : SCM_UNDEFINED;
 130
 131           execute_pushpop_property (tg, ly_car (entry), ly_cadr (entry), val);
 132         }
 133       else if (type == ly_symbol2scm ("assign"))
 134         {
 135           tg->internal_set_property (ly_car (entry), ly_cadr (entry));
 136         }
 137     }
 138 }
 139
 140 /*
 141   Return the object alist for SYM, checking if its base in enclosing
 142   contexts has changed. The alist is updated if necessary.
 143    */
 144 SCM
 145 updated_grob_properties (Context * tg, SCM sym)
 146 {
 147   assert (gh_symbol_p (sym));
 148
 149   tg = tg->where_defined (sym);
 150   if (!tg)
 151     return SCM_EOL;
 152
 153   SCM daddy_props
 154     = (tg->daddy_context_)
 155     ? updated_grob_properties (tg->daddy_context_, sym)
 156     : SCM_EOL;
 157
 158   SCM props  = tg->internal_get_property (sym);
 159
 160   if (!gh_pair_p (props))
 161     {
 162       programming_error ("grob props not a pair?");
 163       return SCM_EOL;
 164     }
 165
 166   SCM based_on = gh_cdr (props);
 167   if (based_on == daddy_props)
 168     {
 169       return gh_car (props);
 170     }
 171   else
 172     {
 173       SCM copy = daddy_props;
 174       SCM * tail = &copy;
 175       SCM p = gh_car (props);
 176       while  (p != based_on)
 177         {
 178           *tail = gh_cons (gh_car (p), daddy_props);
 179           tail = SCM_CDRLOC (*tail);
 180           p = SCM_CDR (p);
 181         }
 182
 183       scm_set_car_x (props, copy);
 184       scm_set_cdr_x (props, daddy_props);
 185
 186       return copy;
 187     }
 188 }
 189
 190 Item*
 191 make_item_from_properties (Context * tg, SCM x)
 192 {
 193   SCM props = updated_grob_properties (tg, x);
 194   return new Item (props);
 195 }
 196
 197 Spanner*
 198 make_spanner_from_properties (Context *tg, SCM x)
 199 {
 200   SCM props = updated_grob_properties (tg, x);
 201   return new Spanner (props);
 202 }
 203