From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 30 Jan 2006 21:05:54 +0000 (+0000)
Subject: Change representation of namespace URIs to use the URI data
X-Git-Tag: 20090517-FFI~1122
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8fa38b93811f0e9ae43bf1f6bc16f1f71cca31a8;p=mit-scheme.git

Change representation of namespace URIs to use the URI data
abstraction.
---

diff --git a/v7/doc/ref-manual/io.texi b/v7/doc/ref-manual/io.texi
index deab818c0..7f6d3edb6 100644
--- a/v7/doc/ref-manual/io.texi
+++ b/v7/doc/ref-manual/io.texi
@@ -1,5 +1,5 @@
 @c This file is part of the MIT/GNU Scheme Reference Manual.
-@c $Id: io.texi,v 1.12 2006/01/30 20:22:41 cph Exp $
+@c $Id: io.texi,v 1.13 2006/01/30 21:05:54 cph Exp $
 
 @c Copyright 1991,1992,1993,1994,1995 Massachusetts Institute of Technology
 @c Copyright 1996,1997,1999,2000,2001 Massachusetts Institute of Technology
@@ -3052,7 +3052,7 @@ identifies an optional namespace.
 @deffn procedure make-xml-name qname uri
 Creates and returns an @acronym{XML} name.  @var{Qname} must be a symbol
 whose name satisfies @code{string-is-xml-name?}.  @var{Uri} must be an
