From: Han-Wen Nienhuys <hanwen@xs4all.nl>
Date: Sun, 29 Dec 2002 16:14:50 +0000 (+0000)
Subject: (markup-thrower-typecheck)
X-Git-Tag: release/1.7.11~24
X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=fc6dec21f05dc474dde44ee6d0da3b83525f0430;p=lilypond.git

(markup-thrower-typecheck)
(markup-typecheck?):  add full typechecking functions.
(make-markup-maker): add make-FOO-markup functions.
(markup-argument-list-error): nice error checking messages.
---

diff --git a/ChangeLog b/ChangeLog
index df834bf51a..29aba07b45 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -3,6 +3,7 @@
 	* scm/new-markup.scm (markup-thrower-typecheck) 
 	(markup-typecheck?):  add full typechecking functions.
 	(make-markup-maker): add make-FOO-markup functions.
+	(markup-argument-list-error): nice error checking messages.
 
 2002-12-29  Jan Nieuwenhuizen  <janneke@gnu.org>
 
diff --git a/scm/c++.scm b/scm/c++.scm
index 9231f51b7c..20d14b9335 100644
--- a/scm/c++.scm
+++ b/scm/c++.scm
@@ -38,38 +38,11 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
-(define type-p-name-alist
-  `(
-   (,ly:dir? . "direction")
-   (,scheme? . "any type")
-   (,number-pair? . "pair of numbers")
-   (,ly:input-location? . "input location")   
-   (,ly:grob? . "grob (GRaphical OBject)")
-   (,grob-list? . "list of grobs")
-   (,ly:duration? . "duration")
-   (,pair? . "pair")
-   (,integer? . "integer")
-   (,list? . "list")
-   (,symbol? . "symbol")
-   (,string? . "string")
-   (,boolean? . "boolean")
-   (,ly:moment? . "moment")
-   (,ly:input-location? . "input location")
-   (,music-list? . "list of music")
-   (,ly:music? . "music")
-   (,number? . "number")
-   (,char? . "char")
-   (,input-port? . "input port")
-   (,output-port? . "output port")   
-   (,vector? . "vector")
-   (,procedure? . "procedure") 
-   (,boolean-or-symbol? . "boolean or symbol")
-   (,number-or-string? . "number or string")
-   (,markup? . "markup (list or string)")
-   (,number-or-grob? . "number or grob")
-   ))
 
 
+;; moved list to end of lily.scm: then all type-predicates are
+;; defined.
+(define type-p-name-alist '()) 
 
 (define (match-predicate obj alist)
   (if (null? alist)
diff --git a/scm/lily.scm b/scm/lily.scm
index f710ef0569..fde3b90e19 100644
--- a/scm/lily.scm
+++ b/scm/lily.scm
@@ -237,6 +237,7 @@ is the  first to satisfy CRIT
      '("music-types.scm"
        "output-lib.scm"
        "c++.scm"
+       
        "molecule.scm"
        "bass-figure.scm"
        "grob-property-description.scm"
@@ -261,3 +262,36 @@ is the  first to satisfy CRIT
 
 
        
+
+
+(set! type-p-name-alist
+  `(
+   (,ly:dir? . "direction")
+   (,scheme? . "any type")
+   (,number-pair? . "pair of numbers")
+   (,ly:input-location? . "input location")   
+   (,ly:grob? . "grob (GRaphical OBject)")
+   (,grob-list? . "list of grobs")
+   (,ly:duration? . "duration")
+   (,pair? . "pair")
+   (,integer? . "integer")
+   (,list? . "list")
+   (,symbol? . "symbol")
+   (,string? . "string")
+   (,boolean? . "boolean")
+   (,ly:moment? . "moment")
+   (,ly:input-location? . "input location")
+   (,music-list? . "list of music")
+   (,ly:music? . "music")
+   (,number? . "number")
+   (,char? . "char")
+   (,input-port? . "input port")
+   (,output-port? . "output port")   
+   (,vector? . "vector")
+   (,procedure? . "procedure") 
+   (,boolean-or-symbol? . "boolean or symbol")
+   (,number-or-string? . "number or string")
+   (,markup? . "markup")
+   (,markup-list? . "list of markups")
+   (,number-or-grob? . "number or grob")
+   ))
diff --git a/scm/new-markup.scm b/scm/new-markup.scm
index 5c86dd4ca3..04d030f7cb 100644
--- a/scm/new-markup.scm
+++ b/scm/new-markup.scm
@@ -291,6 +291,15 @@ for the reader.
       (and (null? signature) (null? arguments)))
   )
 
+
+(define (markup-argument-list-error signature arguments number)
+  (if (and (pair? signature) (pair? arguments))
+      (if (not ((car signature) (car arguments)))
+	  (list number (type-name (car signature)) (car arguments))
+	  (markup-argument-list-error (cdr signature) (cdr arguments) (+ 1 number)))
+      #f
+  ))
+
 ;;
 ;; full recursive typecheck.
 ;;
@@ -395,6 +404,8 @@ for the reader.
 ;; Invalid argument 4 : expecting a BLADIBLA, found: (list-ref 4 args)
 ;;
 ;; right now, you get the entire argument list.
+
+
 (define (make-markup-maker  entry)
   (let*
 	((foo-markup (car entry))
@@ -404,12 +415,25 @@ for the reader.
 	 )
       
       `(define (,(string->symbol make-name) . args)
-	 (if (markup-argument-list? ,signature args)
+	 (if (= (length  args) (length ,signature))
+	     #t
+	     (scm-error 'markup-format ,make-name "Expect ~A arguments for ~A. Found ~A: ~S"
+			(list (length ,signature)
+			      ,make-name
+			      (length args)
+			      args) #f))
+
+	 (let*
+	     (
+	      (error-msg (markup-argument-list-error ,signature args 1))
+	      )
+	 (if error-msg
+	     (scm-error 'markup-format ,make-name "Invalid argument in position ~A\n Expect: ~A\nFound: ~S." error-msg #f)
+	     
 	     (cons ,foo-markup args)
-	     (scm-error 'markup-format ,make-name "Invalid argument list: ~A." (list args) #f)
 	     )))
     )
-
+)
 
 (eval
  (cons 'begin (map make-markup-maker markup-function-list))
@@ -451,14 +475,14 @@ for the reader.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 ;; test make-foo-markup functions
-(if #f
-(begin
-  (make-line-markup (make-simple-markup "FOO")
-		    (make-simple-markup "foo")
-		    )
+(if #t
+    (begin
+      (make-line-markup (make-simple-markup "FOO"))
+      (make-line-markup (make-simple-markup "FOO") (make-simple-markup "foo"))
+      (make-raise-markup "foo" (make-simple-markup "foo"))
+      )
+    )
 
-  (make-teeny-markup (make-simple-markup 1)))
-)
 
 ;;
 ;; test typecheckers. Not wholly useful, because errors are detected