From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 31 Jan 2006 06:15:55 +0000 (+0000)
Subject: Use URI records for for namespace URIs.
X-Git-Tag: 20090517-FFI~1121
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6fbc5acab6294baa02d893c549192cce2827ea18;p=mit-scheme.git

Use URI records for for namespace URIs.
---

diff --git a/v7/doc/ref-manual/io.texi b/v7/doc/ref-manual/io.texi
index 7f6d3edb6..34a52adad 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.13 2006/01/30 21:05:54 cph Exp $
+@c $Id: io.texi,v 1.14 2006/01/31 06:15:55 cph Exp $
 
 @c Copyright 1991,1992,1993,1994,1995 Massachusetts Institute of Technology
 @c Copyright 1996,1997,1999,2000,2001 Massachusetts Institute of Technology
@@ -3041,31 +3041,32 @@ they appear in the @acronym{DTD} of a document, even if the body of the
 document uses them.  Consequently, it must be possible to compare
 non-associated names with associated names.
 
-@cindex Internationalized Resource Identifier
+@cindex Uniform Resource Identifier
 @cindex URI, of XML name
 @cindex qname, of XML name
 An @acronym{XML} name consists of two parts: the @dfn{qname}, which is a
 symbol, possibly including a namespace prefix; and the
-@dfn{Internationalized Resource Identifier} (@acronym{URI}), which
+@dfn{Uniform Resource Identifier} (@acronym{URI}), which
 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
-absolute @acronym{URI} record.  The returned value is an @acronym{XML}
-name that satisfies @code{xml-name?}.
+whose name satisfies @code{string-is-xml-name?}.  @var{Uri} must satisfy
+either @code{absolute-uri?} or @code{null-xml-namespace-uri?}.  The
+returned value is an @acronym{XML} name that satisfies @code{xml-name?}.
 
 If @var{uri} is the @dfn{null} namespace (satisfies
-@code{null-xml-name-prefix?}), the returned value is a symbol equivalent
-to @var{qname}.  This means that an ordinary symbol can be used as an
-@acronym{XML} name when there is no namespace associated with the name.
+@code{null-xml-namespace-uri?}), the returned value is a symbol
+equivalent to @var{qname}.  This means that an ordinary symbol can be
+used as an @acronym{XML} name when there is no namespace associated with
+the name.
 
 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 absolute @acronym{URI} record using
-@code{->absolute-uri}.
+For convenience, @var{uri} may be any object that @code{->uri} is able
+to convert to a @acronym{URI} record, provided the resulting
+@acronym{URI} meets the above restrictions.
 @end deffn
 
 @deffn procedure xml-name? object
@@ -3078,8 +3079,8 @@ 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 absolute @acronym{URI}
-record.
+Returns the @dfn{URI} of @var{xml-name}.  The result always satisfies
+@code{absolute-uri?} or @code{null-xml-namespace-uri?}.
 @end deffn
 
 @deffn procedure xml-name-string xml-name
