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     text
 138     tuplet
 139     white-dot
 140     white-text
 141     zigzag-line
 142     ))
 143
 144 ;; TODO:
 145 ;;  - generate this list by registering the output-backend-commands
 146 ;;    output-backend-commands should have docstrings.
 147 ;;  - remove hard copies in output-ps output-tex
 148 (define-public (ly:all-output-backend-commands)
 149   "Return list of output backend commands."
 150   '(
 151     comment
 152     grob-cause
 153     no-origin
 154     placebox
 155     unknown
 156     ))
 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
 206 (set! type-p-name-alist
 207   `(
 208    (,boolean-or-symbol? . "boolean or symbol")
 209    (,boolean? . "boolean")
 210    (,char? . "char")
 211    (,grob-list? . "list of grobs")
 212    (,hash-table? . "hash table")
 213    (,input-port? . "input port")
 214    (,integer? . "integer")
 215    (,list? . "list")
 216    (,ly:context? . "context")
 217    (,ly:dimension? . "dimension, in staff space")
 218    (,ly:dir? . "direction")
 219    (,ly:duration? . "duration")
 220    (,ly:grob? . "layout object")
 221    (,ly:input-location? . "input location")
 222    (,ly:moment? . "moment")
 223    (,ly:music? . "music")
 224    (,ly:pitch? . "pitch")
 225    (,ly:translator? . "translator")
 226    (,ly:font-metric? . "font metric")
 227    (,markup-list? . "list of markups")
 228    (,markup? . "markup")
 229    (,ly:music-list? . "list of music")
 230    (,number-or-grob? . "number or grob")
 231    (,number-or-string? . "number or string")
 232    (,number-pair? . "pair of numbers")
 233    (,number? . "number")
 234    (,output-port? . "output port")
 235    (,pair? . "pair")
 236    (,procedure? . "procedure")
 237    (,scheme? . "any type")
 238    (,string? . "string")
 239    (,symbol? . "symbol")
 240    (,vector? . "vector")
 241    ))
 242
 243
 244 ;; debug mem leaks
 245
 246 (define gc-protect-stat-count 0)
 247 (define-public (dump-gc-protects)
 248   (set! gc-protect-stat-count (1+ gc-protect-stat-count) )
 249   (let*
 250       ((protects (sort
 251            (hash-table->alist (ly:protects))
 252            (lambda (a b)
 253              (< (object-address (car a))
 254                 (object-address (car b))))))
 255        (outfile    (open-file (string-append
 256                "gcstat-" (number->string gc-protect-stat-count)
 257                ".scm"
 258                ) "w")))
 259
 260     (display "DUMPING...\n")
 261     (display
 262      (filter
 263       (lambda (x) (not (symbol? x)))
 264       (map (lambda (y)
 265              (let
 266                  ((x (car y))
 267                   (c (cdr y)))
 268
 269                (string-append
 270                 (string-join
 271                  (map object->string (list (object-address x) c x))
 272                  " ")
 273                 "\n")))
 274            protects))
 275      outfile)))
 276
 277
 278 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 279
 280 (define-public (ly:system command)
 281   (let*
 282       ((status 0)
 283
 284        (silenced
 285         (string-append command (if (ly:get-option 'verbose)
 286                                  ""
 287                                  " > /dev/null 2>&1 "))))
 288
 289     (if (ly:get-option 'verbose)
 290         (format  (current-error-port) (_ "Invoking `~a'...\n") command))
 291
 292     (set! status (system silenced))
 293     (if (> status 0)
 294         (begin
 295           (format (current-error-port)
 296                   (_ "Error invoking `~a'. Return value ~a") silenced status)
 297           (newline (current-error-port))))))
 298
 299 (define-public (sanitize-command-option str)
 300   (string-append
 301    "\""
 302    (regexp-substitute/global #f "[^- 0-9,.a-zA-Z'\"\\]" str 'pre 'post)
 303   "\""))
 304
 305 (define-public (postscript->pdf papersizename name)
 306   (let* ((cmd (string-append "ps2pdf "
 307                              (string-append
 308                               " -sPAPERSIZE="
 309                               (sanitize-command-option papersizename)
 310                               " "
 311                              name)))
 312          (pdf-name (string-append (basename name ".ps") ".pdf" )))
 313
 314     (if (access? pdf-name W_OK)
 315         (delete-file pdf-name))
 316
 317     (format (current-error-port) (_ "Converting to `~a'...") pdf-name)
 318     (ly:system cmd)))
 319
 320 (define-public (postscript->png resolution name)
 321   (let
 322       ((cmd (string-append
 323            "ps2png --resolution="
 324            (if (number? resolution)
 325                (number->string resolution)
 326                "90 ")
 327            (if (ly:get-option 'verbose)
 328                "--verbose "
 329                " ")
 330            name)))
 331     (ly:system cmd)))
 332
 333 (define-public (lilypond-main files)
 334   "Entry point for LilyPond."
 335   (let* ((failed '())
 336          (handler (lambda (key arg) (set! failed (cons arg failed)))))
 337     (for-each
 338      (lambda (f)
 339        (catch 'ly-file-failed (lambda () (ly:parse-file f)) handler)
 340 ;;;       (dump-gc-protects)
 341        )
 342      files)
 343
 344     (if (pair? failed)
 345         (begin
 346           (newline (current-error-port))
 347           (display (_ "error: failed files: ") (current-error-port))
 348           (display (string-join failed) (current-error-port))
 349           (newline (current-error-port))
 350           (newline (current-error-port))
 351           (exit 1))
 352         (exit 0))))
 353
 354