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