Define Scheme markups using define-public

scm/markup-macros.scm

 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
 ;;;; Copyright (C) 2003--2020 Han-Wen Nienhuys <hanwen@xs4all.nl>
 ;;;;
 ;;;; 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,
@@ skipping 86 matching lines @@
 command.  There is no protection against circular definitions.
 "
   (let* ((command (if (pair? command-and-args)
                       (car command-and-args)
                       command-and-args))
          (args (and (pair? command-and-args) (cdr command-and-args))))
     (if args
         `(,define-markup-command-internal
            ',command (markup-lambda ,args ,@definition) #f)
         `(,define-markup-command-internal
-           ',command ,@definition #f))))
+            -           ',command ,@definition #f))))
+
+(defmacro-public define-markup-command-compilable (command-and-args . definition)
+  "Like define-markup-command, but for use in LilyPond .scm files. We
+generate define-public statements, so the .scm files can be compiled"
+  (let*
+      ((command (car command-and-args))
+       (args (cdr command-and-args))
+       (command-name (string->symbol (format #f "~a-markup" command)))
+       (make-markup-name-str (format #f "make-~a" command-name))
+       (make-markup-name (string->symbol make-markup-name-str)))
+
+    `(begin
+       (define-public ,command-name
+         (markup-lambda ,args ,@definition))
+       (define-public ,make-markup-name
+         (lambda markup-args (make-markup ,command-name ,make-markup-name-str markup-args)))
+
+       (if (not (procedure-name ,command-name))
+           (set-procedure-property! ,command-name 'name (quote ,command-name)))
+       )))
 
 (defmacro*-public markup-lambda
   (args signature
         #:key (category '()) (properties '())
         #:rest body)
   "Defines and returns an anonymous markup command.  Other than
 not registering the markup command, this is identical to
 `define-markup-command`"
   (while (and (pair? body) (keyword? (car body)))
          (set! body (cddr body)))
@@ skipping 42 matching lines @@
   (let* ((command (if (pair? command-and-args)
                       (car command-and-args)
                       command-and-args))
          (args (and (pair? command-and-args) (cdr command-and-args))))
     (if args
         `(,define-markup-command-internal
            ',command (markup-list-lambda ,args ,@definition) #t)
         `(,define-markup-command-internal
            ',command ,@definition #t))))
 
+(defmacro-public define-markup-list-command-compilable
+  (command-and-args . definition)
+  "Like `define-markup-list-command`, but using define-public, so it
+can be compiled."
+  (let* ((command (car command-and-args))
+         (args (cdr command-and-args))
+         (command-name-str (format #f "~a-markup-list" command))
+         (command-name (string->symbol command-name-str))
+         (make-markup-name-str  (format #f "make-~a-markup-list" command))
+         (make-markup-name (string->symbol make-markup-name-str)))
+
+  `(begin
+     (define-public ,command-name
+       (markup-list-lambda ,args ,@definition))
+     (define-public ,make-markup-name
+       (lambda markup-args
+         (list (make-markup ,command-name ,make-markup-name-str markup-args))
+       )))
+  ))
+
 (define (define-markup-command-internal command definition is-list)
-  (let* ((suffix (if is-list "-list" ""))
+  """Define a markup command at runtime. Called from the parser."""
+  (let* (
+         (suffix (if is-list "-list" ""))
          (command-name (string->symbol (format #f "~a-markup~a" command suffix)))
          (make-markup-name (string->symbol (format #f "make-~a-markup~a" command suffix))))
+
     (if (not (procedure-name definition))
         (set-procedure-property! definition 'name command-name))
     (module-define! (current-module) command-name definition)
     (module-define! (current-module) make-markup-name
                     (lambda args
                       (if is-list
                           (list (make-markup definition make-markup-name args))
                           (make-markup definition make-markup-name args))))
     (module-export! (current-module)
-                    (list command-name make-markup-name))))
+                                        (list command-name make-markup-name))))
 
 (defmacro*-public markup-list-lambda
   (arg signature #:key (properties '()) #:rest body)
   "Same as `markup-lambda' but defines a markup list command that, when
 interpreted, returns a list of stencils instead of a single one"
   (let ()                               ; Guile 1.8 defmacro* workaround
     (define (markup-lambda-listify fun)
       (set! (markup-list-function? fun) #t)
       fun)
     (list markup-lambda-listify (cons* 'markup-lambda arg signature body))))
@@ skipping 225 matching lines @@
   (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)))))