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     white-dot
 138     white-text
 139     zigzag-line
 140     ))
 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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 157 ;; other files.
 158
 159 (for-each ly:load
 160      ;; load-from-path
 161      '("lily-library.scm"
 162        "define-music-types.scm"
 163        "output-lib.scm"
 164        "c++.scm"
 165        "chord-ignatzek-names.scm"
 166        "chord-entry.scm"
 167        "chord-generic-names.scm"
 168        "stencil.scm"
 169        "new-markup.scm"
 170        "bass-figure.scm"
 171        "music-functions.scm"
 172        "part-combiner.scm"
 173        "define-music-properties.scm"
 174        "auto-beam.scm"
 175        "chord-name.scm"
 176
 177        "ly-from-scheme.scm"
 178
 179        "define-context-properties.scm"
 180        "translation-functions.scm"
 181        "script.scm"
 182        "midi.scm"
 183        "beam.scm"
 184        "clef.scm"
 185        "slur.scm"
 186        "font.scm"
 187        "encoding.scm"
 188
 189        "fret-diagrams.scm"
 190        "define-markup-commands.scm"
 191        "define-grob-properties.scm"
 192        "define-grobs.scm"
 193        "define-grob-interfaces.scm"
 194        "page-layout.scm"
 195        "titling.scm"
 196
 197        "paper.scm"
 198
 199        ; last:
 200        "safe-lily.scm"
 201        ))
 202
 203
 204 (set! type-p-name-alist
 205   `(
 206    (,boolean-or-symbol? . "boolean or symbol")
 207    (,boolean? . "boolean")
 208    (,char? . "char")
 209    (,grob-list? . "list of grobs")
 210    (,hash-table? . "hash table")
 211    (,input-port? . "input port")
 212    (,integer? . "integer")
 213    (,list? . "list")
 214    (,ly:context? . "context")
 215    (,ly:dimension? . "dimension, in staff space")
 216    (,ly:dir? . "direction")
 217    (,ly:duration? . "duration")
 218    (,ly:grob? . "layout object")
 219    (,ly:input-location? . "input location")
 220    (,ly:moment? . "moment")
 221    (,ly:music? . "music")
 222    (,ly:pitch? . "pitch")
 223    (,ly:translator? . "translator")
 224    (,ly:font-metric? . "font metric")
 225    (,markup-list? . "list of markups")
 226    (,markup? . "markup")
 227    (,ly:music-list? . "list of music")
 228    (,number-or-grob? . "number or grob")
 229    (,number-or-string? . "number or string")
 230    (,number-pair? . "pair of numbers")
 231    (,number? . "number")
 232    (,output-port? . "output port")
 233    (,pair? . "pair")
 234    (,procedure? . "procedure")
 235    (,scheme? . "any type")
 236    (,string? . "string")
 237    (,symbol? . "symbol")
 238    (,vector? . "vector")
 239    ))
 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*
 248       ((protects (sort
 249            (hash-table->alist (ly:protects))
 250            (lambda (a b)
 251              (< (object-address (car a))
 252                 (object-address (car b))))))
 253        (outfile    (open-file (string-append
 254                "gcstat-" (number->string gc-protect-stat-count)
 255                ".scm"
 256                ) "w")))
 257
 258     (display "DUMPING...\n")
 259     (display
 260      (filter
 261       (lambda (x) (not (symbol? x)))
 262       (map (lambda (y)
 263              (let
 264                  ((x (car y))
 265                   (c (cdr y)))
 266
 267                (string-append
 268                 (string-join
 269                  (map object->string (list (object-address x) c x))
 270                  " ")
 271                 "\n")))
 272            protects))
 273      outfile)))
 274
 275
 276 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 277
 278 (define-public (ly:system command)
 279   (let*
 280       ((status 0)
 281
 282        (silenced
 283         (string-append command (if (ly:get-option 'verbose)
 284                                  ""
 285                                  " > /dev/null 2>&1 "))))
 286
 287     (if (ly:get-option 'verbose)
 288         (format  (current-error-port) (_ "Invoking `~a'...\n") command))
 289
 290     (set! status (system silenced))
 291     (if (> status 0)
 292         (begin
 293           (format (current-error-port)
 294                   (_ "Error invoking `~a'. Return value ~a") silenced status)
 295           (newline (current-error-port))))))
 296
 297 (define-public (sanitize-command-option str)
 298   (string-append
 299    "\""
 300    (regexp-substitute/global #f "[^- 0-9,.a-zA-Z'\"\\]" str 'pre 'post)
 301   "\""))
 302
 303 (define-public (postscript->pdf papersizename name)
 304   (let* ((cmd (string-append "ps2pdf "
 305                              (string-append
 306                               " -sPAPERSIZE="
 307                               (sanitize-command-option papersizename)
 308                               " "
 309                              name)))
 310          (pdf-name (string-append (basename name ".ps") ".pdf" )))
 311
 312     (if (access? pdf-name W_OK)
 313         (delete-file pdf-name))
 314
 315     (format (current-error-port) (_ "Converting to `~a'...") pdf-name)
 316     (ly:system cmd)))
 317
 318 (define-public (postscript->png resolution name)
 319   (let
 320       ((cmd (string-append
 321            "ps2png --resolution="
 322            (if (number? resolution)
 323                (number->string resolution)
 324                "90 ")
 325            (if (ly:get-option 'verbose)
 326                "--verbose "
 327                " ")
 328            name)))
 329     (ly:system cmd)))
 330
 331 (define-public (lilypond-main files)
 332   "Entry point for LilyPond."
 333   (let* ((failed '())
 334          (handler (lambda (key arg) (set! failed (cons arg failed)))))
 335     (for-each
 336      (lambda (f)
 337        (catch 'ly-file-failed (lambda () (ly:parse-file f)) handler)
 338 ;;;       (dump-gc-protects)
 339        )
 340      files)
 341
 342     (if (pair? failed)
 343         (begin
 344           (newline (current-error-port))
 345           (display (_ "error: failed files: ") (current-error-port))
 346           (display (string-join failed) (current-error-port))
 347           (newline (current-error-port))
 348           (newline (current-error-port))
 349           (exit 1))
 350         (exit 0))))
 351
 352
 353 (define-public (tweak-grob-property grob sym val)
 354     (set! (ly:grob-property grob sym) val))