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! 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             "file-cache.scm"
 165             "define-music-types.scm"
 166             "output-lib.scm"
 167             "c++.scm"
 168             "chord-ignatzek-names.scm"
 169             "chord-entry.scm"
 170             "chord-generic-names.scm"
 171             "stencil.scm"
 172             "new-markup.scm"
 173             "bass-figure.scm"
 174             "music-functions.scm"
 175             "part-combiner.scm"
 176             "define-music-properties.scm"
 177             "auto-beam.scm"
 178             "chord-name.scm"
 179
 180             "ly-from-scheme.scm"
 181
 182             "define-context-properties.scm"
 183             "translation-functions.scm"
 184             "script.scm"
 185             "midi.scm"
 186             "beam.scm"
 187             "clef.scm"
 188             "slur.scm"
 189             "font.scm"
 190             "encoding.scm"
 191
 192             "fret-diagrams.scm"
 193             "define-markup-commands.scm"
 194             "define-grob-properties.scm"
 195             "define-grobs.scm"
 196             "define-grob-interfaces.scm"
 197             "page-layout.scm"
 198             "titling.scm"
 199
 200             "paper.scm"
 201             "backend-library.scm"
 202                                         ; last:
 203             "safe-lily.scm"))
 204
 205
 206 (set! type-p-name-alist
 207       `(
 208         (,boolean-or-symbol? . "boolean or symbol")
 209         (,boolean? . "boolean")
 210         (,char? . "char")
 211         (,grob-list? . "list of grobs")
 212         (,hash-table? . "hash table")
 213         (,input-port? . "input port")
 214         (,integer? . "integer")
 215         (,list? . "list")
 216         (,ly:context? . "context")
 217         (,ly:dimension? . "dimension, in staff space")
 218         (,ly:dir? . "direction")
 219         (,ly:duration? . "duration")
 220         (,ly:grob? . "layout object")
 221         (,ly:input-location? . "input location")
 222         (,ly:moment? . "moment")
 223         (,ly:music? . "music")
 224         (,ly:pitch? . "pitch")
 225         (,ly:translator? . "translator")
 226         (,ly:font-metric? . "font metric")
 227         (,markup-list? . "list of markups")
 228         (,markup? . "markup")
 229         (,ly:music-list? . "list of music")
 230         (,number-or-grob? . "number or grob")
 231         (,number-or-string? . "number or string")
 232         (,number-pair? . "pair of numbers")
 233         (,number? . "number")
 234         (,output-port? . "output port")
 235         (,pair? . "pair")
 236         (,procedure? . "procedure")
 237         (,scheme? . "any type")
 238         (,string? . "string")
 239         (,symbol? . "symbol")
 240         (,vector? . "vector")))
 241
 242
 243 ;; debug mem leaks
 244
 245 (define gc-protect-stat-count 0)
 246 (define-public (dump-gc-protects)
 247   (set! gc-protect-stat-count (1+ gc-protect-stat-count))
 248   (let* ((protects (sort
 249                     (hash-table->alist (ly:protects))
 250                     (lambda (a b)
 251                       (< (object-address (car a))
 252                          (object-address (car b))))))
 253          (out-file-name (string-append
 254                          "gcstat-" (number->string gc-protect-stat-count)
 255                          ".scm"))
 256          (outfile    (open-file  out-file-name  "w")))
 257
 258     (display "Dumping gc protected objs to ...\n")
 259     (display
 260      (filter
 261       (lambda (x) (not (symbol? x)))
 262       (map (lambda (y)
 263              (let ((x (car y))
 264                    (c (cdr y)))
 265
 266                (string-append
 267                 (string-join
 268                  (map object->string (list (object-address x) c x))
 269                  " ")
 270                 "\n")))
 271            protects))
 272      outfile)))
 273
 274
 275 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 276
 277 (define-public (lilypond-main files)
 278   "Entry point for LilyPond."
 279   (let* ((failed '())
 280          (handler (lambda (key arg) (set! failed (cons arg failed)))))
 281     (for-each
 282      (lambda (f)
 283        (catch 'ly-file-failed (lambda () (ly:parse-file f)) handler)
 284        (if #f
 285            (dump-gc-protects)))
 286      files)
 287
 288     (if (pair? failed)
 289         (begin
 290           (newline (current-error-port))
 291           (display (_ "error: failed files: ") (current-error-port))
 292           (display (string-join failed) (current-error-port))
 293           (newline (current-error-port))
 294           (newline (current-error-port))
 295           (exit 1))
 296         (exit 0))))
 297
 298 (define-public (tweak-grob-property grob sym val)
 299   (set! (ly:grob-property grob sym) val))