X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fparser-ly-from-scheme.scm;h=00368e881fea665152831be7f4dc7938d1647b11;hb=HEAD;hp=0bc41722cc821d54a9ef6fce097856c0b209cdf1;hpb=7f3f0083f89d87c5ed0422858e9648fc759e98a4;p=lilypond.git diff --git a/scm/parser-ly-from-scheme.scm b/scm/parser-ly-from-scheme.scm index 0bc41722cc..00368e881f 100644 --- a/scm/parser-ly-from-scheme.scm +++ b/scm/parser-ly-from-scheme.scm @@ -1,87 +1,79 @@ -;;;; ly-from-scheme.scm -- parsing LilyPond music expressions from scheme +;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; source file of the GNU LilyPond music typesetter -;;;; -;;;; (c) 2004--2008 Nicolas Sceaux +;;;; Copyright (C) 2004--2015 Nicolas Sceaux ;;;; Jan Nieuwenhuizen - -(define gen-lily-sym - ;; Generate a lilyvartmpXX symbol, that may be (hopefully) unique. - (let ((var-idx -1)) - (lambda () - (set! var-idx (1+ var-idx)) - (string->symbol (format #f "lilyvartmp~a" - (list->string (map (lambda (chr) - (integer->char (+ (char->integer #\a) - (- (char->integer chr) - (char->integer #\0))))) - (string->list (number->string var-idx))))))))) - -(define-public (parse-string-result str parser) - "Parse `str', which is supposed to contain a music expression." - - (ly:parser-parse-string - parser - (format #f "parseStringResult = \\notemode { ~a }" str)) - (ly:parser-lookup parser 'parseStringResult)) +;;;; +;;;; LilyPond is free software: you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation, either version 3 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; LilyPond is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with LilyPond. If not, see . (define-public (read-lily-expression chr port) - "Read a #{ lily music expression #} from port and return -the scheme music expression. The $ character may be used to introduce -scheme forms, typically symbols. $$ may be used to simply write a `$' -character." - (let ((bindings '())) - - (define (create-binding! val) - "Create a new symbol, bind it to `val' and return it." - (let ((tmp-symbol (gen-lily-sym))) - (set! bindings (cons (cons tmp-symbol val) bindings)) - tmp-symbol)) - - (define (remove-dollars! form) - "Generate a form where `$variable' and `$ value' mottos are replaced - by new symbols, which are binded to the adequate values." - (cond (;; $variable - (and (symbol? form) - (string=? (substring (symbol->string form) 0 1) "$") - (not (and (<= 2 (string-length (symbol->string form))) - (string=? (substring (symbol->string form) 1 2) "$")))) - (create-binding! (string->symbol (substring (symbol->string form) 1)))) - (;; atom - (not (pair? form)) form) - (;; ($ value ...) - (eqv? (car form) '$) - (cons (create-binding! (cadr form)) (remove-dollars! (cddr form)))) - (else ;; (something ...) - (cons (remove-dollars! (car form)) (remove-dollars! (cdr form)))))) - - (let ((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 encoutered - (read-char port)) - (cond - ;; a $form expression - ((and (char=? c #\$) (not (char=? (peek-char port) #\$))) - (format out "\\~a" (create-binding! (read port)))) - ;; just a $ character - ((and (char=? c #\$) (char=? (peek-char port) #\$)) - ;; pop the second $ - (display (read-char port) out)) - ;; a #scheme expression - ((char=? c #\#) - (let ((expr (read port))) - (format out "#~s" (if (eq? '$ expr) - (create-binding! (read port)) - (remove-dollars! expr))))) - ;; other caracters - (else - (display c out)))))))) - `(let ((parser-clone (ly:parser-clone parser))) - ,@(map (lambda (binding) - `(ly:parser-define! parser-clone ',(car binding) ,(cdr binding))) - (reverse bindings)) - (parse-string-result ,lily-string parser-clone))))) + "Read a lilypond music expression enclosed within @code{#@{} and @code{#@}} +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) + (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 lily-string filename line closures) + (let* ((clone (ly:parser-clone closures (*location*))) + (result (ly:parse-string-expression clone lily-string + filename line))) + (if (ly:parser-has-error? clone) + (ly:parser-error (_ "error in #{ ... #}") (*location*))) + result)) + (list embedded-lilypond + lily-string filename line + (cons 'list (reverse! closures))))) (read-hash-extend #\{ read-lily-expression)