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 "translator-group.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 (Translator_group * 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           Translator_group * where = trg->where_defined (prop);
  41
  42           /*
  43             Don't mess with MIDI.
  44            */
  45           if (!where)
  46             return ;
  47           if (where != trg)
  48             {
  49               SCM base = updated_grob_properties (trg, prop);
  50               prev = gh_cons (base, base);
  51               trg->internal_set_property (prop, prev);
  52             }
  53           else
  54             prev = trg->internal_get_property (prop);
  55
  56           if (!gh_pair_p (prev))
  57             {
  58               programming_error ("Grob definition should be cons.");
  59               return ;
  60             }
  61
  62           SCM prev_alist = gh_car (prev);
  63
  64           if (gh_pair_p (prev_alist) || prev_alist == SCM_EOL)
  65             {
  66               bool ok = type_check_assignment (eltprop, val, ly_symbol2scm ("backend-type?"));
  67
  68               /*
  69                tack onto alist:
  70               */
  71               if (ok)
  72                 gh_set_car_x (prev, scm_acons (eltprop, val, prev_alist));
  73             }
  74           else
  75             {
  76               // warning here.
  77             }
  78         }
  79       else if (trg->where_defined (prop) == trg)
  80         {
  81           SCM prev = trg->internal_get_property (prop);
  82           SCM prev_alist = gh_car (prev);
  83           SCM daddy = gh_cdr (prev);
  84
  85           SCM new_alist = SCM_EOL;
  86           SCM *tail = &new_alist;
  87
  88           while (prev_alist != daddy)
  89             {
  90               if (!gh_equal_p (gh_caar (prev_alist), eltprop))
  91                 {
  92                   *tail = gh_cons (gh_car (prev_alist), daddy);
  93                   tail = SCM_CDRLOC (*tail);
  94                 }
  95               prev_alist = gh_cdr (prev_alist);
  96             }
  97
  98           if (new_alist == SCM_EOL)
  99             trg->unset_property (prop);
 100           else
 101             trg->internal_set_property (prop, gh_cons (new_alist, daddy));
 102         }
 103     }
 104   else
 105     {
 106       warning ("Need symbol arguments for \\override and \\revert");
 107       if (internal_type_checking_global_b)
 108         assert (false);
 109     }
 110 }
 111
 112 /*
 113   PRE_INIT_OPS is in the order specified, and hence must be reversed.
 114  */
 115 void
 116 apply_property_operations (Translator_group*tg, SCM pre_init_ops)
 117 {
 118   SCM correct_order = scm_reverse (pre_init_ops);
 119   for (SCM s = correct_order; gh_pair_p (s); s = ly_cdr (s))
 120     {
 121       SCM entry = ly_car (s);
 122       SCM type = ly_car (entry);
 123       entry = ly_cdr (entry);
 124
 125       if (type == ly_symbol2scm ("push") || type == ly_symbol2scm ("poppush"))
 126         {
 127           SCM val = ly_cddr (entry);
 128           val = gh_pair_p (val) ? ly_car (val) : SCM_UNDEFINED;
 129
 130           execute_pushpop_property (tg, ly_car (entry), ly_cadr (entry), val);
 131         }
 132       else if (type == ly_symbol2scm ("assign"))
 133         {
 134           tg->internal_set_property (ly_car (entry), ly_cadr (entry));
 135         }
 136     }
 137 }
 138
 139 /*
 140   Return the object alist for SYM, checking if its base in enclosing
 141   contexts has changed. The alist is updated if necessary.
 142    */
 143 SCM
 144 updated_grob_properties (Translator_group* tg, SCM sym)
 145 {
 146   assert (gh_symbol_p (sym));
 147
 148   tg = tg->where_defined (sym);
 149   SCM daddy_props
 150     = (tg->daddy_trans_)
 151     ? updated_grob_properties (tg->daddy_trans_, sym)
 152     : SCM_EOL;
 153
 154   SCM props  = tg->internal_get_property (sym);
 155
 156   if (!gh_pair_p (props))
 157     {
 158       programming_error ("grob props not a pair?");
 159       return SCM_EOL;
 160     }
 161
 162   SCM based_on = gh_cdr (props);
 163   if (based_on == daddy_props)
 164     {
 165       return gh_car (props);
 166     }
 167   else
 168     {
 169       SCM copy = daddy_props;
 170       SCM * tail = &copy;
 171       SCM p = gh_car (props);
 172       while  (p != based_on)
 173         {
 174           *tail = gh_cons (gh_car (p), daddy_props);
 175           tail = SCM_CDRLOC (*tail);
 176           p = SCM_CDR (p);
 177         }
 178
 179       scm_set_car_x (props, copy);
 180       scm_set_cdr_x (props, daddy_props);
 181
 182       return copy;
 183     }
 184 }
 185
 186 Item*
 187 make_item_from_properties (Translator_group* tg, SCM x)
 188 {
 189   SCM props = updated_grob_properties (tg, x);
 190   return new Item (props);
 191 }
 192
 193 Spanner*
 194 make_spanner_from_properties (Translator_group *tg, SCM x)
 195 {
 196   SCM props = updated_grob_properties (tg, x);
 197   return new Spanner (props);
 198 }
 199