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