X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Flily.scm;h=7ed892cc4026b02085efa4f0aa859cfad5ed1ac2;hb=cc676c5aadd45985251b5d60fa23eed1ed98f6e6;hp=1cd2fc684b665f7c7805a465c23abb1a4da4189e;hpb=628042b4a0d2c3a12c54f2684e417f4cfe95af72;p=lilypond.git diff --git a/scm/lily.scm b/scm/lily.scm index 1cd2fc684b..7ed892cc40 100644 --- a/scm/lily.scm +++ b/scm/lily.scm @@ -1,523 +1,449 @@ -;;;; lily.scm -- implement Scheme output routines for TeX and PostScript +;;;; lily.scm -- toplevel Scheme stuff ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 1998--2004 Jan Nieuwenhuizen +;;;; (c) 1998--2006 Jan Nieuwenhuizen ;;;; Han-Wen Nienhuys -;;; Library functions + +(define (define-scheme-options) + (for-each (lambda (x) + (ly:add-option (car x) (cadr x) (caddr x))) + + `((point-and-click #t "use point & click") + (paper-size "a4" "the default paper size") + (midi-debug #f "generate human readable MIDI") + (dump-signatures #f "dump output signatures of each system (EPS backend)") + (internal-type-checking #f "check every property assignment for types") + (parse-protect #t "continue when finding errors in inline +scheme are caught in the parser. If off, halt +on errors, and print a stack trace.") + (profile-property-accesses #f "keep statistics of get_property() calls.") + (old-relative #f + "relative for simultaneous music works +similar to chord syntax") + (object-keys #f + "experimental mechanism for remembering tweaks") + (resolution 101 "resolution for generating bitmaps") + (anti-alias-factor 1 "render at higher resolution and scale down result\nto prevent jaggies in PNG") + (book-title-preview #t "include book-titles in preview images.") + (eps-font-include #f "Include fonts in separate-system EPS files.") + (gs-font-load #f + "load fonts via Ghostscript.") + (gui #f "running from gui; redirect stderr to log file") + (delete-intermediate-files #f + "delete unusable PostScript files") + (safe #f "Run safely") + (verbose ,(ly:command-line-verbose?) "value for the --verbose flag") + (strict-infinity-checking #f "If yes, crash on encountering Inf/NaN") + (ttf-verbosity 0 + "how much verbosity for TTF font embedding?") + (debug-gc #f + "dump GC protection info") + (show-available-fonts #f + "List font names available.") + ))) + + +;; need to do this in the beginning. Other parts of the +;; Scheme init depend on these options. +;; +(define-scheme-options) (if (defined? 'set-debug-cell-accesses!) (set-debug-cell-accesses! #f)) +;(set-debug-cell-accesses! 1000) + (use-modules (ice-9 regex) (ice-9 safe) + (ice-9 optargs) (oop goops) - (srfi srfi-1) ; lists - (srfi srfi-13)) ; strings + (srfi srfi-1) + (srfi srfi-13) + (srfi srfi-14)) -(define-public safe-module (make-safe-module)) +;; my display (define-public (myd k v) (display k) (display ": ") (display v) (display ", ")) +(define-public (print . args) + (apply format (cons (current-output-port) args))) + + ;;; General settings ;;; debugging evaluator is slower. This should ;;; have a more sensible default. - (if (ly:get-option 'verbose) (begin (debug-enable 'debug) (debug-enable 'backtrace) - (read-enable 'positions) )) - - -(define-public (line-column-location line col file) - "Print an input location, including column number ." - (string-append (number->string line) ":" - (number->string col) " " file) - ) + (read-enable 'positions))) -(define-public (line-location line col file) - "Print an input location, without column number ." - (string-append (number->string line) " " file) - ) +(define-public tex-backend? + (member (ly:output-backend) '("texstr" "tex"))) -(define-public point-and-click #f) +(define-public parser #f) (define-public (lilypond-version) (string-join (map (lambda (x) (if (symbol? x) (symbol->string x) (number->string x))) - (ly:version)) + (ly:version)) ".")) +;; TeX C++ code actually hooks into TEX_STRING_HASHLIMIT +(define-public TEX_STRING_HASHLIMIT 10000000) -;; cpp hack to get useful error message -(define ifdef "First run this through cpp.") -(define ifndef "First run this through cpp.") +;; gettext wrapper for guile < 1.7.2 +(if (defined? 'gettext) + (define-public _ gettext) + (define-public _ ly:gettext)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-public X 0) -(define-public Y 1) -(define-public START -1) -(define-public STOP 1) -(define-public LEFT -1) -(define-public RIGHT 1) -(define-public UP 1) -(define-public DOWN -1) -(define-public CENTER 0) - -(define-public DOUBLE-FLAT -4) -(define-public THREE-Q-FLAT -3) -(define-public FLAT -2) -(define-public SEMI-FLAT -1) -(define-public NATURAL 0) -(define-public SEMI-SHARP 1) -(define-public SHARP 2) -(define-public THREE-Q-SHARP 3) -(define-public DOUBLE-SHARP 4) -(define-public SEMI-TONE 2) - -(define-public ZERO-MOMENT (ly:make-moment 0 1)) - -(define-public (moment-min a b) - (if (ly:momentsymbol + (string-downcase + (car (string-tokenize (vector-ref (uname) 0) char-set:letter))))) + +(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) #\/)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Unassorted utility functions. - - -;;;;;;;;;;;;;;;; -; alist -(define (uniqued-alist alist acc) - (if (null? alist) acc - (if (assoc (caar alist) acc) - (uniqued-alist (cdr alist) acc) - (uniqued-alist (cdr alist) (cons (car alist) acc))))) - - -(define-public (assoc-get key alist . default) - "Return value if KEY in ALIST, else DEFAULT (or #f if not specified)." - (let ((entry (assoc key alist))) - (if (pair? entry) - (cdr entry) - (if (pair? default) (car default) #f) - ))) - -(define-public (uniqued-alist alist acc) - (if (null? alist) acc - (if (assoc (caar alist) acc) - (uniqued-alist (cdr alist) acc) - (uniqued-alist (cdr alist) (cons (car alist) acc))))) - -(define-public (aliststring (car x)) - (symbol->string (car y)))) - - - -(define (chain-assoc x alist-list) - (if (null? alist-list) - #f - (let* ((handle (assoc x (car alist-list)))) - (if (pair? handle) - handle - (chain-assoc x (cdr alist-list)))))) - - -(define (chain-assoc-get x alist-list . default) - "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not -found." - - (define (helper x alist-list default) - (if (null? alist-list) - default - (let* ((handle (assoc x (car alist-list)))) - (if (pair? handle) - (cdr handle) - (helper x (cdr alist-list) default))))) - - (helper x alist-list - (if (pair? default) (car default) #f))) - -(define (map-alist-vals func list) - "map FUNC over the vals of LIST, leaving the keys." - (if (null? list) - '() - (cons (cons (caar list) (func (cdar list))) - (map-alist-vals func (cdr list))) - )) - -(define (map-alist-keys func list) - "map FUNC over the keys of an alist LIST, leaving the vals. " - (if (null? list) - '() - (cons (cons (func (caar list)) (cdar list)) - (map-alist-keys func (cdr list))) - )) - -;;;;;;;;;;;;;;;; -;; hash - - - -(if (not (defined? 'hash-table?)) ; guile 1.6 compat - (begin - (define hash-table? vector?) - - (define-public (hash-table->alist t) - "Convert table t to list" - (apply append - (vector->list t) - ))) - - ;; native hashtabs. - (begin - (define-public (hash-table->alist t) - - (hash-fold (lambda (k v acc) (acons k v acc)) - '() t) - ) - )) - -;; todo: code dup with C++. -(define-public (alist->hash-table l) - "Convert alist to table" - (let - ((m (make-hash-table (length l)))) - - (map (lambda (k-v) - (hashq-set! m (car k-v) (cdr k-v))) - l) - - m)) - - - -;;;;;;;;;;;;;;;; -; list - -(define (flatten-list lst) - "Unnest LST" - (if (null? lst) - '() - (if (pair? (car lst)) - (append (flatten-list (car lst)) (flatten-list (cdr lst))) - (cons (car lst) (flatten-list (cdr lst)))) - )) - -(define (list-minus a b) - "Return list of elements in A that are not in B." - (lset-difference eq? a b)) - -;; TODO: use the srfi-1 partition function. -(define-public (uniq-list l) - - "Uniq LIST, assuming that it is sorted" - (define (helper acc l) - (if (null? l) - acc - (if (null? (cdr l)) - (cons (car l) acc) - (if (equal? (car l) (cadr l)) - (helper acc (cdr l)) - (helper (cons (car l) acc) (cdr l))) - ))) - (reverse! (helper '() l) '())) - - -(define (split-at-predicate predicate l) - "Split L = (a_1 a_2 ... a_k b_1 ... b_k) -into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k) -Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1). -L1 is copied, L2 not. - -(split-at-predicate (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))" -;; " - -;; KUT EMACS MODE. - - (define (inner-split predicate l acc) - (cond - ((null? l) acc) - ((null? (cdr l)) - (set-car! acc (cons (car l) (car acc))) - acc) - ((predicate (car l) (cadr l)) - (set-car! acc (cons (car l) (car acc))) - (inner-split predicate (cdr l) acc)) - (else - (set-car! acc (cons (car l) (car acc))) - (set-cdr! acc (cdr l)) - acc) - - )) - (let* - ((c (cons '() '())) - ) - (inner-split predicate l c) - (set-car! c (reverse! (car c))) - c) -) - - -(define-public (split-list l sep?) -" -(display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))) ) -=> -((a b c) (d e f) (g)) - -" -;; " KUT EMACS. - -(define (split-one sep? l acc) - "Split off the first parts before separator and return both parts." - (if (null? l) - (cons acc '()) - (if (sep? (car l)) - (cons acc (cdr l)) - (split-one sep? (cdr l) (cons (car l) acc)) - ) - )) - -(if (null? l) - '() - (let* ((c (split-one sep? l '()))) - (cons (reverse! (car c) '()) (split-list (cdr c) sep?)) - ))) - - -(define-public (interval-length x) - "Length of the number-pair X, when an interval" - (max 0 (- (cdr x) (car x))) - ) - - -(define (other-axis a) - (remainder (+ a 1) 2)) - - -(define-public (interval-widen iv amount) - (cons (- (car iv) amount) - (+ (cdr iv) amount))) - -(define-public (interval-union i1 i2) - (cons (min (car i1) (car i2)) - (max (cdr i1) (cdr i2)))) - - -(define-public (write-me message x) - "Return X. Display MESSAGE and write X. Handy for debugging, possibly turned off." - (display message) (write x) (newline) x) -;; x) - -(define (index-cell cell dir) - (if (equal? dir 1) - (cdr cell) - (car cell))) - -(define (cons-map f x) - "map F to contents of X" - (cons (f (car x)) (f (cdr x)))) - - -(define-public (list-insert-separator lst between) - "Create new list, inserting BETWEEN between elements of LIST" - (define (conc x y ) - (if (eq? y #f) - (list x) - (cons x (cons between y)) - )) - (fold-right conc #f lst)) - -;;;;;;;;;;;;;;;; -; other -(define (sign x) - (if (= x 0) - 0 - (if (< x 0) -1 1))) +(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-public (symbolstring l) (symbol->string r))) + (define (recursion-helper signature arguments count) + (define (helper pred? arg count) + (if (not (pred? arg)) -(define-public (!= l r) - (not (= l r))) + (begin + (ly:input-message + location + (format + #f (_ "wrong type for argument ~a. Expecting ~a, found ~s") + count (type-name pred?) arg)) + #f) + #t)) -(define-public (ly:load x) - (let* ( - (fn (%search-load-path x)) - - ) - (if (ly:get-option 'verbose) - (format (current-error-port) "[~A]" fn)) - (primitive-load fn))) + (if (null? signature) + #t + (and (helper (car signature) (car arguments) count) + (recursion-helper (cdr signature) (cdr arguments) (1+ count))))) + (recursion-helper signature arguments 1)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; output -(use-modules - ;(scm output-sketch) - ;(scm output-sodipodi) - ;(scm output-pdftex) - ) +;;(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 (tex-output-expression expr port) - (display (eval expr output-tex-module) port)) + (define-public (ps-output-expression expr port) (display (eval expr output-ps-module) port)) -(define output-alist - `( - ("tex" . ("TeX output. The default output form." ,tex-output-expression)) - ("scm" . ("Scheme dump: debug scheme stencil expressions" ,write)) -; ("sketch" . ("Bare bones Sketch output." ,sketch-output-expression)) -; ("sodipodi" . ("Bare bones Sodipodi output." ,sodipodi-output-expression)) -; ("pdftex" . ("PDFTeX output. Was last seen nonfunctioning." ,pdftex-output-expression)) - )) - - -(define (document-format-dumpers) - (map - (lambda (x) - (display (string-append (pad-string-to 5 (car x)) (cadr x) "\n")) - output-alist) - )) - -(define-public (find-dumper format) - (let ((d (assoc format output-alist))) - (if (pair? d) - (caddr d) - (scm-error "Could not find dumper for format ~s" format)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Safe definitions utility +(define safe-objects (list)) + +(define-macro (define-safe-public arglist . body) + "Define a variable, export it, and mark it as safe, ie 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))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; other files. (for-each ly:load - ;; load-from-path - '("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" - - "define-context-properties.scm" - "translation-functions.scm" - "script.scm" - "midi.scm" - - "beam.scm" - "clef.scm" - "slur.scm" - "font.scm" - - "define-markup-commands.scm" - "define-grob-properties.scm" - "define-grobs.scm" - "define-grob-interfaces.scm" - - "page-layout.scm" - "paper.scm" - )) + ;; load-from-path + '("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" + "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" + + "fret-diagrams.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" + + ;; must be after everything has been defined + "safe-lily.scm")) (set! type-p-name-alist - `( - (,boolean-or-symbol? . "boolean or symbol") - (,boolean? . "boolean") - (,char? . "char") - (,grob-list? . "list of grobs") - (,hash-table? . "hash table") - (,input-port? . "input port") - (,integer? . "integer") - (,list? . "list") - (,ly:context? . "context") - (,ly:dimension? . "dimension, in staff space") - (,ly:dir? . "direction") - (,ly:duration? . "duration") - (,ly:grob? . "layout object") - (,ly:input-location? . "input location") - (,ly:moment? . "moment") - (,ly:music? . "music") - (,ly:pitch? . "pitch") - (,ly:translator? . "translator") - (,ly:font-metric? . "font metric") - (,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") - (,pair? . "pair") - (,procedure? . "procedure") - (,scheme? . "any type") - (,string? . "string") - (,symbol? . "symbol") - (,vector? . "vector") - )) + `( + (,boolean-or-symbol? . "boolean or symbol") + (,boolean? . "boolean") + (,char? . "char") + (,grob-list? . "list of grobs") + (,hash-table? . "hash table") + (,input-port? . "input port") + (,integer? . "integer") + (,list? . "list") + (,ly:context? . "context") + (,ly:dimension? . "dimension, in staff space") + (,ly:dir? . "direction") + (,ly:duration? . "duration") + (,ly:grob? . "layout object") + (,ly:input-location? . "input location") + (,ly:moment? . "moment") + (,ly:music? . "music") + (,ly:pitch? . "pitch") + (,ly:translator? . "translator") + (,ly:font-metric? . "font metric") + (,ly:simple-closure? . "simple closure") + (,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") + (,pair? . "pair") + (,procedure? . "procedure") + (,scheme? . "any type") + (,string? . "string") + (,symbol? . "symbol") + (,vector? . "vector"))) ;; debug mem leaks (define gc-protect-stat-count 0) (define-public (dump-gc-protects) - (set! gc-protect-stat-count (1+ gc-protect-stat-count) ) - (let* - ((protects (sort - (hash-table->alist (ly:protects)) - (lambda (a b) - (< (object-address (car a)) - (object-address (car b)))))) - (outfile (open-file (string-append - "gcstat-" (number->string gc-protect-stat-count) - ".scm" - ) "w")) - ) - + (set! gc-protect-stat-count (1+ gc-protect-stat-count)) + (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 (format "Dumping gc protected objs to ~a...\n" out-file-name)) (display - (filter - (lambda (x) (not (symbol? x))) - (map (lambda (y) - (let - ((x (car y)) + (map (lambda (y) + (let ((x (car y)) (c (cdr y))) - - (string-append - (string-join - (map object->string (list (object-address x) c x)) - " ") - "\n"))) + + (string-append + (string-join + (map object->string (list (object-address x) c x)) + " ") + "\n"))) + + (filter + (lambda (x) + (not (symbol? (car x)))) protects)) outfile) - )) +; (display (ly:smob-protects)) + (newline outfile) + (if (defined? 'gc-live-object-stats) + (let* ((stats #f)) + (display "Live object statistics: GC'ing\n") + (gc) + (gc) + + (set! stats (gc-live-object-stats)) + (display "Dumping live object statistics.\n") + + (for-each + (lambda (x) + (format outfile "~a: ~a\n" (car x) (cdr x))) + (sort (gc-live-object-stats) + (lambda (x y) + (string