X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fly-syntax-constructors.scm;h=eb323b8a00ecede1b03652bdcf2b6fd5bce13978;hb=42606c147e3604536715ee4355cbb0f1d552745e;hp=b3d7f3f0f01cf942ef71f7db0caa19fd47db742f;hpb=25ca54b640c067e2286a1d7ba47f24a1b4dc070e;p=lilypond.git diff --git a/scm/ly-syntax-constructors.scm b/scm/ly-syntax-constructors.scm index b3d7f3f0f0..eb323b8a00 100644 --- a/scm/ly-syntax-constructors.scm +++ b/scm/ly-syntax-constructors.scm @@ -1,6 +1,6 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; Copyright (C) 2006--2012 Erik Sandberg +;;;; Copyright (C) 2006--2015 Erik Sandberg ;;;; ;;;; LilyPond is free software: you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -20,28 +20,37 @@ (defmacro define-ly-syntax (args . body) `(define-public ,args ,@body)) -;; A ly-syntax constructor takes two extra parameters, parser and -;; location. These are mainly used for reporting errors and +;; A ly-syntax constructor takes one extra parameter, +;; location. This is mainly used for reporting errors and ;; warnings. This function is a syntactic sugar which uses the ;; location arg to set the origin of the returned music object; this ;; behaviour is usually desired (defmacro define-ly-syntax-loc (args . body) `(define-public ,args (let ((m ,(cons 'begin body))) - (set! (ly:music-property m 'origin) ,(third args)) + (set! (ly:music-property m 'origin) ,(second args)) m))) -;; Like define-ly-syntax-loc, but adds parser and location -;; parameters. Useful for simple constructors that don't need to +;; Like define-ly-syntax-loc, but adds location +;; parameter. Useful for simple constructors that don't need to ;; report errors. (defmacro define-ly-syntax-simple (args . body) `(define-public ,(cons* (car args) - 'parser 'location (cdr args)) (let ((m ,(cons 'begin body))) (set! (ly:music-property m 'origin) location) m))) +(define (music-function-call-error loc fun m) + (let* ((sig (ly:music-function-signature fun)) + (pred (if (pair? (car sig)) (caar sig) (car sig)))) + (ly:parser-error (*parser*) + (format #f (_ "~a function cannot return ~a") + (type-name pred) + (value->lily-string m (*parser*))) + loc) + (and (pair? (car sig)) (cdar sig)))) + ;; Music function: Apply function and check return value. ;; args are in reverse order, rest may specify additional ones ;; @@ -49,31 +58,28 @@ ;; and no fallback value had been available. In this case, ;; we don't call the function but rather return the general ;; fallback. -(define-ly-syntax (music-function parser loc fun args . rest) +(define-ly-syntax (music-function loc fun args . rest) (let* ((sig (ly:music-function-signature fun)) (pred (if (pair? (car sig)) (caar sig) (car sig))) (good (proper-list? args)) - (m (and good (apply (ly:music-function-extract fun) - parser loc (reverse! args rest))))) + (m (and good (with-fluids ((%location loc)) + (apply (ly:music-function-extract fun) + (reverse! args rest)))))) (if (and good (pred m)) (begin (if (ly:music? m) (set! (ly:music-property m 'origin) loc)) m) - (begin - (if good - (ly:parser-error parser - (format #f (_ "~a function cannot return ~a") - (type-name pred) m) - loc)) - (and (pair? (car sig)) (cdar sig)))))) + (if good + (music-function-call-error loc fun m) + (and (pair? (car sig)) (cdar sig)))))) -(define-ly-syntax (argument-error parser location n pred arg) +(define-ly-syntax (argument-error location n pred arg) (ly:parser-error - parser + (*parser*) (format #f (_ "wrong type for argument ~a. Expecting ~a, found ~s") - n (type-name pred) arg) + n (type-name pred) (music->make-music arg)) location)) (define-ly-syntax-simple (void-music) @@ -98,7 +104,7 @@ 'change-to-type type 'change-to-id id)) -(define-ly-syntax (tempo parser location text . rest) +(define-ly-syntax (tempo location text . rest) (let* ((unit (and (pair? rest) (car rest))) (count (and unit @@ -138,13 +144,13 @@ into a @code{MultiMeasureTextEvent}." (make-music 'MultiMeasureTextEvent music) music)) -(define-ly-syntax (multi-measure-rest parser location duration articulations) +(define-ly-syntax (multi-measure-rest location duration articulations) (make-music 'MultiMeasureRestMusic 'articulations (map script-to-mmrest-text articulations) 'duration duration 'origin location)) -(define-ly-syntax (repetition-chord parser location duration articulations) +(define-ly-syntax (repetition-chord location duration articulations) (make-music 'EventChord 'duration duration 'elements articulations @@ -156,7 +162,7 @@ into a @code{MultiMeasureTextEvent}." (if create-new (set! (ly:music-property csm 'create-new) #t)) csm)) -(define-ly-syntax (composed-markup-list parser location commands markups) +(define-ly-syntax (composed-markup-list location commands markups) ;; `markups' being a list of markups, eg (markup1 markup2 markup3), ;; and `commands' a list of commands with their scheme arguments, in reverse order, ;; eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg: @@ -183,7 +189,7 @@ into a @code{MultiMeasureTextEvent}." (make-map-markup-commands-markup-list compose complex) completed)))))))) -(define-ly-syntax (property-operation parser location ctx music-type symbol . args) +(define-ly-syntax (property-operation location ctx music-type symbol . args) (let* ((props (case music-type ((PropertySet) (list 'value (car args))) ((PropertyUnset) '()) @@ -206,15 +212,20 @@ into a @code{MultiMeasureTextEvent}." 'context-type ctx 'origin location))) -;; TODO: It seems that this function rarely returns anything useful. -(define (get-first-context-id type mus) - "Find the name of a ContextSpeccedMusic with given type" +(define (get-first-context-id! mus) + "Find the name of a ContextSpeccedMusic, possibly naming it" (let ((id (ly:music-property mus 'context-id))) - (if (and (eq? (ly:music-property mus 'type) 'ContextSpeccedMusic) - (eq? (ly:music-property mus 'context-type) type) - (string? id) - (not (string-null? id))) - id + (if (eq? (ly:music-property mus 'name) 'ContextSpeccedMusic) + (if (and (string? id) + (not (string-null? id))) + id + ;; We may reliably give a new context a unique name, but + ;; not an existing one + (if (ly:music-property mus 'create-new #f) + (let ((id (get-next-unique-voice-name))) + (set! (ly:music-property mus 'context-id) id) + id) + '())) '()))) (define unique-counter -1) @@ -225,7 +236,7 @@ into a @code{MultiMeasureTextEvent}." (define-ly-syntax-simple (lyric-event text duration) (make-lyric-event text duration)) -(define (lyric-combine-music sync music loc) +(define (lyric-combine-music sync sync-type music loc) ;; CompletizeExtenderEvent is added following the last lyric in MUSIC ;; to signal to the Extender_engraver that any pending extender should ;; be completed if the lyrics end before the associated voice. @@ -234,26 +245,29 @@ into a @code{MultiMeasureTextEvent}." (make-music 'LyricCombineMusic 'element music 'associated-context sync + 'associated-context-type sync-type 'origin loc)) -(define-ly-syntax (lyric-combine parser location voice music) - (lyric-combine-music voice music location)) +(define-ly-syntax (lyric-combine location voice typ music) + (lyric-combine-music voice typ music location)) -(define-ly-syntax (add-lyrics parser location music addlyrics-list) - (let* ((existing-voice-name (get-first-context-id 'Voice music)) +(define-ly-syntax (add-lyrics location music addlyrics-list) + (let* ((existing-voice-name (get-first-context-id! music)) (voice-name (if (string? existing-voice-name) existing-voice-name (get-next-unique-voice-name))) (voice (if (string? existing-voice-name) - (music) + music (make-music 'ContextSpeccedMusic 'element music 'context-type 'Voice 'context-id voice-name 'origin (ly:music-property music 'origin)))) + (voice-type (ly:music-property voice 'context-type)) (lyricstos (map (lambda (mus) (let* ((loc (ly:music-property mus 'origin)) - (lyr (lyric-combine-music voice-name mus loc))) + (lyr (lyric-combine-music + voice-name voice-type mus loc))) (make-music 'ContextSpeccedMusic 'create-new #t 'context-type 'Lyrics