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