X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=lily%2Fcontext-property.cc;h=6e22b2f808211b28aaa7acedad6afba52f9829f6;hb=b872748c6aa8bb721ced458691b38ac2fac5dfc8;hp=fd57fcd1f372fc439b9a8808178ec6403892398a;hpb=e18531db1f79fb685fbd16d6a2a67bf4b6c09915;p=lilypond.git diff --git a/lily/context-property.cc b/lily/context-property.cc index fd57fcd1f3..6e22b2f808 100644 --- a/lily/context-property.cc +++ b/lily/context-property.cc @@ -1,7 +1,7 @@ /* This file is part of LilyPond, the GNU music typesetter. - Copyright (C) 2004--2010 Han-Wen Nienhuys + Copyright (C) 2004--2015 Han-Wen Nienhuys LilyPond is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -19,11 +19,14 @@ #include "context.hh" #include "engraver.hh" +#include "global-context.hh" +#include "grob-properties.hh" #include "international.hh" #include "item.hh" #include "main.hh" -#include "simple-closure.hh" +#include "smobs.hh" #include "spanner.hh" +#include "unpure-pure-container.hh" #include "warn.hh" /* @@ -32,22 +35,157 @@ */ void general_pushpop_property (Context *context, - SCM context_property, - SCM grob_property_path, - SCM new_value) + SCM context_property, + SCM grob_property_path, + SCM new_value) { + // Numbers may appear, but not in first place if (!scm_is_symbol (context_property) || !scm_is_symbol (scm_car (grob_property_path))) { - warning (_ ("need symbol arguments for \\override and \\revert")); + warning (_ ("need symbol argument for \\override and \\revert")); if (do_internal_type_checking_global) - assert (false); + assert (false); } - sloppy_general_pushpop_property (context, context_property, - grob_property_path, new_value); + Grob_property_info (context, context_property).pushpop + (grob_property_path, new_value); } +bool +typecheck_grob (SCM symbol, SCM value) +{ + if (Unpure_pure_container *upc = unsmob (value)) + return typecheck_grob (symbol, upc->unpure_part ()) + && typecheck_grob (symbol, upc->pure_part ()); + return ly_is_procedure (value) + || type_check_assignment (symbol, value, ly_symbol2scm ("backend-type?")); +} + +class Grob_properties : public Simple_smob +{ +public: + SCM mark_smob () const; + static const char * const type_p_name_; +private: + friend class Grob_property_info; + friend SCM ly_make_grob_properties (SCM); + // alist_ may contain unexpanded nested overrides + SCM alist_; + // based_on_ is the cooked_ value from the next higher context that + // alist_ is based on + SCM based_on_; + // cooked_ is a version of alist_ where nested overrides have been + // expanded + SCM cooked_; + // cooked_from_ is the value of alist_ from which the expansion has + // been done + SCM cooked_from_; + // nested_ is a count of nested overrides in alist_ Or rather: of + // entries that must not appear in the cooked list and are + // identified by having a "key" that is not a symbol. Temporary + // overrides and reverts also meet that description and have a + // nominal key of #t/#f and a value of the original cons cell. + int nested_; + + Grob_properties (SCM alist, SCM based_on) : + alist_ (alist), based_on_ (based_on), + // if the constructor was called with lists possibly containing + // partial overrides, we would need to initialize with based_on in + // order to trigger an initial update. But this should never + // happen, so we initialize straight with alist. + cooked_ (alist), cooked_from_ (alist), nested_ (0) { } +}; + +const char * const Grob_properties::type_p_name_ = "ly:grob-properties?"; + +SCM +Grob_properties::mark_smob () const +{ + scm_gc_mark (alist_); + scm_gc_mark (based_on_); + scm_gc_mark (cooked_); + return cooked_from_; +} + +LY_DEFINE (ly_make_grob_properties, "ly:make-grob-properties", + 1, 0, 0, (SCM alist), + "This packages the given property list @var{alist} in" + " a grob property container stored in a context property" + " with the name of a grob.") +{ + LY_ASSERT_TYPE (ly_is_list, alist, 1); + return Grob_properties (alist, SCM_EOL).smobbed_copy (); +} + + +Grob_property_info +Grob_property_info::find () +{ + if (props_) + return *this; + SCM res = SCM_UNDEFINED; + if (Context *c = context_->where_defined (symbol_, &res)) + if (c != context_) + return Grob_property_info (c, symbol_, unsmob (res)); + props_ = unsmob (res); + return *this; +} + +bool +Grob_property_info::check () +{ + if (props_) + return true; + SCM res = SCM_UNDEFINED; + if (context_->here_defined (symbol_, &res)) + props_ = unsmob (res); + return props_; +} + +bool +Grob_property_info::create () +{ + // Using scm_hashq_create_handle_x would seem like the one-lookup + // way to create a handle if it does not exist yet. However, we + // need to check that there is a corresponding grob in this + // particular output first, and we have to do this in the global + // context. By far the most frequent case will be that a + // Grob_properties for this context already exists, so we optimize + // for that and only check the global handle when the local + // context is pristine. + if (check ()) + return true; + SCM current_context_val = SCM_EOL; + Context *g = context_->get_global_context (); + if (!g) + return false; // Context is probably dead + + /* + Don't mess with MIDI. + */ + if (g == context_ + || !g->here_defined (symbol_, ¤t_context_val)) + return false; + + Grob_properties *def = unsmob (current_context_val); + + if (!def) + { + programming_error ("Grob definition expected"); + return false; + } + + // We create the new Grob_properties from the default definition + // since this is what we have available right now. It may or may + // not be accurate since we don't take into account any + // prospective overrides in intermediate contexts. If there are + // any, they will be factored in when `updated' is being called. + SCM props = Grob_properties (def->alist_, def->alist_).smobbed_copy (); + context_->set_property (symbol_, props); + props_ = unsmob (props); + return props_; +} /* Grob descriptions (ie. alists with layout properties) are @@ -55,142 +193,175 @@ general_pushpop_property (Context *context, alist defined in a parent context. BASED-ON should always be a tail of ALIST. - Push or pop (depending on value of VAL) a single entry entry from a + Push a single entry from a translator property list by name of PROP. GROB_PROPERTY_PATH indicates nested alists, eg. '(beamed-stem-lengths details) - + + Return value can be passed to matched_pop and will only cancel the + same override then. */ -void -execute_override_property (Context *context, - SCM context_property, - SCM grob_property_path, - SCM new_value) +SCM +Grob_property_info::push (SCM grob_property_path, SCM new_value) { - SCM current_context_val = SCM_EOL; - - Context *where = context->where_defined (context_property, - ¤t_context_val); - /* Don't mess with MIDI. */ - if (!where) - return; - - if (where != context) - { - SCM base = updated_grob_properties (context, context_property); - current_context_val = scm_cons (base, base); - context->set_property (context_property, current_context_val); - } - - if (!scm_is_pair (current_context_val)) - { - programming_error ("Grob definition should be cons"); - return; - } - - SCM target_alist = scm_car (current_context_val); + if (!create ()) + return SCM_EOL; SCM symbol = scm_car (grob_property_path); - if (scm_is_pair (scm_cdr (grob_property_path))) + SCM rest = scm_cdr (grob_property_path); + if (scm_is_pair (rest)) { - new_value = nested_property_alist (ly_assoc_get (symbol, target_alist, - SCM_EOL), - scm_cdr (grob_property_path), - new_value); + // poor man's typechecking + if (typecheck_grob (symbol, nested_create_alist (rest, new_value))) { + SCM cell = scm_cons (grob_property_path, new_value); + props_->alist_ = scm_cons (cell, props_->alist_); + props_->nested_++; + return cell; + } + return SCM_EOL; } /* it's tempting to replace the head of the list if it's the same property. However, we have to keep this info around, in case we have to \revert back to it. */ - target_alist = scm_acons (symbol, new_value, target_alist); - bool ok = true; - if (!ly_is_procedure (new_value) - && !is_simple_closure (new_value)) - ok = type_check_assignment (symbol, new_value, - ly_symbol2scm ("backend-type?")); + if (typecheck_grob (symbol, new_value)) + { + SCM cell = scm_cons (symbol, new_value); + props_->alist_ = scm_cons (cell, props_->alist_); + return cell; + } + return SCM_EOL; +} - /* - tack onto alist. We can use set_car, since - updated_grob_properties () in child contexts will check - for changes in the car. - */ - if (ok) +// Used for \once \override, returns a token for matched_pop +SCM +Grob_property_info::temporary_override (SCM grob_property_path, SCM new_value) +{ + SCM cell = push (grob_property_path, new_value); + if (!scm_is_pair (cell)) + return cell; + if (scm_is_symbol (scm_car (cell))) + props_->nested_++; + cell = scm_cons (SCM_BOOL_T, cell); + props_->alist_ = scm_cons (cell, scm_cdr (props_->alist_)); + return cell; +} + +// Used for \once \revert, returns a token for matched_pop +SCM +Grob_property_info::temporary_revert (SCM grob_property_path) +{ + if (!check ()) + return SCM_EOL; + + SCM current_alist = props_->alist_; + SCM daddy = props_->based_on_; + SCM tail = SCM_EOL; + + if (!scm_is_pair (grob_property_path) + || !scm_is_symbol (scm_car (grob_property_path))) { - scm_set_car_x (current_context_val, target_alist); + programming_error ("Grob property path should be list of symbols."); + return SCM_EOL; } + + if (scm_is_pair (scm_cdr (grob_property_path))) + { + tail = assoc_tail (grob_property_path, current_alist, daddy); + if (scm_is_false (tail)) + return SCM_EOL; + } + else + { + tail = assq_tail (scm_car (grob_property_path), current_alist, daddy); + if (scm_is_false (tail)) + return SCM_EOL; + ++props_->nested_; + } + + SCM cell = scm_cons (SCM_BOOL_F, scm_car (tail)); + props_->alist_ = partial_list_copy (current_alist, tail, + scm_cons (cell, scm_cdr (tail))); + return cell; } -/* - do a pop (indicated by new_value==SCM_UNDEFINED) or push - */ + void -sloppy_general_pushpop_property (Context *context, - SCM context_property, - SCM grob_property_path, - SCM new_value) +Grob_property_info::matched_pop (SCM cell) { - if (new_value == SCM_UNDEFINED) - execute_revert_property (context, context_property, - grob_property_path); - else - execute_override_property (context, context_property, - grob_property_path, - new_value); + if (!scm_is_pair (cell)) + return; + if (!check ()) + return; + SCM current_alist = props_->alist_; + SCM daddy = props_->based_on_; + for (SCM p = current_alist; !scm_is_eq (p, daddy); p = scm_cdr (p)) + { + if (scm_is_eq (scm_car (p), cell)) + { + SCM key = scm_car (cell); + if (scm_is_false (key)) + { + // temporary revert, reactivate + cell = scm_cdr (cell); + if (scm_is_symbol (scm_car (cell))) + props_->nested_--; + props_->alist_ = partial_list_copy (current_alist, p, + scm_cons (cell, scm_cdr (p))); + return; + } + if (!scm_is_symbol (key)) + props_->nested_--; + props_->alist_ = partial_list_copy (current_alist, p, scm_cdr (p)); + return; + } + } + return; } /* Revert the property given by property_path. */ void -execute_revert_property (Context *context, - SCM context_property, - SCM grob_property_path) +Grob_property_info::pop (SCM grob_property_path) { - SCM current_context_val = SCM_EOL; - if (context->where_defined (context_property, ¤t_context_val) - == context) + if (!check ()) + return; + + SCM current_alist = props_->alist_; + SCM daddy = props_->based_on_; + + if (!scm_is_pair (grob_property_path) + || !scm_is_symbol (scm_car (grob_property_path))) + { + programming_error ("Grob property path should be list of symbols."); + return; + } + + if (scm_is_pair (scm_cdr (grob_property_path))) + { + SCM old_alist = current_alist; + current_alist = evict_from_alist (grob_property_path, current_alist, daddy); + if (scm_is_eq (old_alist, current_alist)) + return; + props_->nested_--; + } + else + current_alist = evict_from_alist (scm_car (grob_property_path), + current_alist, daddy); + + if (scm_is_eq (current_alist, daddy)) { - SCM current_alist = scm_car (current_context_val); - SCM daddy = scm_cdr (current_context_val); - - if (!scm_is_pair (grob_property_path) - || !scm_is_symbol (scm_car (grob_property_path))) - { - programming_error ("Grob property path should be list of symbols."); - return; - } - - SCM symbol = scm_car (grob_property_path); - if (scm_is_pair (scm_cdr (grob_property_path))) - { - SCM current_sub_alist = ly_assoc_get (symbol, current_alist, SCM_EOL); - SCM new_val - = nested_property_revert_alist (current_sub_alist, - scm_cdr (grob_property_path)); - - if (scm_is_pair (current_alist) - && scm_caar (current_alist) == symbol - && current_alist != daddy) - current_alist = scm_cdr (current_alist); - - current_alist = scm_acons (symbol, new_val, current_alist); - scm_set_car_x (current_context_val, current_alist); - } - else - { - SCM new_alist = evict_from_alist (symbol, current_alist, daddy); - - if (new_alist == daddy) - context->unset_property (context_property); - else - context->set_property (context_property, - scm_cons (new_alist, daddy)); - } + assert (props_->nested_ == 0); + props_ = 0; + context_->unset_property (symbol_); + return; } + props_->alist_ = current_alist; } /* Convenience: a push/pop grob property using a single grob_property @@ -198,44 +369,44 @@ execute_revert_property (Context *context, */ void execute_pushpop_property (Context *context, - SCM context_property, - SCM grob_property, - SCM new_value) + SCM grob, + SCM grob_property, + SCM new_value) { - general_pushpop_property (context, context_property, - scm_list_1 (grob_property), - new_value); + Grob_property_info (context, grob).pushpop (scm_list_1 (grob_property), new_value); } - + /* PRE_INIT_OPS is in the order specified, and hence must be reversed. */ void apply_property_operations (Context *tg, SCM pre_init_ops) { - SCM correct_order = scm_reverse (pre_init_ops); - for (SCM s = correct_order; scm_is_pair (s); s = scm_cdr (s)) + for (SCM s = pre_init_ops; scm_is_pair (s); s = scm_cdr (s)) { SCM entry = scm_car (s); SCM type = scm_car (entry); entry = scm_cdr (entry); - if (type == ly_symbol2scm ("push")) - { - SCM context_prop = scm_car (entry); - SCM val = scm_cadr (entry); - SCM grob_prop_path = scm_cddr (entry); - sloppy_general_pushpop_property (tg, context_prop, grob_prop_path, val); - } - else if (type == ly_symbol2scm ("pop")) - { - SCM context_prop = scm_car (entry); - SCM val = SCM_UNDEFINED; - SCM grob_prop_path = scm_cdr (entry); - sloppy_general_pushpop_property (tg, context_prop, grob_prop_path, val); - } - else if (type == ly_symbol2scm ("assign")) - tg->set_property (scm_car (entry), scm_cadr (entry)); + if (scm_is_eq (type, ly_symbol2scm ("push"))) + { + SCM context_prop = scm_car (entry); + SCM val = scm_cadr (entry); + SCM grob_prop_path = scm_cddr (entry); + Grob_property_info (tg, context_prop).push (grob_prop_path, val); + } + else if (scm_is_eq (type, ly_symbol2scm ("pop"))) + { + SCM context_prop = scm_car (entry); + SCM grob_prop_path = scm_cdr (entry); + Grob_property_info (tg, context_prop).pop (grob_prop_path); + } + else if (scm_is_eq (type, ly_symbol2scm ("assign"))) + tg->set_property (scm_car (entry), scm_cadr (entry)); + else if (scm_is_eq (type, ly_symbol2scm ("apply"))) + scm_apply_1 (scm_car (entry), tg->self_scm (), scm_cdr (entry)); + else if (scm_is_eq (type, ly_symbol2scm ("unset"))) + tg->unset_property (scm_car (entry)); } } @@ -243,45 +414,31 @@ apply_property_operations (Context *tg, SCM pre_init_ops) Return the object alist for SYM, checking if its base in enclosing contexts has changed. The alist is updated if necessary. */ -SCM -updated_grob_properties (Context *tg, SCM sym) +SCM Grob_property_info::updated () { - assert (scm_is_symbol (sym)); + assert (scm_is_symbol (symbol_)); + + Grob_property_info where = find (); - SCM props; - tg = tg->where_defined (sym, &props); - if (!tg) + if (!where) return SCM_EOL; - SCM daddy_props - = (tg->get_parent_context ()) - ? updated_grob_properties (tg->get_parent_context (), sym) - : SCM_EOL; + Context *dad = where.context_->get_parent_context (); - if (!scm_is_pair (props)) - { - programming_error ("grob props not a pair?"); - return SCM_EOL; - } + SCM daddy_props + = dad ? Grob_property_info (dad, symbol_).updated () : SCM_EOL; - SCM based_on = scm_cdr (props); - if (based_on == daddy_props) - return scm_car (props); - else + SCM based_on = where.props_->based_on_; + SCM alist = where.props_->alist_; + if (!scm_is_eq (based_on, daddy_props)) { - SCM copy = daddy_props; - SCM *tail = © - SCM p = scm_car (props); - while (p != based_on) - { - *tail = scm_cons (scm_car (p), daddy_props); - tail = SCM_CDRLOC (*tail); - p = scm_cdr (p); - } - - scm_set_car_x (props, copy); - scm_set_cdr_x (props, daddy_props); - - return copy; + where.props_->based_on_ = daddy_props; + alist = partial_list_copy (alist, based_on, daddy_props); + where.props_->alist_ = alist; } + if (scm_is_eq (where.props_->cooked_from_, alist)) + return where.props_->cooked_; + where.props_->cooked_from_ = alist; + where.props_->cooked_ = nalist_to_alist (alist, where.props_->nested_); + return where.props_->cooked_; }