-@code{xml-namespace-uri} record.  The returned value is an @acronym{XML}
+absolute @acronym{URI} record.  The returned value is an @acronym{XML}
 name that satisfies @code{xml-name?}.
 
 If @var{uri} is the @dfn{null} namespace (satisfies
@@ -3064,8 +3064,8 @@ For convenience, @var{qname} may be a string, in which case it is
 converted to a symbol using @code{make-xml-qname}.
 
 For convenience, @var{uri} may be a string, in which case it is
-converted to an @code{xml-namespace-uri} record using
-@code{make-xml-namespace-uri}.
+converted to an absolute @acronym{URI} record using
+@code{->absolute-uri}.
 @end deffn
 
 @deffn procedure xml-name? object
@@ -3078,7 +3078,7 @@ Returns the @dfn{qname} of @var{xml-name} as a symbol.
 @end deffn
 
 @deffn procedure xml-name-uri xml-name
-Returns the @dfn{URI} of @var{xml-name} as an @code{xml-namespace-uri}
+Returns the @dfn{URI} of @var{xml-name} as an absolute @acronym{URI}
 record.
 @end deffn
 
@@ -3170,26 +3170,6 @@ particular syntax, but this implementation uses an abstract
 representation that speeds up type and equality testing.  Two
 @acronym{URI}s are tested for equality using @code{eq?}.
 
-@deffn procedure make-xml-namespace-uri string
-@var{String} must be a syntactically valid @acronym{URI} encoded in
-@acronym{UTF-8}.  Returns the corresponding @acronym{URI}.
-@end deffn
-
-@deffn procedure xml-namespace-uri? object
-Returns @code{#t} if @var{object} is an @acronym{URI} record, otherwise
-returns @code{#f}.
-@end deffn
-
-@deffn procedure xml-namespace-uri-string uri
-@var{Uri} must satisfy @code{xml-namespace-uri?}.  Returns a newly
-allocated string that is a copy of the string used to create @var{uri}.
-@end deffn
-
-The @acronym{URI} of an @acronym{XML} name may be null if there is no
-namespace associated with the name.  The null @acronym{URI} is
-abstracted by the following two procedures.  Note that the null
-@acronym{URI} satisfies the predicate @code{xml-namespace-uri?}.
-
 @deffn procedure null-xml-namespace-uri
 Returns the null @acronym{URI} record.
 @end deffn
diff --git a/v7/src/xdoc/xdoc.scm b/v7/src/xdoc/xdoc.scm
index d5b285feb..3512cb045 100644
--- a/v7/src/xdoc/xdoc.scm
+++ b/v7/src/xdoc/xdoc.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xdoc.scm,v 1.3 2006/01/30 20:23:05 cph Exp $
+$Id: xdoc.scm,v 1.4 2006/01/30 21:05:45 cph Exp $
 
 Copyright 2003,2004,2006 Massachusetts Institute of Technology
 
@@ -1291,7 +1291,7 @@ USA.
 	(xml-name=? name 'style)
 	(and (xml-name-prefix=? name 'xmlns)
 	     (not (string=? (xml-attribute-value attr)
-			    (xml-namespace-uri-string xdoc-uri)))))))
+			    (uri->string xdoc-uri)))))))
 
 (define (merged-attribute? attr)
   (let ((name (xml-attribute-name attr)))
@@ -1405,7 +1405,7 @@ USA.
 ;;;; XDOC element data types
 
 (define xdoc-uri
-  (make-xml-namespace-uri "http://mit.edu/2003/XDOC"))
+  (->absolute-uri "http://mit.edu/2003/XDOC"))
 
 (define (xdoc-name? name)
   (xml-name-uri=? name xdoc-uri))
diff --git a/v7/src/xml/xhtml.scm b/v7/src/xml/xhtml.scm
index 271a36544..186c854b7 100644
--- a/v7/src/xml/xhtml.scm
+++ b/v7/src/xml/xhtml.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xhtml.scm,v 1.20 2006/01/30 20:20:40 cph Exp $
+$Id: xhtml.scm,v 1.21 2006/01/30 21:05:29 cph Exp $
 
 Copyright 2002,2003,2004,2005,2006 Massachusetts Institute of Technology
 
@@ -28,7 +28,7 @@ USA.
 (declare (usual-integrations))
 
 (define html-uri-string "http://www.w3.org/1999/xhtml")
-(define html-uri (make-xml-namespace-uri html-uri-string))
+(define html-uri (->absolute-uri html-uri-string))
 
 (define (html-element? object)
   (and (xml-element? object)
diff --git a/v7/src/xml/xml-names.scm b/v7/src/xml/xml-names.scm
index de08fefdc..0749f90fc 100644
--- a/v7/src/xml/xml-names.scm
+++ b/v7/src/xml/xml-names.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml-names.scm,v 1.10 2006/01/30 20:20:42 cph Exp $
+$Id: xml-names.scm,v 1.11 2006/01/30 21:05:31 cph Exp $
 
 Copyright 2003,2004,2005,2006 Massachusetts Institute of Technology
 
@@ -29,7 +29,7 @@ USA.
 
 (define (make-xml-name qname uri)
   (let ((qname (make-xml-qname qname))
-	(uri (make-xml-namespace-uri uri)))
+	(uri (->absolute-uri uri)))
     (if (null-xml-namespace-uri? uri)
 	qname
 	(begin
@@ -274,37 +274,6 @@ USA.
 
 ;;;; Namespace URI
 
-(define (make-xml-namespace-uri object)
-  (if (string? object)
-      (begin
-	(if (not (string-is-namespace-uri? object))
-	    (error:bad-range-argument object 'MAKE-XML-NAMESPACE-URI))
-	(hash-table/intern! namespace-uris object
-	  (lambda ()
-	    (%make-xml-namespace-uri object))))
-      (begin
-	(guarantee-xml-namespace-uri object 'MAKE-XML-NAMESPACE-URI)
-	object)))
-
-(define (string-is-namespace-uri? object)
-  ;; See RFC 1630 for correct syntax.
-  (utf8-string-valid? object))
-
-(define namespace-uris
-  (make-string-hash-table))
-
-(define-record-type <xml-namespace-uri>
-    (%make-xml-namespace-uri string)
-    xml-namespace-uri?
-  (string %xml-namespace-uri-string))
-
-(define (guarantee-xml-namespace-uri object caller)
-  (if (not (xml-namespace-uri? object))
-      (error:not-xml-namespace-uri object caller)))
-
-(define (xml-namespace-uri-string uri)
-  (string-copy (%xml-namespace-uri-string uri)))
-
 (define (null-xml-namespace-uri? object)
   (eq? object null-namespace-uri))
 
@@ -312,13 +281,10 @@ USA.
   null-namespace-uri)
 
 (define null-namespace-uri
-  (make-xml-namespace-uri ""))
-
-(define (error:not-xml-namespace-uri object caller)
-  (error:wrong-type-argument object "an XML namespace URI" caller))
+  (->relative-uri ""))
 
 (define xml-uri
-  (make-xml-namespace-uri "http://www.w3.org/XML/1998/namespace"))
+  (->absolute-uri "http://www.w3.org/XML/1998/namespace"))
 
 (define xmlns-uri
-  (make-xml-namespace-uri "http://www.w3.org/2000/xmlns/"))
\ No newline at end of file
+  (->absolute-uri "http://www.w3.org/2000/xmlns/"))
\ No newline at end of file
diff --git a/v7/src/xml/xml-parser.scm b/v7/src/xml/xml-parser.scm
index 4f1e1da56..31e5afd3c 100644
--- a/v7/src/xml/xml-parser.scm
+++ b/v7/src/xml/xml-parser.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml-parser.scm,v 1.66 2006/01/30 20:20:44 cph Exp $
+$Id: xml-parser.scm,v 1.67 2006/01/30 21:05:32 cph Exp $
 
 Copyright 2001,2002,2003,2004,2005,2006 Massachusetts Institute of Technology
 
@@ -566,7 +566,11 @@ USA.
 		    (tail (loop (cdr attrs))))
 		(let ((qname (car uname))
 		      (p (cdr uname)))
-		  (let ((get-uri (lambda () (make-xml-namespace-uri value)))
+		  (let ((get-uri
+			 (lambda ()
+			   (if (string-null? value)
+			       (null-xml-namespace-uri)
+			       (->absolute-uri value))))
 			(forbidden-uri
 			 (lambda (uri)
 			   (perror p "Forbidden namespace URI" uri))))
diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index 12964d4ec..cc0013d87 100644
--- 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.51 2006/01/30 20:20:46 cph Exp $
+$Id: xml-struct.scm,v 1.52 2006/01/30 21:05:33 cph Exp $
 
 Copyright 2001,2002,2003,2004,2005,2006 Massachusetts Institute of Technology
 
@@ -437,10 +437,12 @@ USA.
 			    (symbol-append 'xmlns: prefix))
 			elt)))
     (and value
-	 (make-xml-namespace-uri value))))
+	 (if (string-null? value)
+	     (null-xml-namespace-uri)
+	     (->absolute-uri value)))))
 
 (define (xml-element-namespace-prefix elt uri)
-  (let ((uri (xml-namespace-uri-string uri)))
+  (let ((uri (uri->string uri)))
     (let ((attr
 	   (find-matching-item (xml-element-attributes elt)
 	     (lambda (attr)
@@ -569,7 +571,7 @@ USA.
   (cond ((xml-content-item? value) value)
 	((symbol? value) (symbol-name value))
 	((number? value) (number->string value))
-	((xml-namespace-uri? value) (xml-namespace-uri-string value))
+	((uri? value) (uri->string value))
 	((list-of-type? value xml-nmtoken?) (nmtokens->string value))
 	(else (error:wrong-type-datum value "XML string value"))))
 
diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index 7e5f1566c..aabc20d73 100644
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.62 2006/01/30 20:20:41 cph Exp $
+$Id: xml.pkg,v 1.63 2006/01/30 21:05:30 cph Exp $
 
 Copyright 2001,2002,2003,2004,2005,2006 Massachusetts Institute of Technology
 
@@ -36,18 +36,14 @@ USA.
   (files "xml-names")
   (parent (runtime xml))
   (export ()
-	  <xml-namespace-uri>
 	  error:not-xml-name
-	  error:not-xml-namespace-uri
 	  error:not-xml-nmtoken
 	  error:not-xml-qname
 	  guarantee-xml-name
-	  guarantee-xml-namespace-uri
 	  guarantee-xml-nmtoken
 	  guarantee-xml-qname
 	  make-xml-name
 	  make-xml-name-hash-table
-	  make-xml-namespace-uri
 	  make-xml-nmtoken
 	  make-xml-qname
 	  null-xml-name-prefix
@@ -68,8 +64,6 @@ USA.
 	  xml-name-uri=?
 	  xml-name=?
 	  xml-name?
-	  xml-namespace-uri-string
-	  xml-namespace-uri?
 	  xml-nmtoken-string
 	  xml-nmtoken?
 	  xml-qname-local