scm/lily.scm

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