2 property-engraver.cc -- implement Property engraver
4 source file of the GNU LilyPond music typesetter
6 (c) 1999--2000 Han-Wen Nienhuys <hanwen@cs.uu.nl>
10 #include "lily-guile.hh"
11 #include "engraver.hh"
12 #include "dictionary.hh"
14 #include "scm-hash.hh"
15 #include "translator-group.hh"
18 JUNKME: should use pushproperty everywhere.
21 class Property_engraver
: public Engraver
26 Scheme_hash_table
*prop_dict_
; // junkme
27 void apply_properties (SCM
, Grob
*, Translator_group
*origin
);
30 virtual void acknowledge_grob (Grob_info ei
);
31 virtual void initialize ();
32 virtual void finalize ();
36 VIRTUAL_COPY_CONS(Translator
);
41 Property_engraver::Property_engraver()
46 Property_engraver::finalize()
51 Property_engraver::~Property_engraver ()
54 scm_unprotect_object (prop_dict_
->self_scm ());
58 Property_engraver::initialize ()
60 prop_dict_
= new Scheme_hash_table
;
62 SCM plist
= get_property (ly_symbol2scm ("Generic_property_list"));
63 for (; gh_pair_p (plist
); plist
= gh_cdr (plist
))
65 SCM elt_props
= gh_car (plist
);
66 prop_dict_
->set (gh_car (elt_props
), gh_cdr (elt_props
));
71 Property_engraver::acknowledge_grob (Grob_info i
)
73 SCM ifs
= i
.elem_l_
->get_grob_property ("interfaces");
75 for (; gh_pair_p (ifs
); ifs
= gh_cdr (ifs
))
77 if (prop_dict_
->try_retrieve (gh_car (ifs
), &props
))
79 apply_properties (props
,i
.elem_l_
, i
.origin_trans_l_
->daddy_trans_l_
);
83 if (prop_dict_
->try_retrieve (ly_symbol2scm ("all"), &props
))
85 apply_properties (props
, i
.elem_l_
, i
.origin_trans_l_
->daddy_trans_l_
);
91 Property_engraver::apply_properties (SCM p
, Grob
*e
, Translator_group
*origin
)
93 for (; gh_pair_p (p
); p
= gh_cdr (p
))
96 Try each property in order; earlier descriptions take
97 precedence over later ones, and we don't touch elt-properties if
101 SCM entry
= gh_car (p
);
102 SCM prop_sym
= gh_car (entry
);
103 SCM type_p
= gh_cadr (entry
);
104 SCM elt_prop_sym
= gh_caddr (entry
);
106 SCM preset
= scm_assq(elt_prop_sym
, e
->mutable_property_alist_
);
107 if (preset
!= SCM_BOOL_F
)
110 SCM val
= get_property (prop_sym
);
113 ; // Not defined in context.
114 else if (gh_apply (type_p
, scm_listify (val
, SCM_UNDEFINED
))
115 == SCM_BOOL_T
) // defined and right type: do it
117 e
->set_grob_property (elt_prop_sym
, val
);
119 SCM meta
= e
->get_grob_property ("meta");
120 SCM name
= scm_assoc (ly_symbol2scm ("name"), meta
);
121 warning (_f ("%s is deprecated. Use\n \\property %s.%s \\override #'%s = #%s",
122 ly_symbol2string (prop_sym
).ch_C (),
123 origin
->type_str_
.ch_C (),
124 ly_scm2string (gh_cdr (name
)).ch_C (),
125 ly_symbol2string (elt_prop_sym
).ch_C (),
126 ly_scm2string (ly_write2scm (val
)).ch_C ()));
131 we don't print a warning if VAL == (), because we would
132 get lots of warnings when we restore stuff to default, eg.
134 slurDash = #1 [...] slurDash = ()
136 should not cause "type error: slurDash expects number not
141 { // not the right type: error message.
142 SCM errport
= scm_current_error_port ();
143 SCM typefunc
= scm_eval2 (ly_symbol2scm ("type-name"), SCM_EOL
);
144 SCM type_name
= gh_call1 (typefunc
, type_p
);
145 warning (_f ("Wrong type for property: %s, type: %s, value found: %s, type: %s",
146 ly_symbol2string (prop_sym
).ch_C (),
147 ly_scm2string (type_name
).ch_C (),
148 ly_scm2string (ly_write2scm (val
)).ch_C (),
149 ly_scm2string (ly_type (val
)).ch_C ()));
150 scm_puts ("\n", errport
);
155 ADD_THIS_TRANSLATOR(Property_engraver
);