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
  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))
  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 }
 105
 106 /*
 107   PRE_INIT_OPS is in the order specified, and hence must be reversed.
 108  */
 109 void
 110 apply_property_operations (Translator_group*tg, SCM pre_init_ops)
 111 {
 112   SCM correct_order = scm_reverse (pre_init_ops);
 113   for (SCM s = correct_order; gh_pair_p (s); s = ly_cdr (s))
 114     {
 115       SCM entry = ly_car (s);
 116       SCM type = ly_car (entry);
 117       entry = ly_cdr (entry);
 118
 119       if (type == ly_symbol2scm ("push") || type == ly_symbol2scm ("poppush"))
 120         {
 121           SCM val = ly_cddr (entry);
 122           val = gh_pair_p (val) ? ly_car (val) : SCM_UNDEFINED;
 123
 124           execute_pushpop_property (tg, ly_car (entry), ly_cadr (entry), val);
 125         }
 126       else if (type == ly_symbol2scm ("assign"))
 127         {
 128           tg->internal_set_property (ly_car (entry), ly_cadr (entry));
 129         }
 130     }
 131 }
 132
 133 /*
 134   Return the object alist for SYM, checking if its base in enclosing
 135   contexts has changed. The alist is updated if necessary.
 136    */
 137 SCM
 138 updated_grob_properties (Translator_group* tg, SCM sym)
 139 {
 140   assert (gh_symbol_p (sym));
 141
 142   tg = tg->where_defined (sym);
 143   SCM daddy_props
 144     = (tg->daddy_trans_)
 145     ? updated_grob_properties (tg->daddy_trans_, sym)
 146     : SCM_EOL;
 147
 148   SCM props  = tg->internal_get_property (sym);
 149
 150   if (!gh_pair_p (props))
 151     {
 152       programming_error ("grob props not a pair?");
 153       return SCM_EOL;
 154     }
 155
 156   SCM based_on = gh_cdr (props);
 157   if (based_on == daddy_props)
 158     {
 159       return gh_car (props);
 160     }
 161   else
 162     {
 163       SCM copy = daddy_props;
 164       SCM * tail = &copy;
 165       SCM p = gh_car (props);
 166       while  (p != based_on)
 167         {
 168           *tail = gh_cons (gh_car (p), daddy_props);
 169           tail = SCM_CDRLOC (*tail);
 170           p = SCM_CDR (p);
 171         }
 172
 173       scm_set_car_x (props, copy);
 174       scm_set_cdr_x (props, daddy_props);
 175
 176       return copy;
 177     }
 178 }
 179
 180 Item*
 181 make_item_from_properties (Translator_group* tg, SCM x)
 182 {
 183   SCM props = updated_grob_properties (tg, x);
 184   return new Item (props);
 185 }
 186
 187 Spanner*
 188 make_spanner_from_properties (Translator_group *tg, SCM x)
 189 {
 190   SCM props = updated_grob_properties (tg, x);
 191   return new Spanner (props);
 192 }
 193