define-markup-command: instead of defining COMMAND-markup and

make-COMMAND-markup functions in current module, define them in the
(lily) module. Hopefully fixes #162.

diff --git a/input/regression/markup-scheme.ly b/input/regression/markup-scheme.ly
index 608ba694ae4310c617d7188025db10295db47f34..e82b4b0ba372671647894d40f32bd592dbe10fd4 100644 (file)
--- a/input/regression/markup-scheme.ly
+++ b/input/regression/markup-scheme.ly
@@ -43,8 +43,11 @@ For maintenance reasons, we don't excercise the entire markup command set.
     \combine "X" "+"   
     \combine "o" "/"
     \box \column { \line { "string 1" } \line { "string 2" } }
+    " "
     \italic Norsk
     \super "2"
+    \circle \dynamic "p"
+    " "
     \dynamic sfzp
     \huge { "A" \smaller "A" \smaller \smaller "A"
            \smaller \smaller \smaller "A" }

diff --git a/scm/lily.scm b/scm/lily.scm
index 495ef18cbc57ce7055501bef6a7c53de9fb72c2d..32ab98e88e2a486b72c88d054380da72f3e9063b 100644 (file)
--- a/scm/lily.scm
+++ b/scm/lily.scm
@@ -415,7 +415,10 @@ The syntax is the same as `define*-public'."
          (format "~a ~a ~a\n"
                  gc-protect-stat-count
                  sym
-                 (cdr (assoc sym stats)))
+                 (let ((sym-stat (assoc sym stats)))
+                   (if sym-stat 
+                       (cdr sym-stat)
+                       "?")))
          outfile))
        '(protected-objects bytes-malloced cell-heap-size
                           

diff --git a/scm/markup.scm b/scm/markup.scm
index 268efaf879e971ef69c0a0292cbf40c83d244235..bd20798e91df98f8128447350e1dabbf8b20a0e5 100644 (file)
--- a/scm/markup.scm
+++ b/scm/markup.scm
@@ -35,9 +35,32 @@ The command is now available in markup mode, e.g.
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; 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)
   "
 
@@ -54,25 +77,37 @@ 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)
+or:
+  (define-markup-command COMMAND (arg1-type? arg2-type? ...) function)
 "
-  (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 (string-append (symbol->string command) "-markup")))
-         (make-markup-name (string->symbol (string-append "make-" (symbol->string command-name)))))
-    `(begin
-       (define-public ,(if (pair? args)
-                           (cons command-name args)
-                           command-name)
-         ,@body)
-       (set! (markup-command-signature ,command-name) (list ,@signature))
-       (if (not (member ,command-name markup-function-list))
-           (set! markup-function-list (cons ,command-name markup-function-list)))
-       (define-public (,make-markup-name . args)
-         (let ((sig (list ,@signature)))
-           (make-markup ,command-name ,(symbol->string make-markup-name) sig args))))))
+  (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))))
+    `(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))
+               ,@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))))))
 
 (define-public (make-markup markup-function make-name signature args)
   " Construct a markup object from MARKUP-FUNCTION and ARGS. Typecheck
@@ -266,8 +301,8 @@ Also set markup-signature and markup-keyword object properties."
 (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)))
+               (or prev
+                   (if (eqv? (procedure-name key) markup-sym) key #f)))
              #f
              markup-command-signatures))
 
@@ -410,9 +445,3 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
           (car stencils))
       (ly:make-stencil '() '(0 . 0) '(0 . 0))))
 
-
-
-
-
-
-