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