utf8-dom

cxml.asd

@@ -46,6 +46,7 @@
              #-rune-is-character "runes"
              #+rune-is-character "characters"
 	    :depends-on ("package" "definline"))
+     #+rune-is-integer (:file "utf8" :depends-on ("package"))
      (:file "syntax" :depends-on ("package" "definline" runes))
      (:file "encodings" :depends-on ("package"))
      (:file "encodings-data" :depends-on ("package" "encodings"))
@@ -73,6 +74,25 @@
      (:file "sax-proxy"       :depends-on ("xml-parse")))
     :depends-on (:cxml-runes :puri :trivial-gray-streams))
 
+(defclass utf8dom-file (closure-source-file) ((of)))
+
+(defmethod output-files ((operation compile-op) (c utf8dom-file))
+  (let* ((normal (car (call-next-method)))
+	 (name (concatenate 'string (pathname-name normal) "-utf8"))
+	 (of (make-pathname :name name :defaults normal)))
+    (setf (slot-value c 'of) of)
+    (list of)))
+
+(defmethod perform ((o load-op) (c utf8dom-file))
+  (load (slot-value c 'of)))
+
+(defvar *utf8-runes-readtable*)
+
+(defmethod perform ((operation compile-op) (c utf8dom-file))
+  (let ((*features* (cons 'utf8dom-file *features*))
+	(*readtable* *utf8-runes-readtable*))
+    (call-next-method)))
+
 (asdf:defsystem :cxml-dom
     :default-component-class closure-source-file
     :pathname (merge-pathnames
@@ -80,8 +100,12 @@
                (make-pathname :name nil :type nil :defaults *load-truename*))
     :components
     ((:file "package")
-     (:file "dom-impl"        :depends-on ("package"))
+     (:file rune-impl :pathname "dom-impl" :depends-on ("package"))
-     (:file "dom-builder"     :depends-on ("dom-impl"))
+     (:file rune-builder :pathname "dom-builder" :depends-on (rune-impl))
+     #+rune-is-integer
+     (utf8dom-file utf8-impl :pathname "dom-impl" :depends-on ("package"))
+     #+rune-is-integer
+     (utf8dom-file utf8-builder :pathname "dom-builder" :depends-on (utf8-impl))
      (:file "unparse"         :depends-on ("package"))
      (:file "dom-sax"         :depends-on ("package")))
     :depends-on (:cxml-xml))

doc/using.html

@@ -323,11 +323,10 @@
       builder, since DOM is specified to use UTF-16.
     </p>
     <p>
-      <div class="def">Function CXML:MAKE-RECODER (chained-handler &optional recoder-fn)</div>
+      <div class="def">Function CXML:MAKE-RECODER (chained-handler recoder-fn)</div>
       Return a SAX handler which passes all events on to
       <tt>chained-handler</tt> after converting all strings and rods
-      using <tt>recoder-fn</tt>, a function of one argument which
+      using <tt>recoder-fn</tt>, a function of one argument.
-      defaults to <tt>runes:rod-string</tt>.
     </p>
     <p>
       <b>Example.</b> In a Lisp which ordinarily would use octet vector rods:
@@ -337,7 +336,7 @@
     <p>
       Use a SAX recoder to get strings instead::
     </p>
-    <pre>CL-USER(17): (parse-string "&lt;test/&gt;" (cxml:make-recoder (cxml-xmls:make-xmls-builder)))
+    <pre>CL-USER(17): (parse-string "&lt;test/&gt;" (cxml:make-recoder (cxml-xmls:make-xmls-builder) 'runes:rod-string))
 ("test" NIL)</pre>
 
     <a name="dtdcache"/>

dom/dom-builder.lisp

@@ -8,14 +8,19 @@
 ;;;; Author: David Lichteblau <david@lichteblau.com>
 ;;;; Author: knowledgeTools Int. GmbH
 
-(in-package :dom-impl)
+#-cxml-system::utf8dom-file
+(in-package :rune-dom)
+
+#+cxml-system::utf8dom-file
+(in-package :utf8-dom)
+
 
 (defclass dom-builder ()
   ((document      :initform nil :accessor document)
    (element-stack :initform '() :accessor element-stack)
    (internal-subset             :accessor internal-subset)))
 
-(defun dom:make-dom-builder ()
+(defun make-dom-builder ()
   (make-instance 'dom-builder))
 
 (defun fast-push (new-element vector)
@@ -26,9 +31,9 @@
 	     (not (and sax:*include-xmlns-attributes*
 		       sax:*use-xmlns-namespace*)))
     (error "SAX configuration is incompatible with DOM: *namespace-processing* is activated, but *include-xmlns-attributes* or *use-xmlns-namespace* are not"))
-  (let ((document (make-instance 'dom-impl::document)))
+  (let ((document (make-instance 'document)))
-    (setf (slot-value document 'dom-impl::owner) nil
+    (setf (slot-value document 'owner) nil
-	  (slot-value document 'dom-impl::doc-type) nil)
+	  (slot-value document 'doc-type) nil)
     (setf (document handler) document)
     (push document (element-stack handler))))
 
@@ -46,16 +51,16 @@
 (defmethod sax:start-dtd ((handler dom-builder) name publicid systemid)
   (let* ((document (document handler))
          (doctype (%create-document-type name publicid systemid)))
-    (setf (slot-value doctype 'dom-impl::owner) document
+    (setf (slot-value doctype 'owner) document
-	  (slot-value (dom:notations doctype) 'dom-impl::owner) document
+	  (slot-value (dom:notations doctype) 'owner) document
-	  (slot-value (dom:entities doctype) 'dom-impl::owner) document
+	  (slot-value (dom:entities doctype) 'owner) document
-	  (slot-value document 'dom-impl::doc-type) doctype)))
+	  (slot-value document 'doc-type) doctype)))
 
 (defmethod sax:start-internal-subset ((handler dom-builder))
   (setf (internal-subset handler) nil))
 
 (defmethod sax:end-internal-subset ((handler dom-builder))
-  (setf (internal-subset (slot-value (document handler) 'dom-impl::doc-type))
+  (setf (dom::%internal-subset (slot-value (document handler) 'doc-type))
 	(nreverse (internal-subset handler)))
   (slot-makunbound handler 'internal-subset))
 
@@ -78,6 +83,7 @@
 
 (defmethod sax:start-element
     ((handler dom-builder) namespace-uri local-name qname attributes)
+  (check-type qname rod)
   (with-slots (document element-stack) handler
     (let* ((nsp sax:*namespace-processing*)
 	   (element (make-instance 'element 
@@ -85,7 +91,7 @@
                      :owner document
 		     :namespace-uri (when nsp namespace-uri)
 		     :local-name (when nsp local-name)
-		     :prefix (when nsp (cxml::split-qname (cxml::rod qname)))))
+		     :prefix (%rod (when nsp (cxml::split-qname (real-rod qname))))))
 	  (parent (car element-stack))
           (anodes '()))
       (dolist (attr attributes)
@@ -97,20 +103,20 @@
 		   (dom:create-attribute document (sax:attribute-qname attr))))
               (text
                (dom:create-text-node document (sax:attribute-value attr))))
-          (setf (slot-value anode 'dom-impl::specified-p)
+          (setf (slot-value anode 'specified-p)
                 (sax:attribute-specified-p attr))
-	  (setf (slot-value anode 'dom-impl::owner-element) element)
+	  (setf (slot-value anode 'owner-element) element)
           (dom:append-child anode text)
           (push anode anodes)))
-      (setf (slot-value element 'dom-impl::parent) parent)
+      (setf (slot-value element 'parent) parent)
-      (fast-push element (slot-value parent 'dom-impl::children))
+      (fast-push element (slot-value parent 'children))
       (let ((map
 	      (make-instance 'attribute-node-map
 		:items anodes
 		:element-type :attribute
 		:element element
 		:owner document)))
-	(setf (slot-value element 'dom-impl::attributes) map)
+	(setf (slot-value element 'attributes) map)
 	(dolist (anode anodes)
 	  (setf (slot-value anode 'map) map)))
       (push element element-stack))))
@@ -134,15 +140,15 @@
           (dom:append-data last-child data))
         (t
           (let ((node (dom:create-text-node document data)))
-            (setf (slot-value node 'dom-impl::parent) parent)
+            (setf (slot-value node 'parent) parent)
-            (fast-push node (slot-value (car element-stack) 'dom-impl::children))))))))
+            (fast-push node (slot-value (car element-stack) 'children))))))))
 
 (defmethod sax:start-cdata ((handler dom-builder))
   (with-slots (document element-stack) handler
     (let ((node (dom:create-cdata-section document #""))
           (parent (car element-stack)))
-      (setf (slot-value node 'dom-impl::parent) parent)
+      (setf (slot-value node 'parent) parent)
-      (fast-push node (slot-value parent 'dom-impl::children))
+      (fast-push node (slot-value parent 'children))
       (push node element-stack))))
 
 (defmethod sax:end-cdata ((handler dom-builder))
@@ -153,15 +159,15 @@
   (with-slots (document element-stack) handler
     (let ((node (dom:create-processing-instruction document target data))
           (parent (car element-stack)))
-      (setf (slot-value node 'dom-impl::parent) parent)
+      (setf (slot-value node 'parent) parent)
-      (fast-push node (slot-value (car element-stack) 'dom-impl::children)))))
+      (fast-push node (slot-value (car element-stack) 'children)))))
 
 (defmethod sax:comment ((handler dom-builder) data)
   (with-slots (document element-stack) handler
     (let ((node (dom:create-comment document data))
           (parent (car element-stack)))
-      (setf (slot-value node 'dom-impl::parent) parent)
+      (setf (slot-value node 'parent) parent)
-      (fast-push node (slot-value (car element-stack) 'dom-impl::children)))))
+      (fast-push node (slot-value (car element-stack) 'children)))))
 
 (defmethod sax:unparsed-entity-declaration
     ((handler dom-builder) name public-id system-id notation-name)
@@ -182,7 +188,7 @@
 
 (defun set-entity (handler name pid sid notation)
   (dom:set-named-item (dom:entities (dom:doctype (document handler)))
-                      (make-instance 'dom-impl::entity
+                      (make-instance 'entity
                         :owner (document handler)
                         :name name
                         :public-id pid
@@ -192,7 +198,7 @@
 (defmethod sax:notation-declaration
     ((handler dom-builder) name public-id system-id)
   (dom:set-named-item (dom:notations (dom:doctype (document handler)))
-                      (make-instance 'dom-impl::notation
+                      (make-instance 'notation
                         :owner (document handler)
                         :name name
                         :public-id public-id

dom/dom-impl.lisp

@@ -7,11 +7,24 @@
 ;;;; Author: David Lichteblau <david@lichteblau.com>
 ;;;; Author: knowledgeTools Int. GmbH
 
-(defpackage :dom-impl
+#-cxml-system::utf8dom-file
+(defpackage :rune-dom
   (:use :cl :runes)
-  (:export #:create-document))
+  #+rune-is-character (:nicknames :cxml-dom)
+  (:export #:implementation #:make-dom-builder #:create-document))
+
+#+cxml-system::utf8dom-file
+(defpackage :utf8-dom
+  (:use :cl :utf8-runes)
+  (:nicknames :cxml-dom)
+  (:export #:implementation #:make-dom-builder #:create-document))
+
+#-cxml-system::utf8dom-file
+(in-package :rune-dom)
+
+#+cxml-system::utf8dom-file
+(in-package :utf8-dom)
 
-(in-package :dom-impl)
 
 ;; Classes
 
@@ -107,7 +120,7 @@
    (system-id     :initarg :system-id     :reader dom:system-id)
    (entities      :initarg :entities      :reader dom:entities)
    (notations     :initarg :notations     :reader dom:notations)
-   (internal-subset                       :accessor internal-subset)))
+   (dom::%internal-subset                 :accessor dom::%internal-subset)))
 
 (defclass notation (node)
   ((name          :initarg :name          :reader dom:name)
@@ -144,9 +157,24 @@
   (etypecase x
     (null x)
     (rod x)
+    #+cxml-system::utf8dom-file (runes::rod (cxml::rod-to-utf8-string x))
     (string (string-rod x))
     (vector x)))
 
+#-cxml-system::utf8dom-file
+(defun real-rod (x)
+  (%rod x))
+
+#+cxml-system::utf8dom-file
+(defun real-rod (x)
+  (etypecase x
+    (null x)
+    (runes::rod x)
+    (string (cxml::utf8-string-to-rod x))))
+
+(defun valid-name-p (x)
+  (cxml::valid-name-p (real-rod x)))
+
 (defun assert-writeable (node)
   (when (read-only-p node)
     (dom-error :NO_MODIFICATION_ALLOWED_ERR "~S is marked read-only." node)))
@@ -231,12 +259,12 @@
 	   (string-equal (rod-string version) "2.0"))))
 
 (defun %create-document-type (name publicid systemid)
-  (make-instance 'dom-impl::document-type
+  (make-instance 'document-type
     :name name
-    :notations (make-instance 'dom-impl::named-node-map
+    :notations (make-instance 'named-node-map
 		 :element-type :notation
 		 :owner nil)
-    :entities (make-instance 'dom-impl::named-node-map
+    :entities (make-instance 'named-node-map
 		:element-type :entity
 		:owner nil)
     :public-id publicid
@@ -249,7 +277,7 @@
 
 (defmethod dom:create-document
     ((factory (eql 'implementation)) uri qname doctype)
-  (let ((document (make-instance 'dom-impl::document)))
+  (let ((document (make-instance 'document)))
     (setf (slot-value document 'owner) nil
 	  (slot-value document 'doc-type) doctype)
     (when doctype
@@ -258,9 +286,9 @@
 		   "doctype was created by a different dom implementation"))
       (when (dom:owner-document doctype)
 	(dom-error :WRONG_DOCUMENT_ERR "doctype already in use"))
-      (setf (slot-value doctype 'dom-impl::owner) document
+      (setf (slot-value doctype 'owner) document
-	    (slot-value (dom:notations doctype) 'dom-impl::owner) document
+	    (slot-value (dom:notations doctype) 'owner) document
-	    (slot-value (dom:entities doctype) 'dom-impl::owner) document))
+	    (slot-value (dom:entities doctype) 'owner) document))
     (when (or uri qname)
       (dom:append-child document (dom:create-element-ns document uri qname)))
     document))
@@ -278,7 +306,7 @@
 
 (defmethod dom:create-element ((document document) tag-name)
   (setf tag-name (%rod tag-name))
-  (unless (cxml::valid-name-p tag-name)
+  (unless (valid-name-p tag-name)
     (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string tag-name)))
   (let ((result (make-instance 'element
                   :tag-name tag-name
@@ -295,14 +323,16 @@
     result))
 
 (defun safe-split-qname (qname uri)
-  (unless (cxml::valid-name-p qname)
+  (unless (valid-name-p qname)
     (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string qname)))
   (multiple-value-bind (prefix local-name)
       (handler-case
-	  (cxml::split-qname qname)
+	  (cxml::split-qname (real-rod qname))
 	(cxml:well-formedness-violation (c)
 	  (dom-error :NAMESPACE_ERR "~A" c)))
+    (setf local-name (%rod local-name))
     (when prefix
+      (setf prefix (%rod prefix))
       (unless uri
 	(dom-error :NAMESPACE_ERR "prefix specified but no namespace URI"))
       (when (and (rod= prefix #"xml")
@@ -356,7 +386,7 @@
 (defmethod dom:create-processing-instruction ((document document) target data)
   (setf target (%rod target))
   (setf data (%rod data))
-  (unless (cxml::valid-name-p target)
+  (unless (valid-name-p target)
     (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string target)))
   (make-instance 'processing-instruction
     :owner document
@@ -365,7 +395,7 @@
 
 (defmethod dom:create-attribute ((document document) name)
   (setf name (%rod name))
-  (unless (cxml::valid-name-p name)
+  (unless (valid-name-p name)
     (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string name)))
   (make-instance 'attribute
     :name name
@@ -395,7 +425,7 @@
 
 (defmethod dom:create-entity-reference ((document document) name)
   (setf name (%rod name))
-  (unless (cxml::valid-name-p name)
+  (unless (valid-name-p name)
     (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string name)))
   (make-instance 'entity-reference
     :name name
@@ -445,12 +475,12 @@
 	       (dovector (c (dom:child-nodes n))
 		 (when (dom:element-p c)
 		   (let ((e (cxml::find-element
-			     (cxml::rod (dom:tag-name c))
+			     (real-rod (dom:tag-name c))
 			     (dtd document))))
 		     (when e
 		       (dolist (a (cxml::elmdef-attributes e))
 			 (when (eq :ID (cxml::attdef-type a))
-			   (let* ((name (rod (cxml::attdef-name a)))
+			   (let* ((name (%rod (cxml::attdef-name a)))
 				  (value (dom:get-attribute c name)))
 			     (when (and value (rod= value id))
 			       (return-from t c)))))))
@@ -603,19 +633,19 @@
 ;; node-name 
 
 (defmethod dom:node-name ((self document))
-  '#.(string-rod "#document"))
+  #"#document")
 
 (defmethod dom:node-name ((self document-fragment))
-  '#.(string-rod "#document-fragment"))
+  #"#document-fragment")
 
 (defmethod dom:node-name ((self text))
-  '#.(string-rod "#text"))
+  #"#text")
 
 (defmethod dom:node-name ((self cdata-section))
-  '#.(string-rod "#cdata-section"))
+  #"#cdata-section")
 
 (defmethod dom:node-name ((self comment))
-  '#.(string-rod "#comment"))
+  #"#comment")
 
 (defmethod dom:node-name ((self attribute))
   (dom:name self))
@@ -999,13 +1029,13 @@
   (let ((a (dom:get-attribute-node element name)))
     (if a
         (dom:value a)
-        #.(string-rod ""))))
+        #"")))
 
 (defmethod dom:get-attribute-ns ((element element) uri lname)
   (let ((a (dom:get-attribute-node-ns element uri lname)))
     (if a
         (dom:value a)
-        #.(string-rod ""))))
+        #"")))
 
 (defmethod dom:set-attribute ((element element) name value)
   (assert-writeable element)
@@ -1048,9 +1078,9 @@
   (let* ((qname (dom:name old-attr))
 	 (dtd (dtd (slot-value element 'owner)))
          (e (when dtd (cxml::find-element
-		       (cxml::rod (dom:tag-name element))
+		       (real-rod (dom:tag-name element))
 		       dtd)))
-         (a (when e (cxml::find-attribute e qname))))
+         (a (when e (cxml::find-attribute e (real-rod qname)))))
     (when (and a (listp (cxml::attdef-default a)))
       (let ((new (add-default-attribute element a)))
 	(setf (slot-value new 'namespace-uri) (dom:namespace-uri old-attr))
@@ -1060,7 +1090,7 @@
 (defun add-default-attributes (element)
   (let* ((dtd (dtd (slot-value element 'owner)))
          (e (when dtd (cxml::find-element
-		       (cxml::rod (dom:tag-name element))
+		       (real-rod (dom:tag-name element))
 		       dtd))))
     (when e
       (dolist (a (cxml::elmdef-attributes e))
@@ -1068,13 +1098,15 @@
 		   (listp (cxml::attdef-default a))
 		   (not (dom:get-attribute-node
 			 element
-			 (cxml::attdef-name a))))
+			 (%rod (cxml::attdef-name a)))))
           (let ((anode (add-default-attribute element a)))
 	    (multiple-value-bind (prefix local-name)
 		(handler-case
 		    (cxml::split-qname (cxml::attdef-name a))
 		  (cxml:well-formedness-violation (c)
 		    (dom-error :NAMESPACE_ERR "~A" c)))
+	      (when prefix (setf prefix (%rod prefix)))
+	      (setf local-name (%rod local-name))
 	      ;; das ist fuer importnode07.
 	      ;; so richtig ueberzeugend finde ich das ja nicht.
 	      (setf (slot-value anode 'prefix) prefix)
@@ -1173,14 +1205,14 @@
 
 (defmethod dom:internal-subset ((node document-type))
   ;; FIXME: encoding ist falsch, anderen sink nehmen!
-  (if (and (slot-boundp node 'internal-subset)
+  (if (and (slot-boundp node 'dom::%internal-subset)
 	   ;; die damen und herren von der test suite sind wohl der meinung,
 	   ;; dass ein leeres internal subset nicht vorhanden ist und
 	   ;; wir daher nil liefern sollen.  bittesehr!
-	   (internal-subset node))
+	   (dom::%internal-subset node))
       (with-output-to-string (stream)
 	(let ((sink (cxml:make-character-stream-sink stream)))
-	  (dolist (def (internal-subset node))
+	  (dolist (def (dom::%internal-subset node))
 	    (apply (car def) sink (cdr def)))))
       nil))
 
@@ -1191,7 +1223,7 @@
 
 (defmethod initialize-instance :after ((instance entity-reference) &key)
   (let* ((owner (dom:owner-document instance))
-         (handler (dom:make-dom-builder))
+         (handler (make-dom-builder))
          (resolver (slot-value owner 'entity-resolver)))
     (when resolver
       (setf (document handler) owner)
@@ -1380,10 +1412,10 @@
 
 ;;; Erweiterung
 
-(defun dom-impl:create-document (&optional document-element)
+(defun create-document (&optional document-element)
   ;; Um ein neues Dokumentenobject zu erzeugen, parsen wir einfach ein
   ;; Dummydokument.
-  (let* ((handler (dom:make-dom-builder))
+  (let* ((handler (make-dom-builder))
          (cxml::*ctx* (cxml::make-context :handler handler))
          (result
           (progn

dom/dom-sax.lisp

@@ -6,7 +6,7 @@
 ;;;; Author: David Lichteblau <david@lichteblau.com>
 ;;;; Copyright (c) 2004 knowledgeTools Int. GmbH
 
-(in-package :dom-impl)
+(in-package :cxml)
 
 (defun dom:map-document
     (handler document
@@ -23,9 +23,9 @@
 		       (dom:system-id doctype))
 	(ecase include-doctype
 	  (:full-internal-subset
-	    (when (slot-boundp doctype 'internal-subset)
+	    (when (slot-boundp doctype 'dom::%internal-subset)
 	      (sax:start-internal-subset handler)
-	      (dolist (def (internal-subset doctype))
+	      (dolist (def (dom::%internal-subset doctype))
 		(apply (car def) handler (cdr def)))
 	      (sax:end-internal-subset handler)))
 	  (:canonical-notations

dom/package.lisp

@@ -8,10 +8,6 @@
 (defpackage :dom
   (:use)
   (:export
-   
-   ;; lisp-specific extensions
-   #:make-dom-builder
-
    ;; DOM 2 functions
    #:owner-element
    #:import-node
@@ -100,26 +96,29 @@
    #:target
    #:code
    
-   ;; protocol classes
+   ;; not exported:
-   #:dom-implementation
+;;;   ;; protocol classes
-   #:document-fragment
+;;;   #:dom-implementation
-   #:document
+;;;   #:document-fragment
-   #:node
+;;;   #:document
-   #:node-list
+;;;   #:node
-   #:named-node-map
+;;;   #:node-list
-   #:character-data
+;;;   #:named-node-map
-   #:attr
+;;;   #:character-data
-   #:element
+;;;   #:attr
-   #:text
+;;;   #:element
-   #:comment
+;;;   #:text
-   #:cdata-section
+;;;   #:comment
-   #:document-type
+;;;   #:cdata-section
-   #:notation
+;;;   #:document-type
-   #:entity
+;;;   #:notation
-   #:entity-reference
+;;;   #:entity
-   #:processing-instruction
+;;;   #:entity-reference
+;;;   #:processing-instruction
+
    ;;
    #:items
+
    ;;
    #:node-p
    #:document-p

runes/package.lisp

@@ -61,6 +61,12 @@
            #:set-to-full-speed
            #:xstream-name))
 
+(defpackage :utf8-runes
+  (:use :cl)
+  (:export *utf8-runes-readtable*
+	   #:rune #:rod #:simple-rod #:rod-string #:rod= #:make-rod
+	   #:string-rod))
+
 (defpackage :runes-encoding
   (:use :cl :runes)
   (:export

runes/utf8.lisp

@@ -0,0 +1,44 @@
+;;; copyright (c) 2005 David Lichteblau <david@lichteblau.com>
+;;; License: Lisp-LGPL (See file COPYING for details).
+;;;
+;;; Rune emulation for the UTF-8-compatible DOM implementation.
+;;; Used only with 8 bit characters on non-unicode Lisps.
+
+(in-package :utf8-runes)
+
+(deftype rune () 'character)
+(deftype rod () '(vector rune))
+(deftype simple-rod () '(simple-array rune))
+
+#+(or)
+(definline rune (rod index)
+  (char rod index))
+
+#+(or)
+(defun (setf rune) (newval rod index)
+  (setf (char rod index) newval))
+
+(defun rod= (r s)
+  (string= r s))
+
+(defun rod-string (rod &optional default)
+  (declare (ignore default))
+  rod)
+
+(defun string-rod (string)
+  string)
+
+(defun make-rod (size)
+  (make-string size :element-type 'rune))
+
+(defun rune-reader (stream subchar arg)
+  (runes::rune-char (runes::rune-reader stream subchar arg)))
+
+(defun rod-reader (stream subchar arg)
+  (runes::rod-string (runes::rod-reader stream subchar arg)))
+
+(setf cxml-system::*utf8-runes-readtable*
+      (let ((rt (copy-readtable)))
+	(set-dispatch-macro-character #\# #\/ 'rune-reader rt)
+	(set-dispatch-macro-character #\# #\" 'rod-reader rt)
+	rt))

test/domtest.lisp

@@ -174,7 +174,7 @@
 
 (defun read-members (&optional (directory *directory*))
   (let* ((pathname (merge-pathnames "build/dom2-interfaces.xml" directory))
-         (builder (dom:make-dom-builder))
+         (builder (rune-dom:make-dom-builder))
          (library (dom:document-element (cxml:parse-file pathname builder)))
          (methods '())
          (fields '()))
@@ -209,9 +209,9 @@
     (t (error "unknown condition: ~A" element))))
 
 (defun equalsp (a b test)
-  (when (typep a 'dom-impl::named-node-map)
+  (when (dom:named-node-map-p a)
     (setf a (dom:items a)))
-  (when (typep b 'dom-impl::named-node-map)
+  (when (dom:named-node-map-p b)
     (setf b (dom:items b)))
   (if (and (typep a 'sequence) (typep b 'sequence))
       (null (set-exclusive-or (coerce a 'list) (coerce b 'list) :test test))
@@ -368,7 +368,7 @@
 
 (defun translate-implementation (elt)
   (with-attributes (|var|) elt
-    (maybe-setf (%intern |var|) `'dom-impl::implementation)))
+    (maybe-setf (%intern |var|) `'rune-dom:implementation)))
 
 (defun translate-length (load)
   ;; XXX Soweit ich sehe unterscheiden die Tests nicht zwischen
@@ -406,7 +406,7 @@
     (if (nullify |obj|)
 	(translate-member element)
 	(maybe-setf (%intern |var|)
-		    `(dom:has-feature 'dom-impl::implementation
+		    `(dom:has-feature 'rune-dom:implementation
 				      ,(parse-java-literal |feature|)
 				      ,(parse-java-literal |version|))))))
 
@@ -458,7 +458,7 @@
 (defun translate-assert-size (element)
   (with-attributes (|collection| |size|) element
     `(let ((collection ,(%intern |collection|)))
-       (when (typep collection 'dom-impl::named-node-map)
+       (when (dom:named-node-map-p collection)
          (setf collection (dom:items collection)))
        (assert (eql (length collection) ,(parse-java-literal |size|))))))
 
@@ -493,9 +493,9 @@
       (return
         `(block assert-domexception
            (handler-bind
-               ((dom-impl::dom-exception
+               ((rune-dom::dom-exception
                  (lambda (c)
-                   (when (eq (dom-impl::dom-exception-key c)
+                   (when (eq (rune-dom::dom-exception-key c)
                              ,(intern (tag-name c) :keyword))
                      (return-from assert-domexception)))))
              ,@(translate-body c)
@@ -506,7 +506,7 @@
      ,@(map-child-elements
         'list
         (lambda (exception)
-          `(when (eq (dom-impl::dom-exception-key c)
+          `(when (eq (rune-dom::dom-exception-key c)
                      ,(intern (runes:rod-string (dom:get-attribute exception "code"))
                               :keyword))
              ,@(translate-body exception)
@@ -516,7 +516,7 @@
 (defun translate-try (element)
   `(block try
      (handler-bind
-         ((dom-impl::dom-exception
+         ((rune-dom::dom-exception
            ,(translate-catch
              (do-child-elements (c element :name "catch") (return c))
              '(return-from try))))
@@ -556,7 +556,7 @@
 (defun translate-for-each (element)
   (with-attributes (|collection| |member|) element
     `(let ((collection ,(%intern |collection|)))
-       (when (typep collection 'dom-impl::named-node-map)
+       (when (dom:named-node-map-p collection)
          (setf collection (dom:items collection)))
        (map nil (lambda (,(%intern |member|)) ,@(translate-body element))
             collection))))
@@ -582,7 +582,7 @@
   (unless *fields*
     (multiple-value-setq (*methods* *fields*) (read-members)))
   (catch 'give-up
-    (let* ((builder (dom:make-dom-builder))
+    (let* ((builder (rune-dom:make-dom-builder))
            (cxml::*validate* nil)         ;dom1.dtd is buggy
            (test (dom:document-element (cxml:parse-file pathname builder)))
            title
@@ -631,7 +631,7 @@
   (setf name (runes:rod-string name))
   (cxml:parse-file
    (make-pathname :name name :type "xml" :defaults *files-directory*)
-   (dom:make-dom-builder)))
+   (rune-dom:make-dom-builder)))
 
 (defparameter *bad-tests*
     '("hc_elementnormalize2.xml"
@@ -654,7 +654,7 @@
          (nfailed 0))
     (flet ((parse (test-directory)
 	     (let* ((all-tests (merge-pathnames "alltests.xml" test-directory))
-		    (builder (dom:make-dom-builder))
+		    (builder (rune-dom:make-dom-builder))
 		    (suite (dom:document-element
 			    (cxml:parse-file all-tests builder)))
 		    (*files-directory*

test/xmlconf.lisp

@@ -76,7 +76,7 @@
 
 (defun run-all-tests (directory)
   (let* ((pathname (merge-pathnames "xmlconf.xml" directory))
-         (builder (dom:make-dom-builder))
+         (builder (rune-dom:make-dom-builder))
          (xmlconf (cxml:parse-file pathname builder))
          (ntried 0)
          (nfailed 0)
@@ -124,7 +124,7 @@
   (declare (ignore description))
   (let ((document (apply #'cxml:parse-file
                          pathname
-                         (dom:make-dom-builder)
+                         (rune-dom:make-dom-builder)
                          args)))
     (cond
       ((null output)
@@ -161,7 +161,7 @@
        (handler-case
            (progn
              (format t " [validating:]")
-             (cxml:parse-file pathname (dom:make-dom-builder) :validate t)
+             (cxml:parse-file pathname (rune-dom:make-dom-builder) :validate t)
              (error "validity error not detected")
              nil)
          (cxml:validity-error ()
@@ -174,7 +174,7 @@
   (handler-case
       (progn
          (format t " [not validating:]")
-	(cxml:parse-file pathname (dom:make-dom-builder) :validate nil)
+	(cxml:parse-file pathname (rune-dom:make-dom-builder) :validate nil)
 	(error "well-formedness violation not detected")
       nil)
     (cxml:well-formedness-violation ()
@@ -183,7 +183,7 @@
   (handler-case
       (progn
 	(format t " [validating:]")
-	(cxml:parse-file pathname (dom:make-dom-builder) :validate t)
+	(cxml:parse-file pathname (rune-dom:make-dom-builder) :validate t)
 	(error "well-formedness violation not detected")
       nil)
     (cxml:well-formedness-violation ()

xml/recoder.lisp

@@ -12,7 +12,7 @@
     ((recoder :initarg :recoder :accessor recoder)
      (chained-handler :initarg :chained-handler :accessor chained-handler)))
 
-(defun make-recoder (chained-handler &optional (recoder-fn #'rod-string))
+(defun make-recoder (chained-handler recoder-fn)
   (make-instance 'recoder
     :recoder recoder-fn
     :chained-handler chained-handler))

xml/unparse.lisp

@@ -639,6 +639,6 @@
   (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 'rod)))
+         (result (make-array n :element-type 'rune)))
     (map-into result #'code-rune buffer)
     result))