[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: markup commands leaks (Re: Scheme question on strict substitution)
|
From: |
Nicolas Sceaux |
|
Subject: |
Re: markup commands leaks (Re: Scheme question on strict substitution) |
|
Date: |
Mon, 01 Jan 2007 23:34:11 +0100 |
|
User-agent: |
Gnus/5.11 (Gnus v5.11) Emacs/22.0.50 (darwin) |
Han-Wen Nienhuys <address@hidden> writes:
>> + (let ((command-proc (toplevel-module-ref ',command-name)))
>> + ;; register its command signature
>> + (set! (markup-command-signature command-proc)
>> + (list ,@signature))
>
> hi, this statement still leaks memory. I think the signature hashtab should
> be thrown away or put into the local module as well.
Here is another patch: the markup command hash table is removed.
Using -ddebug seems to reveal no leak. make web works fine.
diff --git a/input/regression/markup-scheme.ly
b/input/regression/markup-scheme.ly
index af1b4f9..e4589d4 100644
--- a/input/regression/markup-scheme.ly
+++ b/input/regression/markup-scheme.ly
@@ -51,7 +51,7 @@ For maintenance reasons, we don't excerc
\dynamic sfzp
\huge { "A" \smaller "A" \smaller \smaller "A"
\smaller \smaller \smaller "A" }
- \sub "alike"
+ \larger \sub "alike"
}
\break
f'1-#(markup*
@@ -74,5 +74,5 @@ For maintenance reasons, we don't excerc
#:dynamic "sfzp"
#:huge #:line ("A" #:smaller "A" #:smaller #:smaller "A"
#:smaller #:smaller #:smaller "A")
- #:sub "alike")
+ #:larger #:sub "alike")
}
diff --git a/ly/declarations-init.ly b/ly/declarations-init.ly
index 210b81d..1732952 100644
--- a/ly/declarations-init.ly
+++ b/ly/declarations-init.ly
@@ -8,6 +8,7 @@ breve = #(ly:make-duration -1 0)
longa = #(ly:make-duration -2 0)
maxima = #(ly:make-duration -3 0)
+\include "markup-init.ly"
\include "music-functions-init.ly"
%% default note names are dutch
diff --git a/ly/markup-init.ly b/ly/markup-init.ly
new file mode 100644
index 0000000..f2461e4
--- /dev/null
+++ b/ly/markup-init.ly
@@ -0,0 +1,85 @@
+%% -*- Mode: Scheme -*-
+
+%%;; to be define later, in a closure
+#(define-public toplevel-module-define-public! #f)
+#(define-public toplevel-module-ref #f)
+#(let ((toplevel-module (current-module)))
+ (set! toplevel-module-define-public!
+ (lambda (symbol value)
+ (module-define! toplevel-module symbol value)
+ (module-export! toplevel-module (list symbol))))
+ (set! toplevel-module-ref
+ (lambda (symbol)
+ (module-ref toplevel-module symbol))))
+
+#(defmacro-public define-public-toplevel
+ (first-arg . rest)
+ "Define a public variable or function in the toplevel module:
+ (define-public-toplevel variable-name value)
+or:
+ (define-public-toplevel (function-name . args)
+ ..body..)"
+ (if (symbol? first-arg)
+ ;; (define-public-toplevel symbol value)
+ (let ((symbol first-arg)
+ (value (car rest)))
+ `(toplevel-module-define-public! ',symbol ,value))
+ ;; (define-public-toplevel (function-name . args) . body)
+ (let ((function-name (car first-arg))
+ (arg-list (cdr first-arg))
+ (body rest))
+ `(toplevel-module-define-public!
+ ',function-name
+ (let ((proc (lambda ,arg-list
+ ,@body)))
+ (set-procedure-property! proc
+ 'name
+ ',function-name)
+ proc)))))
+
+#(defmacro-public define-markup-command (command-and-args signature . body)
+ "
+* Define a COMMAND-markup function after command-and-args and body,
+register COMMAND-markup and its signature,
+
+* add COMMAND-markup to markup-function-list,
+
+* sets COMMAND-markup markup-signature and markup-keyword object properties,
+
+* define a make-COMMAND-markup function.
+
+Syntax:
+ (define-markup-command (COMMAND layout props arg1 arg2 ...)
+ (arg1-type? arg2-type? ...)
+ \"documentation string\"
+ ...command body...)
+or:
+ (define-markup-command COMMAND (arg1-type? arg2-type? ...) function)
+"
+ (let* ((command (if (pair? command-and-args)
+ (car command-and-args)
+ command-and-args))
+ (command-name (string->symbol (format #f "~a-markup" command)))
+ (make-markup-name (string->symbol (format #f "make-~a-markup"
command))))
+ `(begin
+ ;; define the COMMAND-markup procedure in toplevel module
+ ,(if (pair? command-and-args)
+ ;; 1/ (define (COMMAND-markup layout props arg1 arg2 ...)
+ ;; ..command body))
+ `(define-public-toplevel (,command-name ,@(cdr command-and-args))
+ ,@body)
+ ;; 2/ (define (COMMAND-markup . args) (apply function args))
+ (let ((args (gensym "args"))
+ (command (car body)))
+ `(define-public-toplevel (,command-name . ,args)
+ (apply ,command ,args))))
+ (let ((command-proc (toplevel-module-ref ',command-name)))
+ ;; register its command signature
+ (set! (markup-command-signature command-proc)
+ (list ,@signature))
+ ;; define the make-COMMAND-markup procedure in the toplevel module
+ (define-public-toplevel (,make-markup-name . args)
+ (make-markup command-proc
+ ,(symbol->string make-markup-name)
+ (list ,@signature)
+ args))))))
diff --git a/scm/define-markup-commands.scm b/scm/define-markup-commands.scm
index 10d48d5..436d2c2 100644
--- a/scm/define-markup-commands.scm
+++ b/scm/define-markup-commands.scm
@@ -24,13 +24,13 @@
;; geometric shapes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define-markup-command (draw-circle layout props radius thickness fill)
+(define-builtin-markup-command (draw-circle layout props radius thickness fill)
(number? number? boolean?)
"A circle of radius @var{radius}, thickness @var{thickness} and
optionally filled."
(make-circle-stencil radius thickness fill))
-(define-markup-command (triangle layout props filled) (boolean?)
+(define-builtin-markup-command (triangle layout props filled) (boolean?)
"A triangle, filled or not"
(let*
((th (chain-assoc-get 'thickness props 0.1))
@@ -51,7 +51,7 @@ optionally filled."
(cons 0 (* .86 ex))
)))
-(define-markup-command (circle layout props arg) (markup?)
+(define-builtin-markup-command (circle layout props arg) (markup?)
"Draw a circle around @var{arg}. Use @code{thickness},
@code{circle-padding} and @code{font-size} properties to determine line
thickness and padding around the markup."
@@ -64,7 +64,7 @@ thickness and padding around the markup.
(m (interpret-markup layout props arg)))
(circle-stencil m th pad)))
-(define-markup-command (with-url layout props url arg) (string? markup?)
+(define-builtin-markup-command (with-url layout props url arg) (string?
markup?)
"Add a link to URL @var{url} around @var{arg}. This only works in
the PDF backend."
(let* ((stil (interpret-markup layout props arg))
@@ -75,7 +75,7 @@ the PDF backend."
(ly:stencil-add (ly:make-stencil url-expr xextent yextent) stil)))
-(define-markup-command (beam layout props width slope thickness)
+(define-builtin-markup-command (beam layout props width slope thickness)
(number? number? number?)
"Create a beam with the specified parameters."
(let* ((y (* slope width))
@@ -94,7 +94,7 @@ the PDF backend."
(cons (+ (- half) (car yext))
(+ half (cdr yext))))))
-(define-markup-command (box layout props arg) (markup?)
+(define-builtin-markup-command (box layout props arg) (markup?)
"Draw a box round @var{arg}. Looks at @code{thickness},
@code{box-padding} and @code{font-size} properties to determine line
thickness and padding around the markup."
@@ -106,7 +106,7 @@ thickness and padding around the markup.
(m (interpret-markup layout props arg)))
(box-stencil m th pad)))
-(define-markup-command (filled-box layout props xext yext blot)
+(define-builtin-markup-command (filled-box layout props xext yext blot)
(number-pair? number-pair? number?)
"Draw a box with rounded corners of dimensions @var{xext} and
@var{yext}. For example,
@@ -119,17 +119,17 @@ circle of diameter 0 (ie sharp corners).
(ly:round-filled-box
xext yext blot))
-(define-markup-command (rotate layout props ang arg) (number? markup?)
+(define-builtin-markup-command (rotate layout props ang arg) (number? markup?)
"Rotate object with @var{ang} degrees around its center."
(let* ((stil (interpret-markup layout props arg)))
(ly:stencil-rotate stil ang 0 0)))
-(define-markup-command (whiteout layout props arg) (markup?)
+(define-builtin-markup-command (whiteout layout props arg) (markup?)
"Provide a white underground for @var{arg}"
(stencil-whiteout (interpret-markup layout props arg)))
-(define-markup-command (pad-markup layout props padding arg) (number? markup?)
+(define-builtin-markup-command (pad-markup layout props padding arg) (number?
markup?)
"Add space around a markup object."
(let*
@@ -147,7 +147,7 @@ circle of diameter 0 (ie sharp corners).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;FIXME: is this working?
-(define-markup-command (strut layout props) ()
+(define-builtin-markup-command (strut layout props) ()
"Create a box of the same height as the space in the current font."
(let ((m (ly:text-interface::interpret-markup layout props " ")))
(ly:make-stencil (ly:stencil-expr m)
@@ -157,7 +157,7 @@ circle of diameter 0 (ie sharp corners).
;; todo: fix negative space
-(define-markup-command (hspace layout props amount) (number?)
+(define-builtin-markup-command (hspace layout props amount) (number?)
"This produces a invisible object taking horizontal space.
@example
\\markup @{ A \\hspace #2.0 B @}
@@ -174,7 +174,7 @@ normally inserted before elements on a l
;; importing graphics.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define-markup-command (stencil layout props stil) (ly:stencil?)
+(define-builtin-markup-command (stencil layout props stil) (ly:stencil?)
"Stencil as markup"
stil)
@@ -193,7 +193,7 @@ normally inserted before elements on a l
#f)))
-(define-markup-command (epsfile layout props axis size file-name) (number?
number? string?)
+(define-builtin-markup-command (epsfile layout props axis size file-name)
(number? number? string?)
"Inline an EPS image. The image is scaled along @var{axis} to
@var{size}."
@@ -202,7 +202,7 @@ normally inserted before elements on a l
(eps-file->stencil axis size file-name)
))
-(define-markup-command (postscript layout props str) (string?)
+(define-builtin-markup-command (postscript layout props str) (string?)
"This inserts @var{str} directly into the output as a PostScript
command string. Due to technicalities of the output backends,
different scales should be used for the @TeX{} and PostScript backend,
@@ -244,7 +244,7 @@ grestore
'(0 . 0) '(0 . 0)))
-(define-markup-command (score layout props score) (ly:score?)
+(define-builtin-markup-command (score layout props score) (ly:score?)
"Inline an image of music."
(let* ((output (ly:score-embedded-format score layout)))
@@ -255,7 +255,7 @@ grestore
(ly:warning (_"no systems found in \\score markup, does it have a
\\layout block?"))
empty-stencil))))
-(define-markup-command (null layout props) ()
+(define-builtin-markup-command (null layout props) ()
"An empty markup with extents of a single point"
point-stencil)
@@ -266,12 +266,12 @@ grestore
-(define-markup-command (simple layout props str) (string?)
+(define-builtin-markup-command (simple layout props str) (string?)
"A simple text string; @code{\\markup @{ foo @}} is equivalent with
@code{\\markup @{ \\simple #\"foo\" @}}."
(interpret-markup layout props str))
-(define-markup-command (tied-lyric layout props str) (string?)
+(define-builtin-markup-command (tied-lyric layout props str) (string?)
"Like simple-markup, but use tie characters for ~ tilde symbols."
@@ -329,7 +329,7 @@ grestore
(/ (+ (car text-widths) (car (cdr text-widths))) 2))
(get-fill-space word-count line-width (cdr text-widths))))))
-(define-markup-command (fill-line layout props markups)
+(define-builtin-markup-command (fill-line layout props markups)
(markup-list?)
"Put @var{markups} in a horizontal line of width @var{line-width}.
The markups are spaced/flushed to fill the entire line.
@@ -389,7 +389,7 @@ grestore
(stack-stencils-padding-list X
RIGHT fill-space-normal line-stencils))))
-(define-markup-command (line layout props args) (markup-list?)
+(define-builtin-markup-command (line layout props args) (markup-list?)
"Put @var{args} in a horizontal line. The property @code{word-space}
determines the space between each markup in @var{args}."
(let*
@@ -406,7 +406,7 @@ determines the space between each markup
space
(remove ly:stencil-empty? stencils))))
-(define-markup-command (concat layout props args) (markup-list?)
+(define-builtin-markup-command (concat layout props args) (markup-list?)
"Concatenate @var{args} in a horizontal line, without spaces inbetween.
Strings and simple markups are concatenated on the input level, allowing
ligatures. For example, @code{\\concat @{ \"f\" \\simple #\"i\" @}} is
@@ -524,14 +524,14 @@ equivalent to @code{\"fi\"}."
(stack-lines DOWN 0.0 baseline-skip lines)))
-(define-markup-command (justify layout props args) (markup-list?)
+(define-builtin-markup-command (justify layout props args) (markup-list?)
"Like wordwrap, but with lines stretched to justify the margins.
Use @code{\\override #'(line-width . X)} to set line-width, where X
is the number of staff spaces."
(wordwrap-markups layout props args #t))
-(define-markup-command (wordwrap layout props args) (markup-list?)
+(define-builtin-markup-command (wordwrap layout props args) (markup-list?)
"Simple wordwrap. Use @code{\\override #'(line-width . X)} to set
line-width, where X is the number of staff spaces."
@@ -572,23 +572,23 @@ line-width, where X is the number of sta
(stack-lines DOWN 0.0 baseline-skip (apply append para-lines))))
-(define-markup-command (wordwrap-string layout props arg) (string?)
+(define-builtin-markup-command (wordwrap-string layout props arg) (string?)
"Wordwrap a string. Paragraphs may be separated with double newlines"
(wordwrap-string layout props #f arg))
-(define-markup-command (justify-string layout props arg) (string?)
+(define-builtin-markup-command (justify-string layout props arg) (string?)
"Justify a string. Paragraphs may be separated with double newlines"
(wordwrap-string layout props #t arg))
-(define-markup-command (wordwrap-field layout props symbol) (symbol?)
+(define-builtin-markup-command (wordwrap-field layout props symbol) (symbol?)
(let* ((m (chain-assoc-get symbol props)))
(if (string? m)
(interpret-markup layout props
(list wordwrap-string-markup m))
(ly:make-stencil '() '(1 . -1) '(1 . -1)))))
-(define-markup-command (justify-field layout props symbol) (symbol?)
+(define-builtin-markup-command (justify-field layout props symbol) (symbol?)
(let* ((m (chain-assoc-get symbol props)))
(if (string? m)
(interpret-markup layout props
@@ -597,7 +597,7 @@ line-width, where X is the number of sta
-(define-markup-command (combine layout props m1 m2) (markup? markup?)
+(define-builtin-markup-command (combine layout props m1 m2) (markup? markup?)
"Print two markups on top of each other."
(let* ((s1 (interpret-markup layout props m1))
(s2 (interpret-markup layout props m2)))
@@ -606,7 +606,7 @@ line-width, where X is the number of sta
;;
;; TODO: should extract baseline-skip from each argument somehow..
;;
-(define-markup-command (column layout props args) (markup-list?)
+(define-builtin-markup-command (column layout props args) (markup-list?)
"Stack the markups in @var{args} vertically. The property
@code{baseline-skip} determines the space between each markup in @var{args}."
@@ -620,7 +620,7 @@ line-width, where X is the number of sta
(remove ly:stencil-empty? arg-stencils))))
-(define-markup-command (dir-column layout props args) (markup-list?)
+(define-builtin-markup-command (dir-column layout props args) (markup-list?)
"Make a column of args, going up or down, depending on the setting
of the @code{#'direction} layout property."
(let* ((dir (chain-assoc-get 'direction props)))
@@ -630,39 +630,39 @@ of the @code{#'direction} layout propert
(chain-assoc-get 'baseline-skip props)
(map (lambda (x) (interpret-markup layout props x)) args))))
-(define-markup-command (center-align layout props args) (markup-list?)
+(define-builtin-markup-command (center-align layout props args) (markup-list?)
"Put @code{args} in a centered column. "
(let* ((mols (map (lambda (x) (interpret-markup layout props x)) args))
(cmols (map (lambda (x) (ly:stencil-aligned-to x X CENTER)) mols)))
(stack-lines -1 0.0 (chain-assoc-get 'baseline-skip props) cmols)))
-(define-markup-command (vcenter layout props arg) (markup?)
+(define-builtin-markup-command (vcenter layout props arg) (markup?)
"Align @code{arg} to its Y center. "
(let* ((mol (interpret-markup layout props arg)))
(ly:stencil-aligned-to mol Y CENTER)))
-(define-markup-command (hcenter layout props arg) (markup?)
+(define-builtin-markup-command (hcenter layout props arg) (markup?)
"Align @code{arg} to its X center. "
(let* ((mol (interpret-markup layout props arg)))
(ly:stencil-aligned-to mol X CENTER)))
-(define-markup-command (right-align layout props arg) (markup?)
+(define-builtin-markup-command (right-align layout props arg) (markup?)
"Align @var{arg} on its right edge. "
(let* ((m (interpret-markup layout props arg)))
(ly:stencil-aligned-to m X RIGHT)))
-(define-markup-command (left-align layout props arg) (markup?)
+(define-builtin-markup-command (left-align layout props arg) (markup?)
"Align @var{arg} on its left edge. "
(let* ((m (interpret-markup layout props arg)))
(ly:stencil-aligned-to m X LEFT)))
-(define-markup-command (general-align layout props axis dir arg) (integer?
number? markup?)
+(define-builtin-markup-command (general-align layout props axis dir arg)
(integer? number? markup?)
"Align @var{arg} in @var{axis} direction to the @var{dir} side."
(let* ((m (interpret-markup layout props arg)))
(ly:stencil-aligned-to m axis dir)))
-(define-markup-command (halign layout props dir arg) (number? markup?)
+(define-builtin-markup-command (halign layout props dir arg) (number? markup?)
"Set horizontal alignment. If @var{dir} is @code{-1}, then it is
left-aligned, while @code{+1} is right. Values in between interpolate
alignment accordingly."
@@ -671,14 +671,14 @@ alignment accordingly."
-(define-markup-command (with-dimensions layout props x y arg) (number-pair?
number-pair? markup?)
+(define-builtin-markup-command (with-dimensions layout props x y arg)
(number-pair? number-pair? markup?)
"Set the dimensions of @var{arg} to @var{x} and @var{y}."
(let* ((m (interpret-markup layout props arg)))
(ly:make-stencil (ly:stencil-expr m) x y)))
-(define-markup-command (pad-around layout props amount arg) (number? markup?)
+(define-builtin-markup-command (pad-around layout props amount arg) (number?
markup?)
"Add padding @var{amount} all around @var{arg}. "
@@ -694,7 +694,7 @@ alignment accordingly."
))
-(define-markup-command (pad-x layout props amount arg) (number? markup?)
+(define-builtin-markup-command (pad-x layout props amount arg) (number?
markup?)
"Add padding @var{amount} around @var{arg} in the X-direction. "
(let*
@@ -709,7 +709,7 @@ alignment accordingly."
))
-(define-markup-command (put-adjacent layout props arg1 axis dir arg2) (markup?
integer? ly:dir? markup?)
+(define-builtin-markup-command (put-adjacent layout props arg1 axis dir arg2)
(markup? integer? ly:dir? markup?)
"Put @var{arg2} next to @var{arg1}, without moving @var{arg1}. "
@@ -719,7 +719,7 @@ alignment accordingly."
(ly:stencil-combine-at-edge m1 axis dir m2 0.0 0.0)
))
-(define-markup-command (transparent layout props arg) (markup?)
+(define-builtin-markup-command (transparent layout props arg) (markup?)
"Make the argument transparent"
(let*
((m (interpret-markup layout props arg))
@@ -732,7 +732,7 @@ alignment accordingly."
x y)))
-(define-markup-command (pad-to-box layout props x-ext y-ext arg)
+(define-builtin-markup-command (pad-to-box layout props x-ext y-ext arg)
(number-pair? number-pair? markup?)
"Make @var{arg} take at least @var{x-ext}, @var{y-ext} space"
@@ -746,7 +746,7 @@ alignment accordingly."
(interval-union y-ext y))))
-(define-markup-command (hcenter-in layout props length arg)
+(define-builtin-markup-command (hcenter-in layout props length arg)
(number? markup?)
"Center @var{arg} horizontally within a box of extending
@var{length}/2 to the left and right."
@@ -762,7 +762,7 @@ alignment accordingly."
;; property
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define-markup-command (fromproperty layout props symbol) (symbol?)
+(define-builtin-markup-command (fromproperty layout props symbol) (symbol?)
"Read the @var{symbol} from property settings, and produce a stencil
from the markup contained within. If @var{symbol} is not defined, it
returns an empty markup"
@@ -772,7 +772,7 @@ alignment accordingly."
(ly:make-stencil '() '(1 . -1) '(1 . -1)))))
-(define-markup-command (on-the-fly layout props procedure arg) (symbol?
markup?)
+(define-builtin-markup-command (on-the-fly layout props procedure arg)
(symbol? markup?)
"Apply the @var{procedure} markup command to
@var{arg}. @var{procedure} should take a single argument."
(let* ((anonymous-with-signature (lambda (layout props arg) (procedure
layout props arg))))
@@ -783,7 +783,7 @@ alignment accordingly."
-(define-markup-command (override layout props new-prop arg) (pair? markup?)
+(define-builtin-markup-command (override layout props new-prop arg) (pair?
markup?)
"Add the first argument in to the property list. Properties may be
any sort of property supported by @internalsref{font-interface} and
@internalsref{text-interface}, for example
@@ -799,7 +799,7 @@ any sort of property supported by @inter
;; files
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define-markup-command (verbatim-file layout props name) (string?)
+(define-builtin-markup-command (verbatim-file layout props name) (string?)
"Read the contents of a file, and include verbatimly"
(interpret-markup
@@ -819,26 +819,26 @@ any sort of property supported by @inter
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define-markup-command (bigger layout props arg) (markup?)
+(define-builtin-markup-command (bigger layout props arg) (markup?)
"Increase the font size relative to current setting"
(interpret-markup layout props
`(,fontsize-markup 1 ,arg)))
-(define-markup-command (smaller layout props arg) (markup?)
+(define-builtin-markup-command (smaller layout props arg) (markup?)
"Decrease the font size relative to current setting"
(interpret-markup layout props
`(,fontsize-markup -1 ,arg)))
-(define-markup-command larger (markup?) bigger-markup)
+(define-builtin-markup-command larger (markup?) bigger-markup)
-(define-markup-command (finger layout props arg) (markup?)
+(define-builtin-markup-command (finger layout props arg) (markup?)
"Set the argument as small numbers."
(interpret-markup layout
(cons '((font-size . -5) (font-encoding . fetaNumber))
props)
arg))
-(define-markup-command (fontsize layout props increment arg) (number? markup?)
+(define-builtin-markup-command (fontsize layout props increment arg) (number?
markup?)
"Add @var{increment} to the font-size. Adjust baseline skip accordingly."
(let* ((fs (chain-assoc-get 'font-size props 0))
@@ -852,7 +852,7 @@ any sort of property supported by @inter
;; FIXME -> should convert to font-size.
-(define-markup-command (magnify layout props sz arg) (number? markup?)
+(define-builtin-markup-command (magnify layout props sz arg) (number? markup?)
"Set the font magnification for the its argument. In the following
example, the middle A will be 10% larger:
@example
@@ -866,54 +866,54 @@ Use @code{\\fontsize} otherwise."
(prepend-alist-chain 'font-magnification sz props)
arg))
-(define-markup-command (bold layout props arg) (markup?)
+(define-builtin-markup-command (bold layout props arg) (markup?)
"Switch to bold font-series"
(interpret-markup layout (prepend-alist-chain 'font-series 'bold props) arg))
-(define-markup-command (sans layout props arg) (markup?)
+(define-builtin-markup-command (sans layout props arg) (markup?)
"Switch to the sans serif family"
(interpret-markup layout (prepend-alist-chain 'font-family 'sans props) arg))
-(define-markup-command (number layout props arg) (markup?)
+(define-builtin-markup-command (number layout props arg) (markup?)
"Set font family to @code{number}, which yields the font used for
time signatures and fingerings. This font only contains numbers and
some punctuation. It doesn't have any letters. "
(interpret-markup layout (prepend-alist-chain 'font-encoding 'fetaNumber
props) arg))
-(define-markup-command (roman layout props arg) (markup?)
+(define-builtin-markup-command (roman layout props arg) (markup?)
"Set font family to @code{roman}."
(interpret-markup layout (prepend-alist-chain 'font-family 'roman props)
arg))
-(define-markup-command (huge layout props arg) (markup?)
+(define-builtin-markup-command (huge layout props arg) (markup?)
"Set font size to +2."
(interpret-markup layout (prepend-alist-chain 'font-size 2 props) arg))
-(define-markup-command (large layout props arg) (markup?)
+(define-builtin-markup-command (large layout props arg) (markup?)
"Set font size to +1."
(interpret-markup layout (prepend-alist-chain 'font-size 1 props) arg))
-(define-markup-command (normalsize layout props arg) (markup?)
+(define-builtin-markup-command (normalsize layout props arg) (markup?)
"Set font size to default."
(interpret-markup layout (prepend-alist-chain 'font-size 0 props) arg))
-(define-markup-command (small layout props arg) (markup?)
+(define-builtin-markup-command (small layout props arg) (markup?)
"Set font size to -1."
(interpret-markup layout (prepend-alist-chain 'font-size -1 props) arg))
-(define-markup-command (tiny layout props arg) (markup?)
+(define-builtin-markup-command (tiny layout props arg) (markup?)
"Set font size to -2."
(interpret-markup layout (prepend-alist-chain 'font-size -2 props) arg))
-(define-markup-command (teeny layout props arg) (markup?)
+(define-builtin-markup-command (teeny layout props arg) (markup?)
"Set font size to -3."
(interpret-markup layout (prepend-alist-chain 'font-size -3 props) arg))
-(define-markup-command (fontCaps layout props arg) (markup?)
+(define-builtin-markup-command (fontCaps layout props arg) (markup?)
"Set @code{font-shape} to @code{caps}."
(interpret-markup layout (prepend-alist-chain 'font-shape 'caps props) arg))
;; Poor man's caps
-(define-markup-command (smallCaps layout props text) (markup?)
+(define-builtin-markup-command (smallCaps layout props text) (markup?)
"Turn @code{text}, which should be a string, to small caps.
@example
\\markup \\smallCaps \"Text between double quotes\"
@@ -978,10 +978,10 @@ some punctuation. It doesn't have any le
#f
#f)))
-(define-markup-command (caps layout props arg) (markup?)
+(define-builtin-markup-command (caps layout props arg) (markup?)
(interpret-markup layout props (make-smallCaps-markup arg)))
-(define-markup-command (dynamic layout props arg) (markup?)
+(define-builtin-markup-command (dynamic layout props arg) (markup?)
"Use the dynamic font. This font only contains @b{s}, @b{f}, @b{m},
@b{z}, @b{p}, and @b{r}. When producing phrases, like address@hidden @b{f}'',
the
normal words (like address@hidden'') should be done in a different font. The
@@ -989,7 +989,7 @@ recommend font for this is bold and ital
(interpret-markup
layout (prepend-alist-chain 'font-encoding 'fetaDynamic props) arg))
-(define-markup-command (text layout props arg) (markup?)
+(define-builtin-markup-command (text layout props arg) (markup?)
"Use a text font instead of music symbol or music alphabet font."
;; ugh - latin1
@@ -997,26 +997,26 @@ recommend font for this is bold and ital
arg))
-(define-markup-command (italic layout props arg) (markup?)
+(define-builtin-markup-command (italic layout props arg) (markup?)
"Use italic @code{font-shape} for @var{arg}. "
(interpret-markup layout (prepend-alist-chain 'font-shape 'italic props)
arg))
-(define-markup-command (typewriter layout props arg) (markup?)
+(define-builtin-markup-command (typewriter layout props arg) (markup?)
"Use @code{font-family} typewriter for @var{arg}."
(interpret-markup
layout (prepend-alist-chain 'font-family 'typewriter props) arg))
-(define-markup-command (upright layout props arg) (markup?)
+(define-builtin-markup-command (upright layout props arg) (markup?)
"Set font shape to @code{upright}. This is the opposite of @code{italic}."
(interpret-markup
layout (prepend-alist-chain 'font-shape 'upright props) arg))
-(define-markup-command (medium layout props arg) (markup?)
+(define-builtin-markup-command (medium layout props arg) (markup?)
"Switch to medium font-series (in contrast to bold)."
(interpret-markup layout (prepend-alist-chain 'font-series 'medium props)
arg))
-(define-markup-command (normal-text layout props arg) (markup?)
+(define-builtin-markup-command (normal-text layout props arg) (markup?)
"Set all font related properties (except the size) to get the default normal
text font, no matter what font was used earlier."
;; ugh - latin1
(interpret-markup layout
@@ -1029,45 +1029,45 @@ recommend font for this is bold and ital
;; symbols.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define-markup-command (doublesharp layout props) ()
+(define-builtin-markup-command (doublesharp layout props) ()
"Draw a double sharp symbol."
(interpret-markup layout props (markup #:musicglyph (assoc-get 1
standard-alteration-glyph-name-alist ""))))
-(define-markup-command (sesquisharp layout props) ()
+(define-builtin-markup-command (sesquisharp layout props) ()
"Draw a 3/2 sharp symbol."
(interpret-markup layout props (markup #:musicglyph (assoc-get 3/4
standard-alteration-glyph-name-alist ""))))
-(define-markup-command (sharp layout props) ()
+(define-builtin-markup-command (sharp layout props) ()
"Draw a sharp symbol."
(interpret-markup layout props (markup #:musicglyph (assoc-get 1/2
standard-alteration-glyph-name-alist ""))))
-(define-markup-command (semisharp layout props) ()
+(define-builtin-markup-command (semisharp layout props) ()
"Draw a semi sharp symbol."
(interpret-markup layout props (markup #:musicglyph (assoc-get 1/4
standard-alteration-glyph-name-alist ""))))
-(define-markup-command (natural layout props) ()
+(define-builtin-markup-command (natural layout props) ()
"Draw a natural symbol."
(interpret-markup layout props (markup #:musicglyph (assoc-get 0
standard-alteration-glyph-name-alist ""))))
-(define-markup-command (semiflat layout props) ()
+(define-builtin-markup-command (semiflat layout props) ()
"Draw a semiflat."
(interpret-markup layout props (markup #:musicglyph (assoc-get -1/4
standard-alteration-glyph-name-alist ""))))
-(define-markup-command (flat layout props) ()
+(define-builtin-markup-command (flat layout props) ()
"Draw a flat symbol."
(interpret-markup layout props (markup #:musicglyph (assoc-get -1/2
standard-alteration-glyph-name-alist ""))))
-(define-markup-command (sesquiflat layout props) ()
+(define-builtin-markup-command (sesquiflat layout props) ()
"Draw a 3/2 flat symbol."
(interpret-markup layout props (markup #:musicglyph (assoc-get -3/4
standard-alteration-glyph-name-alist ""))))
-(define-markup-command (doubleflat layout props) ()
+(define-builtin-markup-command (doubleflat layout props) ()
"Draw a double flat symbol."
(interpret-markup layout props (markup #:musicglyph (assoc-get -1
standard-alteration-glyph-name-alist ""))))
-(define-markup-command (with-color layout props color arg) (color? markup?)
+(define-builtin-markup-command (with-color layout props color arg) (color?
markup?)
"Draw @var{arg} in color specified by @var{color}"
(let* ((stil (interpret-markup layout props arg)))
@@ -1082,7 +1082,7 @@ recommend font for this is bold and ital
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define-markup-command (arrow-head layout props axis direction filled)
+(define-builtin-markup-command (arrow-head layout props axis direction filled)
(integer? ly:dir? boolean?)
"produce an arrow head in specified direction and axis. Use the filled head
if @var{filled} is specified."
(let*
@@ -1097,7 +1097,7 @@ recommend font for this is bold and ital
props))
name)))
-(define-markup-command (musicglyph layout props glyph-name) (string?)
+(define-builtin-markup-command (musicglyph layout props glyph-name) (string?)
"This is converted to a musical symbol, e.g. @code{\\musicglyph
#\"accidentals.natural\"} will select the natural sign from the music font.
See @usermanref{The Feta font} for a complete listing of the possible glyphs."
@@ -1106,12 +1106,12 @@ See @usermanref{The Feta font} for a co
props))
glyph-name))
-(define-markup-command (lookup layout props glyph-name) (string?)
+(define-builtin-markup-command (lookup layout props glyph-name) (string?)
"Lookup a glyph by name."
(ly:font-get-glyph (ly:paper-get-font layout props)
glyph-name))
-(define-markup-command (char layout props num) (integer?)
+(define-builtin-markup-command (char layout props num) (integer?)
"Produce a single character, e.g. @code{\\char #65} produces the
letter 'A'."
@@ -1139,13 +1139,13 @@ letter 'A'."
(number->markletter-string vec (remainder n lst)))
(make-string 1 (vector-ref vec n)))))
-(define-markup-command (markletter layout props num) (integer?)
+(define-builtin-markup-command (markletter layout props num) (integer?)
"Make a markup letter for @var{num}. The letters start with A to Z
(skipping I), and continues with double letters."
(ly:text-interface::interpret-markup layout props
(number->markletter-string number->mark-letter-vector num)))
-(define-markup-command (markalphabet layout props num) (integer?)
+(define-builtin-markup-command (markalphabet layout props num) (integer?)
"Make a markup letter for @var{num}. The letters start with A to Z
and continues with double letters."
(ly:text-interface::interpret-markup layout props
@@ -1153,7 +1153,7 @@ letter 'A'."
-(define-markup-command (slashed-digit layout props num) (integer?)
+(define-builtin-markup-command (slashed-digit layout props num) (integer?)
"A feta number, with slash. This is for use in the context of
figured bass notation"
(let*
@@ -1212,7 +1212,7 @@ figured bass notation"
;; TODO: better syntax.
-(define-markup-command (note-by-number layout props log dot-count dir)
(number? number? number?)
+(define-builtin-markup-command (note-by-number layout props log dot-count dir)
(number? number? number?)
"Construct a note symbol, with stem. By using fractional values for
@var{dir}, you can obtain longer or shorter stems."
@@ -1309,7 +1309,7 @@ figured bass notation"
(if dots (string-length dots) 0)))
(ly:error (_ "not a valid duration string: ~a") duration-string))))
-(define-markup-command (note layout props duration dir) (string? number?)
+(define-builtin-markup-command (note layout props duration dir) (string?
number?)
"This produces a note with a stem pointing in @var{dir} direction, with
the @var{duration} for the note head type and augmentation dots. For
example, @code{\\note #\"4.\" #-0.75} creates a dotted quarter note, with
@@ -1322,7 +1322,7 @@ a shortened down stem."
;; translating.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define-markup-command (lower layout props amount arg) (number? markup?)
+(define-builtin-markup-command (lower layout props amount arg) (number?
markup?)
"
Lower @var{arg}, by the distance @var{amount}.
A negative @var{amount} indicates raising, see also @code{\\raise}.
@@ -1331,7 +1331,7 @@ A negative @var{amount} indicates raisin
(- amount) Y))
-(define-markup-command (translate-scaled layout props offset arg)
(number-pair? markup?)
+(define-builtin-markup-command (translate-scaled layout props offset arg)
(number-pair? markup?)
"Translate @var{arg} by @var{offset}, scaling the offset by the
@code{font-size}."
(let*
@@ -1342,7 +1342,7 @@ A negative @var{amount} indicates raisin
(ly:stencil-translate (interpret-markup layout props arg)
scaled)))
-(define-markup-command (raise layout props amount arg) (number? markup?)
+(define-builtin-markup-command (raise layout props amount arg) (number?
markup?)
"
Raise @var{arg}, by the distance @var{amount}.
A negative @var{amount} indicates lowering, see also @code{\\lower}.
@@ -1361,7 +1361,7 @@ positions it next to the staff cancels a
and/or @code{extra-offset} properties. "
(ly:stencil-translate-axis (interpret-markup layout props arg) amount Y))
-(define-markup-command (fraction layout props arg1 arg2) (markup? markup?)
+(define-builtin-markup-command (fraction layout props arg1 arg2) (markup?
markup?)
"Make a fraction of two markups."
(let* ((m1 (interpret-markup layout props arg1))
(m2 (interpret-markup layout props arg2))
@@ -1389,13 +1389,13 @@ and/or @code{extra-offset} properties. "
-(define-markup-command (normal-size-super layout props arg) (markup?)
+(define-builtin-markup-command (normal-size-super layout props arg) (markup?)
"Set @var{arg} in superscript with a normal font size."
(ly:stencil-translate-axis
(interpret-markup layout props arg)
(* 0.5 (chain-assoc-get 'baseline-skip props)) Y))
-(define-markup-command (super layout props arg) (markup?)
+(define-builtin-markup-command (super layout props arg) (markup?)
"
@cindex raising text
@cindex lowering text
@@ -1421,7 +1421,7 @@ Raising and lowering texts can be done w
(* 0.5 (chain-assoc-get 'baseline-skip props))
Y))
-(define-markup-command (translate layout props offset arg) (number-pair?
markup?)
+(define-builtin-markup-command (translate layout props offset arg)
(number-pair? markup?)
"This translates an object. Its first argument is a cons of numbers
@example
A \\translate #(cons 2 -3) @{ B C @} D
@@ -1435,7 +1435,7 @@ that.
(ly:stencil-translate (interpret-markup layout props arg)
offset))
-(define-markup-command (sub layout props arg) (markup?)
+(define-builtin-markup-command (sub layout props arg) (markup?)
"Set @var{arg} in subscript."
(ly:stencil-translate-axis
(interpret-markup
@@ -1445,7 +1445,7 @@ that.
(* -0.5 (chain-assoc-get 'baseline-skip props))
Y))
-(define-markup-command (normal-size-sub layout props arg) (markup?)
+(define-builtin-markup-command (normal-size-sub layout props arg) (markup?)
"Set @var{arg} in subscript, in a normal font size."
(ly:stencil-translate-axis
(interpret-markup layout props arg)
@@ -1456,19 +1456,19 @@ that.
;; brackets.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define-markup-command (hbracket layout props arg) (markup?)
+(define-builtin-markup-command (hbracket layout props arg) (markup?)
"Draw horizontal brackets around @var{arg}."
(let ((th 0.1) ;; todo: take from GROB.
(m (interpret-markup layout props arg)))
(bracketify-stencil m X th (* 2.5 th) th)))
-(define-markup-command (bracket layout props arg) (markup?)
+(define-builtin-markup-command (bracket layout props arg) (markup?)
"Draw vertical brackets around @var{arg}."
(let ((th 0.1) ;; todo: take from GROB.
(m (interpret-markup layout props arg)))
(bracketify-stencil m Y th (* 2.5 th) th)))
-(define-markup-command (bracketed-y-column layout props indices args)
+(define-builtin-markup-command (bracketed-y-column layout props indices args)
(list? markup-list?)
"Make a column of the markups in @var{args}, putting brackets around
the elements marked in @var{indices}, which is a list of numbers.
diff --git a/scm/document-markup.scm b/scm/document-markup.scm
index 9a5e51e..27d1229 100644
--- a/scm/document-markup.scm
+++ b/scm/document-markup.scm
@@ -10,10 +10,10 @@
(f-name (symbol->string (procedure-name func)))
(c-name (regexp-substitute/global #f "-markup$" f-name 'pre "" 'post))
(sig (object-property func 'markup-signature))
- (arg-names
- (map symbol->string
- (cddr (cadr (procedure-source func)))))
-
+ (arg-names (let ((arg-list (cadr (procedure-source func))))
+ (if (list? arg-list)
+ (map symbol->string (cddr arg-list))
+ (make-list (length sig) "arg"))))
(sig-type-names (map type-name sig))
(signature-str
(string-join
diff --git a/scm/fret-diagrams.scm b/scm/fret-diagrams.scm
index 2792ef7..a682a82 100644
--- a/scm/fret-diagrams.scm
+++ b/scm/fret-diagrams.scm
@@ -295,7 +295,7 @@ Line thickness is given by @var{th}, fre
(sans-serif-stencil layout props (* size label-font-mag)
label-text)
(* size (+ fret-count label-vertical-offset)) Y)))
-(define-markup-command (fret-diagram-verbose layout props marking-list)
+(define-builtin-markup-command (fret-diagram-verbose layout props marking-list)
(list?)
"Make a fret diagram containing the symbols indicated in @var{marking-list}
@@ -391,7 +391,7 @@ indications per string.
(ly:stencil-aligned-to fret-diagram-stencil X alignment)
))
-(define-markup-command (fret-diagram layout props definition-string)
+(define-builtin-markup-command (fret-diagram layout props definition-string)
(string?)
"
Example
@@ -522,7 +522,7 @@ Note: There is no limit to the number o
(cons* numeric-value (numerify (cdr mylist)))
(cons* (car (string->list (car mylist))) (numerify (cdr
mylist)))))))
-(define-markup-command (fret-diagram-terse layout props definition-string)
+(define-builtin-markup-command (fret-diagram-terse layout props
definition-string)
(string?)
"Make a fret diagram markup using terse string-based syntax.
diff --git a/scm/markup.scm b/scm/markup.scm
index bd20798..c786c16 100644
--- a/scm/markup.scm
+++ b/scm/markup.scm
@@ -20,7 +20,9 @@ The function should return a stencil (i.
print object).
-To add a function, use the define-markup-command utility.
+To add a builtin markup command, use the define-builtin-markup-command
+utility. In a user file, the define-markup-command macro shall be used
+(see ly/markup-init.ly).
(define-markup-command (mycommand layout prop arg1 ...) (arg1-type? ...)
\"my command usage and description\"
@@ -28,7 +30,6 @@ To add a function, use the define-markup
The command is now available in markup mode, e.g.
-
\\markup { .... \\MYCOMMAND #1 argument ... }
" ; "
@@ -36,34 +37,8 @@ The command is now available in markup m
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; markup definer utilities
-(defmacro-public in-module-define-variable (module-name symbol value)
- "Define a variable in a module and export its name.
- (in-module-define-variable (some module) symbol value)"
- (let ((gmodule (gensym "module")))
- `(let ((,gmodule (resolve-module ',module-name)))
- (module-define! ,gmodule ',symbol ,value)
- (module-export! ,gmodule '(,symbol)))))
-
-(defmacro-public in-module-define-function
- (module-name function-name+arg-list . body)
- "Define a public function in a module:
- (in-module-define-function (some module) (function-name . args)
- ..body..)"
- `(in-module-define-variable
- ,module-name
- ,(car function-name+arg-list)
- (let ((proc (lambda ,(cdr function-name+arg-list)
- ,@body)))
- (set-procedure-property! proc
- 'name
- ',(car function-name+arg-list))
- proc)))
-
-;;; `define-markup-command' can be used both for built-in markup
-;;; definitions and user defined markups.
-(defmacro-public define-markup-command (command-and-args signature . body)
+(define-macro (define-builtin-markup-command command-and-args signature . body)
"
-
* Define a COMMAND-markup function after command-and-args and body,
register COMMAND-markup and its signature,
@@ -74,40 +49,36 @@ register COMMAND-markup and its signatur
* define a make-COMMAND-markup function.
Syntax:
- (define-markup-command (COMMAND layout props arg1 arg2 ...) (arg1-type?
arg2-type? ...)
+ (define-builtin-markup-command (COMMAND layout props arg1 arg2 ...)
+ (arg1-type? arg2-type? ...)
\"documentation string\"
...command body...)
-or:
- (define-markup-command COMMAND (arg1-type? arg2-type? ...) function)
+ or:
+ (define-builtin-markup-command COMMAND (arg1-type? arg2-type? ...)
+ function)
"
- (let* ((command (if (pair? command-and-args)
- (car command-and-args)
- command-and-args))
+ (let* ((command (if (pair? command-and-args) (car command-and-args)
command-and-args))
+ (args (if (pair? command-and-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))))
- `(let ((lily-module (resolve-module '(lily))))
- ;; define the COMMAND-markup procedure in (lily) module
- ,(if (pair? command-and-args)
- ;; two cases:
- ;; 1/ (define (COMMAND-markup layout props arg1 arg2 ...)
- ;; ..command body))
- `(in-module-define-function (lily) (,command-name ,@(cdr
command-and-args))
+ `(begin
+ ;; define the COMMAND-markup function
+ ,(if (pair? args)
+ `(define-public (,command-name ,@args)
,@body)
- ;; 2/ (define COMMAND-markup function)
- `(in-module-define-variable (lily) ,command-name ,(car body)))
- (let ((command-proc (module-ref lily-module ',command-name)))
- ;; register its command signature
- (set! (markup-command-signature command-proc)
- (list ,@signature))
- ;; add the COMMAND-markup procedure to the list of markup functions
- (if (not (member command-proc markup-function-list))
- (set! markup-function-list (cons command-proc
markup-function-list)))
- ;; define the make-COMMAND-markup procedure in (lily) module
- (in-module-define-function (lily) (,make-markup-name . args)
- (make-markup command-proc
- ,(symbol->string make-markup-name)
- (list ,@signature)
- args))))))
+ (let ((args (gensym "args"))
+ (markup-command (car body)))
+ `(define-public (,command-name . ,args)
+ ,(format #f "Copy of the ~a command" markup-command)
+ (apply ,markup-command ,args))))
+ (set! (markup-command-signature ,command-name) (list ,@signature))
+ ;; add the command to markup-function-list, for markup documentation
+ (if (not (member ,command-name markup-function-list))
+ (set! markup-function-list (cons ,command-name
markup-function-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))))))
(define-public (make-markup markup-function make-name signature args)
" Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck
@@ -141,22 +112,21 @@ against SIGNATURE, reporting MAKE-NAME a
"The `markup' macro provides a lilypond-like syntax for building markups.
- #:COMMAND is used instead of \\COMMAND
- - #:lines ( ... ) is used instead of { ... }
- - #:center-align ( ... ) is used instead of \\center-align < ... >
+ - #:line ( ... ) is used instead of \\line { ... }
- etc.
Example:
\\markup { foo
\\raise #0.2 \\hbracket \\bold bar
\\override #'(baseline-skip . 4)
- \\bracket \\column < baz bazr bla >
+ \\bracket \\column { baz bazr bla }
}
<==>
(markup \"foo\"
#:raise 0.2 #:hbracket #:bold \"bar\"
#:override '(baseline-skip . 4)
#:bracket #:column (\"baz\" \"bazr\" \"bla\"))
-Use `markup*' in a \\notes block."
+Use `markup*' in a \\notemode context."
(car (compile-all-markup-expressions `(#:line ,body))))
@@ -269,44 +239,28 @@ Use `markup*' in a \\notes block."
;;; (markup-command-keyword raise-markup) ==> "scheme0-markup1"
;;;
-(define markup-command-signatures (make-hash-table 50))
+(define-public (markup-command-keyword markup-command)
+ "Return markup-command's argument keyword, ie a string describing the command
+ arguments, eg. \"scheme0markup1\""
+ (object-property markup-command 'markup-keyword))
-(define (markup-command-signature-ref markup-command)
- "Return markup-command's signature, e.g. (number? markup?).
-markup-command may be a procedure."
- (let ((sig-key (hashq-ref markup-command-signatures
- markup-command)))
- (if sig-key (car sig-key) #f)))
+(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-keyword markup-command)
- "Return markup-command's keyword, e.g. \"scheme0markup1\".
-markup-command may be a procedure."
- (let ((sig-key (hashq-ref markup-command-signatures
- markup-command)))
- (if sig-key (cdr sig-key) #f)))
-
-(define (markup-command-signatureset! markup-command signature)
- "Set markup-command's signature. markup-command must be a named procedure.
-Also set markup-signature and markup-keyword object properties."
- (hashq-set! markup-command-signatures
- markup-command
- (cons signature (markup-signature-to-keyword signature)))
- ;; these object properties are still in use somewhere
+(define-public (markup-command-signature-set! markup-command signature)
+ "Set markup-command's signature and keyword (as object properties)"
(set-object-property! markup-command 'markup-signature signature)
- (set-object-property! markup-command 'markup-keyword
(markup-signature-to-keyword signature)))
-
-(define-public markup-command-signature
- (make-procedure-with-setter markup-command-signature-ref
markup-command-signatureset!))
+ (set-object-property! markup-command 'markup-keyword
+ (markup-signature-to-keyword signature))
+ signature)
-(define (markup-symbol-to-proc markup-sym)
- "Return the markup command procedure which name is `markup-sym', if any."
- (hash-fold (lambda (key val prev)
- (or prev
- (if (eqv? (procedure-name key) markup-sym) key #f)))
- #f
- markup-command-signatures))
+(define-public markup-command-signature
+ (make-procedure-with-setter markup-command-signature-ref
+ markup-command-signature-set!))
-(define-public markup-function-list '())
+;; For documentation purposes
+(define-public markup-function-list (list))
(define-public (markup-signature-to-keyword sig)
" (A B C) -> a0-b1-c2 "
@@ -329,8 +283,13 @@ Also set markup-signature and markup-key
"-"))))
(define-public (lookup-markup-command code)
- (let ((proc (markup-symbol-to-proc (string->symbol (string-append code
"-markup")))))
- (and proc (cons proc (markup-command-keyword proc)))))
+ (let ((proc (catch 'misc-error
+ (lambda ()
+ (module-ref (current-module)
+ (string->symbol (format #f "~a-markup" code))))
+ (lambda (key . args) #f))))
+ (and (procedure? proc)
+ (cons proc (markup-command-keyword proc)))))
;;;;;;;;;;;;;;;;;;;;;;
;;; used in parser.yy to map a list of markup commands on markup arguments
- Re: markup commands leaks (Re: Scheme question on strict substitution),
Nicolas Sceaux <=