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