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