Make EventClass hierarchy a property of Global context

diff --git a/input/regression/scheme-text-spanner.ly b/input/regression/scheme-text-spanner.ly
index c0204d55c71865f3c35ae69d28387916725b9adf..00cf863bd6f475e651e1cda8f359dc90a8183ff0 100644 (file)
--- a/input/regression/scheme-text-spanner.ly
+++ b/input/regression/scheme-text-spanner.ly
@@ -6,11 +6,27 @@ and grob creation methods to create a fully functional text spanner
 in scheme."
 }
 
-#(define-event-class 'scheme-text-span-event
-   '(scheme-text-span-event
-     span-event
-     music-event
-     StreamEvent))
+#(define my-grob-descriptions '())
+
+#(define my-event-classes (ly:make-context-mod))
+
+defineEventClass =
+#(define-void-function (parser location class parent)
+   (symbol? symbol?)
+   (ly:add-context-mod
+    my-event-classes
+    `(apply
+      ,(lambda (context class parent)
+        (ly:context-set-property!
+         context
+         'EventClasses
+         (event-class-cons
+          class
+          parent
+          (ly:context-property context 'EventClasses '()))))
+      ,class ,parent)))
+
+\defineEventClass #'scheme-text-span-event #'span-event
 
 #(define (add-grob-definition grob-name grob-entry)
    (let* ((meta-entry   (assoc-get 'meta grob-entry))
@@ -33,9 +49,9 @@ in scheme."
      (set! meta-entry (assoc-set! meta-entry 'interfaces
                                   ifaces-entry))
      (set! grob-entry (assoc-set! grob-entry 'meta meta-entry))
-     (set! all-grob-descriptions
+     (set! my-grob-descriptions
            (cons (cons grob-name grob-entry)
-                 all-grob-descriptions))))
+                 my-grob-descriptions))))
 
 #(add-grob-definition
   'SchemeTextSpanner
@@ -181,7 +197,8 @@ schemeTextSpannerEnd =
 \layout {
   \context {
     \Global
-    \grobdescriptions #all-grob-descriptions
+    \grobdescriptions #my-grob-descriptions
+    #my-event-classes
   }
   \context {
     \Voice

diff --git a/lily/context-scheme.cc b/lily/context-scheme.cc
index f58a793ed4ef805fcbcf4cd47435e88de47edf82..4f3818ecd8a3cf87841fd7d9bccb4c34e7ca3759 100644 (file)
--- a/lily/context-scheme.cc
+++ b/lily/context-scheme.cc
@@ -211,3 +211,15 @@ LY_DEFINE (ly_context_events_below, "ly:context-events-below",
   Context *ctx = unsmob_context (context);
   return ctx->events_below ()->self_scm ();
 }
+
+LY_DEFINE (ly_make_event_class, "ly:make-event-class",
+          2, 0, 0, (SCM context, SCM type),
+          "Make an event class (a list of types) from the given @var{type}"
+          " within the global context containing @var{context}.")
+{
+  LY_ASSERT_SMOB (Context, context, 1);
+  LY_ASSERT_TYPE (ly_is_symbol, type, 2);
+
+  Context *ctx = unsmob_context (context);
+  return ctx->make_event_class (type);
+}

diff --git a/lily/context.cc b/lily/context.cc
index 0551b3b702701ce56da8e74f77bd84895b239799..4d949e8379c0a02f34003794b7f5e62bf3ec0b80 100644 (file)
--- a/lily/context.cc
+++ b/lily/context.cc
@@ -91,6 +91,7 @@ Context::Context ()
   definition_mods_ = SCM_EOL;
   event_source_ = 0;
   events_below_ = 0;
+  ancestor_lookup_ = SCM_UNDEFINED;
 
   smobify_self ();
 
@@ -452,9 +453,7 @@ be called from any other place than the send_stream_event macro.
 void
 Context::internal_send_stream_event (SCM type, Input *origin, SCM props[])
 {
-  Stream_event *e = new Stream_event
-    (scm_call_1 (ly_lily_module_constant ("ly:make-event-class"), type),
-     origin);
+  Stream_event *e = new Stream_event (make_event_class (type), origin);
   for (int i = 0; props[i]; i += 2)
     {
       e->set_property (props[i], props[i + 1]);
@@ -595,6 +594,14 @@ Context::get_score_context () const
     return 0;
 }
 
+SCM
+Context::make_event_class (SCM event_type)
+{
+  if (SCM_UNBNDP (ancestor_lookup_))
+    ancestor_lookup_ = get_global_context ()->ancestor_lookup_;
+  return scm_hashq_ref (ancestor_lookup_, event_type, SCM_EOL);
+}
+
 Output_def *
 Context::get_output_def () const
 {
@@ -663,6 +670,8 @@ Context::mark_smob (SCM sm)
   if (me->events_below_)
     scm_gc_mark (me->events_below_->self_scm ());
 
+  scm_gc_mark (me->ancestor_lookup_);
+
   return me->properties_scm_;
 }
 

diff --git a/lily/engraver.cc b/lily/engraver.cc
index b8bf1234c04d625fe36c635c38aa3bad1a24c85b..db1303d63ce3b918f95e5d9f254c589a84bf89ea 100644 (file)
--- a/lily/engraver.cc
+++ b/lily/engraver.cc
@@ -53,7 +53,7 @@ Engraver::make_grob_info (Grob *e, SCM cause)
   /* TODO: Remove Music code when it's no longer needed */
   if (Music *m = unsmob_music (cause))
     {
-      cause = m->to_event ()->unprotect ();
+      cause = m->to_event (context ())->unprotect ();
     }
   if (e->get_property ("cause") == SCM_EOL
       && (unsmob_stream_event (cause) || unsmob_grob (cause)))

diff --git a/lily/global-context.cc b/lily/global-context.cc
index 9a4d4c51ffe938af36b5d9e698bd2b936bb01d27..3384133f353ab9e9546d50c55f88f18a52862bdc 100644 (file)
--- a/lily/global-context.cc
+++ b/lily/global-context.cc
@@ -51,6 +51,13 @@ Global_context::Global_context (Output_def *o)
     programming_error ("no `Global' context found");
   else
     globaldef->apply_default_property_operations (this);
+
+  SCM p = get_property ("EventClasses");
+
+  ancestor_lookup_ = scm_make_hash_table (scm_length (p));
+  for (;scm_is_pair (p); p = scm_cdr (p))
+    scm_hashq_set_x (ancestor_lookup_, scm_caar (p), scm_car (p));
+
   accepts_list_ = scm_list_1 (ly_symbol2scm ("Score"));
 }
 

