Implement namespace URI abstraction.

diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index 85c7988b92c907bdfb12af747b6a2b179f814f03..0d1d8db560eb43c463835a10540818f8e2c9d795 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.25 2003/09/24 03:26:23 cph Exp $
+$Id: xml-struct.scm,v 1.26 2003/09/24 03:50:48 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -51,35 +51,46 @@ USA.
           (string-is-xml-name? (symbol-name object)))
       (combo-name? object)))
 
-(define (guarantee-xml-name object caller)
+(define-integrable (guarantee-xml-name object caller)
   (if (not (xml-name? object))
       (error:not-xml-name object caller)))
 
 (define (error:not-xml-name object caller)
   (error:wrong-type-argument object "an XML name" caller))
 
+(define (make-xml-namespace-uri uri)
+  (if (namespace-uri-string? uri)
+      (string->symbol uri)
+      (begin
+       (if uri (guarantee-xml-namespace-uri uri 'MAKE-XML-NAMESPACE-URI))
+       uri)))
+
 (define (xml-namespace-uri? object)
   (and (interned-symbol? object)
-       (let ((string (symbol-name object)))
-        (and (fix:> (string-length string) 0)
-             (utf8-string-valid? string)))))
+       (namespace-uri-string? (symbol-name object))))
+
+(define (namespace-uri-string? object)
+  (and (fix:> (string-length object) 0)
+       (utf8-string-valid? object)))
 
-(define (guarantee-xml-namespace-uri object caller)
+(define-integrable (guarantee-xml-namespace-uri object caller)
   (if (not (xml-namespace-uri? object))
       (error:not-xml-namespace-uri object caller)))
 
 (define (error:not-xml-namespace-uri object caller)
   (error:wrong-type-argument object "an XML namespace URI" caller))
+
+(define (xml-namespace-uri-string uri)
+  (guarantee-xml-namespace-uri uri 'XML-NAMESPACE-URI-STRING)
+  (symbol->string uri))
 \f
-(define (xml-intern name #!optional uri)
-  (let ((uri (if (default-object? uri) #f uri))
-       (lose
+(define (xml-intern simple #!optional uri)
+  (make-xml-name simple (if (default-object? uri) #f uri)))
+
+(define (make-xml-name simple uri)
+  (let ((lose
         (lambda ()
-          (error:wrong-type-argument string
-                                     "an XML name string"
-                                     'XML-INTERN))))
-    (if uri
-       (guarantee-xml-namespace-uri uri 'XML-INTERN))
+          (error:wrong-type-argument simple "an XML name" 'MAKE-XML-NAME))))
     (receive (string symbol)
        (cond ((symbol? name) (values (symbol-name name) name))
              ((string? name) (values name (string->symbol name)))
@@ -89,11 +100,12 @@ USA.
               symbol)
              ((eq? type 'NAME)
               (%make-xml-name symbol
-                              uri
+                              (make-xml-namespace-uri uri)
                               (let ((c (string-find-next-char string #\:)))
                                 (if c
-                                    (string->symbol
-                                     (string-tail string (fix:+ c 1)))
+                                    (substring->symbol string
+                                                       (fix:+ c 1)
+                                                       (string-length string))
                                     symbol))))
              (else (lose)))))))
 

diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index 748d9a50ff5f35f5e7b10f21e4dee20b180318b9..5f2f77526c6cfbd70e55c697a025c5e10dc1e965 100644 (file)
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.26 2003/09/24 03:26:16 cph Exp $
+$Id: xml.pkg,v 1.27 2003/09/24 03:50:45 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -52,6 +52,7 @@ USA.
          <xml-processing-instructions>
          <xml-unparsed-!entity>
          guarantee-xml-name
+         guarantee-xml-namespace-uri
          make-xml-!attlist
          make-xml-!element
          make-xml-!entity
@@ -63,7 +64,9 @@ USA.
          make-xml-element
          make-xml-entity-ref
          make-xml-external-id
+         make-xml-name
          make-xml-name-hash-table
+         make-xml-namespace-uri
          make-xml-parameter-!entity
          make-xml-parameter-entity-ref
          make-xml-processing-instructions
@@ -162,6 +165,8 @@ USA.
          xml-name-uri=?
          xml-name=?
          xml-name?
+         xml-namespace-uri-string
+         xml-namespace-uri?
          xml-nmtoken?
          xml-parameter-!entity-name
          xml-parameter-!entity-value