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