o with-zstream: new macro that ensures all the streams in the input stack
  are closed even if parsing does not exit normally.  Closing streams can also
  allow resources to be reused.

Index: xml/xml-parse.lisp
===================================================================
RCS file: /project/cxml/cvsroot/cxml/xml/xml-parse.lisp,v
retrieving revision 1.67
diff -u -r1.67 xml-parse.lisp
--- xml/xml-parse.lisp	4 Mar 2007 21:04:13 -0000	1.67
+++ xml/xml-parse.lisp	13 Jun 2007 08:15:07 -0000
@@ -1175,6 +1175,21 @@
   token-semantic
   input-stack)
 
+(defun call-with-zstream (fn zstream)
+  (unwind-protect
+      (funcall fn zstream)
+    (dolist (input (zstream-input-stack zstream))
+      (cond #-x&y-streams-are-stream
+	    ((xstream-p input)
+	     (close-xstream input))
+	    #+x&y-streams-are-stream
+	    ((streamp input)
+	     (close input))))))
+
+(defmacro with-zstream ((zstream &rest args) &body body)
+  `(call-with-zstream (lambda (,zstream) ,@body)
+		      (make-zstream ,@args)))
+
 (defun read-token (input)
   (cond ((zstream-token-category input)
          (multiple-value-prog1
@@ -2545,15 +2560,15 @@
               (setf (dtd *ctx*) cached-dtd)
               (report-cached-dtd cached-dtd))
             (t
-              (let* ((xi2 (xstream-open-extid effective-extid))
-                     (zi2 (make-zstream :input-stack (list xi2))))
-                (ensure-dtd)
-                (p/ext-subset zi2)
-                (when (and fresh-dtd-p
-                           *cache-all-dtds*
-                           *validate*
-                           (not (standalone-p *ctx*)))
-                  (setf (getdtd sysid *dtd-cache*) (dtd *ctx*))))))))
+              (let ((xi2 (xstream-open-extid effective-extid)))
+		(with-zstream (zi2 :input-stack (list xi2))
+		  (ensure-dtd)
+		  (p/ext-subset zi2)
+		  (when (and fresh-dtd-p
+			     *cache-all-dtds*
+			     *validate*
+			     (not (standalone-p *ctx*)))
+		    (setf (getdtd sysid *dtd-cache*) (dtd *ctx*)))))))))
       (sax:end-dtd (handler *ctx*))
       (let ((dtd (dtd *ctx*)))
         (sax:entity-resolver
@@ -2657,7 +2672,8 @@
 	   :entity-name "dummy doctype"
 	   :entity-kind :main
 	   :uri (zstream-base-sysid input)))
-    (p/doctype-decl (make-zstream :input-stack (list dummy)) dtd)))
+    (with-zstream (zstream :input-stack (list dummy))
+      (p/doctype-decl zstream dtd))))
 
 (defun fix-seen-< (input)
   (when (eq (peek-token input) :seen-<)
@@ -2841,106 +2857,106 @@
 
 (defun parse-xml-decl (content)
   (let* ((res (make-xml-header))
-         (i (make-rod-xstream content))
-	 (z (make-zstream :input-stack (list i)))
-         (atts (read-attribute-list z i t)))
-    (unless (eq (peek-rune i) :eof)
-      (wf-error i "Garbage at end of XMLDecl."))
-    ;; versioninfo muss da sein
-    ;; dann ? encodingdecl
-    ;; dann ? sddecl
-    ;; dann ende
-    (unless (eq (caar atts) (intern-name '#.(string-rod "version")))
-      (wf-error i "XMLDecl needs version."))
-    (unless (and (>= (length (cdar atts)) 1)
-		 (every (lambda (x)
+	 (i (make-rod-xstream content)))
+    (with-zstream (z :input-stack (list i))
+      (let ((atts (read-attribute-list z i t)))
+	(unless (eq (peek-rune i) :eof)
+	  (wf-error i "Garbage at end of XMLDecl."))
+	;; versioninfo muss da sein
+	;; dann ? encodingdecl
+	;; dann ? sddecl
+	;; dann ende
+	(unless (eq (caar atts) (intern-name '#.(string-rod "version")))
+	  (wf-error i "XMLDecl needs version."))
+	(unless (and (>= (length (cdar atts)) 1)
+		     (every (lambda (x)
+			      (or (rune<= #/a x #/z)
+				  (rune<= #/A x #/Z)
+				  (rune<= #/0 x #/9)
+				  (rune= x #/_)
+				  (rune= x #/.)
+				  (rune= x #/:)
+				  (rune= x #/-)))
+			    (cdar atts)))
+	  (wf-error i"Bad XML version number: ~S." (rod-string (cdar atts))))
+	(setf (xml-header-version res) (rod-string (cdar atts)))
+	(pop atts)
+	(when (eq (caar atts) (intern-name '#.(string-rod "encoding")))
+	  (unless (and (>= (length (cdar atts)) 1)
+		       (every (lambda (x)
+				(or (rune<= #/a x #/z)
+				    (rune<= #/A x #/Z)
+				    (rune<= #/0 x #/9)
+				    (rune= x #/_)
+				    (rune= x #/.)
+				    (rune= x #/-)))
+			      (cdar atts))
+		       ((lambda (x)
 			  (or (rune<= #/a x #/z)
-			      (rune<= #/A x #/Z)
-			      (rune<= #/0 x #/9)
-			      (rune= x #/_)
-			      (rune= x #/.)
-			      (rune= x #/:)
-			      (rune= x #/-)))
-			(cdar atts)))
-      (wf-error i"Bad XML version number: ~S." (rod-string (cdar atts))))
-    (setf (xml-header-version res) (rod-string (cdar atts)))
-    (pop atts)
-    (when (eq (caar atts) (intern-name '#.(string-rod "encoding")))
-      (unless (and (>= (length (cdar atts)) 1)
-                   (every (lambda (x)
-                            (or (rune<= #/a x #/z)
-                                (rune<= #/A x #/Z)
-                                (rune<= #/0 x #/9)
-                                (rune= x #/_)
-                                (rune= x #/.)
-                                (rune= x #/-)))
-                          (cdar atts))
-                   ((lambda (x)
-                      (or (rune<= #/a x #/z)
-                          (rune<= #/A x #/Z)))
-                    (aref (cdar atts) 0)))
-        (wf-error i "Bad XML encoding name: ~S." (rod-string (cdar atts))))
-      (setf (xml-header-encoding res) (rod-string (cdar atts)))
-      (pop atts))
-    (when (eq (caar atts) (intern-name '#.(string-rod "standalone")))
-      (unless (or (rod= (cdar atts) '#.(string-rod "yes"))
-                  (rod= (cdar atts) '#.(string-rod "no")))
-        (wf-error i "XMLDecl's 'standalone' attribute must be exactly \"yes\" or \"no\" and not ~S."
-               (rod-string (cdar atts))))
-      (setf (xml-header-standalone-p res)
-	    (if (rod-equal '#.(string-rod "yes") (cdar atts))
-		:yes
-		:no))
-      (pop atts))
-    (when atts
-      (wf-error i "Garbage in XMLDecl: ~A" (rod-string content)))
-    res))
+			      (rune<= #/A x #/Z)))
+			(aref (cdar atts) 0)))
+	    (wf-error i "Bad XML encoding name: ~S." (rod-string (cdar atts))))
+	  (setf (xml-header-encoding res) (rod-string (cdar atts)))
+	  (pop atts))
+	(when (eq (caar atts) (intern-name '#.(string-rod "standalone")))
+	  (unless (or (rod= (cdar atts) '#.(string-rod "yes"))
+		      (rod= (cdar atts) '#.(string-rod "no")))
+	    (wf-error i "XMLDecl's 'standalone' attribute must be exactly \"yes\" or \"no\" and not ~S."
+		      (rod-string (cdar atts))))
+	  (setf (xml-header-standalone-p res)
+		(if (rod-equal '#.(string-rod "yes") (cdar atts))
+		    :yes
+		    :no))
+	  (pop atts))
+	(when atts
+	  (wf-error i "Garbage in XMLDecl: ~A" (rod-string content)))
+	res))))
 
 (defun parse-text-decl (content)
   (let* ((res (make-xml-header))
-         (i (make-rod-xstream content))
-	 (z (make-zstream :input-stack (list i)))
-         (atts (read-attribute-list z i t)))
-    (unless (eq (peek-rune i) :eof)
-      (wf-error i "Garbage at end of TextDecl"))
-    ;; versioninfo optional
-    ;; encodingdecl muss da sein
-    ;; dann ende
-    (when (eq (caar atts) (intern-name '#.(string-rod "version")))
-      (unless (and (>= (length (cdar atts)) 1)
-		   (every (lambda (x)
-			    (or (rune<= #/a x #/z)
-				(rune<= #/A x #/Z)
-				(rune<= #/0 x #/9)
-				(rune= x #/_)
-				(rune= x #/.)
-				(rune= x #/:)
-				(rune= x #/-)))
-			  (cdar atts)))
-	(wf-error i "Bad XML version number: ~S." (rod-string (cdar atts))))
-      (setf (xml-header-version res) (rod-string (cdar atts)))
-      (pop atts)) 
-    (unless (eq (caar atts) (intern-name '#.(string-rod "encoding")))
-      (wf-error i "TextDecl needs encoding."))
-    (unless (and (>= (length (cdar atts)) 1)
-		 (every (lambda (x)
-			  (or (rune<= #/a x #/z)
-			      (rune<= #/A x #/Z)
-			      (rune<= #/0 x #/9)
-			      (rune= x #/_)
-			      (rune= x #/.)
-			      (rune= x #/-)))
-			(cdar atts))
-		 ((lambda (x)
-		    (or (rune<= #/a x #/z)
-			(rune<= #/A x #/Z)
-			(rune<= #/0 x #/9)))
-		  (aref (cdar atts) 0)))
-      (wf-error i "Bad XML encoding name: ~S." (rod-string (cdar atts))))
-    (setf (xml-header-encoding res) (rod-string (cdar atts)))
-    (pop atts)
-    (when atts
-      (wf-error i "Garbage in TextDecl: ~A" (rod-string content)))
+         (i (make-rod-xstream content)))
+    (with-zstream (z :input-stack (list i))
+      (let ((atts (read-attribute-list z i t)))
+	(unless (eq (peek-rune i) :eof)
+	  (wf-error i "Garbage at end of TextDecl"))
+	;; versioninfo optional
+	;; encodingdecl muss da sein
+	;; dann ende
+	(when (eq (caar atts) (intern-name '#.(string-rod "version")))
+	  (unless (and (>= (length (cdar atts)) 1)
+		       (every (lambda (x)
+				(or (rune<= #/a x #/z)
+				    (rune<= #/A x #/Z)
+				    (rune<= #/0 x #/9)
+				    (rune= x #/_)
+				    (rune= x #/.)
+				    (rune= x #/:)
+				    (rune= x #/-)))
+			      (cdar atts)))
+	    (wf-error i "Bad XML version number: ~S." (rod-string (cdar atts))))
+	  (setf (xml-header-version res) (rod-string (cdar atts)))
+	  (pop atts)) 
+	(unless (eq (caar atts) (intern-name '#.(string-rod "encoding")))
+	  (wf-error i "TextDecl needs encoding."))
+	(unless (and (>= (length (cdar atts)) 1)
+		     (every (lambda (x)
+			      (or (rune<= #/a x #/z)
+				  (rune<= #/A x #/Z)
+				  (rune<= #/0 x #/9)
+				  (rune= x #/_)
+				  (rune= x #/.)
+				  (rune= x #/-)))
+			    (cdar atts))
+		     ((lambda (x)
+			(or (rune<= #/a x #/z)
+			    (rune<= #/A x #/Z)
+			    (rune<= #/0 x #/9)))
+		      (aref (cdar atts) 0)))
+	  (wf-error i "Bad XML encoding name: ~S." (rod-string (cdar atts))))
+	(setf (xml-header-encoding res) (rod-string (cdar atts)))
+	(pop atts)
+	(when atts
+	  (wf-error i "Garbage in TextDecl: ~A" (rod-string content)))))
     res))
 
 ;;;; ---------------------------------------------------------------------------
@@ -3129,10 +3164,10 @@
       (unless (dtd *ctx*)
 	(with-scratch-pads ()
 	  (let ((*data-behaviour* :DTD))
-	    (let* ((xi2 (xstream-open-extid extid))
-		   (zi2 (make-zstream :input-stack (list xi2))))
-	      (ensure-dtd)
-	      (p/ext-subset zi2)))))
+	    (let ((xi2 (xstream-open-extid extid)))
+	      (with-zstream (zi2 :input-stack (list xi2))
+		(ensure-dtd)
+		(p/ext-subset zi2))))))
       (sax:end-dtd handler)
       (let ((dtd (dtd *ctx*)))
         (sax:entity-resolver handler (lambda (n h) (resolve-entity n h dtd)))
@@ -3171,15 +3206,15 @@
            :entity-name "dtd"
            :entity-kind :main
            :uri (safe-stream-sysid stream)))
-    (let ((zstream (make-zstream :input-stack (list input)))
-          (*ctx* (make-context :handler handler))
+    (let ((*ctx* (make-context :handler handler))
           (*validate* t)
           (*data-behaviour* :DTD))
-      (with-scratch-pads ()
-        (ensure-dtd)
-        (peek-rune input)
-        (p/ext-subset zstream)
-        (dtd *ctx*)))))
+      (with-zstream (zstream :input-stack (list input))
+	(with-scratch-pads ()
+	  (ensure-dtd)
+	  (peek-rune input)
+	  (p/ext-subset zstream)
+	  (dtd *ctx*))))))
 
 (defun parse-rod (string handler &rest args)
   (let ((xstream (string->xstream string)))
@@ -3389,63 +3431,63 @@
 
 ;; used only by read-att-value-2
 (defun find-internal-entity-expansion (name)
-  (let ((zinput (make-zstream)))
+  (with-zstream (zinput)
     (with-rune-collector-3 (collect)
       (labels ((muffle (input)
-                 (let (c)
-                   (loop
-                     (setf c (read-rune input))
-                     (cond ((eq c :eof)
-                            (return))
-                           ((rune= c #/&)
-                            (setf c (peek-rune input))
-                            (cond ((eql c :eof)
-				   (eox input))
-			          ((rune= c #/#)
-                                   (let ((c (read-character-reference input)))
-                                     (%put-unicode-char c collect)))
-                                  (t
-                                   (unless (name-start-rune-p c)
-                                     (wf-error zinput "Expecting name after &."))
-                                   (let ((name (read-name-token input)))
-                                     (setf c (read-rune input))
-                                     (check-rune input c #/\;)
-                                     (recurse-on-entity
-                                      zinput name :general
-                                      (lambda (zinput)
-                                        (muffle (car (zstream-input-stack zinput)))))))))
-                           ((rune= c #/<)
-			    (wf-error zinput "unexpected #\/<"))
-                           ((space-rune-p c)
-                            (collect #/space))
-                           ((not (data-rune-p c))
-                            (wf-error zinput "illegal char: ~S." c))
-                           (t
-                            (collect c)))))))
-        (declare (dynamic-extent #'muffle))
-        (recurse-on-entity
-         zinput name :general
-         (lambda (zinput)
-           (muffle (car (zstream-input-stack zinput))))) ))))
+		 (let (c)
+		   (loop
+		    (setf c (read-rune input))
+		    (cond ((eq c :eof)
+			   (return))
+			  ((rune= c #/&)
+			   (setf c (peek-rune input))
+			   (cond ((eql c :eof)
+				  (eox input))
+				 ((rune= c #/#)
+				  (let ((c (read-character-reference input)))
+				    (%put-unicode-char c collect)))
+				 (t
+				  (unless (name-start-rune-p c)
+				    (wf-error zinput "Expecting name after &."))
+				  (let ((name (read-name-token input)))
+				    (setf c (read-rune input))
+				    (check-rune input c #/\;)
+				    (recurse-on-entity
+				     zinput name :general
+				     (lambda (zinput)
+				       (muffle (car (zstream-input-stack zinput)))))))))
+			  ((rune= c #/<)
+			   (wf-error zinput "unexpected #\/<"))
+			  ((space-rune-p c)
+			   (collect #/space))
+			  ((not (data-rune-p c))
+			   (wf-error zinput "illegal char: ~S." c))
+			  (t
+			   (collect c)))))))
+	(declare (dynamic-extent #'muffle))
+	(recurse-on-entity
+	 zinput name :general
+	 (lambda (zinput)
+	   (muffle (car (zstream-input-stack zinput)))))))))
 
 ;; callback for DOM
 (defun resolve-entity (name handler dtd)
   (let ((*validate* nil))
     (if (get-entity-definition name :general dtd)
         (let* ((*ctx* (make-context :handler handler :dtd dtd))
-               (input (make-zstream))
                (*data-behaviour* :DOC))
-          (with-scratch-pads ()
-            (recurse-on-entity
-             input name :general
-             (lambda (input)
-               (prog1
-                   (etypecase (checked-get-entdef name :general)
-                     (internal-entdef (p/content input))
-                     (external-entdef (p/ext-parsed-ent input)))
-                 (unless (eq (peek-token input) :eof)
-                   (wf-error input "Trailing garbage. - ~S"
-			     (peek-token input))))))))
+	  (with-zstream (input)
+	    (with-scratch-pads ()
+	      (recurse-on-entity
+	       input name :general
+	       (lambda (input)
+		 (prog1
+		     (etypecase (checked-get-entdef name :general)
+		       (internal-entdef (p/content input))
+		       (external-entdef (p/ext-parsed-ent input)))
+		   (unless (eq (peek-token input) :eof)
+		     (wf-error input "Trailing garbage. - ~S"
+			       (peek-token input)))))))))
         nil)))
 
 (defun read-att-value-2 (input)
