X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Flily.scm;h=b72878f61b9f170ce39c0cce3cde1bac6d404148;hb=3332fc2677f9c8d472ebe4adf05cc742a0089432;hp=265e506978285c233bbecb143a902a4133e92fe3;hpb=f27a0658b549dc41903280c62388e76df87523f0;p=lilypond.git diff --git a/scm/lily.scm b/scm/lily.scm index 265e506978..b72878f61b 100644 --- a/scm/lily.scm +++ b/scm/lily.scm @@ -1,69 +1,258 @@ -;;;; lily.scm -- toplevel Scheme stuff +;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; source file of the GNU LilyPond music typesetter -;;;; -;;;; (c) 1998--2004 Jan Nieuwenhuizen -;;;; Han-Wen Nienhuys - +;;;; Copyright (C) 1998--2009 Jan Nieuwenhuizen +;;;; Han-Wen Nienhuys +;;;; +;;;; LilyPond is free software: you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation, either version 3 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; LilyPond is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with LilyPond. If not, see . + +;; Internationalisation: (_i "to be translated") gets an entry in the +;; POT file; (gettext ...) must be invoked explicitly to do the actual +;; "translation". +;; +;; (define-macro (_i x) x) +;; (define-macro-public _i (x) x) +;; (define-public-macro _i (x) x) +;; Abbrv-PWR! + +(defmacro-public _i (x) x) + +(read-enable 'positions) +(debug-enable 'debug) + +(define-public PLATFORM + (string->symbol + (string-downcase + (car (string-tokenize (utsname:sysname (uname))))))) + +(define scheme-options-definitions + `( + ;; NAMING: either + + ;; - [subject-]object-object-verb +"ing" + ;; - [subject-]-verb-object-object + + ;; Avoid overlong lines in `lilypond -dhelp'! Strings should not + ;; be longer than 48 characters per line. + + (anti-alias-factor 1 +"Render at higher resolution (using given factor) +and scale down result to prevent jaggies in +PNG images.") + (aux-files #t +"Create .tex, .texi, .count files in the +EPS backend.") + (backend ps +"Select backend. Possible values: 'eps, 'null, +'ps, 'scm, 'socket, 'svg.") + (check-internal-types #f +"Check every property assignment for types.") + (clip-systems #f +"Generate cut-out snippets of a score.") + (datadir #f +"LilyPond prefix for data files (read-only).") + (debug-gc #f +"Dump memory debugging statistics.") + (debug-gc-assert-parsed-dead #f +"For memory debugging: Ensure that all +references to parsed objects are dead. This is +an internal option, and is switched on +automatically for `-ddebug-gc'.") + (debug-lexer #f +"Debug the flex lexer.") + (debug-page-breaking-scoring #f +"Dump scores for many different page breaking +configurations.") + (debug-parser #f +"Debug the bison parser.") + (debug-property-callbacks #f +"Debug cyclic callback chains.") + (debug-skylines #f +"Debug skylines.") + (delete-intermediate-files #t +"Delete unusable, intermediate PostScript files.") + (dump-profile #f +"Dump memory and time information for each file.") + (dump-cpu-profile #f +"Dump timing information (system-dependent).") + (dump-signatures #f +"Dump output signatures of each system. Used for +regression testing.") + (eps-box-padding #f +"Pad left edge of the output EPS bounding box by +given amount (in mm).") + (gs-load-fonts #f +"Load fonts via Ghostscript.") + (gs-load-lily-fonts #f +"Load only LilyPond fonts via Ghostscript.") + (gui #f +"Run LilyPond from a GUI and redirect stderr to +a log file.") + (help #f +"Show this help.") + (include-book-title-preview #t +"Include book titles in preview images.") + (include-eps-fonts #t +"Include fonts in separate-system EPS files.") + (job-count #f +"Process in parallel, using the given number of +jobs.") + (log-file #f +"If string FOO is given as argument, redirect +output to log file `FOO.log'.") + (midi-extension ,(if (eq? PLATFORM 'windows) + "mid" + "midi") +"Set the default file extension for MIDI output +file to given string.") + (music-strings-to-paths #f +"Convert text strings to paths when glyphs belong +to a music font.") + (old-relative #f +"Make \\relative mode for simultaneous music work +similar to chord syntax.") + (point-and-click #t +"Add point & click links to PDF output.") + (paper-size "a4" +"Set default paper size.") + (pixmap-format "png16m" +"Set GhostScript's output format for pixel images.") + (preview #f +"Create PNG and EPS preview images also.") + (print-pages #t +"Print pages in the normal way.") + (protected-scheme-parsing #t +"Continue when errors in inline scheme are caught +in the parser. If #f, halt on errors and print +a stack trace.") + (profile-property-accesses #f +"Keep statistics of get_property() calls.") + (resolution 101 +"Set resolution for generating PNG pixmaps to +given value (in dpi).") + (read-file-list #f +"Specify name of a file which contains a list of +input files to be processed.") + (relative-includes #f +"When processing an \\include command, look for +the included file relative to the current file +(instead of the root file)") + (safe #f +"Run in safer mode.") + (strict-infinity-checking #f +"Force a crash on encountering Inf and NaN +floating point exceptions.") + (strip-output-dir #t +"Don't use directories from input files while +constructing output file names.") + (separate-log-files #f +"For input files `FILE1.ly', `FILE2.ly', ... +output log data to files `FILE1.log', +`FILE2.log', ...") + (trace-memory-frequency #f +"Record Scheme cell usage this many times per +second. Dump results to `FILE.stacks' and +`FILE.graph'.") + (trace-scheme-coverage #f +"Record coverage of Scheme files in `FILE.cov'.") + (show-available-fonts #f +"List available font names.") + (verbose ,(ly:command-line-verbose?) +"Value of the --verbose flag (read-only).") + (warning-as-error #f +"Change all warning and programming_error +messages into errors.") + )) + +;; Need to do this in the beginning. Other parts of the Scheme +;; initialization depend on these options. + +(for-each (lambda (x) + (ly:add-option (car x) (cadr x) (caddr x))) + scheme-options-definitions) + +(for-each (lambda (x) + (ly:set-option (car x) (cdr x))) + (eval-string (ly:command-line-options))) + +(debug-set! stack 0) (if (defined? 'set-debug-cell-accesses!) (set-debug-cell-accesses! #f)) -;;(set-debug-cell-accesses! 5000) + ;(set-debug-cell-accesses! 1000) (use-modules (ice-9 regex) - (ice-9 safe) - (oop goops) - (srfi srfi-1) ; lists - (srfi srfi-13)) ; strings - + (ice-9 safe) + (ice-9 format) + (ice-9 rdelim) + (ice-9 optargs) + (oop goops) + (srfi srfi-1) + (srfi srfi-13) + (srfi srfi-14) + (scm clip-region) + (scm memory-trace) + (scm coverage)) + +(define-public fancy-format + format) + +(define-public (ergonomic-simple-format dest . rest) + "Like ice-9 format, but without the memory consumption." + (if (string? dest) + (apply simple-format (cons #f (cons dest rest))) + (apply simple-format (cons dest rest)))) + +(define format + ergonomic-simple-format) ;; my display -(define-public (myd k v) (display k) (display ": ") (display v) (display ", ")) +(define-public (myd k v) + (display k) + (display ": ") + (display v) + (display ", ") + v) (define-public (print . args) (apply format (cons (current-output-port) args))) -;;; General settings -;;; debugging evaluator is slower. This should -;;; have a more sensible default. +;;; General settings. +;;; +;;; Debugging evaluator is slower. This should have a more sensible +;;; default. -(if (ly:get-option 'verbose) +(if (or (ly:get-option 'verbose) + (ly:get-option 'trace-memory-frequency) + (ly:get-option 'trace-scheme-coverage)) (begin + (ly:set-option 'protected-scheme-parsing #f) (debug-enable 'debug) (debug-enable 'backtrace) (read-enable 'positions))) -(define-public (line-column-location file line col) - "Print an input location, including column number ." - (string-append (number->string line) ":" - (number->string col) " " file)) - -(define-public (line-location file line col) - "Print an input location, without column number ." - (string-append (number->string line) " " file)) - -(define-public point-and-click #f) - -(define-public tex-backend? - (member (ly:output-backend) '("texstr" "tex"))) +(if (ly:get-option 'trace-scheme-coverage) + (coverage:enable)) (define-public parser #f) -(define-public (lilypond-version) - (string-join - (map (lambda (x) (if (symbol? x) - (symbol->string x) - (number->string x))) - (ly:version)) - ".")) - - +(define music-string-to-path-backends + '(svg)) -;; cpp hack to get useful error message -(define ifdef "First run this through cpp.") -(define ifndef "First run this through cpp.") +(if (memq (ly:get-option 'backend) music-string-to-path-backends) + (ly:set-option 'music-strings-to-paths #t)) ;; gettext wrapper for guile < 1.7.2 (if (defined? 'gettext) @@ -71,27 +260,65 @@ (define-public _ ly:gettext)) (define-public (ly:load x) - (let* ((fn (%search-load-path x))) + (let* ((file-name (%search-load-path x))) (if (ly:get-option 'verbose) - (format (current-error-port) "[~A]" fn)) - (primitive-load fn))) - -(define-public TEX_STRING_HASHLIMIT 10000000) + (ly:progress "[~A" file-name)) + (if (not file-name) + (ly:error (_ "cannot find: ~A") x)) + (primitive-load file-name) + (if (ly:get-option 'verbose) + (ly:progress "]\n")))) + +(define-public DOS + (let ((platform (string-tokenize + (vector-ref (uname) 0) char-set:letter+digit))) + (if (null? (cdr platform)) #f + (member (string-downcase (cadr platform)) '("95" "98" "me"))))) + +(case PLATFORM + ((windows) + (define native-getcwd + getcwd) + + (define (slashify x) + (if (string-index x #\\) + x + (string-regexp-substitute + "//*" "/" + (string-regexp-substitute "\\\\" "/" x)))) + + ;; FIXME: this prints a warning. + (define-public (ly-getcwd) + (slashify (native-getcwd)))) + + (else + (define-public ly-getcwd + getcwd))) + +(define-public (is-absolute? file-name) + (let ((file-name-length (string-length file-name))) + (if (= file-name-length 0) + #f + (or (eq? (string-ref file-name 0) #\/) + (and (eq? PLATFORM 'windows) + (> file-name-length 2) + (eq? (string-ref file-name 1) #\:) + (eq? (string-ref file-name 2) #\/)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (type-check-list location signature arguments) - "Typecheck a list of arguments against a list of type -predicates. Print a message at LOCATION if any predicate failed." - (define (recursion-helper signature arguments count) - (define (helper pred? arg count) + "Typecheck a list of arguments against a list of type predicates. +Print a message at LOCATION if any predicate failed." + (define (recursion-helper signature arguments count) + (define (helper pred? arg count) (if (not (pred? arg)) - (begin - (ly:input-message location - (format #f - (_ "wrong type for argument ~a. Expecting ~a, found ~s") - count (type-name pred?) arg)) + (ly:input-message + location + (format + #f (_ "wrong type for argument ~a. Expecting ~a, found ~s") + count (type-name pred?) arg)) #f) #t)) @@ -101,111 +328,102 @@ predicates. Print a message at LOCATION if any predicate failed." (recursion-helper (cdr signature) (cdr arguments) (1+ count))))) (recursion-helper signature arguments 1)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Safe definitions utility + +(define safe-objects + (list)) + +(define-macro (define-safe-public arglist . body) + "Define a variable, export it, and mark it as safe, i.e. usable in +LilyPond safe mode. The syntax is the same as `define*-public'." + (define (get-symbol arg) + (if (pair? arg) + (get-symbol (car arg)) + arg)) + + (let ((safe-symbol (get-symbol arglist))) + `(begin + (define*-public ,arglist + ,@body) + (set! safe-objects (cons (cons ',safe-symbol ,safe-symbol) + safe-objects)) + ,safe-symbol))) + +(define-safe-public (lilypond-version) + (string-join + (map (lambda (x) (if (symbol? x) + (symbol->string x) + (number->string x))) + (ly:version)) + ".")) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; output - - -;;(define-public (output-framework) (write "hello\n")) - -(define output-tex-module - (make-module 1021 (list (resolve-interface '(scm output-tex))))) -(define output-ps-module - (make-module 1021 (list (resolve-interface '(scm output-ps))))) - -(define-public (ps-output-expression expr port) - (display (eval expr output-ps-module) port)) - -;; TODO: generate this list by registering the stencil expressions -;; stencil expressions should have docstrings. -(define-public (ly:all-stencil-expressions) - "Return list of stencil expressions." - '(beam - bezier-sandwich - blank - bracket - char - dashed-line - dashed-slur - dot - draw-line - ez-ball - filledbox - glyph-string - horizontal-line - named-glyph - polygon - repeat-slash - round-filled-box - text - white-dot - white-text - embedded-ps - zigzag-line)) - -;; TODO: -;; - generate this list by registering the output-backend-commands -;; output-backend-commands should have docstrings. -;; - remove hard copies in output-ps output-tex -(define-public (ly:all-output-backend-commands) - "Return list of output backend commands." - '( - comment - grob-cause - no-origin - placebox - unknown)) +;; init pitch system + +(ly:set-default-scale (ly:make-scale #(0 1 2 5/2 7/2 9/2 11/2))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; other files. -(for-each ly:load - ;; load-from-path - '("lily-library.scm" - "define-music-types.scm" - "output-lib.scm" - "c++.scm" - "chord-ignatzek-names.scm" - "chord-entry.scm" - "chord-generic-names.scm" - "stencil.scm" - "new-markup.scm" - "bass-figure.scm" - "music-functions.scm" - "part-combiner.scm" - "define-music-properties.scm" - "auto-beam.scm" - "chord-name.scm" - - "ly-from-scheme.scm" - - "define-context-properties.scm" - "translation-functions.scm" - "script.scm" - "midi.scm" - "beam.scm" - "clef.scm" - "slur.scm" - "font.scm" - "encoding.scm" - - "fret-diagrams.scm" - "define-markup-commands.scm" - "define-grob-properties.scm" - "define-grobs.scm" - "define-grob-interfaces.scm" - "page-layout.scm" - "titling.scm" - - "paper.scm" - - ; last: - "safe-lily.scm")) - +(define init-scheme-files + '("lily-library.scm" + "file-cache.scm" + "define-event-classes.scm" + "define-music-types.scm" + "output-lib.scm" + "c++.scm" + "chord-ignatzek-names.scm" + "chord-entry.scm" + "chord-generic-names.scm" + "stencil.scm" + "markup.scm" + "music-functions.scm" + "part-combiner.scm" + "autochange.scm" + "define-music-properties.scm" + "beam-settings.scm" + "auto-beam.scm" + "chord-name.scm" + + "parser-ly-from-scheme.scm" + "ly-syntax-constructors.scm" + + "define-context-properties.scm" + "translation-functions.scm" + "script.scm" + "midi.scm" + "layout-beam.scm" + "parser-clef.scm" + "layout-slur.scm" + "font.scm" + "encoding.scm" + + "flag-styles.scm" + "fret-diagrams.scm" + "harp-pedals.scm" + "predefined-fretboards.scm" + "define-markup-commands.scm" + "define-grob-properties.scm" + "define-grobs.scm" + "define-grob-interfaces.scm" + "define-stencil-commands.scm" + "titling.scm" + + "paper.scm" + "backend-library.scm" + "x11-color.scm" + "tablature.scm" + + ;; must be after everything has been defined + "safe-lily.scm")) + +(for-each ly:load init-scheme-files) (set! type-p-name-alist - `( + `((,boolean? . "boolean") (,boolean-or-symbol? . "boolean or symbol") - (,boolean? . "boolean") (,char? . "char") (,grob-list? . "list of grobs") (,hash-table? . "hash table") @@ -216,162 +434,342 @@ predicates. Print a message at LOCATION if any predicate failed." (,ly:dimension? . "dimension, in staff space") (,ly:dir? . "direction") (,ly:duration? . "duration") + (,ly:font-metric? . "font metric") (,ly:grob? . "layout object") + (,ly:grob-array? . "array of grobs") (,ly:input-location? . "input location") (,ly:moment? . "moment") (,ly:music? . "music") + (,ly:music-list? . "list of music objects") + (,ly:music-output? . "music output") (,ly:pitch? . "pitch") (,ly:translator? . "translator") - (,ly:font-metric? . "font metric") + (,ly:score? . "score") + (,ly:simple-closure? . "simple closure") + (,ly:skyline-pair? . "pair of skylines") + (,ly:stencil? . "stencil") (,markup-list? . "list of markups") (,markup? . "markup") - (,ly:music-list? . "list of music") (,number-or-grob? . "number or grob") (,number-or-string? . "number or string") (,number-pair? . "pair of numbers") (,number? . "number") - (,output-port? . "output port") + (,output-port? . "output port") (,pair? . "pair") - (,procedure? . "procedure") + (,procedure? . "procedure") + (,rhythmic-location? . "rhythmic location") (,scheme? . "any type") (,string? . "string") (,symbol? . "symbol") (,vector? . "vector"))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; timing + +(define (profile-measurements) + (let* ((t (times)) + (stats (gc-stats))) + (list (- (+ (tms:cutime t) + (tms:utime t)) + (assoc-get 'gc-time-taken stats)) + (assoc-get 'total-cells-allocated stats 0)))) + +(define (dump-profile base last this) + (let* ((outname (format "~a.profile" (dir-basename base ".ly"))) + (diff (map (lambda (y) (apply - y)) (zip this last)))) + (ly:progress "\nWriting timing to ~a..." outname) + (format (open-file outname "w") + "time: ~a\ncells: ~a\n" + (if (ly:get-option 'dump-cpu-profile) + (car diff) + 0) + (cadr diff)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; debug memory leaks -;; debug mem leaks +(define gc-dumping + #f) + +(define gc-protect-stat-count + 0) + +(define-public (dump-live-object-stats outfile) + (for-each (lambda (x) + (format outfile "~a: ~a\n" (car x) (cdr x))) + (sort (gc-live-object-stats) + (lambda (x y) + (stringalist (ly:protects)) - (lambda (a b) - (< (object-address (car a)) - (object-address (car b)))))) + (let* ((protects (sort (hash-table->alist (ly:protects)) + (lambda (a b) + (< (object-address (car a)) + (object-address (car b)))))) (out-file-name (string-append "gcstat-" (number->string gc-protect-stat-count) ".scm")) - (outfile (open-file out-file-name "w"))) - - (display "Dumping gc protected objs to ...\n") - (display - (filter - (lambda (x) (not (symbol? x))) - (map (lambda (y) - (let ((x (car y)) - (c (cdr y))) - - (string-append - (string-join - (map object->string (list (object-address x) c x)) - " ") - "\n"))) - protects)) - outfile))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; backend helpers. - -(define-public (ly:system command) - (let* ((status 0) - - (silenced - (string-append command (if (ly:get-option 'verbose) - "" - " > /dev/null 2>&1 ")))) - - (if (ly:get-option 'verbose) - (format (current-error-port) (_ "Invoking `~a'...\n") command)) - - (set! status (system silenced)) - (if (> status 0) - (begin - (format (current-error-port) - (_ "Error invoking `~a'. Return value ~a") silenced status) - (newline (current-error-port)))))) - -(define-public (sanitize-command-option str) - (string-append - "\"" - (regexp-substitute/global #f "[^- 0-9,.a-zA-Z'\"\\]" str 'pre 'post) - "\"")) - -(define-public (postscript->pdf papersizename name) - (let* ((cmd (string-append "ps2pdf " - (string-append - " -sPAPERSIZE=" - (sanitize-command-option papersizename) - " " - name))) - (pdf-name (string-append (basename name ".ps") ".pdf" ))) - - (if (access? pdf-name W_OK) - (delete-file pdf-name)) - - (format (current-error-port) (_ "Converting to `~a'...") pdf-name) - (ly:system cmd))) - -(define-public (postscript->png resolution name) - (let ((cmd (string-append - "ps2png --resolution=" - (if (number? resolution) - (number->string resolution) - "90 ") - (if (ly:get-option 'verbose) - "--verbose " - " ") - name))) - - (ly:system cmd))) - -(define-public (postprocess-output paper-book module filename formats) - (for-each - (lambda (f) - ((eval (string->symbol (string-append "convert-to-" f)) - module) - paper-book filename)) - - formats)) - -(define-public (completize-formats formats) - (define new-fmts '()) - - (if (member "png" formats) - (set! formats (cons "ps" formats))) - (if (member "pdf" formats) - (set! formats (cons "ps" formats))) - - (for-each - (lambda (x) - (if (member x formats) (set! new-fmts (cons x new-fmts)))) - '("tex" "dvi" "ps" "pdf" "png")) - - new-fmts) + (outfile (open-file out-file-name "w"))) + (set! gc-dumping #t) + (display (format "Dumping GC statistics ~a...\n" out-file-name)) + (display (map (lambda (y) + (let ((x (car y)) + (c (cdr y))) + (display + (format "~a (~a) = ~a\n" (object-address x) c x) + outfile))) + (filter + (lambda (x) + (not (symbol? (car x)))) + protects)) + outfile) + (format outfile "\nprotected symbols: ~a\n" + (apply + (map (lambda (obj-count) + (if (symbol? (car obj-count)) + (cdr obj-count) + 0)) + protects))) + + ;; (display (ly:smob-protects)) + (newline outfile) + (if (defined? 'gc-live-object-stats) + (let* ((stats #f)) + (display "Live object statistics: GC'ing\n") + (ly:reset-all-fonts) + (gc) + (gc) + (display "Asserting dead objects\n") + (ly:set-option 'debug-gc-assert-parsed-dead #t) + (gc) + (ly:set-option 'debug-gc-assert-parsed-dead #f) + (set! stats (gc-live-object-stats)) + (display "Dumping live object statistics.\n") + (dump-live-object-stats outfile))) + (newline outfile) + (let* ((stats (gc-stats))) + (for-each (lambda (sym) + (display + (format "~a ~a ~a\n" + gc-protect-stat-count + sym + (assoc-get sym stats "?")) + + outfile)) + '(protected-objects bytes-malloced cell-heap-size))) + (set! gc-dumping #f) + (close-port outfile))) + +(define (check-memory) + "Read `/proc/self' to check up on memory use." + (define (gulp-file name) + (let* ((file (open-input-file name)) + (text (read-delimited "" file))) + (close file) + text)) + + (let* ((stat (gulp-file "/proc/self/status")) + (lines (string-split stat #\newline)) + (interesting (filter identity + (map + (lambda (l) + (string-match "^VmData:[ \t]*([0-9]*) kB" l)) + lines))) + (mem (string->number (match:substring (car interesting) 1)))) + (display (format "VMDATA: ~a\n" mem)) + (display (gc-stats)) + (if (> mem 100000) + (begin (dump-gc-protects) + (raise 1))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (multi-fork count) + "Split this process into COUNT helpers. Returns either a list of +PIDs or the number of the process." + (define (helper count acc) + (if (> count 0) + (let* ((pid (primitive-fork))) + (if (= pid 0) + (1- count) + (helper (1- count) (cons pid acc)))) + acc)) + + (helper count '())) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-public (lilypond-main files) "Entry point for LilyPond." + (eval-string (ly:command-line-code)) + (if (ly:get-option 'help) + (begin (ly:option-usage) + (exit 0))) + (if (ly:get-option 'show-available-fonts) + (begin (ly:font-config-display-fonts) + (exit 0))) + (if (ly:get-option 'gui) + (gui-main files)) + (if (null? files) + (begin (ly:usage) + (exit 2))) + (if (ly:get-option 'read-file-list) + (set! files + (filter (lambda (s) + (> (string-length s) 0)) + (apply append + (map (lambda (f) + (string-split (ly:gulp-file f) #\nl)) + files))))) + (if (and (number? (ly:get-option 'job-count)) + (>= (length files) (ly:get-option 'job-count))) + (let* ((count (ly:get-option 'job-count)) + (split-todo (split-list files count)) + (joblist (multi-fork count)) + (errors '())) + (if (not (string-or-symbol? (ly:get-option 'log-file))) + (ly:set-option 'log-file "lilypond-multi-run")) + (if (number? joblist) + (begin (ly:set-option + 'log-file (format "~a-~a" + (ly:get-option 'log-file) joblist)) + (set! files (vector-ref split-todo joblist))) + (begin (ly:progress "\nForking into jobs: ~a\n" joblist) + (for-each + (lambda (pid) + (let* ((stat (cdr (waitpid pid)))) + (if (not (= stat 0)) + (set! errors + (acons (list-element-index joblist pid) + stat errors))))) + joblist) + (for-each + (lambda (x) + (let* ((job (car x)) + (state (cdr x)) + (logfile (format "~a-~a.log" + (ly:get-option 'log-file) job)) + (log (ly:gulp-file logfile)) + (len (string-length log)) + (tail (substring log (max 0 (- len 1024))))) + (if (status:term-sig state) + (ly:message + "\n\n~a\n" + (format (_ "job ~a terminated with signal: ~a") + job (status:term-sig state))) + (ly:message + (_ "logfile ~a (exit ~a):\n~a") + logfile (status:exit-val state) tail)))) + errors) + (if (pair? errors) + (ly:error "Children ~a exited with errors." + (map car errors))) + ;; must overwrite individual entries + (if (ly:get-option 'dump-profile) + (dump-profile "lily-run-total" + '(0 0) (profile-measurements))) + (exit (if (null? errors) + 0 + 1)))))) + (if (string-or-symbol? (ly:get-option 'log-file)) + (ly:stderr-redirect (format "~a.log" (ly:get-option 'log-file)) "w")) + (let ((failed (lilypond-all files))) + (if (ly:get-option 'trace-scheme-coverage) + (begin + (coverage:show-all (lambda (f) + (string-contains f "lilypond"))))) + (if (pair? failed) + (begin (ly:error (_ "failed files: ~S") (string-join failed)) + (exit 1)) + (begin + ;; HACK: be sure to exit with single newline + (ly:message "") + (exit 0))))) + +(define-public (lilypond-all files) (let* ((failed '()) - (handler (lambda (key arg) (set! failed (cons arg failed))))) + (separate-logs (ly:get-option 'separate-log-files)) + (ping-log + (if separate-logs + (open-file (if (string-or-symbol? (ly:get-option 'log-file)) + (format "~a.log" (ly:get-option 'log-file)) + "/dev/tty") "a") #f)) + (do-measurements (ly:get-option 'dump-profile)) + (handler (lambda (key failed-file) + (set! failed (append (list failed-file) failed))))) + (gc) (for-each - (lambda (f) - (catch 'ly-file-failed (lambda () (ly:parse-file f)) handler) - (if #f - (dump-gc-protects))) + (lambda (x) + (let* ((start-measurements (if do-measurements + (profile-measurements) + #f)) + (base (dir-basename x ".ly")) + (all-settings (ly:all-options))) + (if separate-logs + (ly:stderr-redirect (format "~a.log" base) "w")) + (if ping-log + (format ping-log "Processing ~a\n" base)) + (if (ly:get-option 'trace-memory-frequency) + (mtrace:start-trace (ly:get-option 'trace-memory-frequency))) + (lilypond-file handler x) + (if start-measurements + (dump-profile x start-measurements (profile-measurements))) + (if (ly:get-option 'trace-memory-frequency) + (begin (mtrace:stop-trace) + (mtrace:dump-results base))) + (for-each (lambda (s) + (ly:set-option (car s) (cdr s))) + all-settings) + (ly:clear-anonymous-modules) + (ly:set-option 'debug-gc-assert-parsed-dead #t) + (gc) + (ly:set-option 'debug-gc-assert-parsed-dead #f) + (if (ly:get-option 'debug-gc) + (dump-gc-protects) + (if (= (random 40) 1) + (ly:reset-all-fonts))))) files) - - (if (pair? failed) - (begin - (newline (current-error-port)) - (display (_ "error: failed files: ") (current-error-port)) - (display (string-join failed) (current-error-port)) - (newline (current-error-port)) - (newline (current-error-port)) - (exit 1)) - (exit 0)))) - -(define-public (tweak-grob-property grob sym val) - (set! (ly:grob-property grob sym) val)) + + ;; we want the failed-files notice in the aggregrate logfile. + (if ping-log + (format ping-log "Failed files: ~a\n" failed)) + (if (ly:get-option 'dump-profile) + (dump-profile "lily-run-total" '(0 0) (profile-measurements))) + failed)) + +(define (lilypond-file handler file-name) + (catch 'ly-file-failed + (lambda () (ly:parse-file file-name)) + (lambda (x . args) (handler x file-name)))) + +(use-modules (scm editor)) + +(define-public (gui-main files) + (if (null? files) + (gui-no-files-handler)) + (if (not (string? (ly:get-option 'log-file))) + (let* ((base (dir-basename (car files) ".ly")) + (log-name (string-append base ".log"))) + (if (not (ly:get-option 'gui)) + (ly:message (_ "Redirecting output to ~a...") log-name)) + (ly:stderr-redirect log-name "w") + (ly:message "# -*-compilation-*-")) + (let ((failed (lilypond-all files))) + (if (pair? failed) + (begin + ;; ugh + (ly:stderr-redirect "foo" "r") + (system (get-editor-command log-name 0 0 0)) + (ly:error (_ "failed files: ~S") (string-join failed)) + ;; not reached? + (exit 1)) + (exit 0))))) + +(define (gui-no-files-handler) + (let* ((ly (string-append (ly:effective-prefix) "/ly/")) + ;; FIXME: soft-code, localize + (welcome-ly (string-append ly "Welcome_to_LilyPond.ly")) + (cmd (get-editor-command welcome-ly 0 0 0))) + (ly:message (_ "Invoking `~a'...\n") cmd) + (system cmd) + (exit 1)))