From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 20 Aug 2003 17:23:47 +0000 (+0000)
Subject: New procedure XML-NAME-PREFIX.
X-Git-Tag: 20090517-FFI~1822
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=05aedfbe056765ab5ffd25763db30d88b2cc56eb;p=mit-scheme.git

New procedure XML-NAME-PREFIX.
---

diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index df37b02bc..aaad364ff 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.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))
-
+
 (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)))))
-
+
 (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?))
-
+
 (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 d9ef4acaa..e80b8d297 100644
--- 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=?