From fb9a2fa00238031205e8bc869192c8d1f00a6a4f Mon Sep 17 00:00:00 2001
From: dlichteblau <dlichteblau>
Date: Sat, 16 Jun 2007 11:27:18 +0000
Subject: [PATCH]         SCL support (thanks to Douglas Crosher).  Includes
 support for         implementations where URIs are valid namestrings, and a
 mode         where normal streams are used instead of xstreams and ystreams  
       (albeit both SCL-specific at this point).

---
 cxml.asd              |   5 +-
 doc/index.xml         |   6 +
 runes.asd             |  10 +-
 runes/package.lisp    |   6 +-
 runes/stream-scl.lisp | 253 +++++++++++++++++++++++++++
 runes/ystream.lisp    |  47 +++++
 xml/package.lisp      |   2 +-
 xml/unparse.lisp      |  13 --
 xml/xml-parse.lisp    | 397 +++++++++++++++++++++---------------------
 9 files changed, 523 insertions(+), 216 deletions(-)
 create mode 100644 runes/stream-scl.lisp

diff --git a/cxml.asd b/cxml.asd
index da092da..13fe474 100644
--- a/cxml.asd
+++ b/cxml.asd
@@ -4,6 +4,9 @@
 
 (defclass closure-source-file (cl-source-file) ())
 
+#+scl
+(pushnew 'uri-is-namestring *features*)
+
 #+sbcl
 (defmethod perform :around ((o compile-op) (s closure-source-file))
   ;; shut up already.  Correctness first.
@@ -30,7 +33,7 @@
      (:file "space-normalizer" :depends-on ("xml-parse"))
      (:file "catalog"         :depends-on ("xml-parse"))
      (:file "sax-proxy"       :depends-on ("xml-parse")))
-    :depends-on (:runes :puri :trivial-gray-streams))
+    :depends-on (:runes :puri #-scl :trivial-gray-streams))
 
 (defclass utf8dom-file (closure-source-file) ((of)))
 
diff --git a/doc/index.xml b/doc/index.xml
index 7a983f6..84d80c1 100644
--- a/doc/index.xml
+++ b/doc/index.xml
@@ -68,6 +68,12 @@
 	only.  The old behaviour using pairs of prefix and local names
 	was removed.  (Thanks to Douglas Crosher.)
       </li>
+      <li>
+	SCL support (thanks to Douglas Crosher).  Includes support for
+	implementations where URIs are valid namestrings, and a mode
+	where normal streams are used instead of xstreams and ystreams
+	(albeit both SCL-specific at this point).
+      </li>
     </ul>
     <p class="nomargin"><tt>rel-2007-05-26</tt></p>
     <ul class="nomargin">
diff --git a/runes.asd b/runes.asd
index 86a73d9..086eba9 100644
--- a/runes.asd
+++ b/runes.asd
@@ -52,7 +52,9 @@
              #+rune-is-character "characters")
      #+rune-is-integer (:file "utf8")
      (:file "syntax")
-     (:file "encodings")
-     (:file "encodings-data")
-     (:file "xstream")
-     (:file "ystream")))
+     #-x&y-streams-are-stream (:file "encodings")
+     #-x&y-streams-are-stream (:file "encodings-data")
+     #-x&y-streams-are-stream (:file "xstream")
+     #-x&y-streams-are-stream (:file "ystream")
+     #+x&y-streams-are-stream (:file #+scl "stream-scl")
+     ))
diff --git a/runes/package.lisp b/runes/package.lisp
index 1e4a3f1..bfecbd8 100644
--- a/runes/package.lisp
+++ b/runes/package.lisp
@@ -79,7 +79,11 @@
 	   #:make-string-ystream/utf8
            ;; #+rune-is-integer
 	   #:make-character-stream-ystream/utf8
