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