Add support for hash tables based on XML names.

diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index 8402aafd4f598197b856a6327e76b3d42c281e85..e443613d1bf424214bf9a576d34a1fbe78c6830f 100644 (file)
--- 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 7f50c8cff2c43f2107889d093c04f0209a74390f..d9ef4acaae7b8d35a3792b2b54086d51f2560f2e 100644 (file)
--- 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=?