+ (let ((documentation (car body))
+ (real-body (cdr body))
+ (properties properties-or-copied-function))
+ `(define-public (,command-name ,@args)
+ ,documentation
+ (let ,(filter identity
+ (map (lambda (prop-spec)
+ (if (pair? 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)))
+ #f))
+ properties))
+ ,@real-body)))
+ (let ((args (gensym "args"))
+ (markup-command properties-or-copied-function))
+ `(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))
+ ;; Register the new function, for markup documentation
+ ,@(map (lambda (category)
+ `(hashq-set! markup-functions-by-category ',category
+ (cons ,command-name
+ (or (hashq-ref markup-functions-by-category ',category)
+ (list)))))
+ (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-or-copied-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-macro (define-builtin-markup-list-command command-and-args signature
+ properties . body)
+ "Same as `define-builtin-markup-command, but defines a command that, when
+interpreted, returns a list of stencils instead os a single one"
+ (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-list" command)))
+ (make-markup-name (string->symbol (format #f "make-~a-markup-list" command))))
+ `(begin
+ ;; define the COMMAND-markup-list function
+ ,(if (pair? args)
+ (let ((documentation (car body))
+ (real-body (cdr body)))
+ `(define-public (,command-name ,@args)
+ ,documentation
+ (let ,(filter identity
+ (map (lambda (prop-spec)
+ (if (pair? 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)))
+ #f))
+ properties))
+ ,@body)))