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