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