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