X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=lily%2Fcontext-property.cc;h=62e04a27323a5b136194c0607954e2b53e35c197;hb=47db9a3883d726ca53e2133a3b2298f78dd6a32e;hp=1ccfe5a970973e7ce3be409406985dcafd0e42f7;hpb=bdf74886dc9bcaf01c55677bf2086f4b76a7ef8c;p=lilypond.git

diff --git a/lily/context-property.cc b/lily/context-property.cc
index 1ccfe5a970..62e04a2732 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--2012 Han-Wen Nienhuys <hanwen@xs4all.nl>
+  Copyright (C) 2004--2015 Han-Wen Nienhuys <hanwen@xs4all.nl>
 
   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,10 +19,13 @@
 
 #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"
@@ -45,164 +48,253 @@ general_pushpop_property (Context *context,
         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);
 }
 
-/*
-  Grob descriptions (ie. alists with layout properties) are
-  represented as a (ALIST . BASED-ON) pair, where BASED-ON is the
-  alist defined in a parent context. BASED-ON should always be a tail
-  of ALIST.
+bool
+typecheck_grob (SCM symbol, SCM value)
+{
+  if (Unpure_pure_container *upc = Unpure_pure_container::unsmob (value))
+    return typecheck_grob (symbol, upc->unpure_part ())
+      && typecheck_grob (symbol, upc->pure_part ());
+  return ly_is_procedure (value)
+    || Simple_closure::is_smob (value)
+    || type_check_assignment (symbol, value, ly_symbol2scm ("backend-type?"));
+}
 
-  Push or pop (depending on value of VAL) a single entry from a
-  translator property list by name of PROP.  GROB_PROPERTY_PATH
-  indicates nested alists, eg. '(beamed-stem-lengths details)
-*/
-void
-execute_override_property (Context *context,
-                           SCM context_property,
-                           SCM grob_property_path,
-                           SCM new_value)
+class Grob_properties : public Simple_smob<Grob_properties>
 {
-  SCM current_context_val = SCM_EOL;
+public:
+  SCM mark_smob ();
+  static const char 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_
+  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 Grob_properties::type_p_name_[] = "ly:grob-properties?";
+
+SCM
+Grob_properties::mark_smob ()
+{
+  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_, Grob_properties::unsmob (res));
+  props_  = Grob_properties::unsmob (res);
+  return *this;
+}
+
+bool
+Grob_property_info::check ()
+{
+  if (props_)
+    return true;
+  SCM res = SCM_UNDEFINED;
+  if (context_->here_defined (symbol_, &res))
+    props_ = Grob_properties::unsmob (res);
+  return props_;
+}
 
-  Context *where = context->where_defined (context_property,
-                                           &current_context_val);
+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 (!where)
-    return;
+  if (g == context_
+      || !g->here_defined (symbol_, &current_context_val))
+    return false;
 
-  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);
-    }
+  Grob_properties *def = Grob_properties::unsmob (current_context_val);
 
-  if (!scm_is_pair (current_context_val))
+  if (!def)
     {
-      programming_error ("Grob definition should be cons");
-      return;
+      programming_error ("Grob definition expected");
+      return false;
     }
 
-  SCM target_alist = scm_car (current_context_val);
+  // 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_ = Grob_properties::unsmob (props);
+  return props_;
+}
 
+/*
+  Grob descriptions (ie. alists with layout properties) are
+  represented as a (ALIST . BASED-ON) pair, where BASED-ON is the
+  alist defined in a parent context. BASED-ON should always be a tail
+  of ALIST.
+
+  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.
+*/
+SCM
+Grob_property_info::push (SCM grob_property_path, SCM new_value)
+{
   /*
-    If the car is a list, the property path comes from a nested override
-    using list syntax inside a \context block
+    Don't mess with MIDI.
   */
-  if (scm_is_pair (scm_car (grob_property_path)))
-    grob_property_path = scm_car (grob_property_path);
+  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;
-  bool pc = is_unpure_pure_container (new_value);
-  SCM vals[] = {pc ? unpure_pure_container_unpure_part (new_value) : new_value,
-                pc ? unpure_pure_container_pure_part (new_value) : SCM_BOOL_F
-               };
-
-  for (int i = 0; i < 2; i++)
-    if (!ly_is_procedure (vals[i])
-        && !is_simple_closure (vals[i]))
-      ok = ok && type_check_assignment (symbol, vals[i],
-                                        ly_symbol2scm ("backend-type?"));
-
-  /*
-    tack onto alist.  We can use set_car, since
-    updated_grob_properties () in child contexts will check
-    for changes in the car.
-  */
-  if (ok)
+  if (typecheck_grob (symbol, new_value))
     {
-      scm_set_car_x (current_context_val, target_alist);
+      SCM cell = scm_cons (symbol, new_value);
+      props_->alist_ = scm_cons (cell, props_->alist_);
+      return cell;
     }
+  return SCM_EOL;
 }
 
-/*
-  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))
+        {
+          if (scm_is_pair (scm_car (cell)))
+            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, &current_context_val)
-      == context)
-    {
-      SCM current_alist = scm_car (current_context_val);
-      SCM daddy = scm_cdr (current_context_val);
+  if (!check ())
+    return;
 
-      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 current_alist = props_->alist_;
+  SCM daddy = props_->based_on_;
 
-      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 (!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 (new_alist == daddy)
-            context->unset_property (context_property);
-          else
-            context->set_property (context_property,
-                                   scm_cons (new_alist, daddy));
-        }
+  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))
+    {
+      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
@@ -210,13 +302,11 @@ execute_revert_property (Context *context,
 */
 void
 execute_pushpop_property (Context *context,
-                          SCM context_property,
+                          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);
 }
 
 /*
@@ -230,33 +320,26 @@ apply_property_operations (Context *tg, SCM pre_init_ops)
       SCM entry = scm_car (s);
       SCM type = scm_car (entry);
       entry = scm_cdr (entry);
-      if (!scm_is_pair (entry))
-        continue;
-      SCM context_prop = scm_car (entry);
-      if (scm_is_pair (context_prop))
-        {
-          if (tg->is_alias (scm_car (context_prop)))
-            context_prop = scm_cdr (context_prop);
-          else
-            continue;
-        }
 
       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);
+          Grob_property_info (tg, context_prop).push (grob_prop_path, val);
         }
       else if (type == ly_symbol2scm ("pop"))
         {
-          SCM val = SCM_UNDEFINED;
+          SCM context_prop = scm_car (entry);
           SCM grob_prop_path = scm_cdr (entry);
-          sloppy_general_pushpop_property (tg, context_prop, grob_prop_path, val);
+          Grob_property_info (tg, context_prop).pop (grob_prop_path);
         }
       else if (type == ly_symbol2scm ("assign"))
-        tg->set_property (context_prop, scm_cadr (entry));
+        tg->set_property (scm_car (entry), scm_cadr (entry));
       else if (type == ly_symbol2scm ("apply"))
-        scm_apply_1 (context_prop, tg->self_scm (), scm_cdr (entry));
+	scm_apply_1 (scm_car (entry), tg->self_scm (), scm_cdr (entry));
+      else if (type == ly_symbol2scm ("unset"))
+        tg->unset_property (scm_car (entry));
     }
 }
 
@@ -264,45 +347,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_));
 
-  SCM props;
-  tg = tg->where_defined (sym, &props);
-  if (!tg)
+  Grob_property_info where = find ();
+
+  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 = &copy;
-      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_;
 }