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