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     "scheme-engravers.scm"
 500     "titling.scm"
 501     "text.scm"
 502
 503     "paper.scm"
 504     "backend-library.scm"
 505     "x11-color.scm"))
 506 ;;  - Files to be loaded last
 507 (define init-scheme-files-tail
 508 ;;  - must be after everything has been defined
 509   '("safe-lily.scm"))
 510 ;;
 511 ;; Now construct the load list
 512 ;;
 513 (define init-scheme-files
 514   (append init-scheme-files-lib
 515           init-scheme-files-used
 516           init-scheme-files-body
 517           init-scheme-files-tail))
 518
 519 (for-each ly:load init-scheme-files)
 520
 521 (define-public r5rs-primary-predicates
 522   `((,boolean? . "boolean")
 523     (,char? . "character")
 524     (,number? . "number")
 525     (,pair? . "pair")
 526     (,port? . "port")
 527     (,procedure? . "procedure")
 528     (,string? . "string")
 529     (,symbol? . "symbol")
 530     (,vector? . "vector")))
 531
 532 (define-public r5rs-secondary-predicates
 533   `((,char-alphabetic? . "alphabetic character")
 534     (,char-lower-case? . "lower-case character")
 535     (,char-numeric? . "numeric character")
 536     (,char-upper-case? . "upper-case character")
 537     (,char-whitespace? . "whitespace character")
 538
 539     (,complex? . "complex number")
 540     (,even? . "even number")
 541     (,exact? . "exact number")
 542     (,inexact? . "inexact number")
 543     (,integer? . "integer")
 544     (,negative? . "negative number")
 545     (,odd? . "odd number")
 546     (,positive? . "positive number")
 547     (,rational? . "rational number")
 548     (,real? . "real number")
 549     (,zero? . "zero")
 550
 551     (,list? . "list")
 552     (,null? . "null")
 553
 554     (,input-port? . "input port")
 555     (,output-port? . "output port")
 556
 557     ;; would this ever be used?
 558     (,eof-object? . "end-of-file object")
 559     ))
 560
 561 (define-public guile-predicates
 562   `((,hash-table? . "hash table")
 563   ))
 564
 565 (define-public lilypond-scheme-predicates
 566   `((,boolean-or-symbol? . "boolean or symbol")
 567     (,color? . "color")
 568     (,cheap-list? . "list")
 569     (,fraction? . "fraction, as pair")
 570     (,grob-list? . "list of grobs")
 571     (,index? . "non-negative integer")
 572     (,markup? . "markup")
 573     (,markup-command-list? . "markup command list")
 574     (,markup-list? . "markup list")
 575     (,moment-pair? . "pair of moment objects")
 576     (,number-list? . "number list")
 577     (,number-or-grob? . "number or grob")
 578     (,number-or-markup? . "number or markup")
 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     (,symbol-list? . "symbol list")
 588     (,symbol-list-or-music? . "symbol list or music")
 589     (,symbol-list-or-symbol? . "symbol list or symbol")
 590     (,void? . "void")
 591     ))
 592
 593 (define-public lilypond-exported-predicates
 594   `((,ly:book? . "book")
 595     (,ly:box? . "box")
 596     (,ly:context? . "context")
 597     (,ly:context-def? . "context definition")
 598     (,ly:context-mod? . "context modification")
 599     (,ly:dimension? . "dimension, in staff space")
 600     (,ly:dir? . "direction")
 601     (,ly:dispatcher? . "dispatcher")
 602     (,ly:duration? . "duration")
 603     (,ly:event? . "post event")
 604     (,ly:font-metric? . "font metric")
 605     (,ly:grob? . "graphical (layout) object")
 606     (,ly:grob-array? . "array of grobs")
 607     (,ly:input-location? . "input location")
 608     (,ly:item? . "item")
 609     (,ly:iterator? . "iterator")
 610     (,ly:lily-lexer? . "lily-lexer")
 611     (,ly:lily-parser? . "lily-parser")
 612     (,ly:listener? . "listener")
 613     (,ly:moment? . "moment")
 614     (,ly:music? . "music")
 615     (,ly:music-function? . "music function")
 616     (,ly:music-list? . "list of music objects")
 617     (,ly:music-output? . "music output")
 618     (,ly:otf-font? . "OpenType font")
 619     (,ly:output-def? . "output definition")
 620     (,ly:page-marker? . "page marker")
 621     (,ly:pango-font? . "pango font")
 622     (,ly:paper-book? . "paper book")
 623     (,ly:paper-system? . "paper-system Prob")
 624     (,ly:pitch? . "pitch")
 625     (,ly:prob? . "property object")
 626     (,ly:score? . "score")
 627     (,ly:simple-closure? . "simple closure")
 628     (,ly:skyline? . "skyline")
 629     (,ly:skyline-pair? . "pair of skylines")
 630     (,ly:source-file? . "source file")
 631     (,ly:spanner? . "spanner")
 632     (,ly:spring? . "spring")
 633     (,ly:stencil? . "stencil")
 634     (,ly:stream-event? . "stream event")
 635     (,ly:translator? . "translator")
 636     (,ly:translator-group? . "translator group")
 637     (,ly:unpure-pure-container? . "unpure/pure container")
 638     ))
 639
 640
 641 (set! type-p-name-alist
 642       (append r5rs-primary-predicates
 643               r5rs-secondary-predicates
 644               guile-predicates
 645               lilypond-scheme-predicates
 646               lilypond-exported-predicates))
 647
 648
 649 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 650 ;; timing
 651
 652 (define (profile-measurements)
 653   (let* ((t (times))
 654          (stats (gc-stats)))
 655     (list (- (+ (tms:cutime t)
 656                 (tms:utime t))
 657              (assoc-get 'gc-time-taken stats))
 658           (assoc-get 'total-cells-allocated  stats 0))))
 659
 660 (define (dump-profile base last this)
 661   (let* ((outname (format #f "~a.profile" (dir-basename base ".ly")))
 662          (diff (map (lambda (y) (apply - y)) (zip this last))))
 663     (ly:progress "\nWriting timing to ~a..." outname)
 664     (format (open-file outname "w")
 665             "time: ~a\ncells: ~a\n"
 666             (if (ly:get-option 'dump-cpu-profile)
 667                 (car diff)
 668                 0)
 669             (cadr diff))))
 670
 671 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 672 ;; debug memory leaks
 673
 674 (define gc-dumping
 675   #f)
 676
 677 (define gc-protect-stat-count
 678   0)
 679
 680 ;; Undead objects that should be ignored after the first time round
 681 (define gc-zombies
 682   (make-weak-key-hash-table 0))
 683
 684 (define-public (dump-live-object-stats outfile)
 685   (for-each (lambda (x)
 686               (format outfile "~a: ~a\n" (car x) (cdr x)))
 687             (sort (gc-live-object-stats)
 688                   (lambda (x y)
 689                     (string<? (car x) (car y))))))
 690
 691 (define-public (dump-gc-protects)
 692   (set! gc-protect-stat-count (1+ gc-protect-stat-count))
 693   (let* ((protects (sort (hash-table->alist (ly:protects))
 694                          (lambda (a b)
 695                            (< (object-address (car a))
 696                               (object-address (car b))))))
 697         (out-file-name (string-append
 698                        "gcstat-" (number->string gc-protect-stat-count)
 699                        ".scm"))
 700         (outfile (open-file out-file-name "w")))
 701     (set! gc-dumping #t)
 702     (ly:progress "Dumping GC statistics ~a...\n" out-file-name)
 703     (for-each (lambda (y)
 704                 (let ((x (car y))
 705                       (c (cdr y)))
 706                   (format outfile "~a (~a) = ~a\n" (object-address x) c x)))
 707               (filter
 708                (lambda (x)
 709                  (not (symbol? (car x))))
 710                protects))
 711     (format outfile "\nprotected symbols: ~a\n"
 712             (apply + (map (lambda (obj-count)
 713                             (if (symbol? (car obj-count))
 714                                 (cdr obj-count)
 715                                 0))
 716                           protects)))
 717
 718     ;; (display (ly:smob-protects))
 719     (newline outfile)
 720     (if (defined? 'gc-live-object-stats)
 721         (let* ((stats #f))
 722           (ly:progress "Live object statistics: GC'ing\n")
 723           (ly:reset-all-fonts)
 724           (gc)
 725           (gc)
 726           (ly:progress "Asserting dead objects\n")
 727           (ly:set-option 'debug-gc-assert-parsed-dead #t)
 728           (gc)
 729           (ly:set-option 'debug-gc-assert-parsed-dead #f)
 730           (for-each
 731            (lambda (x)
 732              (if (not (hashq-ref gc-zombies x))
 733                  (begin
 734                    (ly:programming-error "Parsed object should be dead: ~a" x)
 735                    (hashq-set! gc-zombies x #t))))
 736            (ly:parsed-undead-list!))
 737           (set! stats (gc-live-object-stats))
 738           (ly:progress "Dumping live object statistics.\n")
 739           (dump-live-object-stats outfile)))
 740     (newline outfile)
 741     (let* ((stats (gc-stats)))
 742       (for-each (lambda (sym)
 743                   (format outfile "~a ~a ~a\n"
 744                           gc-protect-stat-count
 745                           sym
 746                           (assoc-get sym stats "?")))
 747                 '(protected-objects bytes-malloced cell-heap-size)))
 748     (set! gc-dumping #f)
 749     (close-port outfile)))
 750
 751 (define (check-memory)
 752   "Read `/proc/self' to check up on memory use."
 753   (define (gulp-file name)
 754     (let* ((file (open-input-file name))
 755            (text (read-delimited "" file)))
 756       (close file)
 757       text))
 758
 759   (let* ((stat (gulp-file "/proc/self/status"))
 760          (lines (string-split stat #\newline))
 761          (interesting (filter identity
 762                               (map
 763                                (lambda (l)
 764                                  (string-match "^VmData:[ \t]*([0-9]*) kB" l))
 765                                lines)))
 766          (mem (string->number (match:substring (car interesting) 1))))
 767     (format #t "VMDATA: ~a\n" mem)
 768     (display (gc-stats))
 769     (newline)
 770     (if (> mem 500000)
 771         (begin (dump-gc-protects)
 772                (raise 1)))))
 773
 774 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 775
 776 (define (multi-fork count)
 777   "Split this process into COUNT helpers.  Returns either a list of
 778 PIDs or the number of the process."
 779   (define (helper count acc)
 780     (if (> count 0)
 781         (let* ((pid (primitive-fork)))
 782               (if (= pid 0)
 783                   (1- count)
 784                   (helper (1- count) (cons pid acc))))
 785         acc))
 786
 787   (helper count '()))
 788
 789 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 790
 791 (define* (ly:exit status #:optional (silently #f))
 792   "Exit function for lilypond"
 793   (if (not silently)
 794       (case status
 795         ((0) (ly:basic-progress (_ "Success: compilation successfully completed")))
 796         ((1) (ly:warning (_ "Compilation completed with warnings or errors")))
 797         (else (ly:message ""))))
 798   (exit status))
 799
 800 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 801
 802 (define-public (lilypond-main files)
 803   "Entry point for LilyPond."
 804   (eval-string (ly:command-line-code))
 805   (if (ly:get-option 'help)
 806       (begin (ly:option-usage)
 807              (ly:exit 0 #t)))
 808   (if (ly:get-option 'show-available-fonts)
 809       (begin (ly:font-config-display-fonts)
 810              (ly:exit 0 #t)))
 811   (if (ly:get-option 'gui)
 812       (gui-main files))
 813   (if (null? files)
 814       (begin (ly:usage)
 815              (ly:exit 2 #t)))
 816   (if (ly:get-option 'read-file-list)
 817       (set! files
 818             (filter (lambda (s)
 819                       (> (string-length s) 0))
 820                     (apply append
 821                            (map (lambda (f)
 822                                   (string-split (string-delete (ly:gulp-file f) #\cr) #\nl))
 823                                 files)))))
 824   (if (and (number? (ly:get-option 'job-count))
 825            (>= (length files) (ly:get-option 'job-count)))
 826       (let* ((count (ly:get-option 'job-count))
 827              (split-todo (split-list files count))
 828              (joblist (multi-fork count))
 829              (errors '()))
 830         (if (not (string-or-symbol? (ly:get-option 'log-file)))
 831             (ly:set-option 'log-file "lilypond-multi-run"))
 832         (if (number? joblist)
 833             (begin (ly:set-option
 834                     'log-file (format #f "~a-~a"
 835                                       (ly:get-option 'log-file) joblist))
 836                     (set! files (vector-ref split-todo joblist)))
 837             (begin (ly:progress "\nForking into jobs:  ~a\n" joblist)
 838                    (for-each
 839                     (lambda (pid)
 840                       (let* ((stat (cdr (waitpid pid))))
 841                         (if (not (= stat 0))
 842                             (set! errors
 843                                   (acons (list-element-index joblist pid)
 844                                  stat errors)))))
 845                     joblist)
 846                    (for-each
 847                     (lambda (x)
 848                       (let* ((job (car x))
 849                              (state (cdr x))
 850                              (logfile (format #f "~a-~a.log"
 851                                               (ly:get-option 'log-file) job))
 852                              (log (ly:gulp-file logfile))
 853                              (len (string-length log))
 854                              (tail (substring  log (max 0 (- len 1024)))))
 855                         (if (status:term-sig state)
 856                             (ly:message
 857                              "\n\n~a\n"
 858                              (format #f (_ "job ~a terminated with signal: ~a")
 859                                      job (status:term-sig state)))
 860                             (ly:message
 861                              (_ "logfile ~a (exit ~a):\n~a")
 862                              logfile (status:exit-val state) tail))))
 863                       errors)
 864                      (if (pair? errors)
 865                          (ly:error "Children ~a exited with errors."
 866                                    (map car errors)))
 867                      ;; must overwrite individual entries
 868                      (if (ly:get-option 'dump-profile)
 869                          (dump-profile "lily-run-total"
 870                                        '(0 0) (profile-measurements)))
 871                      (if (null? errors)
 872                          (ly:exit 0 #f)
 873                          (ly:exit 1 #f))))))
 874
 875   (if (string-or-symbol? (ly:get-option 'log-file))
 876       (ly:stderr-redirect (format #f "~a.log" (ly:get-option 'log-file)) "w"))
 877   (let ((failed (lilypond-all files)))
 878     (if (ly:get-option 'trace-scheme-coverage)
 879         (begin
 880           (coverage:show-all (lambda (f)
 881                                (string-contains f "lilypond")))))
 882     (if (pair? failed)
 883         (begin (ly:error (_ "failed files: ~S") (string-join failed))
 884                (ly:exit 1 #f))
 885         (begin
 886           (ly:exit 0 #f)))))
 887
 888
 889 (define-public (lilypond-all files)
 890   (let* ((failed '())
 891          (separate-logs (ly:get-option 'separate-log-files))
 892          (ping-log
 893           (and separate-logs
 894                (if (string-or-symbol? (ly:get-option 'log-file))
 895                    (open-file (format #f "~a.log" (ly:get-option 'log-file))
 896                               "a")
 897                    (fdes->outport 2))))
 898          (do-measurements (ly:get-option 'dump-profile))
 899          (handler (lambda (key failed-file)
 900                     (set! failed (append (list failed-file) failed)))))
 901     (gc)
 902     (for-each
 903      (lambda (x)
 904        (let* ((start-measurements (if do-measurements
 905                                       (profile-measurements)
 906                                       #f))
 907               (base (dir-basename x ".ly"))
 908               (all-settings (ly:all-options)))
 909          (if separate-logs
 910              (ly:stderr-redirect (format #f "~a.log" base) "w"))
 911          (if ping-log
 912              (format ping-log "Processing ~a\n" base))
 913          (if (ly:get-option 'trace-memory-frequency)
 914              (mtrace:start-trace  (ly:get-option 'trace-memory-frequency)))
 915          (lilypond-file handler x)
 916          (ly:check-expected-warnings)
 917          (session-terminate)
 918          (if start-measurements
 919              (dump-profile x start-measurements (profile-measurements)))
 920          (if (ly:get-option 'trace-memory-frequency)
 921              (begin (mtrace:stop-trace)
 922                     (mtrace:dump-results base)))
 923          (for-each (lambda (s)
 924                      (ly:set-option (car s) (cdr s)))
 925                    all-settings)
 926          (ly:set-option 'debug-gc-assert-parsed-dead #t)
 927          (gc)
 928          (ly:set-option 'debug-gc-assert-parsed-dead #f)
 929          (for-each
 930           (lambda (x)
 931             (if (not (hashq-ref gc-zombies x))
 932                 (begin
 933                   (ly:programming-error "Parsed object should be dead: ~a" x)
 934                   (hashq-set! gc-zombies x #t))))
 935           (ly:parsed-undead-list!))
 936          (if (ly:get-option 'debug-gc)
 937              (dump-gc-protects)
 938              (ly:reset-all-fonts))
 939          (flush-all-ports)))
 940      files)
 941
 942     ;; Ensure a notice re failed files is written to aggregate logfile.
 943     (if ping-log
 944         (format ping-log "Failed files: ~a\n" failed))
 945     (if (ly:get-option 'dump-profile)
 946         (dump-profile "lily-run-total" '(0 0) (profile-measurements)))
 947     failed))
 948
 949 (define (lilypond-file handler file-name)
 950   (catch 'ly-file-failed
 951          (lambda () (ly:parse-file file-name))
 952          (lambda (x . args) (handler x file-name))))
 953
 954 (use-modules (scm editor))
 955
 956 (define-public (gui-main files)
 957   (if (null? files)
 958       (gui-no-files-handler))
 959   (if (not (string? (ly:get-option 'log-file)))
 960       (let* ((base (dir-basename (car files) ".ly"))
 961              (log-name (string-append base ".log")))
 962         (if (not (ly:get-option 'gui))
 963             (ly:message (_ "Redirecting output to ~a...") log-name))
 964         (ly:stderr-redirect log-name "w")
 965         (ly:message "# -*-compilation-*-"))
 966       (let ((failed (lilypond-all files)))
 967         (if (pair? failed)
 968             (begin
 969               ;; ugh
 970               (ly:stderr-redirect "foo" "r")
 971               (system (get-editor-command log-name 0 0 0))
 972               (ly:error (_ "failed files: ~S") (string-join failed))
 973               ;; not reached?
 974               (exit 1))
 975             (ly:exit 0 #f)))))
 976
 977 (define (gui-no-files-handler)
 978   (let* ((ly (string-append (ly:effective-prefix) "/ly/"))
 979          ;; FIXME: soft-code, localize
 980          (welcome-ly (string-append ly "Welcome_to_LilyPond.ly"))
 981          (cmd (get-editor-command welcome-ly 0 0 0)))
 982     (ly:message (_ "Invoking `~a'...\n") cmd)
 983     (system cmd)
 984     (ly:exit 1 #f)))