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