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