lilypond-data 2.16.2-3 / usr / share / lilypond / 2.16.2 / scm / lily.scm

;;;; This file is part of LilyPond, the GNU music typesetter.
;;;;
;;;; Copyright (C) 1998--2012 Jan Nieuwenhuizen <janneke@gnu.org>
;;;; 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/>.

;; Internationalisation: (_i "to be translated") gets an entry in the
;; POT file; (gettext ...) must be invoked explicitly to do the actual
;; "translation".
;;
;; (define-macro (_i x) x)
;; (define-macro-public _i (x) x)
;; (define-public-macro _i (x) x)
;; Abbrv-PWR!

(defmacro-public _i (x) x)

;;; Boolean thunk - are we integrating Guile V2.0 or higher with LilyPond?
(define-public (guile-v2)
  (string>? (version) "1.9.10"))

(read-enable 'positions)
(if (not (guile-v2))
    (debug-enable 'debug)
    (begin
      (debug-enable 'backtrace)
      (debug-set! show-file-name #t)))

(define-public PLATFORM
  (string->symbol
   (string-downcase
    (car (string-tokenize (utsname:sysname (uname)))))))

(define scheme-options-definitions
  `(
    ;; NAMING: either

    ;; - [subject-]object-object-verb +"ing"
    ;; - [subject-]-verb-object-object

    ;; Avoid overlong lines in `lilypond -dhelp'!  Strings should not
    ;; be longer than 48 characters per line.

    (anti-alias-factor 1
"Render at higher resolution (using given factor)
and scale down result to prevent jaggies in
PNG images.")
    (aux-files #t
"Create .tex, .texi, .count files in the
EPS backend.")
    (backend ps
"Select backend.  Possible values: 'eps, 'null,
'ps, 'scm, 'socket, 'svg.")
    (check-internal-types #f
"Check every property assignment for types.")
    (clip-systems #f
"Generate cut-out snippets of a score.")
    (datadir #f
"LilyPond prefix for data files (read-only).")
    (debug-gc #f
"Dump memory debugging statistics.")
    (debug-gc-assert-parsed-dead #f
"For memory debugging: Ensure that all
references to parsed objects are dead.  This is
an internal option, and is switched on
automatically for `-ddebug-gc'.")
    (debug-lexer #f
"Debug the flex lexer.")
    (debug-page-breaking-scoring #f
"Dump scores for many different page breaking
configurations.")
    (debug-parser #f
"Debug the bison parser.")
    (debug-property-callbacks #f
"Debug cyclic callback chains.")
    (debug-skylines #f
"Debug skylines.")
    (delete-intermediate-files #t
"Delete unusable, intermediate PostScript files.")
    (dump-profile #f
"Dump memory and time information for each file.")
    (dump-cpu-profile #f
"Dump timing information (system-dependent).")
    (dump-signatures #f
"Dump output signatures of each system.  Used for
regression testing.")
    (eps-box-padding #f
"Pad left edge of the output EPS bounding box by
given amount (in mm).")
    (gs-load-fonts #f
"Load fonts via Ghostscript.")
    (gs-load-lily-fonts #f
"Load only LilyPond fonts via Ghostscript.")
    (gui #f
"Run LilyPond from a GUI and redirect stderr to
a log file.")
    (help #f
"Show this help.")
    (include-book-title-preview #t
"Include book titles in preview images.")
    (include-eps-fonts #t
"Include fonts in separate-system EPS files.")
    (include-settings #f
"Include file for global settings, included before the score is processed.")
    (job-count #f
"Process in parallel, using the given number of
jobs.")
    (log-file #f
"If string FOO is given as argument, redirect
output to log file `FOO.log'.")
    (max-markup-depth 1024
"Maximum depth for the markup tree. If a markup has more levels,
assume it will not terminate on its own, print a warning and return a
null markup instead.")
    (midi-extension ,(if (eq? PLATFORM 'windows)
                         "mid"
                         "midi")
"Set the default file extension for MIDI output
file to given string.")
    (music-strings-to-paths #f
"Convert text strings to paths when glyphs belong
to a music font.")
    (old-relative #f
"Make \\relative mode for simultaneous music work
similar to chord syntax.")
    (point-and-click #t
"Add point & click links to PDF output.")
    (paper-size "a4"
"Set default paper size.")
    (pixmap-format "png16m"
"Set GhostScript's output format for pixel images.")
    (preview #f
"Create preview images also.")
    (print-pages #t
"Print pages in the normal way.")
    (protected-scheme-parsing #t
"Continue when errors in inline scheme are caught
in the parser.  If #f, halt on errors and print
a stack trace.")
    (profile-property-accesses #f
"Keep statistics of get_property() calls.")
    (resolution 101
"Set resolution for generating PNG pixmaps to
given value (in dpi).")
    (read-file-list #f
"Specify name of a file which contains a list of
input files to be processed.")
    (relative-includes #f
"When processing an \\include command, look for
the included file relative to the current file
(instead of the root file)")
    (safe #f
"Run in safer mode.")
    (separate-log-files #f
"For input files `FILE1.ly', `FILE2.ly', ...
output log data to files `FILE1.log',
`FILE2.log', ...")
    (show-available-fonts #f
"List available font names.")
    (strict-infinity-checking #f
"Force a crash on encountering Inf and NaN
floating point exceptions.")
    (strip-output-dir #t
"Don't use directories from input files while
constructing output file names.")
    (svg-woff #f
"Use woff font files in SVG backend.")
    (trace-memory-frequency #f
"Record Scheme cell usage this many times per
second.  Dump results to `FILE.stacks' and
`FILE.graph'.")
    (trace-scheme-coverage #f
"Record coverage of Scheme files in `FILE.cov'.")
    (verbose ,(ly:verbose-output?)
"Verbose output, i.e. loglevel at least DEBUG (read-only).")
    (warning-as-error #f
"Change all warning and programming_error
messages into errors.")
    ))

;; Need to do this in the beginning.  Other parts of the Scheme
;; initialization depend on these options.

(for-each (lambda (x)
            (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)))

(debug-set! stack 0)

(if (defined? 'set-debug-cell-accesses!)
    (set-debug-cell-accesses! #f))

;;(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)
	     (scm safe-utility-defs))

(define-public _ gettext)
;;; There are new modules defined in Guile V2.0 which we need to use.
;;
;;  Modules and scheme files loaded by lily.scm use currying
;;  in Guile V2 this needs a module which is not present in Guile V1.8
;;

(cond
  ((guile-v2)
   (ly:debug (_ "Using (ice-9 curried-definitions) module\n"))
   (use-modules (ice-9 curried-definitions)))
  (else
    (ly:debug (_ "Guile 1.8\n"))))

;; TODO add in modules for V1.8.7 deprecated in V2.0 and integrated
;; into Guile base code, like (ice-9 syncase).
;;

(define-public fancy-format
  format)

(define-public (ergonomic-simple-format dest . rest)
  "Like ice-9's @code{format}, but without the memory consumption."
  (if (string? dest)
      (apply simple-format (cons #f (cons dest rest)))
      (apply simple-format (cons dest rest))))

(define format
  ergonomic-simple-format)

;; my display
(define-public (myd k v)
  (display k)
  (display ": ")
  (display v)
  (display ", ")
  v)

(define-public (print . args)
  (apply format (cons (current-output-port) args)))


;;; General settings.
;;;
;;; 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))
    (begin
      (ly:set-option 'protected-scheme-parsing #f)
      (debug-enable 'backtrace)
      (read-enable 'positions)))

(if (ly:get-option 'trace-scheme-coverage)
    (coverage:enable))

(define-public parser #f)

(define music-string-to-path-backends
  '(svg))

(if (memq (ly:get-option 'backend) music-string-to-path-backends)
    (ly:set-option 'music-strings-to-paths #t))


(define-public (ly:load x)
  (let* ((file-name (%search-load-path x)))
    (ly:debug "[~A" file-name)
    (if (not file-name)
        (ly:error (_ "cannot find: ~A") x))
    (primitive-load-path file-name)  ;; to support Guile V2 autocompile
    ;; TODO: Any chance to use ly:debug here? Need to extend it to prevent
    ;;       a newline in this case
    (if (ly:get-option 'verbose)
        (ly:progress "]\n"))))

(define-public DOS
  (let ((platform (string-tokenize
                   (vector-ref (uname) 0) char-set:letter+digit)))
    (if (null? (cdr platform)) #f
        (member (string-downcase (cadr platform)) '("95" "98" "me")))))

(define (slashify x)
  (if (string-index x #\\)
      x
      (string-regexp-substitute
        "//*" "/"
        (string-regexp-substitute "\\\\" "/" x))))

(define-public (ly-getcwd)
  (if (eq? PLATFORM 'windows)
      (slashify (getcwd))
      (getcwd)))

(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) #\/))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; If necessary, emulate Guile V2 module_export_all! for Guile V1.8.n
(cond-expand
 ((not guile-v2)
  (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))
    (let ((iface (or (module-public-interface mod)
                     (fresh-interface!))))
      (set-module-obarray! iface (module-obarray mod))))))


(define-safe-public (lilypond-version)
  (string-join
   (map (lambda (x) (if (symbol? x)
                        (symbol->string x)
                        (number->string x)))
        (ly:version))
   "."))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; init pitch system

(ly:set-default-scale (ly:make-scale #(0 1 2 5/2 7/2 9/2 11/2)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; other 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"
    "output-lib.scm"))
;;  - Files containing definitions used later by other files later in load
(define init-scheme-files-used
  '("markup-macros.scm"
    "parser-ly-from-scheme.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"
    "c++.scm"
    "chord-entry.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"
    "ly-syntax-constructors.scm"

    "define-context-properties.scm"
    "translation-functions.scm"
    "script.scm"
    "midi.scm"
    "layout-beam.scm"
    "parser-clef.scm"
    "layout-slur.scm"
    "font.scm"
    "encoding.scm"

    "bar-line.scm"
    "flag-styles.scm"
    "fret-diagrams.scm"
    "tablature.scm"
    "harp-pedals.scm"
    "define-woodwind-diagrams.scm"
    "display-woodwind-diagrams.scm"
    "predefined-fretboards.scm"
    "define-grob-properties.scm"
    "define-grobs.scm"
    "define-grob-interfaces.scm"
    "define-stencil-commands.scm"
    "titling.scm"
    "text.scm"

    "paper.scm"
    "backend-library.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-public r5rs-primary-predicates
  `((,boolean? . "boolean")
    (,char? . "character")
    (,number? . "number")
    (,pair? . "pair")
    (,port? . "port")
    (,procedure? . "procedure")
    (,string? . "string")
    (,symbol? . "symbol")
    (,vector? . "vector")))

(define-public r5rs-secondary-predicates
  `((,char-alphabetic? . "alphabetic character")
    (,char-lower-case? . "lower-case character")
    (,char-numeric? . "numeric character")
    (,char-upper-case? . "upper-case character")
    (,char-whitespace? . "whitespace character")

    (,complex? . "complex number")
    (,even? . "even number")
    (,exact? . "exact number")
    (,inexact? . "inexact number")
    (,integer? . "integer")
    (,negative? . "negative number")
    (,odd? . "odd number")
    (,positive? . "positive number")
    (,rational? . "rational number")
    (,real? . "real number")
    (,zero? . "zero")

    (,list? . "list")
    (,null? . "null")

    (,input-port? . "input port")
    (,output-port? . "output port")

    ;; would this ever be used?
    (,eof-object? . "end-of-file object")
    ))

(define-public guile-predicates
  `((,hash-table? . "hash table")
  ))

(define-public lilypond-scheme-predicates
  `((,boolean-or-symbol? . "boolean or symbol")
    (,color? . "color")
    (,cheap-list? . "list")
    (,fraction? . "fraction, as pair")
    (,grob-list? . "list of grobs")
    (,index? . "non-negative integer")
    ;; this is built on cheap-list
    (,list-or-symbol? . "list or symbol")
    (,markup? . "markup")
    (,markup-command-list? . "markup command list")
    (,markup-list? . "markup list")
    (,moment-pair? . "pair of moment objects")
    (,number-list? . "number list")
    (,number-or-grob? . "number or grob")
    (,number-or-pair? . "number or pair")
    (,number-or-string? . "number or string")
    (,number-pair? . "pair of numbers")
    (,rhythmic-location? . "rhythmic location")
    (,scheme? . "any type")
    (,string-or-pair? . "string or pair")
    (,string-or-symbol? . "string or symbol")
    (,void? . "void")
    ))

(define-public lilypond-exported-predicates
  `((,ly:book? . "book")
    (,ly:box? . "box")
    (,ly:context? . "context")
    (,ly:context-def? . "context definition")
    (,ly:context-mod? . "context modification")
    (,ly:dimension? . "dimension, in staff space")
    (,ly:dir? . "direction")
    (,ly:dispatcher? . "dispatcher")
    (,ly:duration? . "duration")
    (,ly:event? . "post event")
    (,ly:font-metric? . "font metric")
    (,ly:grob? . "graphical (layout) object")
    (,ly:grob-array? . "array of grobs")
    (,ly:input-location? . "input location")
    (,ly:item? . "item")
    (,ly:iterator? . "iterator")
    (,ly:lily-lexer? . "lily-lexer")
    (,ly:lily-parser? . "lily-parser")
    (,ly:listener? . "listener")
    (,ly:moment? . "moment")
    (,ly:music? . "music")
    (,ly:music-function? . "music function")
    (,ly:music-list? . "list of music objects")
    (,ly:music-output? . "music output")
    (,ly:otf-font? . "OpenType font")
    (,ly:output-def? . "output definition")
    (,ly:page-marker? . "page marker")
    (,ly:pango-font? . "pango font")
    (,ly:paper-book? . "paper book")
    (,ly:paper-system? . "paper-system Prob")
    (,ly:pitch? . "pitch")
    (,ly:prob? . "property object")
    (,ly:score? . "score")
    (,ly:simple-closure? . "simple closure")
    (,ly:skyline? . "skyline")
    (,ly:skyline-pair? . "pair of skylines")
    (,ly:source-file? . "source file")
    (,ly:spanner? . "spanner")
    (,ly:spring? . "spring")
    (,ly:stencil? . "stencil")
    (,ly:stream-event? . "stream event")
    (,ly:translator? . "translator")
    (,ly:translator-group? . "translator group")
    (,ly:unpure-pure-container? . "unpure/pure container")
    ))


(set! type-p-name-alist
      (append r5rs-primary-predicates
              r5rs-secondary-predicates
              guile-predicates
              lilypond-scheme-predicates
              lilypond-exported-predicates))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; timing

(define (profile-measurements)
  (let* ((t (times))
         (stats (gc-stats)))
    (list (- (+ (tms:cutime t)
                (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))))
    (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))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; debug memory leaks

(define gc-dumping
  #f)

(define gc-protect-stat-count
  0)

(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))))))

(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")))
    (set! gc-dumping #t)
    (ly:progress "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))
    (format outfile "\nprotected symbols: ~a\n"
            (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))
          (ly:progress "Live object statistics: GC'ing\n")
          (ly:reset-all-fonts)
          (gc)
          (gc)
          (ly:progress "Asserting dead objects\n")
          (ly:set-option 'debug-gc-assert-parsed-dead #t)
          (gc)
          (ly:set-option 'debug-gc-assert-parsed-dead #f)
	  (for-each
	   (lambda (x)
	     (ly:programming-error "Parsed object should be dead: ~a" x))
	   (ly:parsed-undead-list!))
          (set! stats (gc-live-object-stats))
          (ly:progress "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)))
    (set! gc-dumping #f)
    (close-port outfile)))

(define (check-memory)
  "Read `/proc/self' to check up on memory use."
  (define (gulp-file name)
    (let* ((file (open-input-file name))
           (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))))
    (format #t "VMDATA: ~a\n" mem)
    (display (gc-stats))
    (newline)
    (if (> mem 500000)
        (begin (dump-gc-protects)
               (raise 1)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (multi-fork count)
  "Split this process into COUNT helpers.  Returns either a list of
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))

  (helper count '()))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define* (ly:exit status #:optional (silently #f))
  "Exit function for lilypond"
  (if (not silently)
      (case status
        ((0) (ly:basic-progress (_ "Success: compilation successfully completed")))
        ((1) (ly:warning (_ "Compilation completed with warnings or errors")))
        (else (ly:message ""))))
  (exit status))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-public (lilypond-main files)
  "Entry point for LilyPond."
  (eval-string (ly:command-line-code))
  (if (ly:get-option 'help)
      (begin (ly:option-usage)
             (ly:exit 0 #t)))
  (if (ly:get-option 'show-available-fonts)
      (begin (ly:font-config-display-fonts)
             (ly:exit 0 #t)))
  (if (ly:get-option 'gui)
      (gui-main files))
  (if (null? files)
      (begin (ly:usage)
             (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 (string-delete (ly:gulp-file f) #\cr) #\nl))
                                files)))))
  (if (and (number? (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))))))

  (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")))))
    (if (pair? failed)
        (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
          (and separate-logs
               (if (string-or-symbol? (ly:get-option 'log-file))
                   (open-file (format #f "~a.log" (ly:get-option 'log-file))
                              "a")
                   (fdes->outport 2))))
         (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)
         (ly:check-expected-warnings)
         (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)
	 (for-each
	  (lambda (x)
	    (ly:programming-error "Parsed object should be dead: ~a" x))
	  (ly:parsed-undead-list!))
         (if (ly:get-option 'debug-gc)
             (dump-gc-protects)
             (ly:reset-all-fonts))
         (flush-all-ports)))
     files)

    ;; Ensure a notice re failed files is written to aggregate logfile.
    (if ping-log
        (format ping-log "Failed files: ~a\n" failed))
    (if (ly:get-option 'dump-profile)
        (dump-profile "lily-run-total" '(0 0) (profile-measurements)))
    failed))

(define-public lilypond-declarations '())

(define (lilypond-file handler file-name)
  (catch 'ly-file-failed
         (lambda () (ly:parse-file file-name))
         (lambda (x . args) (handler x file-name))))

(use-modules (scm editor))

(define-public (gui-main files)
  (if (null? files)
      (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-*-"))
      (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)))))

(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)))
    (ly:message (_ "Invoking `~a'...\n") cmd)
    (system cmd)
    (ly:exit 1 #f)))