From 16a0136f099766fc0a5e9297b9c4e01daef9d2a4 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 26 Sep 2003 03:56:58 +0000
Subject: [PATCH] Major update to rationalize naming structure.  The
 implementation of names has been moved to its own file.  There are now fully
 fleshed-out XML-QNAME and XML-NMTOKEN abstractions, so that it's possible to
 talk about all those names that aren't affected by namespaces (e.g.
 everything in the DTD).

---
 v7/src/xml/compile.scm    |   7 +-
 v7/src/xml/load.scm       |   6 +-
 v7/src/xml/xml-names.scm  | 317 ++++++++++++++++++++++++++++++++++++++
 v7/src/xml/xml-output.scm |  11 +-
 v7/src/xml/xml-parser.scm |  76 +++++----
 v7/src/xml/xml-struct.scm | 288 +++-------------------------------
 v7/src/xml/xml.pkg        |  86 ++++++-----
 7 files changed, 437 insertions(+), 354 deletions(-)
 create mode 100644 v7/src/xml/xml-names.scm

diff --git a/v7/src/xml/compile.scm b/v7/src/xml/compile.scm
index 16d9fd383..5f08bd7cf 100644
--- a/v7/src/xml/compile.scm
+++ b/v7/src/xml/compile.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: compile.scm,v 1.11 2003/02/14 18:28:38 cph Exp $
+$Id: compile.scm,v 1.12 2003/09/26 03:56:38 cph Exp $
 
-Copyright 2001 Massachusetts Institute of Technology
+Copyright 2001,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -38,7 +38,8 @@ USA.
       (lambda ()
 	(load "parser-macro")
 	(for-each compile-file
-		  '("xml-struct"
+		  '("xml-names"
+		    "xml-struct"
 		    "xml-chars"
 		    "xml-output"
 		    "xml-parser"))))
diff --git a/v7/src/xml/load.scm b/v7/src/xml/load.scm
index 52c86038c..4663d053f 100644
--- a/v7/src/xml/load.scm
+++ b/v7/src/xml/load.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: load.scm,v 1.10 2003/02/14 18:28:38 cph Exp $
+$Id: load.scm,v 1.11 2003/09/26 03:56:41 cph Exp $
 
-Copyright 2001,2002 Massachusetts Institute of Technology
+Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -28,4 +28,4 @@ USA.
 (with-working-directory-pathname (directory-pathname (current-load-pathname))
   (lambda ()
     (package/system-loader "xml" '() 'QUERY)))
