(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.
(make-markup): better function: less quoting escapades.

diff --git a/ChangeLog b/ChangeLog
index 29aba07b45a12474cc088fb50342b30d27440b5c..ccc15dc5f2db9e9e0957314bccb79c280bdcaac1 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -4,6 +4,7 @@
        (markup-typecheck?):  add full typechecking functions.
        (make-markup-maker): add make-FOO-markup functions.
        (markup-argument-list-error): nice error checking messages.
+       (make-markup): better function: less quoting escapades.
 
 2002-12-29  Jan Nieuwenhuizen  <janneke@gnu.org>
 

diff --git a/scm/new-markup.scm b/scm/new-markup.scm
index 04d030f7cb8f6bce430ac608f3dfd6b65fd0b59b..07f6d11f34c6de8d84b7b0887b43eec734b7a091 100644 (file)
--- a/scm/new-markup.scm
+++ b/scm/new-markup.scm
@@ -283,8 +283,8 @@ for the reader.
   )
   (and (list? arg) (markup-list-inner? arg)))
 
-
 (define (markup-argument-list? signature arguments)
+  "Typecheck argument list."
   (if (and (pair? signature) (pair? arguments))
       (and ((car signature) (car arguments))
           (markup-argument-list? (cdr signature) (cdr arguments)))
@@ -293,6 +293,9 @@ for the reader.
 
 
 (define (markup-argument-list-error signature arguments number)
+  "return (ARG-NR TYPE-EXPECTED ARG-FOUND) if an error is detected, or
+#f is no error found.
+"
   (if (and (pair? signature) (pair? arguments))
       (if (not ((car signature) (car arguments)))
          (list number (type-name (car signature)) (car arguments))
@@ -330,6 +333,10 @@ for the reader.
    #t
   )
 
+
+;;
+;; good enough if you only  use make-XXX-markup functions.
+;; 
 (define (cheap-markup? x)
   (and (pair? x)
        (markup-function? (car x)))
@@ -415,18 +422,22 @@ for the reader.
         )
       
       `(define (,(string->symbol make-name) . args)
-        (if (= (length  args) (length ,signature))
-            #t
+        (let*
+            (
+             (arglen (length  args))
+             (siglen (length ,signature))
+             (error-msg
+              (if (and (> 0 siglen) (> 0 arglen))
+                  (markup-argument-list-error ,signature args 1)))
+             
+             )
+        
+        (if (or (not (= arglen siglen)) (< siglen 0) (< 0 arglen))
             (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)
             
@@ -435,6 +446,49 @@ for the reader.
     )
 )
 
+
+
+(define (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.
+"
+
+  (let*
+      (
+       (arglen (length args))
+       (siglen (length signature))
+       (error-msg
+       (if (and (> siglen 0) (> arglen 0))
+           (markup-argument-list-error signature args 1)))
+       )
+
+
+    (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
+       (scm-error 'markup-format make-name "Expect ~A arguments for ~A. Found ~A: ~S"
+                  (list siglen
+                        make-name
+                        arglen
+                        args) #f))
+
+    (if error-msg
+       (scm-error 'markup-format make-name "Invalid argument in position ~A\nExpect: ~A\nFound: ~S." error-msg #f)
+       
+       (cons markup-function  args)
+       )))
+
+(define (make-markup-maker entry)
+  (let* (
+        (name (symbol->string (procedure-name (car entry))))
+        (make-name  (string-append "make-" name))
+        (signature (object-property (car entry) 'markup-signature))
+        )
+  
+    `(define (,(string->symbol make-name) . args)
+       (make-markup ,(car entry) ,make-name ,(cons 'list signature)  args)
+       ))
+  )
+
 (eval
  (cons 'begin (map make-markup-maker markup-function-list))
  markup-module
@@ -474,9 +528,26 @@ for the reader.
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(if #f
+   (define (typecheck-with-error x)
+     (catch
+      'markup-format
+      (lambda () (markup? x))
+      (lambda (key message arg)
+       (display "\nERROR: markup format error: \n")
+       (display message)
+       (newline)
+       (write arg (current-output-port))
+       )
+      )))
+
 ;; test make-foo-markup functions
 (if #t
     (begin
+      (newline)
+      (newline)
+      (display (make-line-markup (list (make-simple-markup "FOO"))))
+      
       (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"))
@@ -494,17 +565,7 @@ for the reader.
    ;; To get error messages, see above to install the alternate
    ;; typecheck routine for markup?.
    
-   (define (typecheck-with-error x)
-     (catch
-      'markup-format
-      (lambda () (markup? x))
-      (lambda (key message arg)
-       (display "\nERROR: markup format error: \n")
-       (display message)
-       (newline)
-       (write arg (current-output-port))
-       )
-      ))
+
 
    (display (typecheck-with-error `(,simple-markup "foobar")))
    (display (typecheck-with-error `(,simple-markup "foobar")))