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 (define-public TEX_STRING_HASHLIMIT 10000000)
  77
  78 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  79
  80 (define (type-check-list location signature arguments)
  81   "Typecheck a list of arguments against a list of type
  82 predicates. Print a message at LOCATION if any predicate failed."
  83   (define (recursion-helper signature arguments count)
  84     (define (helper pred? arg count)
  85       (if (not (pred? arg))
  86
  87           (begin
  88             (ly:input-message location
  89                               (format #f
  90                                       (_ "wrong type for argument ~a. Expecting ~a, found ~s")
  91                                       count (type-name pred?) arg))
  92             #f)
  93           #t))
  94
  95     (if (null? signature)
  96         #t
  97         (and (helper (car signature) (car arguments) count)
  98              (recursion-helper (cdr signature) (cdr arguments) (1+ count)))))
  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     glyph-string
 131     horizontal-line
 132     named-glyph
 133     polygon
 134     repeat-slash
 135     round-filled-box
 136     text
 137     white-dot
 138     white-text
 139     embedded-ps
 140     zigzag-line))
 141
 142 ;; TODO:
 143 ;;  - generate this list by registering the output-backend-commands
 144 ;;    output-backend-commands should have docstrings.
 145 ;;  - remove hard copies in output-ps output-tex
 146 (define-public (ly:all-output-backend-commands)
 147   "Return list of output backend commands."
 148   '(
 149     comment
 150     grob-cause
 151     no-origin
 152     placebox
 153     unknown))
 154
 155 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 156 ;; other files.
 157
 158 (for-each ly:load
 159           ;; load-from-path
 160           '("lily-library.scm"
 161             "define-music-types.scm"
 162             "output-lib.scm"
 163             "c++.scm"
 164             "chord-ignatzek-names.scm"
 165             "chord-entry.scm"
 166             "chord-generic-names.scm"
 167             "stencil.scm"
 168             "new-markup.scm"
 169             "bass-figure.scm"
 170             "music-functions.scm"
 171             "part-combiner.scm"
 172             "define-music-properties.scm"
 173             "auto-beam.scm"
 174             "chord-name.scm"
 175
 176             "ly-from-scheme.scm"
 177
 178             "define-context-properties.scm"
 179             "translation-functions.scm"
 180             "script.scm"
 181             "midi.scm"
 182             "beam.scm"
 183             "clef.scm"
 184             "slur.scm"
 185             "font.scm"
 186             "encoding.scm"
 187
 188             "fret-diagrams.scm"
 189             "define-markup-commands.scm"
 190             "define-grob-properties.scm"
 191             "define-grobs.scm"
 192             "define-grob-interfaces.scm"
 193             "page-layout.scm"
 194             "titling.scm"
 195
 196             "paper.scm"
 197
 198                                         ; last:
 199             "safe-lily.scm"))
 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 ;; debug mem leaks
 240
 241 (define gc-protect-stat-count 0)
 242 (define-public (dump-gc-protects)
 243   (set! gc-protect-stat-count (1+ gc-protect-stat-count))
 244   (let* ((protects (sort
 245                     (hash-table->alist (ly:protects))
 246                     (lambda (a b)
 247                       (< (object-address (car a))
 248                          (object-address (car b))))))
 249          (out-file-name (string-append
 250                          "gcstat-" (number->string gc-protect-stat-count)
 251                          ".scm"))
 252          (outfile    (open-file  out-file-name  "w")))
 253
 254     (display "Dumping gc protected objs to ...\n")
 255     (display
 256      (filter
 257       (lambda (x) (not (symbol? x)))
 258       (map (lambda (y)
 259              (let ((x (car y))
 260                    (c (cdr y)))
 261
 262                (string-append
 263                 (string-join
 264                  (map object->string (list (object-address x) c x))
 265                  " ")
 266                 "\n")))
 267            protects))
 268      outfile)))
 269
 270
 271 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 272
 273 (define-public (ly:system command)
 274   (let* ((status 0)
 275
 276          (silenced
 277           (string-append command (if (ly:get-option 'verbose)
 278                                      ""
 279                                      " > /dev/null 2>&1 "))))
 280
 281     (if (ly:get-option 'verbose)
 282         (format  (current-error-port) (_ "Invoking `~a'...\n") command))
 283
 284     (set! status (system silenced))
 285     (if (> status 0)
 286         (begin
 287           (format (current-error-port)
 288                   (_ "Error invoking `~a'. Return value ~a") silenced status)
 289           (newline (current-error-port))))))
 290
 291 (define-public (sanitize-command-option str)
 292   (string-append
 293    "\""
 294    (regexp-substitute/global #f "[^- 0-9,.a-zA-Z'\"\\]" str 'pre 'post)
 295    "\""))
 296
 297 (define-public (postscript->pdf papersizename name)
 298   (let* ((cmd (string-append "ps2pdf "
 299                              (string-append
 300                               " -sPAPERSIZE="
 301                               (sanitize-command-option papersizename)
 302                               " "
 303                               name)))
 304          (pdf-name (string-append (basename name ".ps") ".pdf" )))
 305
 306     (if (access? pdf-name W_OK)
 307         (delete-file pdf-name))
 308
 309     (format (current-error-port) (_ "Converting to `~a'...") pdf-name)
 310     (ly:system cmd)))
 311
 312 (define-public (postscript->png resolution name)
 313   (let ((cmd (string-append
 314               "ps2png --resolution="
 315               (if (number? resolution)
 316                   (number->string resolution)
 317                   "90 ")
 318               (if (ly:get-option 'verbose)
 319                   "--verbose "
 320                   " ")
 321               name)))
 322     (ly:system cmd)))
 323
 324 (define-public (lilypond-main files)
 325   "Entry point for LilyPond."
 326   (let* ((failed '())
 327          (handler (lambda (key arg) (set! failed (cons arg failed)))))
 328     (for-each
 329      (lambda (f)
 330        (catch 'ly-file-failed (lambda () (ly:parse-file f)) handler)
 331        (if #f
 332            (dump-gc-protects)))
 333      files)
 334
 335     (if (pair? failed)
 336         (begin
 337           (newline (current-error-port))
 338           (display (_ "error: failed files: ") (current-error-port))
 339           (display (string-join failed) (current-error-port))
 340           (newline (current-error-port))
 341           (newline (current-error-port))
 342           (exit 1))
 343         (exit 0))))
 344
 345 (define-public (tweak-grob-property grob sym val)
 346   (set! (ly:grob-property grob sym) val))