]> git.donarmstrong.com Git - lilypond.git/blob - ly/markup-init.ly
Merge branch 'lilypond/translation' of /home/jcharles/GIT/Lily/ into lilypond/translation
[lilypond.git] / ly / markup-init.ly
1 %% -*- Mode: Scheme -*-
2
3 \version "2.11.9"
4
5 %%;; to be define later, in a closure
6 #(define-public toplevel-module-define-public! #f)
7 #(define-public toplevel-module-ref #f)
8 #(let ((toplevel-module (current-module)))
9    (set! toplevel-module-define-public!
10          (lambda (symbol value)
11            (module-define! toplevel-module symbol value)
12            (module-export! toplevel-module (list symbol))))
13    (set! toplevel-module-ref
14          (lambda (symbol)
15            (module-ref toplevel-module symbol))))
16
17 #(defmacro-public define-public-toplevel
18    (first-arg . rest)
19   "Define a public variable or function in the toplevel module:
20   (define-public-toplevel variable-name value)
21 or:
22   (define-public-toplevel (function-name . args)
23     ..body..)"
24   (if (symbol? first-arg)
25       ;; (define-public-toplevel symbol value)
26       (let ((symbol first-arg)
27             (value (car rest)))
28         `(toplevel-module-define-public! ',symbol ,value))
29       ;; (define-public-toplevel (function-name . args) . body)
30       (let ((function-name (car first-arg))
31             (arg-list (cdr first-arg))
32             (body rest))
33         `(toplevel-module-define-public!
34           ',function-name
35           (let ((proc (lambda ,arg-list
36                         ,@body)))
37             (set-procedure-property! proc
38                                      'name
39                                      ',function-name)
40             proc)))))
41
42 #(defmacro-public define-markup-command (command-and-args signature . body)
43   "
44 * Define a COMMAND-markup function after command-and-args and body,
45 register COMMAND-markup and its signature,
46
47 * add COMMAND-markup to markup-function-list,
48
49 * sets COMMAND-markup markup-signature and markup-keyword object properties,
50
51 * define a make-COMMAND-markup function.
52
53 Syntax:
54   (define-markup-command (COMMAND layout props arg1 arg2 ...)
55                          (arg1-type? arg2-type? ...)
56     \"documentation string\"
57     ...command body...)
58 or:
59   (define-markup-command COMMAND (arg1-type? arg2-type? ...) function)
60 "
61   (let* ((command (if (pair? command-and-args)
62                       (car command-and-args)
63                       command-and-args))
64          (command-name (string->symbol (format #f "~a-markup" command)))
65          (make-markup-name (string->symbol (format #f "make-~a-markup" command))))
66     `(begin
67        ;; define the COMMAND-markup procedure in toplevel module
68        ,(if (pair? command-and-args)
69             ;; 1/ (define (COMMAND-markup layout props arg1 arg2 ...)
70             ;;      ..command body))
71             `(define-public-toplevel (,command-name ,@(cdr command-and-args))
72                ,@body)
73             ;; 2/ (define (COMMAND-markup . args) (apply function args))
74             (let ((args (gensym "args"))
75                   (command (car body)))
76             `(define-public-toplevel (,command-name . ,args)
77                (apply ,command ,args))))
78        (let ((command-proc (toplevel-module-ref ',command-name)))
79          ;; register its command signature
80          (set! (markup-command-signature command-proc)
81                (list ,@signature))
82          ;; define the make-COMMAND-markup procedure in the toplevel module
83          (define-public-toplevel (,make-markup-name . args)
84            (make-markup command-proc
85                         ,(symbol->string make-markup-name)
86                         (list ,@signature)
87                         args))))))
88
89 #(defmacro-public define-markup-list-command (command-and-args signature . body)
90   "Same as `define-markup-command', but defines a command that, when interpreted,
91 returns a list of stencils, instead of a single one."
92   (let* ((command (if (pair? command-and-args)
93                       (car command-and-args)
94                       command-and-args))
95          (command-name (string->symbol (format #f "~a-markup-list" command)))
96          (make-markup-name (string->symbol (format #f "make-~a-markup-list" command))))
97     `(begin
98        ;; define the COMMAND-markup-list procedure in toplevel module
99        ,(if (pair? command-and-args)
100             ;; 1/ (define (COMMAND-markup-list layout props arg1 arg2 ...)
101             ;;      ..command body))
102             `(define-public-toplevel (,command-name ,@(cdr command-and-args))
103                ,@body)
104             ;; 2/ (define (COMMAND-markup-list . args) (apply function args))
105             (let ((args (gensym "args"))
106                   (command (car body)))
107             `(define-public-toplevel (,command-name . ,args)
108                (apply ,command ,args))))
109        (let ((command-proc (toplevel-module-ref ',command-name)))
110          ;; register its command signature
111          (set! (markup-command-signature command-proc)
112                (list ,@signature))
113          ;; it's a markup-list command:
114          (set-object-property! command-proc 'markup-list-command #t)
115          ;; define the make-COMMAND-markup-list procedure in the toplevel module
116          (define-public-toplevel (,make-markup-name . args)
117            (list (make-markup command-proc
118                               ,(symbol->string make-markup-name)
119                               (list ,@signature)
120                               args)))))))