diff --git a/lily/include/context.hh b/lily/include/context.hh
index 6a9e59358cdb5633549ac89e90e9846cd28b5dc8..5543235c25d4b668d2140300697bcb2914a68799 100644 (file)
--- a/lily/include/context.hh
+++ b/lily/include/context.hh
@@ -117,6 +117,13 @@ public:
   virtual Moment now_mom () const;
   virtual Context *get_default_interpreter (string context_id = "");
 
+  // It would make some sense to have the following just available in
+  // a global context.  It would be decidedly tricky, however, to have
+  // it initialized before the constructor of its Context base class
+  // was able to trigger garbage collection.
+  SCM ancestor_lookup_;
+  SCM make_event_class (SCM);
+
   bool is_alias (SCM) const;
   void add_alias (SCM);
   void add_context (Context *trans);

diff --git a/lily/include/music.hh b/lily/include/music.hh
index 83cc5ff4c3148a4add8d1c7b165bc46a0bfe8829..b0f48371048a50bc6f4a3d953d89fc20828a88da 100644 (file)
--- a/lily/include/music.hh
+++ b/lily/include/music.hh
@@ -24,6 +24,7 @@
 #include "moment.hh"
 #include "pitch.hh"
 #include "prob.hh"
+#include "context.hh"
 
 #define is_mus_type(x) internal_is_music_type (ly_symbol2scm (x))
 
@@ -39,7 +40,7 @@ public:
 
   bool internal_is_music_type (SCM) const;
 
-  Stream_event *to_event () const;
+  Stream_event *to_event (Context *) const;
 
   DECLARE_SCHEME_CALLBACK (relative_callback, (SCM, SCM));
   Pitch to_relative_octave (Pitch);

diff --git a/lily/music.cc b/lily/music.cc
index e96e83d59fa14016a3afc10b14c5b63fbcc7dd6e..cc814c074b456256eeb8f089781957c178091a46 100644 (file)
--- a/lily/music.cc
+++ b/lily/music.cc
@@ -271,7 +271,7 @@ Music::origin () const
   ES TODO: This method should probably be reworked or junked.
 */
 Stream_event *
-Music::to_event () const
+Music::to_event (Context *c) const
 {
   SCM class_name = ly_camel_case_2_lisp_identifier (get_property ("name"));
 
@@ -279,9 +279,8 @@ Music::to_event () const
   if (!internal_is_music_type (class_name))
     programming_error ("Not a music type");
 
-  Stream_event *e = new Stream_event
-    (scm_call_1 (ly_lily_module_constant ("ly:make-event-class"), class_name),
-     mutable_property_alist_);
+  Stream_event *e = new Stream_event (c->make_event_class (class_name),
+                                     mutable_property_alist_);
   Moment length = get_length ();
   if (length.to_bool ())
     e->set_property ("length", length.smobbed_copy ());
@@ -294,7 +293,7 @@ Music::to_event () const
       for (; scm_is_pair (art_mus); art_mus = scm_cdr (art_mus))
         {
           Music *m = unsmob_music (scm_car (art_mus));
-          art_ev = scm_cons (m->to_event ()->unprotect (), art_ev);
+          art_ev = scm_cons (m->to_event (c)->unprotect (), art_ev);
         }
       e->set_property ("articulations", scm_reverse_x (art_ev, SCM_EOL));
     }
