X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Flily-library.scm;fp=scm%2Flily-library.scm;h=ec1097a32b7ace1ae756e86f61fd5fa08f6cffd7;hb=32a34dcef0c0041c6d62677487a380b5c8b85712;hp=0e2c810da912504b32010ab56219732712c2cf5b;hpb=f41973ff763d5972a85995b6d40c864281ec6714;p=lilypond.git

diff --git a/scm/lily-library.scm b/scm/lily-library.scm
index 0e2c810da9..ec1097a32b 100644
--- a/scm/lily-library.scm
+++ b/scm/lily-library.scm
@@ -1,6 +1,6 @@
 ;;;; 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
@@ -19,6 +19,9 @@
 ; 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.
 
@@ -154,39 +157,39 @@
   (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"
-  (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)))
 
-(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"
-  (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
 
-(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
-  (let* ((base-name (get-current-filename parser))
-	 (output-suffix (get-current-suffix parser))
-	 (alist-key (format "~a~a" base-name output-suffix))
+  (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))
 	 (result base-name))
     ;; Allow all ASCII alphanumerics, including accents
     (if (string? output-suffix)
         (set! result
-              (format "~a-~a"
+              (format #f "~a-~a"
                       result
                       (string-regexp-substitute
                        "[^-[:alnum:]]"
@@ -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))
-	 (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)
@@ -227,6 +230,24 @@ bookoutput function"
       (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)))
 
@@ -236,6 +257,115 @@ bookoutput function"
                      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
@@ -522,6 +652,10 @@ right (@var{dir}=+1)."
 (define (other-axis a)
   (remainder (+ a 1) 2))
 
+(define-public (interval-scale iv factor)
+  (cons (* (car iv) factor)
+    (* (cdr iv) factor)))
+
 (define-public (interval-widen iv amount)
   (cons (- (car iv) amount)
     (+ (cdr iv) amount)))
@@ -852,17 +986,12 @@ print a warning and set an optional @var{default}."
     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)
-  (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")))