Add support for measures split across lines.

[lilypond.git] / scm / parser-ly-from-scheme.scm

diff --git a/scm/parser-ly-from-scheme.scm b/scm/parser-ly-from-scheme.scm
index f96af9396dfd11d7bbe31a192fc089af6411a954..ad95a16d24d2f74ebc70e793b6d485f09a67d2e4 100644 (file)
--- a/scm/parser-ly-from-scheme.scm
+++ b/scm/parser-ly-from-scheme.scm
@@ -1,6 +1,6 @@
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
-;;;; Copyright (C) 2004--2011  Nicolas Sceaux  <nicolas.sceaux@free.fr>
+;;;; Copyright (C) 2004--2012  Nicolas Sceaux  <nicolas.sceaux@free.fr>
 ;;;;           Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify
@@ -21,26 +21,57 @@
 from @var{port} and return the corresponding Scheme music expression.
 @samp{$} and @samp{#} introduce immediate and normal Scheme forms."
   (let* ((closures '())
+        (filename (port-filename port))
+        (line (port-line port))
         (lily-string (call-with-output-string
                       (lambda (out)
-                        (do ((c (read-char port) (read-char port)))
-                            ((and (char=? c #\#)
-                                  (char=? (peek-char port) #\})) ;; we stop when #} is encountered
-                             (read-char port))
-                          ;; a #scheme or $scheme expression
-                          (if (or (char=? c #\#) (char=? c #\$))
-                              (begin
-                                (set! closures (cons (read port) closures))
-                                (format out "~a~s" c (car closures)))
-                              ;; other characters
-                              (display c out)))))))
-    `(let* ((clone
-            (ly:parser-clone parser (list ,@(map (lambda (c)
-                                                   `(lambda () ,c))
-                                                 (reverse! closures)))))
-           (result (ly:parse-string-expression clone ,lily-string)))
-       (if (ly:parser-has-error? clone)
-          (ly:parser-error parser (_ "error in #{ ... #}")))
-       result)))
+                        (let ((copycat 
+                               (make-soft-port
+                                (vector #f #f #f
+                                        (lambda ()
+                                          (let ((x (read-char port)))
+                                            (write-char x out)
+                                            x)) #f)
+                                "r")))
+                          (set-port-filename! copycat filename)
+                          (do ((c (read-char port) (read-char port)))
+                              ((and (char=? c #\#)
+                                    (char=? (peek-char port) #\}))
+                               ;; we stop when #} is encountered
+                               (read-char port))
+                            (write-char c out)
+                            ;; a #scheme or $scheme expression
+                            (if (or (char=? c #\#) (char=? c #\$))
+                                (let* ((p (ftell out))
+                                       (expr
+                                        (begin
+                                          (set-port-line! copycat
+                                                          (port-line port))
+                                          (set-port-column! copycat
+                                                            (port-column port))
+                                          (if (char=? (peek-char port) #\@)
+                                              (read-char copycat))
+                                          (read copycat))))
+                                  ;; kill unused lookahead, it has been
+                                  ;; written out already
+                                  (drain-input copycat)
+                                  ;; only put symbols and non-quote
+                                  ;; lists into closures -- constants
+                                  ;; don't need lexical environments
+                                  ;; for evaluation.
+                                  (if (or (symbol? expr)
+                                          (and (pair? expr)
+                                               (not (eq? 'quote (car expr)))))
+                                      (set! closures
+                                            (cons `(cons ,p (lambda () ,expr))
+                                                  closures)))))))))))
+    (define (embedded-lilypond parser lily-string filename line closures)
+      (let* ((clone (ly:parser-clone parser closures))
+            (result (ly:parse-string-expression clone lily-string
+                                                filename line)))
+       (if (ly:parser-has-error? clone)
+           (ly:parser-error parser (_ "error in #{ ... #}")))
+       result))
+    (list embedded-lilypond 'parser lily-string filename line (cons 'list (reverse! closures)))))
 
 (read-hash-extend #\{ read-lily-expression)