scm/lily.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 1998--2012 Jan Nieuwenhuizen <janneke@gnu.org>
   4 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
   5 ;;;;
   6 ;;;; LilyPond is free software: you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation, either version 3 of the License, or
   9 ;;;; (at your option) any later version.
  10 ;;;;
  11 ;;;; LilyPond is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 ;; Internationalisation: (_i "to be translated") gets an entry in the
  20 ;; POT file; (gettext ...) must be invoked explicitly to do the actual
  21 ;; "translation".
  22 ;;
  23 ;; (define-macro (_i x) x)
  24 ;; (define-macro-public _i (x) x)
  25 ;; (define-public-macro _i (x) x)
  26 ;; Abbrv-PWR!
  27
  28 (defmacro-public _i (x) x)
  29
  30 ;;; Boolean thunk - are we integrating Guile V2.0 or higher with LilyPond?
  31 (define-public (guile-v2)
  32   (string>? (version) "1.9.10"))
  33
  34 (read-enable 'positions)
  35 (if (not (guile-v2))
  36     (debug-enable 'debug)
  37     (begin
  38       (debug-enable 'backtrace)
  39       (debug-set! show-file-name #t)))
  40
  41 (define-public PLATFORM
  42   (string->symbol
  43    (string-downcase
  44     (car (string-tokenize (utsname:sysname (uname)))))))
  45
  46 ;;
  47 ;; Session-handling variables and procedures.
  48 ;;
  49 ;;  A "session" corresponds to one .ly file processed on a LilyPond
  50 ;;  command line.  Every session gets to see a reasonably fresh state
  51 ;;  of LilyPond and should work independently from previous files.
  52 ;;
  53 ;;  Session management relies on cooperation, namely the user not
  54 ;;  trying to change variables and data structures internal to
  55 ;;  LilyPond.  It is not proof against in-place modification of data
  56 ;;  structures (as they are just reinitialized with the original
  57 ;;  identities), and it is not proof against tampering with internals.
  58 ;;
  59 ;;  As a consequence, session management is not sufficient for
  60 ;;  separating multiple independent .ly files in "-dsafe" mode: you
  61 ;;  should give each its own LilyPond process when reliable separation
  62 ;;  is mandatory.
  63 ;;
  64 ;;  For standard tasks and programming practices, multiple sessions in
  65 ;;  the same LilyPond job should work reasonably independently and
  66 ;;  without "bleed-over" while still loading and compiling the
  67 ;;  relevant .scm and .ly files only once.
  68 ;;
  69
  70 (define lilypond-declarations '())
  71 (define after-session-hook (make-hook))
  72
  73 (define-public (call-after-session thunk)
  74   (if (ly:undead? lilypond-declarations)
  75       (ly:error (_ "call-after-session used after session start")))
  76   (add-hook! after-session-hook thunk #t))
  77
  78 (defmacro-public define-session (name value)
  79   "This defines a variable @var{name} with the starting value
  80 @var{value} that is reinitialized at the start of each session.
  81 A@tie{}session basically corresponds to one LilyPond file on the
  82 command line.  The value is recorded at the start of the first session
  83 after loading all initialization files and before loading the user
  84 file and is reinstated for all of the following sessions.  This
  85 happens just by replacing the value, not by copying structures, so you
  86 should not destructively modify them.  For example, lists defined in
  87 this manner should be changed within a session only be adding material
  88 to their front or replacing them altogether, not by modifying parts of
  89 them.  It is an error to call @code{define-session} after the first
  90 session has started."
  91   (define (add-session-variable name value)
  92     (if (ly:undead? lilypond-declarations)
  93         (ly:error (_ "define-session used after session start")))
  94     (let ((var (make-variable value)))
  95       (module-add! (current-module) name var)
  96       (set! lilypond-declarations (cons var lilypond-declarations))))
  97   `(,add-session-variable ',name ,value))
  98
  99 (defmacro-public define-session-public (name value)
 100   "Like @code{define-session}, but also exports @var{name}."
 101   `(begin
 102      (define-session ,name ,value)
 103      (export ,name)))
 104
 105 (define (session-terminate)
 106   (if (ly:undead? lilypond-declarations)
 107       (begin
 108         (for-each
 109          (lambda (p) (variable-set! (cadr p) (cddr p)))
 110          (ly:get-undead lilypond-declarations))
 111         (run-hook after-session-hook))))
 112
 113 (define lilypond-interfaces #f)
 114
 115 (define-public (session-initialize thunk)
 116   "Initialize this session.  The first session in a LilyPond run is
 117 initialized by calling @var{thunk}, then recording the values of all
 118 variables in the current module as well as those defined with
 119 @code{define-session}.  Subsequent calls of @code{session-initialize}
 120 ignore @var{thunk} and instead just reinitialize all recorded
 121 variables to their value after the initial call of @var{thunk}."
 122
 123 ;; We need to save the variables of the current module along with
 124 ;; their values: functions defined in the module might refer to the
 125 ;; variables.
 126
 127 ;; The entries in lilypond-declarations consist of a cons* consisting
 128 ;; of symbol, variable, and value.  Variables defined with
 129 ;; define-session have the symbol set to #f.
 130
 131   (if (ly:undead? lilypond-declarations)
 132       (begin
 133         (module-use-interfaces! (current-module) (reverse lilypond-interfaces))
 134         (for-each
 135          (lambda (p)
 136            (let ((var (cadr p))
 137                  (val (cddr p)))
 138              (variable-set! var val)
 139              (if (car p)
 140                  (module-add! (current-module) (car p) var))))
 141          (ly:get-undead lilypond-declarations)))
 142       (begin
 143         (thunk)
 144         (set! lilypond-interfaces
 145               (filter (lambda (m) (eq? 'interface (module-kind m)))
 146                       (module-uses (current-module))))
 147         (let ((decl (map! (lambda (v)
 148                             (cons* #f v (variable-ref v)))
 149                           lilypond-declarations)))
 150           (module-for-each
 151            (lambda (s v)
 152              (let ((val (variable-ref v)))
 153                (if (not (ly:lily-parser? val))
 154                    (set! decl
 155                          (cons
 156                           (cons* s v val)
 157                           decl)))))
 158            (current-module))
 159           (set! lilypond-declarations (ly:make-undead decl))))))
 160
 161 (define scheme-options-definitions
 162   `(
 163     ;; NAMING: either
 164
 165     ;; - [subject-]object-object-verb +"ing"
 166     ;; - [subject-]-verb-object-object
 167
 168     ;; Avoid overlong lines in `lilypond -dhelp'!  Strings should not
 169     ;; be longer than 48 characters per line.
 170
 171     (anti-alias-factor 1
 172 "Render at higher resolution (using given factor)
 173 and scale down result to prevent jaggies in
 174 PNG images.")
 175     (aux-files #t
 176 "Create .tex, .texi, .count files in the
 177 EPS backend.")
 178     (backend ps
 179 "Select backend.  Possible values: 'eps, 'null,
 180 'ps, 'scm, 'socket, 'svg.")
 181     (check-internal-types #f
 182 "Check every property assignment for types.")
 183     (clip-systems #f
 184 "Generate cut-out snippets of a score.")
 185     (datadir #f
 186 "LilyPond prefix for data files (read-only).")
 187     (debug-gc #f
 188 "Dump memory debugging statistics.")
 189     (debug-gc-assert-parsed-dead #f
 190 "For memory debugging: Ensure that all
 191 references to parsed objects are dead.  This is
 192 an internal option, and is switched on
 193 automatically for `-ddebug-gc'.")
 194     (debug-lexer #f
 195 "Debug the flex lexer.")
 196     (debug-page-breaking-scoring #f
 197 "Dump scores for many different page breaking
 198 configurations.")
 199     (debug-parser #f
 200 "Debug the bison parser.")
 201     (debug-property-callbacks #f
 202 "Debug cyclic callback chains.")
 203     (debug-skylines #f
 204 "Debug skylines.")
 205     (delete-intermediate-files #t
 206 "Delete unusable, intermediate PostScript files.")
 207     (dump-profile #f
 208 "Dump memory and time information for each file.")
 209     (dump-cpu-profile #f
 210 "Dump timing information (system-dependent).")
 211     (dump-signatures #f
 212 "Dump output signatures of each system.  Used for
 213 regression testing.")
 214     (eps-box-padding #f
 215 "Pad left edge of the output EPS bounding box by
 216 given amount (in mm).")
 217     (gs-load-fonts #f
 218 "Load fonts via Ghostscript.")
 219     (gs-load-lily-fonts #f
 220 "Load only LilyPond fonts via Ghostscript.")
 221     (gui #f
 222 "Run LilyPond from a GUI and redirect stderr to
 223 a log file.")
 224     (help #f
 225 "Show this help.")
 226     (include-book-title-preview #t
 227 "Include book titles in preview images.")
 228     (include-eps-fonts #t
 229 "Include fonts in separate-system EPS files.")
 230     (include-settings #f
 231 "Include file for global settings, included before the score is processed.")
 232     (job-count #f
 233 "Process in parallel, using the given number of
 234 jobs.")
 235     (log-file #f
 236 "If string FOO is given as argument, redirect
 237 output to log file `FOO.log'.")
 238     (max-markup-depth 1024
 239 "Maximum depth for the markup tree. If a markup has more levels,
 240 assume it will not terminate on its own, print a warning and return a
 241 null markup instead.")
 242     (midi-extension ,(if (eq? PLATFORM 'windows)
 243                          "mid"
 244                          "midi")
 245 "Set the default file extension for MIDI output
 246 file to given string.")
 247     (music-strings-to-paths #f
 248 "Convert text strings to paths when glyphs belong
 249 to a music font.")
 250     (point-and-click #t
 251 "Add point & click links to PDF output.")
 252     (paper-size "a4"
 253 "Set default paper size.")
 254     (pixmap-format "png16m"
 255 "Set GhostScript's output format for pixel images.")
 256     (preview #f
 257 "Create preview images also.")
 258     (print-pages #t
 259 "Print pages in the normal way.")
 260     (protected-scheme-parsing #t
 261 "Continue when errors in inline scheme are caught
 262 in the parser.  If #f, halt on errors and print
 263 a stack trace.")
 264     (profile-property-accesses #f
 265 "Keep statistics of get_property() calls.")
 266     (resolution 101
 267 "Set resolution for generating PNG pixmaps to
 268 given value (in dpi).")
 269     (read-file-list #f
 270 "Specify name of a file which contains a list of
 271 input files to be processed.")
 272     (relative-includes #f
 273 "When processing an \\include command, look for
 274 the included file relative to the current file
 275 (instead of the root file)")
 276     (safe #f
 277 "Run in safer mode.")
 278     (separate-log-files #f
 279 "For input files `FILE1.ly', `FILE2.ly', ...
 280 output log data to files `FILE1.log',
 281 `FILE2.log', ...")
 282     (show-available-fonts #f
 283 "List available font names.")
 284     (strict-infinity-checking #f
 285 "Force a crash on encountering Inf and NaN
 286 floating point exceptions.")
 287     (strip-output-dir #t
 288 "Don't use directories from input files while
 289 constructing output file names.")
 290     (svg-woff #f
 291 "Use woff font files in SVG backend.")
 292     (trace-memory-frequency #f
 293 "Record Scheme cell usage this many times per
 294 second.  Dump results to `FILE.stacks' and
 295 `FILE.graph'.")
 296     (trace-scheme-coverage #f
 297 "Record coverage of Scheme files in `FILE.cov'.")
 298     (verbose ,(ly:verbose-output?)
 299 "Verbose output, i.e. loglevel at least DEBUG (read-only).")
 300     (warning-as-error #f
 301 "Change all warning and programming_error
 302 messages into errors.")
 303     ))
 304
 305 ;; Need to do this in the beginning.  Other parts of the Scheme
 306 ;; initialization depend on these options.
 307
 308 (for-each (lambda (x)
 309             (ly:add-option (car x) (cadr x) (caddr x)))
 310           scheme-options-definitions)
 311
 312 (for-each (lambda (x)
 313             (ly:set-option (car x) (cdr x)))
 314           (eval-string (ly:command-line-options)))
 315
 316 (debug-set! stack 0)
 317
 318 (if (defined? 'set-debug-cell-accesses!)
 319     (set-debug-cell-accesses! #f))
 320
 321 ;;(set-debug-cell-accesses! 1000)
 322
 323 (use-modules (ice-9 regex)
 324              (ice-9 safe)
 325              (ice-9 format)
 326              (ice-9 rdelim)
 327              (ice-9 optargs)
 328              (oop goops)
 329              (srfi srfi-1)
 330              (srfi srfi-13)
 331              (srfi srfi-14)
 332              (scm clip-region)
 333              (scm memory-trace)
 334              (scm coverage)
 335              (scm safe-utility-defs))
 336
 337 (define-public _ gettext)
 338 ;;; There are new modules defined in Guile V2.0 which we need to use.
 339 ;;
 340 ;;  Modules and scheme files loaded by lily.scm use currying
 341 ;;  in Guile V2 this needs a module which is not present in Guile V1.8
 342 ;;
 343
 344 (cond
 345   ((guile-v2)
 346    (ly:debug (_ "Using (ice-9 curried-definitions) module\n"))
 347    (use-modules (ice-9 curried-definitions)))
 348   (else
 349     (ly:debug (_ "Guile 1.8\n"))))
 350
 351 ;; TODO add in modules for V1.8.7 deprecated in V2.0 and integrated
 352 ;; into Guile base code, like (ice-9 syncase).
 353 ;;
 354
 355 (define-public fancy-format
 356   format)
 357
 358 (define-public (ergonomic-simple-format dest . rest)
 359   "Like ice-9's @code{format}, but without the memory consumption."
 360   (if (string? dest)
 361       (apply simple-format (cons #f (cons dest rest)))
 362       (apply simple-format (cons dest rest))))
 363
 364 (define format
 365   ergonomic-simple-format)
 366
 367 ;; my display
 368 (define-public (myd k v)
 369   (display k)
 370   (display ": ")
 371   (display v)
 372   (display ", ")
 373   v)
 374
 375 (define-public (print . args)
 376   (apply format (cons (current-output-port) args)))
 377
 378
 379 ;;; General settings.
 380 ;;;
 381 ;;; Debugging evaluator is slower.  This should have a more sensible
 382 ;;; default.
 383
 384
 385 (if (or (ly:get-option 'verbose)
 386         (ly:get-option 'trace-memory-frequency)
 387         (ly:get-option 'trace-scheme-coverage))
 388     (begin
 389       (ly:set-option 'protected-scheme-parsing #f)
 390       (debug-enable 'backtrace)
 391       (read-enable 'positions)))
 392
 393 (if (ly:get-option 'trace-scheme-coverage)
 394     (coverage:enable))
 395
 396 (define-public parser #f)
 397
 398 (define music-string-to-path-backends
 399   '(svg))
 400
 401 (if (memq (ly:get-option 'backend) music-string-to-path-backends)
 402     (ly:set-option 'music-strings-to-paths #t))
 403
 404 (define-public (ly:load x)
 405   (let* ((file-name (%search-load-path x)))
 406     (ly:debug "[~A" file-name)
 407     (if (not file-name)
 408         (ly:error (_ "cannot find: ~A") x))
 409     (primitive-load-path file-name)  ;; to support Guile V2 autocompile
 410     ;; TODO: Any chance to use ly:debug here? Need to extend it to prevent
 411     ;;       a newline in this case
 412     (if (ly:get-option 'verbose)
 413         (ly:progress "]\n"))))
 414
 415 (define-public DOS
 416   (let ((platform (string-tokenize
 417                    (vector-ref (uname) 0) char-set:letter+digit)))
 418     (if (null? (cdr platform)) #f
 419         (member (string-downcase (cadr platform)) '("95" "98" "me")))))
 420
 421 (define (slashify x)
 422   (if (string-index x #\\)
 423       x
 424       (string-regexp-substitute
 425         "//*" "/"
 426         (string-regexp-substitute "\\\\" "/" x))))
 427
 428 (define-public (ly-getcwd)
 429   (if (eq? PLATFORM 'windows)
 430       (slashify (getcwd))
 431       (getcwd)))
 432
 433 (define-public (is-absolute? file-name)
 434   (let ((file-name-length (string-length file-name)))
 435     (if (= file-name-length 0)
 436         #f
 437         (or (eq? (string-ref file-name 0) #\/)
 438             (and (eq? PLATFORM 'windows)
 439                  (> file-name-length 2)
 440                  (eq? (string-ref file-name 1) #\:)
 441                  (eq? (string-ref file-name 2) #\/))))))
 442
 443 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 444 ;;; If necessary, emulate Guile V2 module_export_all! for Guile V1.8.n
 445 (cond-expand
 446  ((not guile-v2)
 447   (define (module-export-all! mod)
 448     (define (fresh-interface!)
 449       (let ((iface (make-module)))
 450         (set-module-name! iface (module-name mod))
 451         ;; for guile 2: (set-module-version! iface (module-version mod))
 452         (set-module-kind! iface 'interface)
 453         (set-module-public-interface! mod iface)
 454         iface))
 455     (let ((iface (or (module-public-interface mod)
 456                      (fresh-interface!))))
 457       (set-module-obarray! iface (module-obarray mod))))))
 458
 459
 460 (define-safe-public (lilypond-version)
 461   (string-join
 462    (map (lambda (x) (if (symbol? x)
 463                         (symbol->string x)
 464                         (number->string x)))
 465         (ly:version))
 466    "."))
 467
 468 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 469 ;; init pitch system
 470
 471 (ly:set-default-scale (ly:make-scale #(0 1 2 5/2 7/2 9/2 11/2)))
 472
 473 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 474 ;; other files.
 475
 476 ;;
 477 ;;  List of Scheme files to be loaded into the (lily) module.
 478 ;;
 479 ;;  - Library definitions, need to be at the head of the list
 480 (define init-scheme-files-lib
 481   '("lily-library.scm"
 482     "output-lib.scm"))
 483 ;;  - Files containing definitions used later by other files later in load
 484 (define init-scheme-files-used
 485   '("markup-macros.scm"
 486     "parser-ly-from-scheme.scm"))
 487 ;;  - Main body of files to be loaded
 488 (define init-scheme-files-body
 489   '("file-cache.scm"
 490     "define-event-classes.scm"
 491     "define-music-callbacks.scm"
 492     "define-music-types.scm"
 493     "define-note-names.scm"
 494     "c++.scm"
 495     "chord-entry.scm"
 496     "skyline.scm"
 497     "stencil.scm"
 498     "define-markup-commands.scm"
 499     "markup.scm"
 500     "modal-transforms.scm"
 501     "chord-generic-names.scm"
 502     "chord-ignatzek-names.scm"
 503     "music-functions.scm"
 504     "part-combiner.scm"
 505     "autochange.scm"
 506     "define-music-properties.scm"
 507     "time-signature-settings.scm"
 508     "auto-beam.scm"
 509     "chord-name.scm"
 510     "bezier-tools.scm"
 511     "ly-syntax-constructors.scm"
 512
 513     "define-context-properties.scm"
 514     "translation-functions.scm"
 515     "script.scm"
 516     "midi.scm"
 517     "layout-beam.scm"
 518     "parser-clef.scm"
 519     "layout-slur.scm"
 520     "font.scm"
 521     "encoding.scm"
 522
 523     "bar-line.scm"
 524     "flag-styles.scm"
 525     "fret-diagrams.scm"
 526     "tablature.scm"
 527     "harp-pedals.scm"
 528     "define-woodwind-diagrams.scm"
 529     "display-woodwind-diagrams.scm"
 530     "predefined-fretboards.scm"
 531     "define-grob-properties.scm"
 532     "define-grobs.scm"
 533     "define-grob-interfaces.scm"
 534     "define-stencil-commands.scm"
 535     "scheme-engravers.scm"
 536     "titling.scm"
 537     "text.scm"
 538
 539     "paper.scm"
 540     "backend-library.scm"
 541     "x11-color.scm"))
 542 ;;  - Files to be loaded last
 543 (define init-scheme-files-tail
 544 ;;  - must be after everything has been defined
 545   '("safe-lily.scm"))
 546 ;;
 547 ;; Now construct the load list
 548 ;;
 549 (define init-scheme-files
 550   (append init-scheme-files-lib
 551           init-scheme-files-used
 552           init-scheme-files-body
 553           init-scheme-files-tail))
 554
 555 (for-each ly:load init-scheme-files)
 556
 557 (define-public r5rs-primary-predicates
 558   `((,boolean? . "boolean")
 559     (,char? . "character")
 560     (,number? . "number")
 561     (,pair? . "pair")
 562     (,port? . "port")
 563     (,procedure? . "procedure")
 564     (,string? . "string")
 565     (,symbol? . "symbol")
 566     (,vector? . "vector")))
 567
 568 (define-public r5rs-secondary-predicates
 569   `((,char-alphabetic? . "alphabetic character")
 570     (,char-lower-case? . "lower-case character")
 571     (,char-numeric? . "numeric character")
 572     (,char-upper-case? . "upper-case character")
 573     (,char-whitespace? . "whitespace character")
 574
 575     (,complex? . "complex number")
 576     (,even? . "even number")
 577     (,exact? . "exact number")
 578     (,inexact? . "inexact number")
 579     (,integer? . "integer")
 580     (,negative? . "negative number")
 581     (,odd? . "odd number")
 582     (,positive? . "positive number")
 583     (,rational? . "rational number")
 584     (,real? . "real number")
 585     (,zero? . "zero")
 586
 587     (,list? . "list")
 588     (,null? . "null")
 589
 590     (,input-port? . "input port")
 591     (,output-port? . "output port")
 592
 593     ;; would this ever be used?
 594     (,eof-object? . "end-of-file object")
 595     ))
 596
 597 (define-public guile-predicates
 598   `((,hash-table? . "hash table")
 599   ))
 600
 601 (define-public lilypond-scheme-predicates
 602   `((,boolean-or-symbol? . "boolean or symbol")
 603     (,color? . "color")
 604     (,cheap-list? . "list")
 605     (,fraction? . "fraction, as pair")
 606     (,grob-list? . "list of grobs")
 607     (,index? . "non-negative integer")
 608     (,markup? . "markup")
 609     (,markup-command-list? . "markup command list")
 610     (,markup-list? . "markup list")
 611     (,moment-pair? . "pair of moment objects")
 612     (,number-list? . "number list")
 613     (,number-or-grob? . "number or grob")
 614     (,number-or-markup? . "number or markup")
 615     (,number-or-pair? . "number or pair")
 616     (,number-or-string? . "number or string")
 617     (,number-pair? . "pair of numbers")
 618     (,rhythmic-location? . "rhythmic location")
 619     (,scheme? . "any type")
 620     (,string-or-pair? . "string or pair")
 621     (,string-or-music? . "string or music")
 622     (,string-or-symbol? . "string or symbol")
 623     (,symbol-list? . "symbol list")
 624     (,symbol-list-or-music? . "symbol list or music")
 625     (,symbol-list-or-symbol? . "symbol list or symbol")
 626     (,void? . "void")
 627     ))
 628
 629 (define-public lilypond-exported-predicates
 630   `((,ly:book? . "book")
 631     (,ly:box? . "box")
 632     (,ly:context? . "context")
 633     (,ly:context-def? . "context definition")
 634     (,ly:context-mod? . "context modification")
 635     (,ly:dimension? . "dimension, in staff space")
 636     (,ly:dir? . "direction")
 637     (,ly:dispatcher? . "dispatcher")
 638     (,ly:duration? . "duration")
 639     (,ly:event? . "post event")
 640     (,ly:font-metric? . "font metric")
 641     (,ly:grob? . "graphical (layout) object")
 642     (,ly:grob-array? . "array of grobs")
 643     (,ly:input-location? . "input location")
 644     (,ly:item? . "item")
 645     (,ly:iterator? . "iterator")
 646     (,ly:lily-lexer? . "lily-lexer")
 647     (,ly:lily-parser? . "lily-parser")
 648     (,ly:listener? . "listener")
 649     (,ly:moment? . "moment")
 650     (,ly:music? . "music")
 651     (,ly:music-function? . "music function")
 652     (,ly:music-list? . "list of music objects")
 653     (,ly:music-output? . "music output")
 654     (,ly:otf-font? . "OpenType font")
 655     (,ly:output-def? . "output definition")
 656     (,ly:page-marker? . "page marker")
 657     (,ly:pango-font? . "pango font")
 658     (,ly:paper-book? . "paper book")
 659     (,ly:paper-system? . "paper-system Prob")
 660     (,ly:pitch? . "pitch")
 661     (,ly:prob? . "property object")
 662     (,ly:score? . "score")
 663     (,ly:simple-closure? . "simple closure")
 664     (,ly:skyline? . "skyline")
 665     (,ly:skyline-pair? . "pair of skylines")
 666     (,ly:source-file? . "source file")
 667     (,ly:spanner? . "spanner")
 668     (,ly:spring? . "spring")
 669     (,ly:stencil? . "stencil")
 670     (,ly:stream-event? . "stream event")
 671     (,ly:translator? . "translator")
 672     (,ly:translator-group? . "translator group")
 673     (,ly:unpure-pure-container? . "unpure/pure container")
 674     ))
 675
 676
 677 (set! type-p-name-alist
 678       (append r5rs-primary-predicates
 679               r5rs-secondary-predicates
 680               guile-predicates
 681               lilypond-scheme-predicates
 682               lilypond-exported-predicates))
 683
 684
 685 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 686 ;; timing
 687
 688 (define (profile-measurements)
 689   (let* ((t (times))
 690          (stats (gc-stats)))
 691     (list (- (+ (tms:cutime t)
 692                 (tms:utime t))
 693              (assoc-get 'gc-time-taken stats))
 694           (assoc-get 'total-cells-allocated  stats 0))))
 695
 696 (define (dump-profile base last this)
 697   (let* ((outname (format #f "~a.profile" (dir-basename base ".ly")))
 698          (diff (map (lambda (y) (apply - y)) (zip this last))))
 699     (ly:progress "\nWriting timing to ~a..." outname)
 700     (format (open-file outname "w")
 701             "time: ~a\ncells: ~a\n"
 702             (if (ly:get-option 'dump-cpu-profile)
 703                 (car diff)
 704                 0)
 705             (cadr diff))))
 706
 707 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 708 ;; debug memory leaks
 709
 710 (define gc-dumping
 711   #f)
 712
 713 (define gc-protect-stat-count
 714   0)
 715
 716 ;; Undead objects that should be ignored after the first time round
 717 (define gc-zombies
 718   (make-weak-key-hash-table 0))
 719
 720 (define-public (dump-live-object-stats outfile)
 721   (for-each (lambda (x)
 722               (format outfile "~a: ~a\n" (car x) (cdr x)))
 723             (sort (gc-live-object-stats)
 724                   (lambda (x y)
 725                     (string<? (car x) (car y))))))
 726
 727 (define-public (dump-gc-protects)
 728   (set! gc-protect-stat-count (1+ gc-protect-stat-count))
 729   (let* ((protects (sort (hash-table->alist (ly:protects))
 730                          (lambda (a b)
 731                            (< (object-address (car a))
 732                               (object-address (car b))))))
 733         (out-file-name (string-append
 734                        "gcstat-" (number->string gc-protect-stat-count)
 735                        ".scm"))
 736         (outfile (open-file out-file-name "w")))
 737     (set! gc-dumping #t)
 738     (ly:progress "Dumping GC statistics ~a...\n" out-file-name)
 739     (for-each (lambda (y)
 740                 (let ((x (car y))
 741                       (c (cdr y)))
 742                   (format outfile "~a (~a) = ~a\n" (object-address x) c x)))
 743               (filter
 744                (lambda (x)
 745                  (not (symbol? (car x))))
 746                protects))
 747     (format outfile "\nprotected symbols: ~a\n"
 748             (apply + (map (lambda (obj-count)
 749                             (if (symbol? (car obj-count))
 750                                 (cdr obj-count)
 751                                 0))
 752                           protects)))
 753
 754     ;; (display (ly:smob-protects))
 755     (newline outfile)
 756     (if (defined? 'gc-live-object-stats)
 757         (let* ((stats #f))
 758           (ly:progress "Live object statistics: GC'ing\n")
 759           (ly:reset-all-fonts)
 760           (gc)
 761           (gc)
 762           (ly:progress "Asserting dead objects\n")
 763           (ly:set-option 'debug-gc-assert-parsed-dead #t)
 764           (gc)
 765           (ly:set-option 'debug-gc-assert-parsed-dead #f)
 766           (for-each
 767            (lambda (x)
 768              (if (not (hashq-ref gc-zombies x))
 769                  (begin
 770                    (ly:programming-error "Parsed object should be dead: ~a" x)
 771                    (hashq-set! gc-zombies x #t))))
 772            (ly:parsed-undead-list!))
 773           (set! stats (gc-live-object-stats))
 774           (ly:progress "Dumping live object statistics.\n")
 775           (dump-live-object-stats outfile)))
 776     (newline outfile)
 777     (let* ((stats (gc-stats)))
 778       (for-each (lambda (sym)
 779                   (format outfile "~a ~a ~a\n"
 780                           gc-protect-stat-count
 781                           sym
 782                           (assoc-get sym stats "?")))
 783                 '(protected-objects bytes-malloced cell-heap-size)))
 784     (set! gc-dumping #f)
 785     (close-port outfile)))
 786
 787 (define (check-memory)
 788   "Read `/proc/self' to check up on memory use."
 789   (define (gulp-file name)
 790     (let* ((file (open-input-file name))
 791            (text (read-delimited "" file)))
 792       (close file)
 793       text))
 794
 795   (let* ((stat (gulp-file "/proc/self/status"))
 796          (lines (string-split stat #\newline))
 797          (interesting (filter identity
 798                               (map
 799                                (lambda (l)
 800                                  (string-match "^VmData:[ \t]*([0-9]*) kB" l))
 801                                lines)))
 802          (mem (string->number (match:substring (car interesting) 1))))
 803     (format #t "VMDATA: ~a\n" mem)
 804     (display (gc-stats))
 805     (newline)
 806     (if (> mem 500000)
 807         (begin (dump-gc-protects)
 808                (raise 1)))))
 809
 810 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 811
 812 (define (multi-fork count)
 813   "Split this process into COUNT helpers.  Returns either a list of
 814 PIDs or the number of the process."
 815   (define (helper count acc)
 816     (if (> count 0)
 817         (let* ((pid (primitive-fork)))
 818               (if (= pid 0)
 819                   (1- count)
 820                   (helper (1- count) (cons pid acc))))
 821         acc))
 822
 823   (helper count '()))
 824
 825 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 826
 827 (define* (ly:exit status #:optional (silently #f))
 828   "Exit function for lilypond"
 829   (if (not silently)
 830       (case status
 831         ((0) (ly:basic-progress (_ "Success: compilation successfully completed")))
 832         ((1) (ly:warning (_ "Compilation completed with warnings or errors")))
 833         (else (ly:message ""))))
 834   (exit status))
 835
 836 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 837
 838 (define-public (lilypond-main files)
 839   "Entry point for LilyPond."
 840   (eval-string (ly:command-line-code))
 841   (if (ly:get-option 'help)
 842       (begin (ly:option-usage)
 843              (ly:exit 0 #t)))
 844   (if (ly:get-option 'show-available-fonts)
 845       (begin (ly:font-config-display-fonts)
 846              (ly:exit 0 #t)))
 847   (if (ly:get-option 'gui)
 848       (gui-main files))
 849   (if (null? files)
 850       (begin (ly:usage)
 851              (ly:exit 2 #t)))
 852   (if (ly:get-option 'read-file-list)
 853       (set! files
 854             (filter (lambda (s)
 855                       (> (string-length s) 0))
 856                     (apply append
 857                            (map (lambda (f)
 858                                   (string-split (string-delete (ly:gulp-file f) #\cr) #\nl))
 859                                 files)))))
 860   (if (and (number? (ly:get-option 'job-count))
 861            (>= (length files) (ly:get-option 'job-count)))
 862       (let* ((count (ly:get-option 'job-count))
 863              (split-todo (split-list files count))
 864              (joblist (multi-fork count))
 865              (errors '()))
 866         (if (not (string-or-symbol? (ly:get-option 'log-file)))
 867             (ly:set-option 'log-file "lilypond-multi-run"))
 868         (if (number? joblist)
 869             (begin (ly:set-option
 870                     'log-file (format #f "~a-~a"
 871                                       (ly:get-option 'log-file) joblist))
 872                     (set! files (vector-ref split-todo joblist)))
 873             (begin (ly:progress "\nForking into jobs:  ~a\n" joblist)
 874                    (for-each
 875                     (lambda (pid)
 876                       (let* ((stat (cdr (waitpid pid))))
 877                         (if (not (= stat 0))
 878                             (set! errors
 879                                   (acons (list-element-index joblist pid)
 880                                  stat errors)))))
 881                     joblist)
 882                    (for-each
 883                     (lambda (x)
 884                       (let* ((job (car x))
 885                              (state (cdr x))
 886                              (logfile (format #f "~a-~a.log"
 887                                               (ly:get-option 'log-file) job))
 888                              (log (ly:gulp-file logfile))
 889                              (len (string-length log))
 890                              (tail (substring  log (max 0 (- len 1024)))))
 891                         (if (status:term-sig state)
 892                             (ly:message
 893                              "\n\n~a\n"
 894                              (format #f (_ "job ~a terminated with signal: ~a")
 895                                      job (status:term-sig state)))
 896                             (ly:message
 897                              (_ "logfile ~a (exit ~a):\n~a")
 898                              logfile (status:exit-val state) tail))))
 899                       errors)
 900                      (if (pair? errors)
 901                          (ly:error "Children ~a exited with errors."
 902                                    (map car errors)))
 903                      ;; must overwrite individual entries
 904                      (if (ly:get-option 'dump-profile)
 905                          (dump-profile "lily-run-total"
 906                                        '(0 0) (profile-measurements)))
 907                      (if (null? errors)
 908                          (ly:exit 0 #f)
 909                          (ly:exit 1 #f))))))
 910
 911   (if (string-or-symbol? (ly:get-option 'log-file))
 912       (ly:stderr-redirect (format #f "~a.log" (ly:get-option 'log-file)) "w"))
 913   (let ((failed (lilypond-all files)))
 914     (if (ly:get-option 'trace-scheme-coverage)
 915         (begin
 916           (coverage:show-all (lambda (f)
 917                                (string-contains f "lilypond")))))
 918     (if (pair? failed)
 919         (begin (ly:error (_ "failed files: ~S") (string-join failed))
 920                (ly:exit 1 #f))
 921         (begin
 922           (ly:exit 0 #f)))))
 923
 924
 925 (define-public (lilypond-all files)
 926   (let* ((failed '())
 927          (separate-logs (ly:get-option 'separate-log-files))
 928          (ping-log
 929           (and separate-logs
 930                (if (string-or-symbol? (ly:get-option 'log-file))
 931                    (open-file (format #f "~a.log" (ly:get-option 'log-file))
 932                               "a")
 933                    (fdes->outport 2))))
 934          (do-measurements (ly:get-option 'dump-profile))
 935          (handler (lambda (key failed-file)
 936                     (set! failed (append (list failed-file) failed)))))
 937     (gc)
 938     (for-each
 939      (lambda (x)
 940        (let* ((start-measurements (if do-measurements
 941                                       (profile-measurements)
 942                                       #f))
 943               (base (dir-basename x ".ly"))
 944               (all-settings (ly:all-options)))
 945          (if separate-logs
 946              (ly:stderr-redirect (format #f "~a.log" base) "w"))
 947          (if ping-log
 948              (format ping-log "Processing ~a\n" base))
 949          (if (ly:get-option 'trace-memory-frequency)
 950              (mtrace:start-trace  (ly:get-option 'trace-memory-frequency)))
 951          (lilypond-file handler x)
 952          (ly:check-expected-warnings)
 953          (session-terminate)
 954          (if start-measurements
 955              (dump-profile x start-measurements (profile-measurements)))
 956          (if (ly:get-option 'trace-memory-frequency)
 957              (begin (mtrace:stop-trace)
 958                     (mtrace:dump-results base)))
 959          (for-each (lambda (s)
 960                      (ly:set-option (car s) (cdr s)))
 961                    all-settings)
 962          (ly:set-option 'debug-gc-assert-parsed-dead #t)
 963          (gc)
 964          (ly:set-option 'debug-gc-assert-parsed-dead #f)
 965          (for-each
 966           (lambda (x)
 967             (if (not (hashq-ref gc-zombies x))
 968                 (begin
 969                   (ly:programming-error "Parsed object should be dead: ~a" x)
 970                   (hashq-set! gc-zombies x #t))))
 971           (ly:parsed-undead-list!))
 972          (if (ly:get-option 'debug-gc)
 973              (dump-gc-protects)
 974              (ly:reset-all-fonts))
 975          (flush-all-ports)))
 976      files)
 977
 978     ;; Ensure a notice re failed files is written to aggregate logfile.
 979     (if ping-log
 980         (format ping-log "Failed files: ~a\n" failed))
 981     (if (ly:get-option 'dump-profile)
 982         (dump-profile "lily-run-total" '(0 0) (profile-measurements)))
 983     failed))
 984
 985 (define (lilypond-file handler file-name)
 986   (catch 'ly-file-failed
 987          (lambda () (ly:parse-file file-name))
 988          (lambda (x . args) (handler x file-name))))
 989
 990 (use-modules (scm editor))
 991
 992 (define-public (gui-main files)
 993   (if (null? files)
 994       (gui-no-files-handler))
 995   (if (not (string? (ly:get-option 'log-file)))
 996       (let* ((base (dir-basename (car files) ".ly"))
 997              (log-name (string-append base ".log")))
 998         (if (not (ly:get-option 'gui))
 999             (ly:message (_ "Redirecting output to ~a...") log-name))
1000         (ly:stderr-redirect log-name "w")
1001         (ly:message "# -*-compilation-*-"))
1002       (let ((failed (lilypond-all files)))
1003         (if (pair? failed)
1004             (begin
1005               ;; ugh
1006               (ly:stderr-redirect "foo" "r")
1007               (system (get-editor-command log-name 0 0 0))
1008               (ly:error (_ "failed files: ~S") (string-join failed))
1009               ;; not reached?
1010               (exit 1))
1011             (ly:exit 0 #f)))))
1012
1013 (define (gui-no-files-handler)
1014   (let* ((ly (string-append (ly:effective-prefix) "/ly/"))
1015          ;; FIXME: soft-code, localize
1016          (welcome-ly (string-append ly "Welcome_to_LilyPond.ly"))
1017          (cmd (get-editor-command welcome-ly 0 0 0)))
1018     (ly:message (_ "Invoking `~a'...\n") cmd)
1019     (system cmd)
1020     (ly:exit 1 #f)))