1 ;;;; lily.scm -- implement Scheme output routines for TeX and PostScript
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 1998--2004 Jan Nieuwenhuizen <janneke@gnu.org>
6 ;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
10 (if (defined? 'set-debug-cell-accesses!)
11 (set-debug-cell-accesses! #f))
13 ;; ugh, need this for encoding.scm test
14 ;; srfi-13 overrides string->list
15 (define-public plain-string->list string->list)
17 (use-modules (ice-9 regex)
21 (srfi srfi-13)) ; strings
23 (define-public safe-module (make-safe-module))
25 (define-public (myd k v) (display k) (display ": ") (display v) (display ", "))
28 ;;; debugging evaluator is slower. This should
29 ;;; have a more sensible default.
31 (if (ly:get-option 'verbose)
34 (debug-enable 'backtrace)
35 (read-enable 'positions)))
37 (define-public (line-column-location line col file)
38 "Print an input location, including column number ."
39 (string-append (number->string line) ":"
40 (number->string col) " " file))
42 (define-public (line-location line col file)
43 "Print an input location, without column number ."
44 (string-append (number->string line) " " file))
46 (define-public point-and-click #f)
48 (define-public parser #f)
50 (define-public (lilypond-version)
52 (map (lambda (x) (if (symbol? x)
60 ;; cpp hack to get useful error message
61 (define ifdef "First run this through cpp.")
62 (define ifndef "First run this through cpp.")
66 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
70 (define-public START -1)
71 (define-public STOP 1)
72 (define-public LEFT -1)
73 (define-public RIGHT 1)
75 (define-public DOWN -1)
76 (define-public CENTER 0)
78 (define-public DOUBLE-FLAT -4)
79 (define-public THREE-Q-FLAT -3)
80 (define-public FLAT -2)
81 (define-public SEMI-FLAT -1)
82 (define-public NATURAL 0)
83 (define-public SEMI-SHARP 1)
84 (define-public SHARP 2)
85 (define-public THREE-Q-SHARP 3)
86 (define-public DOUBLE-SHARP 4)
87 (define-public SEMI-TONE 2)
89 (define-public ZERO-MOMENT (ly:make-moment 0 1))
91 (define-public (moment-min a b)
92 (if (ly:moment<? a b) a b))
94 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
95 ;; lily specific variables.
97 (define-public default-script-alist '())
99 (define-public safe-mode? #f)
102 (define-public (print-music-as-book parser music)
103 (let* ((score (ly:music-scorify music))
104 (book (ly:score-bookify score)))
105 (ly:parser-print-book parser book)))
107 (define-public (print-score-as-book parser score)
108 (let ((book (ly:score-bookify score)))
109 (ly:parser-print-book parser book)))
111 (define-public (print-score parser score)
112 (let ((book (ly:score-bookify score)))
113 (ly:parser-print-score parser book)))
115 (define-public default-toplevel-music-handler print-music-as-book)
116 (define-public default-toplevel-book-handler ly:parser-print-book)
117 (define-public default-toplevel-score-handler print-score-as-book)
120 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
121 ;;; Unassorted utility functions.
126 (define-public (assoc-get key alist . default)
127 "Return value if KEY in ALIST, else DEFAULT (or #f if not specified)."
128 (let ((entry (assoc key alist)))
131 (if (pair? default) (car default) #f))))
133 (define-public (uniqued-alist alist acc)
134 (if (null? alist) acc
135 (if (assoc (caar alist) acc)
136 (uniqued-alist (cdr alist) acc)
137 (uniqued-alist (cdr alist) (cons (car alist) acc)))))
139 (define-public (alist<? x y)
140 (string<? (symbol->string (car x))
141 (symbol->string (car y))))
143 (define-public (chain-assoc x alist-list)
144 (if (null? alist-list)
146 (let* ((handle (assoc x (car alist-list))))
149 (chain-assoc x (cdr alist-list))))))
151 (define-public (chain-assoc-get x alist-list . default)
152 "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
155 (define (helper x alist-list default)
156 (if (null? alist-list)
158 (let* ((handle (assoc x (car alist-list))))
161 (helper x (cdr alist-list) default)))))
164 (if (pair? default) (car default) #f)))
166 (define (map-alist-vals func list)
167 "map FUNC over the vals of LIST, leaving the keys."
170 (cons (cons (caar list) (func (cdar list)))
171 (map-alist-vals func (cdr list)))
174 (define (map-alist-keys func list)
175 "map FUNC over the keys of an alist LIST, leaving the vals. "
178 (cons (cons (func (caar list)) (cdar list))
179 (map-alist-keys func (cdr list)))
187 (if (not (defined? 'hash-table?)) ; guile 1.6 compat
189 (define hash-table? vector?)
191 (define-public (hash-table->alist t)
192 "Convert table t to list"
199 (define-public (hash-table->alist t)
201 (hash-fold (lambda (k v acc) (acons k v acc))
206 ;; todo: code dup with C++.
207 (define-public (alist->hash-table l)
208 "Convert alist to table"
210 ((m (make-hash-table (length l))))
213 (hashq-set! m (car k-v) (cdr k-v)))
223 (define (flatten-list lst)
227 (if (pair? (car lst))
228 (append (flatten-list (car lst)) (flatten-list (cdr lst)))
229 (cons (car lst) (flatten-list (cdr lst))))
232 (define (list-minus a b)
233 "Return list of elements in A that are not in B."
234 (lset-difference eq? a b))
237 ;; TODO: use the srfi-1 partition function.
238 (define-public (uniq-list l)
240 "Uniq LIST, assuming that it is sorted"
241 (define (helper acc l)
246 (if (equal? (car l) (cadr l))
248 (helper (cons (car l) acc) (cdr l)))
250 (reverse! (helper '() l) '()))
253 (define (split-at-predicate predicate l)
254 "Split L = (a_1 a_2 ... a_k b_1 ... b_k)
255 into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k)
256 Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
257 L1 is copied, L2 not.
259 (split-at-predicate (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))"
264 (define (inner-split predicate l acc)
268 (set-car! acc (cons (car l) (car acc)))
270 ((predicate (car l) (cadr l))
271 (set-car! acc (cons (car l) (car acc)))
272 (inner-split predicate (cdr l) acc))
274 (set-car! acc (cons (car l) (car acc)))
275 (set-cdr! acc (cdr l))
282 (inner-split predicate l c)
283 (set-car! c (reverse! (car c)))
288 (define-public (split-list l sep?)
290 (display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))) )
292 ((a b c) (d e f) (g))
297 (define (split-one sep? l acc)
298 "Split off the first parts before separator and return both parts."
303 (split-one sep? (cdr l) (cons (car l) acc))
309 (let* ((c (split-one sep? l '())))
310 (cons (reverse! (car c) '()) (split-list (cdr c) sep?))
314 (define-public (interval-length x)
315 "Length of the number-pair X, when an interval"
316 (max 0 (- (cdr x) (car x)))
320 (define (other-axis a)
321 (remainder (+ a 1) 2))
324 (define-public (interval-widen iv amount)
325 (cons (- (car iv) amount)
326 (+ (cdr iv) amount)))
328 (define-public (interval-union i1 i2)
329 (cons (min (car i1) (car i2))
330 (max (cdr i1) (cdr i2))))
333 (define-public (write-me message x)
334 "Return X. Display MESSAGE and write X. Handy for debugging, possibly turned off."
335 (display message) (write x) (newline) x)
338 (define (index-cell cell dir)
343 (define (cons-map f x)
344 "map F to contents of X"
345 (cons (f (car x)) (f (cdr x))))
348 (define-public (list-insert-separator lst between)
349 "Create new list, inserting BETWEEN between elements of LIST"
353 (cons x (cons between y))
355 (fold-right conc #f lst))
364 (define-public (symbol<? l r)
365 (string<? (symbol->string l) (symbol->string r)))
367 (define-public (!= l r)
370 (define-public (ly:load x)
372 (fn (%search-load-path x))
375 (if (ly:get-option 'verbose)
376 (format (current-error-port) "[~A]" fn))
377 (primitive-load fn)))
380 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
384 ;(scm output-sodipodi)
390 (define output-tex-module
391 (make-module 1021 (list (resolve-interface '(scm output-tex)))))
392 (define output-ps-module
393 (make-module 1021 (list (resolve-interface '(scm output-ps)))))
394 (define-public (tex-output-expression expr port)
395 (display (eval expr output-tex-module) port))
396 (define-public (ps-output-expression expr port)
397 (display (eval expr output-ps-module) port))
401 ("tex" . ("TeX output. The default output form." ,tex-output-expression))
402 ("scm" . ("Scheme dump: debug scheme stencil expressions" ,write))
403 ; ("sketch" . ("Bare bones Sketch output." ,sketch-output-expression))
404 ; ("sodipodi" . ("Bare bones Sodipodi output." ,sodipodi-output-expression))
405 ; ("pdftex" . ("PDFTeX output. Was last seen nonfunctioning." ,pdftex-output-expression))
409 (define (document-format-dumpers)
412 (display (string-append (pad-string-to 5 (car x)) (cadr x) "\n"))
416 (define-public (find-dumper format)
417 (let ((d (assoc format output-alist)))
420 (scm-error "Could not find dumper for format ~s" format))))
422 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
427 '("define-music-types.scm"
430 "chord-ignatzek-names.scm"
432 "chord-generic-names.scm"
436 "music-functions.scm"
438 "define-music-properties.scm"
444 "define-context-properties.scm"
445 "translation-functions.scm"
455 "define-markup-commands.scm"
456 "define-grob-properties.scm"
458 "define-grob-interfaces.scm"
464 (set! type-p-name-alist
466 (,boolean-or-symbol? . "boolean or symbol")
467 (,boolean? . "boolean")
469 (,grob-list? . "list of grobs")
470 (,hash-table? . "hash table")
471 (,input-port? . "input port")
472 (,integer? . "integer")
474 (,ly:context? . "context")
475 (,ly:dimension? . "dimension, in staff space")
476 (,ly:dir? . "direction")
477 (,ly:duration? . "duration")
478 (,ly:grob? . "layout object")
479 (,ly:input-location? . "input location")
480 (,ly:moment? . "moment")
481 (,ly:music? . "music")
482 (,ly:pitch? . "pitch")
483 (,ly:translator? . "translator")
484 (,ly:font-metric? . "font metric")
485 (,markup-list? . "list of markups")
486 (,markup? . "markup")
487 (,ly:music-list? . "list of music")
488 (,number-or-grob? . "number or grob")
489 (,number-or-string? . "number or string")
490 (,number-pair? . "pair of numbers")
491 (,number? . "number")
492 (,output-port? . "output port")
494 (,procedure? . "procedure")
495 (,scheme? . "any type")
496 (,string? . "string")
497 (,symbol? . "symbol")
498 (,vector? . "vector")
504 (define gc-protect-stat-count 0)
505 (define-public (dump-gc-protects)
506 (set! gc-protect-stat-count (1+ gc-protect-stat-count) )
509 (hash-table->alist (ly:protects))
511 (< (object-address (car a))
512 (object-address (car b))))))
513 (outfile (open-file (string-append
514 "gcstat-" (number->string gc-protect-stat-count)
519 (display "DUMPING...\n")
522 (lambda (x) (not (symbol? x)))
530 (map object->string (list (object-address x) c x))
538 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
540 (define-public (lilypond-main files)
541 "Entry point for Lilypond"
544 (handler (lambda (key arg)
545 (set! failed (cons arg failed))))
550 (catch 'ly-file-failed
551 (lambda () (ly:parse-file fn))
558 (display (string-append "\n *** Failed files: " (string-join failed) "\n" ))