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