1 ;;;; lily.scm -- top-level Scheme stuff
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 1998--2009 Jan Nieuwenhuizen <janneke@gnu.org>
6 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
8 ;; Internationalisation: (_i "to be translated") gets an entry in the
9 ;; POT file; (gettext ...) must be invoked explicitly to do the actual
12 ;; (define-macro (_i x) x)
13 ;; (define-macro-public _i (x) x)
14 ;; (define-public-macro _i (x) x)
17 (defmacro-public _i (x) x)
19 (read-enable 'positions)
22 (define-public PLATFORM
25 (car (string-tokenize (utsname:sysname (uname)))))))
27 (define scheme-options-definitions
31 ;; - [subject-]object-object-verb +"ing"
32 ;; - [subject-]-verb-object-object
34 ;; Avoid overlong lines in `lilypond -dhelp'! Strings should not
35 ;; be longer than 48 characters per line.
38 "Render at higher resolution (using given factor)
39 and scale down result to prevent jaggies in
42 "Select backend. Possible values: 'eps, 'null,
44 (check-internal-types #f
45 "Check every property assignment for types.")
47 "Generate cut-out snippets of a score.")
49 "LilyPond prefix for data files (read-only).")
51 "Dump memory debugging statistics.")
52 (debug-gc-assert-parsed-dead #f
53 "For memory debugging: Ensure that all
54 references to parsed objects are dead. This is
55 an internal option, and is switched on
56 automatically for `-ddebug-gc'.")
58 "Debug the flex lexer.")
59 (debug-page-breaking-scoring #f
60 "Dump scores for many different page breaking
63 "Debug the bison parser.")
64 (debug-property-callbacks #f
65 "Debug cyclic callback chains.")
68 (delete-intermediate-files #f
69 "Delete unusable, intermediate PostScript files.")
71 "Dump memory and time information for each file.")
73 "Dump timing information (system-dependent).")
75 "Dump output signatures of each system. Used for
78 "Pad left edge of the output EPS bounding box by
79 given amount (in mm).")
81 "Load fonts via Ghostscript.")
82 (gs-load-lily-fonts #f
83 "Load only LilyPond fonts via Ghostscript.")
85 "Run LilyPond from a GUI and redirect stderr to
89 (include-book-title-preview #t
90 "Include book titles in preview images.")
92 "Include fonts in separate-system EPS files.")
94 "Process in parallel, using the given number of
97 "If string FOO is given as argument, redirect
98 output to log file `FOO.log'.")
99 (midi-extension ,(if (eq? PLATFORM 'windows)
102 "Set the default file extension for MIDI output
103 file to given string.")
105 "Make \\relative mode for simultaneous music work
106 similar to chord syntax.")
108 "Add point & click links to PDF output.")
110 "Set default paper size.")
111 (pixmap-format "png16m"
112 "Set GhostScript's output format for pixel images.")
114 "Create PNG and EPS preview images also.")
116 "Print pages in the normal way.")
117 (protected-scheme-parsing #t
118 "Continue when errors in inline scheme are caught
119 in the parser. If #f, halt on errors and print
121 (profile-property-accesses #f
122 "Keep statistics of get_property() calls.")
124 "Set resolution for generating PNG pixmaps to
125 given value (in dpi).")
127 "Specify name of a file which contains a list of
128 input files to be processed.")
129 (relative-includes #f
130 "When processing an \\include command, look for
131 the included file relative to the current file
132 (instead of the root file)")
134 "Run in safer mode.")
135 (strict-infinity-checking #f
136 "Force a crash on encountering Inf and NaN
137 floating point exceptions.")
139 "Don't use directories from input files while
140 constructing output file names.")
141 (separate-log-files #f
142 "For input files `FILE1.ly', `FILE2.ly', ...
143 output log data to files `FILE1.log',
145 (trace-memory-frequency #f
146 "Record Scheme cell usage this many times per
147 second. Dump results to `FILE.stacks' and
149 (trace-scheme-coverage #f
150 "Record coverage of Scheme files in `FILE.cov'.")
151 (show-available-fonts #f
152 "List available font names.")
153 (verbose ,(ly:command-line-verbose?)
154 "Value of the --verbose flag (read-only).")
157 ;; Need to do this in the beginning. Other parts of the Scheme
158 ;; initialization depend on these options.
160 (for-each (lambda (x)
161 (ly:add-option (car x) (cadr x) (caddr x)))
162 scheme-options-definitions)
164 (for-each (lambda (x)
165 (ly:set-option (car x) (cdr x)))
166 (eval-string (ly:command-line-options)))
170 (if (defined? 'set-debug-cell-accesses!)
171 (set-debug-cell-accesses! #f))
173 ;(set-debug-cell-accesses! 1000)
175 (use-modules (ice-9 regex)
188 (define-public fancy-format
191 (define-public (ergonomic-simple-format dest . rest)
192 "Like ice-9 format, but without the memory consumption."
194 (apply simple-format (cons #f (cons dest rest)))
195 (apply simple-format (cons dest rest))))
198 ergonomic-simple-format)
201 (define-public (myd k v)
208 (define-public (print . args)
209 (apply format (cons (current-output-port) args)))
212 ;;; General settings.
214 ;;; Debugging evaluator is slower. This should have a more sensible
217 (if (or (ly:get-option 'verbose)
218 (ly:get-option 'trace-memory-frequency)
219 (ly:get-option 'trace-scheme-coverage))
221 (ly:set-option 'protected-scheme-parsing #f)
222 (debug-enable 'debug)
223 (debug-enable 'backtrace)
224 (read-enable 'positions)))
226 (if (ly:get-option 'trace-scheme-coverage)
229 (define-public parser #f)
232 ;; gettext wrapper for guile < 1.7.2
233 (if (defined? 'gettext)
234 (define-public _ gettext)
235 (define-public _ ly:gettext))
237 (define-public (ly:load x)
238 (let* ((file-name (%search-load-path x)))
239 (if (ly:get-option 'verbose)
240 (ly:progress "[~A" file-name))
242 (ly:error (_ "cannot find: ~A") x))
243 (primitive-load file-name)
244 (if (ly:get-option 'verbose)
248 (let ((platform (string-tokenize
249 (vector-ref (uname) 0) char-set:letter+digit)))
250 (if (null? (cdr platform)) #f
251 (member (string-downcase (cadr platform)) '("95" "98" "me")))))
255 (define native-getcwd
259 (if (string-index x #\\)
261 (string-regexp-substitute
263 (string-regexp-substitute "\\\\" "/" x))))
265 ;; FIXME: this prints a warning.
266 (define-public (ly-getcwd)
267 (slashify (native-getcwd))))
270 (define-public ly-getcwd
273 (define-public (is-absolute? file-name)
274 (let ((file-name-length (string-length file-name)))
275 (if (= file-name-length 0)
277 (or (eq? (string-ref file-name 0) #\/)
278 (and (eq? PLATFORM 'windows)
279 (> file-name-length 2)
280 (eq? (string-ref file-name 1) #\:)
281 (eq? (string-ref file-name 2) #\/))))))
283 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
285 (define (type-check-list location signature arguments)
286 "Typecheck a list of arguments against a list of type predicates.
287 Print a message at LOCATION if any predicate failed."
288 (define (recursion-helper signature arguments count)
289 (define (helper pred? arg count)
290 (if (not (pred? arg))
295 #f (_ "wrong type for argument ~a. Expecting ~a, found ~s")
296 count (type-name pred?) arg))
300 (if (null? signature)
302 (and (helper (car signature) (car arguments) count)
303 (recursion-helper (cdr signature) (cdr arguments) (1+ count)))))
304 (recursion-helper signature arguments 1))
306 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
309 ;; (define-public (output-framework) (write "hello\n"))
311 (define output-ps-module
312 (make-module 1021 (list (resolve-interface '(scm output-ps)))))
314 (define-public (ps-output-expression expr port)
315 (display (eval expr output-ps-module) port))
317 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
318 ;; Safe definitions utility
323 (define-macro (define-safe-public arglist . body)
324 "Define a variable, export it, and mark it as safe, i.e. usable in
325 LilyPond safe mode. The syntax is the same as `define*-public'."
326 (define (get-symbol arg)
328 (get-symbol (car arg))
331 (let ((safe-symbol (get-symbol arglist)))
333 (define*-public ,arglist
335 (set! safe-objects (cons (cons ',safe-symbol ,safe-symbol)
339 (define-safe-public (lilypond-version)
341 (map (lambda (x) (if (symbol? x)
347 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
350 (ly:set-default-scale (ly:make-scale #(0 1 2 5/2 7/2 9/2 11/2)))
352 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
355 (define init-scheme-files
358 "define-event-classes.scm"
359 "define-music-types.scm"
362 "chord-ignatzek-names.scm"
364 "chord-generic-names.scm"
367 "music-functions.scm"
370 "define-music-properties.scm"
374 "parser-ly-from-scheme.scm"
375 "ly-syntax-constructors.scm"
377 "define-context-properties.scm"
378 "translation-functions.scm"
390 "predefined-fretboards.scm"
391 "define-markup-commands.scm"
392 "define-grob-properties.scm"
394 "define-grob-interfaces.scm"
395 "define-stencil-commands.scm"
399 "backend-library.scm"
402 ;; must be after everything has been defined
405 (for-each ly:load init-scheme-files)
407 (set! type-p-name-alist
408 `((,boolean-or-symbol? . "boolean or symbol")
409 (,boolean? . "boolean")
411 (,grob-list? . "list of grobs")
412 (,hash-table? . "hash table")
413 (,input-port? . "input port")
414 (,integer? . "integer")
416 (,ly:context? . "context")
417 (,ly:dimension? . "dimension, in staff space")
418 (,ly:dir? . "direction")
419 (,ly:duration? . "duration")
420 (,ly:grob? . "layout object")
421 (,ly:input-location? . "input location")
422 (,ly:moment? . "moment")
423 (,ly:music? . "music")
424 (,ly:pitch? . "pitch")
425 (,ly:translator? . "translator")
426 (,ly:font-metric? . "font metric")
427 (,ly:simple-closure? . "simple closure")
428 (,markup-list? . "list of markups")
429 (,markup? . "markup")
430 (,ly:music-list? . "list of music")
431 (,number-or-grob? . "number or grob")
432 (,number-or-string? . "number or string")
433 (,number-pair? . "pair of numbers")
434 (,number? . "number")
435 (,output-port? . "output port")
437 (,procedure? . "procedure")
438 (,rhythmic-location? . "rhythmic location")
439 (,scheme? . "any type")
440 (,string? . "string")
441 (,symbol? . "symbol")
442 (,vector? . "vector")))
444 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
447 (define (profile-measurements)
450 (list (- (+ (tms:cutime t)
452 (ly:assoc-get 'gc-time-taken stats))
453 (ly:assoc-get 'total-cells-allocated stats 0))))
455 (define (dump-profile base last this)
456 (let* ((outname (format "~a.profile" (dir-basename base ".ly")))
457 (diff (map (lambda (y) (apply - y)) (zip this last))))
458 (ly:progress "\nWriting timing to ~a..." outname)
459 (format (open-file outname "w")
460 "time: ~a\ncells: ~a\n"
461 (if (ly:get-option 'dump-cpu-profile)
466 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
467 ;; debug memory leaks
472 (define gc-protect-stat-count
475 (define-public (dump-live-object-stats outfile)
476 (for-each (lambda (x)
477 (format outfile "~a: ~a\n" (car x) (cdr x)))
478 (sort (gc-live-object-stats)
480 (string<? (car x) (car y))))))
482 (define-public (dump-gc-protects)
483 (set! gc-protect-stat-count (1+ gc-protect-stat-count))
484 (let* ((protects (sort (hash-table->alist (ly:protects))
486 (< (object-address (car a))
487 (object-address (car b))))))
488 (out-file-name (string-append
489 "gcstat-" (number->string gc-protect-stat-count)
491 (outfile (open-file out-file-name "w")))
493 (display (format "Dumping GC statistics ~a...\n" out-file-name))
494 (display (map (lambda (y)
498 (format "~a (~a) = ~a\n" (object-address x) c x)
502 (not (symbol? (car x))))
505 (format outfile "\nprotected symbols: ~a\n"
506 (apply + (map (lambda (obj-count)
507 (if (symbol? (car obj-count))
512 ;; (display (ly:smob-protects))
514 (if (defined? 'gc-live-object-stats)
516 (display "Live object statistics: GC'ing\n")
520 (display "Asserting dead objects\n")
521 (ly:set-option 'debug-gc-assert-parsed-dead #t)
523 (ly:set-option 'debug-gc-assert-parsed-dead #f)
524 (set! stats (gc-live-object-stats))
525 (display "Dumping live object statistics.\n")
526 (dump-live-object-stats outfile)))
528 (let* ((stats (gc-stats)))
529 (for-each (lambda (sym)
532 gc-protect-stat-count
534 (let ((sym-stat (assoc sym stats)))
539 '(protected-objects bytes-malloced cell-heap-size)))
541 (close-port outfile)))
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)))
551 (let* ((stat (gulp-file "/proc/self/status"))
552 (lines (string-split stat #\newline))
553 (interesting (filter identity
556 (string-match "^VmData:[ \t]*([0-9]*) kB" l))
558 (mem (string->number (match:substring (car interesting) 1))))
559 (display (format "VMDATA: ~a\n" mem))
562 (begin (dump-gc-protects)
565 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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)
572 (let* ((pid (primitive-fork)))
575 (helper (1- count) (cons pid acc))))
580 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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)
588 (if (ly:get-option 'show-available-fonts)
589 (begin (ly:font-config-display-fonts)
591 (if (ly:get-option 'gui)
596 (if (ly:get-option 'read-file-list)
599 (> (string-length s) 0))
602 (string-split (ly:gulp-file f) #\nl))
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))
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)
620 (let* ((stat (cdr (waitpid pid))))
623 (acons (list-element-index joblist pid)
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)
638 (format (_ "job ~a terminated with signal: ~a")
639 job (status:term-sig state)))
641 (_ "logfile ~a (exit ~a):\n~a")
642 logfile (status:exit-val state) tail))))
645 (ly:error "Children ~a exited with 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)
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)
659 (coverage:show-all (lambda (f)
660 (string-contains f "lilypond")))))
662 (begin (ly:error (_ "failed files: ~S") (string-join failed))
665 ;; HACK: be sure to exit with single newline
669 (define-public (lilypond-all files)
671 (separate-logs (ly:get-option 'separate-log-files))
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)))))
683 (let* ((start-measurements (if do-measurements
684 (profile-measurements)
686 (base (dir-basename x ".ly"))
687 (all-settings (ly:all-options)))
689 (ly:stderr-redirect (format "~a.log" base) "w"))
691 (format ping-log "Procesing ~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)))
703 (ly:clear-anonymous-modules)
704 (ly:set-option 'debug-gc-assert-parsed-dead #t)
706 (ly:set-option 'debug-gc-assert-parsed-dead #f)
707 (if (ly:get-option 'debug-gc)
709 (if (= (random 40) 1)
710 (ly:reset-all-fonts)))))
713 ;; we want the failed-files notice in the aggregrate logfile.
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)))
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))))
725 (use-modules (scm editor))
727 (define-public (gui-main 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)))
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))
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'...") cmd)