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