From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 24 Sep 2008 00:44:50 +0000 (+0000)
Subject: Add optional ERROR? arg to XML-ELEMENT-CHILD and FIND-XML-ATTR.
X-Git-Tag: 20090517-FFI~121
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=64481b3ea42a17b25353f79e09293a835ca30d06;p=mit-scheme.git

Add optional ERROR? arg to XML-ELEMENT-CHILD and FIND-XML-ATTR.
---

diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index c69565eb6..7e92248a1 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.63 2008/09/24 00:40:36 cph Exp $
+$Id: xml-struct.scm,v 1.64 2008/09/24 00:44:50 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -244,12 +244,16 @@ USA.
 	      (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-child name elt #!optional error?)
+  (let ((child
+	 (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)))))
+    (if (and (not child) (if (default-object? error?) #f error?))
+	(error:bad-range-argument name 'XML-ELEMENT-CHILD))
+    child))
 
 (define (xml-element-children name elt)
   (let ((name (xml-name-arg name 'XML-ELEMENT-CHILDREN)))
@@ -258,7 +262,7 @@ USA.
 		   (xml-name=? (xml-element-name item) name)))
 	    (xml-element-content elt))))
 
-(define (find-xml-attr name elt)
+(define (find-xml-attr name elt #!optional error?)
   (let ((attr
 	 (find (let ((name (xml-name-arg name 'FIND-XML-ATTR)))
 		 (lambda (attr)
@@ -268,6 +272,8 @@ USA.
 		   (begin
 		     (guarantee-xml-attribute-list elt 'FIND-XML-ATTR)
 		     elt)))))
+    (if (and (not attr) (if (default-object? error?) #f error?))
+	(error:bad-range-argument name 'FIND-XML-ATTR))
     (and attr
 	 (xml-attribute-value attr))))