X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=lily%2Fcontext-property.cc;h=5f2c8c70e5e4adeaeea4c67cc57354b4ac0b1000;hb=324ff94afc62c7011b7377f24392f95391ed3b84;hp=7ee4b904d9a7edaf34aa4f0247cd704208ddf097;hpb=4bb29573149a0ffa1f881c5e38a0fe68e9e76b67;p=lilypond.git

diff --git a/lily/context-property.cc b/lily/context-property.cc
index 7ee4b904d9..5f2c8c70e5 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--2011 Han-Wen Nienhuys <hanwen@xs4all.nl>
+  Copyright (C) 2004--2014 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,11 +19,15 @@
 
 #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"
 
 /*
@@ -44,8 +48,148 @@ 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);
+}
+
+bool
+typecheck_grob (SCM symbol, SCM value)
+{
+  if (is_unpure_pure_container (value))
+    return typecheck_grob (symbol, unpure_pure_container_unpure_part (value))
+      && typecheck_grob (symbol, unpure_pure_container_pure_part (value));
+  return ly_is_procedure (value)
+    || is_simple_closure (value)
+    || type_check_assignment (symbol, value, ly_symbol2scm ("backend-type?"));
+}
+
+class Grob_properties {
+  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) { }
+  DECLARE_SIMPLE_SMOBS (Grob_properties);
+};
+
+#include "ly-smobs.icc"
+IMPLEMENT_SIMPLE_SMOBS (Grob_properties);
+IMPLEMENT_DEFAULT_EQUAL_P (Grob_properties);
+IMPLEMENT_TYPE_P (Grob_properties, "ly:grob-properties?");
+
+SCM
+Grob_properties::mark_smob (SCM smob)
+{
+  Grob_properties *gp = (Grob_properties *) SCM_SMOB_DATA (smob);
+  scm_gc_mark (gp->alist_);
+  scm_gc_mark (gp->based_on_);
+  scm_gc_mark (gp->cooked_);
+  return gp->cooked_from_;
+}
+
+int
+Grob_properties::print_smob (SCM /*smob*/, SCM port, scm_print_state *)
+{
+  scm_puts ("#<Grob_properties>", port);
+
+  return 1;
+}
+
+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_;
+}
+
+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_, &current_context_val))
+    return false;
+
+  Grob_properties *def = Grob_properties::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_ = Grob_properties::unsmob (props);
+  return props_;
 }
 
 /*
@@ -59,143 +203,74 @@ general_pushpop_property (Context *context,
   indicates nested alists, eg. '(beamed-stem-lengths details)
 */
 void
-execute_override_property (Context *context,
-                           SCM context_property,
-                           SCM grob_property_path,
-                           SCM new_value)
+Grob_property_info::push (SCM grob_property_path, SCM new_value)
 {
-  SCM current_context_val = SCM_EOL;
-
-  Context *where = context->where_defined (context_property,
-                                           &current_context_val);
-
   /*
     Don't mess with MIDI.
   */
-  if (!where)
+  if (!create ())
     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 the car is a list, the property path comes from a nested override
-    using list syntax inside a \context block
-  */
-  if (scm_is_pair (scm_car (grob_property_path)))
-    grob_property_path = scm_car (grob_property_path);
-
   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))) {
+        props_->alist_ = scm_acons (grob_property_path, new_value, props_->alist_);
+        props_->nested_++;
+      }
+      return;
     }
 
   /* 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?"));
-
-  /*
-    tack onto alist.  We can use set_car, since
-    updated_grob_properties () in child contexts will check
-    for changes in the car.
-  */
-  if (ok)
-    {
-      scm_set_car_x (current_context_val, target_alist);
-    }
-}
 
-/*
-  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)
-{
-  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 (typecheck_grob (symbol, new_value))
+    props_->alist_ = scm_acons (symbol, new_value, props_->alist_);
 }
 
 /*
   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
@@ -203,13 +278,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);
 }
 
 /*
@@ -218,8 +291,7 @@ execute_pushpop_property (Context *context,
 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);
@@ -230,17 +302,20 @@ apply_property_operations (Context *tg, SCM pre_init_ops)
           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 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);
+          Grob_property_info (tg, context_prop).pop (grob_prop_path);
         }
       else if (type == ly_symbol2scm ("assign"))
         tg->set_property (scm_car (entry), scm_cadr (entry));
+      else if (type == ly_symbol2scm ("apply"))
+	scm_apply_1 (scm_car (entry), tg->self_scm (), scm_cdr (entry));
+      else if (type == ly_symbol2scm ("unset"))
+        tg->unset_property (scm_car (entry));
     }
 }
 
@@ -248,45 +323,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 = &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_;
 }