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