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