scm/lily.scm

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