X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fdefine-event-classes.scm;h=f5a6cea5f01603f28080b606eef64c55079ef4cc;hb=b370c52fca172ffc5ac522cc2d92fc4c996b6b65;hp=fee440ad508f1924691f15d7e2e1e18e6eb20c78;hpb=fc9fdf1b559adff595d3e4869e02bf81b2309c73;p=lilypond.git

diff --git a/scm/define-event-classes.scm b/scm/define-event-classes.scm
index fee440ad50..f5a6cea5f0 100644
--- a/scm/define-event-classes.scm
+++ b/scm/define-event-classes.scm
@@ -59,20 +59,35 @@
     (Announcement . (AnnounceNewContext))
     ))
 
+(define-public (event-class-cons class parent classlist)
+  (let ((lineage (assq parent classlist)))
+    (if (not lineage)
+	(begin
+	  (if (not (null? parent))
+	      (ly:warning (_ "unknown parent class `~a'") parent))
+	  (set! lineage '())))
+    (if (symbol? class)
+	(acons class lineage classlist)
+	(fold (lambda (elt alist)
+		(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 ancestor-lookup (make-hash-table 11))
+(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.
-(for-each
- (lambda (rel)
-   (for-each
-    (lambda (type)
-      (hashq-set! ancestor-lookup type
-		  (cons type (hashq-ref ancestor-lookup (car rel) '()))))
-    (cdr rel)))
- event-classes)
 
 (define-public (define-event-class leaf heritage)
   (cond
@@ -96,7 +111,7 @@
 
 (define-public (ly:in-event-class? ev cl)
   "Does event @var{ev} belong to event class @var{cl}?"
-  (memq cl (ly:make-event-class (ly:event-property ev 'class))))
+  (memq cl (ly:event-property ev 'class)))
 
 ;; does this exist in guile already?
 (define (map-tree f t)