scm/lily.scm

   1 ;;;; lily.scm -- toplevel Scheme stuff
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c)  1998--2004 Jan Nieuwenhuizen <janneke@gnu.org>
   6 ;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
   7
   8
   9 (if (defined? 'set-debug-cell-accesses!)
  10     (set-debug-cell-accesses! #f))
  11
  12 ;;(set-debug-cell-accesses! 5000)
  13
  14 (use-modules (ice-9 regex)
  15              (ice-9 safe)
  16              (oop goops)
  17              (srfi srfi-1)  ; lists
  18              (srfi srfi-13)) ; strings
  19
  20
  21 ;; my display
  22 (define-public (myd k v) (display k) (display ": ") (display v) (display ", "))
  23
  24 (define-public (print . args)
  25   (apply format (cons (current-output-port) args)))
  26
  27
  28 ;;; General settings
  29 ;;; debugging evaluator is slower.  This should
  30 ;;; have a more sensible default.
  31
  32 (if (ly:get-option 'verbose)
  33     (begin
  34       (debug-enable 'debug)
  35       (debug-enable 'backtrace)
  36       (read-enable 'positions)))
  37
  38 (define-public (line-column-location file line col)
  39   "Print an input location, including column number ."
  40   (string-append (number->string line) ":"
  41                  (number->string col) " " file))
  42
  43 (define-public (line-location  file line col)
  44   "Print an input location, without column number ."
  45   (string-append (number->string line) " " file))
  46
  47 (define-public point-and-click #f)
  48
  49 (define-public tex-backend?
  50   (member (ly:output-backend) '("texstr" "tex")))
  51
  52 (define-public parser #f)
  53
  54 (define-public (lilypond-version)
  55   (string-join
  56    (map (lambda (x) (if (symbol? x)
  57                         (symbol->string x)
  58                         (number->string x)))
  59         (ly:version))
  60    "."))
  61
  62
  63
  64 ;; cpp hack to get useful error message
  65 (define ifdef "First run this through cpp.")
  66 (define ifndef "First run this through cpp.")
  67
  68 ;; gettext wrapper for guile < 1.7.2
  69 (if (defined? 'gettext)
  70     (define-public _ gettext)
  71     (define-public _ ly:gettext))
  72
  73 (define-public (ly:load x)
  74   (let* ((fn (%search-load-path x)))
  75     (if (ly:get-option 'verbose)
  76         (format (current-error-port) "[~A]" fn))
  77     (primitive-load fn)))
  78
  79 (define-public TEX_STRING_HASHLIMIT 10000000)
  80
  81 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  82
  83 (define (type-check-list location signature arguments)
  84   "Typecheck a list of arguments against a list of type
  85 predicates. Print a message at LOCATION if any predicate failed."
  86   (define (recursion-helper signature arguments count)
  87     (define (helper pred? arg count)
  88       (if (not (pred? arg))
  89
  90           (begin
  91             (ly:input-message location
  92                               (format #f
  93                                       (_ "wrong type for argument ~a. Expecting ~a, found ~s")
  94                                       count (type-name pred?) arg))
  95             #f)
  96           #t))
  97
  98     (if (null? signature)
  99         #t
 100         (and (helper (car signature) (car arguments) count)
 101              (recursion-helper (cdr signature) (cdr arguments) (1+ count)))))
 102   (recursion-helper signature arguments 1))
 103
 104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 105 ;;  output
 106
 107
 108 ;;(define-public (output-framework) (write "hello\n"))
 109
 110 (define output-tex-module
 111   (make-module 1021 (list (resolve-interface '(scm output-tex)))))
 112 (define output-ps-module
 113   (make-module 1021 (list (resolve-interface '(scm output-ps)))))
 114
 115 (define-public (ps-output-expression expr port)
 116   (display (eval expr output-ps-module) port))
 117
 118 ;; TODO: generate this list by registering the stencil expressions
 119 ;;       stencil expressions should have docstrings.
 120 (define-public (ly:all-stencil-expressions)
 121   "Return list of stencil expressions."
 122   '(beam
 123     bezier-sandwich
 124     blank
 125     bracket
 126     char
 127     dashed-line
 128     dashed-slur
 129     dot
 130     draw-line
 131     ez-ball
 132     filledbox
 133     glyph-string
 134     horizontal-line
 135     named-glyph
 136     polygon
 137     repeat-slash
 138     round-filled-box
 139     text
 140     white-dot
 141     white-text
 142     embedded-ps
 143     zigzag-line))
 144
 145 ;; TODO:
 146 ;;  - generate this list by registering the output-backend-commands
 147 ;;    output-backend-commands should have docstrings.
 148 ;;  - remove hard copies in output-ps output-tex
 149 (define-public (ly:all-output-backend-commands)
 150   "Return list of output backend commands."
 151   '(
 152     comment
 153     grob-cause
 154     no-origin
 155     placebox
 156     unknown))
 157
 158 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 159 ;; other files.
 160
 161 (for-each ly:load
 162           ;; load-from-path
 163           '("lily-library.scm"
 164             "define-music-types.scm"
 165             "output-lib.scm"
 166             "c++.scm"
 167             "chord-ignatzek-names.scm"
 168             "chord-entry.scm"
 169             "chord-generic-names.scm"
 170             "stencil.scm"
 171             "new-markup.scm"
 172             "bass-figure.scm"
 173             "music-functions.scm"
 174             "part-combiner.scm"
 175             "define-music-properties.scm"
 176             "auto-beam.scm"
 177             "chord-name.scm"
 178
 179             "ly-from-scheme.scm"
 180
 181             "define-context-properties.scm"
 182             "translation-functions.scm"
 183             "script.scm"
 184             "midi.scm"
 185             "beam.scm"
 186             "clef.scm"
 187             "slur.scm"
 188             "font.scm"
 189             "encoding.scm"
 190
 191             "fret-diagrams.scm"
 192             "define-markup-commands.scm"
 193             "define-grob-properties.scm"
 194             "define-grobs.scm"
 195             "define-grob-interfaces.scm"
 196             "page-layout.scm"
 197             "titling.scm"
 198
 199             "paper.scm"
 200
 201                                         ; last:
 202             "safe-lily.scm"))
 203
 204
 205 (set! type-p-name-alist
 206       `(
 207         (,boolean-or-symbol? . "boolean or symbol")
 208         (,boolean? . "boolean")
 209         (,char? . "char")
 210         (,grob-list? . "list of grobs")
 211         (,hash-table? . "hash table")
 212         (,input-port? . "input port")
 213         (,integer? . "integer")
 214         (,list? . "list")
 215         (,ly:context? . "context")
 216         (,ly:dimension? . "dimension, in staff space")
 217         (,ly:dir? . "direction")
 218         (,ly:duration? . "duration")
 219         (,ly:grob? . "layout object")
 220         (,ly:input-location? . "input location")
 221         (,ly:moment? . "moment")
 222         (,ly:music? . "music")
 223         (,ly:pitch? . "pitch")
 224         (,ly:translator? . "translator")
 225         (,ly:font-metric? . "font metric")
 226         (,markup-list? . "list of markups")
 227         (,markup? . "markup")
 228         (,ly:music-list? . "list of music")
 229         (,number-or-grob? . "number or grob")
 230         (,number-or-string? . "number or string")
 231         (,number-pair? . "pair of numbers")
 232         (,number? . "number")
 233         (,output-port? . "output port")
 234         (,pair? . "pair")
 235         (,procedure? . "procedure")
 236         (,scheme? . "any type")
 237         (,string? . "string")
 238         (,symbol? . "symbol")
 239         (,vector? . "vector")))
 240
 241
 242 ;; debug mem leaks
 243
 244 (define gc-protect-stat-count 0)
 245 (define-public (dump-gc-protects)
 246   (set! gc-protect-stat-count (1+ gc-protect-stat-count))
 247   (let* ((protects (sort
 248                     (hash-table->alist (ly:protects))
 249                     (lambda (a b)
 250                       (< (object-address (car a))
 251                          (object-address (car b))))))
 252          (out-file-name (string-append
 253                          "gcstat-" (number->string gc-protect-stat-count)
 254                          ".scm"))
 255          (outfile    (open-file  out-file-name  "w")))
 256
 257     (display "Dumping gc protected objs to ...\n")
 258     (display
 259      (filter
 260       (lambda (x) (not (symbol? x)))
 261       (map (lambda (y)
 262              (let ((x (car y))
 263                    (c (cdr y)))
 264
 265                (string-append
 266                 (string-join
 267                  (map object->string (list (object-address x) c x))
 268                  " ")
 269                 "\n")))
 270            protects))
 271      outfile)))
 272
 273
 274 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 275 ;; backend helpers.
 276
 277 (define-public (ly:system command)
 278   (let* ((status 0)
 279
 280          (silenced
 281           (string-append command (if (ly:get-option 'verbose)
 282                                      ""
 283                                      " > /dev/null 2>&1 "))))
 284
 285     (if (ly:get-option 'verbose)
 286         (format  (current-error-port) (_ "Invoking `~a'...\n") command))
 287
 288     (set! status (system silenced))
 289     (if (> status 0)
 290         (begin
 291           (format (current-error-port)
 292                   (_ "Error invoking `~a'. Return value ~a") silenced status)
 293           (newline (current-error-port))))))
 294
 295 (define-public (sanitize-command-option str)
 296   (string-append
 297    "\""
 298    (regexp-substitute/global #f "[^- 0-9,.a-zA-Z'\"\\]" str 'pre 'post)
 299    "\""))
 300
 301 (define-public (postscript->pdf papersizename name)
 302   (let* ((cmd (string-append "ps2pdf "
 303                              (string-append
 304                               " -sPAPERSIZE="
 305                               (sanitize-command-option papersizename)
 306                               " "
 307                               name)))
 308          (pdf-name (string-append (basename name ".ps") ".pdf" )))
 309
 310     (if (access? pdf-name W_OK)
 311         (delete-file pdf-name))
 312
 313     (format (current-error-port) (_ "Converting to `~a'...") pdf-name)
 314     (ly:system cmd)))
 315
 316 (define-public (postscript->png resolution name)
 317   (let ((cmd (string-append
 318               "ps2png --resolution="
 319               (if (number? resolution)
 320                   (number->string resolution)
 321                   "90 ")
 322               (if (ly:get-option 'verbose)
 323                   "--verbose "
 324                   " ")
 325               name)))
 326
 327     (ly:system cmd)))
 328
 329 (define-public (postprocess-output paper-book module filename formats)
 330   (for-each
 331    (lambda (f)
 332      ((eval (string->symbol (string-append "convert-to-" f))
 333             module)
 334       paper-book filename))
 335
 336    formats))
 337
 338 (define-public (completize-formats formats)
 339   (define new-fmts '())
 340
 341   (if (member "png" formats)
 342       (set! formats (cons "ps" formats)))
 343   (if (member "pdf" formats)
 344       (set! formats (cons "ps" formats)))
 345
 346   (for-each
 347    (lambda (x)
 348      (if (member x formats) (set! new-fmts (cons x new-fmts))))
 349    '("tex" "dvi" "ps" "pdf" "png"))
 350
 351   new-fmts)
 352
 353 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 354
 355 (define-public (lilypond-main files)
 356   "Entry point for LilyPond."
 357   (let* ((failed '())
 358          (handler (lambda (key arg) (set! failed (cons arg failed)))))
 359     (for-each
 360      (lambda (f)
 361        (catch 'ly-file-failed (lambda () (ly:parse-file f)) handler)
 362        (if #f
 363            (dump-gc-protects)))
 364      files)
 365
 366     (if (pair? failed)
 367         (begin
 368           (newline (current-error-port))
 369           (display (_ "error: failed files: ") (current-error-port))
 370           (display (string-join failed) (current-error-port))
 371           (newline (current-error-port))
 372           (newline (current-error-port))
 373           (exit 1))
 374         (exit 0))))
 375
 376 (define-public (tweak-grob-property grob sym val)
 377   (set! (ly:grob-property grob sym) val))