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 tex-backend?
  50   (member (ly:output-backend) '("texstr" "tex")))
  51
  52 (define-public parser #f)
  53
  54 (define-public (lilypond-version)
  55   (string-join
  56    (map (lambda (x) (if (symbol? x)
  57                         (symbol->string x)
  58                         (number->string x)))
  59         (ly:version))
  60    "."))
  61
  62
  63
  64 ;; cpp hack to get useful error message
  65 (define ifdef "First run this through cpp.")
  66 (define ifndef "First run this through cpp.")
  67
  68 ;; gettext wrapper for guile < 1.7.2
  69 (if (defined? 'gettext)
  70     (define-public _ gettext)
  71     (define-public _ ly:gettext))
  72
  73 (define-public (ly:load x)
  74   (let* ((fn (%search-load-path x)))
  75     (if (ly:get-option 'verbose)
  76         (format (current-error-port) "[~A]" fn))
  77     (primitive-load fn)))
  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 location
  92                               (format #f
  93                                       (_ "wrong type for argument ~a. Expecting ~a, found ~s")
  94                                       count (type-name pred?) arg))
  95             #f)
  96           #t))
  97
  98     (if (null? signature)
  99         #t
 100         (and (helper (car signature) (car arguments) count)
 101              (recursion-helper (cdr signature) (cdr arguments) (1+ count)))))
 102   (recursion-helper signature arguments 1))
 103
 104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 105 ;;  output
 106
 107
 108 ;;(define-public (output-framework) (write "hello\n"))
 109
 110 (define output-tex-module
 111   (make-module 1021 (list (resolve-interface '(scm output-tex)))))
 112 (define output-ps-module
 113   (make-module 1021 (list (resolve-interface '(scm output-ps)))))
 114
 115 (define-public (ps-output-expression expr port)
 116   (display (eval expr output-ps-module) port))
 117
 118 ;; TODO: generate this list by registering the stencil expressions
 119 ;;       stencil expressions should have docstrings.
 120 (define-public (ly:all-stencil-expressions)
 121   "Return list of stencil expressions."
 122   '(beam
 123     bezier-sandwich
 124     blank
 125     bracket
 126     char
 127     dashed-line
 128     dashed-slur
 129     dot
 130     draw-line
 131     ez-ball
 132     filledbox
 133     glyph-string
 134     horizontal-line
 135     named-glyph
 136     polygon
 137     repeat-slash
 138     round-filled-box
 139     text
 140     white-dot
 141     white-text
 142     embedded-ps
 143     zigzag-line))
 144
 145 ;; TODO:
 146 ;;  - generate this list by registering the output-backend-commands
 147 ;;    output-backend-commands should have docstrings.
 148 ;;  - remove hard copies in output-ps output-tex
 149 (define-public (ly:all-output-backend-commands)
 150   "Return list of output backend commands."
 151   '(
 152     comment
 153     grob-cause
 154     no-origin
 155     placebox
 156     unknown))
 157
 158 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 159 ;; other files.
 160
 161 (for-each ly:load
 162           ;; load-from-path
 163           '("lily-library.scm"
 164             "define-music-types.scm"
 165             "output-lib.scm"
 166             "c++.scm"
 167             "chord-ignatzek-names.scm"
 168             "chord-entry.scm"
 169             "chord-generic-names.scm"
 170             "stencil.scm"
 171             "new-markup.scm"
 172             "bass-figure.scm"
 173             "music-functions.scm"
 174             "part-combiner.scm"
 175             "define-music-properties.scm"
 176             "auto-beam.scm"
 177             "chord-name.scm"
 178
 179             "ly-from-scheme.scm"
 180
 181             "define-context-properties.scm"
 182             "translation-functions.scm"
 183             "script.scm"
 184             "midi.scm"
 185             "beam.scm"
 186             "clef.scm"
 187             "slur.scm"
 188             "font.scm"
 189             "encoding.scm"
 190
 191             "fret-diagrams.scm"
 192             "define-markup-commands.scm"
 193             "define-grob-properties.scm"
 194             "define-grobs.scm"
 195             "define-grob-interfaces.scm"
 196             "page-layout.scm"
 197             "titling.scm"
 198
 199             "paper.scm"
 200             "backend-library.scm"
 201                                         ; last:
 202             "safe-lily.scm"))
 203
 204
 205 (set! type-p-name-alist
 206       `(
 207         (,boolean-or-symbol? . "boolean or symbol")
 208         (,boolean? . "boolean")
 209         (,char? . "char")
 210         (,grob-list? . "list of grobs")
 211         (,hash-table? . "hash table")
 212         (,input-port? . "input port")
 213         (,integer? . "integer")
 214         (,list? . "list")
 215         (,ly:context? . "context")
 216         (,ly:dimension? . "dimension, in staff space")
 217         (,ly:dir? . "direction")
 218         (,ly:duration? . "duration")
 219         (,ly:grob? . "layout object")
 220         (,ly:input-location? . "input location")
 221         (,ly:moment? . "moment")
 222         (,ly:music? . "music")
 223         (,ly:pitch? . "pitch")
 224         (,ly:translator? . "translator")
 225         (,ly:font-metric? . "font metric")
 226         (,markup-list? . "list of markups")
 227         (,markup? . "markup")
 228         (,ly:music-list? . "list of music")
 229         (,number-or-grob? . "number or grob")
 230         (,number-or-string? . "number or string")
 231         (,number-pair? . "pair of numbers")
 232         (,number? . "number")
 233         (,output-port? . "output port")
 234         (,pair? . "pair")
 235         (,procedure? . "procedure")
 236         (,scheme? . "any type")
 237         (,string? . "string")
 238         (,symbol? . "symbol")
 239         (,vector? . "vector")))
 240
 241
 242 ;; debug mem leaks
 243
 244 (define gc-protect-stat-count 0)
 245 (define-public (dump-gc-protects)
 246   (set! gc-protect-stat-count (1+ gc-protect-stat-count))
 247   (let* ((protects (sort
 248                     (hash-table->alist (ly:protects))
 249                     (lambda (a b)
 250                       (< (object-address (car a))
 251                          (object-address (car b))))))
 252          (out-file-name (string-append
 253                          "gcstat-" (number->string gc-protect-stat-count)
 254                          ".scm"))
 255          (outfile    (open-file  out-file-name  "w")))
 256
 257     (display "Dumping gc protected objs to ...\n")
 258     (display
 259      (filter
 260       (lambda (x) (not (symbol? x)))
 261       (map (lambda (y)
 262              (let ((x (car y))
 263                    (c (cdr y)))
 264
 265                (string-append
 266                 (string-join
 267                  (map object->string (list (object-address x) c x))
 268                  " ")
 269                 "\n")))
 270            protects))
 271      outfile)))
 272
 273
 274 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 275
 276 (define-public (lilypond-main files)
 277   "Entry point for LilyPond."
 278   (let* ((failed '())
 279          (handler (lambda (key arg) (set! failed (cons arg failed)))))
 280     (for-each
 281      (lambda (f)
 282        (catch 'ly-file-failed (lambda () (ly:parse-file f)) handler)
 283        (if #f
 284            (dump-gc-protects)))
 285      files)
 286
 287     (if (pair? failed)
 288         (begin
 289           (newline (current-error-port))
 290           (display (_ "error: failed files: ") (current-error-port))
 291           (display (string-join failed) (current-error-port))
 292           (newline (current-error-port))
 293           (newline (current-error-port))
 294           (exit 1))
 295         (exit 0))))
 296
 297 (define-public (tweak-grob-property grob sym val)
 298   (set! (ly:grob-property grob sym) val))