X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fly-syntax-constructors.scm;h=0a12672095701cf1844cef2ba881010afe2be0de;hb=90e4d7057f3857da049dfda3d130017d4719bd6b;hp=54cea850ec9bd52b089c09e95f80110711419177;hpb=6ec61abd275a527807dd64bd216e1c5e6b8b74f3;p=lilypond.git

diff --git a/scm/ly-syntax-constructors.scm b/scm/ly-syntax-constructors.scm
index 54cea850ec..0a12672095 100644
--- a/scm/ly-syntax-constructors.scm
+++ b/scm/ly-syntax-constructors.scm
@@ -50,7 +50,7 @@
             (if (ly:music? m) (ly:set-origin! m) m)
             (music-function-call-error fun m))
         (and (pair? sigcar)
-             (if (ly:music (cdr sigcar))
+             (if (ly:music? (cdr sigcar))
                  (ly:music-deep-copy (cdr sigcar) (*location*))
                  (cdr sigcar))))))
 
@@ -203,36 +203,70 @@ into a @code{MultiMeasureTextEvent}."
 (define-public (partial-markup commands)
   ;; Like composed-markup-list, except that the result is a single
   ;; markup command that can be applied to one markup
-  (define (compose arg)
+  (define (compose rest)
     (fold
      (lambda (cmd prev) (append cmd (list prev)))
-     arg
-     commands))
-  (let ((chain (lambda (layout props arg)
-                 (interpret-markup layout props (compose arg)))))
-    (set-object-property! chain 'markup-signature (list markup?))
+     (append (car commands) rest)
+     (cdr commands)))
+  (let ((chain (lambda (layout props . rest)
+                 (interpret-markup layout props (compose rest)))))
+    (set! (markup-command-signature chain)
+          (list-tail
+           (markup-command-signature (caar commands))
+           (length (cdar commands))))
     chain))
 
-(define-public (property-operation ctx music-type symbol . args)
-  (let* ((props (case music-type
-                  ((PropertySet) (list 'value (car args)))
-                  ((PropertyUnset) '())
-                  ((OverrideProperty) (list 'grob-value (car args)
-                                            'grob-property-path (if (list? (cadr args))
-                                                                    (cadr args)
-                                                                    (cdr args))
-                                            'pop-first #t))
-                  ((RevertProperty)
-                   (if (list? (car args))
-                       (list 'grob-property-path (car args))
-                       (list 'grob-property-path args)))
-                  (else (ly:error (_ "Invalid property operation ~a") music-type))))
-         (m (ly:set-origin! (apply make-music music-type
-                                   'symbol symbol
-                                   props))))
-    (ly:set-origin! (make-music 'ContextSpeccedMusic
-                                'element m
-                                'context-type ctx))))
+(define-public (property-set context property value)
+  (ly:set-origin! (context-spec-music
+                   (ly:set-origin!
+                    (make-music 'PropertySet
+                                'symbol property
+                                'value value))
+                   context)))
+
+(define-public (property-unset context property)
+  (ly:set-origin! (context-spec-music
+                   (ly:set-origin!
+                    (make-music 'PropertyUnset
+                                'symbol property))
+                   context)))
+
+(define-public (property-override context path value)
+  (ly:set-origin! (context-spec-music
+                   (ly:set-origin!
+                    (make-music 'OverrideProperty
+                                'symbol (car path)
+                                'grob-property-path (cdr path)
+                                'grob-value value
+                                'pop-first #t))
+                   context)))
+
+(define-public (property-revert context path)
+  (ly:set-origin! (context-spec-music
+                   (ly:set-origin!
+                    (make-music 'RevertProperty
+                                'symbol (car path)
+                                'grob-property-path (cdr path)))
+                   context)))
+
+;; The signature here is slightly fishy since the "fallback return
+;; value" is not actually music but #f.  This used to be (void-music)
+;; but triggered "Parsed object should be dead" warnings for music
+;; objects outside of the current parser session/module.  The called
+;; functions always deliver music and are used from the parser in a
+;; manner where only the last argument is provided from outside the
+;; parser, and its predicate "scheme?" is always true.  So the
+;; fallback value will never get used and its improper type is no
+;; issue.
+(define-public property-override-function
+  (ly:make-music-function
+   (list (cons ly:music? #f) symbol? symbol-list? scheme?)
+   property-override))
+
+(define-public property-set-function
+  (ly:make-music-function
+   (list (cons ly:music? #f) symbol? symbol? scheme?)
+   property-set))
 
 (define (get-first-context-id! mus)
   "Find the name of a ContextSpeccedMusic, possibly naming it"
@@ -279,14 +313,16 @@ into a @code{MultiMeasureTextEvent}."
                                 'origin (ly:music-property music 'origin))))
          (voice-type (ly:music-property voice 'context-type))
          (lyricstos (map
-                     (lambda (mus)
+                     (lambda (mus+mods)
                        (with-location
-                        (ly:music-property mus 'origin)
+                        (ly:music-property (car mus+mods) 'origin)
                         (ly:set-origin! (make-music 'ContextSpeccedMusic
                                                     'create-new #t
                                                     'context-type 'Lyrics
+                                                    'property-operations (cdr mus+mods)
                                                     'element
                                                     (lyric-combine
-                                                     voice-name voice-type mus)))))
+                                                     voice-name voice-type
+                                                     (car mus+mods))))))
                      addlyrics-list)))
     (make-simultaneous-music (cons voice lyricstos))))