scm/lily.scm

   1 ;;;; lily.scm -- implement Scheme output routines for TeX and PostScript
   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 ;;; Library functions
   9
  10
  11 (if (defined? 'set-debug-cell-accesses!)
  12     (set-debug-cell-accesses! #f))
  13
  14 ;(set-debug-cell-accesses! 5000)
  15
  16 (use-modules (ice-9 regex)
  17              (ice-9 safe)
  18              (oop goops)
  19              (srfi srfi-1)  ; lists
  20              (srfi srfi-13)) ; strings
  21
  22
  23 ; my display
  24
  25 (define-public (myd k v) (display k) (display ": ") (display v) (display ", "))
  26
  27 (define-public (print . args)
  28   (apply format (cons (current-output-port) args)))
  29
  30
  31 ;;; General settings
  32 ;;; debugging evaluator is slower.  This should
  33 ;;; have a more sensible default.
  34
  35 (if (ly:get-option 'verbose)
  36     (begin
  37       (debug-enable 'debug)
  38       (debug-enable 'backtrace)
  39       (read-enable 'positions)))
  40
  41 (define-public (line-column-location file line col)
  42   "Print an input location, including column number ."
  43   (string-append (number->string line) ":"
  44                  (number->string col) " " file))
  45
  46 (define-public (line-location  file line col)
  47   "Print an input location, without column number ."
  48   (string-append (number->string line) " " file))
  49
  50 (define-public point-and-click #f)
  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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  80
  81 (define (type-check-list location signature arguments)
  82   "Typecheck a list of arguments against a list of type
  83 predicates. Print a message at LOCATION if any predicate failed."
  84   (define (recursion-helper signature arguments count)
  85     (define (helper pred? arg count)
  86       (if (not (pred? arg))
  87
  88           (begin
  89             (ly:input-message location
  90                               (format #f
  91                                       (_ "wrong type for argument ~a. Expecting ~a, found ~s")
  92                                       count (type-name pred?) arg))
  93             #f)
  94           #t))
  95
  96     (if (null? signature)
  97         #t
  98         (and (helper (car signature) (car arguments) count)
  99              (recursion-helper (cdr signature) (cdr arguments) (1+ count)))
 100         ))
 101   (recursion-helper signature arguments 1))
 102
 103 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 104 ;;  output
 105
 106
 107 ;;(define-public (output-framework) (write "hello\n"))
 108
 109 (define output-tex-module
 110   (make-module 1021 (list (resolve-interface '(scm output-tex)))))
 111 (define output-ps-module
 112   (make-module 1021 (list (resolve-interface '(scm output-ps)))))
 113
 114 (define-public (ps-output-expression expr port)
 115   (display (eval expr output-ps-module) port))
 116
 117 ;; TODO: generate this list by registering the stencil expressions
 118 ;;       stencil expressions should have docstrings.
 119 (define-public (ly:all-stencil-expressions)
 120   "Return list of stencil expressions."
 121   '(beam
 122     bezier-sandwich
 123     blank
 124     bracket
 125     char
 126     dashed-line
 127     dashed-slur
 128     dot
 129     draw-line
 130     ez-ball
 131     filledbox
 132     horizontal-line
 133     polygon
 134     repeat-slash
 135     round-filled-box
 136     text
 137     tuplet
 138     white-dot
 139     white-text
 140     zigzag-line
 141     ))
 142
 143 ;; TODO:
 144 ;;  - generate this list by registering the output-backend-commands
 145 ;;    output-backend-commands should have docstrings.
 146 ;;  - remove hard copies in output-ps output-tex
 147 (define-public (ly:all-output-backend-commands)
 148   "Return list of output backend commands."
 149   '(
 150     comment
 151     grob-cause
 152     no-origin
 153     placebox
 154     unknown
 155     ))
 156
 157 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 158 ;; other files.
 159
 160 (for-each ly:load
 161      ;; load-from-path
 162      '("lily-library.scm"
 163        "define-music-types.scm"
 164        "output-lib.scm"
 165        "c++.scm"
 166        "chord-ignatzek-names.scm"
 167        "chord-entry.scm"
 168        "chord-generic-names.scm"
 169        "stencil.scm"
 170        "new-markup.scm"
 171        "bass-figure.scm"
 172        "music-functions.scm"
 173        "part-combiner.scm"
 174        "define-music-properties.scm"
 175        "auto-beam.scm"
 176        "chord-name.scm"
 177
 178        "ly-from-scheme.scm"
 179
 180        "define-context-properties.scm"
 181        "translation-functions.scm"
 182        "script.scm"
 183        "midi.scm"
 184        "beam.scm"
 185        "clef.scm"
 186        "slur.scm"
 187        "font.scm"
 188        "encoding.scm"
 189
 190        "fret-diagrams.scm"
 191        "define-markup-commands.scm"
 192        "define-grob-properties.scm"
 193        "define-grobs.scm"
 194        "define-grob-interfaces.scm"
 195        "page-layout.scm"
 196        "titling.scm"
 197
 198        "paper.scm"
 199
 200        ; last:
 201        "safe-lily.scm"
 202        ))
 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
 243 ;; debug mem leaks
 244
 245 (define gc-protect-stat-count 0)
 246 (define-public (dump-gc-protects)
 247   (set! gc-protect-stat-count (1+ gc-protect-stat-count) )
 248   (let*
 249       ((protects (sort
 250            (hash-table->alist (ly:protects))
 251            (lambda (a b)
 252              (< (object-address (car a))
 253                 (object-address (car b))))))
 254        (outfile    (open-file (string-append
 255                "gcstat-" (number->string gc-protect-stat-count)
 256                ".scm"
 257                ) "w")))
 258
 259     (display "DUMPING...\n")
 260     (display
 261      (filter
 262       (lambda (x) (not (symbol? x)))
 263       (map (lambda (y)
 264              (let
 265                  ((x (car y))
 266                   (c (cdr y)))
 267
 268                (string-append
 269                 (string-join
 270                  (map object->string (list (object-address x) c x))
 271                  " ")
 272                 "\n")))
 273            protects))
 274      outfile)))
 275
 276
 277 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 278
 279 (define-public (ly:system command)
 280   (let*
 281       ((status 0)
 282
 283        (silenced
 284         (string-append command (if (ly:get-option 'verbose)
 285                                  ""
 286                                  " > /dev/null 2>&1 "))))
 287
 288     (if (ly:get-option 'verbose)
 289         (format  (current-error-port) (_ "Invoking `~a'...\n") command))
 290
 291     (set! status (system silenced))
 292     (if (> status 0)
 293         (begin
 294           (format (current-error-port)
 295                   (_ "Error invoking `~a'. Return value ~a") silenced status)
 296           (newline (current-error-port))))))
 297
 298 (define-public (sanitize-command-option str)
 299   (string-append
 300    "\""
 301    (regexp-substitute/global #f "[^- 0-9,.a-zA-Z'\"\\]" str 'pre 'post)
 302   "\""))
 303
 304 (define-public (postscript->pdf papersizename name)
 305   (let* ((cmd (string-append "ps2pdf "
 306                              (string-append
 307                               " -sPAPERSIZE="
 308                               (sanitize-command-option papersizename)
 309                               " "
 310                              name)))
 311          (pdf-name (string-append (basename name ".ps") ".pdf" )))
 312
 313     (if (access? pdf-name W_OK)
 314         (delete-file pdf-name))
 315
 316     (format (current-error-port) (_ "Converting to `~a'...") pdf-name)
 317     (ly:system cmd)))
 318
 319 (define-public (postscript->png resolution name)
 320   (let
 321       ((cmd (string-append
 322            "ps2png --resolution="
 323            (if (number? resolution)
 324                (number->string resolution)
 325                "90 ")
 326            (if (ly:get-option 'verbose)
 327                "--verbose "
 328                " ")
 329            name)))
 330     (ly:system cmd)))
 331
 332 (define-public (lilypond-main files)
 333   "Entry point for LilyPond."
 334   (let* ((failed '())
 335          (handler (lambda (key arg) (set! failed (cons arg failed)))))
 336     (for-each
 337      (lambda (f)
 338        (catch 'ly-file-failed (lambda () (ly:parse-file f)) handler)
 339 ;;;       (dump-gc-protects)
 340        )
 341      files)
 342
 343     (if (pair? failed)
 344         (begin
 345           (newline (current-error-port))
 346           (display (_ "error: failed files: ") (current-error-port))
 347           (display (string-join failed) (current-error-port))
 348           (newline (current-error-port))
 349           (newline (current-error-port))
 350           (exit 1))
 351         (exit 0))))
 352
 353