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! 1000)
  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 ;; initialize defaults.
  40 (ly:set-option 'command-line-settings
  41                '((resolution . 90)
  42                  (preview-include-book-title . #t)
  43                  ))
  44
  45 (define-public tex-backend?
  46   (member (ly:output-backend) '("texstr" "tex")))
  47
  48 (define-public parser #f)
  49
  50 (define-public (lilypond-version)
  51   (string-join
  52    (map (lambda (x) (if (symbol? x)
  53                         (symbol->string x)
  54                         (number->string x)))
  55         (ly:version))
  56    "."))
  57
  58
  59
  60 ;; cpp hack to get useful error message
  61 (define ifdef "First run this through cpp.")
  62 (define ifndef "First run this through cpp.")
  63
  64 ;; gettext wrapper for guile < 1.7.2
  65 (if (defined? 'gettext)
  66     (define-public _ gettext)
  67     (define-public _ ly:gettext))
  68
  69 (define-public (ly:load x)
  70   (let* ((file-name (%search-load-path x)))
  71     (if (ly:get-option 'verbose)
  72         (ly:progress "[~A" file-name))
  73     (primitive-load file-name)
  74     (if (ly:get-option 'verbose)
  75         (ly:progress "]"))))
  76
  77 (define-public TEX_STRING_HASHLIMIT 10000000)
  78
  79 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  80
  81 (define (type-check-list location signature arguments)
  82   "Typecheck a list of arguments against a list of type
  83 predicates. Print a message at LOCATION if any predicate failed."
  84   (define (recursion-helper signature arguments count)
  85     (define (helper pred? arg count)
  86       (if (not (pred? arg))
  87
  88           (begin
  89             (ly:input-message
  90              location
  91              (format
  92               #f (_ "wrong type for argument ~a.  Expecting ~a, found ~s")
  93               count (type-name pred?) arg))
  94             #f)
  95           #t))
  96
  97     (if (null? signature)
  98         #t
  99         (and (helper (car signature) (car arguments) count)
 100              (recursion-helper (cdr signature) (cdr arguments) (1+ count)))))
 101   (recursion-helper signature arguments 1))
 102
 103 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 104 ;;  output
 105
 106
 107 ;;(define-public (output-framework) (write "hello\n"))
 108
 109 (define output-tex-module
 110   (make-module 1021 (list (resolve-interface '(scm output-tex)))))
 111 (define output-ps-module
 112   (make-module 1021 (list (resolve-interface '(scm output-ps)))))
 113
 114 (define-public (ps-output-expression expr port)
 115   (display (eval expr output-ps-module) port))
 116
 117 ;; TODO: generate this list by registering the stencil expressions
 118 ;;       stencil expressions should have docstrings.
 119 (define-public (ly:all-stencil-expressions)
 120   "Return list of stencil expressions."
 121   '(beam
 122     bezier-sandwich
 123     blank
 124     bracket
 125     char
 126     circle
 127     dashed-line
 128     dashed-slur
 129     dot
 130     draw-line
 131     ez-ball
 132     filledbox
 133     glyph-string
 134     horizontal-line
 135     named-glyph
 136     polygon
 137     repeat-slash
 138     round-filled-box
 139     text
 140     url-link
 141     utf8-string
 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             "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             "x11-color.scm"
 225
 226             ;; must be after everything has been defined
 227             "safe-lily.scm"))
 228
 229
 230 (set! type-p-name-alist
 231       `(
 232         (,boolean-or-symbol? . "boolean or symbol")
 233         (,boolean? . "boolean")
 234         (,char? . "char")
 235         (,grob-list? . "list of grobs")
 236         (,hash-table? . "hash table")
 237         (,input-port? . "input port")
 238         (,integer? . "integer")
 239         (,list? . "list")
 240         (,ly:context? . "context")
 241         (,ly:dimension? . "dimension, in staff space")
 242         (,ly:dir? . "direction")
 243         (,ly:duration? . "duration")
 244         (,ly:grob? . "layout object")
 245         (,ly:input-location? . "input location")
 246         (,ly:moment? . "moment")
 247         (,ly:music? . "music")
 248         (,ly:pitch? . "pitch")
 249         (,ly:translator? . "translator")
 250         (,ly:font-metric? . "font metric")
 251         (,markup-list? . "list of markups")
 252         (,markup? . "markup")
 253         (,ly:music-list? . "list of music")
 254         (,number-or-grob? . "number or grob")
 255         (,number-or-string? . "number or string")
 256         (,number-pair? . "pair of numbers")
 257         (,number? . "number")
 258         (,output-port? . "output port")
 259         (,pair? . "pair")
 260         (,procedure? . "procedure")
 261         (,scheme? . "any type")
 262         (,string? . "string")
 263         (,symbol? . "symbol")
 264         (,vector? . "vector")))
 265
 266
 267 ;; debug mem leaks
 268
 269 (define gc-protect-stat-count 0)
 270 (define-public (dump-gc-protects)
 271   (set! gc-protect-stat-count (1+ gc-protect-stat-count))
 272   (let* ((protects (sort
 273                     (hash-table->alist (ly:protects))
 274                     (lambda (a b)
 275                       (< (object-address (car a))
 276                          (object-address (car b))))))
 277          (out-file-name (string-append
 278                          "gcstat-" (number->string gc-protect-stat-count)
 279                          ".scm"))
 280          (outfile    (open-file  out-file-name  "w")))
 281
 282     (display "Dumping gc protected objs to ...\n")
 283     (display
 284      (filter
 285       (lambda (x) (not (symbol? x)))
 286       (map (lambda (y)
 287              (let ((x (car y))
 288                    (c (cdr y)))
 289
 290                (string-append
 291                 (string-join
 292                  (map object->string (list (object-address x) c x))
 293                  " ")
 294                 "\n")))
 295            protects))
 296      outfile)))
 297
 298 (define-public (tweak-grob-property grob sym val)
 299   (set! (ly:grob-property grob sym) val))
 300
 301 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 302 (define-public (lilypond-main files)
 303   "Entry point for LilyPond."
 304
 305   (if (null? files)
 306       (no-files-handler))
 307
 308   (let ((failed (lilypond-all files)))
 309     (if (pair? failed)
 310         (begin
 311           (ly:error (_ "failed files: ~S") (string-join failed))
 312           (exit 1))
 313         (begin
 314           ;; HACK: be sure to exit with single newline
 315           (ly:message "")
 316           (exit 0)))))
 317
 318 (define (no-files-handler)
 319   (ly:usage)
 320   (exit 2))
 321
 322 (define-public (lilypond-all files)
 323   (let* ((failed '())
 324          (handler (lambda (key failed-file)
 325                     (set! failed (append (list failed-file) failed)))))
 326     ;;(handler (lambda (key . arg) (set! failed (append arg failed)))))
 327     (for-each (lambda (x) (lilypond-file handler x)) files)))
 328
 329 (define (lilypond-file handler file-name)
 330   (catch 'ly-file-failed
 331          (lambda () (ly:parse-file file-name))
 332          (lambda (x . args) (handler x file-name)))
 333   ;;(lambda (x) (handler x f)))
 334   (if #f
 335       (dump-gc-protects)))
 336
 337 (use-modules (scm editor))
 338
 339 (define-public (gui-main files)
 340   (if (null? files) (gui-no-files-handler))
 341   (let* ((base (basename (car files) ".ly"))
 342          (log-name (string-append base ".log"))
 343          (log-file (open-file log-name "w")))
 344     (display "# -*-compilation-*-" log-file)
 345     (newline log-file)
 346     (ly:message (_ "Redirecting output to ~a...") log-name)
 347     (ly:port-move (fileno (current-error-port)) log-file)
 348     (if (null? (lilypond-all files))
 349         (exit 0)
 350         (begin
 351           (system (get-editor-command log-name 0 0))
 352           (exit 1)))))
 353
 354 (define (gui-no-files-handler)
 355   (let* ((input (string-append
 356                  (string-regexp-substitute
 357                   "share/lilypond/" "share/doc/lilypond-"
 358                   (getenv "LILYPONDPREFIX"))
 359                  "-1/input"))
 360          (ly (string-append input "/" "Welcome to LilyPond.ly"))
 361          (cmd (get-editor-command ly 0 0)))
 362     (system cmd)))
 363
 364 ;; FIXME
 365 ;; (define lilypond-main gui-main)