@@ -311,7 +310,7 @@ Music::to_event () const
 void
 Music::send_to_context (Context *c)
 {
-  Stream_event *ev = to_event ();
+  Stream_event *ev = to_event (c);
   c->event_source ()->broadcast (ev);
   ev->unprotect ();
 }

diff --git a/lily/part-combine-iterator.cc b/lily/part-combine-iterator.cc
index e7bece69cb325579d49407b4b8d0992066b024bc..06449fb5dca228c13dd6a9daa0269cbce80c400e 100644 (file)
--- a/lily/part-combine-iterator.cc
+++ b/lily/part-combine-iterator.cc
@@ -224,8 +224,8 @@ Part_combine_iterator::kill_mmrest (int in)
   if (!mmrest_event_)
     {
       mmrest_event_ = new Stream_event
-       (scm_call_1 (ly_lily_module_constant ("ly:make-event-class"),
-                    ly_symbol2scm ("multi-measure-rest-event")));
+       (handles_[in].get_context ()->make_event_class
+        (ly_symbol2scm ("multi-measure-rest-event")));
       mmrest_event_->set_property ("duration", SCM_EOL);
       mmrest_event_->unprotect ();
     }
@@ -256,16 +256,15 @@ Part_combine_iterator::unisono (bool silent)
       if (playing_state_ != UNISONO
           && newstate == UNISONO)
         {
+          Context *out = (last_playing_ == SOLO2 ? second_iter_ : first_iter_)
+                         ->get_outlet ();
           if (!unisono_event_)
             {
               unisono_event_ = new Stream_event
-               (scm_call_1 (ly_lily_module_constant ("ly:make-event-class"),
-                            ly_symbol2scm ("unisono-event")));
+               (out->make_event_class (ly_symbol2scm ("unisono-event")));
               unisono_event_->unprotect ();
             }
 
-          Context *out = (last_playing_ == SOLO2 ? second_iter_ : first_iter_)
-                         ->get_outlet ();
           out->event_source ()->broadcast (unisono_event_);
           playing_state_ = UNISONO;
         }
@@ -291,8 +290,8 @@ Part_combine_iterator::solo1 ()
           if (!solo_one_event_)
             {
               solo_one_event_ = new Stream_event
-               (scm_call_1 (ly_lily_module_constant ("ly:make-event-class"),
-                            ly_symbol2scm ("solo-one-event")));
+               (first_iter_->get_outlet ()->make_event_class
+                (ly_symbol2scm ("solo-one-event")));
               solo_one_event_->unprotect ();
             }
 
@@ -318,8 +317,8 @@ Part_combine_iterator::solo2 ()
           if (!solo_two_event_)
             {
               solo_two_event_ = new Stream_event
-               (scm_call_1 (ly_lily_module_constant ("ly:make-event-class"),
-                            ly_symbol2scm ("solo-two-event")));
+               (second_iter_->get_outlet ()->make_event_class
+                (ly_symbol2scm ("solo-two-event")));
               solo_two_event_->unprotect ();
             }
 

diff --git a/lily/rhythmic-music-iterator.cc b/lily/rhythmic-music-iterator.cc
index 3a91d9d7cb21ab68d4faff9152de9449be274656..951c145ec83c65cee469f4cec50c6c1adafab3a5 100644 (file)
--- a/lily/rhythmic-music-iterator.cc
+++ b/lily/rhythmic-music-iterator.cc
@@ -47,7 +47,7 @@ Rhythmic_music_iterator::process (Moment m)
       descend_to_bottom_context ();
 
       Context *c = get_outlet ();
-      Stream_event *ev = get_music ()->to_event ();
+      Stream_event *ev = get_music ()->to_event (c);
       SCM arts = ev->get_property ("articulations");
 
       if (scm_is_pair (arts))

diff --git a/ly/engraver-init.ly b/ly/engraver-init.ly
index dbc8dbea56b086840fd47b5ea01284d17139c174..6e8210b9c183f788e5ab0bff425d6aaaf65d415d 100644 (file)
--- a/ly/engraver-init.ly
+++ b/ly/engraver-init.ly
@@ -26,6 +26,7 @@
   \defaultchild "Score"
   \description "Hard coded entry point for LilyPond.  Cannot be tuned."
   \grobdescriptions #all-grob-descriptions
