Issue 4455/2: Pass location to syntax constructors as %location fluid

diff --git a/lily/music-function.cc b/lily/music-function.cc
index 353dc8997085b69778c95d7495d801e1e2ae5aba..da0860b9fe770f0a6a6b8d20b2fb8fce98809e62 100644 (file)
--- a/lily/music-function.cc
+++ b/lily/music-function.cc
@@ -168,6 +168,6 @@ Music_function::call (SCM rest)
   if (scm_is_true (scm_call_1 (pred, res)))
     return with_loc (res, location, false);
 
-  return scm_call_3 (ly_lily_module_constant ("music-function-call-error"),
-                     location, self_scm (), res);
+  return scm_call_2 (ly_lily_module_constant ("music-function-call-error"),
+                     self_scm (), res);
 }

diff --git a/lily/parser.yy b/lily/parser.yy
index 05227ca9200853a39922e11079eff90afcdae508..24f38b0e74b14dea9cffa3384f83e63aa5d97169 100644 (file)
--- a/lily/parser.yy
+++ b/lily/parser.yy
@@ -190,15 +190,36 @@ Lily_parser::parser_error (Input const *i, Lily_parser *parser, SCM *, const str
 - Don't use lily module, create a new module instead.
 - delay application of the function
 */
-#define LOWLEVEL_MAKE_SYNTAX(proc, args)       \
-  scm_apply_0 (proc, args)
+
+static SCM
+syntax_call (void *arg)
+{
+       SCM sarg = reinterpret_cast <SCM> (arg);
+       return scm_apply_0 (scm_car (sarg), scm_cdr (sarg));
+}
+
+#define LOWLEVEL_MAKE_SYNTAX(location, args)                           \
+       scm_c_with_fluid                                                \
+               (ly_lily_module_constant ("%location"),                 \
+                parser->lexer_->override_input (location).smobbed_copy (), \
+                syntax_call,                                           \
+                reinterpret_cast <void*> (args))
+
 /* Syntactic Sugar. */
 #define MAKE_SYNTAX(name, location, ...)                               \
-       LOWLEVEL_MAKE_SYNTAX (ly_lily_module_constant (name), scm_list_n (parser->lexer_->override_input (location).smobbed_copy (), ##__VA_ARGS__, SCM_UNDEFINED))
+       LOWLEVEL_MAKE_SYNTAX (location,                                 \
+                             scm_list_n (ly_lily_module_constant (name), \
+                                         ##__VA_ARGS__, SCM_UNDEFINED))
+
 #define START_MAKE_SYNTAX(name, ...)                                   \
-       scm_list_n (ly_lily_module_constant (name) , ##__VA_ARGS__, SCM_UNDEFINED)
+       scm_list_n (ly_lily_module_constant (name),                     \
+                   ##__VA_ARGS__, SCM_UNDEFINED)
+
 #define FINISH_MAKE_SYNTAX(start, location, ...)                       \
-       LOWLEVEL_MAKE_SYNTAX (scm_car (start), scm_cons (parser->lexer_->override_input (location).smobbed_copy (), scm_append_x (scm_list_2 (scm_cdr (start), scm_list_n (__VA_ARGS__, SCM_UNDEFINED)))))
+       LOWLEVEL_MAKE_SYNTAX (location,                                 \
+                             scm_append_x                              \
+                             (scm_list_2 (start, scm_list_n            \
+                                          (__VA_ARGS__, SCM_UNDEFINED))))
 
 SCM get_next_unique_context_id ();
 SCM get_next_unique_lyrics_context_id ();

diff --git a/scm/ly-syntax-constructors.scm b/scm/ly-syntax-constructors.scm
index a645b085da1cd0d8bfe5ba4959ba9b73a62367e5..9f2c98048df5eaf78561d1ee5713695973711572 100644 (file)
--- a/scm/ly-syntax-constructors.scm
+++ b/scm/ly-syntax-constructors.scm
@@ -20,35 +20,25 @@
 (defmacro define-ly-syntax (args . body)
   `(define-public ,args ,@body))
 
-;; 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
+;; A ly-syntax constructor can access location data as (*location*).
+;; This is mainly used for reporting errors and warnings. This
+;; function is a syntactic sugar which uses (*location*) 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) ,(second args))
-       m)))
-;; 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)
-                          'location
-                          (cdr args))
-     (let ((m ,(cons 'begin body)))
-       (set! (ly:music-property m 'origin) location)
+       (set! (ly:music-property m 'origin) (*location*))
        m)))
 
-(define (music-function-call-error loc fun m)
+(define (music-function-call-error fun m)
   (let* ((sig (ly:music-function-signature fun))
          (pred (if (pair? (car sig)) (caar sig) (car sig))))
     (ly:parser-error
                      (format #f (_ "~a function cannot return ~a")
                              (type-name pred)
                              (value->lily-string m))
-                     loc)
+                     (*location*))
     (and (pair? (car sig)) (cdar sig))))
 
 ;; Music function: Apply function and check return value.
@@ -58,59 +48,58 @@
 ;; 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 loc fun args . rest)
+(define-ly-syntax (music-function 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 (with-fluids ((%location loc))
-                                   (apply (ly:music-function-extract fun)
-                                          (reverse! args rest))))))
+         (m (and good (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))
+              (set! (ly:music-property m 'origin) (*location*)))
           m)
         (if good
-            (music-function-call-error loc fun m)
+            (music-function-call-error fun m)
             (and (pair? (car sig)) (cdar sig))))))
 
-(define-ly-syntax (argument-error location n pred arg)
+(define-ly-syntax (argument-error n pred arg)
   (ly:parser-error
    (format #f
            (_ "wrong type for argument ~a.  Expecting ~a, found ~s")
            n (type-name pred) (music->make-music arg))
-   location))
+   (*location*)))
 
-(define-ly-syntax-simple (void-music)
+(define-ly-syntax-loc (void-music)
   (make-music 'Music))
 
-(define-ly-syntax-simple (sequential-music mlist)
+(define-ly-syntax-loc (sequential-music mlist)
   (make-sequential-music mlist))
 
-(define-ly-syntax-simple (simultaneous-music mlist)
+(define-ly-syntax-loc (simultaneous-music mlist)
   (make-simultaneous-music mlist))
 
-(define-ly-syntax-simple (event-chord mlist)
+(define-ly-syntax-loc (event-chord mlist)
   (make-music 'EventChord
               'elements mlist))
 
-(define-ly-syntax-simple (unrelativable-music mus)
+(define-ly-syntax-loc (unrelativable-music mus)
   (make-music 'UnrelativableMusic
               'element mus))
 
-(define-ly-syntax-simple (context-change type id)
+(define-ly-syntax-loc (context-change type id)
   (make-music 'ContextChange
               'change-to-type type
               'change-to-id id))
 
-(define-ly-syntax (tempo location text . rest)
+(define-ly-syntax (tempo text . rest)
   (let* ((unit (and (pair? rest)
                     (car rest)))
          (count (and unit
                      (cadr rest)))
          (range-tempo? (pair? count))
          (tempo-change (make-music 'TempoChangeEvent
-                                   'origin location
+                                   'origin (*location*)
                                    'text text
                                    'tempo-unit unit
                                    'metronome-count count))
@@ -132,7 +121,7 @@
         (make-sequential-music (list tempo-change tempo-set))
         tempo-change)))
 
-(define-ly-syntax-simple (repeat type num body alts)
+(define-ly-syntax-loc (repeat type num body alts)
   (make-repeat type num body alts))
 
 (define (script-to-mmrest-text music)
@@ -143,25 +132,23 @@ into a @code{MultiMeasureTextEvent}."
       (make-music 'MultiMeasureTextEvent music)
       music))
 
-(define-ly-syntax (multi-measure-rest location duration articulations)
+(define-ly-syntax-loc (multi-measure-rest duration articulations)
   (make-music 'MultiMeasureRestMusic
               'articulations (map script-to-mmrest-text articulations)
-              'duration duration
-              'origin location))
+              'duration duration))
 
-(define-ly-syntax (repetition-chord location duration articulations)
+(define-ly-syntax-loc (repetition-chord duration articulations)
   (make-music 'EventChord
               'duration duration
-              'elements articulations
-              'origin location))
+              'elements articulations))
 
-(define-ly-syntax-simple (context-specification type id ops create-new mus)
+(define-ly-syntax-loc (context-specification type id ops create-new mus)
   (let ((csm (context-spec-music mus type id)))
     (set! (ly:music-property csm 'property-operations) ops)
     (if create-new (set! (ly:music-property csm 'create-new) #t))
     csm))
 
-(define-ly-syntax (composed-markup-list location commands markups)
+(define-ly-syntax (composed-markup-list 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:
@@ -188,7 +175,7 @@ into a @code{MultiMeasureTextEvent}."
                       (make-map-markup-commands-markup-list
                        compose complex) completed))))))))
 
-(define-ly-syntax (property-operation location ctx music-type symbol . args)
+(define-ly-syntax (property-operation ctx music-type symbol . args)
   (let* ((props (case music-type
                   ((PropertySet) (list 'value (car args)))
                   ((PropertyUnset) '())
@@ -204,12 +191,12 @@ into a @code{MultiMeasureTextEvent}."
                   (else (ly:error (_ "Invalid property operation ~a") music-type))))
          (m (apply make-music music-type
                    'symbol symbol
-                   'origin location
+                   'origin (*location*)
                    props)))
     (make-music 'ContextSpeccedMusic
                 'element m
                 'context-type ctx
-                'origin location)))
+                'origin (*location*))))
 
 (define (get-first-context-id! mus)
   "Find the name of a ContextSpeccedMusic, possibly naming it"
@@ -232,7 +219,7 @@ into a @code{MultiMeasureTextEvent}."
   (set! unique-counter (1+ unique-counter))
   (call-with-output-string (lambda (p) (format p "uniqueContext~s" unique-counter))))
 
-(define-ly-syntax-simple (lyric-event text duration)
+(define-ly-syntax-loc (lyric-event text duration)
   (make-lyric-event text duration))
 
 (define (lyric-combine-music sync sync-type music loc)
@@ -247,10 +234,10 @@ into a @code{MultiMeasureTextEvent}."
               'associated-context-type sync-type
               'origin loc))
 
-(define-ly-syntax (lyric-combine location voice typ music)
-  (lyric-combine-music voice typ music location))
+(define-ly-syntax (lyric-combine voice typ music)
+  (lyric-combine-music voice typ music (*location*)))
 
-(define-ly-syntax (add-lyrics location music addlyrics-list)
+(define-ly-syntax (add-lyrics music addlyrics-list)
   (let* ((existing-voice-name (get-first-context-id! music))
          (voice-name (if (string? existing-voice-name)
                          existing-voice-name