-	   #:runes-to-utf8/adjustable-string))
+	   #:runes-to-utf8/adjustable-string
+
+	   #:rod-to-utf8-string
+	   #:utf8-string-to-rod
+	   #:make-octet-input-stream))
 
 (defpackage :utf8-runes
   (:use :cl)
diff --git a/runes/stream-scl.lisp b/runes/stream-scl.lisp
new file mode 100644
index 0000000..085e05f
--- /dev/null
+++ b/runes/stream-scl.lisp
@@ -0,0 +1,253 @@
+;;; -*- Mode: Lisp; Syntax: Common-Lisp; readtable: runes; Encoding: utf-8; -*-
+;;; ---------------------------------------------------------------------------
+;;;     Title: Fast streams
+;;;   Created: 1999-07-17
+;;;    Author: Douglas Crosher
+;;;   License: Lisp-LGPL (See file COPYING for details).
+;;; ---------------------------------------------------------------------------
+;;;  (c) copyright 2007 by Douglas Crosher
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Library General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Library General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Library General Public
+;;; License along with this library; if not, write to the 
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
+;;; Boston, MA  02111-1307  USA.
+
+(in-package :runes)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defparameter *fast* '(optimize (speed 3) (safety 3))))
+
+(deftype runes-encoding:encoding-error ()
+  'ext:character-conversion-error)
+
+
+;;; xstream
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defclass xstream (ext:character-stream)
+  ((name :initarg :name :initform nil
+	 :accessor xstream-name)
+   (column :initarg :column :initform 0)
+   (line :initarg :line :initform 1)
+   (unread-column :initarg :unread-column :initform 0)))
+
+(defclass eol-conversion-xstream (lisp::eol-conversion-input-stream xstream)
+  ())
+
+) ; eval-when
+
+(defun make-eol-conversion-xstream (source-stream)
+  "Returns a character stream that conversion CR-LF pairs and lone CR
+  characters into single linefeed character."
+  (declare (type stream source-stream))
+  (let ((stream (ext:make-eol-conversion-stream source-stream
+						:input t
+						:close-stream-p t)))
+    (change-class stream 'eol-conversion-xstream)))
+
+(definline xstream-p (stream)
+  (typep stream 'xstream))
+
+(defun close-xstream (input)
+  (close input))
+
+(definline read-rune (input)
+  (declare (type stream input)
+	   (inline read-char)
+	   #.*fast*)
+  (let ((char (read-char input nil :eof)))
+    (cond ((member char '(#\UFFFE #\UFFFF))
+	   ;; These characters are illegal within XML documents.
+	   (simple-error 'ext:character-conversion-error
+			 "~@<Illegal XML document character: ~S~:@>" char))
+	  ((eql char #\linefeed)
+	   (setf (slot-value input 'unread-column) (slot-value input 'column))
+	   (setf (slot-value input 'column) 0)
+	   (incf (the kernel:index (slot-value input 'line))))
+	  (t
+	   (incf (the kernel:index (slot-value input 'column)))))
+    char))
+
+(definline peek-rune (input)
+  (declare (type stream input)
+	   (inline peek-char)
+	   #.*fast*)
+  (peek-char nil input nil :eof))
+
+(definline consume-rune (input)
+  (declare (type stream input)
+	   (inline read-rune)
+	   #.*fast*)
+  (read-rune input)
+  nil)
+
+(definline unread-rune (rune input)
+  (declare (type stream input)
+	   (inline unread-char)
+	   #.*fast*)
+  (unread-char rune input)
+  (cond ((eql rune #\linefeed)
+	 (setf (slot-value input 'column) (slot-value input 'unread-column))
+	 (setf (slot-value input 'unread-column) 0)
+	 (decf (the kernel:index (slot-value input 'line))))
+	(t
+	 (decf (the kernel:index (slot-value input 'column)))))
+  nil)
+
+(defun fread-rune (input)
+  (read-rune input))
+
+(defun fpeek-rune (input)
+  (peek-rune input))
+
+(defun xstream-position (input)
+  (file-position input))
+
+(defun runes-encoding:find-encoding (encoding)
+  encoding)
+
+(defun make-xstream (os-stream &key name
+                                    (speed 8192)
+                                    (initial-speed 1)
+                                    (initial-encoding :guess))
+  (declare (ignore speed))
+  (assert (eql initial-speed 1))
+  (assert (eq initial-encoding :guess))
+  (let* ((stream (ext:make-xml-character-conversion-stream os-stream
+							   :input t
+							   :close-stream-p t))
+	 (xstream (make-eol-conversion-xstream stream)))
+    (setf (xstream-name xstream) name)
+    xstream))
+
+
+(defclass xstream-string-input-stream (lisp::string-input-stream xstream)
+  ())
+
+(defun make-rod-xstream (string &key name)
+  (declare (type string string))
+  (let ((stream (make-string-input-stream string)))
+    (change-class stream 'xstream-string-input-stream :name name)))
+
+;;; already at 'full speed' so just return the buffer size.
+(defun set-to-full-speed (stream)
+  (length (ext:stream-in-buffer stream)))
+
+(defun xstream-speed (stream)
+  (length (ext:stream-in-buffer stream)))
+
+(defun xstream-line-number (stream)
+  (slot-value stream 'line))
+
+(defun xstream-column-number (stream)
+  (slot-value stream 'column))
+
+(defun xstream-encoding (stream)
+  (stream-external-format stream))
+
+;;; the encoding will have already been detected, but it is checked against the
+;;; declared encoding here.
+(defun (setf xstream-encoding) (declared-encoding stream)
+  (let* ((initial-encoding (xstream-encoding stream))
+	 (canonical-encoding
+	  (cond ((and (eq initial-encoding :utf-16le)
+		      (member declared-encoding '(:utf-16 :utf16 :utf-16le :utf16le)
+			      :test 'string-equal))
+		 :utf-16le)
+		((and (eq initial-encoding :utf-16be)
+		      (member declared-encoding '(:utf-16 :utf16 :utf-16be :utf16be)
+			      :test 'string-equal))
+		 :utf-16be)
+		((and (eq initial-encoding :ucs-4be)
+		      (member declared-encoding '(:ucs-4 :ucs4 :ucs-4be :ucs4be)
+			      :test 'string-equal))
+		 :ucs4-be)
+		((and (eq initial-encoding :ucs-4le)
+		      (member declared-encoding '(:ucs-4 :ucs4 :ucs-4le :ucs4le)
+			      :test 'string-equal))
+		 :ucs4-le)
+		(t
+		 declared-encoding))))
+    (unless (string-equal initial-encoding canonical-encoding)
+      (warn "Unable to change xstream encoding from ~S to ~S (~S)~%"
+	    initial-encoding declared-encoding canonical-encoding))
+    declared-encoding))
+
+
+;;; ystream - a run output stream.
+
+(deftype ystream () 'stream)
+
+(defun ystream-column (stream)
+  (ext:line-column stream))
+
+(definline write-rune (rune stream)
+  (declare (inline write-char))
+  (write-char rune stream))
+
+(defun write-rod (rod stream)
+  (declare (type rod rod)
+	   (type stream stream))
+  (write-string rod stream))
+
+(defun make-rod-ystream ()
+  (make-string-output-stream))
+
+(defun close-ystream (stream)
+  (etypecase stream
+    (ext:string-output-stream
+     (get-output-stream-string stream))
+    (ext:character-conversion-output-stream
+     (let ((target (slot-value stream 'stream)))
+       (close stream)
+       (if (typep target 'ext:byte-output-stream)
+	   (ext:get-output-stream-bytes target)
+	   stream)))))
+
+;;;; CHARACTER-STREAM-YSTREAM
+
+(defun make-character-stream-ystream (target-stream)
+  target-stream)
+
+
+;;;; OCTET-VECTOR-YSTREAM
+
+(defun make-octet-vector-ystream ()
+  (let ((target (ext:make-byte-output-stream)))
+    (ext:make-character-conversion-stream target :output t
+					  :external-format :utf-8
+					  :close-stream-p t)))
+
+;;;; OCTET-STREAM-YSTREAM
+
+(defun make-octet-stream-ystream (os-stream)
+  (ext:make-character-conversion-stream os-stream :output t
+					:external-format :utf-8
+					:close-stream-p t))
+
+
+;;;; helper functions
+
+(defun rod-to-utf8-string (rod)
+  (ext:make-string-from-bytes (ext:make-bytes-from-string rod :utf8)
+			      :iso-8859-1))
+
+(defun utf8-string-to-rod (str)
+  (let ((bytes (map '(vector (unsigned-byte 8)) #'char-code str)))
+    (ext:make-string-from-bytes bytes :utf-8)))
+
+(defun make-octet-input-stream (octets)
+  (ext:make-byte-input-stream octets))
+
+
diff --git a/runes/ystream.lisp b/runes/ystream.lisp
index a7ae87a..b98d0e8 100644
--- a/runes/ystream.lisp
+++ b/runes/ystream.lisp
@@ -248,3 +248,50 @@
 
   (defmethod close-ystream ((ystream string-ystream/utf8))
     (get-output-stream-string (ystream-os-stream ystream))))
+
+
+;;;; helper functions
+
+(defun rod-to-utf8-string (rod)
+  (let ((out (make-buffer :element-type 'character)))
+    (runes-to-utf8/adjustable-string out rod (length rod))
+    out))
+
+(defun utf8-string-to-rod (str)
+  (let* ((bytes (map '(vector (unsigned-byte 8)) #'char-code str))
+         (buffer (make-array (length bytes) :element-type '(unsigned-byte 16)))
+         (n (runes-encoding:decode-sequence
+	     :utf-8 bytes 0 (length bytes) buffer 0 0 nil))
+         (result (make-array n :element-type 'rune)))
+    (map-into result #'code-rune buffer)
+    result))
+
+(defclass octet-input-stream
+    (trivial-gray-stream-mixin fundamental-binary-input-stream)
+    ((octets :initarg :octets)
+     (pos :initform 0)))
+
+(defmethod close ((stream octet-input-stream) &key abort)
+  (declare (ignore abort))
+  (open-stream-p stream))
+
+(defmethod stream-read-byte ((stream octet-input-stream))
+  (with-slots (octets pos) stream
+    (if (>= pos (length octets))
+        :eof
+        (prog1
+            (elt octets pos)
+          (incf pos)))))
+
+(defmethod stream-read-sequence
+    ((stream octet-input-stream) sequence start end &key &allow-other-keys)
+  (with-slots (octets pos) stream
+    (let* ((length (min (- end start) (- (length octets) pos)))
+           (end1 (+ start length))
+           (end2 (+ pos length)))
+      (replace sequence octets :start1 start :end1 end1 :start2 pos :end2 end2)
+      (setf pos end2)
+      end1)))
+
+(defun make-octet-input-stream (octets)
+  (make-instance 'octet-input-stream :octets octets))
diff --git a/xml/package.lisp b/xml/package.lisp
index 5518d48..c0d1550 100644
--- a/xml/package.lisp
+++ b/xml/package.lisp
@@ -6,7 +6,7 @@
 (in-package :cl-user)
 
 (defpackage :cxml
-  (:use :cl :runes :runes-encoding :trivial-gray-streams)
+  (:use :cl :runes :runes-encoding #-scl :trivial-gray-streams)
   (:export
    ;; xstreams
    #:make-xstream
diff --git a/xml/unparse.lisp b/xml/unparse.lisp
index e522f8b..caf2025 100644
--- a/xml/unparse.lisp
+++ b/xml/unparse.lisp
@@ -619,16 +619,3 @@
   (maybe-emit-start-tag)
   (sax:characters *sink* (rod data))
   data)
-
-(defun rod-to-utf8-string (rod)
-  (let ((out (make-buffer :element-type 'character)))
-    (runes-to-utf8/adjustable-string out rod (length rod))
-    out))
-
-(defun utf8-string-to-rod (str)
-  (let* ((bytes (map '(vector (unsigned-byte 8)) #'char-code str))
-         (buffer (make-array (length bytes) :element-type '(unsigned-byte 16)))
-         (n (decode-sequence :utf-8 bytes 0 (length bytes) buffer 0 0 nil))
-         (result (make-array n :element-type 'rune)))
-    (map-into result #'code-rune buffer)
-    result))
diff --git a/xml/xml-parse.lisp b/xml/xml-parse.lisp
index f215f0b..db27f72 100644
--- a/xml/xml-parse.lisp
+++ b/xml/xml-parse.lisp
@@ -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))
 
 ;;;; ---------------------------------------------------------------------------
@@ -2957,6 +2973,7 @@
 ;;;; ---------------------------------------------------------------------------
 ;;;; User interface ;;;;
 
+#-cxml-system::uri-is-namestring
 (defun specific-or (component &optional (alternative nil))
   (if (eq component :unspecific)
       alternative
@@ -2967,6 +2984,7 @@
       alternative
       str))
 
+#-cxml-system::uri-is-namestring
 (defun make-uri (&rest initargs &key path query &allow-other-keys)
   (apply #'make-instance
          'puri:uri
@@ -2974,9 +2992,11 @@
          :query (and query (escape-query query))
          initargs))
 
+#-cxml-system::uri-is-namestring
 (defun escape-path (list)
   (puri::render-parsed-path list t))
 
+#-cxml-system::uri-is-namestring
 (defun escape-query (pairs)
   (flet ((escape (str)
            (puri::encode-escaped-encoding str puri::*reserved-characters* t)))
@@ -2990,6 +3010,7 @@
           (write-char #\= s)
           (write-string (escape (cdr pair)) s))))))
 
+#-cxml-system::uri-is-namestring
 (defun uri-parsed-query (uri)
   (flet ((unescape (str)
            (puri::decode-escaped-encoding str t puri::*reserved-characters*)))
@@ -3005,9 +3026,11 @@
         (t
           nil)))))
 
+#-cxml-system::uri-is-namestring
 (defun query-value (name alist)
   (cdr (assoc name alist :test #'equal)))
 
+#-cxml-system::uri-is-namestring
 (defun pathname-to-uri (pathname)
   (let ((path
          (append (pathname-directory pathname)
@@ -3027,6 +3050,11 @@
                           (specific-or (pathname-device pathname)))
                   :path path))))
 
+#+cxml-system::uri-is-namestring
+(defun pathname-to-uri (pathname)
+  (puri:parse-uri (namestring pathname)))
+
+#-cxml-system::uri-is-namestring
 (defun parse-name.type (str)
   (if str
       (let ((i (position #\. str :from-end t)))
@@ -3035,6 +3063,7 @@
             (values str nil)))
       (values nil nil)))
 
+#-cxml-system::uri-is-namestring
 (defun uri-to-pathname (uri)
   (let ((scheme (puri:uri-scheme uri))
         (path (puri:uri-parsed-path uri)))
@@ -3058,11 +3087,17 @@
                            :directory (cons :absolute (butlast (cdr path)))
                            :name name
                            :type type))))))
+#+cxml-system::uri-is-namestring
+(defun uri-to-pathname (uri)
+  (let ((pathname (puri:render-uri uri nil)))
+    (when (equalp (pathname-host pathname) "+")
+      (setf (slot-value pathname 'lisp::host) "localhost"))
+    pathname))
 
 (defun parse-xstream (xstream handler &rest args)
   (let ((*ctx* nil))
     (handler-case
-	(let ((zstream (make-zstream :input-stack (list xstream))))
+	(with-zstream (zstream :input-stack (list xstream))
 	  (peek-rune xstream)
 	  (with-scratch-pads ()
 	    (apply #'p/document zstream handler args)))
@@ -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)))
@@ -3193,36 +3228,6 @@
 (defun string->xstream (string)
   (make-rod-xstream (string-rod string)))
 
-(defclass octet-input-stream
-    (trivial-gray-stream-mixin fundamental-binary-input-stream)
-    ((octets :initarg :octets)
-     (pos :initform 0)))
-
-(defmethod close ((stream octet-input-stream) &key abort)
-  (declare (ignore abort))
-  (open-stream-p stream))
-
-(defmethod stream-read-byte ((stream octet-input-stream))
-  (with-slots (octets pos) stream
-    (if (>= pos (length octets))
-        :eof
-        (prog1
-            (elt octets pos)
-          (incf pos)))))
-
-(defmethod stream-read-sequence
-    ((stream octet-input-stream) sequence start end &key &allow-other-keys)
-  (with-slots (octets pos) stream
-    (let* ((length (min (- end start) (- (length octets) pos)))
-           (end1 (+ start length))
-           (end2 (+ pos length)))
-      (replace sequence octets :start1 start :end1 end1 :start2 pos :end2 end2)
-      (setf pos end2)
-      end1)))
-
-(defun make-octet-input-stream (octets)
-  (make-instance 'octet-input-stream :octets octets))
-
 (defun parse-octets (octets handler &rest args)
   (apply #'parse-stream (make-octet-input-stream octets) handler args))
 
@@ -3389,63 +3394,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)