;;;; 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
; 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.
(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:]]"
(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)
(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)))
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
(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)))
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")))
projects / lilypond.git / blobdiff