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