From f41963f0b6135c02c363f8401628e85b9bc60def Mon Sep 17 00:00:00 2001 From: Ian Hulin Date: Mon, 22 Aug 2011 11:01:13 +0100 Subject: [PATCH] T1349 - Fix load order for running with Guile V2 1. Split load list into components (init-scheme-files-lib, *-used, *-body and *-tail, and append them together before doing load. 2. Split markup macros from markup.scm to new file markup-macros.scm --- scm/lily.scm | 513 +++++++++++++++++++------------------- scm/markup-macros.scm | 479 ++++++++++++++++++++++++++++++++++++ scm/markup.scm | 555 ++++-------------------------------------- 3 files changed, 788 insertions(+), 759 deletions(-) create mode 100644 scm/markup-macros.scm diff --git a/scm/lily.scm b/scm/lily.scm index cf6c8b07c8..55d989e2d2 100644 --- a/scm/lily.scm +++ b/scm/lily.scm @@ -121,8 +121,8 @@ jobs.") "If string FOO is given as argument, redirect output to log file `FOO.log'.") (midi-extension ,(if (eq? PLATFORM 'windows) - "mid" - "midi") + "mid" + "midi") "Set the default file extension for MIDI output file to given string.") (music-strings-to-paths #f @@ -190,12 +190,12 @@ messages into errors.") ;; initialization depend on these options. (for-each (lambda (x) - (ly:add-option (car x) (cadr x) (caddr x))) - scheme-options-definitions) + (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))) + (ly:set-option (car x) (cdr x))) + (eval-string (ly:command-line-options))) (debug-set! stack 0) @@ -205,17 +205,17 @@ messages into errors.") ;;(set-debug-cell-accesses! 1000) (use-modules (ice-9 regex) - (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)) + (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 _ gettext) ;;; There are new modules defined in Guile V2.0 which we need to use. @@ -264,9 +264,10 @@ messages into errors.") ;;; Debugging evaluator is slower. This should have a more sensible ;;; default. + (if (or (ly:get-option 'verbose) - (ly:get-option 'trace-memory-frequency) - (ly:get-option 'trace-scheme-coverage)) + (ly:get-option 'trace-memory-frequency) + (ly:get-option 'trace-scheme-coverage)) (begin (ly:set-option 'protected-scheme-parsing #f) (debug-enable 'backtrace) @@ -297,16 +298,16 @@ messages into errors.") (define-public DOS (let ((platform (string-tokenize - (vector-ref (uname) 0) char-set:letter+digit))) + (vector-ref (uname) 0) char-set:letter+digit))) (if (null? (cdr platform)) #f - (member (string-downcase (cadr platform)) '("95" "98" "me"))))) + (member (string-downcase (cadr platform)) '("95" "98" "me"))))) (define (slashify x) (if (string-index x #\\) x (string-regexp-substitute - "//*" "/" - (string-regexp-substitute "\\\\" "/" x)))) + "//*" "/" + (string-regexp-substitute "\\\\" "/" x)))) (define-public (ly-getcwd) (if (eq? PLATFORM 'windows) @@ -316,12 +317,12 @@ messages into errors.") (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) #\/)))))) + #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) #\/)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; If necessary, emulate Guile V2 module_export_all! for Guile V1.8.n @@ -330,13 +331,13 @@ messages into errors.") (define (module-export-all! mod) (define (fresh-interface!) (let ((iface (make-module))) - (set-module-name! iface (module-name mod)) - ;; for guile 2: (set-module-version! iface (module-version mod)) - (set-module-kind! iface 'interface) - (set-module-public-interface! mod iface) - iface)) + (set-module-name! iface (module-name mod)) + ;; for guile 2: (set-module-version! iface (module-version mod)) + (set-module-kind! iface 'interface) + (set-module-public-interface! mod iface) + iface)) (let ((iface (or (module-public-interface mod) - (fresh-interface!)))) + (fresh-interface!)))) (set-module-obarray! iface (module-obarray mod)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -346,19 +347,19 @@ 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)) - #f) - #t)) + (begin + (ly:input-message + location + (format + #f (_ "wrong type for argument ~a. Expecting ~a, found ~s") + count (type-name pred?) arg)) + #f) + #t)) (if (null? signature) - #t - (and (helper (car signature) (car arguments) count) - (recursion-helper (cdr signature) (cdr arguments) (1+ count))))) + #t + (and (helper (car signature) (car arguments) count) + (recursion-helper (cdr signature) (cdr arguments) (1+ count))))) (recursion-helper signature arguments 1)) @@ -387,9 +388,9 @@ LilyPond safe mode. The syntax is the same as `define*-public'." (define-safe-public (lilypond-version) (string-join (map (lambda (x) (if (symbol? x) - (symbol->string x) - (number->string x))) - (ly:version)) + (symbol->string x) + (number->string x))) + (ly:version)) ".")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -400,36 +401,43 @@ LilyPond safe mode. The syntax is the same as `define*-public'." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; other files. -(define init-scheme-files +;; +;; List of Scheme files to be loaded into the (lily) module. +;; +;; - Library definitions, need to be at the head of the list +(define init-scheme-files-lib '("lily-library.scm" - "file-cache.scm" + "output-lib.scm")) +;; - Files containing definitions used later by other files later in load +(define init-scheme-files-used + '("markup-macros.scm")) +;; - Main body of files to be loaded +(define init-scheme-files-body + '("file-cache.scm" "define-event-classes.scm" "define-music-callbacks.scm" "define-music-types.scm" "define-note-names.scm" - "output-lib.scm" "c++.scm" - "chord-ignatzek-names.scm" "chord-entry.scm" - "chord-generic-names.scm" "stencil.scm" + "define-markup-commands.scm" "markup.scm" "modal-transforms.scm" + "chord-generic-names.scm" + "chord-ignatzek-names.scm" "music-functions.scm" "part-combiner.scm" "autochange.scm" "define-music-properties.scm" "time-signature-settings.scm" "auto-beam.scm" + "chord-name.scm" "bezier-tools.scm" "parser-ly-from-scheme.scm" "ly-syntax-constructors.scm" "define-context-properties.scm" - ;; guile 1.9 wants markups defined before referenced - "define-markup-commands.scm" - - "chord-name.scm" "translation-functions.scm" "script.scm" "midi.scm" @@ -454,10 +462,19 @@ LilyPond safe mode. The syntax is the same as `define*-public'." "paper.scm" "backend-library.scm" - "x11-color.scm" - - ;; must be after everything has been defined - "safe-lily.scm")) + "x11-color.scm")) +;; - Files to be loaded last +(define init-scheme-files-tail +;; - must be after everything has been defined + '("safe-lily.scm")) +;; +;; Now construct the load list +;; +(define init-scheme-files + (append init-scheme-files-lib + init-scheme-files-used + init-scheme-files-body + init-scheme-files-tail)) (for-each ly:load init-scheme-files) @@ -581,22 +598,22 @@ LilyPond safe mode. The syntax is the same as `define*-public'." (define (profile-measurements) (let* ((t (times)) - (stats (gc-stats))) + (stats (gc-stats))) (list (- (+ (tms:cutime t) - (tms:utime t)) - (assoc-get 'gc-time-taken stats)) - (assoc-get 'total-cells-allocated stats 0)))) + (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 #f "~a.profile" (dir-basename base ".ly"))) - (diff (map (lambda (y) (apply - y)) (zip this last)))) + (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)))) + "time: ~a\ncells: ~a\n" + (if (ly:get-option 'dump-cpu-profile) + (car diff) + 0) + (cadr diff)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; debug memory leaks @@ -609,61 +626,61 @@ LilyPond safe mode. The syntax is the same as `define*-public'." (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)))))) - (out-file-name (string-append - "gcstat-" (number->string gc-protect-stat-count) - ".scm")) - (outfile (open-file out-file-name "w"))) + (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"))) (set! gc-dumping #t) (format #t "Dumping GC statistics ~a...\n" out-file-name) (for-each (lambda (y) - (let ((x (car y)) - (c (cdr y))) - (format outfile "~a (~a) = ~a\n" (object-address x) c x))) - (filter - (lambda (x) - (not (symbol? (car x)))) - protects)) + (let ((x (car y)) + (c (cdr y))) + (format outfile "~a (~a) = ~a\n" (object-address x) c x))) + (filter + (lambda (x) + (not (symbol? (car x)))) + protects)) (format outfile "\nprotected symbols: ~a\n" - (apply + (map (lambda (obj-count) - (if (symbol? (car obj-count)) - (cdr obj-count) - 0)) - protects))) + (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))) + (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) - (format outfile "~a ~a ~a\n" - gc-protect-stat-count - sym - (assoc-get sym stats "?"))) - '(protected-objects bytes-malloced cell-heap-size))) + (format outfile "~a ~a ~a\n" + gc-protect-stat-count + sym + (assoc-get sym stats "?"))) + '(protected-objects bytes-malloced cell-heap-size))) (set! gc-dumping #f) (close-port outfile))) @@ -671,23 +688,23 @@ LilyPond safe mode. The syntax is the same as `define*-public'." "Read `/proc/self' to check up on memory use." (define (gulp-file name) (let* ((file (open-input-file name)) - (text (read-delimited "" file))) + (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)))) + (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)))) (format #t "VMDATA: ~a\n" mem) (display (gc-stats)) (if (> mem 100000) - (begin (dump-gc-protects) - (raise 1))))) + (begin (dump-gc-protects) + (raise 1))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -696,11 +713,11 @@ LilyPond safe mode. The syntax is the same as `define*-public'." 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)) + (let* ((pid (primitive-fork))) + (if (= pid 0) + (1- count) + (helper (1- count) (cons pid acc)))) + acc)) (helper count '())) @@ -710,9 +727,9 @@ PIDs or the number of the process." "Exit function for lilypond" (if (not silently) (case status - ((0) (ly:success (_ "Compilation successfully completed"))) - ((1) (ly:warning (_ "Compilation completed with warnings or errors"))) - (else (ly:message "")))) + ((0) (ly:success (_ "Compilation successfully completed"))) + ((1) (ly:warning (_ "Compilation completed with warnings or errors"))) + (else (ly:message "")))) (exit status)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -722,141 +739,141 @@ PIDs or the number of the process." (eval-string (ly:command-line-code)) (if (ly:get-option 'help) (begin (ly:option-usage) - (ly:exit 0 #t))) + (ly:exit 0 #t))) (if (ly:get-option 'show-available-fonts) (begin (ly:font-config-display-fonts) - (ly:exit 0 #t))) + (ly:exit 0 #t))) (if (ly:get-option 'gui) (gui-main files)) (if (null? files) (begin (ly:usage) - (ly:exit 2 #t))) + (ly:exit 2 #t))) (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))))) + (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))) + (>= (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 #f "~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 #f "~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 #f (_ "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))) - (if (null? errors) - (ly:exit 0 #f) - (ly:exit 1 #f)))))) + (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 #f "~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 #f "~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 #f (_ "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))) + (if (null? errors) + (ly:exit 0 #f) + (ly:exit 1 #f)))))) (if (string-or-symbol? (ly:get-option 'log-file)) (ly:stderr-redirect (format #f "~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"))))) + (begin + (coverage:show-all (lambda (f) + (string-contains f "lilypond"))))) (if (pair? failed) - (begin (ly:error (_ "failed files: ~S") (string-join failed)) - (ly:exit 1 #f)) - (begin - (ly:exit 0 #f))))) + (begin (ly:error (_ "failed files: ~S") (string-join failed)) + (ly:exit 1 #f)) + (begin + (ly:exit 0 #f))))) (define-public (lilypond-all files) (let* ((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 #f "~a.log" (ly:get-option 'log-file)) - "/dev/stderr") "a") #f)) - (do-measurements (ly:get-option 'dump-profile)) - (handler (lambda (key failed-file) - (set! failed (append (list failed-file) 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 #f "~a.log" (ly:get-option 'log-file)) + "/dev/stderr") "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 (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 #f "~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: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) + (profile-measurements) + #f)) + (base (dir-basename x ".ly")) + (all-settings (ly:all-options))) + (if separate-logs + (ly:stderr-redirect (format #f "~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: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) (ly:reset-all-fonts)))) files) ;; Ensure a notice re failed files is written to aggregate logfile. (if ping-log - (format ping-log "Failed files: ~a\n" failed)) + (format ping-log "Failed files: ~a\n" failed)) (if (ly:get-option 'dump-profile) - (dump-profile "lily-run-total" '(0 0) (profile-measurements))) + (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)))) + (lambda () (ly:parse-file file-name)) + (lambda (x . args) (handler x file-name)))) (use-modules (scm editor)) @@ -865,27 +882,27 @@ PIDs or the number of the process." (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-*-")) + (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)) - (ly:exit 0 #f))))) + (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)) + (ly:exit 0 #f))))) (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))) + ;; 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) (ly:exit 1 #f))) diff --git a/scm/markup-macros.scm b/scm/markup-macros.scm new file mode 100644 index 0000000000..cccfaccfcb --- /dev/null +++ b/scm/markup-macros.scm @@ -0,0 +1,479 @@ +;;;; This file is part of LilyPond, the GNU music typesetter. +;;;; +;;;; Copyright (C) 2003--2010 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 . + +" +Internally markup is stored as lists, whose head is a function. + + (FUNCTION ARG1 ARG2 ... ) + +When the markup is formatted, then FUNCTION is called as follows + + (FUNCTION GROB PROPS ARG1 ARG2 ... ) + +GROB is the current grob, PROPS is a list of alists, and ARG1.. are +the rest of the arguments. + +The function should return a stencil (i.e. a formatted, ready to +print object). + + +To add a markup command, use the define-markup-command utility. + + (define-markup-command (mycommand layout prop arg1 ...) (arg1-type? ...) + \"my command usage and description\" + ...function body...) + +The command is now available in markup mode, e.g. + + \\markup { .... \\MYCOMMAND #1 argument ... } + +" ; " + +;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; markup definer utilities + +;; For documentation purposes +;; category -> markup functions +(define-public markup-functions-by-category (make-hash-table 150)) +;; markup function -> used properties +(define-public markup-functions-properties (make-weak-key-hash-table 151)) +;; List of markup list functions +(define-public markup-list-functions (make-weak-key-hash-table 151)) + +(use-modules (ice-9 optargs)) + +(defmacro*-public define-markup-command + (command-and-args signature + #:key (category '()) (properties '()) + #:rest body) + " +* Define a COMMAND-markup function after command-and-args and body, +register COMMAND-markup and its signature, + +* add COMMAND-markup to markup-functions-by-category, + +* sets COMMAND-markup markup-signature object property, + +* define a make-COMMAND-markup function. + +Syntax: + (define-markup-command (COMMAND layout props . arguments) + argument-types + [ #:properties properties ] + \"documentation string\" + ...command body...) + +where: + `argument-types' is a list of type predicates for arguments + `properties' a list of (property default-value) lists + +The specified properties are available as let-bound variables in the +command body, using the respective `default-value' as fallback in case +`property' is not found in `props'. `props' itself is left unchanged: +if you want defaults specified in that manner passed down into other +markup functions, you need to adjust `props' yourself. + +The autogenerated documentation makes use of some optional +specifications that are otherwise ignored: + +After `argument-types', you may also specify + [ #:category category ] +where: + `category' is either a symbol or a symbol list specifying the + category for this markup command in the docs. + +As an element of the `properties' list, you may directly use a +COMMANDx-markup symbol instead of a `(prop value)' list to indicate +that this markup command is called by the newly defined command, +adding its properties to the documented properties of the new +command. There is no protection against circular definitions. +" + (let* ((command (car command-and-args)) + (args (cdr command-and-args)) + (command-name (string->symbol (format #f "~a-markup" command))) + (make-markup-name (string->symbol (format #f "make-~a-markup" command)))) + (while (and (pair? body) (keyword? (car body))) + (set! body (cddr body))) + `(begin + ;; define the COMMAND-markup function + ,(let* ((documentation (if (string? (car body)) + (list (car body)) + '())) + (real-body (if (or (null? documentation) + (null? (cdr body))) + body (cdr body)))) + `(define-public (,command-name ,@args) + ,@documentation + (let ,(map (lambda (prop-spec) + (let ((prop (car prop-spec)) + (default-value (if (null? (cdr prop-spec)) + #f + (cadr prop-spec))) + (props (cadr args))) + `(,prop (chain-assoc-get ',prop ,props ,default-value)))) + (filter pair? properties)) + ,@real-body))) + (set! (markup-command-signature ,command-name) (list ,@signature)) + ;; Register the new function, for markup documentation + ,@(map (lambda (category) + `(hashq-set! + (or (hashq-ref markup-functions-by-category ',category) + (let ((hash (make-weak-key-hash-table 151))) + (hashq-set! markup-functions-by-category ',category + hash) + hash)) + ,command-name #t)) + (if (list? category) category (list category))) + ;; Used properties, for markup documentation + (hashq-set! markup-functions-properties + ,command-name + (list ,@(map (lambda (prop-spec) + (cond ((symbol? prop-spec) + prop-spec) + ((not (null? (cdr prop-spec))) + `(list ',(car prop-spec) ,(cadr prop-spec))) + (else + `(list ',(car prop-spec))))) + (if (pair? args) + properties + (list))))) + ;; define the make-COMMAND-markup function + (define-public (,make-markup-name . args) + (let ((sig (list ,@signature))) + (make-markup ,command-name ,(symbol->string make-markup-name) sig args)))))) + +(defmacro*-public define-markup-list-command + (command-and-args signature #:key (properties '()) #:rest body) + "Same as `define-markup-command', but defines a command that, when +interpreted, returns a list of stencils instead of a single one" + (let* ((command (car command-and-args)) + (args (cdr command-and-args)) + (command-name (string->symbol (format #f "~a-markup-list" command))) + (make-markup-name (string->symbol (format #f "make-~a-markup-list" command)))) + (while (and (pair? body) (keyword? (car body))) + (set! body (cddr body))) + `(begin + ;; define the COMMAND-markup-list function + ,(let* ((documentation (if (string? (car body)) + (list (car body)) + '())) + (real-body (if (or (null? documentation) + (null? (cdr body))) + body (cdr body)))) + `(define-public (,command-name ,@args) + ,@documentation + (let ,(map (lambda (prop-spec) + (let ((prop (car prop-spec)) + (default-value (if (null? (cdr prop-spec)) + #f + (cadr prop-spec))) + (props (cadr args))) + `(,prop (chain-assoc-get ',prop ,props ,default-value)))) + (filter pair? properties)) + ,@real-body))) + (set! (markup-command-signature ,command-name) (list ,@signature)) + ;; add the command to markup-list-function-list, for markup documentation + (hashq-set! markup-list-functions ,command-name #t) + ;; Used properties, for markup documentation + (hashq-set! markup-functions-properties + ,command-name + (list ,@(map (lambda (prop-spec) + (cond ((symbol? prop-spec) + prop-spec) + ((not (null? (cdr prop-spec))) + `(list ',(car prop-spec) ,(cadr prop-spec))) + (else + `(list ',(car prop-spec))))) + (if (pair? args) + properties + (list))))) + ;; it's a markup-list command: + (set-object-property! ,command-name 'markup-list-command #t) + ;; define the make-COMMAND-markup-list function + (define-public (,make-markup-name . args) + (let ((sig (list ,@signature))) + (list (make-markup ,command-name + ,(symbol->string make-markup-name) sig args))))))) + +;;;;;;;;;;;;;;; +;;; Utilities for storing and accessing markup commands signature +;;; Examples: +;;; +;;; (set! (markup-command-signature raise-markup) (list number? markup?)) +;;; ==> (# #) +;;; +;;; (markup-command-signature raise-markup) +;;; ==> (# #) +;;; + +(define-public (markup-command-signature-ref markup-command) + "Return markup-command's signature (the 'markup-signature object property)" + (object-property markup-command 'markup-signature)) + +(define-public (markup-command-signature-set! markup-command signature) + "Set markup-command's signature (as object property)" + (set-object-property! markup-command 'markup-signature signature) + signature) + +(define-public markup-command-signature + (make-procedure-with-setter markup-command-signature-ref + markup-command-signature-set!)) + +;;;;;;;;;;;;;;;;;;;;;; +;;; markup type predicates + +(define (markup-function? x) + (and (markup-command-signature x) + (not (object-property x 'markup-list-command)))) + +(define (markup-list-function? x) + (and (markup-command-signature x) + (object-property x 'markup-list-command))) + +(define-public (markup-command-list? x) + "Determine if `x' is a markup command list, ie. a list composed of +a markup list function and its arguments." + (and (pair? x) (markup-list-function? (car x)))) + +(define-public (markup-list? arg) + "Return a true value if `x' is a list of markups or markup command lists." + (define (markup-list-inner? lst) + (or (null? lst) + (and (or (markup? (car lst)) (markup-command-list? (car lst))) + (markup-list-inner? (cdr lst))))) + (not (not (and (list? arg) (markup-list-inner? arg))))) + +(define (markup-argument-list? signature arguments) + "Typecheck argument list." + (if (and (pair? signature) (pair? arguments)) + (and ((car signature) (car arguments)) + (markup-argument-list? (cdr signature) (cdr arguments))) + (and (null? signature) (null? arguments)))) + + +(define (markup-argument-list-error signature arguments number) + "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or +#f is no error found. +" + (if (and (pair? signature) (pair? arguments)) + (if (not ((car signature) (car arguments))) + (list number (type-name (car signature)) (car arguments)) + (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number))) + #f)) + +;; +;; full recursive typecheck. +;; +(define (markup-typecheck? arg) + (or (string? arg) + (and (pair? arg) + (markup-function? (car arg)) + (markup-argument-list? (markup-command-signature (car arg)) + (cdr arg))))) + +;; +;; +;; +;; +(define (markup-thrower-typecheck arg) + "typecheck, and throw an error when something amiss. + +Uncovered - cheap-markup? is used." + + (cond ((string? arg) #t) + ((not (pair? arg)) + (throw 'markup-format "Not a pair" arg)) + ((not (markup-function? (car arg))) + (throw 'markup-format "Not a markup function " (car arg))) + ((not (markup-argument-list? (markup-command-signature (car arg)) + (cdr arg))) + (throw 'markup-format "Arguments failed typecheck for " arg))) + #t) + +;; +;; good enough if you only use make-XXX-markup functions. +;; +(define (cheap-markup? x) + (or (string? x) + (and (pair? x) + (markup-function? (car x))))) + +;; +;; replace by markup-thrower-typecheck for more detailed diagnostics. +;; +(define-public markup? cheap-markup?) + +(define-public (make-markup markup-function make-name signature args) + " Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck +against SIGNATURE, reporting MAKE-NAME as the user-invoked function. +" + (let* ((arglen (length args)) + (siglen (length signature)) + (error-msg (if (and (> siglen 0) (> arglen 0)) + (markup-argument-list-error signature args 1) + #f))) + (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0)) + (ly:error (string-append make-name ": " + (_ "Wrong number of arguments. Expect: ~A, found ~A: ~S")) + siglen arglen args)) + (if error-msg + (ly:error + (string-append + make-name ": " + (_ "Invalid argument in position ~A. Expect: ~A, found: ~S.")) + (car error-msg) (cadr error-msg)(caddr error-msg)) + (cons markup-function args)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; markup constructors +;;; lilypond-like syntax for markup construction in scheme. + +(use-modules (ice-9 receive)) + +(defmacro*-public markup* (#:rest body) + "Same as `markup', for use in a \\notes block." + `(ly:export (markup ,@body))) + + +(define (compile-all-markup-expressions expr) + "Return a list of canonical markups expressions, e.g.: + (#:COMMAND1 arg11 arg12 #:COMMAND2 arg21 arg22 arg23) + ===> + ((make-COMMAND1-markup arg11 arg12) + (make-COMMAND2-markup arg21 arg22 arg23) ...)" + (do ((rest expr rest) + (markps '() markps)) + ((null? rest) (reverse markps)) + (receive (m r) (compile-markup-expression rest) + (set! markps (cons m markps)) + (set! rest r)))) + +(define (keyword->make-markup key) + "Transform a keyword, e.g. #:COMMAND, in a make-COMMAND-markup symbol." + (string->symbol (string-append "make-" (symbol->string (keyword->symbol key)) "-markup"))) + +(define (compile-markup-expression expr) + "Return two values: the first complete canonical markup expression + found in `expr', e.g. (make-COMMAND-markup arg1 arg2 ...), + and the rest expression." + (cond ((and (pair? expr) + (keyword? (car expr))) + ;; expr === (#:COMMAND arg1 ...) + (let ((command (symbol->string (keyword->symbol (car expr))))) + (if (not (pair? (lookup-markup-command command))) + (ly:error (_ "Not a markup command: ~A") command)) + (let* ((sig (markup-command-signature + (car (lookup-markup-command command)))) + (sig-len (length sig))) + (do ((i 0 (1+ i)) + (args '() args) + (rest (cdr expr) rest)) + ((>= i sig-len) + (values (cons (keyword->make-markup (car expr)) (reverse args)) rest)) + (cond ((eqv? (list-ref sig i) markup-list?) + ;; (car rest) is a markup list + (set! args (cons `(list ,@(compile-all-markup-expressions (car rest))) args)) + (set! rest (cdr rest))) + (else + ;; pick up one arg in `rest' + (receive (a r) (compile-markup-arg rest) + (set! args (cons a args)) + (set! rest r)))))))) + ((and (pair? expr) + (pair? (car expr)) + (keyword? (caar expr))) + ;; expr === ((#:COMMAND arg1 ...) ...) + (receive (m r) (compile-markup-expression (car expr)) + (values m (cdr expr)))) + ((and (pair? expr) + (string? (car expr))) ;; expr === ("string" ...) + (values `(make-simple-markup ,(car expr)) (cdr expr))) + (else + ;; expr === (symbol ...) or ((funcall ...) ...) + (values (car expr) + (cdr expr))))) + +(define (compile-all-markup-args expr) + "Transform `expr' into markup arguments" + (do ((rest expr rest) + (args '() args)) + ((null? rest) (reverse args)) + (receive (a r) (compile-markup-arg rest) + (set! args (cons a args)) + (set! rest r)))) + +(define (compile-markup-arg expr) + "Return two values: the desired markup argument, and the rest arguments" + (cond ((null? expr) + ;; no more args + (values '() '())) + ((keyword? (car expr)) + ;; expr === (#:COMMAND ...) + ;; ==> build and return the whole markup expression + (compile-markup-expression expr)) + ((and (pair? (car expr)) + (keyword? (caar expr))) + ;; expr === ((#:COMMAND ...) ...) + ;; ==> build and return the whole markup expression(s) + ;; found in (car expr) + (receive (markup-expr rest-expr) (compile-markup-expression (car expr)) + (if (null? rest-expr) + (values markup-expr (cdr expr)) + (values `(list ,markup-expr ,@(compile-all-markup-args rest-expr)) + (cdr expr))))) + ((and (pair? (car expr)) + (pair? (caar expr))) + ;; expr === (((foo ...) ...) ...) + (values (cons 'list (compile-all-markup-args (car expr))) (cdr expr))) + (else (values (car expr) (cdr expr))))) + +(define (lookup-markup-command-aux symbol) + (let ((proc (catch 'misc-error + (lambda () + (module-ref (current-module) symbol)) + (lambda (key . args) #f)))) + (and (procedure? proc) proc))) + +(define-public (lookup-markup-command code) + (let ((proc (lookup-markup-command-aux + (string->symbol (format #f "~a-markup" code))))) + (and proc (markup-function? proc) + (cons proc (markup-command-signature proc))))) + +(define-public (lookup-markup-list-command code) + (let ((proc (lookup-markup-command-aux + (string->symbol (format #f "~a-markup-list" code))))) + (and proc (markup-list-function? proc) + (cons proc (markup-command-signature proc))))) + +;;;;;;;;;;;;;;;;;;;;;; +;;; used in parser.yy to map a list of markup commands on markup arguments +(define-public (map-markup-command-list commands markups) + "`markups' being a list of markups, eg (markup1 markup2 markup3), +and `commands' a list of commands with their scheme arguments, in reverse order, +eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg: + ((bold (raise 4 (italic markup1))) + (bold (raise 4 (italic markup2))) + (bold (raise 4 (italic markup3)))) +" + (map-in-order (lambda (arg) + (let ((result arg)) + (for-each (lambda (cmd) + (set! result (append cmd (list result)))) + commands) + result)) + markups)) diff --git a/scm/markup.scm b/scm/markup.scm index 3cf774d4a8..47ebe5d2bc 100644 --- a/scm/markup.scm +++ b/scm/markup.scm @@ -15,227 +15,6 @@ ;;;; You should have received a copy of the GNU General Public License ;;;; along with LilyPond. If not, see . -" -Internally markup is stored as lists, whose head is a function. - - (FUNCTION ARG1 ARG2 ... ) - -When the markup is formatted, then FUNCTION is called as follows - - (FUNCTION GROB PROPS ARG1 ARG2 ... ) - -GROB is the current grob, PROPS is a list of alists, and ARG1.. are -the rest of the arguments. - -The function should return a stencil (i.e. a formatted, ready to -print object). - - -To add a markup command, use the define-markup-command utility. - - (define-markup-command (mycommand layout prop arg1 ...) (arg1-type? ...) - \"my command usage and description\" - ...function body...) - -The command is now available in markup mode, e.g. - - \\markup { .... \\MYCOMMAND #1 argument ... } - -" ; " - -;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; markup definer utilities - -;; For documentation purposes -;; category -> markup functions -(define-public markup-functions-by-category (make-hash-table 150)) -;; markup function -> used properties -(define-public markup-functions-properties (make-weak-key-hash-table 151)) -;; List of markup list functions -(define-public markup-list-functions (make-weak-key-hash-table 151)) - -(use-modules (ice-9 optargs)) - -(defmacro*-public define-markup-command - (command-and-args signature - #:key (category '()) (properties '()) - #:rest body) - " -* Define a COMMAND-markup function after command-and-args and body, -register COMMAND-markup and its signature, - -* add COMMAND-markup to markup-functions-by-category, - -* sets COMMAND-markup markup-signature object property, - -* define a make-COMMAND-markup function. - -Syntax: - (define-markup-command (COMMAND layout props . arguments) - argument-types - [ #:properties properties ] - \"documentation string\" - ...command body...) - -where: - `argument-types' is a list of type predicates for arguments - `properties' a list of (property default-value) lists - -The specified properties are available as let-bound variables in the -command body, using the respective `default-value' as fallback in case -`property' is not found in `props'. `props' itself is left unchanged: -if you want defaults specified in that manner passed down into other -markup functions, you need to adjust `props' yourself. - -The autogenerated documentation makes use of some optional -specifications that are otherwise ignored: - -After `argument-types', you may also specify - [ #:category category ] -where: - `category' is either a symbol or a symbol list specifying the - category for this markup command in the docs. - -As an element of the `properties' list, you may directly use a -COMMANDx-markup symbol instead of a `(prop value)' list to indicate -that this markup command is called by the newly defined command, -adding its properties to the documented properties of the new -command. There is no protection against circular definitions. -" - (let* ((command (car command-and-args)) - (args (cdr command-and-args)) - (command-name (string->symbol (format #f "~a-markup" command))) - (make-markup-name (string->symbol (format #f "make-~a-markup" command)))) - (while (and (pair? body) (keyword? (car body))) - (set! body (cddr body))) - `(begin - ;; define the COMMAND-markup function - ,(let* ((documentation (if (string? (car body)) - (list (car body)) - '())) - (real-body (if (or (null? documentation) - (null? (cdr body))) - body (cdr body)))) - `(define-public (,command-name ,@args) - ,@documentation - (let ,(map (lambda (prop-spec) - (let ((prop (car prop-spec)) - (default-value (if (null? (cdr prop-spec)) - #f - (cadr prop-spec))) - (props (cadr args))) - `(,prop (chain-assoc-get ',prop ,props ,default-value)))) - (filter pair? properties)) - ,@real-body))) - (set! (markup-command-signature ,command-name) (list ,@signature)) - ;; Register the new function, for markup documentation - ,@(map (lambda (category) - `(hashq-set! - (or (hashq-ref markup-functions-by-category ',category) - (let ((hash (make-weak-key-hash-table 151))) - (hashq-set! markup-functions-by-category ',category - hash) - hash)) - ,command-name #t)) - (if (list? category) category (list category))) - ;; Used properties, for markup documentation - (hashq-set! markup-functions-properties - ,command-name - (list ,@(map (lambda (prop-spec) - (cond ((symbol? prop-spec) - prop-spec) - ((not (null? (cdr prop-spec))) - `(list ',(car prop-spec) ,(cadr prop-spec))) - (else - `(list ',(car prop-spec))))) - (if (pair? args) - properties - (list))))) - ;; define the make-COMMAND-markup function - (define-public (,make-markup-name . args) - (let ((sig (list ,@signature))) - (make-markup ,command-name ,(symbol->string make-markup-name) sig args)))))) - -(defmacro*-public define-markup-list-command - (command-and-args signature #:key (properties '()) #:rest body) - "Same as `define-markup-command', but defines a command that, when -interpreted, returns a list of stencils instead of a single one" - (let* ((command (car command-and-args)) - (args (cdr command-and-args)) - (command-name (string->symbol (format #f "~a-markup-list" command))) - (make-markup-name (string->symbol (format #f "make-~a-markup-list" command)))) - (while (and (pair? body) (keyword? (car body))) - (set! body (cddr body))) - `(begin - ;; define the COMMAND-markup-list function - ,(let* ((documentation (if (string? (car body)) - (list (car body)) - '())) - (real-body (if (or (null? documentation) - (null? (cdr body))) - body (cdr body)))) - `(define-public (,command-name ,@args) - ,@documentation - (let ,(map (lambda (prop-spec) - (let ((prop (car prop-spec)) - (default-value (if (null? (cdr prop-spec)) - #f - (cadr prop-spec))) - (props (cadr args))) - `(,prop (chain-assoc-get ',prop ,props ,default-value)))) - (filter pair? properties)) - ,@real-body))) - (set! (markup-command-signature ,command-name) (list ,@signature)) - ;; add the command to markup-list-function-list, for markup documentation - (hashq-set! markup-list-functions ,command-name #t) - ;; Used properties, for markup documentation - (hashq-set! markup-functions-properties - ,command-name - (list ,@(map (lambda (prop-spec) - (cond ((symbol? prop-spec) - prop-spec) - ((not (null? (cdr prop-spec))) - `(list ',(car prop-spec) ,(cadr prop-spec))) - (else - `(list ',(car prop-spec))))) - (if (pair? args) - properties - (list))))) - ;; it's a markup-list command: - (set-object-property! ,command-name 'markup-list-command #t) - ;; define the make-COMMAND-markup-list function - (define-public (,make-markup-name . args) - (let ((sig (list ,@signature))) - (list (make-markup ,command-name - ,(symbol->string make-markup-name) sig args))))))) - -(define-public (make-markup markup-function make-name signature args) - "Construct a markup object from @var{markup-function} and @var{args}. -Typecheck against @var{signature}, reporting @var{make-name} as the -user-invoked function." - (let* ((arglen (length args)) - (siglen (length signature)) - (error-msg (if (and (> siglen 0) (> arglen 0)) - (markup-argument-list-error signature args 1) - #f))) - (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0)) - (ly:error (string-append make-name ": " - (_ "Wrong number of arguments. Expect: ~A, found ~A: ~S")) - siglen arglen args)) - (if error-msg - (ly:error - (string-append - make-name ": " - (_ "Invalid argument in position ~A. Expect: ~A, found: ~S.")) - (car error-msg) (cadr error-msg)(caddr error-msg)) - (cons markup-function args)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; markup constructors -;;; lilypond-like syntax for markup construction in scheme. - -(use-modules (ice-9 receive)) - (defmacro*-public markup (#:rest body) "The `markup' macro provides a lilypond-like syntax for building markups. @@ -258,252 +37,6 @@ Use `markup*' in a \\notemode context." (car (compile-all-markup-expressions `(#:line ,body)))) -(defmacro*-public markup* (#:rest body) - "Same as `markup', for use in a \\notes block." - `(ly:export (markup ,@body))) - - -(define (compile-all-markup-expressions expr) - "Return a list of canonical markups expressions, e.g.: - (#:COMMAND1 arg11 arg12 #:COMMAND2 arg21 arg22 arg23) - ===> - ((make-COMMAND1-markup arg11 arg12) - (make-COMMAND2-markup arg21 arg22 arg23) ...)" - (do ((rest expr rest) - (markps '() markps)) - ((null? rest) (reverse markps)) - (receive (m r) (compile-markup-expression rest) - (set! markps (cons m markps)) - (set! rest r)))) - -(define (keyword->make-markup key) - "Transform a keyword, e.g. #:COMMAND, in a make-COMMAND-markup symbol." - (string->symbol (string-append "make-" (symbol->string (keyword->symbol key)) "-markup"))) - -(define (compile-markup-expression expr) - "Return two values: the first complete canonical markup expression - found in `expr', e.g. (make-COMMAND-markup arg1 arg2 ...), - and the rest expression." - (cond ((and (pair? expr) - (keyword? (car expr))) - ;; expr === (#:COMMAND arg1 ...) - (let ((command (symbol->string (keyword->symbol (car expr))))) - (if (not (pair? (lookup-markup-command command))) - (ly:error (_ "Not a markup command: ~A") command)) - (let* ((sig (markup-command-signature - (car (lookup-markup-command command)))) - (sig-len (length sig))) - (do ((i 0 (1+ i)) - (args '() args) - (rest (cdr expr) rest)) - ((>= i sig-len) - (values (cons (keyword->make-markup (car expr)) (reverse args)) rest)) - (cond ((eqv? (list-ref sig i) markup-list?) - ;; (car rest) is a markup list - (set! args (cons `(list ,@(compile-all-markup-expressions (car rest))) args)) - (set! rest (cdr rest))) - (else - ;; pick up one arg in `rest' - (receive (a r) (compile-markup-arg rest) - (set! args (cons a args)) - (set! rest r)))))))) - ((and (pair? expr) - (pair? (car expr)) - (keyword? (caar expr))) - ;; expr === ((#:COMMAND arg1 ...) ...) - (receive (m r) (compile-markup-expression (car expr)) - (values m (cdr expr)))) - ((and (pair? expr) - (string? (car expr))) ;; expr === ("string" ...) - (values `(make-simple-markup ,(car expr)) (cdr expr))) - (else - ;; expr === (symbol ...) or ((funcall ...) ...) - (values (car expr) - (cdr expr))))) - -(define (compile-all-markup-args expr) - "Transform `expr' into markup arguments" - (do ((rest expr rest) - (args '() args)) - ((null? rest) (reverse args)) - (receive (a r) (compile-markup-arg rest) - (set! args (cons a args)) - (set! rest r)))) - -(define (compile-markup-arg expr) - "Return two values: the desired markup argument, and the rest arguments" - (cond ((null? expr) - ;; no more args - (values '() '())) - ((keyword? (car expr)) - ;; expr === (#:COMMAND ...) - ;; ==> build and return the whole markup expression - (compile-markup-expression expr)) - ((and (pair? (car expr)) - (keyword? (caar expr))) - ;; expr === ((#:COMMAND ...) ...) - ;; ==> build and return the whole markup expression(s) - ;; found in (car expr) - (receive (markup-expr rest-expr) (compile-markup-expression (car expr)) - (if (null? rest-expr) - (values markup-expr (cdr expr)) - (values `(list ,markup-expr ,@(compile-all-markup-args rest-expr)) - (cdr expr))))) - ((and (pair? (car expr)) - (pair? (caar expr))) - ;; expr === (((foo ...) ...) ...) - (values (cons 'list (compile-all-markup-args (car expr))) (cdr expr))) - (else (values (car expr) (cdr expr))))) - -;;;;;;;;;;;;;;; -;;; Utilities for storing and accessing markup commands signature -;;; Examples: -;;; -;;; (set! (markup-command-signature raise-markup) (list number? markup?)) -;;; ==> (# #) -;;; -;;; (markup-command-signature raise-markup) -;;; ==> (# #) -;;; - -(define-public (markup-command-signature-ref markup-command) - "Return @var{markup-command}'s signature (the @code{'markup-signature} -object property)." - (object-property markup-command 'markup-signature)) - -(define-public (markup-command-signature-set! markup-command signature) - "Set @var{markup-command}'s signature (as object property)." - (set-object-property! markup-command 'markup-signature signature) - signature) - -(define-public markup-command-signature - (make-procedure-with-setter markup-command-signature-ref - markup-command-signature-set!)) - -(define (lookup-markup-command-aux symbol) - (let ((proc (catch 'misc-error - (lambda () - (module-ref (current-module) symbol)) - (lambda (key . args) #f)))) - (and (procedure? proc) proc))) - -(define-public (lookup-markup-command code) - (let ((proc (lookup-markup-command-aux - (string->symbol (format #f "~a-markup" code))))) - (and proc (markup-function? proc) - (cons proc (markup-command-signature proc))))) - -(define-public (lookup-markup-list-command code) - (let ((proc (lookup-markup-command-aux - (string->symbol (format #f "~a-markup-list" code))))) - (and proc (markup-list-function? proc) - (cons proc (markup-command-signature proc))))) - -;;;;;;;;;;;;;;;;;;;;;; -;;; used in parser.yy to map a list of markup commands on markup arguments -(define-public (map-markup-command-list commands markups) - "@var{markups} being a list of markups, for example -@code{(markup1 markup2 markup3)}, and @var{commands} a list of commands with -their scheme arguments, in reverse order, for example -@code{((italic) (raise 4) (bold))}, map the commands on each markup argument, -for example -@example -((bold (raise 4 (italic markup1))) - (bold (raise 4 (italic markup2))) - (bold (raise 4 (italic markup3)))) -@end example" - (map-in-order (lambda (arg) - (let ((result arg)) - (for-each (lambda (cmd) - (set! result (append cmd (list result)))) - commands) - result)) - markups)) - -;;;;;;;;;;;;;;;;;;;;;; -;;; markup type predicates - -(define (markup-function? x) - (and (markup-command-signature x) - (not (object-property x 'markup-list-command)))) - -(define (markup-list-function? x) - (and (markup-command-signature x) - (object-property x 'markup-list-command))) - -(define-public (markup-command-list? x) - "Determine whether @var{x} is a markup command list, i.e. a list -composed of a markup list function and its arguments." - (and (pair? x) (markup-list-function? (car x)))) - -(define-public (markup-list? arg) - "Return @code{#t} if @var{x} is a list of markups or markup command lists." - (define (markup-list-inner? lst) - (or (null? lst) - (and (or (markup? (car lst)) (markup-command-list? (car lst))) - (markup-list-inner? (cdr lst))))) - (not (not (and (list? arg) (markup-list-inner? arg))))) - -(define (markup-argument-list? signature arguments) - "Typecheck argument list." - (if (and (pair? signature) (pair? arguments)) - (and ((car signature) (car arguments)) - (markup-argument-list? (cdr signature) (cdr arguments))) - (and (null? signature) (null? arguments)))) - - -(define (markup-argument-list-error signature arguments number) - "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or -#f is no error found. -" - (if (and (pair? signature) (pair? arguments)) - (if (not ((car signature) (car arguments))) - (list number (type-name (car signature)) (car arguments)) - (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number))) - #f)) - -;; -;; full recursive typecheck. -;; -(define (markup-typecheck? arg) - (or (string? arg) - (and (pair? arg) - (markup-function? (car arg)) - (markup-argument-list? (markup-command-signature (car arg)) - (cdr arg))))) - -;; -;; -;; -;; -(define (markup-thrower-typecheck arg) - "typecheck, and throw an error when something amiss. - -Uncovered - cheap-markup? is used." - - (cond ((string? arg) #t) - ((not (pair? arg)) - (throw 'markup-format "Not a pair" arg)) - ((not (markup-function? (car arg))) - (throw 'markup-format "Not a markup function " (car arg))) - ((not (markup-argument-list? (markup-command-signature (car arg)) - (cdr arg))) - (throw 'markup-format "Arguments failed typecheck for " arg))) - #t) - -;; -;; good enough if you only use make-XXX-markup functions. -;; -(define (cheap-markup? x) - (or (string? x) - (and (pair? x) - (markup-function? (car x))))) - -;; -;; replace by markup-thrower-typecheck for more detailed diagnostics. -;; -(define-public markup? cheap-markup?) - ;; utility (define (markup-join markups sep) @@ -518,12 +51,12 @@ Uncovered - cheap-markup? is used." (define-public (interpret-markup-list layout props markup-list) (let ((stencils (list))) (for-each (lambda (m) - (set! stencils - (if (markup-command-list? m) - (append! (reverse! (apply (car m) layout props (cdr m))) - stencils) - (cons (interpret-markup layout props m) stencils)))) - markup-list) + (set! stencils + (if (markup-command-list? m) + (append! (reverse! (apply (car m) layout props (cdr m))) + stencils) + (cons (interpret-markup layout props m) stencils)))) + markup-list) (reverse! stencils))) (define-public (prepend-alist-chain key val chain) @@ -532,15 +65,15 @@ Uncovered - cheap-markup? is used." (define-public (stack-stencil-line space stencils) "DOCME" (if (and (pair? stencils) - (ly:stencil? (car stencils))) + (ly:stencil? (car stencils))) (if (and (pair? (cdr stencils)) - (ly:stencil? (cadr stencils))) + (ly:stencil? (cadr stencils))) (let* ((tail (stack-stencil-line space (cdr stencils))) (head (car stencils)) (xoff (+ space (interval-length (ly:stencil-extent head X))))) (ly:stencil-add head - (ly:stencil-translate-axis tail xoff X))) + (ly:stencil-translate-axis tail xoff X))) (car stencils)) (ly:make-stencil '() '(0 . 0) '(0 . 0)))) @@ -550,57 +83,57 @@ Uncovered - cheap-markup? is used." (define-public (markup->string m) ;; markup commands with one markup argument, formatting ignored (define markups-first-argument '(list - bold-markup box-markup caps-markup dynamic-markup finger-markup - fontCaps-markup huge-markup italic-markup large-markup larger-markup - medium-markup normal-size-sub-markup normal-size-super-markup - normal-text-markup normalsize-markup number-markup roman-markup - sans-markup simple-markup small-markup smallCaps-markup smaller-markup - sub-markup super-markup teeny-markup text-markup tiny-markup - typewriter-markup underline-markup upright-markup bracket-markup - circle-markup hbracket-markup parenthesize-markup rounded-box-markup - - center-align-markup center-column-markup column-markup dir-column-markup - fill-line-markup justify-markup justify-string-markup left-align-markup - left-column-markup line-markup right-align-markup right-column-markup - vcenter-markup wordwrap-markup wordwrap-string-markup )) + bold-markup box-markup caps-markup dynamic-markup finger-markup + fontCaps-markup huge-markup italic-markup large-markup larger-markup + medium-markup normal-size-sub-markup normal-size-super-markup + normal-text-markup normalsize-markup number-markup roman-markup + sans-markup simple-markup small-markup smallCaps-markup smaller-markup + sub-markup super-markup teeny-markup text-markup tiny-markup + typewriter-markup underline-markup upright-markup bracket-markup + circle-markup hbracket-markup parenthesize-markup rounded-box-markup + + center-align-markup center-column-markup column-markup dir-column-markup + fill-line-markup justify-markup justify-string-markup left-align-markup + left-column-markup line-markup right-align-markup right-column-markup + vcenter-markup wordwrap-markup wordwrap-string-markup )) ;; markup commands with markup as second argument, first argument ;; specifies some formatting and is ignored (define markups-second-argument '(list - abs-fontsize-markup fontsize-markup magnify-markup lower-markup - pad-around-markup pad-markup-markup pad-x-markup raise-markup - halign-markup hcenter-in-markup rotate-markup translate-markup - translate-scaled-markup with-url-markup scale-markup )) + abs-fontsize-markup fontsize-markup magnify-markup lower-markup + pad-around-markup pad-markup-markup pad-x-markup raise-markup + halign-markup hcenter-in-markup rotate-markup translate-markup + translate-scaled-markup with-url-markup scale-markup )) ;; helper functions to handle string cons like string lists (define (markup-cons->string-cons c) (if (not (pair? c)) (markup->string c) - (cons (markup->string (car c)) (markup-cons->string-cons (cdr c))))) + (cons (markup->string (car c)) (markup-cons->string-cons (cdr c))))) (define (string-cons-join c) (if (not (pair? c)) c (string-join (list (car c) (string-cons-join (cdr c))) ""))) (cond - ((string? m) m) - ((null? m) "") + ((string? m) m) + ((null? m) "") - ;; handle \concat (string-join without spaces) - ((and (pair? m) (equal? (car m) concat-markup)) - (string-cons-join (markup-cons->string-cons (cadr m))) ) + ;; handle \concat (string-join without spaces) + ((and (pair? m) (equal? (car m) concat-markup)) + (string-cons-join (markup-cons->string-cons (cadr m))) ) - ;; markup functions with the markup as first arg - ((member (car m) (primitive-eval markups-first-argument)) - (markup->string (cadr m))) + ;; markup functions with the markup as first arg + ((member (car m) (primitive-eval markups-first-argument)) + (markup->string (cadr m))) - ;; markup functions with markup as second arg - ((member (car m) (primitive-eval markups-second-argument)) - (markup->string (cddr m))) + ;; markup functions with markup as second arg + ((member (car m) (primitive-eval markups-second-argument)) + (markup->string (cddr m))) - ;; ignore all other markup functions - ((markup-function? (car m)) "") + ;; ignore all other markup functions + ((markup-function? (car m)) "") - ;; handle markup lists - ((list? m) - (string-join (map markup->string m) " ")) + ;; handle markup lists + ((list? m) + (string-join (map markup->string m) " ")) - (else "ERROR, unable to extract string from markup"))) + (else "ERROR, unable to extract string from markup"))) -- 2.39.2