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
  23 (define-public (myd k v) (display k) (display ": ") (display v) (display ", "))
  24
  25 (define-public (print . args)
  26   (apply format (cons (current-output-port) args)))
  27
  28
  29 ;;; General settings
  30 ;;; debugging evaluator is slower.  This should
  31 ;;; have a more sensible default.
  32
  33 (if (ly:get-option 'verbose)
  34     (begin
  35       (debug-enable 'debug)
  36       (debug-enable 'backtrace)
  37       (read-enable 'positions)))
  38
  39 (define-public (line-column-location file line col)
  40   "Print an input location, including column number ."
  41   (string-append (number->string line) ":"
  42                  (number->string col) " " file))
  43
  44 (define-public (line-location  file line col)
  45   "Print an input location, without column number ."
  46   (string-append (number->string line) " " file))
  47
  48 (define-public point-and-click #f)
  49
  50 (define-public parser #f)
  51
  52 (define-public (lilypond-version)
  53   (string-join
  54    (map (lambda (x) (if (symbol? x)
  55                         (symbol->string x)
  56                         (number->string x)))
  57                 (ly:version))
  58    "."))
  59
  60
  61
  62 ;; cpp hack to get useful error message
  63 (define ifdef "First run this through cpp.")
  64 (define ifndef "First run this through cpp.")
  65
  66 ;; gettext wrapper for guile < 1.7.2
  67 (if (defined? 'gettext)
  68     (define-public _ gettext)
  69     (define-public _ ly:gettext))
  70
  71 (define-public (ly:load x)
  72   (let* ((fn (%search-load-path x)))
  73     (if (ly:get-option 'verbose)
  74         (format (current-error-port) "[~A]" fn))
  75     (primitive-load fn)))
  76
  77 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  78
  79 (define (type-check-list location signature arguments)
  80   "Typecheck a list of arguments against a list of type
  81 predicates. Print a message at LOCATION if any predicate failed."
  82   (define (recursion-helper signature arguments count)
  83     (define (helper pred? arg count)
  84       (if (not (pred? arg))
  85
  86           (begin
  87             (ly:input-message location
  88                               (format #f
  89                                       (_ "wrong type for argument ~a. Expecting ~a, found ~s")
  90                                       count (type-name pred?) arg))
  91             #f)
  92           #t))
  93
  94     (if (null? signature)
  95         #t
  96         (and (helper (car signature) (car arguments) count)
  97              (recursion-helper (cdr signature) (cdr arguments) (1+ count)))
  98         ))
  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     horizontal-line
 131     polygon
 132     repeat-slash
 133     round-filled-box
 134     text
 135     white-dot
 136     white-text
 137     zigzag-line
 138     ))
 139
 140 ;; TODO:
 141 ;;  - generate this list by registering the output-backend-commands
 142 ;;    output-backend-commands should have docstrings.
 143 ;;  - remove hard copies in output-ps output-tex
 144 (define-public (ly:all-output-backend-commands)
 145   "Return list of output backend commands."
 146   '(
 147     comment
 148     grob-cause
 149     no-origin
 150     placebox
 151     unknown
 152     ))
 153
 154 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 155 ;; other files.
 156
 157 (for-each ly:load
 158      ;; load-from-path
 159      '("lily-library.scm"
 160        "define-music-types.scm"
 161        "output-lib.scm"
 162        "c++.scm"
 163        "chord-ignatzek-names.scm"
 164        "chord-entry.scm"
 165        "chord-generic-names.scm"
 166        "stencil.scm"
 167        "new-markup.scm"
 168        "bass-figure.scm"
 169        "music-functions.scm"
 170        "part-combiner.scm"
 171        "define-music-properties.scm"
 172        "auto-beam.scm"
 173        "chord-name.scm"
 174
 175        "ly-from-scheme.scm"
 176
 177        "define-context-properties.scm"
 178        "translation-functions.scm"
 179        "script.scm"
 180        "midi.scm"
 181        "beam.scm"
 182        "clef.scm"
 183        "slur.scm"
 184        "font.scm"
 185        "encoding.scm"
 186
 187        "fret-diagrams.scm"
 188        "define-markup-commands.scm"
 189        "define-grob-properties.scm"
 190        "define-grobs.scm"
 191        "define-grob-interfaces.scm"
 192        "page-layout.scm"
 193        "titling.scm"
 194
 195        "paper.scm"
 196
 197        ; last:
 198        "safe-lily.scm"
 199        ))
 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
 240 ;; debug mem leaks
 241
 242 (define gc-protect-stat-count 0)
 243 (define-public (dump-gc-protects)
 244   (set! gc-protect-stat-count (1+ gc-protect-stat-count) )
 245   (let*
 246       ((protects (sort
 247            (hash-table->alist (ly:protects))
 248            (lambda (a b)
 249              (< (object-address (car a))
 250                 (object-address (car b))))))
 251        (outfile    (open-file (string-append
 252                "gcstat-" (number->string gc-protect-stat-count)
 253                ".scm"
 254                ) "w")))
 255
 256     (display "DUMPING...\n")
 257     (display
 258      (filter
 259       (lambda (x) (not (symbol? x)))
 260       (map (lambda (y)
 261              (let
 262                  ((x (car y))
 263                   (c (cdr y)))
 264
 265                (string-append
 266                 (string-join
 267                  (map object->string (list (object-address x) c x))
 268                  " ")
 269                 "\n")))
 270            protects))
 271      outfile)))
 272
 273
 274 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 275
 276 (define-public (ly:system command)
 277   (let*
 278       ((status 0)
 279
 280        (silenced
 281         (string-append command (if (ly:get-option 'verbose)
 282                                  ""
 283                                  " > /dev/null 2>&1 "))))
 284
 285     (if (ly:get-option 'verbose)
 286         (format  (current-error-port) (_ "Invoking `~a'...\n") command))
 287
 288     (set! status (system silenced))
 289     (if (> status 0)
 290         (begin
 291           (format (current-error-port)
 292                   (_ "Error invoking `~a'. Return value ~a") silenced status)
 293           (newline (current-error-port))))))
 294
 295 (define-public (sanitize-command-option str)
 296   (string-append
 297    "\""
 298    (regexp-substitute/global #f "[^- 0-9,.a-zA-Z'\"\\]" str 'pre 'post)
 299   "\""))
 300
 301 (define-public (postscript->pdf papersizename name)
 302   (let* ((cmd (string-append "ps2pdf "
 303                              (string-append
 304                               " -sPAPERSIZE="
 305                               (sanitize-command-option papersizename)
 306                               " "
 307                              name)))
 308          (pdf-name (string-append (basename name ".ps") ".pdf" )))
 309
 310     (if (access? pdf-name W_OK)
 311         (delete-file pdf-name))
 312
 313     (format (current-error-port) (_ "Converting to `~a'...") pdf-name)
 314     (ly:system cmd)))
 315
 316 (define-public (postscript->png resolution name)
 317   (let
 318       ((cmd (string-append
 319            "ps2png --resolution="
 320            (if (number? resolution)
 321                (number->string resolution)
 322                "90 ")
 323            (if (ly:get-option 'verbose)
 324                "--verbose "
 325                " ")
 326            name)))
 327     (ly:system cmd)))
 328
 329 (define-public (lilypond-main files)
 330   "Entry point for LilyPond."
 331   (let* ((failed '())
 332          (handler (lambda (key arg) (set! failed (cons arg failed)))))
 333     (for-each
 334      (lambda (f)
 335        (catch 'ly-file-failed (lambda () (ly:parse-file f)) handler)
 336 ;;;       (dump-gc-protects)
 337        )
 338      files)
 339
 340     (if (pair? failed)
 341         (begin
 342           (newline (current-error-port))
 343           (display (_ "error: failed files: ") (current-error-port))
 344           (display (string-join failed) (current-error-port))
 345           (newline (current-error-port))
 346           (newline (current-error-port))
 347           (exit 1))
 348         (exit 0))))
 349
 350
 351 (define-public (tweak-grob-property grob sym val)
 352     (set! (ly:grob-property grob sym) val))