@@ -3164,19 +3165,18 @@ Returns @code{#t} if @var{object} is the null prefix, otherwise returns
 @code{#f}.
 @end deffn
 
-These next procedures define the data abstraction for namespace
-@acronym{URI}s.  Conceptually, an @acronym{URI} is a string with a
-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?}.
+The namespace @acronym{URI} of an @acronym{XML} name may be null,
+meaning that there is no namespace associated with the name.  This
+namespace is represented by a relative @acronym{URI} record whose string
+representation is the null string.
 
 @deffn procedure null-xml-namespace-uri
-Returns the null @acronym{URI} record.
+Returns the null namespace @acronym{URI} record.
 @end deffn
 
 @deffn procedure null-xml-namespace-uri? object
-Returns @code{#t} if @var{object} is the null @acronym{URI} record,
-otherwise returns @code{#f}.
+Returns @code{#t} if @var{object} is the null namespace @acronym{URI}
+record, otherwise returns @code{#f}.
 @end deffn
 
 The following values are two distinguished @acronym{URI} records.
diff --git a/v7/src/xml/xml-names.scm b/v7/src/xml/xml-names.scm
index 0749f90fc..686100461 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.11 2006/01/30 21:05:31 cph Exp $
+$Id: xml-names.scm,v 1.12 2006/01/31 06:14:16 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 (->absolute-uri uri)))
+	(uri (->uri uri)))
     (if (null-xml-namespace-uri? uri)
 	qname
 	(begin
@@ -37,17 +37,17 @@ USA.
 	  (%make-xml-name qname uri)))))
 
 (define (check-prefix+uri qname uri)
-  (if (let ((s (symbol-name qname)))
-	(let ((c (find-prefix-separator s)))
-	  (case c
-	    ((#f) #f)
-	    ((ILLEGAL) uri)
-	    (else
-	     (let ((prefix (utf8-string->symbol (string-head s c))))
-	       (or (and (eq? prefix 'xml)
-			(not (eq? uri xml-uri)))
-		   (and (eq? prefix 'xmlns)
-			(not (eq? uri xmlns-uri)))))))))
+  (if (not (and (uri-absolute? uri)
+		(let ((s (symbol-name qname)))
+		  (let ((c (find-prefix-separator s)))
+		    (case c
+		      ((#f) #t)
+		      ((ILLEGAL) #f)
+		      (else
+		       (case (utf8-string->symbol (string-head s c))
+			 ((xml) (uri=? uri xml-uri))
+			 ((xmlns) (uri=? uri xmlns-uri))
+			 (else #t))))))))
       (error:bad-range-argument uri 'MAKE-XML-NAME)))
 
 (define (%make-xml-name qname uri)
@@ -78,6 +78,17 @@ USA.
 
 (define (error:not-xml-name object caller)
   (error:wrong-type-argument object "an XML Name" caller))
+
+(define (null-xml-namespace-uri? object)
+  (and (uri? object)
+       (uri=? object null-namespace-uri)))
+
+(define (null-xml-namespace-uri)
+  null-namespace-uri)
+
+(define null-namespace-uri (->relative-uri ""))
+(define xml-uri (->absolute-uri "http://www.w3.org/XML/1998/namespace"))
+(define xmlns-uri (->absolute-uri "http://www.w3.org/2000/xmlns/"))
 
 (define (make-xml-nmtoken object)
   (if (string? object)
@@ -152,7 +163,7 @@ USA.
 	(else (error:not-xml-name name 'XML-NAME-URI))))
 
 (define (xml-name-uri=? name uri)
-  (eq? (xml-name-uri name) uri))
+  (uri=? (xml-name-uri name) uri))
 
 (define (xml-name-prefix name)
   (xml-qname-prefix
@@ -270,21 +281,4 @@ USA.
     expanded-name?
   (uri expanded-name-uri)
   (local expanded-name-local)
-  (combos expanded-name-combos))
-
-;;;; Namespace URI
-
-(define (null-xml-namespace-uri? object)
-  (eq? object null-namespace-uri))
-
-(define (null-xml-namespace-uri)
-  null-namespace-uri)
-
-(define null-namespace-uri
-  (->relative-uri ""))
-
-(define xml-uri
-  (->absolute-uri "http://www.w3.org/XML/1998/namespace"))
-
-(define xmlns-uri
-  (->absolute-uri "http://www.w3.org/2000/xmlns/"))
\ No newline at end of file
+  (combos expanded-name-combos))
\ No newline at end of file
diff --git a/v7/src/xml/xml-output.scm b/v7/src/xml/xml-output.scm
index ed6f2c7e9..f2b39ef31 100644
--- a/v7/src/xml/xml-output.scm
+++ b/v7/src/xml/xml-output.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: xml-output.scm,v 1.39 2006/01/30 20:20:43 cph Exp $
+$Id: xml-output.scm,v 1.40 2006/01/31 06:14:20 cph Exp $
 
-Copyright 2001,2002,2003,2004,2005 Massachusetts Institute of Technology
+Copyright 2001,2002,2003,2004,2005,2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -464,12 +464,12 @@ USA.
 	  (if (xml-external-id-uri id)
 	      (begin
 		(write-indent col ctx)
-		(quoted-string (xml-external-id-uri id)))))
+		(quoted-string (uri->string (xml-external-id-uri id))))))
 	(begin
 	  (write-indent col ctx)
 	  (emit-string "SYSTEM" ctx)
 	  (emit-string " " ctx)
-	  (quoted-string (xml-external-id-uri id))))))
+	  (quoted-string (uri->string (xml-external-id-uri id)))))))
 
 (define (write-indent col ctx)
   (if col
diff --git a/v7/src/xml/xml-parser.scm b/v7/src/xml/xml-parser.scm
index 31e5afd3c..40a78c1d5 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.67 2006/01/30 21:05:32 cph Exp $
+$Id: xml-parser.scm,v 1.68 2006/01/31 06:14:25 cph Exp $
 
 Copyright 2001,2002,2003,2004,2005,2006 Massachusetts Institute of Technology
 
@@ -570,14 +570,15 @@ USA.
 			 (lambda ()
 			   (if (string-null? value)
 			       (null-xml-namespace-uri)
-			       (->absolute-uri value))))
+			       (string->absolute-uri value))))
 			(forbidden-uri
 			 (lambda (uri)
-			   (perror p "Forbidden namespace URI" uri))))
+			   (perror p "Forbidden namespace URI"
+				   (uri->string uri)))))
 		    (let ((guarantee-legal-uri
 			   (lambda (uri)
-			     (if (or (eq? uri xml-uri)
-				     (eq? uri xmlns-uri))
+			     (if (or (uri=? uri xml-uri)
+				     (uri=? uri xmlns-uri))
 				 (forbidden-uri uri)))))
 		      (cond ((xml-name=? qname 'xmlns)
 			     (let ((uri (get-uri)))
@@ -588,7 +589,7 @@ USA.
 				 (perror p "Illegal namespace prefix" qname))
 			     (let ((uri (get-uri)))
 			       (if (xml-name=? qname 'xmlns:xml)
-				   (if (not (eq? uri xml-uri))
+				   (if (not (uri=? uri xml-uri))
 				       (forbidden-uri uri))
 				   (guarantee-legal-uri uri))
 			       (cons (cons (xml-name-local qname) uri) tail)))
diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index cc0013d87..662698a65 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.52 2006/01/30 21:05:33 cph Exp $
+$Id: xml-struct.scm,v 1.53 2006/01/31 06:14:29 cph Exp $
 
 Copyright 2001,2002,2003,2004,2005,2006 Massachusetts Institute of Technology
 
@@ -262,7 +262,7 @@ USA.
   (uri canonicalize
        (lambda (object)
 	 (and object
-	      (canonicalize-char-data object)))))
+	      (->uri (canonicalize-char-data object))))))
 
 (define (public-id? object)
   (string-composed-of? object char-set:xml-public-id))
@@ -442,17 +442,16 @@ USA.
 	     (->absolute-uri value)))))
 
 (define (xml-element-namespace-prefix elt uri)
-  (let ((uri (uri->string uri)))
-    (let ((attr
-	   (find-matching-item (xml-element-attributes elt)
-	     (lambda (attr)
-	       (and (xml-attribute-namespace-decl? attr)
-		    (string=? (xml-attribute-value attr) uri))))))
-      (and attr
-	   (let ((name (xml-attribute-name attr)))
-	     (if (xml-name=? name 'xmlns)
-		 (null-xml-name-prefix)
-		 (xml-name-local name)))))))
+  (let ((attr
+	 (find-matching-item (xml-element-attributes elt)
+	   (lambda (attr)
+	     (and (xml-attribute-namespace-decl? attr)
+		  (uri=? (->uri (xml-attribute-value attr)) uri))))))
+    (and attr
+	 (let ((name (xml-attribute-name attr)))
+	   (if (xml-name=? name 'xmlns)
+	       (null-xml-name-prefix)
+	       (xml-name-local name))))))
 
 ;;;; Convenience procedures