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
  93              location
  94              (format
  95               #f (_ "wrong type for argument ~a.  Expecting ~a, found ~s")
  96               count (type-name pred?) arg))
  97             #f)
  98           #t))
  99
 100     (if (null? signature)
 101         #t
 102         (and (helper (car signature) (car arguments) count)
 103              (recursion-helper (cdr signature) (cdr arguments) (1+ count)))))
 104   (recursion-helper signature arguments 1))
 105
 106 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 107 ;;  output
 108
 109
 110 ;;(define-public (output-framework) (write "hello\n"))
 111
 112 (define output-tex-module
 113   (make-module 1021 (list (resolve-interface '(scm output-tex)))))
 114 (define output-ps-module
 115   (make-module 1021 (list (resolve-interface '(scm output-ps)))))
 116
 117 (define-public (ps-output-expression expr port)
 118   (display (eval expr output-ps-module) port))
 119
 120 ;; TODO: generate this list by registering the stencil expressions
 121 ;;       stencil expressions should have docstrings.
 122 (define-public (ly:all-stencil-expressions)
 123   "Return list of stencil expressions."
 124   '(beam
 125     bezier-sandwich
 126     blank
 127     bracket
 128     char
 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     white-dot
 143     white-text
 144     embedded-ps
 145     zigzag-line))
 146
 147 ;; TODO:
 148 ;;  - generate this list by registering the output-backend-commands
 149 ;;    output-backend-commands should have docstrings.
 150 ;;  - remove hard copies in output-ps output-tex
 151 (define-public (ly:all-output-backend-commands)
 152   "Return list of output backend commands."
 153   '(
 154     comment
 155     grob-cause
 156     no-origin
 157     placebox
 158     unknown))
 159
 160 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 161 ;; Safe definitions utility
 162 (define safe-objects (list))
 163
 164 (define-macro (define-safe-public arglist . body)
 165   "Define a variable, export it, and mark it as safe, ie usable in LilyPond safe mode.
 166 The syntax is the same as `define*-public'."
 167   (define (get-symbol arg)
 168     (if (pair? arg)
 169         (get-symbol (car arg))
 170         arg))
 171   (let ((safe-symbol (get-symbol arglist)))
 172     `(begin
 173        (define*-public ,arglist
 174          ,@body)
 175        (set! safe-objects (cons (cons ',safe-symbol ,safe-symbol)
 176                                 safe-objects))
 177        ,safe-symbol)))
 178
 179
 180 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 181 ;; other files.
 182
 183 (for-each ly:load
 184           ;; load-from-path
 185           '("lily-library.scm"
 186             "file-cache.scm"
 187             "define-music-types.scm"
 188             "output-lib.scm"
 189             "c++.scm"
 190             "chord-ignatzek-names.scm"
 191             "chord-entry.scm"
 192             "chord-generic-names.scm"
 193             "stencil.scm"
 194             "new-markup.scm"
 195             "bass-figure.scm"
 196             "music-functions.scm"
 197             "part-combiner.scm"
 198             "define-music-properties.scm"
 199             "auto-beam.scm"
 200             "chord-name.scm"
 201
 202             "ly-from-scheme.scm"
 203
 204             "define-context-properties.scm"
 205             "translation-functions.scm"
 206             "script.scm"
 207             "midi.scm"
 208             "beam.scm"
 209             "clef.scm"
 210             "slur.scm"
 211             "font.scm"
 212             "encoding.scm"
 213
 214             "fret-diagrams.scm"
 215             "define-markup-commands.scm"
 216             "define-grob-properties.scm"
 217             "define-grobs.scm"
 218             "define-grob-interfaces.scm"
 219             "page-layout.scm"
 220             "titling.scm"
 221
 222             "paper.scm"
 223             "backend-library.scm"
 224                                         ; last:
 225             "safe-lily.scm"))
 226
 227
 228 (set! type-p-name-alist
 229       `(
 230         (,boolean-or-symbol? . "boolean or symbol")
 231         (,boolean? . "boolean")
 232         (,char? . "char")
 233         (,grob-list? . "list of grobs")
 234         (,hash-table? . "hash table")
 235         (,input-port? . "input port")
 236         (,integer? . "integer")
 237         (,list? . "list")
 238         (,ly:context? . "context")
 239         (,ly:dimension? . "dimension, in staff space")
 240         (,ly:dir? . "direction")
 241         (,ly:duration? . "duration")
 242         (,ly:grob? . "layout object")
 243         (,ly:input-location? . "input location")
 244         (,ly:moment? . "moment")
 245         (,ly:music? . "music")
 246         (,ly:pitch? . "pitch")
 247         (,ly:translator? . "translator")
 248         (,ly:font-metric? . "font metric")
 249         (,markup-list? . "list of markups")
 250         (,markup? . "markup")
 251         (,ly:music-list? . "list of music")
 252         (,number-or-grob? . "number or grob")
 253         (,number-or-string? . "number or string")
 254         (,number-pair? . "pair of numbers")
 255         (,number? . "number")
 256         (,output-port? . "output port")
 257         (,pair? . "pair")
 258         (,procedure? . "procedure")
 259         (,scheme? . "any type")
 260         (,string? . "string")
 261         (,symbol? . "symbol")
 262         (,vector? . "vector")))
 263
 264
 265 ;; debug mem leaks
 266
 267 (define gc-protect-stat-count 0)
 268 (define-public (dump-gc-protects)
 269   (set! gc-protect-stat-count (1+ gc-protect-stat-count))
 270   (let* ((protects (sort
 271                     (hash-table->alist (ly:protects))
 272                     (lambda (a b)
 273                       (< (object-address (car a))
 274                          (object-address (car b))))))
 275          (out-file-name (string-append
 276                          "gcstat-" (number->string gc-protect-stat-count)
 277                          ".scm"))
 278          (outfile    (open-file  out-file-name  "w")))
 279
 280     (display "Dumping gc protected objs to ...\n")
 281     (display
 282      (filter
 283       (lambda (x) (not (symbol? x)))
 284       (map (lambda (y)
 285              (let ((x (car y))
 286                    (c (cdr y)))
 287
 288                (string-append
 289                 (string-join
 290                  (map object->string (list (object-address x) c x))
 291                  " ")
 292                 "\n")))
 293            protects))
 294      outfile)))
 295
 296
 297 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 298
 299 (define-public (lilypond-main files)
 300   "Entry point for LilyPond."
 301   (let* ((failed '())
 302          (handler (lambda (key arg) (set! failed (cons arg failed)))))
 303     (for-each
 304      (lambda (f)
 305        (catch 'ly-file-failed (lambda () (ly:parse-file f)) handler)
 306        (if #f
 307            (dump-gc-protects)))
 308      files)
 309
 310     (if (pair? failed)
 311         (begin
 312           (newline (current-error-port))
 313           (display (_ "error: failed files: ") (current-error-port))
 314           (display (string-join failed) (current-error-port))
 315           (newline (current-error-port))
 316           (newline (current-error-port))
 317           (exit 1))
 318         (exit 0))))
 319
 320 (define-public (tweak-grob-property grob sym val)
 321   (set! (ly:grob-property grob sym) val))