Release: bump version.

[lilypond.git] / scm / lily-library.scm

diff --git a/scm/lily-library.scm b/scm/lily-library.scm
index ede65ff5e2a54b88d303e0a2429e3980384c7022..91ece1e476a360785b81614f636d59e79d9123d7 100644 (file)
--- a/scm/lily-library.scm
+++ b/scm/lily-library.scm
@@ -1,6 +1,6 @@
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;

-;;;; Copyright (C) 1998--2011 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Copyright (C) 1998--2012 Jan Nieuwenhuizen <janneke@gnu.org>

 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify
 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify


@@ -19,6 +19,9 @@
 ; for take, drop, take-while, list-index, and find-tail:
 (use-modules (srfi srfi-1))
 
 ; for take, drop, take-while, list-index, and find-tail:
 (use-modules (srfi srfi-1))
 

+; for define-safe-public when byte-compiling using Guile V2
+(use-modules (scm safe-utility-defs))
+

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; constants.
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; constants.
 


@@ -154,31 +157,31 @@
   (ly:make-score music))
 
 
   (ly:make-score music))
 
 

-(define (get-current-filename parser)
+(define (get-current-filename parser book)

   "return any suffix value for output filename allowing for settings by
 calls to bookOutputName function"
   "return any suffix value for output filename allowing for settings by
 calls to bookOutputName function"

-  (let ((book-filename (ly:parser-lookup parser 'book-filename)))
+  (let ((book-filename (paper-variable parser book 'output-filename)))

     (if (not book-filename)
        (ly:parser-output-name parser)
        book-filename)))
 
     (if (not book-filename)
        (ly:parser-output-name parser)
        book-filename)))
 

-(define (get-current-suffix parser)
+(define (get-current-suffix parser book)

   "return any suffix value for output filename allowing for settings by calls to
 bookoutput function"
   "return any suffix value for output filename allowing for settings by calls to
 bookoutput function"

-  (let ((book-output-suffix (ly:parser-lookup parser 'book-output-suffix)))
+  (let ((book-output-suffix (paper-variable parser book 'output-suffix)))

     (if (not (string? book-output-suffix))
        (ly:parser-lookup parser 'output-suffix)
        book-output-suffix)))
 
 (define-public current-outfile-name #f)  ; for use by regression tests
 
     (if (not (string? book-output-suffix))
        (ly:parser-lookup parser 'output-suffix)
        book-output-suffix)))
 
 (define-public current-outfile-name #f)  ; for use by regression tests
 

-(define (get-outfile-name parser)
+(define (get-outfile-name parser book)

   "return current filename for generating backend output files"
   ;; user can now override the base file name, so we have to use
   ;; the file-name concatenated with any potential output-suffix value
   ;; as the key to out internal a-list
   "return current filename for generating backend output files"
   ;; user can now override the base file name, so we have to use
   ;; the file-name concatenated with any potential output-suffix value
   ;; as the key to out internal a-list

-  (let* ((base-name (get-current-filename parser))
-        (output-suffix (get-current-suffix parser))
+  (let* ((base-name (get-current-filename parser book))
+        (output-suffix (get-current-suffix parser book))

         (alist-key (format #f "~a~a" base-name output-suffix))
         (counter-alist (ly:parser-lookup parser 'counter-alist))
         (output-count (assoc-get alist-key counter-alist 0))
         (alist-key (format #f "~a~a" base-name output-suffix))
         (counter-alist (ly:parser-lookup parser 'counter-alist))
         (output-count (assoc-get alist-key counter-alist 0))


@@ -206,7 +209,7 @@ bookoutput function"
 (define (print-book-with parser book process-procedure)
   (let* ((paper (ly:parser-lookup parser '$defaultpaper))
         (layout (ly:parser-lookup parser '$defaultlayout))
 (define (print-book-with parser book process-procedure)
   (let* ((paper (ly:parser-lookup parser '$defaultpaper))
         (layout (ly:parser-lookup parser '$defaultlayout))

-        (outfile-name (get-outfile-name parser)))
+        (outfile-name (get-outfile-name parser book)))

     (process-procedure book paper layout outfile-name)))
 
 (define-public (print-book-with-defaults parser book)
     (process-procedure book paper layout outfile-name)))
 
 (define-public (print-book-with-defaults parser book)


@@ -227,6 +230,24 @@ bookoutput function"
       (else
           ((ly:parser-lookup parser 'toplevel-score-handler) parser score))))
 
       (else
           ((ly:parser-lookup parser 'toplevel-score-handler) parser score))))
 

+(define-public paper-variable
+  (let
+      ((get-papers
+       (lambda (parser book)
+         (append (if (and book (ly:output-def? (ly:book-paper book)))
+                     (list (ly:book-paper book))
+                     '())
+                 (ly:parser-lookup parser '$papers)
+                 (list (ly:parser-lookup parser '$defaultpaper))))))
+    (make-procedure-with-setter
+     (lambda (parser book symbol)
+       (any (lambda (p) (ly:output-def-lookup p symbol #f))
+           (get-papers parser book)))
+     (lambda (parser book symbol value)
+       (ly:output-def-set-variable!
+       (car (get-papers parser book))
+       symbol value)))))
+

 (define-public (add-text parser text)
   (add-score parser (list text)))
 
 (define-public (add-text parser text)
   (add-score parser (list text)))
 


@@ -236,6 +257,115 @@ bookoutput function"
                      parser
                     music))
 
                      parser
                     music))
 

+(define-public (context-mod-from-music parser music)
+  (let ((warn #t) (mods (ly:make-context-mod)))
+    (let loop ((m music) (context #f))
+      (if (music-is-of-type? m 'layout-instruction-event)
+         (let ((symbol (cons context (ly:music-property m 'symbol))))
+           (ly:add-context-mod
+            mods
+            (case (ly:music-property m 'name)
+              ((PropertySet)
+               (list 'assign
+                     symbol
+                     (ly:music-property m 'value)))
+              ((PropertyUnset)
+               (list 'unset symbol))
+              ((OverrideProperty)
+               (cons* 'push
+                      symbol
+                      (ly:music-property m 'grob-value)
+                      (ly:music-property m 'grob-property-path)))
+              ((RevertProperty)
+               (cons* 'pop
+                      symbol
+                      (ly:music-property m 'grob-property-path))))))
+         (case (ly:music-property m 'name)
+           ((ApplyContext)
+            (ly:add-context-mod mods
+                                (list 'apply
+                                      (ly:music-property m 'procedure))))
+           ((ContextSpeccedMusic)
+            (loop (ly:music-property m 'element)
+                  (ly:music-property m 'context-type)))
+           (else
+            (let ((callback (ly:music-property m 'elements-callback)))
+              (if (procedure? callback)
+                  (fold loop context (callback m))
+                  (if (and warn (ly:duration? (ly:music-property m 'duration)))
+                      (begin
+                        (ly:music-warning
+                         music
+                         (_ "Music unsuitable for context-mod"))
+                        (set! warn #f))))))))
+      context)
+    mods))
+
+(define-public (context-defs-from-music parser output-def music)
+  (let ((warn #t))
+    (let loop ((m music) (mods #f))
+      ;; The parser turns all sets, overrides etc into something
+      ;; wrapped in ContextSpeccedMusic.  If we ever get a set,
+      ;; override etc that is not wrapped in ContextSpeccedMusic, the
+      ;; user has created it in Scheme himself without providing the
+      ;; required wrapping.  In that case, using #f in the place of a
+      ;; context modification results in a reasonably recognizable
+      ;; error.
+      (if (music-is-of-type? m 'layout-instruction-event)
+         (ly:add-context-mod
+          mods
+          (case (ly:music-property m 'name)
+            ((PropertySet)
+             (list 'assign
+                   (ly:music-property m 'symbol)
+                   (ly:music-property m 'value)))
+            ((PropertyUnset)
+             (list 'unset
+                   (ly:music-property m 'symbol)))
+            ((OverrideProperty)
+             (cons* 'push
+                    (ly:music-property m 'symbol)
+                    (ly:music-property m 'grob-value)
+                    (ly:music-property m 'grob-property-path)))
+            ((RevertProperty)
+             (cons* 'pop
+                    (ly:music-property m 'symbol)
+                    (ly:music-property m 'grob-property-path)))))
+         (case (ly:music-property m 'name)
+           ((ApplyContext)
+            (ly:add-context-mod mods
+                                (list 'apply
+                                      (ly:music-property m 'procedure))))
+           ((ContextSpeccedMusic)
+            ;; Use let* here to let defs catch up with modifications
+            ;; to the context defs made in the recursion
+            (let* ((mods (loop (ly:music-property m 'element)
+                               (ly:make-context-mod)))
+                   (defs (ly:output-find-context-def
+                          output-def (ly:music-property m 'context-type))))
+              (if (null? defs)
+                  (ly:music-warning
+                   music
+                   (ly:format (_ "Cannot find context-def \\~a")
+                              (ly:music-property m 'context-type)))
+                  (for-each
+                   (lambda (entry)
+                     (ly:output-def-set-variable!
+                      output-def (car entry)
+                      (ly:context-def-modify (cdr entry) mods)))
+                   defs))))
+           (else
+            (let ((callback (ly:music-property m 'elements-callback)))
+              (if (procedure? callback)
+                  (fold loop mods (callback m))
+                  (if (and warn (ly:duration? (ly:music-property m 'duration)))
+                      (begin
+                        (ly:music-warning
+                         music
+                         (_ "Music unsuitable for output-def"))
+                        (set! warn #f))))))))
+      mods)))
+

 
 ;;;;;;;;;;;;;;;;
 ;; alist
 
 ;;;;;;;;;;;;;;;;
 ;; alist


@@ -852,17 +982,12 @@ print a warning and set an optional @var{default}."
     scaling))
 
 (define-public (version-not-seen-message input-file-name)
     scaling))
 
 (define-public (version-not-seen-message input-file-name)

-  (ly:message
-   "~a:0: ~a ~a"
-    input-file-name
-    (_ "warning:")
-    (format #f
-           (_ "no \\version statement found, please add~afor future compatibility")
-           (format #f "\n\n\\version ~s\n\n" (lilypond-version)))))
+  (ly:warning-located
+    (ly:format "~a:0" input-file-name)
+    (_ "no \\version statement found, please add~afor future compatibility")
+    (format #f "\n\n\\version ~s\n\n" (lilypond-version))))

 
 (define-public (old-relative-not-used-message input-file-name)
 
 (define-public (old-relative-not-used-message input-file-name)

-  (ly:message
-   "~a:0: ~a ~a"
-    input-file-name
-    (_ "warning:")
+  (ly:warning-located
+    (ly:format "~a:0" input-file-name)

     (_ "old relative compatibility not used")))
     (_ "old relative compatibility not used")))