1
;;;; lily.scm -- implement Scheme output routines for TeX and PostScript
1
;;;; lily.scm -- toplevel Scheme stuff
3
3
;;;; source file of the GNU LilyPond music typesetter
5
;;;; (c) 1998--2004 Jan Nieuwenhuizen <janneke@gnu.org>
5
;;;; (c) 1998--2006 Jan Nieuwenhuizen <janneke@gnu.org>
6
6
;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
9
(define (define-scheme-options)
11
(ly:add-option (car x) (cadr x) (caddr x)))
13
`((point-and-click #t "use point & click")
14
(paper-size "a4" "the default paper size")
15
(midi-debug #f "generate human readable MIDI")
16
(dump-signatures #f "dump output signatures of each system (EPS backend)")
17
(internal-type-checking #f "check every property assignment for types")
18
(parse-protect #t "continue when finding errors in inline
19
scheme are caught in the parser. If off, halt
20
on errors, and print a stack trace.")
21
(profile-property-accesses #f "keep statistics of get_property() calls.")
23
"relative for simultaneous music works
24
similar to chord syntax")
26
"experimental mechanism for remembering tweaks")
27
(resolution 101 "resolution for generating bitmaps")
28
(anti-alias-factor 1 "render at higher resolution and scale down result\nto prevent jaggies in PNG")
29
(book-title-preview #t "include book-titles in preview images.")
30
(eps-font-include #f "Include fonts in separate-system EPS files.")
32
"load fonts via Ghostscript.")
33
(gui #f "running from gui; redirect stderr to log file")
34
(delete-intermediate-files #f
35
"delete unusable PostScript files")
36
(safe #f "Run safely")
37
(verbose ,(ly:command-line-verbose?) "value for the --verbose flag")
38
(strict-infinity-checking #f "If yes, crash on encountering Inf/NaN")
40
"how much verbosity for TTF font embedding?")
42
"dump GC protection info")
43
(show-available-fonts #f
44
"List font names available.")
48
;; need to do this in the beginning. Other parts of the
49
;; Scheme init depend on these options.
51
(define-scheme-options)
10
53
(if (defined? 'set-debug-cell-accesses!)
11
54
(set-debug-cell-accesses! #f))
56
;(set-debug-cell-accesses! 1000)
13
58
(use-modules (ice-9 regex)
17
(srfi srfi-13)) ; strings
19
(define-public safe-module (make-safe-module))
21
68
(define-public (myd k v) (display k) (display ": ") (display v) (display ", "))
70
(define-public (print . args)
71
(apply format (cons (current-output-port) args)))
23
74
;;; General settings
24
75
;;; debugging evaluator is slower. This should
25
76
;;; have a more sensible default.
28
78
(if (ly:get-option 'verbose)
30
80
(debug-enable 'debug)
31
81
(debug-enable 'backtrace)
32
(read-enable 'positions) ))
35
(define-public (line-column-location line col file)
36
"Print an input location, including column number ."
37
(string-append (number->string line) ":"
38
(number->string col) " " file)
41
(define-public (line-location line col file)
42
"Print an input location, without column number ."
43
(string-append (number->string line) " " file)
46
(define-public point-and-click #f)
82
(read-enable 'positions)))
84
(define-public tex-backend?
85
(member (ly:output-backend) '("texstr" "tex")))
87
(define-public parser #f)
48
89
(define-public (lilypond-version)
50
91
(map (lambda (x) (if (symbol? x)
52
93
(number->string x)))
58
;; cpp hack to get useful error message
59
(define ifdef "First run this through cpp.")
60
(define ifndef "First run this through cpp.")
64
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
68
(define-public START -1)
69
(define-public STOP 1)
70
(define-public LEFT -1)
71
(define-public RIGHT 1)
73
(define-public DOWN -1)
74
(define-public CENTER 0)
76
(define-public DOUBLE-FLAT -4)
77
(define-public THREE-Q-FLAT -3)
78
(define-public FLAT -2)
79
(define-public SEMI-FLAT -1)
80
(define-public NATURAL 0)
81
(define-public SEMI-SHARP 1)
82
(define-public SHARP 2)
83
(define-public THREE-Q-SHARP 3)
84
(define-public DOUBLE-SHARP 4)
85
(define-public SEMI-TONE 2)
87
(define-public ZERO-MOMENT (ly:make-moment 0 1))
89
(define-public (moment-min a b)
90
(if (ly:moment<? a b) a b))
92
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
93
;; lily specific variables.
94
(define-public default-script-alist '())
96
(define-public safe-mode? #f)
98
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
99
;;; Unassorted utility functions.
104
(define (uniqued-alist alist acc)
105
(if (null? alist) acc
106
(if (assoc (caar alist) acc)
107
(uniqued-alist (cdr alist) acc)
108
(uniqued-alist (cdr alist) (cons (car alist) acc)))))
111
(define-public (assoc-get key alist . default)
112
"Return value if KEY in ALIST, else DEFAULT (or #f if not specified)."
113
(let ((entry (assoc key alist)))
116
(if (pair? default) (car default) #f)
119
(define-public (uniqued-alist alist acc)
120
(if (null? alist) acc
121
(if (assoc (caar alist) acc)
122
(uniqued-alist (cdr alist) acc)
123
(uniqued-alist (cdr alist) (cons (car alist) acc)))))
125
(define-public (alist<? x y)
126
(string<? (symbol->string (car x))
127
(symbol->string (car y))))
129
(define-public (chain-assoc x alist-list)
130
(if (null? alist-list)
132
(let* ((handle (assoc x (car alist-list))))
135
(chain-assoc x (cdr alist-list))))))
137
(define-public (chain-assoc-get x alist-list . default)
138
"Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
141
(define (helper x alist-list default)
142
(if (null? alist-list)
144
(let* ((handle (assoc x (car alist-list))))
147
(helper x (cdr alist-list) default)))))
150
(if (pair? default) (car default) #f)))
152
(define (map-alist-vals func list)
153
"map FUNC over the vals of LIST, leaving the keys."
156
(cons (cons (caar list) (func (cdar list)))
157
(map-alist-vals func (cdr list)))
160
(define (map-alist-keys func list)
161
"map FUNC over the keys of an alist LIST, leaving the vals. "
164
(cons (cons (func (caar list)) (cdar list))
165
(map-alist-keys func (cdr list)))
173
(if (not (defined? 'hash-table?)) ; guile 1.6 compat
175
(define hash-table? vector?)
177
(define-public (hash-table->alist t)
178
"Convert table t to list"
185
(define-public (hash-table->alist t)
187
(hash-fold (lambda (k v acc) (acons k v acc))
192
;; todo: code dup with C++.
193
(define-public (alist->hash-table l)
194
"Convert alist to table"
196
((m (make-hash-table (length l))))
199
(hashq-set! m (car k-v) (cdr k-v)))
209
(define (flatten-list lst)
213
(if (pair? (car lst))
214
(append (flatten-list (car lst)) (flatten-list (cdr lst)))
215
(cons (car lst) (flatten-list (cdr lst))))
218
(define (list-minus a b)
219
"Return list of elements in A that are not in B."
220
(lset-difference eq? a b))
223
;; TODO: use the srfi-1 partition function.
224
(define-public (uniq-list l)
226
"Uniq LIST, assuming that it is sorted"
227
(define (helper acc l)
232
(if (equal? (car l) (cadr l))
234
(helper (cons (car l) acc) (cdr l)))
236
(reverse! (helper '() l) '()))
239
(define (split-at-predicate predicate l)
240
"Split L = (a_1 a_2 ... a_k b_1 ... b_k)
241
into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k)
242
Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
243
L1 is copied, L2 not.
245
(split-at-predicate (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))"
250
(define (inner-split predicate l acc)
254
(set-car! acc (cons (car l) (car acc)))
256
((predicate (car l) (cadr l))
257
(set-car! acc (cons (car l) (car acc)))
258
(inner-split predicate (cdr l) acc))
260
(set-car! acc (cons (car l) (car acc)))
261
(set-cdr! acc (cdr l))
268
(inner-split predicate l c)
269
(set-car! c (reverse! (car c)))
274
(define-public (split-list l sep?)
276
(display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))) )
278
((a b c) (d e f) (g))
283
(define (split-one sep? l acc)
284
"Split off the first parts before separator and return both parts."
289
(split-one sep? (cdr l) (cons (car l) acc))
295
(let* ((c (split-one sep? l '())))
296
(cons (reverse! (car c) '()) (split-list (cdr c) sep?))
300
(define-public (interval-length x)
301
"Length of the number-pair X, when an interval"
302
(max 0 (- (cdr x) (car x)))
306
(define (other-axis a)
307
(remainder (+ a 1) 2))
310
(define-public (interval-widen iv amount)
311
(cons (- (car iv) amount)
312
(+ (cdr iv) amount)))
314
(define-public (interval-union i1 i2)
315
(cons (min (car i1) (car i2))
316
(max (cdr i1) (cdr i2))))
319
(define-public (write-me message x)
320
"Return X. Display MESSAGE and write X. Handy for debugging, possibly turned off."
321
(display message) (write x) (newline) x)
324
(define (index-cell cell dir)
329
(define (cons-map f x)
330
"map F to contents of X"
331
(cons (f (car x)) (f (cdr x))))
334
(define-public (list-insert-separator lst between)
335
"Create new list, inserting BETWEEN between elements of LIST"
339
(cons x (cons between y))
341
(fold-right conc #f lst))
350
(define-public (symbol<? l r)
351
(string<? (symbol->string l) (symbol->string r)))
353
(define-public (!= l r)
98
;; TeX C++ code actually hooks into TEX_STRING_HASHLIMIT
99
(define-public TEX_STRING_HASHLIMIT 10000000)
103
;; gettext wrapper for guile < 1.7.2
104
(if (defined? 'gettext)
105
(define-public _ gettext)
106
(define-public _ ly:gettext))
356
108
(define-public (ly:load x)
358
(fn (%search-load-path x))
361
(if (ly:get-option 'verbose)
362
(format (current-error-port) "[~A]" fn))
363
(primitive-load fn)))
109
(let* ((file-name (%search-load-path x)))
110
(if (ly:get-option 'verbose)
111
(ly:progress "[~A" file-name))
113
(ly:error (_ "Can't find ~A" x)))
114
(primitive-load file-name)
115
(if (ly:get-option 'verbose)
119
;; #(CYGWIN_NT-5.1 Hostname 1.5.12(0.116/4/2) 2004-11-10 08:34 i686)
122
;; #(Linux hostname 2.4.27-1-686 #1 Fri Sep 3 06:28:00 UTC 2004 i686)
125
;; #(Windows XP HOSTNAME build 2600 5.01 Service Pack 1 i686)
129
(define-public PLATFORM
132
(car (string-tokenize (vector-ref (uname) 0) char-set:letter)))))
135
(let ((platform (string-tokenize
136
(vector-ref (uname) 0) char-set:letter+digit)))
137
(if (null? (cdr platform)) #f
138
(member (string-downcase (cadr platform)) '("95" "98" "me")))))
142
(define native-getcwd getcwd)
144
(if (string-index x #\\)
146
(string-regexp-substitute
148
(string-regexp-substitute "\\\\" "/" x))))
149
;; FIXME: this prints a warning.
150
(define-public (ly-getcwd)
151
(slashify (native-getcwd))))
152
(else (define-public ly-getcwd getcwd)))
154
(define-public (is-absolute? file-name)
155
(let ((file-name-length (string-length file-name)))
156
(if (= file-name-length 0)
158
(or (eq? (string-ref file-name 0) #\/)
159
(and (eq? PLATFORM 'windows)
160
(> file-name-length 2)
161
(eq? (string-ref file-name 1) #\:)
162
(eq? (string-ref file-name 2) #\/))))))
164
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
166
(define (type-check-list location signature arguments)
167
"Typecheck a list of arguments against a list of type
168
predicates. Print a message at LOCATION if any predicate failed."
169
(define (recursion-helper signature arguments count)
170
(define (helper pred? arg count)
171
(if (not (pred? arg))
177
#f (_ "wrong type for argument ~a. Expecting ~a, found ~s")
178
count (type-name pred?) arg))
182
(if (null? signature)
184
(and (helper (car signature) (car arguments) count)
185
(recursion-helper (cdr signature) (cdr arguments) (1+ count)))))
186
(recursion-helper signature arguments 1))
366
188
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
370
;(scm output-sodipodi)
192
;;(define-public (output-framework) (write "hello\n"))
376
194
(define output-tex-module
377
195
(make-module 1021 (list (resolve-interface '(scm output-tex)))))
378
196
(define output-ps-module
379
197
(make-module 1021 (list (resolve-interface '(scm output-ps)))))
380
(define-public (tex-output-expression expr port)
381
(display (eval expr output-tex-module) port))
382
199
(define-public (ps-output-expression expr port)
383
200
(display (eval expr output-ps-module) port))
387
("tex" . ("TeX output. The default output form." ,tex-output-expression))
388
("scm" . ("Scheme dump: debug scheme stencil expressions" ,write))
389
; ("sketch" . ("Bare bones Sketch output." ,sketch-output-expression))
390
; ("sodipodi" . ("Bare bones Sodipodi output." ,sodipodi-output-expression))
391
; ("pdftex" . ("PDFTeX output. Was last seen nonfunctioning." ,pdftex-output-expression))
395
(define (document-format-dumpers)
398
(display (string-append (pad-string-to 5 (car x)) (cadr x) "\n"))
402
(define-public (find-dumper format)
403
(let ((d (assoc format output-alist)))
406
(scm-error "Could not find dumper for format ~s" format))))
202
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
203
;; Safe definitions utility
204
(define safe-objects (list))
206
(define-macro (define-safe-public arglist . body)
207
"Define a variable, export it, and mark it as safe, ie usable in LilyPond safe mode.
208
The syntax is the same as `define*-public'."
209
(define (get-symbol arg)
211
(get-symbol (car arg))
213
(let ((safe-symbol (get-symbol arglist)))
215
(define*-public ,arglist
217
(set! safe-objects (cons (cons ',safe-symbol ,safe-symbol)
408
222
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
411
225
(for-each ly:load
413
'("define-music-types.scm"
416
"chord-ignatzek-names.scm"
418
"chord-generic-names.scm"
422
"music-functions.scm"
424
"define-music-properties.scm"
428
"define-context-properties.scm"
429
"translation-functions.scm"
438
"define-markup-commands.scm"
439
"define-grob-properties.scm"
441
"define-grob-interfaces.scm"
229
; "define-event-classes.scm"
230
"define-music-types.scm"
233
"chord-ignatzek-names.scm"
235
"chord-generic-names.scm"
238
"music-functions.scm"
241
"define-music-properties.scm"
245
"parser-ly-from-scheme.scm"
247
"define-context-properties.scm"
248
"translation-functions.scm"
258
"define-markup-commands.scm"
259
"define-grob-properties.scm"
261
"define-grob-interfaces.scm"
262
"define-stencil-commands.scm"
263
"layout-page-layout.scm"
267
"backend-library.scm"
270
;; must be after everything has been defined
448
274
(set! type-p-name-alist
450
(,boolean-or-symbol? . "boolean or symbol")
451
(,boolean? . "boolean")
453
(,grob-list? . "list of grobs")
454
(,hash-table? . "hash table")
455
(,input-port? . "input port")
456
(,integer? . "integer")
458
(,ly:context? . "context")
459
(,ly:dimension? . "dimension, in staff space")
460
(,ly:dir? . "direction")
461
(,ly:duration? . "duration")
462
(,ly:grob? . "layout object")
463
(,ly:input-location? . "input location")
464
(,ly:moment? . "moment")
465
(,ly:music? . "music")
466
(,ly:pitch? . "pitch")
467
(,ly:translator? . "translator")
468
(,ly:font-metric? . "font metric")
469
(,markup-list? . "list of markups")
470
(,markup? . "markup")
471
(,ly:music-list? . "list of music")
472
(,number-or-grob? . "number or grob")
473
(,number-or-string? . "number or string")
474
(,number-pair? . "pair of numbers")
475
(,number? . "number")
476
(,output-port? . "output port")
478
(,procedure? . "procedure")
479
(,scheme? . "any type")
480
(,string? . "string")
481
(,symbol? . "symbol")
482
(,vector? . "vector")
276
(,boolean-or-symbol? . "boolean or symbol")
277
(,boolean? . "boolean")
279
(,grob-list? . "list of grobs")
280
(,hash-table? . "hash table")
281
(,input-port? . "input port")
282
(,integer? . "integer")
284
(,ly:context? . "context")
285
(,ly:dimension? . "dimension, in staff space")
286
(,ly:dir? . "direction")
287
(,ly:duration? . "duration")
288
(,ly:grob? . "layout object")
289
(,ly:input-location? . "input location")
290
(,ly:moment? . "moment")
291
(,ly:music? . "music")
292
(,ly:pitch? . "pitch")
293
(,ly:translator? . "translator")
294
(,ly:font-metric? . "font metric")
295
(,ly:simple-closure? . "simple closure")
296
(,markup-list? . "list of markups")
297
(,markup? . "markup")
298
(,ly:music-list? . "list of music")
299
(,number-or-grob? . "number or grob")
300
(,number-or-string? . "number or string")
301
(,number-pair? . "pair of numbers")
302
(,number? . "number")
303
(,output-port? . "output port")
305
(,procedure? . "procedure")
306
(,scheme? . "any type")
307
(,string? . "string")
308
(,symbol? . "symbol")
309
(,vector? . "vector")))
486
312
;; debug mem leaks
488
314
(define gc-protect-stat-count 0)
489
315
(define-public (dump-gc-protects)
490
(set! gc-protect-stat-count (1+ gc-protect-stat-count) )
493
(hash-table->alist (ly:protects))
495
(< (object-address (car a))
496
(object-address (car b))))))
497
(outfile (open-file (string-append
498
"gcstat-" (number->string gc-protect-stat-count)
503
(display "DUMPING...\n")
316
(set! gc-protect-stat-count (1+ gc-protect-stat-count))
317
(let* ((protects (sort
318
(hash-table->alist (ly:protects))
320
(< (object-address (car a))
321
(object-address (car b))))))
323
(out-file-name (string-append
324
"gcstat-" (number->string gc-protect-stat-count)
326
(outfile (open-file out-file-name "w")))
328
(display (format "Dumping gc protected objs to ~a...\n" out-file-name))
506
(lambda (x) (not (symbol? x)))
336
(map object->string (list (object-address x) c x))
514
(map object->string (list (object-address x) c x))
342
(not (symbol? (car x))))
346
; (display (ly:smob-protects))
348
(if (defined? 'gc-live-object-stats)
350
(display "Live object statistics: GC'ing\n")
354
(set! stats (gc-live-object-stats))
355
(display "Dumping live object statistics.\n")
359
(format outfile "~a: ~a\n" (car x) (cdr x)))
360
(sort (gc-live-object-stats)
362
(string<? (car x) (car y)))))))))
364
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
367
(define-public (lilypond-main files)
368
"Entry point for LilyPond."
370
(define (no-files-handler)
374
(if (ly:get-option 'gui)
380
(let ((failed (lilypond-all files)))
383
(ly:error (_ "failed files: ~S") (string-join failed))
386
;; HACK: be sure to exit with single newline
390
(define-public (lilypond-all files)
392
(if (ly:get-option 'show-available-fonts)
394
(ly:font-config-display-fonts)
399
(handler (lambda (key failed-file)
400
(set! failed (append (list failed-file) failed)))))
404
(lilypond-file handler x)
405
(ly:clear-anonymous-modules)
406
(if (ly:get-option 'debug-gc)
412
(define (lilypond-file handler file-name)
413
(catch 'ly-file-failed
414
(lambda () (ly:parse-file file-name))
415
(lambda (x . args) (handler x file-name))))
417
(use-modules (scm editor))
419
(define-public (gui-main files)
421
(gui-no-files-handler))
422
(let* ((base (basename (car files) ".ly"))
423
(log-name (string-append base ".log")))
424
(if (not (ly:get-option 'gui))
425
(ly:message (_ "Redirecting output to ~a...") log-name))
426
(ly:stderr-redirect log-name "w")
427
(ly:message "# -*-compilation-*-")
429
(let ((failed (lilypond-all files)))
433
(ly:stderr-redirect "foo" "r")
434
(system (get-editor-command log-name 0 0 0))
435
(ly:error (_ "failed files: ~S") (string-join failed))
440
(define (gui-no-files-handler)
441
(let* ((ly (string-append (ly:effective-prefix) "/ly/"))
442
;; FIXME: soft-code, localize
443
(welcome-ly (string-append ly "Welcome_to_LilyPond.ly"))
444
(cmd (get-editor-command welcome-ly 0 0 0)))
445
(ly:message (_ "Invoking `~a'...") cmd)
added
removed
scm/lily.scm
