X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmarkup.scm;h=c47cb4a6c3685206678ef8ad9fd54111a8c28b9e;hb=20f3b60ef944d225d64d2abdd21b0936a6046545;hp=f1e32402366a50b5cfa05aebcf71efb469f6c099;hpb=ba3045ce76cd37a4e11fd775fa04ce4b7586ad77;p=lilypond.git

diff --git a/scm/markup.scm b/scm/markup.scm
index f1e3240236..c47cb4a6c3 100644
--- a/scm/markup.scm
+++ b/scm/markup.scm
@@ -2,7 +2,7 @@
 ;;;;
 ;;;;  source file of the GNU LilyPond music typesetter
 ;;;; 
-;;;; (c) 2003--2006 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; (c) 2003--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
 
 "
 Internally markup is stored as lists, whose head is a function.
@@ -69,7 +69,7 @@ Syntax:
             (let ((args (gensym "args"))
                   (markup-command (car body)))
             `(define-public (,command-name . ,args)
-               ,(format #f "Copy of the ~a command" markup-command)
+               ,(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
@@ -80,6 +80,36 @@ Syntax:
          (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 . 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)
+	    `(define-public (,command-name ,@args)
+	       ,@body)
+	    (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-list-function-list, for markup documentation
+       (if (not (member ,command-name markup-list-function-list))
+	   (set! markup-list-function-list (cons ,command-name
+						 markup-list-function-list)))
+       ;; it's a markup-list command:
+       (set-object-property! ,command-name 'markup-list-command #t)
+       ;; define the make-COMMAND-markup-list function
+       (define-public (,make-markup-name . args)
+	 (let ((sig (list ,@signature)))
+	   (list (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
 against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
@@ -112,7 +142,7 @@ against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
   "The `markup' macro provides a lilypond-like syntax for building markups.
 
  - #:COMMAND is used instead of \\COMMAND
- - #:line ( ... ) is used instead of \line { ... }
+ - #:line ( ... ) is used instead of \\line { ... }
  - etc.
 
 Example:
@@ -239,44 +269,29 @@ Use `markup*' in a \\notemode context."
 ;;; (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-list-function-list (list))
 
 (define-public (markup-signature-to-keyword sig)
   " (A B C) -> a0-b1-c2 "
@@ -298,9 +313,24 @@ Also set markup-signature and markup-keyword object properties."
                                     sig)
                          "-"))))
 
+(define (lookup-markup-command-aux symbol)
+  (let ((proc (catch 'misc-error
+                (lambda ()
+                  (module-ref (current-module) symbol))
+                (lambda (key . args) #f))))
+    (and (procedure? proc) proc)))
+
 (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 (lookup-markup-command-aux
+	       (string->symbol (format #f "~a-markup" code)))))
+    (and proc (markup-function? proc)
+	 (cons proc (markup-command-keyword 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-keyword proc)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;
 ;;; used in parser.yy to map a list of markup commands on markup arguments
@@ -324,13 +354,25 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
 ;;; markup type predicates
 
 (define (markup-function? x)
-  (not (not (markup-command-signature x))))
+  (and (markup-command-signature x)
+       (not (object-property x 'markup-list-command))))
+
+(define (markup-list-function? x)
+  (and (markup-command-signature x)
+       (object-property x 'markup-list-command)))
+
+(define-public (markup-command-list? x)
+  "Determine if `x' is a markup command list, ie. a list composed of
+a markup list function and its arguments."
+  (and (pair? x) (markup-list-function? (car x))))
 
 (define-public (markup-list? arg)
+  "Return a true value if `x' is a list of markups or markup command lists."
   (define (markup-list-inner? lst)
     (or (null? lst)
-        (and (markup? (car lst)) (markup-list-inner? (cdr lst)))))
-  (and (list? arg) (markup-list-inner? arg)))
+	(and (or (markup? (car lst)) (markup-command-list? (car lst)))
+             (markup-list-inner? (cdr lst)))))
+  (not (not (and (list? arg) (markup-list-inner? arg)))))
 
 (define (markup-argument-list? signature arguments)
   "Typecheck argument list."
@@ -361,9 +403,14 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
                                   (cdr arg)))))
 
 ;; 
-;; typecheck, and throw an error when something amiss.
+;; 
+;;
 ;; 
 (define (markup-thrower-typecheck arg)
+  "typecheck, and throw an error when something amiss.
+
+Uncovered - cheap-markup? is used."
+
   (cond ((string? arg) #t)
         ((not (pair? arg))
          (throw 'markup-format "Not a pair" arg))
@@ -397,6 +444,18 @@ eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
 
 
 (define-public interpret-markup ly:text-interface::interpret-markup)
+
+(define-public (interpret-markup-list layout props markup-list)
+  (let ((stencils (list)))
+    (for-each (lambda (m)
+		(set! stencils
+		      (if (markup-command-list? m)
+			  (append! (reverse! (apply (car m) layout props (cdr m)))
+				   stencils)
+			  (cons (interpret-markup layout props m) stencils))))
+	      markup-list)
+    (reverse! stencils)))
+
 (define-public (prepend-alist-chain key val chain)
   (cons (acons key val (car chain)) (cdr chain)))