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