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