Implement GUARANTEE- procedures for all types. Implement

XML-ELEMENT-NAMESPACE-DECLS.

diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index 0d1d8db560eb43c463835a10540818f8e2c9d795..5a0eab3b257dcff5f9b6dc0255d63950c5494bc5 100644 (file)
--- a/v7/src/xml/xml-struct.scm
+++ b/v7/src/xml/xml-struct.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml-struct.scm,v 1.26 2003/09/24 03:50:48 cph Exp $
+$Id: xml-struct.scm,v 1.27 2003/09/24 04:17:38 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -51,7 +51,7 @@ USA.
           (string-is-xml-name? (symbol-name object)))
       (combo-name? object)))
 
-(define-integrable (guarantee-xml-name object caller)
+(define (guarantee-xml-name object caller)
   (if (not (xml-name? object))
       (error:not-xml-name object caller)))
 
@@ -73,7 +73,7 @@ USA.
   (and (fix:> (string-length object) 0)
        (utf8-string-valid? object)))
 
-(define-integrable (guarantee-xml-namespace-uri object caller)
+(define (guarantee-xml-namespace-uri object caller)
   (if (not (xml-namespace-uri? object))
       (error:not-xml-namespace-uri object caller)))
 
@@ -256,6 +256,8 @@ USA.
               (slots (cddr form)))
           (let ((rtd (symbol-append '< root '>))
                 (constructor (symbol-append 'MAKE- root))
+                (predicate (symbol-append root '?))
+                (error:not (symbol-append 'ERROR:NOT- root))
                 (slot-vars
                  (map (lambda (slot)
                         (close-syntax (car slot) environment))
@@ -268,8 +270,19 @@ USA.
               `(BEGIN
                  (DEFINE ,rtd
                    (MAKE-RECORD-TYPE ',root '(,@(map car slots))))
-                 (DEFINE ,(symbol-append root '?)
+                 (DEFINE ,predicate
                    (RECORD-PREDICATE ,rtd))
+                 (DEFINE (,(symbol-append 'GUARANTEE- root) OBJECT CALLER)
+                   (IF (NOT ,predicate)
+                       (,error:not OBJECT CALLER)))
+                 (DEFINE (,error:not OBJECT CALLER)
+                   (ERROR:WRONG-TYPE-ARGUMENT
+                    OBJECT
+                    ,(string-append "an XML "
+                                    (string-replace (symbol-name (cadr form))
+                                                    #\-
+                                                    #\space))
+                    CALLER))
                  (DEFINE ,constructor
                    (LET ((CONSTRUCTOR
                           (RECORD-CONSTRUCTOR ,rtd '(,@(map car slots)))))
@@ -365,11 +378,6 @@ USA.
   (and (pair? object)
        (list-of-type? object xml-attribute-value-item?)))
 
-(define (simple-xml-attribute-value? object)
-  (and (pair? object)
-       (xml-char-data? (car object))
-       (null? (cdr object))))
-
 (define (xml-attribute-value-item? object)
   (or (xml-char-data? object)
       (xml-entity-ref? object)))
@@ -625,4 +633,37 @@ USA.
 (define-xml-printer external-id
   (lambda (dtd)
     (or (xml-external-id-id dtd)
-       (xml-external-id-uri dtd))))
\ No newline at end of file
+       (xml-external-id-uri dtd))))
+\f
+(define (simple-xml-attribute-value? object)
+  (and (pair? object)
+       (xml-char-data? (car object))
+       (null? (cdr object))
+       (car object)))
+
+(define (guarantee-simple-xml-attribute-value object caller)
+  (let ((v (simple-xml-attribute-value? object)))
+    (if (not v)
+       (error:not-simple-xml-attribute-value object caller))
+    v))
+
+(define (error:not-simple-xml-attribute-value object caller)
+  (error:wrong-type-argument object "simple XML attribute value" caller))
+
+(define (xml-element-namespace-decls elt)
+  (guarantee-xml-element elt 'XML-ELEMENT-NAMESPACE-DECLS)
+  (let loop ((attrs (xml-element-attributes elt)))
+    (if (pair? attrs)
+       (let ((name (caar attrs))
+             (keep
+              (lambda (prefix)
+                (cons (cons prefix
+                            (make-xml-namespace-uri
+                             (guarantee-simple-xml-attribute-value
+                              (cdar attrs)
+                              #f)))
+                      (loop (cdr attrs))))))
+         (cond ((xml-name=? name 'xmlns) (keep #f))
+               ((xml-name-prefix=? name 'xmlns) (keep (xml-name-local name)))
+               (else (loop (cdr attrs)))))
+       '())))
\ No newline at end of file

diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index 5f2f77526c6cfbd70e55c697a025c5e10dc1e965..2b3172d05f4ac8fa7222746b61f26cadd3428761 100644 (file)
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.27 2003/09/24 03:50:45 cph Exp $
+$Id: xml.pkg,v 1.28 2003/09/24 04:17:45 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -51,8 +51,42 @@ USA.
          <xml-parameter-entity-ref>
          <xml-processing-instructions>
          <xml-unparsed-!entity>
+         error:not-simple-xml-attribute-value
+         error:not-xml-!attlist
+         error:not-xml-!element
+         error:not-xml-!entity
+         error:not-xml-!notation
+         error:not-xml-comment
+         error:not-xml-declaration
+         error:not-xml-document
+         error:not-xml-dtd
+         error:not-xml-element
+         error:not-xml-entity-ref
+         error:not-xml-external-id
+         error:not-xml-name
+         error:not-xml-namespace-uri
+         error:not-xml-parameter-!entity
+         error:not-xml-parameter-entity-ref
+         error:not-xml-processing-instructions
+         error:not-xml-unparsed-!entity
+         guarantee-simple-xml-attribute-value
+         guarantee-xml-!attlist
+         guarantee-xml-!element
+         guarantee-xml-!entity
+         guarantee-xml-!notation
+         guarantee-xml-comment
+         guarantee-xml-declaration
+         guarantee-xml-document
+         guarantee-xml-dtd
+         guarantee-xml-element
+         guarantee-xml-entity-ref
+         guarantee-xml-external-id
          guarantee-xml-name
          guarantee-xml-namespace-uri
+         guarantee-xml-parameter-!entity
+         guarantee-xml-parameter-entity-ref
+         guarantee-xml-processing-instructions
+         guarantee-xml-unparsed-!entity
          make-xml-!attlist
          make-xml-!element
          make-xml-!entity
@@ -146,6 +180,7 @@ USA.
          xml-element-attributes
          xml-element-contents
          xml-element-name
+         xml-element-namespace-decls
          xml-element?
          xml-entity-ref-name
          xml-entity-ref?