X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fdisplay-lily.scm;h=b5a7cff139c58dfca945397ebfff5d7283f327ff;hb=b872748c6aa8bb721ced458691b38ac2fac5dfc8;hp=e591d50b1d47fe7744e643a0924e48be6759a4d6;hpb=659981f73d714c5c80b1ad529d6b8725e25ac877;p=lilypond.git diff --git a/scm/display-lily.scm b/scm/display-lily.scm index e591d50b1d..b5a7cff139 100644 --- a/scm/display-lily.scm +++ b/scm/display-lily.scm @@ -190,20 +190,18 @@ match thoses described in `pattern'." ;; build the test conditions for each element found in a (property . (e1 e2 ...)) pair. ;; this requires accessing to an element of a list, hence the index. ;; (typically, property will be 'elements) - ,@(map (lambda (prop-elements) - (let ((ges (gensym)) - (index -1)) - `(and ,@(map (lambda (e) - (set! index (1+ index)) - (if (music? e) - (gen-condition `(and (> (length (ly:music-property ,expr ',(car prop-elements))) - ,index) - (list-ref (ly:music-property ,expr ',(car prop-elements)) - ,index)) - e) - #t)) - (cdr prop-elements))))) - elements-list)))) + ,@(map + (lambda (prop-elements) + (let ((ges (gensym)) + (len (length (cdr prop-elements)))) + `(let ((,ges (ly:music-property ,expr ',(car prop-elements)))) + (and (eqv? (length+ ,ges) ,len) + ,@(filter-map + (lambda (e index) + (and (music? e) + (gen-condition `(list-ref ,ges ,index) e))) + (cdr prop-elements) (iota len)))))) + elements-list)))) (define (gen-bindings expr pattern) "Helper function for `with-music-match'. @@ -248,7 +246,7 @@ Generate binding forms by looking for ?var symbol in pattern." (cdr prop-elements)))) elements-list)))) -(define-macro (with-music-match music-expr+pattern . body) +(defmacro-public with-music-match (music-expr+pattern . body) "If `music-expr' matches `pattern', call `body'. `pattern' should look like: '(music property value @@ -269,10 +267,9 @@ inside body." (pattern (second music-expr+pattern)) (expr-sym (gensym))) `(let ((,expr-sym ,music-expr)) - (if ,(gen-condition expr-sym pattern) - (let ,(gen-bindings expr-sym pattern) - ,@body) - #f)))) + (and ,(gen-condition expr-sym pattern) + (let ,(gen-bindings expr-sym pattern) + ,@body))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;