From afa2e6ba70105eb14de0042e1c61876a0c5bf0b9 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 26 Sep 2003 00:35:52 +0000
Subject: [PATCH] Export XML-IRI and XMLNS-IRI.  Change MAKE-XML-NAME to signal
 an error if the xml: or xmlns: prefixes are used with the wrong IRI.

---
 v7/src/xml/xml-parser.scm |  5 +----
 v7/src/xml/xml-struct.scm | 40 ++++++++++++++++++++++++++++-----------
 v7/src/xml/xml.pkg        |  6 ++++--
 3 files changed, 34 insertions(+), 17 deletions(-)

diff --git a/v7/src/xml/xml-parser.scm b/v7/src/xml/xml-parser.scm
index b39deaafe..e5a13f199 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.43 2003/09/25 16:51:18 cph Exp $
+$Id: xml-parser.scm,v 1.44 2003/09/26 00:35:49 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -537,9 +537,6 @@ USA.
 				(string-tail->symbol s (fix:+ c 1))
 				simple))
 	    simple)))))
-
-(define xml-iri "http://www.w3.org/XML/1998/namespace")
-(define xmlns-iri "http://www.w3.org/2000/xmlns/")
 
 ;;;; Processing instructions
 
diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index fb38b80eb..1d6d52f66 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.32 2003/09/25 16:51:20 cph Exp $
+$Id: xml-struct.scm,v 1.33 2003/09/26 00:35:52 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -100,24 +100,36 @@ USA.
 		     iri)))
 
 (define (make-xml-name simple iri)
-  (let ((lose
+  (let ((bad-name
 	 (lambda ()
-	   (error:wrong-type-argument simple "an XML name" 'MAKE-XML-NAME))))
+	   (error:wrong-type-argument simple "an XML name" 'MAKE-XML-NAME)))
+	(bad-iri
+	 (lambda ()
+	   (error:wrong-type-argument iri "IRI" 'MAKE-XML-NAME))))
     (receive (string symbol)
 	(cond ((symbol? simple) (values (symbol-name simple) simple))
 	      ((string? simple) (values simple (string->symbol simple)))
-	      (else (lose)))
+	      (else (bad-name)))
       (let ((type (string-is-xml-nmtoken? string)))
 	(cond ((and type (default-xml-namespace-iri? iri))
 	       symbol)
 	      ((eq? type 'NAME)
-	       (%make-xml-name symbol
-			       (make-xml-namespace-iri iri)
-			       (let ((c (string-find-next-char string #\:)))
-				 (if c
-				     (string-tail->symbol string (fix:+ c 1))
-				     symbol))))
-	      (else (lose)))))))
+	       (let ((iri (make-xml-namespace-iri iri)))
+		 (%make-xml-name
+		  symbol
+		  iri
+		  (let ((c (string-find-next-char string #\:)))
+		    (if c
+			(let ((prefix (string-head->symbol string c))
+			      (local (string-tail->symbol string (fix:+ c 1))))
+			  (if (or (and (eq? prefix 'xml)
+				       (not (eq? iri xml-iri)))
+				  (and (eq? prefix 'xmlns)
+				       (not (eq? iri xmlns-iri))))
+			      (bad-iri))
+			  local)
+			symbol)))))
+	      (else (bad-name)))))))
 
 (define (%make-xml-name simple iri local)
   (let ((uname
@@ -135,6 +147,12 @@ USA.
 
 (define universal-names
   (make-eq-hash-table))
+
+(define xml-iri
+  (make-xml-namespace-iri "http://www.w3.org/XML/1998/namespace"))
+
+(define xmlns-iri
+  (make-xml-namespace-iri "http://www.w3.org/2000/xmlns/"))
 
 (define (xml-name-simple name)
   (cond ((xml-nmtoken? name) name)
diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index b7f7e2103..eb909bb64 100644
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.30 2003/09/25 16:51:12 cph Exp $
+$Id: xml.pkg,v 1.31 2003/09/26 00:35:45 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -195,6 +195,7 @@ USA.
 	  (xml-external-id-uri xml-external-id-iri)
 	  xml-external-id?
 	  xml-intern
+	  xml-iri
 	  xml-name-hash
 	  xml-name-local
 	  xml-name-local=?
@@ -222,7 +223,8 @@ USA.
 	  xml-unparsed-!entity-name
 	  xml-unparsed-!entity-notation
 	  xml-unparsed-!entity?
-	  xml-whitespace-string?)
+	  xml-whitespace-string?
+	  xmlns-iri)
   (export (runtime xml parser)
 	  %make-xml-name))
 
-- 
2.25.1