scm/lily.scm

   1 ;;;; lily.scm -- toplevel Scheme stuff
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c) 1998--2005 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! 1000)
  13
  14 (use-modules (ice-9 regex)
  15              (ice-9 safe)
  16              (ice-9 optargs)
  17              (oop goops)
  18              (srfi srfi-1)  ; lists
  19              (srfi srfi-13)) ; strings
  20
  21
  22 ;; my display
  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
  40
  41 ;; initialize defaults.
  42 (ly:set-option 'command-line-settings
  43                '((resolution . 90)
  44                  (preview-include-book-title . #t)
  45                  ))
  46
  47 (define-public tex-backend?
  48   (member (ly:output-backend) '("texstr" "tex")))
  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* ((file-name (%search-load-path x)))
  73     (if (ly:get-option 'verbose)
  74         (ly:progress "[~A" file-name))
  75     (primitive-load file-name)
  76     (if (ly:get-option 'verbose)
  77         (ly:progress "]"))))
  78
  79 (define-public TEX_STRING_HASHLIMIT 10000000)
  80
  81 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  82
  83 (define (type-check-list location signature arguments)
  84   "Typecheck a list of arguments against a list of type
  85 predicates. Print a message at LOCATION if any predicate failed."
  86   (define (recursion-helper signature arguments count)
  87     (define (helper pred? arg count)
  88       (if (not (pred? arg))
  89
  90           (begin
  91             (ly:input-message
  92              location
  93              (format
  94               #f (_ "wrong type for argument ~a.  Expecting ~a, found ~s")
  95               count (type-name pred?) arg))
  96             #f)
  97           #t))
  98
  99     (if (null? signature)
 100         #t
 101         (and (helper (car signature) (car arguments) count)
 102              (recursion-helper (cdr signature) (cdr arguments) (1+ count)))))
 103   (recursion-helper signature arguments 1))
 104
 105 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 106 ;;  output
 107
 108
 109 ;;(define-public (output-framework) (write "hello\n"))
 110
 111 (define output-tex-module
 112   (make-module 1021 (list (resolve-interface '(scm output-tex)))))
 113 (define output-ps-module
 114   (make-module 1021 (list (resolve-interface '(scm output-ps)))))
 115
 116 (define-public (ps-output-expression expr port)
 117   (display (eval expr output-ps-module) port))
 118
 119 ;; TODO: generate this list by registering the stencil expressions
 120 ;;       stencil expressions should have docstrings.
 121 (define-public (ly:all-stencil-expressions)
 122   "Return list of stencil expressions."
 123   '(beam
 124     bezier-sandwich
 125     blank
 126     bracket
 127     char
 128     circle
 129     dashed-line
 130     dashed-slur
 131     dot
 132     draw-line
 133     ez-ball
 134     filledbox
 135     glyph-string
 136     horizontal-line
 137     named-glyph
 138     polygon
 139     repeat-slash
 140     round-filled-box
 141     text
 142     url-link
 143     utf8-string
 144     white-dot
 145     white-text
 146     embedded-ps
 147     zigzag-line))
 148
 149 ;; TODO:
 150 ;;  - generate this list by registering the output-backend-commands
 151 ;;    output-backend-commands should have docstrings.
 152 ;;  - remove hard copies in output-ps output-tex
 153 (define-public (ly:all-output-backend-commands)
 154   "Return list of output backend commands."
 155   '(
 156     comment
 157     grob-cause
 158     no-origin
 159     placebox
 160     unknown))
 161
 162 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 163 ;; Safe definitions utility
 164 (define safe-objects (list))
 165
 166 (define-macro (define-safe-public arglist . body)
 167   "Define a variable, export it, and mark it as safe, ie usable in LilyPond safe mode.
 168 The syntax is the same as `define*-public'."
 169   (define (get-symbol arg)
 170     (if (pair? arg)
 171         (get-symbol (car arg))
 172         arg))
 173   (let ((safe-symbol (get-symbol arglist)))
 174     `(begin
 175        (define*-public ,arglist
 176          ,@body)
 177        (set! safe-objects (cons (cons ',safe-symbol ,safe-symbol)
 178                                 safe-objects))
 179        ,safe-symbol)))
 180
 181
 182 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 183 ;; other files.
 184
 185 (for-each ly:load
 186           ;; load-from-path
 187           '("lily-library.scm"
 188             "file-cache.scm"
 189             "define-music-types.scm"
 190             "output-lib.scm"
 191             "c++.scm"
 192             "chord-ignatzek-names.scm"
 193             "chord-entry.scm"
 194             "chord-generic-names.scm"
 195             "stencil.scm"
 196             "markup.scm"
 197             "bass-figure.scm"
 198             "music-functions.scm"
 199             "part-combiner.scm"
 200             "define-music-properties.scm"
 201             "auto-beam.scm"
 202             "chord-name.scm"
 203
 204             "ly-from-scheme.scm"
 205
 206             "define-context-properties.scm"
 207             "translation-functions.scm"
 208             "script.scm"
 209             "midi.scm"
 210             "beam.scm"
 211             "clef.scm"
 212             "slur.scm"
 213             "font.scm"
 214             "encoding.scm"
 215
 216             "fret-diagrams.scm"
 217             "define-markup-commands.scm"
 218             "define-grob-properties.scm"
 219             "define-grobs.scm"
 220             "define-grob-interfaces.scm"
 221             "page-layout.scm"
 222             "titling.scm"
 223
 224             "paper.scm"
 225             "backend-library.scm"
 226             "x11-color.scm"
 227
 228             ;; must be after everything has been defined
 229             "safe-lily.scm"))
 230
 231
 232 (set! type-p-name-alist
 233       `(
 234         (,boolean-or-symbol? . "boolean or symbol")
 235         (,boolean? . "boolean")
 236         (,char? . "char")
 237         (,grob-list? . "list of grobs")
 238         (,hash-table? . "hash table")
 239         (,input-port? . "input port")
 240         (,integer? . "integer")
 241         (,list? . "list")
 242         (,ly:context? . "context")
 243         (,ly:dimension? . "dimension, in staff space")
 244         (,ly:dir? . "direction")
 245         (,ly:duration? . "duration")
 246         (,ly:grob? . "layout object")
 247         (,ly:input-location? . "input location")
 248         (,ly:moment? . "moment")
 249         (,ly:music? . "music")
 250         (,ly:pitch? . "pitch")
 251         (,ly:translator? . "translator")
 252         (,ly:font-metric? . "font metric")
 253         (,markup-list? . "list of markups")
 254         (,markup? . "markup")
 255         (,ly:music-list? . "list of music")
 256         (,number-or-grob? . "number or grob")
 257         (,number-or-string? . "number or string")
 258         (,number-pair? . "pair of numbers")
 259         (,number? . "number")
 260         (,output-port? . "output port")
 261         (,pair? . "pair")
 262         (,procedure? . "procedure")
 263         (,scheme? . "any type")
 264         (,string? . "string")
 265         (,symbol? . "symbol")
 266         (,vector? . "vector")))
 267
 268
 269 ;; debug mem leaks
 270
 271 (define gc-protect-stat-count 0)
 272 (define-public (dump-gc-protects)
 273   (set! gc-protect-stat-count (1+ gc-protect-stat-count))
 274   (let* ((protects (sort
 275                     (hash-table->alist (ly:protects))
 276                     (lambda (a b)
 277                       (< (object-address (car a))
 278                          (object-address (car b))))))
 279          (out-file-name (string-append
 280                          "gcstat-" (number->string gc-protect-stat-count)
 281                          ".scm"))
 282          (outfile    (open-file  out-file-name  "w")))
 283
 284     (display "Dumping gc protected objs to ...\n")
 285     (display
 286      (filter
 287       (lambda (x) (not (symbol? x)))
 288       (map (lambda (y)
 289              (let ((x (car y))
 290                    (c (cdr y)))
 291
 292                (string-append
 293                 (string-join
 294                  (map object->string (list (object-address x) c x))
 295                  " ")
 296                 "\n")))
 297            protects))
 298      outfile)))
 299
 300
 301 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 302
 303 (define-public (lilypond-main files)
 304   "Entry point for LilyPond."
 305   (let* ((failed '())
 306          (handler (lambda (key failed-file)
 307              (set! failed (append (list failed-file) failed)))))
 308          ;;(handler (lambda (key . arg) (set! failed (append arg failed)))))
 309     (for-each
 310      (lambda (f)
 311        (catch 'ly-file-failed
 312               (lambda () (ly:parse-file f))
 313               (lambda (x . args) (handler x f)))
 314               ;;(lambda (x) (handler x f)))
 315        (if #f
 316            (dump-gc-protects)))
 317      files)
 318
 319     (if (pair? failed)
 320         (begin
 321           (ly:error (_ "failed files: ~S") (string-join failed))
 322           (exit 1))
 323         (begin
 324           ;; HACK: be sure to exit with single newline
 325           (ly:message "")
 326           (exit 0)))))
 327
 328 (define-public (tweak-grob-property grob sym val)
 329   (set! (ly:grob-property grob sym) val))