"If string FOO is given as argument, redirect
output to log file `FOO.log'.")
(midi-extension ,(if (eq? PLATFORM 'windows)
- "mid"
- "midi")
+ "mid"
+ "midi")
"Set the default file extension for MIDI output
file to given string.")
(music-strings-to-paths #f
;; initialization depend on these options.
(for-each (lambda (x)
- (ly:add-option (car x) (cadr x) (caddr x)))
- scheme-options-definitions)
+ (ly:add-option (car x) (cadr x) (caddr x)))
+ scheme-options-definitions)
(for-each (lambda (x)
- (ly:set-option (car x) (cdr x)))
- (eval-string (ly:command-line-options)))
+ (ly:set-option (car x) (cdr x)))
+ (eval-string (ly:command-line-options)))
(debug-set! stack 0)
;;(set-debug-cell-accesses! 1000)
(use-modules (ice-9 regex)
- (ice-9 safe)
- (ice-9 format)
- (ice-9 rdelim)
- (ice-9 optargs)
- (oop goops)
- (srfi srfi-1)
- (srfi srfi-13)
- (srfi srfi-14)
- (scm clip-region)
- (scm memory-trace)
- (scm coverage))
+ (ice-9 safe)
+ (ice-9 format)
+ (ice-9 rdelim)
+ (ice-9 optargs)
+ (oop goops)
+ (srfi srfi-1)
+ (srfi srfi-13)
+ (srfi srfi-14)
+ (scm clip-region)
+ (scm memory-trace)
+ (scm coverage))
(define-public _ gettext)
;;; There are new modules defined in Guile V2.0 which we need to use.
;;; Debugging evaluator is slower. This should have a more sensible
;;; default.
+
(if (or (ly:get-option 'verbose)
- (ly:get-option 'trace-memory-frequency)
- (ly:get-option 'trace-scheme-coverage))
+ (ly:get-option 'trace-memory-frequency)
+ (ly:get-option 'trace-scheme-coverage))
(begin
(ly:set-option 'protected-scheme-parsing #f)
(debug-enable 'backtrace)
(define-public DOS
(let ((platform (string-tokenize
- (vector-ref (uname) 0) char-set:letter+digit)))
+ (vector-ref (uname) 0) char-set:letter+digit)))
(if (null? (cdr platform)) #f
- (member (string-downcase (cadr platform)) '("95" "98" "me")))))
+ (member (string-downcase (cadr platform)) '("95" "98" "me")))))
(define (slashify x)
(if (string-index x #\\)
x
(string-regexp-substitute
- "//*" "/"
- (string-regexp-substitute "\\\\" "/" x))))
+ "//*" "/"
+ (string-regexp-substitute "\\\\" "/" x))))
(define-public (ly-getcwd)
(if (eq? PLATFORM 'windows)
(define-public (is-absolute? file-name)
(let ((file-name-length (string-length file-name)))
(if (= file-name-length 0)
- #f
- (or (eq? (string-ref file-name 0) #\/)
- (and (eq? PLATFORM 'windows)
- (> file-name-length 2)
- (eq? (string-ref file-name 1) #\:)
- (eq? (string-ref file-name 2) #\/))))))
+ #f
+ (or (eq? (string-ref file-name 0) #\/)
+ (and (eq? PLATFORM 'windows)
+ (> file-name-length 2)
+ (eq? (string-ref file-name 1) #\:)
+ (eq? (string-ref file-name 2) #\/))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; If necessary, emulate Guile V2 module_export_all! for Guile V1.8.n
(define (module-export-all! mod)
(define (fresh-interface!)
(let ((iface (make-module)))
- (set-module-name! iface (module-name mod))
- ;; for guile 2: (set-module-version! iface (module-version mod))
- (set-module-kind! iface 'interface)
- (set-module-public-interface! mod iface)
- iface))
+ (set-module-name! iface (module-name mod))
+ ;; for guile 2: (set-module-version! iface (module-version mod))
+ (set-module-kind! iface 'interface)
+ (set-module-public-interface! mod iface)
+ iface))
(let ((iface (or (module-public-interface mod)
- (fresh-interface!))))
+ (fresh-interface!))))
(set-module-obarray! iface (module-obarray mod))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (recursion-helper signature arguments count)
(define (helper pred? arg count)
(if (not (pred? arg))
- (begin
- (ly:input-message
- location
- (format
- #f (_ "wrong type for argument ~a. Expecting ~a, found ~s")
- count (type-name pred?) arg))
- #f)
- #t))
+ (begin
+ (ly:input-message
+ location
+ (format
+ #f (_ "wrong type for argument ~a. Expecting ~a, found ~s")
+ count (type-name pred?) arg))
+ #f)
+ #t))
(if (null? signature)
- #t
- (and (helper (car signature) (car arguments) count)
- (recursion-helper (cdr signature) (cdr arguments) (1+ count)))))
+ #t
+ (and (helper (car signature) (car arguments) count)
+ (recursion-helper (cdr signature) (cdr arguments) (1+ count)))))
(recursion-helper signature arguments 1))
(define-safe-public (lilypond-version)
(string-join
(map (lambda (x) (if (symbol? x)
- (symbol->string x)
- (number->string x)))
- (ly:version))
+ (symbol->string x)
+ (number->string x)))
+ (ly:version))
"."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; other files.
-(define init-scheme-files
+;;
+;; List of Scheme files to be loaded into the (lily) module.
+;;
+;; - Library definitions, need to be at the head of the list
+(define init-scheme-files-lib
'("lily-library.scm"
- "file-cache.scm"
+ "output-lib.scm"))
+;; - Files containing definitions used later by other files later in load
+(define init-scheme-files-used
+ '("markup-macros.scm"))
+;; - Main body of files to be loaded
+(define init-scheme-files-body
+ '("file-cache.scm"
"define-event-classes.scm"
"define-music-callbacks.scm"
"define-music-types.scm"
"define-note-names.scm"
- "output-lib.scm"
"c++.scm"
- "chord-ignatzek-names.scm"
"chord-entry.scm"
- "chord-generic-names.scm"
"stencil.scm"
+ "define-markup-commands.scm"
"markup.scm"
"modal-transforms.scm"
+ "chord-generic-names.scm"
+ "chord-ignatzek-names.scm"
"music-functions.scm"
"part-combiner.scm"
"autochange.scm"
"define-music-properties.scm"
"time-signature-settings.scm"
"auto-beam.scm"
+ "chord-name.scm"
"bezier-tools.scm"
"parser-ly-from-scheme.scm"
"ly-syntax-constructors.scm"
"define-context-properties.scm"
- ;; guile 1.9 wants markups defined before referenced
- "define-markup-commands.scm"
-
- "chord-name.scm"
"translation-functions.scm"
"script.scm"
"midi.scm"
"paper.scm"
"backend-library.scm"
- "x11-color.scm"
-
- ;; must be after everything has been defined
- "safe-lily.scm"))
+ "x11-color.scm"))
+;; - Files to be loaded last
+(define init-scheme-files-tail
+;; - must be after everything has been defined
+ '("safe-lily.scm"))
+;;
+;; Now construct the load list
+;;
+(define init-scheme-files
+ (append init-scheme-files-lib
+ init-scheme-files-used
+ init-scheme-files-body
+ init-scheme-files-tail))
(for-each ly:load init-scheme-files)
(define (profile-measurements)
(let* ((t (times))
- (stats (gc-stats)))
+ (stats (gc-stats)))
(list (- (+ (tms:cutime t)
- (tms:utime t))
- (assoc-get 'gc-time-taken stats))
- (assoc-get 'total-cells-allocated stats 0))))
+ (tms:utime t))
+ (assoc-get 'gc-time-taken stats))
+ (assoc-get 'total-cells-allocated stats 0))))
(define (dump-profile base last this)
(let* ((outname (format #f "~a.profile" (dir-basename base ".ly")))
- (diff (map (lambda (y) (apply - y)) (zip this last))))
+ (diff (map (lambda (y) (apply - y)) (zip this last))))
(ly:progress "\nWriting timing to ~a..." outname)
(format (open-file outname "w")
- "time: ~a\ncells: ~a\n"
- (if (ly:get-option 'dump-cpu-profile)
- (car diff)
- 0)
- (cadr diff))))
+ "time: ~a\ncells: ~a\n"
+ (if (ly:get-option 'dump-cpu-profile)
+ (car diff)
+ 0)
+ (cadr diff))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; debug memory leaks
(define-public (dump-live-object-stats outfile)
(for-each (lambda (x)
- (format outfile "~a: ~a\n" (car x) (cdr x)))
- (sort (gc-live-object-stats)
- (lambda (x y)
- (string<? (car x) (car y))))))
+ (format outfile "~a: ~a\n" (car x) (cdr x)))
+ (sort (gc-live-object-stats)
+ (lambda (x y)
+ (string<? (car x) (car y))))))
(define-public (dump-gc-protects)
(set! gc-protect-stat-count (1+ gc-protect-stat-count))
(let* ((protects (sort (hash-table->alist (ly:protects))
- (lambda (a b)
- (< (object-address (car a))
- (object-address (car b))))))
- (out-file-name (string-append
- "gcstat-" (number->string gc-protect-stat-count)
- ".scm"))
- (outfile (open-file out-file-name "w")))
+ (lambda (a b)
+ (< (object-address (car a))
+ (object-address (car b))))))
+ (out-file-name (string-append
+ "gcstat-" (number->string gc-protect-stat-count)
+ ".scm"))
+ (outfile (open-file out-file-name "w")))
(set! gc-dumping #t)
(format #t "Dumping GC statistics ~a...\n" out-file-name)
(for-each (lambda (y)
- (let ((x (car y))
- (c (cdr y)))
- (format outfile "~a (~a) = ~a\n" (object-address x) c x)))
- (filter
- (lambda (x)
- (not (symbol? (car x))))
- protects))
+ (let ((x (car y))
+ (c (cdr y)))
+ (format outfile "~a (~a) = ~a\n" (object-address x) c x)))
+ (filter
+ (lambda (x)
+ (not (symbol? (car x))))
+ protects))
(format outfile "\nprotected symbols: ~a\n"
- (apply + (map (lambda (obj-count)
- (if (symbol? (car obj-count))
- (cdr obj-count)
- 0))
- protects)))
+ (apply + (map (lambda (obj-count)
+ (if (symbol? (car obj-count))
+ (cdr obj-count)
+ 0))
+ protects)))
;; (display (ly:smob-protects))
(newline outfile)
(if (defined? 'gc-live-object-stats)
- (let* ((stats #f))
- (display "Live object statistics: GC'ing\n")
- (ly:reset-all-fonts)
- (gc)
- (gc)
- (display "Asserting dead objects\n")
- (ly:set-option 'debug-gc-assert-parsed-dead #t)
- (gc)
- (ly:set-option 'debug-gc-assert-parsed-dead #f)
- (set! stats (gc-live-object-stats))
- (display "Dumping live object statistics.\n")
- (dump-live-object-stats outfile)))
+ (let* ((stats #f))
+ (display "Live object statistics: GC'ing\n")
+ (ly:reset-all-fonts)
+ (gc)
+ (gc)
+ (display "Asserting dead objects\n")
+ (ly:set-option 'debug-gc-assert-parsed-dead #t)
+ (gc)
+ (ly:set-option 'debug-gc-assert-parsed-dead #f)
+ (set! stats (gc-live-object-stats))
+ (display "Dumping live object statistics.\n")
+ (dump-live-object-stats outfile)))
(newline outfile)
(let* ((stats (gc-stats)))
(for-each (lambda (sym)
- (format outfile "~a ~a ~a\n"
- gc-protect-stat-count
- sym
- (assoc-get sym stats "?")))
- '(protected-objects bytes-malloced cell-heap-size)))
+ (format outfile "~a ~a ~a\n"
+ gc-protect-stat-count
+ sym
+ (assoc-get sym stats "?")))
+ '(protected-objects bytes-malloced cell-heap-size)))
(set! gc-dumping #f)
(close-port outfile)))
"Read `/proc/self' to check up on memory use."
(define (gulp-file name)
(let* ((file (open-input-file name))
- (text (read-delimited "" file)))
+ (text (read-delimited "" file)))
(close file)
text))
(let* ((stat (gulp-file "/proc/self/status"))
- (lines (string-split stat #\newline))
- (interesting (filter identity
- (map
- (lambda (l)
- (string-match "^VmData:[ \t]*([0-9]*) kB" l))
- lines)))
- (mem (string->number (match:substring (car interesting) 1))))
+ (lines (string-split stat #\newline))
+ (interesting (filter identity
+ (map
+ (lambda (l)
+ (string-match "^VmData:[ \t]*([0-9]*) kB" l))
+ lines)))
+ (mem (string->number (match:substring (car interesting) 1))))
(format #t "VMDATA: ~a\n" mem)
(display (gc-stats))
(if (> mem 100000)
- (begin (dump-gc-protects)
- (raise 1)))))
+ (begin (dump-gc-protects)
+ (raise 1)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
PIDs or the number of the process."
(define (helper count acc)
(if (> count 0)
- (let* ((pid (primitive-fork)))
- (if (= pid 0)
- (1- count)
- (helper (1- count) (cons pid acc))))
- acc))
+ (let* ((pid (primitive-fork)))
+ (if (= pid 0)
+ (1- count)
+ (helper (1- count) (cons pid acc))))
+ acc))
(helper count '()))
"Exit function for lilypond"
(if (not silently)
(case status
- ((0) (ly:success (_ "Compilation successfully completed")))
- ((1) (ly:warning (_ "Compilation completed with warnings or errors")))
- (else (ly:message ""))))
+ ((0) (ly:success (_ "Compilation successfully completed")))
+ ((1) (ly:warning (_ "Compilation completed with warnings or errors")))
+ (else (ly:message ""))))
(exit status))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(eval-string (ly:command-line-code))
(if (ly:get-option 'help)
(begin (ly:option-usage)
- (ly:exit 0 #t)))
+ (ly:exit 0 #t)))
(if (ly:get-option 'show-available-fonts)
(begin (ly:font-config-display-fonts)
- (ly:exit 0 #t)))
+ (ly:exit 0 #t)))
(if (ly:get-option 'gui)
(gui-main files))
(if (null? files)
(begin (ly:usage)
- (ly:exit 2 #t)))
+ (ly:exit 2 #t)))
(if (ly:get-option 'read-file-list)
(set! files
- (filter (lambda (s)
- (> (string-length s) 0))
- (apply append
- (map (lambda (f)
- (string-split (ly:gulp-file f) #\nl))
- files)))))
+ (filter (lambda (s)
+ (> (string-length s) 0))
+ (apply append
+ (map (lambda (f)
+ (string-split (ly:gulp-file f) #\nl))
+ files)))))
(if (and (number? (ly:get-option 'job-count))
- (>= (length files) (ly:get-option 'job-count)))
+ (>= (length files) (ly:get-option 'job-count)))
(let* ((count (ly:get-option 'job-count))
- (split-todo (split-list files count))
- (joblist (multi-fork count))
- (errors '()))
- (if (not (string-or-symbol? (ly:get-option 'log-file)))
- (ly:set-option 'log-file "lilypond-multi-run"))
- (if (number? joblist)
- (begin (ly:set-option
- 'log-file (format #f "~a-~a"
- (ly:get-option 'log-file) joblist))
- (set! files (vector-ref split-todo joblist)))
- (begin (ly:progress "\nForking into jobs: ~a\n" joblist)
- (for-each
- (lambda (pid)
- (let* ((stat (cdr (waitpid pid))))
- (if (not (= stat 0))
- (set! errors
- (acons (list-element-index joblist pid)
- stat errors)))))
- joblist)
- (for-each
- (lambda (x)
- (let* ((job (car x))
- (state (cdr x))
- (logfile (format #f "~a-~a.log"
- (ly:get-option 'log-file) job))
- (log (ly:gulp-file logfile))
- (len (string-length log))
- (tail (substring log (max 0 (- len 1024)))))
- (if (status:term-sig state)
- (ly:message
- "\n\n~a\n"
- (format #f (_ "job ~a terminated with signal: ~a")
- job (status:term-sig state)))
- (ly:message
- (_ "logfile ~a (exit ~a):\n~a")
- logfile (status:exit-val state) tail))))
- errors)
- (if (pair? errors)
- (ly:error "Children ~a exited with errors."
- (map car errors)))
- ;; must overwrite individual entries
- (if (ly:get-option 'dump-profile)
- (dump-profile "lily-run-total"
- '(0 0) (profile-measurements)))
- (if (null? errors)
- (ly:exit 0 #f)
- (ly:exit 1 #f))))))
+ (split-todo (split-list files count))
+ (joblist (multi-fork count))
+ (errors '()))
+ (if (not (string-or-symbol? (ly:get-option 'log-file)))
+ (ly:set-option 'log-file "lilypond-multi-run"))
+ (if (number? joblist)
+ (begin (ly:set-option
+ 'log-file (format #f "~a-~a"
+ (ly:get-option 'log-file) joblist))
+ (set! files (vector-ref split-todo joblist)))
+ (begin (ly:progress "\nForking into jobs: ~a\n" joblist)
+ (for-each
+ (lambda (pid)
+ (let* ((stat (cdr (waitpid pid))))
+ (if (not (= stat 0))
+ (set! errors
+ (acons (list-element-index joblist pid)
+ stat errors)))))
+ joblist)
+ (for-each
+ (lambda (x)
+ (let* ((job (car x))
+ (state (cdr x))
+ (logfile (format #f "~a-~a.log"
+ (ly:get-option 'log-file) job))
+ (log (ly:gulp-file logfile))
+ (len (string-length log))
+ (tail (substring log (max 0 (- len 1024)))))
+ (if (status:term-sig state)
+ (ly:message
+ "\n\n~a\n"
+ (format #f (_ "job ~a terminated with signal: ~a")
+ job (status:term-sig state)))
+ (ly:message
+ (_ "logfile ~a (exit ~a):\n~a")
+ logfile (status:exit-val state) tail))))
+ errors)
+ (if (pair? errors)
+ (ly:error "Children ~a exited with errors."
+ (map car errors)))
+ ;; must overwrite individual entries
+ (if (ly:get-option 'dump-profile)
+ (dump-profile "lily-run-total"
+ '(0 0) (profile-measurements)))
+ (if (null? errors)
+ (ly:exit 0 #f)
+ (ly:exit 1 #f))))))
(if (string-or-symbol? (ly:get-option 'log-file))
(ly:stderr-redirect (format #f "~a.log" (ly:get-option 'log-file)) "w"))
(let ((failed (lilypond-all files)))
(if (ly:get-option 'trace-scheme-coverage)
- (begin
- (coverage:show-all (lambda (f)
- (string-contains f "lilypond")))))
+ (begin
+ (coverage:show-all (lambda (f)
+ (string-contains f "lilypond")))))
(if (pair? failed)
- (begin (ly:error (_ "failed files: ~S") (string-join failed))
- (ly:exit 1 #f))
- (begin
- (ly:exit 0 #f)))))
+ (begin (ly:error (_ "failed files: ~S") (string-join failed))
+ (ly:exit 1 #f))
+ (begin
+ (ly:exit 0 #f)))))
(define-public (lilypond-all files)
(let* ((failed '())
- (separate-logs (ly:get-option 'separate-log-files))
- (ping-log
- (if separate-logs
- (open-file (if (string-or-symbol? (ly:get-option 'log-file))
- (format #f "~a.log" (ly:get-option 'log-file))
- "/dev/stderr") "a") #f))
- (do-measurements (ly:get-option 'dump-profile))
- (handler (lambda (key failed-file)
- (set! failed (append (list failed-file) failed)))))
+ (separate-logs (ly:get-option 'separate-log-files))
+ (ping-log
+ (if separate-logs
+ (open-file (if (string-or-symbol? (ly:get-option 'log-file))
+ (format #f "~a.log" (ly:get-option 'log-file))
+ "/dev/stderr") "a") #f))
+ (do-measurements (ly:get-option 'dump-profile))
+ (handler (lambda (key failed-file)
+ (set! failed (append (list failed-file) failed)))))
(gc)
(for-each
(lambda (x)
(let* ((start-measurements (if do-measurements
- (profile-measurements)
- #f))
- (base (dir-basename x ".ly"))
- (all-settings (ly:all-options)))
- (if separate-logs
- (ly:stderr-redirect (format #f "~a.log" base) "w"))
- (if ping-log
- (format ping-log "Processing ~a\n" base))
- (if (ly:get-option 'trace-memory-frequency)
- (mtrace:start-trace (ly:get-option 'trace-memory-frequency)))
- (lilypond-file handler x)
- (if start-measurements
- (dump-profile x start-measurements (profile-measurements)))
- (if (ly:get-option 'trace-memory-frequency)
- (begin (mtrace:stop-trace)
- (mtrace:dump-results base)))
- (for-each (lambda (s)
- (ly:set-option (car s) (cdr s)))
- all-settings)
- (ly:set-option 'debug-gc-assert-parsed-dead #t)
- (gc)
- (ly:set-option 'debug-gc-assert-parsed-dead #f)
- (if (ly:get-option 'debug-gc)
- (dump-gc-protects)
+ (profile-measurements)
+ #f))
+ (base (dir-basename x ".ly"))
+ (all-settings (ly:all-options)))
+ (if separate-logs
+ (ly:stderr-redirect (format #f "~a.log" base) "w"))
+ (if ping-log
+ (format ping-log "Processing ~a\n" base))
+ (if (ly:get-option 'trace-memory-frequency)
+ (mtrace:start-trace (ly:get-option 'trace-memory-frequency)))
+ (lilypond-file handler x)
+ (if start-measurements
+ (dump-profile x start-measurements (profile-measurements)))
+ (if (ly:get-option 'trace-memory-frequency)
+ (begin (mtrace:stop-trace)
+ (mtrace:dump-results base)))
+ (for-each (lambda (s)
+ (ly:set-option (car s) (cdr s)))
+ all-settings)
+ (ly:set-option 'debug-gc-assert-parsed-dead #t)
+ (gc)
+ (ly:set-option 'debug-gc-assert-parsed-dead #f)
+ (if (ly:get-option 'debug-gc)
+ (dump-gc-protects)
(ly:reset-all-fonts))))
files)
;; Ensure a notice re failed files is written to aggregate logfile.
(if ping-log
- (format ping-log "Failed files: ~a\n" failed))
+ (format ping-log "Failed files: ~a\n" failed))
(if (ly:get-option 'dump-profile)
- (dump-profile "lily-run-total" '(0 0) (profile-measurements)))
+ (dump-profile "lily-run-total" '(0 0) (profile-measurements)))
failed))
(define (lilypond-file handler file-name)
(catch 'ly-file-failed
- (lambda () (ly:parse-file file-name))
- (lambda (x . args) (handler x file-name))))
+ (lambda () (ly:parse-file file-name))
+ (lambda (x . args) (handler x file-name))))
(use-modules (scm editor))
(gui-no-files-handler))
(if (not (string? (ly:get-option 'log-file)))
(let* ((base (dir-basename (car files) ".ly"))
- (log-name (string-append base ".log")))
- (if (not (ly:get-option 'gui))
- (ly:message (_ "Redirecting output to ~a...") log-name))
- (ly:stderr-redirect log-name "w")
- (ly:message "# -*-compilation-*-"))
+ (log-name (string-append base ".log")))
+ (if (not (ly:get-option 'gui))
+ (ly:message (_ "Redirecting output to ~a...") log-name))
+ (ly:stderr-redirect log-name "w")
+ (ly:message "# -*-compilation-*-"))
(let ((failed (lilypond-all files)))
- (if (pair? failed)
- (begin
- ;; ugh
- (ly:stderr-redirect "foo" "r")
- (system (get-editor-command log-name 0 0 0))
- (ly:error (_ "failed files: ~S") (string-join failed))
- ;; not reached?
- (exit 1))
- (ly:exit 0 #f)))))
+ (if (pair? failed)
+ (begin
+ ;; ugh
+ (ly:stderr-redirect "foo" "r")
+ (system (get-editor-command log-name 0 0 0))
+ (ly:error (_ "failed files: ~S") (string-join failed))
+ ;; not reached?
+ (exit 1))
+ (ly:exit 0 #f)))))
(define (gui-no-files-handler)
(let* ((ly (string-append (ly:effective-prefix) "/ly/"))
- ;; FIXME: soft-code, localize
- (welcome-ly (string-append ly "Welcome_to_LilyPond.ly"))
- (cmd (get-editor-command welcome-ly 0 0 0)))
+ ;; FIXME: soft-code, localize
+ (welcome-ly (string-append ly "Welcome_to_LilyPond.ly"))
+ (cmd (get-editor-command welcome-ly 0 0 0)))
(ly:message (_ "Invoking `~a'...\n") cmd)
(system cmd)
(ly:exit 1 #f)))
--- /dev/null
+;;;; This file is part of LilyPond, the GNU music typesetter.
+;;;;
+;;;; Copyright (C) 2003--2010 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;;
+;;;; 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 <http://www.gnu.org/licenses/>.
+
+"
+Internally markup is stored as lists, whose head is a function.
+
+ (FUNCTION ARG1 ARG2 ... )
+
+When the markup is formatted, then FUNCTION is called as follows
+
+ (FUNCTION GROB PROPS ARG1 ARG2 ... )
+
+GROB is the current grob, PROPS is a list of alists, and ARG1.. are
+the rest of the arguments.
+
+The function should return a stencil (i.e. a formatted, ready to
+print object).
+
+
+To add a markup command, use the define-markup-command utility.
+
+ (define-markup-command (mycommand layout prop arg1 ...) (arg1-type? ...)
+ \"my command usage and description\"
+ ...function body...)
+
+The command is now available in markup mode, e.g.
+
+ \\markup { .... \\MYCOMMAND #1 argument ... }
+
+" ; "
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; markup definer utilities
+
+;; For documentation purposes
+;; category -> markup functions
+(define-public markup-functions-by-category (make-hash-table 150))
+;; markup function -> used properties
+(define-public markup-functions-properties (make-weak-key-hash-table 151))
+;; List of markup list functions
+(define-public markup-list-functions (make-weak-key-hash-table 151))
+
+(use-modules (ice-9 optargs))
+
+(defmacro*-public define-markup-command
+ (command-and-args signature
+ #:key (category '()) (properties '())
+ #:rest body)
+ "
+* Define a COMMAND-markup function after command-and-args and body,
+register COMMAND-markup and its signature,
+
+* add COMMAND-markup to markup-functions-by-category,
+
+* sets COMMAND-markup markup-signature object property,
+
+* define a make-COMMAND-markup function.
+
+Syntax:
+ (define-markup-command (COMMAND layout props . arguments)
+ argument-types
+ [ #:properties properties ]
+ \"documentation string\"
+ ...command body...)
+
+where:
+ `argument-types' is a list of type predicates for arguments
+ `properties' a list of (property default-value) lists
+
+The specified properties are available as let-bound variables in the
+command body, using the respective `default-value' as fallback in case
+`property' is not found in `props'. `props' itself is left unchanged:
+if you want defaults specified in that manner passed down into other
+markup functions, you need to adjust `props' yourself.
+
+The autogenerated documentation makes use of some optional
+specifications that are otherwise ignored:
+
+After `argument-types', you may also specify
+ [ #:category category ]
+where:
+ `category' is either a symbol or a symbol list specifying the
+ category for this markup command in the docs.
+
+As an element of the `properties' list, you may directly use a
+COMMANDx-markup symbol instead of a `(prop value)' list to indicate
+that this markup command is called by the newly defined command,
+adding its properties to the documented properties of the new
+command. There is no protection against circular definitions.
+"
+ (let* ((command (car command-and-args))
+ (args (cdr command-and-args))
+ (command-name (string->symbol (format #f "~a-markup" command)))
+ (make-markup-name (string->symbol (format #f "make-~a-markup" command))))
+ (while (and (pair? body) (keyword? (car body)))
+ (set! body (cddr body)))
+ `(begin
+ ;; define the COMMAND-markup function
+ ,(let* ((documentation (if (string? (car body))
+ (list (car body))
+ '()))
+ (real-body (if (or (null? documentation)
+ (null? (cdr body)))
+ body (cdr body))))
+ `(define-public (,command-name ,@args)
+ ,@documentation
+ (let ,(map (lambda (prop-spec)
+ (let ((prop (car prop-spec))
+ (default-value (if (null? (cdr prop-spec))
+ #f
+ (cadr prop-spec)))
+ (props (cadr args)))
+ `(,prop (chain-assoc-get ',prop ,props ,default-value))))
+ (filter pair? properties))
+ ,@real-body)))
+ (set! (markup-command-signature ,command-name) (list ,@signature))
+ ;; Register the new function, for markup documentation
+ ,@(map (lambda (category)
+ `(hashq-set!
+ (or (hashq-ref markup-functions-by-category ',category)
+ (let ((hash (make-weak-key-hash-table 151)))
+ (hashq-set! markup-functions-by-category ',category
+ hash)
+ hash))
+ ,command-name #t))
+ (if (list? category) category (list category)))
+ ;; Used properties, for markup documentation
+ (hashq-set! markup-functions-properties
+ ,command-name
+ (list ,@(map (lambda (prop-spec)
+ (cond ((symbol? prop-spec)
+ prop-spec)
+ ((not (null? (cdr prop-spec)))
+ `(list ',(car prop-spec) ,(cadr prop-spec)))
+ (else
+ `(list ',(car prop-spec)))))
+ (if (pair? args)
+ properties
+ (list)))))
+ ;; define the make-COMMAND-markup function
+ (define-public (,make-markup-name . args)
+ (let ((sig (list ,@signature)))
+ (make-markup ,command-name ,(symbol->string make-markup-name) sig args))))))
+
+(defmacro*-public define-markup-list-command
+ (command-and-args signature #:key (properties '()) #:rest body)
+ "Same as `define-markup-command', but defines a command that, when
+interpreted, returns a list of stencils instead of a single one"
+ (let* ((command (car command-and-args))
+ (args (cdr command-and-args))
+ (command-name (string->symbol (format #f "~a-markup-list" command)))
+ (make-markup-name (string->symbol (format #f "make-~a-markup-list" command))))
+ (while (and (pair? body) (keyword? (car body)))
+ (set! body (cddr body)))
+ `(begin
+ ;; define the COMMAND-markup-list function
+ ,(let* ((documentation (if (string? (car body))
+ (list (car body))
+ '()))
+ (real-body (if (or (null? documentation)
+ (null? (cdr body)))
+ body (cdr body))))
+ `(define-public (,command-name ,@args)
+ ,@documentation
+ (let ,(map (lambda (prop-spec)
+ (let ((prop (car prop-spec))
+ (default-value (if (null? (cdr prop-spec))
+ #f
+ (cadr prop-spec)))
+ (props (cadr args)))
+ `(,prop (chain-assoc-get ',prop ,props ,default-value))))
+ (filter pair? properties))
+ ,@real-body)))
+ (set! (markup-command-signature ,command-name) (list ,@signature))
+ ;; add the command to markup-list-function-list, for markup documentation
+ (hashq-set! markup-list-functions ,command-name #t)
+ ;; Used properties, for markup documentation
+ (hashq-set! markup-functions-properties
+ ,command-name
+ (list ,@(map (lambda (prop-spec)
+ (cond ((symbol? prop-spec)
+ prop-spec)
+ ((not (null? (cdr prop-spec)))
+ `(list ',(car prop-spec) ,(cadr prop-spec)))
+ (else
+ `(list ',(car prop-spec)))))
+ (if (pair? args)
+ properties
+ (list)))))
+ ;; it's a markup-list command:
+ (set-object-property! ,command-name 'markup-list-command #t)
+ ;; define the make-COMMAND-markup-list function
+ (define-public (,make-markup-name . args)
+ (let ((sig (list ,@signature)))
+ (list (make-markup ,command-name
+ ,(symbol->string make-markup-name) sig args)))))))
+
+;;;;;;;;;;;;;;;
+;;; Utilities for storing and accessing markup commands signature
+;;; Examples:
+;;;
+;;; (set! (markup-command-signature raise-markup) (list number? markup?))
+;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
+;;;
+;;; (markup-command-signature raise-markup)
+;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
+;;;
+
+(define-public (markup-command-signature-ref markup-command)
+ "Return markup-command's signature (the 'markup-signature object property)"
+ (object-property markup-command 'markup-signature))
+
+(define-public (markup-command-signature-set! markup-command signature)
+ "Set markup-command's signature (as object property)"
+ (set-object-property! markup-command 'markup-signature signature)
+ signature)
+
+(define-public markup-command-signature
+ (make-procedure-with-setter markup-command-signature-ref
+ markup-command-signature-set!))
+
+;;;;;;;;;;;;;;;;;;;;;;
+;;; markup type predicates
+
+(define (markup-function? x)
+ (and (markup-command-signature x)
+ (not (object-property x 'markup-list-command))))
+
+(define (markup-list-function? x)
+ (and (markup-command-signature x)
+ (object-property x 'markup-list-command)))
+
+(define-public (markup-command-list? x)
+ "Determine if `x' is a markup command list, ie. a list composed of
+a markup list function and its arguments."
+ (and (pair? x) (markup-list-function? (car x))))
+
+(define-public (markup-list? arg)
+ "Return a true value if `x' is a list of markups or markup command lists."
+ (define (markup-list-inner? lst)
+ (or (null? lst)
+ (and (or (markup? (car lst)) (markup-command-list? (car lst)))
+ (markup-list-inner? (cdr lst)))))
+ (not (not (and (list? arg) (markup-list-inner? arg)))))
+
+(define (markup-argument-list? signature arguments)
+ "Typecheck argument list."
+ (if (and (pair? signature) (pair? arguments))
+ (and ((car signature) (car arguments))
+ (markup-argument-list? (cdr signature) (cdr arguments)))
+ (and (null? signature) (null? arguments))))
+
+
+(define (markup-argument-list-error signature arguments number)
+ "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or
+#f is no error found.
+"
+ (if (and (pair? signature) (pair? arguments))
+ (if (not ((car signature) (car arguments)))
+ (list number (type-name (car signature)) (car arguments))
+ (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number)))
+ #f))
+
+;;
+;; full recursive typecheck.
+;;
+(define (markup-typecheck? arg)
+ (or (string? arg)
+ (and (pair? arg)
+ (markup-function? (car arg))
+ (markup-argument-list? (markup-command-signature (car arg))
+ (cdr arg)))))
+
+;;
+;;
+;;
+;;
+(define (markup-thrower-typecheck arg)
+ "typecheck, and throw an error when something amiss.
+
+Uncovered - cheap-markup? is used."
+
+ (cond ((string? arg) #t)
+ ((not (pair? arg))
+ (throw 'markup-format "Not a pair" arg))
+ ((not (markup-function? (car arg)))
+ (throw 'markup-format "Not a markup function " (car arg)))
+ ((not (markup-argument-list? (markup-command-signature (car arg))
+ (cdr arg)))
+ (throw 'markup-format "Arguments failed typecheck for " arg)))
+ #t)
+
+;;
+;; good enough if you only use make-XXX-markup functions.
+;;
+(define (cheap-markup? x)
+ (or (string? x)
+ (and (pair? x)
+ (markup-function? (car x)))))
+
+;;
+;; replace by markup-thrower-typecheck for more detailed diagnostics.
+;;
+(define-public markup? cheap-markup?)
+
+(define-public (make-markup markup-function make-name signature args)
+ " Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck
+against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
+"
+ (let* ((arglen (length args))
+ (siglen (length signature))
+ (error-msg (if (and (> siglen 0) (> arglen 0))
+ (markup-argument-list-error signature args 1)
+ #f)))
+ (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
+ (ly:error (string-append make-name ": "
+ (_ "Wrong number of arguments. Expect: ~A, found ~A: ~S"))
+ siglen arglen args))
+ (if error-msg
+ (ly:error
+ (string-append
+ make-name ": "
+ (_ "Invalid argument in position ~A. Expect: ~A, found: ~S."))
+ (car error-msg) (cadr error-msg)(caddr error-msg))
+ (cons markup-function args))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; markup constructors
+;;; lilypond-like syntax for markup construction in scheme.
+
+(use-modules (ice-9 receive))
+
+(defmacro*-public markup* (#:rest body)
+ "Same as `markup', for use in a \\notes block."
+ `(ly:export (markup ,@body)))
+
+
+(define (compile-all-markup-expressions expr)
+ "Return a list of canonical markups expressions, e.g.:
+ (#:COMMAND1 arg11 arg12 #:COMMAND2 arg21 arg22 arg23)
+ ===>
+ ((make-COMMAND1-markup arg11 arg12)
+ (make-COMMAND2-markup arg21 arg22 arg23) ...)"
+ (do ((rest expr rest)
+ (markps '() markps))
+ ((null? rest) (reverse markps))
+ (receive (m r) (compile-markup-expression rest)
+ (set! markps (cons m markps))
+ (set! rest r))))
+
+(define (keyword->make-markup key)
+ "Transform a keyword, e.g. #:COMMAND, in a make-COMMAND-markup symbol."
+ (string->symbol (string-append "make-" (symbol->string (keyword->symbol key)) "-markup")))
+
+(define (compile-markup-expression expr)
+ "Return two values: the first complete canonical markup expression
+ found in `expr', e.g. (make-COMMAND-markup arg1 arg2 ...),
+ and the rest expression."
+ (cond ((and (pair? expr)
+ (keyword? (car expr)))
+ ;; expr === (#:COMMAND arg1 ...)
+ (let ((command (symbol->string (keyword->symbol (car expr)))))
+ (if (not (pair? (lookup-markup-command command)))
+ (ly:error (_ "Not a markup command: ~A") command))
+ (let* ((sig (markup-command-signature
+ (car (lookup-markup-command command))))
+ (sig-len (length sig)))
+ (do ((i 0 (1+ i))
+ (args '() args)
+ (rest (cdr expr) rest))
+ ((>= i sig-len)
+ (values (cons (keyword->make-markup (car expr)) (reverse args)) rest))
+ (cond ((eqv? (list-ref sig i) markup-list?)
+ ;; (car rest) is a markup list
+ (set! args (cons `(list ,@(compile-all-markup-expressions (car rest))) args))
+ (set! rest (cdr rest)))
+ (else
+ ;; pick up one arg in `rest'
+ (receive (a r) (compile-markup-arg rest)
+ (set! args (cons a args))
+ (set! rest r))))))))
+ ((and (pair? expr)
+ (pair? (car expr))
+ (keyword? (caar expr)))
+ ;; expr === ((#:COMMAND arg1 ...) ...)
+ (receive (m r) (compile-markup-expression (car expr))
+ (values m (cdr expr))))
+ ((and (pair? expr)
+ (string? (car expr))) ;; expr === ("string" ...)
+ (values `(make-simple-markup ,(car expr)) (cdr expr)))
+ (else
+ ;; expr === (symbol ...) or ((funcall ...) ...)
+ (values (car expr)
+ (cdr expr)))))
+
+(define (compile-all-markup-args expr)
+ "Transform `expr' into markup arguments"
+ (do ((rest expr rest)
+ (args '() args))
+ ((null? rest) (reverse args))
+ (receive (a r) (compile-markup-arg rest)
+ (set! args (cons a args))
+ (set! rest r))))
+
+(define (compile-markup-arg expr)
+ "Return two values: the desired markup argument, and the rest arguments"
+ (cond ((null? expr)
+ ;; no more args
+ (values '() '()))
+ ((keyword? (car expr))
+ ;; expr === (#:COMMAND ...)
+ ;; ==> build and return the whole markup expression
+ (compile-markup-expression expr))
+ ((and (pair? (car expr))
+ (keyword? (caar expr)))
+ ;; expr === ((#:COMMAND ...) ...)
+ ;; ==> build and return the whole markup expression(s)
+ ;; found in (car expr)
+ (receive (markup-expr rest-expr) (compile-markup-expression (car expr))
+ (if (null? rest-expr)
+ (values markup-expr (cdr expr))
+ (values `(list ,markup-expr ,@(compile-all-markup-args rest-expr))
+ (cdr expr)))))
+ ((and (pair? (car expr))
+ (pair? (caar expr)))
+ ;; expr === (((foo ...) ...) ...)
+ (values (cons 'list (compile-all-markup-args (car expr))) (cdr expr)))
+ (else (values (car expr) (cdr expr)))))
+
+(define (lookup-markup-command-aux symbol)
+ (let ((proc (catch 'misc-error
+ (lambda ()
+ (module-ref (current-module) symbol))
+ (lambda (key . args) #f))))
+ (and (procedure? proc) proc)))
+
+(define-public (lookup-markup-command code)
+ (let ((proc (lookup-markup-command-aux
+ (string->symbol (format #f "~a-markup" code)))))
+ (and proc (markup-function? proc)
+ (cons proc (markup-command-signature proc)))))
+
+(define-public (lookup-markup-list-command code)
+ (let ((proc (lookup-markup-command-aux
+ (string->symbol (format #f "~a-markup-list" code)))))
+ (and proc (markup-list-function? proc)
+ (cons proc (markup-command-signature proc)))))
+
+;;;;;;;;;;;;;;;;;;;;;;
+;;; used in parser.yy to map a list of markup commands on markup arguments
+(define-public (map-markup-command-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:
+ ((bold (raise 4 (italic markup1)))
+ (bold (raise 4 (italic markup2)))
+ (bold (raise 4 (italic markup3))))
+"
+ (map-in-order (lambda (arg)
+ (let ((result arg))
+ (for-each (lambda (cmd)
+ (set! result (append cmd (list result))))
+ commands)
+ result))
+ markups))
;;;; You should have received a copy of the GNU General Public License
;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
-"
-Internally markup is stored as lists, whose head is a function.
-
- (FUNCTION ARG1 ARG2 ... )
-
-When the markup is formatted, then FUNCTION is called as follows
-
- (FUNCTION GROB PROPS ARG1 ARG2 ... )
-
-GROB is the current grob, PROPS is a list of alists, and ARG1.. are
-the rest of the arguments.
-
-The function should return a stencil (i.e. a formatted, ready to
-print object).
-
-
-To add a markup command, use the define-markup-command utility.
-
- (define-markup-command (mycommand layout prop arg1 ...) (arg1-type? ...)
- \"my command usage and description\"
- ...function body...)
-
-The command is now available in markup mode, e.g.
-
- \\markup { .... \\MYCOMMAND #1 argument ... }
-
-" ; "
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; markup definer utilities
-
-;; For documentation purposes
-;; category -> markup functions
-(define-public markup-functions-by-category (make-hash-table 150))
-;; markup function -> used properties
-(define-public markup-functions-properties (make-weak-key-hash-table 151))
-;; List of markup list functions
-(define-public markup-list-functions (make-weak-key-hash-table 151))
-
-(use-modules (ice-9 optargs))
-
-(defmacro*-public define-markup-command
- (command-and-args signature
- #:key (category '()) (properties '())
- #:rest body)
- "
-* Define a COMMAND-markup function after command-and-args and body,
-register COMMAND-markup and its signature,
-
-* add COMMAND-markup to markup-functions-by-category,
-
-* sets COMMAND-markup markup-signature object property,
-
-* define a make-COMMAND-markup function.
-
-Syntax:
- (define-markup-command (COMMAND layout props . arguments)
- argument-types
- [ #:properties properties ]
- \"documentation string\"
- ...command body...)
-
-where:
- `argument-types' is a list of type predicates for arguments
- `properties' a list of (property default-value) lists
-
-The specified properties are available as let-bound variables in the
-command body, using the respective `default-value' as fallback in case
-`property' is not found in `props'. `props' itself is left unchanged:
-if you want defaults specified in that manner passed down into other
-markup functions, you need to adjust `props' yourself.
-
-The autogenerated documentation makes use of some optional
-specifications that are otherwise ignored:
-
-After `argument-types', you may also specify
- [ #:category category ]
-where:
- `category' is either a symbol or a symbol list specifying the
- category for this markup command in the docs.
-
-As an element of the `properties' list, you may directly use a
-COMMANDx-markup symbol instead of a `(prop value)' list to indicate
-that this markup command is called by the newly defined command,
-adding its properties to the documented properties of the new
-command. There is no protection against circular definitions.
-"
- (let* ((command (car command-and-args))
- (args (cdr command-and-args))
- (command-name (string->symbol (format #f "~a-markup" command)))
- (make-markup-name (string->symbol (format #f "make-~a-markup" command))))
- (while (and (pair? body) (keyword? (car body)))
- (set! body (cddr body)))
- `(begin
- ;; define the COMMAND-markup function
- ,(let* ((documentation (if (string? (car body))
- (list (car body))
- '()))
- (real-body (if (or (null? documentation)
- (null? (cdr body)))
- body (cdr body))))
- `(define-public (,command-name ,@args)
- ,@documentation
- (let ,(map (lambda (prop-spec)
- (let ((prop (car prop-spec))
- (default-value (if (null? (cdr prop-spec))
- #f
- (cadr prop-spec)))
- (props (cadr args)))
- `(,prop (chain-assoc-get ',prop ,props ,default-value))))
- (filter pair? properties))
- ,@real-body)))
- (set! (markup-command-signature ,command-name) (list ,@signature))
- ;; Register the new function, for markup documentation
- ,@(map (lambda (category)
- `(hashq-set!
- (or (hashq-ref markup-functions-by-category ',category)
- (let ((hash (make-weak-key-hash-table 151)))
- (hashq-set! markup-functions-by-category ',category
- hash)
- hash))
- ,command-name #t))
- (if (list? category) category (list category)))
- ;; Used properties, for markup documentation
- (hashq-set! markup-functions-properties
- ,command-name
- (list ,@(map (lambda (prop-spec)
- (cond ((symbol? prop-spec)
- prop-spec)
- ((not (null? (cdr prop-spec)))
- `(list ',(car prop-spec) ,(cadr prop-spec)))
- (else
- `(list ',(car prop-spec)))))
- (if (pair? args)
- properties
- (list)))))
- ;; define the make-COMMAND-markup function
- (define-public (,make-markup-name . args)
- (let ((sig (list ,@signature)))
- (make-markup ,command-name ,(symbol->string make-markup-name) sig args))))))
-
-(defmacro*-public define-markup-list-command
- (command-and-args signature #:key (properties '()) #:rest body)
- "Same as `define-markup-command', but defines a command that, when
-interpreted, returns a list of stencils instead of a single one"
- (let* ((command (car command-and-args))
- (args (cdr command-and-args))
- (command-name (string->symbol (format #f "~a-markup-list" command)))
- (make-markup-name (string->symbol (format #f "make-~a-markup-list" command))))
- (while (and (pair? body) (keyword? (car body)))
- (set! body (cddr body)))
- `(begin
- ;; define the COMMAND-markup-list function
- ,(let* ((documentation (if (string? (car body))
- (list (car body))
- '()))
- (real-body (if (or (null? documentation)
- (null? (cdr body)))
- body (cdr body))))
- `(define-public (,command-name ,@args)
- ,@documentation
- (let ,(map (lambda (prop-spec)
- (let ((prop (car prop-spec))
- (default-value (if (null? (cdr prop-spec))
- #f
- (cadr prop-spec)))
- (props (cadr args)))
- `(,prop (chain-assoc-get ',prop ,props ,default-value))))
- (filter pair? properties))
- ,@real-body)))
- (set! (markup-command-signature ,command-name) (list ,@signature))
- ;; add the command to markup-list-function-list, for markup documentation
- (hashq-set! markup-list-functions ,command-name #t)
- ;; Used properties, for markup documentation
- (hashq-set! markup-functions-properties
- ,command-name
- (list ,@(map (lambda (prop-spec)
- (cond ((symbol? prop-spec)
- prop-spec)
- ((not (null? (cdr prop-spec)))
- `(list ',(car prop-spec) ,(cadr prop-spec)))
- (else
- `(list ',(car prop-spec)))))
- (if (pair? args)
- properties
- (list)))))
- ;; it's a markup-list command:
- (set-object-property! ,command-name 'markup-list-command #t)
- ;; define the make-COMMAND-markup-list function
- (define-public (,make-markup-name . args)
- (let ((sig (list ,@signature)))
- (list (make-markup ,command-name
- ,(symbol->string make-markup-name) sig args)))))))
-
-(define-public (make-markup markup-function make-name signature args)
- "Construct a markup object from @var{markup-function} and @var{args}.
-Typecheck against @var{signature}, reporting @var{make-name} as the
-user-invoked function."
- (let* ((arglen (length args))
- (siglen (length signature))
- (error-msg (if (and (> siglen 0) (> arglen 0))
- (markup-argument-list-error signature args 1)
- #f)))
- (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
- (ly:error (string-append make-name ": "
- (_ "Wrong number of arguments. Expect: ~A, found ~A: ~S"))
- siglen arglen args))
- (if error-msg
- (ly:error
- (string-append
- make-name ": "
- (_ "Invalid argument in position ~A. Expect: ~A, found: ~S."))
- (car error-msg) (cadr error-msg)(caddr error-msg))
- (cons markup-function args))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; markup constructors
-;;; lilypond-like syntax for markup construction in scheme.
-
-(use-modules (ice-9 receive))
-
(defmacro*-public markup (#:rest body)
"The `markup' macro provides a lilypond-like syntax for building markups.
(car (compile-all-markup-expressions `(#:line ,body))))
-(defmacro*-public markup* (#:rest body)
- "Same as `markup', for use in a \\notes block."
- `(ly:export (markup ,@body)))
-
-
-(define (compile-all-markup-expressions expr)
- "Return a list of canonical markups expressions, e.g.:
- (#:COMMAND1 arg11 arg12 #:COMMAND2 arg21 arg22 arg23)
- ===>
- ((make-COMMAND1-markup arg11 arg12)
- (make-COMMAND2-markup arg21 arg22 arg23) ...)"
- (do ((rest expr rest)
- (markps '() markps))
- ((null? rest) (reverse markps))
- (receive (m r) (compile-markup-expression rest)
- (set! markps (cons m markps))
- (set! rest r))))
-
-(define (keyword->make-markup key)
- "Transform a keyword, e.g. #:COMMAND, in a make-COMMAND-markup symbol."
- (string->symbol (string-append "make-" (symbol->string (keyword->symbol key)) "-markup")))
-
-(define (compile-markup-expression expr)
- "Return two values: the first complete canonical markup expression
- found in `expr', e.g. (make-COMMAND-markup arg1 arg2 ...),
- and the rest expression."
- (cond ((and (pair? expr)
- (keyword? (car expr)))
- ;; expr === (#:COMMAND arg1 ...)
- (let ((command (symbol->string (keyword->symbol (car expr)))))
- (if (not (pair? (lookup-markup-command command)))
- (ly:error (_ "Not a markup command: ~A") command))
- (let* ((sig (markup-command-signature
- (car (lookup-markup-command command))))
- (sig-len (length sig)))
- (do ((i 0 (1+ i))
- (args '() args)
- (rest (cdr expr) rest))
- ((>= i sig-len)
- (values (cons (keyword->make-markup (car expr)) (reverse args)) rest))
- (cond ((eqv? (list-ref sig i) markup-list?)
- ;; (car rest) is a markup list
- (set! args (cons `(list ,@(compile-all-markup-expressions (car rest))) args))
- (set! rest (cdr rest)))
- (else
- ;; pick up one arg in `rest'
- (receive (a r) (compile-markup-arg rest)
- (set! args (cons a args))
- (set! rest r))))))))
- ((and (pair? expr)
- (pair? (car expr))
- (keyword? (caar expr)))
- ;; expr === ((#:COMMAND arg1 ...) ...)
- (receive (m r) (compile-markup-expression (car expr))
- (values m (cdr expr))))
- ((and (pair? expr)
- (string? (car expr))) ;; expr === ("string" ...)
- (values `(make-simple-markup ,(car expr)) (cdr expr)))
- (else
- ;; expr === (symbol ...) or ((funcall ...) ...)
- (values (car expr)
- (cdr expr)))))
-
-(define (compile-all-markup-args expr)
- "Transform `expr' into markup arguments"
- (do ((rest expr rest)
- (args '() args))
- ((null? rest) (reverse args))
- (receive (a r) (compile-markup-arg rest)
- (set! args (cons a args))
- (set! rest r))))
-
-(define (compile-markup-arg expr)
- "Return two values: the desired markup argument, and the rest arguments"
- (cond ((null? expr)
- ;; no more args
- (values '() '()))
- ((keyword? (car expr))
- ;; expr === (#:COMMAND ...)
- ;; ==> build and return the whole markup expression
- (compile-markup-expression expr))
- ((and (pair? (car expr))
- (keyword? (caar expr)))
- ;; expr === ((#:COMMAND ...) ...)
- ;; ==> build and return the whole markup expression(s)
- ;; found in (car expr)
- (receive (markup-expr rest-expr) (compile-markup-expression (car expr))
- (if (null? rest-expr)
- (values markup-expr (cdr expr))
- (values `(list ,markup-expr ,@(compile-all-markup-args rest-expr))
- (cdr expr)))))
- ((and (pair? (car expr))
- (pair? (caar expr)))
- ;; expr === (((foo ...) ...) ...)
- (values (cons 'list (compile-all-markup-args (car expr))) (cdr expr)))
- (else (values (car expr) (cdr expr)))))
-
-;;;;;;;;;;;;;;;
-;;; Utilities for storing and accessing markup commands signature
-;;; Examples:
-;;;
-;;; (set! (markup-command-signature raise-markup) (list number? markup?))
-;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
-;;;
-;;; (markup-command-signature raise-markup)
-;;; ==> (#<primitive-procedure number?> #<procedure markup? (obj)>)
-;;;
-
-(define-public (markup-command-signature-ref markup-command)
- "Return @var{markup-command}'s signature (the @code{'markup-signature}
-object property)."
- (object-property markup-command 'markup-signature))
-
-(define-public (markup-command-signature-set! markup-command signature)
- "Set @var{markup-command}'s signature (as object property)."
- (set-object-property! markup-command 'markup-signature signature)
- signature)
-
-(define-public markup-command-signature
- (make-procedure-with-setter markup-command-signature-ref
- markup-command-signature-set!))
-
-(define (lookup-markup-command-aux symbol)
- (let ((proc (catch 'misc-error
- (lambda ()
- (module-ref (current-module) symbol))
- (lambda (key . args) #f))))
- (and (procedure? proc) proc)))
-
-(define-public (lookup-markup-command code)
- (let ((proc (lookup-markup-command-aux
- (string->symbol (format #f "~a-markup" code)))))
- (and proc (markup-function? proc)
- (cons proc (markup-command-signature proc)))))
-
-(define-public (lookup-markup-list-command code)
- (let ((proc (lookup-markup-command-aux
- (string->symbol (format #f "~a-markup-list" code)))))
- (and proc (markup-list-function? proc)
- (cons proc (markup-command-signature proc)))))
-
-;;;;;;;;;;;;;;;;;;;;;;
-;;; used in parser.yy to map a list of markup commands on markup arguments
-(define-public (map-markup-command-list commands markups)
- "@var{markups} being a list of markups, for example
-@code{(markup1 markup2 markup3)}, and @var{commands} a list of commands with
-their scheme arguments, in reverse order, for example
-@code{((italic) (raise 4) (bold))}, map the commands on each markup argument,
-for example
-@example
-((bold (raise 4 (italic markup1)))
- (bold (raise 4 (italic markup2)))
- (bold (raise 4 (italic markup3))))
-@end example"
- (map-in-order (lambda (arg)
- (let ((result arg))
- (for-each (lambda (cmd)
- (set! result (append cmd (list result))))
- commands)
- result))
- markups))
-
-;;;;;;;;;;;;;;;;;;;;;;
-;;; markup type predicates
-
-(define (markup-function? x)
- (and (markup-command-signature x)
- (not (object-property x 'markup-list-command))))
-
-(define (markup-list-function? x)
- (and (markup-command-signature x)
- (object-property x 'markup-list-command)))
-
-(define-public (markup-command-list? x)
- "Determine whether @var{x} is a markup command list, i.e. a list
-composed of a markup list function and its arguments."
- (and (pair? x) (markup-list-function? (car x))))
-
-(define-public (markup-list? arg)
- "Return @code{#t} if @var{x} is a list of markups or markup command lists."
- (define (markup-list-inner? lst)
- (or (null? lst)
- (and (or (markup? (car lst)) (markup-command-list? (car lst)))
- (markup-list-inner? (cdr lst)))))
- (not (not (and (list? arg) (markup-list-inner? arg)))))
-
-(define (markup-argument-list? signature arguments)
- "Typecheck argument list."
- (if (and (pair? signature) (pair? arguments))
- (and ((car signature) (car arguments))
- (markup-argument-list? (cdr signature) (cdr arguments)))
- (and (null? signature) (null? arguments))))
-
-
-(define (markup-argument-list-error signature arguments number)
- "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or
-#f is no error found.
-"
- (if (and (pair? signature) (pair? arguments))
- (if (not ((car signature) (car arguments)))
- (list number (type-name (car signature)) (car arguments))
- (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number)))
- #f))
-
-;;
-;; full recursive typecheck.
-;;
-(define (markup-typecheck? arg)
- (or (string? arg)
- (and (pair? arg)
- (markup-function? (car arg))
- (markup-argument-list? (markup-command-signature (car arg))
- (cdr arg)))))
-
-;;
-;;
-;;
-;;
-(define (markup-thrower-typecheck arg)
- "typecheck, and throw an error when something amiss.
-
-Uncovered - cheap-markup? is used."
-
- (cond ((string? arg) #t)
- ((not (pair? arg))
- (throw 'markup-format "Not a pair" arg))
- ((not (markup-function? (car arg)))
- (throw 'markup-format "Not a markup function " (car arg)))
- ((not (markup-argument-list? (markup-command-signature (car arg))
- (cdr arg)))
- (throw 'markup-format "Arguments failed typecheck for " arg)))
- #t)
-
-;;
-;; good enough if you only use make-XXX-markup functions.
-;;
-(define (cheap-markup? x)
- (or (string? x)
- (and (pair? x)
- (markup-function? (car x)))))
-
-;;
-;; replace by markup-thrower-typecheck for more detailed diagnostics.
-;;
-(define-public markup? cheap-markup?)
-
;; utility
(define (markup-join markups sep)
(define-public (interpret-markup-list layout props markup-list)
(let ((stencils (list)))
(for-each (lambda (m)
- (set! stencils
- (if (markup-command-list? m)
- (append! (reverse! (apply (car m) layout props (cdr m)))
- stencils)
- (cons (interpret-markup layout props m) stencils))))
- markup-list)
+ (set! stencils
+ (if (markup-command-list? m)
+ (append! (reverse! (apply (car m) layout props (cdr m)))
+ stencils)
+ (cons (interpret-markup layout props m) stencils))))
+ markup-list)
(reverse! stencils)))
(define-public (prepend-alist-chain key val chain)
(define-public (stack-stencil-line space stencils)
"DOCME"
(if (and (pair? stencils)
- (ly:stencil? (car stencils)))
+ (ly:stencil? (car stencils)))
(if (and (pair? (cdr stencils))
- (ly:stencil? (cadr stencils)))
+ (ly:stencil? (cadr stencils)))
(let* ((tail (stack-stencil-line space (cdr stencils)))
(head (car stencils))
(xoff (+ space (interval-length (ly:stencil-extent head X)))))
(ly:stencil-add head
- (ly:stencil-translate-axis tail xoff X)))
+ (ly:stencil-translate-axis tail xoff X)))
(car stencils))
(ly:make-stencil '() '(0 . 0) '(0 . 0))))
(define-public (markup->string m)
;; markup commands with one markup argument, formatting ignored
(define markups-first-argument '(list
- bold-markup box-markup caps-markup dynamic-markup finger-markup
- fontCaps-markup huge-markup italic-markup large-markup larger-markup
- medium-markup normal-size-sub-markup normal-size-super-markup
- normal-text-markup normalsize-markup number-markup roman-markup
- sans-markup simple-markup small-markup smallCaps-markup smaller-markup
- sub-markup super-markup teeny-markup text-markup tiny-markup
- typewriter-markup underline-markup upright-markup bracket-markup
- circle-markup hbracket-markup parenthesize-markup rounded-box-markup
-
- center-align-markup center-column-markup column-markup dir-column-markup
- fill-line-markup justify-markup justify-string-markup left-align-markup
- left-column-markup line-markup right-align-markup right-column-markup
- vcenter-markup wordwrap-markup wordwrap-string-markup ))
+ bold-markup box-markup caps-markup dynamic-markup finger-markup
+ fontCaps-markup huge-markup italic-markup large-markup larger-markup
+ medium-markup normal-size-sub-markup normal-size-super-markup
+ normal-text-markup normalsize-markup number-markup roman-markup
+ sans-markup simple-markup small-markup smallCaps-markup smaller-markup
+ sub-markup super-markup teeny-markup text-markup tiny-markup
+ typewriter-markup underline-markup upright-markup bracket-markup
+ circle-markup hbracket-markup parenthesize-markup rounded-box-markup
+
+ center-align-markup center-column-markup column-markup dir-column-markup
+ fill-line-markup justify-markup justify-string-markup left-align-markup
+ left-column-markup line-markup right-align-markup right-column-markup
+ vcenter-markup wordwrap-markup wordwrap-string-markup ))
;; markup commands with markup as second argument, first argument
;; specifies some formatting and is ignored
(define markups-second-argument '(list
- abs-fontsize-markup fontsize-markup magnify-markup lower-markup
- pad-around-markup pad-markup-markup pad-x-markup raise-markup
- halign-markup hcenter-in-markup rotate-markup translate-markup
- translate-scaled-markup with-url-markup scale-markup ))
+ abs-fontsize-markup fontsize-markup magnify-markup lower-markup
+ pad-around-markup pad-markup-markup pad-x-markup raise-markup
+ halign-markup hcenter-in-markup rotate-markup translate-markup
+ translate-scaled-markup with-url-markup scale-markup ))
;; helper functions to handle string cons like string lists
(define (markup-cons->string-cons c)
(if (not (pair? c)) (markup->string c)
- (cons (markup->string (car c)) (markup-cons->string-cons (cdr c)))))
+ (cons (markup->string (car c)) (markup-cons->string-cons (cdr c)))))
(define (string-cons-join c)
(if (not (pair? c)) c
(string-join (list (car c) (string-cons-join (cdr c))) "")))
(cond
- ((string? m) m)
- ((null? m) "")
+ ((string? m) m)
+ ((null? m) "")
- ;; handle \concat (string-join without spaces)
- ((and (pair? m) (equal? (car m) concat-markup))
- (string-cons-join (markup-cons->string-cons (cadr m))) )
+ ;; handle \concat (string-join without spaces)
+ ((and (pair? m) (equal? (car m) concat-markup))
+ (string-cons-join (markup-cons->string-cons (cadr m))) )
- ;; markup functions with the markup as first arg
- ((member (car m) (primitive-eval markups-first-argument))
- (markup->string (cadr m)))
+ ;; markup functions with the markup as first arg
+ ((member (car m) (primitive-eval markups-first-argument))
+ (markup->string (cadr m)))
- ;; markup functions with markup as second arg
- ((member (car m) (primitive-eval markups-second-argument))
- (markup->string (cddr m)))
+ ;; markup functions with markup as second arg
+ ((member (car m) (primitive-eval markups-second-argument))
+ (markup->string (cddr m)))
- ;; ignore all other markup functions
- ((markup-function? (car m)) "")
+ ;; ignore all other markup functions
+ ((markup-function? (car m)) "")
- ;; handle markup lists
- ((list? m)
- (string-join (map markup->string m) " "))
+ ;; handle markup lists
+ ((list? m)
+ (string-join (map markup->string m) " "))
- (else "ERROR, unable to extract string from markup")))
+ (else "ERROR, unable to extract string from markup")))
projects / lilypond.git / commitdiff