]> git.donarmstrong.com Git - lilypond.git/blob - scm/lily.scm
d4e05a4af1a9b1c20c08a32428b1e7baa3eaef2b
[lilypond.git] / scm / lily.scm
1 ;;;; lily.scm -- toplevel Scheme stuff
2 ;;;;
3 ;;;;  source file of the GNU LilyPond music typesetter
4 ;;;; 
5 ;;;; (c) 1998--2006 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 explicitely to do the actual
10 ;; "translation".
11 ;;(define-macro (_i x) x)
12 ;;(define-macro-public _i (x) x)
13 ;;(define-public-macro _i (x) x)
14 ;; Abbrv-PWR!
15 (defmacro-public _i (x) x)
16
17 (define (define-scheme-options)
18   (for-each (lambda (x)
19               (ly:add-option (car x) (cadr x) (caddr x)))
20           
21             `(
22
23               ;; NAMING: either
24
25               ;; - [subject-]object-object-verb +"ing"
26               ;; - [subject-]-verb-object-object
27
28               (anti-alias-factor 1 "render at higher resolution and scale down result\nto prevent jaggies in PNG")
29               (check-internal-types #f "check every property assignment for types")
30               (clip-systems #f "Generate cut-out snippets of a score")
31               (debug-gc #f "dump memory debugging statistics")
32               (debug-gc-assert-parsed-dead #f "for memory debugging:
33 ensure that all refs to parsed objects are dead.  This is an internal option, and is switched on automatically for -ddebug-gc.") 
34               (debug-lexer #f "debug the flex lexer")
35               (debug-midi #f "generate human readable MIDI")
36               (debug-parser #f "debug the bison parser")
37               (debug-skylines #f "debug skylines")
38               (delete-intermediate-files #f
39                                          "delete unusable PostScript files")
40               (dump-profile #f "dump timing information for each file")
41               (dump-signatures #f "dump output signatures of each system.  Used for regression testing.")
42               
43               (eps-box-padding #f "Pad EPS bounding box left edge.  Guarantee alignment between systems in LaTeX.")
44               (gs-load-fonts #f
45                             "load fonts via Ghostscript.")
46               (gui #f "running from gui; redirect stderr to log file")
47
48               (include-book-title-preview #t "include book-titles in preview images.")
49               (include-eps-fonts #t "Include fonts in separate-system EPS files.")
50               (job-count #f "Process in parallel") 
51               (log-file #f "redirect output to log FILE.log")
52
53               (old-relative #f
54                             "relative for simultaneous music works
55 similar to chord syntax")
56               (point-and-click #t "use point & click")
57               (paper-size "a4" "the default paper size")
58               (pixmap-format "png16m" "GS format to use for pixel images")
59               (protected-scheme-parsing #t "continue when finding errors in inline
60 scheme are caught in the parser. If off, halt 
61 on errors, and print a stack trace.")
62               (profile-property-accesses #f "keep statistics of get_property() calls.")
63               
64               (resolution 101 "resolution for generating PNG bitmaps")
65               (read-file-list #f "Read files to be processed from command line arguments")
66
67               (safe #f "Run safely")
68               (strict-infinity-checking #f "If yes, crash on encountering Inf/NaN.")
69               (separate-log-files #f "Output to FILE.log per file.")
70               (ttf-verbosity 0
71                              "how much verbosity for TTF font embedding?")
72               (show-available-fonts #f
73                                     "List font names available.")
74               (verbose ,(ly:command-line-verbose?) "value for the --verbose flag")
75               )))
76
77
78 ;; need to do this in the beginning. Other parts of the
79 ;; Scheme init depend on these options.
80 ;;
81 (define-scheme-options)
82
83 (debug-set! stack 0)
84
85 (if (defined? 'set-debug-cell-accesses!)
86     (set-debug-cell-accesses! #f))
87
88                                         ;(set-debug-cell-accesses! 1000)
89
90 (use-modules (ice-9 regex)
91              (ice-9 safe)
92              (ice-9 optargs)
93              (oop goops)
94              (srfi srfi-1)
95              (srfi srfi-13)
96              (srfi srfi-14)
97              (scm clip-region)
98              )
99
100 ;; my display
101 (define-public (myd k v) (display k) (display ": ") (display v) (display ", ")
102   v)
103
104 (define-public (print . args)
105   (apply format (cons (current-output-port) args)))
106
107
108 ;;; General settings
109 ;;; debugging evaluator is slower.  This should
110 ;;; have a more sensible default.
111
112 (if (ly:get-option 'verbose)
113     (begin
114       (ly:set-option 'protected-scheme-parsing #f)
115       (debug-enable 'debug)
116       (debug-enable 'backtrace)
117       (read-enable 'positions)))
118
119 (define-public tex-backend?
120   (member (ly:output-backend) '("texstr" "tex")))
121
122 (define-public parser #f)
123
124 (define-public (lilypond-version)
125   (string-join
126    (map (lambda (x) (if (symbol? x)
127                         (symbol->string x)
128                         (number->string x)))
129         (ly:version))
130    "."))
131
132
133 ;; TeX C++ code actually hooks into TEX_STRING_HASHLIMIT 
134 (define-public TEX_STRING_HASHLIMIT 10000000)
135
136
137
138 ;; gettext wrapper for guile < 1.7.2
139 (if (defined? 'gettext)
140     (define-public _ gettext)
141     (define-public _ ly:gettext))
142
143 (define-public (ly:load x)
144   (let* ((file-name (%search-load-path x)))
145     (if (ly:get-option 'verbose)
146         (ly:progress "[~A" file-name))
147     (if (not file-name)
148         (ly:error (_ "cannot find: ~A") x))
149     (primitive-load file-name)
150     (if (ly:get-option 'verbose)
151         (ly:progress "]"))))
152
153 ;; Cygwin
154 ;; #(CYGWIN_NT-5.1 Hostname 1.5.12(0.116/4/2) 2004-11-10 08:34 i686)
155 ;;
156 ;; Debian
157 ;; #(Linux hostname 2.4.27-1-686 #1 Fri Sep 3 06:28:00 UTC 2004 i686)
158 ;;
159 ;; Mingw
160 ;; #(Windows XP HOSTNAME build 2600 5.01 Service Pack 1 i686)
161 ;;
162
163 ;; ugh, code dup.
164 (define-public PLATFORM
165   (string->symbol
166    (string-downcase
167     (car (string-tokenize (vector-ref (uname) 0) char-set:letter)))))
168
169 (define-public DOS
170   (let ((platform (string-tokenize
171                    (vector-ref (uname) 0) char-set:letter+digit)))
172     (if (null? (cdr platform)) #f
173         (member (string-downcase (cadr platform)) '("95" "98" "me")))))
174
175 (case PLATFORM
176   ((windows)
177    (define native-getcwd getcwd)
178    (define (slashify x)
179      (if (string-index x #\\)
180          x
181          (string-regexp-substitute
182           "//*" "/"
183           (string-regexp-substitute "\\\\" "/" x))))
184    ;; FIXME: this prints a warning.
185    (define-public (ly-getcwd)
186      (slashify (native-getcwd))))
187   (else (define-public ly-getcwd getcwd)))
188
189 (define-public (is-absolute? file-name)
190   (let ((file-name-length (string-length file-name)))
191     (if (= file-name-length 0)
192         #f
193         (or (eq? (string-ref file-name 0) #\/)
194             (and (eq? PLATFORM 'windows)
195                  (> file-name-length 2)
196                  (eq? (string-ref file-name 1) #\:)
197                  (eq? (string-ref file-name 2) #\/))))))
198
199 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
200
201 (define (type-check-list location signature arguments)
202   "Typecheck a list of arguments against a list of type
203 predicates. Print a message at LOCATION if any predicate failed."
204
205   (define (recursion-helper signature arguments count) 
206     (define (helper pred? arg count) 
207       (if (not (pred? arg))
208
209           (begin
210             (ly:input-message
211              location
212              (format
213               #f (_ "wrong type for argument ~a.  Expecting ~a, found ~s")
214               count (type-name pred?) arg))
215             #f)
216           #t))
217
218     (if (null? signature)
219         #t
220         (and (helper (car signature) (car arguments) count)
221              (recursion-helper (cdr signature) (cdr arguments) (1+ count)))))
222
223   (recursion-helper signature arguments 1))
224
225 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
226 ;;  output
227
228
229 ;;(define-public (output-framework) (write "hello\n"))
230
231 (define output-tex-module
232   (make-module 1021 (list (resolve-interface '(scm output-tex)))))
233 (define output-ps-module
234   (make-module 1021 (list (resolve-interface '(scm output-ps)))))
235
236 (define-public (ps-output-expression expr port)
237   (display (eval expr output-ps-module) port))
238
239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
240 ;; Safe definitions utility
241 (define safe-objects (list))
242
243 (define-macro (define-safe-public arglist . body)
244   "Define a variable, export it, and mark it as safe, ie usable in LilyPond safe mode.
245 The syntax is the same as `define*-public'."
246   (define (get-symbol arg)
247     (if (pair? arg)
248         (get-symbol (car arg))
249         arg))
250   (let ((safe-symbol (get-symbol arglist)))
251     `(begin
252        (define*-public ,arglist
253          ,@body)
254        (set! safe-objects (cons (cons ',safe-symbol ,safe-symbol)
255                                 safe-objects))
256        ,safe-symbol)))
257
258 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
259 ;; init pitch system
260
261 (ly:set-default-scale (ly:make-scale #(0 1 2 5/2 7/2 9/2 11/2)))
262
263
264
265 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
266 ;; other files.
267
268 (for-each ly:load
269           ;; load-from-path
270           '("lily-library.scm"
271             "file-cache.scm"
272             "define-event-classes.scm"
273             "define-music-types.scm"
274             "output-lib.scm"
275             "c++.scm"
276             "chord-ignatzek-names.scm"
277             "chord-entry.scm"
278             "chord-generic-names.scm"
279             "stencil.scm"
280             "markup.scm"
281             "music-functions.scm"
282             "part-combiner.scm"
283             "autochange.scm"
284             "define-music-properties.scm"
285             "auto-beam.scm"
286             "chord-name.scm"
287
288             "parser-ly-from-scheme.scm"
289             "ly-syntax-constructors.scm"
290             
291             "define-context-properties.scm"
292             "translation-functions.scm"
293             "script.scm"
294             "midi.scm"
295             "layout-beam.scm"
296             "parser-clef.scm"
297             "layout-slur.scm"
298             "font.scm"
299             "encoding.scm"
300             
301             "fret-diagrams.scm"
302             "define-markup-commands.scm"
303             "define-grob-properties.scm"
304             "define-grobs.scm"
305             "define-grob-interfaces.scm"
306             "define-stencil-commands.scm"
307             "titling.scm"
308             
309             "paper.scm"
310             "backend-library.scm"
311             "x11-color.scm"
312
313             ;; must be after everything has been defined
314             "safe-lily.scm"))
315
316
317 (set! type-p-name-alist
318       `(
319         (,boolean-or-symbol? . "boolean or symbol")
320         (,boolean? . "boolean")
321         (,char? . "char")
322         (,grob-list? . "list of grobs")
323         (,hash-table? . "hash table")
324         (,input-port? . "input port")
325         (,integer? . "integer")
326         (,list? . "list")
327         (,ly:context? . "context")
328         (,ly:dimension? . "dimension, in staff space")
329         (,ly:dir? . "direction")
330         (,ly:duration? . "duration")
331         (,ly:grob? . "layout object")
332         (,ly:input-location? . "input location")
333         (,ly:moment? . "moment")
334         (,ly:music? . "music")
335         (,ly:pitch? . "pitch")
336         (,ly:translator? . "translator")
337         (,ly:font-metric? . "font metric")
338         (,ly:simple-closure? . "simple closure")
339         (,markup-list? . "list of markups")
340         (,markup? . "markup")
341         (,ly:music-list? . "list of music")
342         (,number-or-grob? . "number or grob")
343         (,number-or-string? . "number or string")
344         (,number-pair? . "pair of numbers")
345         (,number? . "number")
346         (,output-port? . "output port")   
347         (,pair? . "pair")
348         (,procedure? . "procedure")
349         (,rhythmic-location? . "rhythmic location")
350         (,scheme? . "any type")
351         (,string? . "string")
352         (,symbol? . "symbol")
353         (,vector? . "vector")))
354
355 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
356 ;; timing
357
358 (define (profile-measurements)
359   (let* ((t (times))
360          (stats (gc-stats)))
361     
362     (list
363      (- (+ (tms:cutime t)
364            (tms:utime t))
365         (ly:assoc-get 'gc-time-taken stats))
366      
367      (ly:assoc-get 'total-cells-allocated  stats 0)
368      )))
369
370 (define (dump-profile base last this)
371   (let*
372       ((outname (format "~a.profile" (basename base ".ly")))
373        (diff (map (lambda (y) (apply - y)) (zip this last))))
374     
375     (ly:progress "\nWriting timing to ~a..." outname)
376     (format (open-file outname "w")
377             "time: ~a\ncells: ~a\n"
378             (car diff)
379             (cadr diff)
380             )))
381
382
383 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
384 ;; debug mem leaks
385
386 (define gc-dumping #f)
387 (define gc-protect-stat-count 0)
388 (define-public (dump-gc-protects)
389   (set! gc-protect-stat-count (1+ gc-protect-stat-count))
390   (let* ((protects (sort
391                     (hash-table->alist (ly:protects))
392                     (lambda (a b)
393                       (< (object-address (car a))
394                          (object-address (car b))))))
395
396          (out-file-name (string-append
397                          "gcstat-" (number->string gc-protect-stat-count)
398                          ".scm"))
399          (outfile    (open-file  out-file-name  "w")))
400
401     (set! gc-dumping #t)
402     (display (format "Dumping GC statistics ~a...\n" out-file-name))
403     (display
404      (map (lambda (y)
405             (let ((x (car y))
406                   (c (cdr y)))
407               (display 
408                (format "~a (~a) = ~a\n" (object-address x) c x)
409                outfile)))
410           (filter
411            (lambda (x)
412              (not (symbol? (car x))))
413            protects))
414      outfile)
415
416     (format outfile "\nprotected symbols: ~a\n"
417             (length (filter symbol?  (map car protects))))
418     
419              
420
421     ;; (display (ly:smob-protects))
422     (newline outfile)
423     (if (defined? 'gc-live-object-stats)
424         (let* ((stats #f))
425           (display "Live object statistics: GC'ing\n")
426           (ly:reset-all-fonts)
427           (gc)
428           (gc)
429           (display "Asserting dead objects\n")
430           (ly:set-option 'debug-gc-assert-parsed-dead #t)
431           (gc)
432           (ly:set-option 'debug-gc-assert-parsed-dead #f)
433
434           (set! stats (gc-live-object-stats))
435           (display "Dumping live object statistics.\n")
436           
437           (for-each
438            (lambda (x)
439              (format outfile "~a: ~a\n" (car x) (cdr x)))
440            (sort (gc-live-object-stats)
441                  (lambda (x y)
442                    (string<? (car x) (car y)))))))
443
444
445     (newline outfile)
446     (let*
447         ((stats (gc-stats)))
448       
449       (for-each
450        (lambda (sym)
451          (display
452           (format "~a ~a ~a\n"
453                   gc-protect-stat-count
454                   sym
455                   (let ((sym-stat (assoc sym stats)))
456                     (if sym-stat 
457                         (cdr sym-stat)
458                         "?")))
459           outfile))
460        '(protected-objects bytes-malloced cell-heap-size
461                            
462                            )))
463
464     (set! gc-dumping #f)
465     
466     ))
467
468 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
469
470
471 (define (multi-fork count)
472   (define (helper count acc)
473     (if (> count 0)
474       (let*
475           ((pid  (primitive-fork)))
476         (if (= pid 0)
477             (1- count)
478             (helper (1- count) (cons pid acc))))
479       acc))
480   (helper count '()))
481
482
483 (define-public (lilypond-main files)
484   "Entry point for LilyPond."
485   
486   (define (no-files-handler)
487     (ly:usage)
488     (exit 2))
489
490   (if (ly:get-option 'gui)
491       (gui-main files))
492
493   (if (null? files)
494       (no-files-handler))
495
496   (if (ly:get-option 'read-file-list)
497       (set! files
498             (filter (lambda (s)
499                       (> (string-length s) 0))
500                     (apply append
501                            (map (lambda (f) (string-split (ly:gulp-file f) #\nl))
502                                 files)))
503             ))
504   
505   (if (and (number? (ly:get-option 'job-count))
506            (>= (length files) (ly:get-option 'job-count)))
507       
508       (let*
509           ((count (ly:get-option 'job-count))
510            (split-todo (split-list files count)) 
511            (joblist (multi-fork count))
512            (errors '()))
513
514         (if (not (string-or-symbol? (ly:get-option 'log-file)))
515             (ly:set-option 'log-file "lilypond-multi-run"))
516         
517         (if (number? joblist)
518             (begin
519               (ly:set-option 'log-file (format "~a-~a"
520                                                (ly:get-option 'log-file) joblist))
521               (set! files (vector-ref split-todo joblist)))
522
523             (begin
524               (ly:progress "\nForking into jobs:  ~a\n" joblist)
525               (for-each
526                (lambda (pid)
527                  (let* ((stat (cdr (waitpid pid))))
528                    
529                    (if (not (= stat 0))
530                        (set! errors (acons (list-element-index joblist pid) stat errors)))))
531                joblist)
532
533               (for-each
534                (lambda (x)
535                  (let* ((job (car x))
536                         (state (cdr x))
537                         (logfile  (format "~a-~a.log"
538                                           (ly:get-option 'log-file) job))
539                         (log (ly:gulp-file logfile))
540                         (len (string-length log))
541                         (tail (substring  log (max 0 (- len 1024)))))
542
543                    (if (status:term-sig state)
544                        (ly:message "\n\n~a\n"
545                                    (format (_ "job ~a terminated with signal: ~a")
546                                            job
547                                            (status:term-sig state)))
548                        (ly:message (_ "logfile ~a (exit ~a):\n~a") logfile (status:exit-val state) tail))))
549
550                errors)
551
552               (if (pair? errors)
553                   (ly:error "Children ~a exited with errors." (map car errors)))
554
555               ;; must overwrite individual entries
556               (if (ly:get-option 'dump-profile)
557                   (dump-profile "lily-run-total" '(0 0) (profile-measurements)))
558
559             (exit (if (null? errors) 0 1))))))
560               
561            
562   (if (string-or-symbol? (ly:get-option 'log-file))
563       (ly:stderr-redirect (format "~a.log" (ly:get-option 'log-file)) "w"))
564   
565   (let ((failed (lilypond-all files)))
566     (if (pair? failed)
567         (begin
568           (ly:error (_ "failed files: ~S") (string-join failed))
569           (exit 1))
570         (begin
571           ;; HACK: be sure to exit with single newline
572           (ly:message "")
573           (exit 0)))))
574
575 (define-public (lilypond-all files)
576
577
578   (if (ly:get-option 'show-available-fonts)
579       (begin
580         (ly:font-config-display-fonts)
581         (exit 0)
582         ))
583   
584   (let* ((failed '())
585          (separate-logs (ly:get-option 'separate-log-files))
586          (do-measurements (ly:get-option 'dump-profile))
587          (handler (lambda (key failed-file)
588                     (set! failed (append (list failed-file) failed)))))
589
590     (gc)
591     (for-each
592      (lambda (x)
593        (let*
594            ((start-measurements (if do-measurements
595                                     (profile-measurements)
596                                     #f))
597             (base (basename x ".ly"))
598             (all-settings (ly:all-options)))
599
600          (if separate-logs
601              (ly:stderr-redirect (format "~a.log" base) "w"))
602        
603          (lilypond-file handler x)
604          (if start-measurements
605              (dump-profile x start-measurements (profile-measurements)))
606        
607          (for-each
608           (lambda (s)
609             (ly:set-option (car s) (cdr s)))
610           all-settings)
611          
612          (ly:clear-anonymous-modules)
613          (ly:set-option 'debug-gc-assert-parsed-dead #t)
614          (gc)
615          (ly:set-option 'debug-gc-assert-parsed-dead #f)
616          
617          
618          (if (ly:get-option 'debug-gc)
619              (dump-gc-protects)
620              (if (= (random 40) 1)
621                  (ly:reset-all-fonts)))))
622
623      files)
624
625     ;; we want the failed-files notice in the aggregrate logfile.
626     (if (ly:get-option 'separate-logs)
627         (ly:stderr-redirect
628          (if (string-or-symbol? (ly:get-option 'log-file))
629              (format "~a.log" (ly:get-option 'log-file))
630              "/dev/tty") "a"))
631
632     (if (ly:get-option 'dump-profile)
633         (dump-profile "lily-run-total" '(0 0) (profile-measurements)))
634     
635     failed))
636
637 (define (lilypond-file handler file-name)
638   (catch 'ly-file-failed
639          (lambda () (ly:parse-file file-name))
640          (lambda (x . args) (handler x file-name))))
641
642 (use-modules (scm editor))
643
644 (define-public (gui-main files)
645   (if (null? files)
646       (gui-no-files-handler))
647
648   (if (not (string? (ly:get-option 'log-file)))
649       (let* ((base (basename (car files) ".ly"))
650              (log-name (string-append base ".log")))
651         (if (not (ly:get-option 'gui))
652             (ly:message (_ "Redirecting output to ~a...") log-name))
653         (ly:stderr-redirect log-name "w")
654         (ly:message "# -*-compilation-*-"))
655     
656     (let ((failed (lilypond-all files)))
657       (if (pair? failed)
658           (begin
659             ;; ugh
660             (ly:stderr-redirect "foo" "r")
661             (system (get-editor-command log-name 0 0 0))
662             (ly:error (_ "failed files: ~S") (string-join failed))
663             ;; not reached?
664             (exit 1))
665           (exit 0)))))
666
667 (define (gui-no-files-handler)
668   (let* ((ly (string-append (ly:effective-prefix) "/ly/"))
669          ;; FIXME: soft-code, localize
670          (welcome-ly (string-append ly "Welcome_to_LilyPond.ly"))
671          (cmd (get-editor-command welcome-ly 0 0 0)))
672     (ly:message (_ "Invoking `~a'...") cmd)
673     (system cmd)
674     (exit 1)))