From 58aaebf90fe06daef0c3a4c425d0912c34d553b1 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 1 Aug 2003 03:26:09 +0000
Subject: [PATCH] Add support for hash tables based on XML names.

---
 v7/src/xml/xml-struct.scm | 18 +++++++++++++++++-
 v7/src/xml/xml.pkg        |  5 ++++-
 2 files changed, 21 insertions(+), 2 deletions(-)

diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index 8402aafd4..e443613d1 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.18 2003/07/30 19:44:05 cph Exp $
+$Id: xml-struct.scm,v 1.19 2003/08/01 03:25:51 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -112,6 +112,16 @@ USA.
 	((combo-name? name) (universal-name-uri (combo-name-universal name)))
 	(else (error:not-xml-name name 'XML-NAME-URI))))
 
+(define (xml-name-local name)
+  (cond ((xml-nmtoken? name)
+	 (let ((s (symbol-name name)))
+	   (let ((c (string-find-next-char s #\:)))
+	     (if c
+		 (string->symbol (string-tail s (fix:+ c 1)))
+		 name))))
+	((combo-name? name) (universal-name-local (combo-name-universal name)))
+	(else (error:not-xml-name name 'XML-NAME-STRING))))
+
 (define (xml-name=? n1 n2)
   (let ((lose (lambda (n) (error:not-xml-name n 'XML-NAME=?))))
     (cond ((xml-nmtoken? n1)
@@ -127,6 +137,12 @@ USA.
 		 (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))))
diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index 7f50c8cff..d9ef4acaa 100644
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.22 2003/07/30 19:43:52 cph Exp $
+$Id: xml.pkg,v 1.23 2003/08/01 03:26:09 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -63,6 +63,7 @@ USA.
 	  make-xml-element
 	  make-xml-entity-ref
 	  make-xml-external-id
+	  make-xml-name-hash-table
 	  make-xml-parameter-!entity
 	  make-xml-parameter-entity-ref
 	  make-xml-processing-instructions
@@ -148,6 +149,8 @@ USA.
 	  xml-external-id-uri
 	  xml-external-id?
 	  xml-intern
+	  xml-name-hash
+	  xml-name-local
 	  xml-name-string
 	  xml-name-uri
 	  xml-name=?
-- 
2.25.1