From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 23 Jul 2007 02:46:10 +0000 (+0000)
Subject: Change XML name type to represent namespace URI as a string, and to
X-Git-Tag: 20090517-FFI~488
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=47824baba7de5054848e2ec34d95d6ef7de2e6f5;p=mit-scheme.git

Change XML name type to represent namespace URI as a string, and to
compare namespace URIs using string comparison.
---

diff --git a/v7/src/xml/xml-names.scm b/v7/src/xml/xml-names.scm
index b423ac2cd..4d7598ff5 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.16 2007/07/23 01:43:39 cph Exp $
+$Id: xml-names.scm,v 1.17 2007/07/23 02:46:07 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -31,35 +31,38 @@ USA.
 
 (define (make-xml-name qname uri)
   (let ((qname (make-xml-qname qname))
-	(uri (->uri uri)))
-    (if (null-xml-namespace-uri? uri)
+	(uri-string
+	 (cond ((string? uri) uri)
+	       ((wide-string? uri) (wide-string->utf8-string uri))
+	       ((symbol? uri) (symbol-name uri))
+	       ((uri? uri) (uri->string uri))
+	       (else (error:not-uri uri 'MAKE-XML-NAME)))))
+    (string->uri uri-string)		;signals error if not URI
+    (if (string-null? uri-string)
 	qname
 	(begin
-	  (check-prefix+uri qname uri)
-	  (%make-xml-name qname uri)))))
-
-(define (check-prefix+uri qname uri)
-  (if (not (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)
+	  (if (not (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) (string=? uri-string xml-uri-string))
+			    ((xmlns) (string=? uri-string xmlns-uri-string))
+			    (else #t)))))))
+	      (error:bad-range-argument uri-string 'MAKE-XML-NAME))
+	  (%make-xml-name qname uri-string)))))
+
+(define (%make-xml-name qname uri-string)
   (let ((uname
 	 (let ((local (xml-qname-local qname)))
 	   (hash-table/intern! (hash-table/intern! expanded-names
-						   uri
+						   uri-string
 						   make-eq-hash-table)
 			       local
 			       (lambda ()
-				 (make-expanded-name uri
+				 (make-expanded-name uri-string
 						     local
 						     (make-eq-hash-table)))))))
     (hash-table/intern! (expanded-name-combos uname)
@@ -67,7 +70,7 @@ USA.
 			(lambda () (make-combo-name qname uname)))))
 
 (define expanded-names
-  (make-eq-hash-table))
+  (make-string-hash-table))
 
 (define (xml-name? object)
   (or (xml-qname? object)
@@ -87,9 +90,11 @@ USA.
 (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 null-namespace-uri (->uri ""))
+(define xml-uri-string "http://www.w3.org/XML/1998/namespace")
+(define xml-uri (->uri xml-uri-string))
+(define xmlns-uri-string "http://www.w3.org/2000/xmlns/")
+(define xmlns-uri (->uri xmlns-uri-string))
 
 (define (make-xml-nmtoken object)
   (if (string? object)
@@ -159,7 +164,7 @@ USA.
   (eq? (xml-name-qname name) qname))
 
 (define (xml-name-uri name)
-  (cond ((xml-qname? name) (null-xml-namespace-uri))
+  (cond ((xml-qname? name) "")
 	((combo-name? name) (expanded-name-uri (combo-name-expanded name)))
 	(else (error:not-xml-name name 'XML-NAME-URI))))
 
diff --git a/v7/src/xml/xml-parser.scm b/v7/src/xml/xml-parser.scm
index 78e02176e..5a179fc7c 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.75 2007/07/23 01:43:41 cph Exp $
+$Id: xml-parser.scm,v 1.76 2007/07/23 02:46:09 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -379,7 +379,15 @@ USA.
 		(set-xml-attribute-name! attr
 					 (expand-attribute-name
 					  (xml-attribute-name attr))))
-	      attrs)))
+	      attrs)
+    (do ((attrs attrs (cdr attrs)))
+	((not (pair? attrs)) unspecific)
+      (let ((name (xml-attribute-name (car attrs))))
+	(if (there-exists? (cdr attrs)
+	      (lambda (attr)
+		(xml-name=? (xml-attribute-name attr) name)))
+	    (perror p "Attributes with same name"
+		    (xml-name-qname name)))))))
 
 (define (parse-element-content b p name)
   (let ((vc (parse-content b)))
@@ -569,33 +577,27 @@ USA.
 		    (tail (loop (cdr attrs))))
 		(let ((qname (car uname))
 		      (p (cdr uname)))
-		  (let ((get-uri
+		  (let ((forbidden-uri
 			 (lambda ()
-			   (if (string-null? value)
-			       (null-xml-namespace-uri)
-			       (string->uri value))))
-			(forbidden-uri
-			 (lambda (uri)
-			   (perror p "Forbidden namespace URI"
-				   (uri->string uri)))))
+			   (perror p "Forbidden namespace URI" value))))
 		    (let ((guarantee-legal-uri
-			   (lambda (uri)
-			     (if (or (uri=? uri xml-uri)
-				     (uri=? uri xmlns-uri))
-				 (forbidden-uri uri)))))
+			   (lambda ()
+			     (if (or (string=? value xml-uri-string)
+				     (string=? value xmlns-uri-string))
+				 (forbidden-uri)))))
 		      (cond ((xml-name=? qname 'xmlns)
-			     (let ((uri (get-uri)))
-			       (guarantee-legal-uri uri)
-			       (cons (cons (null-xml-name-prefix) uri) tail)))
+			     (string->uri value) ;signals error if not URI
+			     (guarantee-legal-uri)
+			     (cons (cons (null-xml-name-prefix) value) tail))
 			    ((xml-name-prefix=? qname 'xmlns)
 			     (if (xml-name=? qname 'xmlns:xmlns)
 				 (perror p "Illegal namespace prefix" qname))
-			     (let ((uri (get-uri)))
-			       (if (xml-name=? qname 'xmlns:xml)
-				   (if (not (uri=? uri xml-uri))
-				       (forbidden-uri uri))
-				   (guarantee-legal-uri uri))
-			       (cons (cons (xml-name-local qname) uri) tail)))
+			     (string->uri value) ;signals error if not URI
+			     (if (xml-name=? qname 'xmlns:xml)
+				 (if (not (string=? value xml-uri-string))
+				     (forbidden-uri))
+				 (guarantee-legal-uri))
+			     (cons (cons (xml-name-local qname) value) tail))
 			    (else tail))))))
 	      *prefix-bindings*)))
   unspecific)
@@ -608,20 +610,20 @@ USA.
 	(p (cdr uname)))
     (if *in-dtd?*
 	qname
-	(let ((uri (lookup-namespace-prefix qname p attribute-name?)))
-	  (if (null-xml-namespace-uri? uri)
+	(let ((string (lookup-namespace-prefix qname p attribute-name?)))
+	  (if (string-null? string)
 	      qname
-	      (%make-xml-name qname uri))))))
+	      (%make-xml-name qname string))))))
 
 (define (lookup-namespace-prefix qname p attribute-name?)
   (let ((prefix (xml-qname-prefix qname)))
     (cond ((eq? prefix 'xmlns)
-	   xmlns-uri)
+	   xmlns-uri-string)
 	  ((eq? prefix 'xml)
-	   xml-uri)
+	   xml-uri-string)
 	  ((and attribute-name?
 		(null-xml-name-prefix? prefix))
-	   (null-xml-namespace-uri))
+	   "")
 	  (else
 	   (let ((entry (assq prefix *prefix-bindings*)))
 	     (if entry
@@ -629,7 +631,7 @@ USA.
 		 (begin
 		   (if (not (null-xml-name-prefix? prefix))
 		       (perror p "Undeclared XML prefix" prefix))
-		   (null-xml-namespace-uri))))))))
+		   "")))))))
 
 ;;;; Processing instructions
 
diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index da547a525..23c8a91d4 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.57 2007/01/05 21:19:29 cph Exp $
+$Id: xml-struct.scm,v 1.58 2007/07/23 02:46:10 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -452,16 +452,16 @@ USA.
 			    (symbol-append 'xmlns: prefix))
 			elt)))
     (and value
-	 (if (string-null? value)
-	     (null-xml-namespace-uri)
-	     (->absolute-uri value)))))
+	 (begin
+	   (string->uri value)		;signals error if not URI
+	   value))))
 
-(define (xml-element-namespace-prefix elt uri)
+(define (xml-element-namespace-prefix elt uri-string)
   (let ((attr
 	 (find-matching-item (xml-element-attributes elt)
 	   (lambda (attr)
 	     (and (xml-attribute-namespace-decl? attr)
-		  (uri=? (->uri (xml-attribute-value attr)) uri))))))
+		  (string=? (xml-attribute-value attr) uri-string))))))
     (and attr
 	 (let ((name (xml-attribute-name attr)))
 	   (if (xml-name=? name 'xmlns)
diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index bc194f5a0..0f3a09e0c 100644
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.91 2007/01/17 03:43:00 cph Exp $
+$Id: xml.pkg,v 1.92 2007/07/23 02:46:07 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -73,7 +73,9 @@ USA.
 	  xml-qname-string
 	  xml-qname?
 	  xml-uri
-	  xmlns-uri)
+	  xml-uri-string
+	  xmlns-uri
+	  xmlns-uri-string)
   (export (runtime xml)
 	  %make-xml-name
 	  string-composed-of?