+  EventClasses = #all-event-classes
 }
 
 \context {

diff --git a/ly/performer-init.ly b/ly/performer-init.ly
index 98ae0ceb8f6bfffe46783dc4b493d2ec43462d40..0ad1e2964ee9cab5e4b7b7f030b00f1fed8ffd71 100644 (file)
--- a/ly/performer-init.ly
+++ b/ly/performer-init.ly
@@ -35,6 +35,7 @@
   \name Global
   \accepts Score
   \description "Hard coded entry point for LilyPond.  Cannot be tuned."
+  EventClasses = #all-event-classes
 }
 
 \context {

diff --git a/scm/define-context-properties.scm b/scm/define-context-properties.scm
index 15c717ffd1d480ba969caa7aac4987991db97798..59baec69ad6b7140a0af48a1dad37a0d043c721b 100644 (file)
--- a/scm/define-context-properties.scm
+++ b/scm/define-context-properties.scm
@@ -583,6 +583,7 @@ are described in @rinternals{bar-line-interface}.")
      (apply translator-property-description x))
 
    `(
+     (EventClasses ,cheap-list? "The initial list of event classes.")
 
      (associatedVoiceContext ,ly:context? "The context object of the
 @code{Voice} that has the melody for this @code{Lyrics}.")

diff --git a/scm/define-event-classes.scm b/scm/define-event-classes.scm
index 51709463db64d6e9c334fd43e1b5769550eee029..e093337091d7610af2d36b2bc1e68c9c5bc5476b 100644 (file)
--- a/scm/define-event-classes.scm
+++ b/scm/define-event-classes.scm
@@ -72,47 +72,19 @@
                (acons elt lineage alist))
              classlist class))))
 
-(define all-event-classes
-  (fold (lambda (elt classlist)
-         (event-class-cons (cdr elt) (car elt) classlist))
-       '() event-classes))
-
-;; Maps event-class to a list of ancestors (inclusive)
-(define-public ancestor-lookup
-  (let ((h (make-hash-table (length all-event-classes))))
-    (for-each (lambda (ent) (hashq-set! h (car ent) ent))
-             all-event-classes)
-    h))
-
-
 ;; Each class will be defined as
 ;; (class parent grandparent .. )
 ;; so that (eq? (cdr class) parent) holds.
 
-(define-public (define-event-class leaf heritage)
-  (cond
-   ((not (eq? leaf (car heritage)))
-    (ly:warning (_ "All classes must be the last in their matrilineal line.")))
-   ((not (equal? (cdr heritage)
-                 (list-head (hashq-ref ancestor-lookup (cadr heritage) '())
-                            (length (cdr heritage)))))
-    (ly:warning (_ "All classes must have a well-defined pedigree in the existing class hierarchy.")))
-   (else (hashq-set! ancestor-lookup
-                     leaf
-                     (cons leaf
-                           (hashq-ref ancestor-lookup
-                                      (cadr heritage)
-                                      '())))))
-  *unspecified*)
-
-;; TODO: Allow entering more complex classes, by taking unions.
-(define-public (ly:make-event-class leaf)
- (hashq-ref ancestor-lookup leaf))
-
 (define-public (ly:in-event-class? ev cl)
   "Does event @var{ev} belong to event class @var{cl}?"
   (memq cl (ly:event-property ev 'class)))
 
+(define-public all-event-classes
+  (fold (lambda (elt classlist)
+         (event-class-cons (cdr elt) (car elt) classlist))
+       '() event-classes))
+
 ;; does this exist in guile already?
 (define (map-tree f t)
   (cond

diff --git a/scm/document-music.scm b/scm/document-music.scm
index c9bb9f011b1d96e634215fa7313bce30a1e31544..7d7e2a9942b974169b722eb2ec39b2e33200c390 100644 (file)
--- a/scm/document-music.scm
+++ b/scm/document-music.scm
@@ -16,6 +16,8 @@
 ;;;; You should have received a copy of the GNU General Public License
 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
 
+(define doc-context (ly:make-global-context $defaultlayout))
+
 (define (music-props-doc)
   (make <texi-node>
     #:name "Music properties"
@@ -31,7 +33,7 @@
 (define music-types->names (make-hash-table 61))
 (filter-map (lambda (entry)
              (let* ((class (ly:camel-case->lisp-identifier (car entry)))
-                    (classes (ly:make-event-class class)))
+                    (classes (ly:make-event-class doc-context class)))
                (if classes
                    (map
                     (lambda (cl)
@@ -88,7 +90,7 @@
   (let* ((namesym  (car obj))
         (props (cdr obj))
         (class (ly:camel-case->lisp-identifier namesym))
-        (classes (ly:make-event-class class))
+        (classes (ly:make-event-class doc-context class))
         (accept-list (if classes
                          (human-listify
                           (map ref-ify