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              (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 (define-public (line-column-location file line col)
  40   "Print an input location, including column number ."
  41   (string-append (number->string line) ":"
  42                  (number->string col) " " file))
  43
  44 (define-public (line-location  file line col)
  45   "Print an input location, without column number ."
  46   (string-append (number->string line) " " file))
  47
  48 (define-public point-and-click #f)
  49
  50 (define-public tex-backend?
  51   (member (ly:output-backend) '("texstr" "tex")))
  52
  53 (define-public parser #f)
  54
  55 (define-public (lilypond-version)
  56   (string-join
  57    (map (lambda (x) (if (symbol? x)
  58                         (symbol->string x)
  59                         (number->string x)))
  60         (ly:version))
  61    "."))
  62
  63
  64
  65 ;; cpp hack to get useful error message
  66 (define ifdef "First run this through cpp.")
  67 (define ifndef "First run this through cpp.")
  68
  69 ;; gettext wrapper for guile < 1.7.2
  70 (if (defined? 'gettext)
  71     (define-public _ gettext)
  72     (define-public _ ly:gettext))
  73
  74 (define-public (ly:load x)
  75   (let* ((fn (%search-load-path x)))
  76     (if (ly:get-option 'verbose)
  77         (format (current-error-port) "[~A]" fn))
  78     (primitive-load fn)))
  79
  80 (define-public TEX_STRING_HASHLIMIT 10000000)
  81
  82 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  83
  84 (define (type-check-list location signature arguments)
  85   "Typecheck a list of arguments against a list of type
  86 predicates. Print a message at LOCATION if any predicate failed."
  87   (define (recursion-helper signature arguments count)
  88     (define (helper pred? arg count)
  89       (if (not (pred? arg))
  90
  91           (begin
  92             (ly:input-message location
  93                               (format #f
  94                                       (_ "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     dashed-line
 129     dashed-slur
 130     dot
 131     draw-line
 132     ez-ball
 133     filledbox
 134     glyph-string
 135     horizontal-line
 136     named-glyph
 137     polygon
 138     repeat-slash
 139     round-filled-box
 140     text
 141     white-dot
 142     white-text
 143     embedded-ps
 144     zigzag-line))
 145
 146 ;; TODO:
 147 ;;  - generate this list by registering the output-backend-commands
 148 ;;    output-backend-commands should have docstrings.
 149 ;;  - remove hard copies in output-ps output-tex
 150 (define-public (ly:all-output-backend-commands)
 151   "Return list of output backend commands."
 152   '(
 153     comment
 154     grob-cause
 155     no-origin
 156     placebox
 157     unknown))
 158
 159 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 160 ;; Safe definitions utility
 161 (define safe-objects (list))
 162
 163 (define-macro (define-safe-public arglist . body)
 164   "Define a variable, export it, and mark it as safe, ie usable in LilyPond safe mode.
 165 The syntax is the same as `define*-public'."
 166   (define (get-symbol arg)
 167     (if (pair? arg)
 168         (get-symbol (car arg))
 169         arg))
 170   (let ((safe-symbol (get-symbol arglist)))
 171     `(begin
 172        (define*-public ,arglist
 173          ,@body)
 174        (set! safe-objects (cons (cons ',safe-symbol ,safe-symbol)
 175                                 safe-objects))
 176        ,safe-symbol)))
 177
 178
 179 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 180 ;; other files.
 181
 182 (for-each ly:load
 183           ;; load-from-path
 184           '("lily-library.scm"
 185             "file-cache.scm"
 186             "define-music-types.scm"
 187             "output-lib.scm"
 188             "c++.scm"
 189             "chord-ignatzek-names.scm"
 190             "chord-entry.scm"
 191             "chord-generic-names.scm"
 192             "stencil.scm"
 193             "new-markup.scm"
 194             "bass-figure.scm"
 195             "music-functions.scm"
 196             "part-combiner.scm"
 197             "define-music-properties.scm"
 198             "auto-beam.scm"
 199             "chord-name.scm"
 200
 201             "ly-from-scheme.scm"
 202
 203             "define-context-properties.scm"
 204             "translation-functions.scm"
 205             "script.scm"
 206             "midi.scm"
 207             "beam.scm"
 208             "clef.scm"
 209             "slur.scm"
 210             "font.scm"
 211             "encoding.scm"
 212
 213             "fret-diagrams.scm"
 214             "define-markup-commands.scm"
 215             "define-grob-properties.scm"
 216             "define-grobs.scm"
 217             "define-grob-interfaces.scm"
 218             "page-layout.scm"
 219             "titling.scm"
 220
 221             "paper.scm"
 222             "backend-library.scm"
 223                                         ; last:
 224             "safe-lily.scm"))
 225
 226
 227 (set! type-p-name-alist
 228       `(
 229         (,boolean-or-symbol? . "boolean or symbol")
 230         (,boolean? . "boolean")
 231         (,char? . "char")
 232         (,grob-list? . "list of grobs")
 233         (,hash-table? . "hash table")
 234         (,input-port? . "input port")
 235         (,integer? . "integer")
 236         (,list? . "list")
 237         (,ly:context? . "context")
 238         (,ly:dimension? . "dimension, in staff space")
 239         (,ly:dir? . "direction")
 240         (,ly:duration? . "duration")
 241         (,ly:grob? . "layout object")
 242         (,ly:input-location? . "input location")
 243         (,ly:moment? . "moment")
 244         (,ly:music? . "music")
 245         (,ly:pitch? . "pitch")
 246         (,ly:translator? . "translator")
 247         (,ly:font-metric? . "font metric")
 248         (,markup-list? . "list of markups")
 249         (,markup? . "markup")
 250         (,ly:music-list? . "list of music")
 251         (,number-or-grob? . "number or grob")
 252         (,number-or-string? . "number or string")
 253         (,number-pair? . "pair of numbers")
 254         (,number? . "number")
 255         (,output-port? . "output port")
 256         (,pair? . "pair")
 257         (,procedure? . "procedure")
 258         (,scheme? . "any type")
 259         (,string? . "string")
 260         (,symbol? . "symbol")
 261         (,vector? . "vector")))
 262
 263
 264 ;; debug mem leaks
 265
 266 (define gc-protect-stat-count 0)
 267 (define-public (dump-gc-protects)
 268   (set! gc-protect-stat-count (1+ gc-protect-stat-count))
 269   (let* ((protects (sort
 270                     (hash-table->alist (ly:protects))
 271                     (lambda (a b)
 272                       (< (object-address (car a))
 273                          (object-address (car b))))))
 274          (out-file-name (string-append
 275                          "gcstat-" (number->string gc-protect-stat-count)
 276                          ".scm"))
 277          (outfile    (open-file  out-file-name  "w")))
 278
 279     (display "Dumping gc protected objs to ...\n")
 280     (display
 281      (filter
 282       (lambda (x) (not (symbol? x)))
 283       (map (lambda (y)
 284              (let ((x (car y))
 285                    (c (cdr y)))
 286
 287                (string-append
 288                 (string-join
 289                  (map object->string (list (object-address x) c x))
 290                  " ")
 291                 "\n")))
 292            protects))
 293      outfile)))
 294
 295
 296 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 297
 298 (define-public (lilypond-main files)
 299   "Entry point for LilyPond."
 300   (let* ((failed '())
 301          (handler (lambda (key arg) (set! failed (cons arg failed)))))
 302     (for-each
 303      (lambda (f)
 304        (catch 'ly-file-failed (lambda () (ly:parse-file f)) handler)
 305        (if #f
 306            (dump-gc-protects)))
 307      files)
 308
 309     (if (pair? failed)
 310         (begin
 311           (newline (current-error-port))
 312           (display (_ "error: failed files: ") (current-error-port))
 313           (display (string-join failed) (current-error-port))
 314           (newline (current-error-port))
 315           (newline (current-error-port))
 316           (exit 1))
 317         (exit 0))))
 318
 319 (define-public (tweak-grob-property grob sym val)
 320   (set! (ly:grob-property grob sym) val))