]> git.donarmstrong.com Git - lilypond.git/blob - scm/lily.scm
Merge branch 'master' into lilypond/translation
[lilypond.git] / scm / lily.scm
1 ;;;; lily.scm -- top-level Scheme stuff
2 ;;;;
3 ;;;;  source file of the GNU LilyPond music typesetter
4 ;;;;
5 ;;;; (c) 1998--2009 Jan Nieuwenhuizen <janneke@gnu.org>
6 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
7
8 ;; Internationalisation: (_i "to be translated") gets an entry in the
9 ;; POT file; (gettext ...) must be invoked explicitly to do the actual
10 ;; "translation".
11 ;;
12 ;; (define-macro (_i x) x)
13 ;; (define-macro-public _i (x) x)
14 ;; (define-public-macro _i (x) x)
15 ;; Abbrv-PWR!
16
17 (defmacro-public _i (x) x)
18
19 (read-enable 'positions)
20 (debug-enable 'debug)
21
22 (define-public PLATFORM
23   (string->symbol
24    (string-downcase
25     (car (string-tokenize (utsname:sysname (uname)))))))
26
27 (define scheme-options-definitions
28   `(
29     ;; NAMING: either
30
31     ;; - [subject-]object-object-verb +"ing"
32     ;; - [subject-]-verb-object-object
33
34     ;; Avoid overlong lines in `lilypond -dhelp'!  Strings should not
35     ;; be longer than 48 characters per line.
36
37     (anti-alias-factor 1
38 "Render at higher resolution (using given factor)
39 and scale down result to prevent jaggies in
40 PNG images.")
41     (aux-files #t 
42 "Create .tex, .texi, .count files in the 
43 EPS backend.")
44     (backend ps
45 "Select backend.  Possible values: 'eps, 'null,
46 'ps, 'scm, 'socket, 'svg.")
47     (check-internal-types #f
48 "Check every property assignment for types.")
49     (clip-systems #f
50 "Generate cut-out snippets of a score.")
51     (datadir #f
52 "LilyPond prefix for data files (read-only).")
53     (debug-gc #f
54 "Dump memory debugging statistics.")
55     (debug-gc-assert-parsed-dead #f
56 "For memory debugging: Ensure that all
57 references to parsed objects are dead.  This is
58 an internal option, and is switched on
59 automatically for `-ddebug-gc'.")
60     (debug-lexer #f
61 "Debug the flex lexer.")
62     (debug-page-breaking-scoring #f
63 "Dump scores for many different page breaking
64 configurations.")
65     (debug-parser #f
66 "Debug the bison parser.")
67     (debug-property-callbacks #f
68 "Debug cyclic callback chains.")
69     (debug-skylines #f
70 "Debug skylines.")
71     (delete-intermediate-files #t
72 "Delete unusable, intermediate PostScript files.")
73     (dump-profile #f
74 "Dump memory and time information for each file.")
75     (dump-cpu-profile #f
76 "Dump timing information (system-dependent).")
77     (dump-signatures #f
78 "Dump output signatures of each system.  Used for
79 regression testing.")
80     (eps-box-padding #f
81 "Pad left edge of the output EPS bounding box by
82 given amount (in mm).")
83     (gs-load-fonts #f
84 "Load fonts via Ghostscript.")
85     (gs-load-lily-fonts #f
86 "Load only LilyPond fonts via Ghostscript.")
87     (gui #f
88 "Run LilyPond from a GUI and redirect stderr to
89 a log file.")
90     (help #f
91 "Show this help.")
92     (include-book-title-preview #t
93 "Include book titles in preview images.")
94     (include-eps-fonts #t
95 "Include fonts in separate-system EPS files.")
96     (job-count #f
97 "Process in parallel, using the given number of
98 jobs.")
99     (log-file #f
100 "If string FOO is given as argument, redirect
101 output to log file `FOO.log'.")
102     (midi-extension ,(if (eq? PLATFORM 'windows)
103                          "mid"
104                          "midi")
105 "Set the default file extension for MIDI output
106 file to given string.")
107     (old-relative #f
108 "Make \\relative mode for simultaneous music work
109 similar to chord syntax.")
110     (point-and-click #t
111 "Add point & click links to PDF output.")
112     (paper-size "a4"
113 "Set default paper size.")
114     (pixmap-format "png16m"
115 "Set GhostScript's output format for pixel images.")
116     (preview #f
117 "Create PNG and EPS preview images also.")
118     (print-pages #t
119 "Print pages in the normal way.")
120     (protected-scheme-parsing #t
121 "Continue when errors in inline scheme are caught
122 in the parser.  If #f, halt on errors and print
123 a stack trace.")
124     (profile-property-accesses #f
125 "Keep statistics of get_property() calls.")
126     (resolution 101
127 "Set resolution for generating PNG pixmaps to
128 given value (in dpi).")
129     (read-file-list #f
130 "Specify name of a file which contains a list of
131 input files to be processed.")
132     (relative-includes #f
133 "When processing an \\include command, look for
134 the included file relative to the current file
135 (instead of the root file)")
136     (safe #f
137 "Run in safer mode.")
138     (strict-infinity-checking #f
139 "Force a crash on encountering Inf and NaN
140 floating point exceptions.")
141     (strip-output-dir #t
142 "Don't use directories from input files while
143 constructing output file names.")
144     (separate-log-files #f
145 "For input files `FILE1.ly', `FILE2.ly', ...
146 output log data to files `FILE1.log',
147 `FILE2.log', ...")
148     (trace-memory-frequency #f
149 "Record Scheme cell usage this many times per
150 second.  Dump results to `FILE.stacks' and
151 `FILE.graph'.")
152     (trace-scheme-coverage #f
153 "Record coverage of Scheme files in `FILE.cov'.")
154     (show-available-fonts #f
155 "List available font names.")
156     (verbose ,(ly:command-line-verbose?)
157 "Value of the --verbose flag (read-only).")
158     (warning-as-error #f
159 "Change all warning and programming_error
160 messages into errors.")
161     ))
162
163 ;; Need to do this in the beginning.  Other parts of the Scheme
164 ;; initialization depend on these options.
165
166 (for-each (lambda (x)
167             (ly:add-option (car x) (cadr x) (caddr x)))
168           scheme-options-definitions)
169
170 (for-each (lambda (x)
171             (ly:set-option (car x) (cdr x)))
172           (eval-string (ly:command-line-options)))
173
174 (debug-set! stack 0)
175
176 (if (defined? 'set-debug-cell-accesses!)
177     (set-debug-cell-accesses! #f))
178
179                                         ;(set-debug-cell-accesses! 1000)
180
181 (use-modules (ice-9 regex)
182              (ice-9 safe)
183              (ice-9 format)
184              (ice-9 rdelim)
185              (ice-9 optargs)
186              (oop goops)
187              (srfi srfi-1)
188              (srfi srfi-13)
189              (srfi srfi-14)
190              (scm clip-region)
191              (scm memory-trace)
192              (scm coverage))
193
194 (define-public fancy-format
195   format)
196
197 (define-public (ergonomic-simple-format dest . rest)
198   "Like ice-9 format, but without the memory consumption."
199   (if (string? dest)
200       (apply simple-format (cons #f (cons dest rest)))
201       (apply simple-format (cons dest rest))))
202
203 (define format
204   ergonomic-simple-format)
205
206 ;; my display
207 (define-public (myd k v)
208   (display k)
209   (display ": ")
210   (display v)
211   (display ", ")
212   v)
213
214 (define-public (print . args)
215   (apply format (cons (current-output-port) args)))
216
217
218 ;;; General settings.
219 ;;;
220 ;;; Debugging evaluator is slower.  This should have a more sensible
221 ;;; default.
222
223 (if (or (ly:get-option 'verbose)
224         (ly:get-option 'trace-memory-frequency)
225         (ly:get-option 'trace-scheme-coverage))
226     (begin
227       (ly:set-option 'protected-scheme-parsing #f)
228       (debug-enable 'debug)
229       (debug-enable 'backtrace)
230       (read-enable 'positions)))
231
232 (if (ly:get-option 'trace-scheme-coverage)
233     (coverage:enable))
234
235 (define-public parser #f)
236
237
238 ;; gettext wrapper for guile < 1.7.2
239 (if (defined? 'gettext)
240     (define-public _ gettext)
241     (define-public _ ly:gettext))
242
243 (define-public (ly:load x)
244   (let* ((file-name (%search-load-path x)))
245     (if (ly:get-option 'verbose)
246         (ly:progress "[~A" file-name))
247     (if (not file-name)
248         (ly:error (_ "cannot find: ~A") x))
249     (primitive-load file-name)
250     (if (ly:get-option 'verbose)
251         (ly:progress "]\n"))))
252
253 (define-public DOS
254   (let ((platform (string-tokenize
255                    (vector-ref (uname) 0) char-set:letter+digit)))
256     (if (null? (cdr platform)) #f
257         (member (string-downcase (cadr platform)) '("95" "98" "me")))))
258
259 (case PLATFORM
260   ((windows)
261    (define native-getcwd
262      getcwd)
263
264    (define (slashify x)
265      (if (string-index x #\\)
266          x
267          (string-regexp-substitute
268           "//*" "/"
269           (string-regexp-substitute "\\\\" "/" x))))
270
271    ;; FIXME: this prints a warning.
272    (define-public (ly-getcwd)
273      (slashify (native-getcwd))))
274
275   (else
276    (define-public ly-getcwd
277      getcwd)))
278
279 (define-public (is-absolute? file-name)
280   (let ((file-name-length (string-length file-name)))
281     (if (= file-name-length 0)
282         #f
283         (or (eq? (string-ref file-name 0) #\/)
284             (and (eq? PLATFORM 'windows)
285                  (> file-name-length 2)
286                  (eq? (string-ref file-name 1) #\:)
287                  (eq? (string-ref file-name 2) #\/))))))
288
289 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
290
291 (define (type-check-list location signature arguments)
292   "Typecheck a list of arguments against a list of type predicates.
293 Print a message at LOCATION if any predicate failed."
294   (define (recursion-helper signature arguments count)
295     (define (helper pred? arg count)
296       (if (not (pred? arg))
297           (begin
298             (ly:input-message
299              location
300              (format
301               #f (_ "wrong type for argument ~a.  Expecting ~a, found ~s")
302               count (type-name pred?) arg))
303             #f)
304           #t))
305
306     (if (null? signature)
307         #t
308         (and (helper (car signature) (car arguments) count)
309              (recursion-helper (cdr signature) (cdr arguments) (1+ count)))))
310   (recursion-helper signature arguments 1))
311
312
313 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
314 ;; Safe definitions utility
315
316 (define safe-objects
317   (list))
318
319 (define-macro (define-safe-public arglist . body)
320   "Define a variable, export it, and mark it as safe, i.e. usable in
321 LilyPond safe mode.  The syntax is the same as `define*-public'."
322   (define (get-symbol arg)
323     (if (pair? arg)
324         (get-symbol (car arg))
325         arg))
326
327   (let ((safe-symbol (get-symbol arglist)))
328     `(begin
329        (define*-public ,arglist
330          ,@body)
331        (set! safe-objects (cons (cons ',safe-symbol ,safe-symbol)
332                                 safe-objects))
333        ,safe-symbol)))
334
335 (define-safe-public (lilypond-version)
336   (string-join
337    (map (lambda (x) (if (symbol? x)
338                         (symbol->string x)
339                         (number->string x)))
340         (ly:version))
341    "."))
342
343 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
344 ;; init pitch system
345
346 (ly:set-default-scale (ly:make-scale #(0 1 2 5/2 7/2 9/2 11/2)))
347
348 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
349 ;; other files.
350
351 (define init-scheme-files
352   '("lily-library.scm"
353     "file-cache.scm"
354     "define-event-classes.scm"
355     "define-music-types.scm"
356     "output-lib.scm"
357     "c++.scm"
358     "chord-ignatzek-names.scm"
359     "chord-entry.scm"
360     "chord-generic-names.scm"
361     "stencil.scm"
362     "markup.scm"
363     "music-functions.scm"
364     "part-combiner.scm"
365     "autochange.scm"
366     "define-music-properties.scm"
367     "beam-settings.scm"
368     "auto-beam.scm"
369     "chord-name.scm"
370
371     "parser-ly-from-scheme.scm"
372     "ly-syntax-constructors.scm"
373
374     "define-context-properties.scm"
375     "translation-functions.scm"
376     "script.scm"
377     "midi.scm"
378     "layout-beam.scm"
379     "parser-clef.scm"
380     "layout-slur.scm"
381     "font.scm"
382     "encoding.scm"
383
384     "flag-styles.scm"
385     "fret-diagrams.scm"
386     "harp-pedals.scm"
387     "predefined-fretboards.scm"
388     "define-markup-commands.scm"
389     "define-grob-properties.scm"
390     "define-grobs.scm"
391     "define-grob-interfaces.scm"
392     "define-stencil-commands.scm"
393     "titling.scm"
394
395     "paper.scm"
396     "backend-library.scm"
397     "x11-color.scm"
398     "tablature.scm"
399
400     ;; must be after everything has been defined
401     "safe-lily.scm"))
402
403 (for-each ly:load init-scheme-files)
404
405 (set! type-p-name-alist
406       `((,boolean? . "boolean")
407         (,boolean-or-symbol? . "boolean or symbol")
408         (,char? . "char")
409         (,grob-list? . "list of grobs")
410         (,hash-table? . "hash table")
411         (,input-port? . "input port")
412         (,integer? . "integer")
413         (,list? . "list")
414         (,ly:context? . "context")
415         (,ly:dimension? . "dimension, in staff space")
416         (,ly:dir? . "direction")
417         (,ly:duration? . "duration")
418         (,ly:font-metric? . "font metric")
419         (,ly:grob? . "layout object")
420         (,ly:grob-array? . "array of grobs")
421         (,ly:input-location? . "input location")
422         (,ly:moment? . "moment")
423         (,ly:music? . "music")
424         (,ly:music-list? . "list of music objects")
425         (,ly:music-output? . "music output")
426         (,ly:pitch? . "pitch")
427         (,ly:translator? . "translator")
428         (,ly:simple-closure? . "simple closure")
429         (,ly:skyline-pair? . "pair of skylines")
430         (,ly:stencil? . "stencil")
431         (,markup-list? . "list of markups")
432         (,markup? . "markup")
433         (,number-or-grob? . "number or grob")
434         (,number-or-string? . "number or string")
435         (,number-pair? . "pair of numbers")
436         (,number? . "number")
437         (,output-port? . "output port")
438         (,pair? . "pair")
439         (,procedure? . "procedure")
440         (,rhythmic-location? . "rhythmic location")
441         (,scheme? . "any type")
442         (,string? . "string")
443         (,symbol? . "symbol")
444         (,vector? . "vector")))
445
446 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
447 ;; timing
448
449 (define (profile-measurements)
450   (let* ((t (times))
451          (stats (gc-stats)))
452     (list (- (+ (tms:cutime t)
453                 (tms:utime t))
454              (assoc-get 'gc-time-taken stats))
455           (assoc-get 'total-cells-allocated  stats 0))))
456
457 (define (dump-profile base last this)
458   (let* ((outname (format "~a.profile" (dir-basename base ".ly")))
459          (diff (map (lambda (y) (apply - y)) (zip this last))))
460     (ly:progress "\nWriting timing to ~a..." outname)
461     (format (open-file outname "w")
462             "time: ~a\ncells: ~a\n"
463             (if (ly:get-option 'dump-cpu-profile)
464                 (car diff)
465                 0)
466             (cadr diff))))
467
468 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
469 ;; debug memory leaks
470
471 (define gc-dumping
472   #f)
473
474 (define gc-protect-stat-count
475   0)
476
477 (define-public (dump-live-object-stats outfile)
478   (for-each (lambda (x)
479               (format outfile "~a: ~a\n" (car x) (cdr x)))
480             (sort (gc-live-object-stats)
481                   (lambda (x y)
482                     (string<? (car x) (car y))))))
483
484 (define-public (dump-gc-protects)
485   (set! gc-protect-stat-count (1+ gc-protect-stat-count))
486   (let* ((protects (sort (hash-table->alist (ly:protects))
487                          (lambda (a b)
488                            (< (object-address (car a))
489                               (object-address (car b))))))
490          (out-file-name (string-append
491                          "gcstat-" (number->string gc-protect-stat-count)
492                          ".scm"))
493          (outfile (open-file out-file-name "w")))
494     (set! gc-dumping #t)
495     (display (format "Dumping GC statistics ~a...\n" out-file-name))
496     (display (map (lambda (y)
497                     (let ((x (car y))
498                           (c (cdr y)))
499                       (display
500                        (format "~a (~a) = ~a\n" (object-address x) c x)
501                        outfile)))
502                   (filter
503                    (lambda (x)
504                      (not (symbol? (car x))))
505                    protects))
506              outfile)
507     (format outfile "\nprotected symbols: ~a\n"
508             (apply + (map (lambda (obj-count)
509                             (if (symbol? (car obj-count))
510                                 (cdr obj-count)
511                                 0))
512                           protects)))
513
514     ;; (display (ly:smob-protects))
515     (newline outfile)
516     (if (defined? 'gc-live-object-stats)
517         (let* ((stats #f))
518           (display "Live object statistics: GC'ing\n")
519           (ly:reset-all-fonts)
520           (gc)
521           (gc)
522           (display "Asserting dead objects\n")
523           (ly:set-option 'debug-gc-assert-parsed-dead #t)
524           (gc)
525           (ly:set-option 'debug-gc-assert-parsed-dead #f)
526           (set! stats (gc-live-object-stats))
527           (display "Dumping live object statistics.\n")
528           (dump-live-object-stats outfile)))
529     (newline outfile)
530     (let* ((stats (gc-stats)))
531       (for-each (lambda (sym)
532                   (display
533                    (format "~a ~a ~a\n"
534                            gc-protect-stat-count
535                            sym
536                            (assoc-get sym stats "?"))
537
538                    outfile))
539                 '(protected-objects bytes-malloced cell-heap-size)))
540     (set! gc-dumping #f)
541     (close-port outfile)))
542
543 (define (check-memory)
544   "Read `/proc/self' to check up on memory use."
545   (define (gulp-file name)
546     (let* ((file (open-input-file name))
547            (text (read-delimited "" file)))
548       (close file)
549       text))
550
551   (let* ((stat (gulp-file "/proc/self/status"))
552          (lines (string-split stat #\newline))
553          (interesting (filter identity
554                               (map
555                                (lambda (l)
556                                  (string-match "^VmData:[ \t]*([0-9]*) kB" l))
557                                lines)))
558          (mem (string->number (match:substring (car interesting) 1))))
559     (display (format  "VMDATA: ~a\n" mem))
560     (display (gc-stats))
561     (if (> mem 100000)
562         (begin (dump-gc-protects)
563                (raise 1)))))
564
565 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
566
567 (define (multi-fork count)
568   "Split this process into COUNT helpers.  Returns either a list of
569 PIDs or the number of the process."
570   (define (helper count acc)
571     (if (> count 0)
572         (let* ((pid (primitive-fork)))
573           (if (= pid 0)
574               (1- count)
575               (helper (1- count) (cons pid acc))))
576         acc))
577
578   (helper count '()))
579
580 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
581
582 (define-public (lilypond-main files)
583   "Entry point for LilyPond."
584   (eval-string (ly:command-line-code))
585   (if (ly:get-option 'help)
586       (begin (ly:option-usage)
587              (exit 0)))
588   (if (ly:get-option 'show-available-fonts)
589       (begin (ly:font-config-display-fonts)
590              (exit 0)))
591   (if (ly:get-option 'gui)
592       (gui-main files))
593   (if (null? files)
594       (begin (ly:usage)
595              (exit 2)))
596   (if (ly:get-option 'read-file-list)
597       (set! files
598             (filter (lambda (s)
599                       (> (string-length s) 0))
600                     (apply append
601                            (map (lambda (f)
602                                   (string-split (ly:gulp-file f) #\nl))
603                                 files)))))
604   (if (and (number? (ly:get-option 'job-count))
605            (>= (length files) (ly:get-option 'job-count)))
606       (let* ((count (ly:get-option 'job-count))
607              (split-todo (split-list files count))
608              (joblist (multi-fork count))
609              (errors '()))
610         (if (not (string-or-symbol? (ly:get-option 'log-file)))
611             (ly:set-option 'log-file "lilypond-multi-run"))
612         (if (number? joblist)
613             (begin (ly:set-option
614                     'log-file (format "~a-~a"
615                                       (ly:get-option 'log-file) joblist))
616                    (set! files (vector-ref split-todo joblist)))
617             (begin (ly:progress "\nForking into jobs:  ~a\n" joblist)
618                    (for-each
619                     (lambda (pid)
620                       (let* ((stat (cdr (waitpid pid))))
621                         (if (not (= stat 0))
622                             (set! errors
623                                   (acons (list-element-index joblist pid)
624                                          stat errors)))))
625                     joblist)
626                    (for-each
627                     (lambda (x)
628                       (let* ((job (car x))
629                              (state (cdr x))
630                              (logfile (format "~a-~a.log"
631                                               (ly:get-option 'log-file) job))
632                              (log (ly:gulp-file logfile))
633                              (len (string-length log))
634                              (tail (substring  log (max 0 (- len 1024)))))
635                         (if (status:term-sig state)
636                             (ly:message
637                              "\n\n~a\n"
638                              (format (_ "job ~a terminated with signal: ~a")
639                                      job (status:term-sig state)))
640                             (ly:message
641                              (_ "logfile ~a (exit ~a):\n~a")
642                              logfile (status:exit-val state) tail))))
643                     errors)
644                    (if (pair? errors)
645                        (ly:error "Children ~a exited with errors."
646                                  (map car errors)))
647                    ;; must overwrite individual entries
648                    (if (ly:get-option 'dump-profile)
649                        (dump-profile "lily-run-total"
650                                      '(0 0) (profile-measurements)))
651                    (exit (if (null? errors)
652                              0
653                              1))))))
654   (if (string-or-symbol? (ly:get-option 'log-file))
655       (ly:stderr-redirect (format "~a.log" (ly:get-option 'log-file)) "w"))
656   (let ((failed (lilypond-all files)))
657     (if (ly:get-option 'trace-scheme-coverage)
658         (begin
659           (coverage:show-all (lambda (f)
660                                (string-contains f "lilypond")))))
661     (if (pair? failed)
662         (begin (ly:error (_ "failed files: ~S") (string-join failed))
663                (exit 1))
664         (begin
665           ;; HACK: be sure to exit with single newline
666           (ly:message "")
667           (exit 0)))))
668
669 (define-public (lilypond-all files)
670   (let* ((failed '())
671          (separate-logs (ly:get-option 'separate-log-files))
672          (ping-log
673           (if separate-logs
674               (open-file (if (string-or-symbol? (ly:get-option 'log-file))
675                              (format "~a.log" (ly:get-option 'log-file))
676                              "/dev/tty") "a") #f))
677          (do-measurements (ly:get-option 'dump-profile))
678          (handler (lambda (key failed-file)
679                     (set! failed (append (list failed-file) failed)))))
680     (gc)
681     (for-each
682      (lambda (x)
683        (let* ((start-measurements (if do-measurements
684                                       (profile-measurements)
685                                       #f))
686               (base (dir-basename x ".ly"))
687               (all-settings (ly:all-options)))
688          (if separate-logs
689              (ly:stderr-redirect (format "~a.log" base) "w"))
690          (if ping-log
691              (format ping-log "Processing ~a\n" base))
692          (if (ly:get-option 'trace-memory-frequency)
693              (mtrace:start-trace  (ly:get-option 'trace-memory-frequency)))
694          (lilypond-file handler x)
695          (if start-measurements
696              (dump-profile x start-measurements (profile-measurements)))
697          (if (ly:get-option 'trace-memory-frequency)
698              (begin (mtrace:stop-trace)
699                     (mtrace:dump-results base)))
700          (for-each (lambda (s)
701                      (ly:set-option (car s) (cdr s)))
702                    all-settings)
703          (ly:clear-anonymous-modules)
704          (ly:set-option 'debug-gc-assert-parsed-dead #t)
705          (gc)
706          (ly:set-option 'debug-gc-assert-parsed-dead #f)
707          (if (ly:get-option 'debug-gc)
708              (dump-gc-protects)
709              (if (= (random 40) 1)
710                  (ly:reset-all-fonts)))))
711      files)
712
713     ;; we want the failed-files notice in the aggregrate logfile.
714     (if ping-log
715         (format ping-log "Failed files: ~a\n" failed))
716     (if (ly:get-option 'dump-profile)
717         (dump-profile "lily-run-total" '(0 0) (profile-measurements)))
718     failed))
719
720 (define (lilypond-file handler file-name)
721   (catch 'ly-file-failed
722          (lambda () (ly:parse-file file-name))
723          (lambda (x . args) (handler x file-name))))
724
725 (use-modules (scm editor))
726
727 (define-public (gui-main files)
728   (if (null? files)
729       (gui-no-files-handler))
730   (if (not (string? (ly:get-option 'log-file)))
731       (let* ((base (dir-basename (car files) ".ly"))
732              (log-name (string-append base ".log")))
733         (if (not (ly:get-option 'gui))
734             (ly:message (_ "Redirecting output to ~a...") log-name))
735         (ly:stderr-redirect log-name "w")
736         (ly:message "# -*-compilation-*-"))
737       (let ((failed (lilypond-all files)))
738         (if (pair? failed)
739             (begin
740               ;; ugh
741               (ly:stderr-redirect "foo" "r")
742               (system (get-editor-command log-name 0 0 0))
743               (ly:error (_ "failed files: ~S") (string-join failed))
744               ;; not reached?
745               (exit 1))
746             (exit 0)))))
747
748 (define (gui-no-files-handler)
749   (let* ((ly (string-append (ly:effective-prefix) "/ly/"))
750          ;; FIXME: soft-code, localize
751          (welcome-ly (string-append ly "Welcome_to_LilyPond.ly"))
752          (cmd (get-editor-command welcome-ly 0 0 0)))
753     (ly:message (_ "Invoking `~a'...\n") cmd)
754     (system cmd)
755     (exit 1)))