From 020a03f66e50356fa58cf04425d5587b39344a00 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 24 Sep 2008 00:40:36 +0000
Subject: [PATCH] Implement XML-ELEMENT-CHILD and XML-ELEMENT-CHILDREN.

---
 v7/src/xml/xml-struct.scm | 58 +++++++++++++++++++++++++--------------
 v7/src/xml/xml.pkg        |  6 +++-
 2 files changed, 42 insertions(+), 22 deletions(-)

diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index 5a6221f7e..c69565eb6 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.62 2008/09/24 00:26:39 cph Exp $
+$Id: xml-struct.scm,v 1.63 2008/09/24 00:40:36 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -200,6 +200,8 @@ USA.
 		  (loop (cdr attrs)))
 	     #t))))
 
+(define-guarantee xml-attribute-list "XML attribute list")
+
 (define (xml-content? object)
   (list-of-type? object xml-content-item?))
 
@@ -241,6 +243,40 @@ USA.
 		       (xml-processing-instructions? item)))
 	      (error:wrong-type-datum content "an XML content")))))
     (search content)))
+
+(define (xml-element-child name elt)
+  (let ((name (xml-name-arg name 'XML-ELEMENT-CHILD)))
+    (find (lambda (item)
+	    (and (xml-element? item)
+		 (xml-name=? (xml-element-name item) name)))
+	  (xml-element-content elt))))
+
+(define (xml-element-children name elt)
+  (let ((name (xml-name-arg name 'XML-ELEMENT-CHILDREN)))
+    (filter (lambda (item)
+	      (and (xml-element? item)
+		   (xml-name=? (xml-element-name item) name)))
+	    (xml-element-content elt))))
+
+(define (find-xml-attr name elt)
+  (let ((attr
+	 (find (let ((name (xml-name-arg name 'FIND-XML-ATTR)))
+		 (lambda (attr)
+		   (xml-name=? (xml-attribute-name attr) name)))
+	       (if (xml-element? elt)
+		   (xml-element-attributes elt)
+		   (begin
+		     (guarantee-xml-attribute-list elt 'FIND-XML-ATTR)
+		     elt)))))
+    (and attr
+	 (xml-attribute-value attr))))
+
+(define (xml-name-arg arg caller)
+  (if (string? arg)
+      (make-xml-name arg)
+      (begin
+	(guarantee-xml-name arg caller)
+	arg)))
 
 (define-xml-type comment
   (text canonicalize canonicalize-char-data))
@@ -551,26 +587,6 @@ USA.
 		    (else
 		     (error "Unknown item passed to xml-attrs:" item))))
 	    '())))))
-
-(define (find-xml-attr name elt)
-  (let ((name
-	 (if (string? name)
-	     (make-xml-name name)
-	     (begin
-	       (guarantee-xml-name name 'FIND-XML-ATTR)
-	       name))))
-    (let loop
-	((attrs
-	  (if (xml-element? elt)
-	      (xml-element-attributes elt)
-	      (begin
-		(guarantee-list-of-type elt xml-attribute? "XML attributes"
-					'FIND-XML-ATTR)
-		elt))))
-      (and (pair? attrs)
-	   (if (xml-name=? (xml-attribute-name (car attrs)) name)
-	       (xml-attribute-value (car attrs))
-	       (loop (cdr attrs)))))))
 
 (define (flatten-xml-element-content item)
   (letrec
diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index 240948067..da784c115 100644
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.103 2008/08/24 06:27:16 cph Exp $
+$Id: xml.pkg,v 1.104 2008/09/24 00:40:33 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -109,6 +109,7 @@ USA.
 	  error:not-xml-!entity
 	  error:not-xml-!notation
 	  error:not-xml-attribute
+	  error:not-xml-attribute-list
 	  error:not-xml-comment
 	  error:not-xml-declaration
 	  error:not-xml-document
@@ -127,6 +128,7 @@ USA.
 	  guarantee-xml-!entity
 	  guarantee-xml-!notation
 	  guarantee-xml-attribute
+	  guarantee-xml-attribute-list
 	  guarantee-xml-comment
 	  guarantee-xml-declaration
 	  guarantee-xml-document
@@ -233,6 +235,8 @@ USA.
 	  xml-dtd-root
 	  xml-dtd?
 	  xml-element-attributes
+	  xml-element-child
+	  xml-element-children
 	  xml-element-content
 	  xml-element-name
 	  xml-element-namespace-decls
-- 
2.25.1