OLD | NEW |
1 ;;;; This file is part of LilyPond, the GNU music typesetter. | 1 ;;;; This file is part of LilyPond, the GNU music typesetter. |
2 ;;;; | 2 ;;;; |
3 ;;;; Copyright (C) 1998--2010 Jan Nieuwenhuizen <janneke@gnu.org> | 3 ;;;; Copyright (C) 1998--2010 Jan Nieuwenhuizen <janneke@gnu.org> |
4 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl> | 4 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl> |
5 ;;;; | 5 ;;;; |
6 ;;;; LilyPond is free software: you can redistribute it and/or modify | 6 ;;;; LilyPond is free software: you can redistribute it and/or modify |
7 ;;;; it under the terms of the GNU General Public License as published by | 7 ;;;; it under the terms of the GNU General Public License as published by |
8 ;;;; the Free Software Foundation, either version 3 of the License, or | 8 ;;;; the Free Software Foundation, either version 3 of the License, or |
9 ;;;; (at your option) any later version. | 9 ;;;; (at your option) any later version. |
10 ;;;; | 10 ;;;; |
(...skipping 166 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
177 )) | 177 )) |
178 | 178 |
179 ;; Need to do this in the beginning. Other parts of the Scheme | 179 ;; Need to do this in the beginning. Other parts of the Scheme |
180 ;; initialization depend on these options. | 180 ;; initialization depend on these options. |
181 | 181 |
182 (for-each (lambda (x) | 182 (for-each (lambda (x) |
183 (ly:add-option (car x) (cadr x) (caddr x))) | 183 (ly:add-option (car x) (cadr x) (caddr x))) |
184 scheme-options-definitions) | 184 scheme-options-definitions) |
185 | 185 |
186 (for-each (lambda (x) | 186 (for-each (lambda (x) |
187 » (ly:set-option (car x) (cdr x))) | 187 » (ly:set-option (car x) (cdr x))) |
188 » (eval-string (ly:command-line-options))) | 188 » (eval-string (ly:command-line-options))) |
189 | 189 |
190 (debug-set! stack 0) | 190 (debug-set! stack 0) |
191 | 191 |
192 (if (defined? 'set-debug-cell-accesses!) | 192 (if (defined? 'set-debug-cell-accesses!) |
193 (set-debug-cell-accesses! #f)) | 193 (set-debug-cell-accesses! #f)) |
194 | 194 |
195 ;(set-debug-cell-accesses! 1000) | 195 ;(set-debug-cell-accesses! 1000) |
196 | 196 |
197 (use-modules (ice-9 regex) | 197 (use-modules (ice-9 regex) |
198 (ice-9 safe) | 198 (ice-9 safe) |
199 (ice-9 format) | 199 (ice-9 format) |
200 (ice-9 rdelim) | 200 (ice-9 rdelim) |
201 (ice-9 optargs) | 201 (ice-9 optargs) |
202 (oop goops) | 202 (oop goops) |
203 (srfi srfi-1) | 203 (srfi srfi-1) |
204 (srfi srfi-13) | 204 (srfi srfi-13) |
205 (srfi srfi-14) | 205 (srfi srfi-14) |
206 (scm clip-region) | 206 (scm clip-region) |
207 (scm memory-trace) | 207 (scm memory-trace) |
208 (scm coverage)) | 208 (scm coverage)) |
209 | 209 |
210 (define-public fancy-format | 210 (define-public fancy-format |
211 format) | 211 format) |
212 | 212 |
| 213 (define (simple-format-handler dest . rest) |
| 214 (if (string? dest) |
| 215 (apply fancy-format (cons #f (cons dest . rest))) |
| 216 (apply fancy-format (cons dest . rest)))) |
| 217 |
213 (define-public (ergonomic-simple-format dest . rest) | 218 (define-public (ergonomic-simple-format dest . rest) |
214 "Like ice-9 format, but without the memory consumption." | 219 "Like ice-9 format, but without the memory consumption." |
215 (if (string? dest) | 220 (catch #t |
| 221 (lambda () (if (string? dest) |
216 (apply simple-format (cons #f (cons dest rest))) | 222 (apply simple-format (cons #f (cons dest rest))) |
217 (apply simple-format (cons dest rest)))) | 223 (apply simple-format (cons dest rest)))) |
| 224 (lambda (key dest . rest) (simple-format-handler dest rest)))) |
218 | 225 |
219 (define format | 226 (define format |
220 ergonomic-simple-format) | 227 ergonomic-simple-format) |
221 | 228 |
222 ;; my display | 229 ;; my display |
223 (define-public (myd k v) | 230 (define-public (myd k v) |
224 (display k) | 231 (display k) |
225 (display ": ") | 232 (display ": ") |
226 (display v) | 233 (display v) |
227 (display ", ") | 234 (display ", ") |
(...skipping 13 matching lines...) Expand all Loading... |
241 (ly:get-option 'trace-scheme-coverage)) | 248 (ly:get-option 'trace-scheme-coverage)) |
242 (begin | 249 (begin |
243 (ly:set-option 'protected-scheme-parsing #f) | 250 (ly:set-option 'protected-scheme-parsing #f) |
244 (debug-enable 'debug) | 251 (debug-enable 'debug) |
245 (debug-enable 'backtrace) | 252 (debug-enable 'backtrace) |
246 (read-enable 'positions))) | 253 (read-enable 'positions))) |
247 | 254 |
248 (if (ly:get-option 'trace-scheme-coverage) | 255 (if (ly:get-option 'trace-scheme-coverage) |
249 (coverage:enable)) | 256 (coverage:enable)) |
250 | 257 |
| 258 ;;; Boolean thunk - are we integrating Guile V2.0 or higher with Lilypond? |
| 259 (define-public (guile-v2 ) |
| 260 (string>? (version) "1.9.10")) |
| 261 |
251 (define-public parser #f) | 262 (define-public parser #f) |
252 | 263 |
253 (define music-string-to-path-backends | 264 (define music-string-to-path-backends |
254 '(svg)) | 265 '(svg)) |
255 | 266 |
256 (if (memq (ly:get-option 'backend) music-string-to-path-backends) | 267 (if (memq (ly:get-option 'backend) music-string-to-path-backends) |
257 (ly:set-option 'music-strings-to-paths #t)) | 268 (ly:set-option 'music-strings-to-paths #t)) |
258 | 269 |
259 (define-public _ gettext) | 270 (define-public _ gettext) |
260 | 271 |
261 (define-public (ly:load x) | 272 (define-public (ly:load x) |
262 (let* ((file-name (%search-load-path x))) | 273 (let* ((file-name (%search-load-path x))) |
263 (if (ly:get-option 'verbose) | 274 (if (ly:get-option 'verbose) |
264 (ly:progress "[~A" file-name)) | 275 (ly:progress "[~A" file-name)) |
265 (if (not file-name) | 276 (if (not file-name) |
266 (ly:error (_ "cannot find: ~A") x)) | 277 (ly:error (_ "cannot find: ~A") x)) |
267 (primitive-load file-name) | 278 (primitive-load file-name) |
268 (if (ly:get-option 'verbose) | 279 (if (ly:get-option 'verbose) |
269 (ly:progress "]\n")))) | 280 (ly:progress "]\n")))) |
270 | 281 |
271 (define-public DOS | 282 (define-public DOS |
272 (let ((platform (string-tokenize | 283 (let ((platform (string-tokenize |
273 » » (vector-ref (uname) 0) char-set:letter+digit))) | 284 » » (vector-ref (uname) 0) char-set:letter+digit))) |
274 (if (null? (cdr platform)) #f | 285 (if (null? (cdr platform)) #f |
275 (member (string-downcase (cadr platform)) '("95" "98" "me"))))) | 286 (member (string-downcase (cadr platform)) '("95" "98" "me"))))) |
276 | 287 |
277 (define (slashify x) | 288 (define (slashify x) |
278 (if (string-index x #\\) | 289 (if (string-index x #\\) |
279 x | 290 x |
280 (string-regexp-substitute | 291 (string-regexp-substitute |
281 "//*" "/" | 292 "//*" "/" |
282 (string-regexp-substitute "\\\\" "/" x)))) | 293 (string-regexp-substitute "\\\\" "/" x)))) |
283 | 294 |
284 (define-public (ly-getcwd) | 295 (define-public (ly-getcwd) |
285 (if (eq? PLATFORM 'windows) | 296 (if (eq? PLATFORM 'windows) |
286 (slashify (getcwd)) | 297 (slashify (getcwd)) |
287 (getcwd))) | 298 (getcwd))) |
288 | 299 |
289 (define-public (is-absolute? file-name) | 300 (define-public (is-absolute? file-name) |
290 (let ((file-name-length (string-length file-name))) | 301 (let ((file-name-length (string-length file-name))) |
291 (if (= file-name-length 0) | 302 (if (= file-name-length 0) |
292 #f | 303 #f |
293 (or (eq? (string-ref file-name 0) #\/) | 304 (or (eq? (string-ref file-name 0) #\/) |
294 (and (eq? PLATFORM 'windows) | 305 (and (eq? PLATFORM 'windows) |
295 (> file-name-length 2) | 306 (> file-name-length 2) |
296 (eq? (string-ref file-name 1) #\:) | 307 (eq? (string-ref file-name 1) #\:) |
297 (eq? (string-ref file-name 2) #\/)))))) | 308 (eq? (string-ref file-name 2) #\/)))))) |
298 | 309 |
299 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | 310 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 311 ;;; If necessary, emulate Guile V2 module_export_all! for Guile V1.8.n |
| 312 (cond-expand |
| 313 ((not guile-v2) |
| 314 (define (module-export-all! mod) |
| 315 (define (fresh-interface!) |
| 316 (let ((iface (make-module))) |
| 317 (set-module-name! iface (module-name mod)) |
| 318 ;; for guile 2: (set-module-version! iface (module-version mod)) |
| 319 (set-module-kind! iface 'interface) |
| 320 (set-module-public-interface! mod iface) |
| 321 iface)) |
| 322 (let ((iface (or (module-public-interface mod) |
| 323 (fresh-interface!)))) |
| 324 (set-module-obarray! iface (module-obarray mod)))))) |
300 | 325 |
| 326 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
301 (define (type-check-list location signature arguments) | 327 (define (type-check-list location signature arguments) |
302 "Typecheck a list of arguments against a list of type predicates. | 328 "Typecheck a list of arguments against a list of type predicates. |
303 Print a message at LOCATION if any predicate failed." | 329 Print a message at LOCATION if any predicate failed." |
304 (define (recursion-helper signature arguments count) | 330 (define (recursion-helper signature arguments count) |
305 (define (helper pred? arg count) | 331 (define (helper pred? arg count) |
306 (if (not (pred? arg)) | 332 (if (not (pred? arg)) |
307 (begin | 333 (begin |
308 (ly:input-message | 334 (ly:input-message |
309 location | 335 location |
310 (format | 336 (format |
(...skipping 395 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
706 (errors '())) | 732 (errors '())) |
707 (if (not (string-or-symbol? (ly:get-option 'log-file))) | 733 (if (not (string-or-symbol? (ly:get-option 'log-file))) |
708 (ly:set-option 'log-file "lilypond-multi-run")) | 734 (ly:set-option 'log-file "lilypond-multi-run")) |
709 (if (number? joblist) | 735 (if (number? joblist) |
710 (begin (ly:set-option | 736 (begin (ly:set-option |
711 'log-file (format "~a-~a" | 737 'log-file (format "~a-~a" |
712 (ly:get-option 'log-file) joblist)) | 738 (ly:get-option 'log-file) joblist)) |
713 (set! files (vector-ref split-todo joblist))) | 739 (set! files (vector-ref split-todo joblist))) |
714 (begin (ly:progress "\nForking into jobs: ~a\n" joblist) | 740 (begin (ly:progress "\nForking into jobs: ~a\n" joblist) |
715 (for-each | 741 (for-each |
716 » » (lambda (pid) | 742 (lambda (pid) |
717 (let* ((stat (cdr (waitpid pid)))) | 743 (let* ((stat (cdr (waitpid pid)))) |
718 (if (not (= stat 0)) | 744 (if (not (= stat 0)) |
719 (set! errors | 745 (set! errors |
720 (acons (list-element-index joblist pid) | 746 (acons (list-element-index joblist pid) |
721 stat errors))))) | 747 stat errors))))) |
722 joblist) | 748 joblist) |
723 (for-each | 749 (for-each |
724 (lambda (x) | 750 (lambda (x) |
725 (let* ((job (car x)) | 751 (let* ((job (car x)) |
726 (state (cdr x)) | 752 (state (cdr x)) |
727 (logfile (format "~a-~a.log" | 753 (logfile (format "~a-~a.log" |
728 (ly:get-option 'log-file) job)) | 754 (ly:get-option 'log-file) job)) |
729 (log (ly:gulp-file logfile)) | 755 (log (ly:gulp-file logfile)) |
730 (len (string-length log)) | 756 (len (string-length log)) |
731 (tail (substring log (max 0 (- len 1024))))) | 757 (tail (substring log (max 0 (- len 1024))))) |
732 » » » (if (status:term-sig state) | 758 » » » (if (status:term-sig state) |
733 » » » (ly:message | 759 » » » (ly:message |
734 » » » "\n\n~a\n" | 760 "\n\n~a\n" |
735 » » » (format (_ "job ~a terminated with signal: ~a") | 761 » » » (format (_ "job ~a terminated with signal: ~a") |
736 » » » » job (status:term-sig state))) | 762 » » » » job (status:term-sig state))) |
737 » » » (ly:message | 763 » » » (ly:message |
738 » » » (_ "logfile ~a (exit ~a):\n~a") | 764 » » » (_ "logfile ~a (exit ~a):\n~a") |
739 » » » logfile (status:exit-val state) tail)))) | 765 » » » logfile (status:exit-val state) tail)))) |
740 errors) | 766 errors) |
741 (if (pair? errors) | 767 (if (pair? errors) |
742 (ly:error "Children ~a exited with errors." | 768 (ly:error "Children ~a exited with errors." |
743 (map car errors))) | 769 (map car errors))) |
744 ;; must overwrite individual entries | 770 ;; must overwrite individual entries |
745 (if (ly:get-option 'dump-profile) | 771 (if (ly:get-option 'dump-profile) |
746 (dump-profile "lily-run-total" | 772 (dump-profile "lily-run-total" |
747 '(0 0) (profile-measurements))) | 773 '(0 0) (profile-measurements))) |
748 (if (null? errors) | 774 (if (null? errors) |
749 (ly:exit 0 #f) | 775 (ly:exit 0 #f) |
750 (ly:exit 1 #f)))))) | 776 (ly:exit 1 #f)))))) |
751 | 777 |
752 (if (string-or-symbol? (ly:get-option 'log-file)) | 778 (if (string-or-symbol? (ly:get-option 'log-file)) |
753 (ly:stderr-redirect (format "~a.log" (ly:get-option 'log-file)) "w")) | 779 (ly:stderr-redirect (format "~a.log" (ly:get-option 'log-file)) "w")) |
754 (let ((failed (lilypond-all files))) | 780 (let ((failed (lilypond-all files))) |
755 (if (ly:get-option 'trace-scheme-coverage) | 781 (if (ly:get-option 'trace-scheme-coverage) |
756 (begin | 782 (begin |
757 (coverage:show-all (lambda (f) | 783 (coverage:show-all (lambda (f) |
758 (string-contains f "lilypond"))))) | 784 (string-contains f "lilypond"))))) |
759 (if (pair? failed) | 785 (if (pair? failed) |
760 (begin (ly:error (_ "failed files: ~S") (string-join failed)) | 786 (begin (ly:error (_ "failed files: ~S") (string-join failed)) |
761 (ly:exit 1 #f)) | 787 » (ly:exit 1 #f)) |
762 (begin | 788 (begin |
763 (ly:exit 0 #f))))) | 789 (ly:exit 0 #f))))) |
764 | 790 |
765 | 791 |
766 (define-public (lilypond-all files) | 792 (define-public (lilypond-all files) |
767 (let* ((failed '()) | 793 (let* ((failed '()) |
768 (separate-logs (ly:get-option 'separate-log-files)) | 794 (separate-logs (ly:get-option 'separate-log-files)) |
769 (ping-log | 795 (ping-log |
770 » (if separate-logs | 796 » (if separate-logs |
771 » (open-file (if (string-or-symbol? (ly:get-option 'log-file)) | 797 » (open-file (if (string-or-symbol? (ly:get-option 'log-file)) |
772 » » » (format "~a.log" (ly:get-option 'log-file)) | 798 » » » (format "~a.log" (ly:get-option 'log-file)) |
773 » » » "/dev/tty") "a") #f)) | 799 » » » "/dev/tty") "a") #f)) |
774 (do-measurements (ly:get-option 'dump-profile)) | 800 (do-measurements (ly:get-option 'dump-profile)) |
775 (handler (lambda (key failed-file) | 801 (handler (lambda (key failed-file) |
776 (set! failed (append (list failed-file) failed))))) | 802 (set! failed (append (list failed-file) failed))))) |
777 (gc) | 803 (gc) |
778 (for-each | 804 (for-each |
779 (lambda (x) | 805 (lambda (x) |
780 (let* ((start-measurements (if do-measurements | 806 (let* ((start-measurements (if do-measurements |
781 (profile-measurements) | 807 (profile-measurements) |
782 #f)) | 808 #f)) |
783 (base (dir-basename x ".ly")) | 809 (base (dir-basename x ".ly")) |
784 (all-settings (ly:all-options))) | 810 (all-settings (ly:all-options))) |
785 (if separate-logs | 811 (if separate-logs |
786 » (ly:stderr-redirect (format "~a.log" base) "w")) | 812 » (ly:stderr-redirect (format "~a.log" base) "w")) |
787 (if ping-log | 813 (if ping-log |
788 » (format ping-log "Processing ~a\n" base)) | 814 » (format ping-log "Processing ~a\n" base)) |
789 (if (ly:get-option 'trace-memory-frequency) | 815 (if (ly:get-option 'trace-memory-frequency) |
790 (mtrace:start-trace (ly:get-option 'trace-memory-frequency))) | 816 (mtrace:start-trace (ly:get-option 'trace-memory-frequency))) |
791 » (lilypond-file handler x) | 817 » (lilypond-file handler x) |
792 » (if start-measurements | 818 » (if start-measurements |
793 » (dump-profile x start-measurements (profile-measurements))) | 819 » (dump-profile x start-measurements (profile-measurements))) |
794 » (if (ly:get-option 'trace-memory-frequency) | 820 » (if (ly:get-option 'trace-memory-frequency) |
795 » (begin (mtrace:stop-trace) | 821 » (begin (mtrace:stop-trace) |
796 » » (mtrace:dump-results base))) | 822 » » (mtrace:dump-results base))) |
797 » (for-each (lambda (s) | 823 » (for-each (lambda (s) |
798 » » (ly:set-option (car s) (cdr s))) | 824 » » (ly:set-option (car s) (cdr s))) |
799 » » all-settings) | 825 » » all-settings) |
800 » (ly:set-option 'debug-gc-assert-parsed-dead #t) | 826 » (ly:set-option 'debug-gc-assert-parsed-dead #t) |
801 » (gc) | 827 » (gc) |
802 » (ly:set-option 'debug-gc-assert-parsed-dead #f) | 828 » (ly:set-option 'debug-gc-assert-parsed-dead #f) |
803 » (if (ly:get-option 'debug-gc) | 829 » (if (ly:get-option 'debug-gc) |
804 » (dump-gc-protects) | 830 » (dump-gc-protects) |
805 (ly:reset-all-fonts)))) | 831 (ly:reset-all-fonts)))) |
806 files) | 832 files) |
807 | 833 |
808 ;; we want the failed-files notice in the aggregrate logfile. | 834 ;; we want the failed-files noticed in the aggregrate logfile. |
809 (if ping-log | 835 (if ping-log |
810 (format ping-log "Failed files: ~a\n" failed)) | 836 (format ping-log "Failed files: ~a\n" failed)) |
811 (if (ly:get-option 'dump-profile) | 837 (if (ly:get-option 'dump-profile) |
812 (dump-profile "lily-run-total" '(0 0) (profile-measurements))) | 838 (dump-profile "lily-run-total" '(0 0) (profile-measurements))) |
813 failed)) | 839 failed)) |
814 | 840 |
815 (define (lilypond-file handler file-name) | 841 (define (lilypond-file handler file-name) |
816 (catch 'ly-file-failed | 842 (catch 'ly-file-failed |
817 (lambda () (ly:parse-file file-name)) | 843 (lambda () (ly:parse-file file-name)) |
818 (lambda (x . args) (handler x file-name)))) | 844 (lambda (x . args) (handler x file-name)))) |
(...skipping 22 matching lines...) Expand all Loading... |
841 (ly:exit 0 #f))))) | 867 (ly:exit 0 #f))))) |
842 | 868 |
843 (define (gui-no-files-handler) | 869 (define (gui-no-files-handler) |
844 (let* ((ly (string-append (ly:effective-prefix) "/ly/")) | 870 (let* ((ly (string-append (ly:effective-prefix) "/ly/")) |
845 ;; FIXME: soft-code, localize | 871 ;; FIXME: soft-code, localize |
846 (welcome-ly (string-append ly "Welcome_to_LilyPond.ly")) | 872 (welcome-ly (string-append ly "Welcome_to_LilyPond.ly")) |
847 (cmd (get-editor-command welcome-ly 0 0 0))) | 873 (cmd (get-editor-command welcome-ly 0 0 0))) |
848 (ly:message (_ "Invoking `~a'...\n") cmd) | 874 (ly:message (_ "Invoking `~a'...\n") cmd) |
849 (system cmd) | 875 (system cmd) |
850 (ly:exit 1 #f))) | 876 (ly:exit 1 #f))) |
OLD | NEW |