New procedure XML-NAME-PREFIX.

diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index df37b02bc045ada458ac718f9e8dc423c490bf98..aaad364ff237a81cb630db78c7a3be81a530bf41 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.21 2003/08/03 06:20:40 cph Exp $
+$Id: xml-struct.scm,v 1.22 2003/08/20 17:23:34 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -106,6 +106,18 @@ USA.
        ((combo-name? name) (universal-name-uri (combo-name-universal name)))
        (else (error:not-xml-name name 'XML-NAME-URI))))
 
+(define (xml-name-prefix name)
+  (let ((simple
+        (lambda (name)
+          (let ((s (symbol-name name)))
+            (let ((c (string-find-next-char s #\:)))
+              (if c
+                  (string->symbol (string-head s c))
+                  #f))))))
+    (cond ((xml-nmtoken? name) (simple name))
+         ((combo-name? name) (simple (combo-name-simple name)))
+         (else (error:not-xml-name name 'XML-NAME-PREFIX)))))
+
 (define (xml-name-local name)
   (cond ((xml-nmtoken? name)
         (let ((s (symbol-name name)))
@@ -114,7 +126,7 @@ USA.
                 (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))))
+       (else (error:not-xml-name name 'XML-NAME-LOCAL))))
 
 (define (xml-name=? n1 n2)
   (let ((lose (lambda (n) (error:not-xml-name n 'XML-NAME=?))))
@@ -136,7 +148,7 @@ USA.
 
 (define make-xml-name-hash-table
   (strong-hash-table/constructor xml-name-hash xml-name=? #t))
-
+\f
 (define (xml-nmtoken? object)
   (and (symbol? object)
        (string-is-xml-nmtoken? (symbol-name object))))
@@ -482,7 +494,7 @@ USA.
       (and (pair? object)
           (eq? 'default (car object))
           (xml-attribute-value? (cdr object)))))
-
+\f
 (define-xml-type !entity
   (name xml-name?)
   (value entity-value? canonicalize-entity-value))
@@ -514,7 +526,7 @@ USA.
 
 (define-xml-type parameter-entity-ref
   (name xml-name?))
-\f
+
 (define-syntax define-xml-printer
   (sc-macro-transformer
    (lambda (form environment)

diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index d9ef4acaae7b8d35a3792b2b54086d51f2560f2e..e80b8d29748d7f4d48abdc1100f179da9aa7c5d0 100644 (file)
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.23 2003/08/01 03:26:09 cph Exp $
+$Id: xml.pkg,v 1.24 2003/08/20 17:23:47 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -151,6 +151,7 @@ USA.
          xml-intern
          xml-name-hash
          xml-name-local
+         xml-name-prefix
          xml-name-string
          xml-name-uri
          xml-name=?