-(add-subsystem-identification! "XML" '(0 3))
\ No newline at end of file
+(add-subsystem-identification! "XML" '(0 4))
\ No newline at end of file
diff --git a/v7/src/xml/xml-names.scm b/v7/src/xml/xml-names.scm
new file mode 100644
index 000000000..064cc21b2
--- /dev/null
+++ b/v7/src/xml/xml-names.scm
@@ -0,0 +1,317 @@
+#| -*-Scheme-*-
+
+$Id: xml-names.scm,v 1.1 2003/09/26 03:56:48 cph Exp $
+
+Copyright 2003 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; XML name structures
+
+(declare (usual-integrations))
+
+(define (make-xml-name qname iri)
+  (let ((qname (make-xml-qname qname))
+	(iri (make-xml-namespace-iri iri)))
+    (if (null-xml-namespace-iri? iri)
+	qname
+	(begin
+	  (check-prefix+iri qname iri)
+	  (%make-xml-name qname iri)))))
+
+(define (check-prefix+iri qname iri)
+  (let ((s (symbol-name qname)))
+    (let ((c (string-find-next-char s #\:)))
+      (if (and c
+	       (let ((prefix (string-head->symbol s c)))
+		 (or (and (eq? prefix 'xml)
+			  (not (eq? iri xml-iri)))
+		     (and (eq? prefix 'xmlns)
+			  (not (eq? iri xmlns-iri))))))
+	  (error:bad-range-argument iri 'MAKE-XML-NAME)))))
+
+(define (%make-xml-name qname iri)
+  (let ((uname
+	 (let ((local (xml-qname-local qname)))
+	   (hash-table/intern! (hash-table/intern! expanded-names
+						   iri
+						   make-eq-hash-table)
+			       local
+			       (lambda ()
+				 (make-expanded-name iri
+						     local
+						     (make-eq-hash-table)))))))
+    (hash-table/intern! (expanded-name-combos uname)
+			qname
+			(lambda () (make-combo-name qname uname)))))
+
+(define expanded-names
+  (make-eq-hash-table))
+
+(define (xml-name? object)
+  (or (xml-qname? object)
+      (combo-name? object)))
+
+(define (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-nmtoken object)
+  (if (string? object)
+      (begin
+	(if (not (string-is-xml-nmtoken? object))
+	    (error:bad-range-argument object 'MAKE-XML-NMTOKEN))
+	(string->symbol object))
+      (begin
+	(guarantee-xml-nmtoken object 'MAKE-XML-NMTOKEN)
+	object)))
+
+(define (xml-nmtoken? object)
+  (and (symbol? object)
+       (string-is-xml-nmtoken? (symbol-name object))))
+
+(define (guarantee-xml-nmtoken object caller)
+  (if (not (xml-nmtoken? object))
+      (error:not-xml-nmtoken object caller)))
+
+(define (error:not-xml-nmtoken object caller)
+  (error:wrong-type-argument object "an XML name token" caller))
+
+(define (xml-nmtoken-string nmtoken)
+  (guarantee-xml-nmtoken nmtoken 'XML-NMTOKEN-STRING)
+  (symbol-name nmtoken))
+
+(define (string-is-xml-name? string)
+  (eq? (string-is-xml-nmtoken? string) 'NAME))
+
+(define (string-is-xml-nmtoken? string)
+  (let ((buffer (string->parser-buffer string)))
+    (let ((check-char
+	   (lambda ()
+	     (match-utf8-char-in-alphabet buffer alphabet:name-subsequent))))
+      (letrec
+	  ((no-colon
+	    (lambda ()
+	      (cond ((match-parser-buffer-char buffer #\:)
+		     (colon))
+		    ((peek-parser-buffer-char buffer)
+		     (and (check-char)
+			  (no-colon)))
+		    (else 'NAME))))
+	   (colon
+	    (lambda ()
+	      (cond ((match-parser-buffer-char buffer #\:)
+		     (nmtoken?))
+		    ((peek-parser-buffer-char buffer)
+		     (and (check-char)
+			  (colon)))
+		    (else 'NAME))))
+	   (nmtoken?
+	    (lambda ()
+	      (if (peek-parser-buffer-char buffer)
+		  (and (check-char)
+		       (nmtoken?))
+		  'NMTOKEN))))
+	(if (match-utf8-char-in-alphabet buffer alphabet:name-initial)
+	    (no-colon)
+	    (and (check-char)
+		 (nmtoken?)))))))
+
+(define (string-composed-of? string char-set)
+  (and (string? string)
+       (substring-composed-of? string 0 (string-length string) char-set)))
+
+(define (substring-composed-of? string start end char-set)
+  (let loop ((index start))
+    (or (fix:= index end)
+	(and (char-set-member? char-set (string-ref string index))
+	     (loop (fix:+ index 1))))))
+
+(define (xml-name-string name)
+  (symbol-name (xml-name-qname name)))
+
+(define (xml-name-qname name)
+  (cond ((xml-qname? name) name)
+	((combo-name? name) (combo-name-qname name))
+	(else (error:not-xml-name name 'XML-NAME-QNAME))))
+
+(define (xml-name-qname=? name qname)
+  (eq? (xml-name-qname name) qname))
+
+(define (xml-name-iri name)
+  (cond ((xml-qname? name) (null-xml-namespace-iri))
+	((combo-name? name) (expanded-name-iri (combo-name-expanded name)))
+	(else (error:not-xml-name name 'XML-NAME-IRI))))
+
+(define (xml-name-iri=? name iri)
+  (eq? (xml-name-iri name) iri))
+
+(define (xml-name-prefix name)
+  (xml-qname-prefix
+   (cond ((xml-qname? name) name)
+	 ((combo-name? name) (combo-name-qname name))
+	 (else (error:not-xml-name name 'XML-NAME-PREFIX)))))
+
+(define (null-xml-name-prefix? object)
+  (eq? object '||))
+
+(define (null-xml-name-prefix)
+  '||)
+
+(define (xml-name-prefix=? name prefix)
+  (eq? (xml-name-prefix name) prefix))
+
+(define (xml-name-local name)
+  (cond ((xml-qname? name) (xml-qname-local name))
+	((combo-name? name) (expanded-name-local (combo-name-expanded name)))
+	(else (error:not-xml-name name 'XML-NAME-LOCAL))))
+
+(define (xml-name-local=? name local)
+  (eq? (xml-name-local name) local))
+
+(define (xml-name=? n1 n2)
+  (let ((lose (lambda (n) (error:not-xml-name n 'XML-NAME=?))))
+    (cond ((xml-qname? n1)
+	   (cond ((xml-qname? n2) (eq? n1 n2))
+		 ((combo-name? n2) (eq? n1 (combo-name-qname n2)))
+		 (else (lose n2))))
+	  ((combo-name? n1)
+	   (cond ((xml-qname? n2)
+		  (eq? (combo-name-qname n1) n2))
+		 ((combo-name? n2)
+		  (eq? (combo-name-expanded n1)
+		       (combo-name-expanded n2)))
+		 (else (lose n2))))
+	  (else (lose n1)))))
+
+(define (xml-name-hash name modulus)
+  (eq-hash-mod (xml-name-local name) modulus))
+
+(define make-xml-name-hash-table
+  (strong-hash-table/constructor xml-name-hash xml-name=? #t))
+
+(define (make-xml-qname object)
+  (if (string? object)
+      (begin
+	(if (not (string-is-xml-name? object))
+	    (error:bad-range-argument object 'MAKE-XML-QNAME))
+	(string->symbol object))
+      (begin
+	(guarantee-xml-qname object 'MAKE-XML-QNAME)
+	object)))
+
+(define (xml-qname? object)
+  (and (interned-symbol? object)
+       (string-is-xml-name? (symbol-name object))))
+
+(define (guarantee-xml-qname object caller)
+  (if (not (xml-qname? object))
+      (error:not-xml-qname object caller)))
+
+(define (error:not-xml-qname object caller)
+  (error:wrong-type-argument object "an XML QName" caller))
+
+(define (xml-qname-string qname)
+  (guarantee-xml-qname qname 'XML-QNAME-STRING)
+  (symbol-name qname))
+
+(define (xml-qname-local qname)
+  (let ((s (symbol-name qname)))
+    (let ((c (string-find-next-char s #\:)))
+      (if c
+	  (string-tail->symbol s (fix:+ c 1))
+	  qname))))
+
+(define (xml-qname-prefix qname)
+  (let ((s (symbol-name qname)))
+    (let ((c (string-find-next-char s #\:)))
+      (if c
+	  (string-head->symbol s c)
+	  (null-xml-name-prefix)))))
+
+(define-record-type <combo-name>
+    (make-combo-name qname expanded)
+    combo-name?
+  (qname combo-name-qname)
+  (expanded combo-name-expanded))
+
+(set-record-type-unparser-method! <combo-name>
+  (standard-unparser-method 'XML-NAME
+    (lambda (name port)
+      (write-char #\space port)
+      (write (combo-name-qname name) port))))
+
+(define-record-type <expanded-name>
+    (make-expanded-name iri local combos)
+    expanded-name?
+  (iri expanded-name-iri)
+  (local expanded-name-local)
+  (combos expanded-name-combos))
+
+;;;; Namespace IRI
+
+(define (make-xml-namespace-iri object)
+  (if (string? object)
+      (begin
+	(if (not (string-is-namespace-iri? object))
+	    (error:bad-range-argument object 'MAKE-XML-NAMESPACE-IRI))
+	(hash-table/intern! namespace-iris object
+	  (lambda ()
+	    (%make-xml-namespace-iri object))))
+      (begin
+	(guarantee-xml-namespace-iri object 'MAKE-XML-NAMESPACE-IRI)
+	object)))
+
+(define (string-is-namespace-iri? object)
+  ;; See RFC 1630 for correct syntax.
+  (utf8-string-valid? object))
+
+(define namespace-iris
+  (make-string-hash-table))
+
+(define-record-type <xml-namespace-iri>
+    (%make-xml-namespace-iri string)
+    xml-namespace-iri?
+  (string xml-namespace-iri-string))
+
+(define (guarantee-xml-namespace-iri object caller)
+  (if (not (xml-namespace-iri? object))
+      (error:not-xml-namespace-iri object caller)))
+
+(define (null-xml-namespace-iri? object)
+  (eq? object null-namespace-iri))
+
+(define (null-xml-namespace-iri)
+  null-namespace-iri)
+
+(define null-namespace-iri
+  (make-xml-namespace-iri ""))
+
+(define (error:not-xml-namespace-iri object caller)
+  (error:wrong-type-argument object "an XML namespace IRI" caller))
+
+(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/"))
\ No newline at end of file
diff --git a/v7/src/xml/xml-output.scm b/v7/src/xml/xml-output.scm
index 5cbc7a587..979c4b35a 100644
--- a/v7/src/xml/xml-output.scm
+++ b/v7/src/xml/xml-output.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml-output.scm,v 1.25 2003/09/25 16:51:15 cph Exp $
+$Id: xml-output.scm,v 1.26 2003/09/26 03:56:51 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -249,10 +249,10 @@ USA.
 		    (emit-string "(" ctx)
 		    (if (pair? (cdr type))
 			(begin
-			  (write-xml-name (cadr type) ctx)
-			  (for-each (lambda (name)
+			  (write-xml-nmtoken (cadr type) ctx)
+			  (for-each (lambda (nmtoken)
 				      (emit-string "|" ctx)
-				      (write-xml-name name ctx))
+				      (write-xml-nmtoken nmtoken ctx))
 				    (cddr type))))
 		    (emit-string ")" ctx))
 		   (else
@@ -417,6 +417,9 @@ USA.
 (define (xml-name-columns name)
   (utf8-string-length (xml-name-string name)))
 
+(define (write-xml-nmtoken nmtoken ctx)
+  (emit-string (xml-nmtoken-string nmtoken) ctx))
+
 (define (write-entity-value value col ctx)
   (if (xml-external-id? value)
       (write-xml-external-id value col ctx)
diff --git a/v7/src/xml/xml-parser.scm b/v7/src/xml/xml-parser.scm
index 9377c6402..ed08bfbb3 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.45 2003/09/26 01:00:11 cph Exp $
+$Id: xml-parser.scm,v 1.46 2003/09/26 03:56:54 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -436,7 +436,7 @@ USA.
 
 (define (simple-name-parser type)
   (let ((m (string-append "Malformed " type " name")))
-    (*parser (require-success m (map xml-intern (match match-name))))))
+    (*parser (require-success m (map make-xml-qname (match match-name))))))
 
 (define parse-entity-name (simple-name-parser "entity"))
 (define parse-pi-name (simple-name-parser "processing-instructions"))
@@ -452,7 +452,7 @@ USA.
 (define parse-required-name-token	;[7]
   (*parser
    (require-success "Malformed XML name token"
-     (map xml-intern (match match-name-token)))))
+     (map make-xml-nmtoken (match match-name-token)))))
 
 (define (match-name-token buffer)
   (and (match-utf8-char-in-alphabet buffer alphabet:name-subsequent)
@@ -504,40 +504,36 @@ USA.
 	      *prefix-bindings*)))
   unspecific)
 
-(define (intern-element-name n) (intern-name n #t))
-(define (intern-attribute-name n) (intern-name n #f))
+(define (intern-element-name n) (intern-name n #f))
+(define (intern-attribute-name n) (intern-name n #t))
 
-(define (intern-name n element-name?)
-  (let ((s (car n))
+(define (intern-name n attribute-name?)
+  (let ((qname (string->symbol (car n)))
 	(p (cdr n)))
-    (let ((qname (string->symbol s))
-	  (c (string-find-next-char s #\:)))
-      (let ((iri
-	     (if (and (not *in-dtd?*)
-		      (or element-name? c))
-		 (let ((prefix
-			(if c
-			    (string-head->symbol s c)
-			    (null-xml-name-prefix))))
-		   (case prefix
-		     ((xmlns) xmlns-iri)
-		     ((xml) xml-iri)
-		     (else
-		      (let ((entry (assq prefix *prefix-bindings*)))
-			(if entry
-			    (cdr entry)
-			    (begin
-			      (if (not (null-xml-name-prefix? prefix))
-				  (perror p "Unknown XML prefix" prefix))
-			      (null-xml-namespace-iri)))))))
-		 (null-xml-namespace-iri? iri))))
-	(if (null-xml-namespace-iri? iri)
-	    qname
-	    (%make-xml-name qname
-			    iri
-			    (if c
-				(string-tail->symbol s (fix:+ c 1))
-				qname)))))))
+    (if *in-dtd?*
+	qname
+	(let ((iri (lookup-namespace-prefix qname p attribute-name?)))
+	  (if (null-xml-namespace-iri? iri)
+	      qname
+	      (%make-xml-name qname iri))))))
+
+(define (lookup-namespace-prefix qname p attribute-name?)
+  (let ((prefix (xml-qname-prefix qname)))
+    (cond ((eq? prefix 'xmlns)
+	   xmlns-iri)
+	  ((eq? prefix 'xml)
+	   xml-iri)
+	  ((and attribute-name?
+		(null-xml-name-prefix? prefix))
+	   (null-xml-namespace-iri))
+	  (else
+	   (let ((entry (assq prefix *prefix-bindings*)))
+	     (if entry
+		 (cdr entry)
+		 (begin
+		   (if (not (null-xml-name-prefix? prefix))
+		       (perror p "Undeclared XML prefix" prefix))
+		   (null-xml-namespace-iri))))))))
 
 ;;;; Processing instructions
 
@@ -695,7 +691,7 @@ USA.
 	  parse-attribute-value))))
 
 (define parse-declaration-attributes
-  (attribute-list-parser (*parser (map xml-intern (match match-name)))))
+  (attribute-list-parser (*parser (map make-xml-qname (match match-name)))))
 
 (define parse-attribute-list
   (attribute-list-parser parse-uninterned-name))
@@ -1069,8 +1065,8 @@ USA.
 	 parse-required-element-name
 	 S
 	 ;;[46]
-	 (alt (map xml-intern (match "EMPTY"))
-	      (map xml-intern (match "ANY"))
+	 (alt (map make-xml-qname (match "EMPTY"))
+	      (map make-xml-qname (match "ANY"))
 	      ;;[51]
 	      (encapsulate vector->list
 		(with-pointer p
@@ -1124,14 +1120,14 @@ USA.
 
 (define parse-!attlist-type		;[54,57]
   (*parser
-   (alt (map xml-intern
+   (alt (map make-xml-qname
 	     ;;[55,56]
 	     (match (alt "CDATA" "IDREFS" "IDREF" "ID"
 			 "ENTITY" "ENTITIES" "NMTOKENS" "NMTOKEN")))
 	;;[58]
 	(encapsulate vector->list
 	  (bracket "notation type"
-	      (seq (map xml-intern (match "NOTATION"))
+	      (seq (map make-xml-qname (match "NOTATION"))
 		   S
 		   "(")
 	      ")"
diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index 0d50f334b..ea860bf99 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.34 2003/09/26 01:00:14 cph Exp $
+$Id: xml-struct.scm,v 1.35 2003/09/26 03:56:58 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -27,259 +27,6 @@ USA.
 
 (declare (usual-integrations))
 
-(define-record-type <combo-name>
-    (make-combo-name qname expanded)
-    combo-name?
-  (qname combo-name-qname)
-  (expanded combo-name-expanded))
-
-(set-record-type-unparser-method! <combo-name>
-  (standard-unparser-method 'XML-NAME
-    (lambda (name port)
-      (write-char #\space port)
-      (write (combo-name-qname name) port))))
-
-(define-record-type <expanded-name>
-    (make-expanded-name iri local combos)
-    expanded-name?
-  (iri expanded-name-iri)
-  (local expanded-name-local)
-  (combos expanded-name-combos))
-
-(define (xml-name? object)
-  (or (and (interned-symbol? object)
-	   (string-is-xml-name? (symbol-name object)))
-      (combo-name? object)))
-
-(define (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-iri iri)
-  (if (string? iri)
-      (begin
-	(if (not (namespace-iri-string? iri))
-	    (error:not-xml-namespace-iri iri 'MAKE-XML-NAMESPACE-IRI))
-	(string->symbol iri))
-      (begin
-	(guarantee-xml-namespace-iri iri 'MAKE-XML-NAMESPACE-IRI)
-	iri)))
-
-(define (xml-namespace-iri? object)
-  (and (interned-symbol? object)
-       (namespace-iri-string? (symbol-name object))))
-
-(define (namespace-iri-string? object)
-  ;; See RFC 1630 for correct syntax.
-  (utf8-string-valid? object))
-
-(define (null-xml-namespace-iri? object)
-  (eq? object '||))
-
-(define (null-xml-namespace-iri)
-  '||)
-
-(define (guarantee-xml-namespace-iri object caller)
-  (if (not (xml-namespace-iri? object))
-      (error:not-xml-namespace-iri object caller)))
-
-(define (error:not-xml-namespace-iri object caller)
-  (error:wrong-type-argument object "an XML namespace IRI" caller))
-
-(define (xml-namespace-iri->string iri)
-  (guarantee-xml-namespace-iri iri 'XML-NAMESPACE-IRI->STRING)
-  (symbol->string iri))
-
-(define (xml-intern qname #!optional iri)
-  (make-xml-name qname
-		 (if (default-object? iri)
-		     (null-xml-namespace-iri)
-		     iri)))
-
-(define (make-xml-name qname iri)
-  (let ((bad-name
-	 (lambda ()
-	   (error:wrong-type-argument qname "an XML name" 'MAKE-XML-NAME)))
-	(bad-iri
-	 (lambda ()
-	   (error:wrong-type-argument iri "IRI" 'MAKE-XML-NAME))))
-    (receive (string symbol)
-	(cond ((symbol? qname) (values (symbol-name qname) qname))
-	      ((string? qname) (values qname (string->symbol qname)))
-	      (else (bad-name)))
-      (let ((type (string-is-xml-nmtoken? string)))
-	(cond ((and type (null-xml-namespace-iri? iri))
-	       symbol)
-	      ((eq? type 'NAME)
-	       (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 qname iri local)
-  (let ((uname
-	 (hash-table/intern! (hash-table/intern! expanded-names
-						 iri
-						 make-eq-hash-table)
-			     local
-			     (lambda ()
-			       (make-expanded-name iri
-						   local
-						   (make-eq-hash-table))))))
-    (hash-table/intern! (expanded-name-combos uname)
-			qname
-			(lambda () (make-combo-name qname uname)))))
-
-(define expanded-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-qname name)
-  (cond ((xml-nmtoken? name) name)
-	((combo-name? name) (combo-name-qname name))
-	(else (error:not-xml-name name 'XML-NAME-QNAME))))
-
-(define (xml-name-qname=? name qname)
-  (eq? (xml-name-qname name) qname))
-
-(define (xml-name-string name)
-  (symbol-name (xml-name-qname name)))
-
-(define (xml-name-iri name)
-  (cond ((xml-nmtoken? name) (null-xml-namespace-iri))
-	((combo-name? name) (expanded-name-iri (combo-name-expanded name)))
-	(else (error:not-xml-name name 'XML-NAME-IRI))))
-
-(define (xml-name-iri=? name iri)
-  (eq? (xml-name-iri name) iri))
-
-(define (xml-name-prefix name)
-  (let ((s
-	 (symbol-name
-	  (cond ((xml-nmtoken? name) name)
-		((combo-name? name) (combo-name-qname name))
-		(else (error:not-xml-name name 'XML-NAME-PREFIX))))))
-    (let ((c (string-find-next-char s #\:)))
-      (if c
-	  (string-head->symbol s c)
-	  (null-xml-name-prefix)))))
-
-(define (null-xml-name-prefix? object)
-  (eq? object '||))
-
-(define (null-xml-name-prefix)
-  '||)
-
-(define (xml-name-prefix=? name prefix)
-  (eq? (xml-name-prefix name) prefix))
-
-(define (xml-name-local name)
-  (cond ((xml-nmtoken? name)
-	 (let ((s (symbol-name name)))
-	   (let ((c (string-find-next-char s #\:)))
-	     (if c
-		 (string-tail->symbol s (fix:+ c 1))
-		 name))))
-	((combo-name? name) (expanded-name-local (combo-name-expanded name)))
-	(else (error:not-xml-name name 'XML-NAME-LOCAL))))
-
-(define (xml-name-local=? name local)
-  (eq? (xml-name-local name) local))
-
-(define (xml-name=? n1 n2)
-  (let ((lose (lambda (n) (error:not-xml-name n 'XML-NAME=?))))
-    (cond ((xml-nmtoken? n1)
-	   (cond ((xml-nmtoken? n2) (eq? n1 n2))
-		 ((combo-name? n2) (eq? n1 (combo-name-qname n2)))
-		 (else (lose n2))))
-	  ((combo-name? n1)
-	   (cond ((xml-nmtoken? n2)
-		  (eq? (combo-name-qname n1) n2))
-		 ((combo-name? n2)
-		  (eq? (combo-name-expanded n1)
-		       (combo-name-expanded n2)))
-		 (else (lose n2))))
-	  (else (lose n1)))))
-
-(define (xml-name-hash name modulus)
-  (eq-hash-mod (xml-name-local name) modulus))
-
-(define make-xml-name-hash-table
-  (strong-hash-table/constructor xml-name-hash xml-name=? #t))
-
-(define (xml-nmtoken? object)
-  (and (symbol? object)
-       (string-is-xml-nmtoken? (symbol-name object))))
-
-(define (string-is-xml-name? string)
-  (eq? (string-is-xml-nmtoken? string) 'NAME))
-
-(define (string-is-xml-nmtoken? string)
-  (let ((buffer (string->parser-buffer string)))
-    (let ((check-char
-	   (lambda ()
-	     (match-utf8-char-in-alphabet buffer alphabet:name-subsequent))))
-      (letrec
-	  ((no-colon
-	    (lambda ()
-	      (cond ((match-parser-buffer-char buffer #\:)
-		     (colon))
-		    ((peek-parser-buffer-char buffer)
-		     (and (check-char)
-			  (no-colon)))
-		    (else 'NAME))))
-	   (colon
-	    (lambda ()
-	      (cond ((match-parser-buffer-char buffer #\:)
-		     (nmtoken?))
-		    ((peek-parser-buffer-char buffer)
-		     (and (check-char)
-			  (colon)))
-		    (else 'NAME))))
-	   (nmtoken?
-	    (lambda ()
-	      (if (peek-parser-buffer-char buffer)
-		  (and (check-char)
-		       (nmtoken?))
-		  'NMTOKEN))))
-	(if (match-utf8-char-in-alphabet buffer alphabet:name-initial)
-	    (no-colon)
-	    (and (check-char)
-		 (nmtoken?)))))))
-
-(define (xml-whitespace-string? object)
-  (string-composed-of? object char-set:xml-whitespace))
-
-(define (string-composed-of? string char-set)
-  (and (string? string)
-       (substring-composed-of? string 0 (string-length string) char-set)))
-
-(define (substring-composed-of? string start end char-set)
-  (let loop ((index start))
-    (or (fix:= index end)
-	(and (char-set-member? char-set (string-ref string index))
-	     (loop (fix:+ index 1))))))
-
 (define-syntax define-xml-type
   (sc-macro-transformer
    (lambda (form environment)
@@ -360,6 +107,9 @@ USA.
 	  (xml-whitespace-string? object)
 	  (xml-processing-instructions? object)))))
 
+(define (xml-whitespace-string? object)
+  (string-composed-of? object char-set:xml-whitespace))
+
 (define-xml-type declaration
   (version xml-version?)
   (encoding xml-encoding?)
@@ -431,7 +181,7 @@ USA.
 (define-xml-type processing-instructions
   (name
    (lambda (object)
-     (and (xml-name? object)
+     (and (xml-qname? object)
 	  (not (string-ci=? "xml" (symbol-name object))))))
   (text xml-char-data? canonicalize-char-data))
 
@@ -520,14 +270,14 @@ USA.
 		  (string->char-set " \r\n-'()+,./:=?;!*#@$_%")))
 
 (define-xml-type !element
-  (name xml-name?)
+  (name xml-qname?)
   (content-type
    (lambda (object)
      (or (eq? object '|EMPTY|)
 	 (eq? object '|ANY|)
 	 (and (pair? object)
 	      (eq? '|#PCDATA| (car object))
-	      (list-of-type? (cdr object) xml-name?))
+	      (list-of-type? (cdr object) xml-qname?))
 	 (letrec
 	     ((children?
 	       (lambda (object)
@@ -539,7 +289,7 @@ USA.
 			  (list-of-type? (cdr object) cp?))))))
 	      (cp?
 	       (lambda (object)
-		 (or (maybe-wrapped object xml-name?)
+		 (or (maybe-wrapped object xml-qname?)
 		     (children? object))))
 	      (maybe-wrapped
 	       (lambda (object pred)
@@ -554,13 +304,13 @@ USA.
 	   (children? object))))))
 
 (define-xml-type !attlist
-  (name xml-name?)
+  (name xml-qname?)
   (definitions
     (lambda (object)
       (list-of-type? object
 	(lambda (item)
 	  (and (pair? item)
-	       (xml-name? (car item))
+	       (xml-qname? (car item))
 	       (pair? (cdr item))
 	       (!attlist-type? (cadr item))
 	       (pair? (cddr item))
@@ -587,7 +337,7 @@ USA.
       (eq? object '|NMTOKEN|)
       (and (pair? object)
 	   (eq? '|NOTATION| (car object))
-	   (list-of-type? (cdr object) xml-name?))
+	   (list-of-type? (cdr object) xml-qname?))
       (and (pair? object)
 	   (eq? 'enumerated (car object))
 	   (list-of-type? (cdr object) xml-nmtoken?))))
@@ -603,16 +353,16 @@ USA.
 	   (xml-attribute-value? (cdr object)))))
 
 (define-xml-type !entity
-  (name xml-name?)
+  (name xml-qname?)
   (value entity-value? canonicalize-entity-value))
 
 (define-xml-type unparsed-!entity
-  (name xml-name?)
+  (name xml-qname?)
   (id xml-external-id?)
-  (notation xml-name?))
+  (notation xml-qname?))
 
 (define-xml-type parameter-!entity
-  (name xml-name?)
+  (name xml-qname?)
   (value entity-value? canonicalize-entity-value))
 
 (define (entity-value? object)
@@ -625,14 +375,14 @@ USA.
       (xml-external-id? object)))
 
 (define-xml-type !notation
-  (name xml-name?)
+  (name xml-qname?)
   (id xml-external-id?))
 
 (define-xml-type entity-ref
-  (name xml-name?))
+  (name xml-qname?))
 
 (define-xml-type parameter-entity-ref
-  (name xml-name?))
+  (name xml-qname?))
 
 (define-syntax define-xml-printer
   (sc-macro-transformer
@@ -707,7 +457,7 @@ USA.
 	 (make-xml-namespace-iri (guarantee-xml-attribute-value attr)))))
 
 (define (xml-element-namespace-prefix elt iri)
-  (let ((iri (xml-namespace-iri->string iri)))
+  (let ((iri (xml-namespace-iri-string iri)))
     (let ((attr
 	   (find-matching-item (xml-element-attributes elt)
 	     (lambda (attr)
diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index 414ec0f2e..088f3fb4d 100644
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.32 2003/09/26 01:00:07 cph Exp $
+$Id: xml.pkg,v 1.33 2003/09/26 03:56:45 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -32,6 +32,55 @@ USA.
 (define-package (runtime xml)
   (parent (runtime)))
 
+(define-package (runtime xml names)
+  (files "xml-names")
+  (parent (runtime xml))
+  (export ()
+	  <xml-namespace-iri>
+	  error:not-xml-name
+	  error:not-xml-namespace-iri
+	  error:not-xml-nmtoken
+	  error:not-xml-qname
+	  guarantee-xml-name
+	  guarantee-xml-namespace-iri
+	  guarantee-xml-nmtoken
+	  guarantee-xml-qname
+	  make-xml-name
+	  make-xml-name-hash-table
+	  make-xml-namespace-iri
+	  make-xml-nmtoken
+	  make-xml-qname
+	  null-xml-name-prefix
+	  null-xml-name-prefix?
+	  null-xml-namespace-iri
+	  null-xml-namespace-iri?
+	  xml-iri
+	  xml-name-hash
+	  xml-name-iri
+	  xml-name-iri=?
+	  xml-name-local
+	  xml-name-local=?
+	  xml-name-prefix
+	  xml-name-prefix=?
+	  xml-name-qname
+	  xml-name-qname=?
+	  xml-name-string
+	  xml-name=?
+	  xml-name?
+	  xml-namespace-iri-string
+	  xml-namespace-iri?
+	  xml-nmtoken-string
+	  xml-nmtoken?
+	  xml-qname-local
+	  xml-qname-prefix
+	  xml-qname-string
+	  xml-qname?
+	  xmlns-iri)
+  (export (runtime xml)
+	  %make-xml-name
+	  string-composed-of?
+	  substring-composed-of?))
+
 (define-package (runtime xml structure)
   (files "xml-struct")
   (parent (runtime xml))
@@ -63,8 +112,6 @@ USA.
 	  error:not-xml-element
 	  error:not-xml-entity-ref
 	  error:not-xml-external-id
-	  error:not-xml-name
-	  error:not-xml-namespace-iri
 	  error:not-xml-parameter-!entity
 	  error:not-xml-parameter-entity-ref
 	  error:not-xml-processing-instructions
@@ -81,8 +128,6 @@ USA.
 	  guarantee-xml-element
 	  guarantee-xml-entity-ref
 	  guarantee-xml-external-id
-	  guarantee-xml-name
-	  guarantee-xml-namespace-iri
 	  guarantee-xml-parameter-!entity
 	  guarantee-xml-parameter-entity-ref
 	  guarantee-xml-processing-instructions
@@ -98,17 +143,10 @@ USA.
 	  make-xml-element
 	  make-xml-entity-ref
 	  make-xml-external-id
-	  make-xml-name
-	  make-xml-name-hash-table
-	  make-xml-namespace-iri
 	  make-xml-parameter-!entity
 	  make-xml-parameter-entity-ref
 	  make-xml-processing-instructions
 	  make-xml-unparsed-!entity
-	  null-xml-name-prefix
-	  null-xml-name-prefix?
-	  null-xml-namespace-iri
-	  null-xml-namespace-iri?
 	  set-xml-!attlist-definitions!
 	  set-xml-!attlist-name!
 	  set-xml-!element-content-type!
@@ -136,7 +174,6 @@ USA.
 	  set-xml-entity-ref-name!
 	  set-xml-external-id-id!
 	  set-xml-external-id-iri!
-	  (set-xml-external-id-uri! set-xml-external-id-iri!)
 	  set-xml-parameter-!entity-name!
 	  set-xml-parameter-!entity-value!
 	  set-xml-parameter-entity-ref-name!
@@ -192,25 +229,7 @@ USA.
 	  xml-entity-ref?
 	  xml-external-id-id
 	  xml-external-id-iri
-	  (xml-external-id-uri xml-external-id-iri)
 	  xml-external-id?
-	  xml-intern
-	  xml-iri
-	  xml-name-hash
-	  xml-name-local
-	  xml-name-local=?
-	  xml-name-prefix
-	  xml-name-prefix=?
-	  xml-name-qname
-	  xml-name-qname=?
-	  xml-name-string
-	  xml-name-iri
-	  xml-name-iri=?
-	  xml-name=?
-	  xml-name?
-	  xml-namespace-iri->string
-	  xml-namespace-iri?
-	  xml-nmtoken?
 	  xml-parameter-!entity-name
 	  xml-parameter-!entity-value
 	  xml-parameter-!entity?
@@ -223,10 +242,7 @@ USA.
 	  xml-unparsed-!entity-name
 	  xml-unparsed-!entity-notation
 	  xml-unparsed-!entity?
-	  xml-whitespace-string?
-	  xmlns-iri)
-  (export (runtime xml parser)
-	  %make-xml-name))
+	  xml-whitespace-string?))
 
 (define-package (runtime xml parser)
   (files "xml-chars" "xml-parser")
-- 
2.25.1