...
 
Commits (409)
--- orig/xml/xml-parse.lisp
+++ mod/xml/xml-parse.lisp
@@ -525,7 +525,10 @@
(declaim (type (simple-array rune (*))
*scratch-pad* *scratch-pad-2* *scratch-pad-3* *scratch-pad-4*))
-(defmacro with-scratch-pads (() &body body)
+(defmacro with-scratch-pads (#-clisp ()
+ ;; clisp does not allow () as macro argument list
+ #+clisp (&key &allow-other-keys)
+ &body body)
`(let ((*scratch-pad* (make-array 1024 :element-type 'rune))
(*scratch-pad-2* (make-array 1024 :element-type 'rune))
(*scratch-pad-3* (make-array 1024 :element-type 'rune))
Changes to Gilbert Baumann's Code
========================================
(Stand dieser Liste: patch-54)
base-0
Import of Closure's src/xml and src/glisp
Build system
----------------
patch-14
dom-builder.lsp braucht package.lisp
patch-17
xml-parse braucht dom-impl
patch-18
xml-parse braucht encodings
patch-19
xml-parse.lisp needs xml-stream.lisp
Interface changes
----------------
patch-2
export UNPARSE-DOCUMENT
Portability issues
----------------
patch-1
ACL port aktualisiert
patch-8
fixed more mlisp breakage
DOM fixes
----------------
patch-3
add dom:remove-child, dom:import-node
patch-6
fixed dom:remove-child
patch-7
strings->rods in set-attribute, too
patch-21
dom:item und dom:length fuer NodeList implementiert
patch-22
s/remove-atttribute/remove-attribute
patch-23
dom:remove-attribute-node korrigiert
patch-24
neu: dom:remove-attribute
patch-25
dom:normalize implementiert
patch-26
get-elements-by-tag-name fuer Element implementiert
patch-32
s/data/value/ fuer CHARACTER-DATA
patch-33
Aufruf von Setter-Methoden
patch-34
(setf value) nachgetragen
patch-35
(DOM:NODE-VALUE ATTRIBUTE) korrigiert
patch-36
writer fuer DOM:DATA
patch-37
(setf dom:node-value) implementiert
patch-43
hack: implemented CHILD-NODES for ENTITY-REFERENCE
patch-44
ENTITY-REFERENCE-Kinder als read-only markieren
patch-45
DOM-EXCEPTION implementiert
patch-46
fixed special cases in delete-data and replace-data
patch-47
delete-data: Arraytyp korrigiert
patch-48
DOM:INSERT-DATA implementiert
patch-49
bugfix: replace-data for count != (length arg)
patch-50
patch-46 nachgebessert: offset == length ist OK
patch-51
fixed special cases in dom:substring-data
patch-52
fixed patch-36, my (setf dom:data) implementation was bogus
xml-parse.lisp changes
----------------
patch-5
(assert (eql initial-speed 1)) in make-xstream
patch-20
added a forward declaration for *namespace-bindings*
patch-39
fix for thread safety in p/document
patch-41
Warnung ueber (nicht) redefinierte Attribute abschalten koennen
patch-54
call sax:comment; create comment nodes
String-Handling
----------------
patch-4
renamed dom to cdom, added string-dom
patch-38
diverse setter nachgetragen
Misc.
----------------
patch-9
print elements with their tag-name
patch-11
print attributes with name and value
patch-10
(reverted by patch-10)
patch-12
REVERT patch-10
domtest.cl
----------------
patch-27
alle DOM Level 1 CORE Tests uebersetzen koennen (mehr schlecht als recht)
patch-28
so, jetzt kompilieren die DOM-Tests auch (wenngleich zwei drittel noch fehlschlagen)
patch-29
einzelnen Test ausfuehren koennen
patch-30
<length/> workaround
patch-31
<equals/> fuer nicht-Strings
patch-40
?
patch-42
implementationAttribute-Probleme zwar ausgeben, aber kein WARN machen
patch-53
domtest fixes fuer <var/> und <nodeType>
xmlconf.cl
----------------
patch-13
Testfunktion fuer XML Conformance Test Suite
patch-15
run only tests for namespace-aware XML-1.0 parsers
patch-16
mit korrektem OUTPUT abgleichen
This diff is collapsed.
;;; XXX Die vielen verschiedenen Systeme hier sollten vielleicht
;;; Module eines grossen Systems CXML werden?
(defpackage :cxml-system
(:use :asdf :cl))
(in-package :cxml-system)
;; XXX das sollte natuerlich erst beim laden stattfinden
#+cmu
(require :gray-streams)
(defclass closure-source-file (cl-source-file) ())
#+sbcl
(defmethod perform :around ((o compile-op) (s closure-source-file))
;; shut up already. Correctness first.
(handler-bind ((sb-ext:compiler-note #'muffle-warning))
(call-next-method)))
(let (#+sbcl (*compile-print* nil))
(call-next-method))))
#-(or rune-is-character rune-is-octet)
(progn
(format t "~&;;; Checking for wide character support...")
(force-output)
(pushnew (dotimes (x 65536
(progn
(format t " ok, characters have at least 16 bits.~%")
:rune-is-character))
(unless (and (< x char-code-limit) (code-char x))
(format t " no, reverting to octet strings.~%")
(return :rune-is-octet)))
*features*))
#-rune-is-character
(format t "~&;;; Building cxml with (UNSIGNED-BYTE 16) RUNES~%")
(unless (find-package :glisp)
(defpackage :glisp))
#+rune-is-character
(format t "~&;;; Building cxml with CHARACTER RUNES~%")
(defsystem glisp
(defsystem runes
:default-component-class closure-source-file
:pathname (merge-pathnames
"glisp/"
"runes/"
(make-pathname :name nil :type nil :defaults *load-truename*))
:components
((:file dependent
((:file "package")
(:file dependent
:pathname
#+CLISP "dep-clisp"
#+(AND :CMU (NOT :PTHREAD)) "dep-cmucl"
#+sbcl "dep-sbcl"
#+(AND :CMU :PTHREAD) "dep-cmucl-dtc"
#+(and allegro allegro-v5.0) "dep-acl5"
#+(and allegro (not allegro-v5.0)) "dep-acl"
#+GCL "dep-gcl"
#-(or sbcl CLISP CMU allegro GCL) #.(error "Configure!"))
(:file "package"
:depends-on (dependent))
(:file "runes"
#+(and allegro-version>= (version>= 5.0)) "dep-acl5"
#+(and allegro-version>= (not (version>= 5.0))) "dep-acl"
#+openmcl "dep-openmcl"
#-(or sbcl CLISP CMU allegro openmcl) #.(error "Configure!")
:depends-on ("package"))
(:file runes
:pathname
#-rune-is-character "runes"
#+rune-is-character "characters"
:depends-on ("package" dependent))
(:file "util"
:depends-on ("package" dependent "runes"))
(:file "match"
:depends-on ("package" dependent "runes" "util"))))
(:file "syntax" :depends-on ("package" dependent runes))
(:file "util" :depends-on ("package" dependent))
(:file "encodings" :depends-on ("package"))
(:file "encodings-data" :depends-on ("package" "encodings"))
(:file "xstream"
:depends-on ("package" dependent "syntax" "encodings-data"))))
(asdf:defsystem :cxml
(asdf:defsystem :xml
:default-component-class closure-source-file
:pathname (merge-pathnames
"cxml/"
"xml/"
(make-pathname :name nil :type nil :defaults *load-truename*))
:components
((:file "package")
(:file "encodings" :depends-on ("package"))
(:file "encodings-data" :depends-on ("package" "encodings"))
(:file "sax-handler")
(:file "dompack")
(:file "dom-impl" :depends-on ("dompack"))
(:file "dom-builder" :depends-on ("dom-impl" "sax-handler"))
(:file "xml-stream" :depends-on ("package"))
(:file "characters" :depends-on ("package"))
(:file "xml-name-rune-p" :depends-on ("package"))
(:file "xml-parse" :depends-on ("package" "dompack" "sax-handler"))
(:file "xml-canonic" :depends-on ("package" "dompack" "xml-parse")))
:depends-on (:glisp))
(:file "split-sequence" :depends-on ("package"))
(:file "xml-parse" :depends-on ("package" "sax-handler" "split-sequence" "xml-name-rune-p" "characters"))
(:file "characters" :depends-on ("package"))
(:file "unparse" :depends-on ("xml-parse"))
(:file "xmls-compat" :depends-on ("xml-parse"))
(:file "recoder" :depends-on ("xml-parse"))
(:file "catalog" :depends-on ("xml-parse"))
(:file "sax-proxy" :depends-on ("xml-parse")))
:depends-on (:runes :puri))
(asdf:defsystem :dom
:default-component-class closure-source-file
:pathname (merge-pathnames
"dom/"
(make-pathname :name nil :type nil :defaults *load-truename*))
:components
((:file "package")
(:file "dom-impl" :depends-on ("package"))
(:file "dom-builder" :depends-on ("dom-impl"))
(:file "unparse" :depends-on ("package"))
(:file "simple-dom" :depends-on ("package"))
(:file "dom-sax" :depends-on ("package")))
:depends-on (:xml))
(asdf:defsystem :cxml-test
:default-component-class closure-source-file
:pathname (merge-pathnames
"test/"
(make-pathname :name nil :type nil :defaults *load-truename*))
:components ((:file "domtest") (:file "xmlconf"))
:depends-on (:xml :dom))
(asdf:defsystem :cxml :components () :depends-on (:dom :cxml-test))
;;;; dom-builder.lisp -- DOM-building SAX handler
;;;;
;;;; This file is part of the CXML parser, released under (L)LGPL.
;;;; See file COPYING for details.
;;;;
;;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
;;;; Author: Henrik Motakef <hmot@henrik-motakef.de>
;;;; Author: David Lichteblau <david@lichteblau.com>
;;;; Author: knowledgeTools Int. GmbH
;;; XXX this DOM builder knows too much about the specifics of the DOM
;;; implementation for my taste. While document creation is not specified
;;; by the DOM Level 1 spec, we shouldn't really be manually setting slots
;;; in other nodes IMHO.
;;;
;;; As a follow-up to that, the children list is created in the wrong order
;;; and then reversed. Is it really worth the improved speed to do this?
;;; Calling APPEND-NODE would be portable.
;;;
;;; In particular, that design choice has lead to other bugs, for example the
;;; PARENT slot has to be set manually, too. A DOM test finally showed
;;; that this had been forgotten for Text nodes and PIs.
;;;
;;; Opinions?
;;;
;;; -- David
;;; Now at least the children list isn't reversed anymore, because I changed
;;; the representation to be an extensible vector. Still its not clear to
;;; me whether the DOM Builder should be affected by such changes at all.
;;;
;;; -- David
;;; implementation for my taste. We need a sensible protocol for fast DOM
;;; building.
(in-package :dom-impl)
......@@ -41,13 +32,16 @@
(push document (element-stack handler))))
(defmethod sax:end-document ((handler dom-builder))
(setf (slot-value (document handler) 'entities) xml::*entities*)
(setf (slot-value (document handler) 'dtd) (cxml::dtd cxml::*ctx*))
(let ((doctype (dom:doctype (document handler))))
(when doctype
(setf (slot-value (dom:entities doctype) 'read-only-p) t)
(setf (slot-value (dom:notations doctype) 'read-only-p) t)))
(document handler))
(defmethod sax:entity-resolver ((handler dom-builder) resolver)
(setf (slot-value (document handler) 'entity-resolver) resolver))
(defmethod sax:start-dtd ((handler dom-builder) name publicid systemid)
(declare (ignore publicid systemid))
(let* ((document (document handler))
......@@ -62,17 +56,36 @@
(setf (slot-value doctype 'dom-impl::owner) document
(slot-value document 'dom-impl::doc-type) doctype)))
(defmethod sax:start-element ((handler dom-builder) namespace-uri local-name qname attributes)
(defmethod sax:start-element
((handler dom-builder) namespace-uri local-name qname attributes)
(declare (ignore namespace-uri local-name))
(with-slots (document element-stack) handler
(let ((element (dom:create-element document qname))
(parent (car element-stack)))
(let ((element (make-instance 'element
:tag-name qname
:owner document))
(parent (car element-stack))
(anodes '()))
(dolist (attr attributes)
(dom:set-attribute element (xml::attribute-qname attr) (xml::attribute-value attr)))
(let ((anode
(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)
(sax:attribute-specified-p attr))
(dom:append-child anode text)
(push anode anodes)))
(setf (slot-value element 'dom-impl::parent) parent)
(fast-push element (slot-value parent 'dom-impl::children))
(setf (slot-value element 'dom-impl::attributes)
(make-instance 'attribute-node-map
:items anodes
:element-type :attribute
:element element
:owner document))
(push element element-stack))))
(defmethod sax:end-element ((handler dom-builder) namespace-uri local-name qname)
(declare (ignore namespace-uri local-name qname))
(pop (element-stack handler)))
(defmethod sax:characters ((handler dom-builder) data)
......@@ -121,13 +134,29 @@
(defmethod sax:unparsed-entity-declaration
((handler dom-builder) name public-id system-id notation-name)
(set-entity handler name public-id system-id notation-name))
(defmethod sax:external-entity-declaration
((handler dom-builder) kind name public-id system-id)
(ecase kind
(:general (set-entity handler name public-id system-id nil))
(:parameter)))
(defmethod sax:internal-entity-declaration
((handler dom-builder) kind name value)
(declare (ignore value))
(ecase kind
(:general (set-entity handler name nil nil nil))
(:parameter)))
(defun set-entity (handler name pid sid notation)
(dom:set-named-item (dom:entities (dom:doctype (document handler)))
(make-instance 'dom-impl::entity
:owner (document handler)
:name name
:public-id public-id
:system-id system-id
:notation-name notation-name)))
:public-id pid
:system-id sid
:notation-name notation)))
(defmethod sax:notation-declaration
((handler dom-builder) name public-id system-id)
......
;;;; dom-impl.lisp -- Implementation of DOM 1 Core
;;;;
;;;; This file is part of the CXML parser, released under (L)LGPL.
;;;; See file COPYING for details.
;;;;
;;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
;;;; Author: David Lichteblau <david@lichteblau.com>
;;;; Author: knowledgeTools Int. GmbH
(defpackage :dom-impl
(:use :cl :runes))
......@@ -26,7 +35,8 @@
(defclass document (node)
((doc-type :initarg :doc-type :reader dom:doctype)
(entities :initform nil :reader entities)))
(dtd :initform nil :reader dtd)
(entity-resolver :initform nil)))
(defclass document-fragment (node)
())
......@@ -91,6 +101,9 @@
(read-only-p :initform nil :reader read-only-p)
(element-type :initarg :element-type)))
(defclass attribute-node-map (named-node-map)
((element :initarg :element)))
;;; Implementation
......@@ -115,18 +128,19 @@
(defun move (from to from-start to-start length)
;; like (setf (subseq to to-start (+ to-start length))
;; (subseq from from-start (+ from-start length)))
;; but without creating the garbage
;; but without creating the garbage.
;; Also, this is using AREF not ELT so that fill-pointers are ignored.
(if (< to-start from-start)
(loop
repeat length
for i from from-start
for j from to-start
do (setf (elt to j) (elt from i)))
do (setf (aref to j) (aref from i)))
(loop
repeat length
for i from (+ from-start length -1) by -1
for j from (+ to-start length -1) by -1
do (setf (elt to j) (elt from i)))))
for i downfrom (+ from-start length -1)
for j downfrom (+ to-start length -1)
do (setf (aref to j) (aref from i)))))
(defun adjust-vector-exponentially (vector new-dimension set-fill-pointer-p)
(let ((d (array-dimension vector 0)))
......@@ -175,14 +189,18 @@
(defmethod dom:create-element ((document document) tag-name)
(setf tag-name (rod tag-name))
(unless (xml::valid-name-p tag-name)
(unless (cxml::valid-name-p tag-name)
(dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string tag-name)))
(make-instance 'element
:tag-name tag-name
:owner document
:attributes (make-instance 'named-node-map
:element-type :attribute
(let ((result (make-instance 'element
:tag-name tag-name
:owner document)))
(setf (slot-value result 'attributes)
(make-instance 'attribute-node-map
:element-type :attribute
:owner document
:element result))
(add-default-attributes result)
result))
(defmethod dom:create-document-fragment ((document document))
(make-instance 'document-fragment
......@@ -209,7 +227,7 @@
(defmethod dom:create-processing-instruction ((document document) target data)
(setf target (rod target))
(setf data (rod data))
(unless (xml::valid-name-p target)
(unless (cxml::valid-name-p target)
(dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string target)))
(make-instance 'processing-instruction
:owner document
......@@ -218,7 +236,7 @@
(defmethod dom:create-attribute ((document document) name)
(setf name (rod name))
(unless (xml::valid-name-p name)
(unless (cxml::valid-name-p name)
(dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string name)))
(make-instance 'attribute
:name name
......@@ -227,7 +245,7 @@
(defmethod dom:create-entity-reference ((document document) name)
(setf name (rod name))
(unless (xml::valid-name-p name)
(unless (cxml::valid-name-p name)
(dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string name)))
(make-instance 'entity-reference
:name name
......@@ -590,7 +608,7 @@
(assert-writeable node)
(setq arg (rod arg))
(with-slots (value) node
(setf value (concatenate (type-of value) value arg)))
(setf value (concatenate 'rod value arg)))
(values))
(defmethod dom:delete-data ((node character-data) offset count)
......@@ -756,8 +774,38 @@
(unless (find old-attr items)
(dom-error :NOT_FOUND_ERR "Attribute not found."))
(setf items (remove old-attr items))
(maybe-add-default-attribute element (dom:name old-attr))
old-attr))
;; eek, defaulting:
(defun maybe-add-default-attribute (element name)
(let* ((dtd (dtd (slot-value element 'owner)))
(e (cxml::find-element (dom:tag-name element) dtd))
(a (when e (cxml::find-attribute e name))))
(when (and a (listp (cxml::attdef-default a)))
(add-default-attribute element a))))
(defun add-default-attributes (element)
(let* ((dtd (dtd (slot-value element 'owner)))
(e (cxml::find-element (dom:tag-name element) dtd)))
(when e
(dolist (a (cxml::elmdef-attributes e))
(when (and a (listp (cxml::attdef-default a)))
(add-default-attribute element a))))))
(defun add-default-attribute (element adef)
(let* ((value (second (cxml::attdef-default adef)))
(owner (slot-value element 'owner))
(anode (dom:create-attribute owner (cxml::attdef-name adef)))
(text (dom:create-text-node owner value)))
(setf (slot-value anode 'dom-impl::specified-p) nil)
(dom:append-child anode text)
(push anode (slot-value (dom:attributes element) 'items))))
(defmethod dom:remove-named-item :after ((self attribute-node-map) name)
(maybe-add-default-attribute (slot-value self 'element) name))
(defmethod dom:get-elements-by-tag-name ((element element) name)
(assert-writeable element)
(get-elements-by-tag-name-internal element name))
......@@ -779,7 +827,7 @@
(incf i))
((and previous (eq (dom:node-type previous) :text))
(setf (slot-value previous 'value)
(concatenate 'vector
(concatenate 'rod
(dom:data previous)
(dom:data child)))
(dom:remove-child n child)
......@@ -816,13 +864,13 @@
(defmethod initialize-instance :after ((instance entity-reference) &key)
(let* ((owner (dom:owner-document instance))
(entities (or (entities owner) xml::*entities*))
(children (xml::resolve-entity (dom:name instance) entities)))
(setf (slot-value instance 'children)
(make-node-list
(map 'vector
(lambda (node) (dom:import-node owner node t))
children))))
(handler (dom:make-dom-builder))
(resolver (slot-value owner 'entity-resolver)))
(unless resolver
(dom-error :NOT_SUPPORTED_ERR "No entity resolver registered."))
(setf (document handler) owner)
(push instance (element-stack handler))
(funcall resolver (dom:name instance) handler))
(labels ((walk (n)
(setf (slot-value n 'read-only-p) t)
(when (dom:element-p n)
......@@ -925,12 +973,13 @@
(import-node-internal 'document-fragment document node deep))
(defmethod dom:import-node ((document document) (node element) deep)
(let* ((attributes (make-instance 'named-node-map
(let* ((attributes (make-instance 'attribute-node-map
:element-type :attribute
:owner document))
(result (import-node-internal 'element document node deep
:attributes attributes
:tag-name (dom:tag-name node))))
(setf (slot-value attributes 'element) result)
(dolist (attribute (dom:items (dom:attributes node)))
(when (or (dom:specified attribute) *clone-not-import*)
(dom:set-attribute result (dom:name attribute) (dom:value attribute))))
......@@ -981,3 +1030,19 @@
(defmethod dom:clone-node ((node node) deep)
(let ((*clone-not-import* t))
(dom:import-node (dom:owner-document node) node deep)))
;;; Erweiterung
(defun dom:create-document (&optional document-element)
;; Um ein neues Dokumentenobject zu erzeugen, parsen wir einfach ein
;; Dummydokument.
(let* ((handler (dom:make-dom-builder))
(cxml::*ctx* (cxml::make-context :handler handler))
(result
(progn
(sax:start-document handler)
(sax:end-document handler))))
(when document-element
(dom:append-child result (dom:import-node result document-element t)))
result))
;;;; dom-sax.lisp -- DOM walker
;;;;
;;;; This file is part of the CXML parser, released under (L)LGPL.
;;;; See file COPYING for details.
;;;;
;;;; Author: David Lichteblau <david@lichteblau.com>
;;;; Copyright (c) 2004 knowledgeTools Int. GmbH
(in-package :dom-impl)
(defun dom:map-document
......@@ -8,15 +16,20 @@
(let ((doctype (dom:doctype document)))
(when doctype
(sax:start-dtd handler (dom:name doctype) nil nil)
(let ((ns (dom:notations doctype)))
;; need notations for canonical mode 2
(let* ((ns (dom:notations doctype))
(a (make-array (dom:length ns))))
;; get them
(dotimes (k (dom:length ns))
(let ((n (dom:item ns k)))
(sax:notation-declaration handler
(dom:name n)
(dom:public-id n)
(dom:system-id n)))
;; fixme: entities!
)
(setf (elt a k) (dom:item ns k)))
;; sort them
(setf a (sort a #'rod< :key #'dom:name))
(loop for n across a do
(sax:notation-declaration handler
(dom:name n)
(dom:public-id n)
(dom:system-id n)))
;; fixme: entities!
(sax:end-dtd handler))))
(labels ((walk (node)
(dom:do-node-list (child (dom:child-nodes node))
......@@ -53,8 +66,8 @@
(when (and (or defaultp (dom:specified a))
(or xmlnsp (not (cxml::xmlns-attr-p (dom:name a)))))
(push
(cxml::make-attribute :qname (dom:name a)
:value (dom:value a)
:specified-p (dom:specified a))
(sax:make-attribute :qname (dom:name a)
:value (dom:value a)
:specified-p (dom:specified a))
results)))
(reverse results)))
;;;; package.lisp -- Paketdefinition
;;;;
;;;; This file is part of the CXML parser, released under (L)LGPL.
;;;; See file COPYING for details.
(in-package :cl-user)
(defpackage :dom
......@@ -108,4 +113,6 @@
#:named-node-map-p
#:map-node-list
#:do-node-list))
#:do-node-list
#:create-document
#:map-document))
(in-package :xml)
(in-package :cxml)
;;; Implementation of a simple but faster DOM.
......
;;; XXX delete this file
;;;
;;; A wrapper package STRING-DOM around the ordinary DOM presents
;;; DOMString as Lisp STRING. This was a workaround until
;;; RUNE-IS-CHARACTER was implemented, but might still be useful on
;;; Lisps without Unicode support.
;;;
;;; Copyright (c) 2004 knowledgeTools Int. GmbH
(defpackage :string-dom
(:use))
......
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XML; readtable: runes; Encoding: utf-8; -*-
;;; ---------------------------------------------------------------------------
;;; Title: Dump canonic XML according to J.Clark
;;; Created: 1999-09-09
;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
;;; License: LGPL (See file COPYING for details).
;;; ---------------------------------------------------------------------------
;;; © copyright 1999 by Gilbert Baumann
;;; 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 :xml)
;;
;; | Canonical XML
;; | =============
;; |
;; | This document defines a subset of XML called canonical XML. The
;; | intended use of canonical XML is in testing XML processors, as a
;; | representation of the result of parsing an XML document.
;; |
;; | Every well-formed XML document has a unique structurally equivalent
;; | canonical XML document. Two structurally equivalent XML documents have
;; | a byte-for-byte identical canonical XML document. Canonicalizing an
;; | XML document requires only information that an XML processor is
;; | required to make available to an application.
;; |
;; | A canonical XML document conforms to the following grammar:
;; |
;; | CanonXML ::= Pi* element Pi*
;; | element ::= Stag (Datachar | Pi | element)* Etag
;; | Stag ::= '<' Name Atts '>'
;; | Etag ::= '</' Name '>'
;; | Pi ::= '<?' Name ' ' (((Char - S) Char*)? - (Char* '?>' Char*)) '?>'
;; | Atts ::= (' ' Name '=' '"' Datachar* '"')*
;; | Datachar ::= '&amp;' | '&lt;' | '&gt;' | '&quot;'
;; | | '&#9;'| '&#10;'| '&#13;'
;; | | (Char - ('&' | '<' | '>' | '"' | #x9 | #xA | #xD))
;; | Name ::= (see XML spec)
;; | Char ::= (see XML spec)
;; | S ::= (see XML spec)
;; |
;; | Attributes are in lexicographical order (in Unicode bit order).
;; |
;; | A canonical XML document is encoded in UTF-8.
;; |
;; | Ignorable white space is considered significant and is treated
;; | equivalently to data.
;;
;; -- James Clark (jjc@jclark.com)
(defvar *quux*) ;!!!BIG HACK!!!
(defun unparse-document (doc sink)
(map nil (rcurry #'unparse-node sink) (dom:child-nodes doc)))
(defun unparse-node (node sink)
(cond ((dom:element-p node)
(write-rune #/< sink)
(write-rod (dom:tag-name node) sink)
;; atts
(let ((atts (sort (copy-list (dom:items (dom:attributes node)))
#'rod< :key #'dom:name)))
(dolist (a atts)
(write-rune #/space sink)
(write-rod (dom:name a) sink)
(write-rune #/= sink)
(write-rune #/\" sink)
(let ((*quux* nil))
(map nil (lambda (c) (unparse-datachar c sink)) (dom:value a)))
(write-rune #/\" sink)))
(write-rod '#.(string-rod ">") sink)
(dom:do-node-list (k (dom:child-nodes node))
(unparse-node k sink))
(write-rod '#.(string-rod "</") sink)
(write-rod (dom:tag-name node) sink)
(write-rod '#.(string-rod ">") sink))
((dom:processing-instruction-p node)
(unless (rod-equal (dom:target node) '#.(string-rod "xml"))
(write-rod '#.(string-rod "<?") sink)
(write-rod (dom:target node) sink)
(write-rune #/space sink)
(write-rod (dom:data node) sink)
(write-rod '#.(string-rod "?>") sink) ))
((dom:text-node-p node)
(let ((*quux* nil))
(map nil (lambda (c) (unparse-datachar c sink))
(dom:data node))))
((dom:comment-p node))
(t
(error "Oops in unparse: ~S." node))))
(defun unparse-datachar (c sink)
(cond ((rune= c #/&) (write-rod '#.(string-rod "&amp;") sink))
((rune= c #/<) (write-rod '#.(string-rod "&lt;") sink))
((rune= c #/>) (write-rod '#.(string-rod "&gt;") sink))
((rune= c #/\") (write-rod '#.(string-rod "&quot;") sink))
((rune= c #/U+0009) (write-rod '#.(string-rod "&#9;") sink))
((rune= c #/U+000A) (write-rod '#.(string-rod "&#10;") sink))
((rune= c #/U+000D) (write-rod '#.(string-rod "&#13;") sink))
(t
(write-rune c sink))))
(defun write-rod (rod sink)
(let ((*quux* nil))
(map nil (lambda (c) (write-rune c sink)) rod)))
(defun write-rune (rune sink)
(let ((code (rune-code rune)))
(cond ((<= #xD800 code #xDBFF)
(setf *quux* code))
((<= #xDC00 code #xDFFF)
(let ((q (logior (ash (- *quux* #xD7C0) 10) (- code #xDC00))))
(write-rune-0 q sink))
(setf *quux* nil))
(t
(write-rune-0 code sink)))))
(defun write-rune-0 (code sink)
(labels ((wr (x)
(write-char (code-char x) sink)))
(cond ((<= #x00000000 code #x0000007F)
(wr code))
((<= #x00000080 code #x000007FF)
(wr (logior #b11000000 (ldb (byte 5 6) code)))
(wr (logior #b10000000 (ldb (byte 6 0) code))))
((<= #x00000800 code #x0000FFFF)
(wr (logior #b11100000 (ldb (byte 4 12) code)))
(wr (logior #b10000000 (ldb (byte 6 6) code)))
(wr (logior #b10000000 (ldb (byte 6 0) code))))
((<= #x00010000 code #x001FFFFF)
(wr (logior #b11110000 (ldb (byte 3 18) code)))
(wr (logior #b10000000 (ldb (byte 6 12) code)))
(wr (logior #b10000000 (ldb (byte 6 6) code)))
(wr (logior #b10000000 (ldb (byte 6 0) code))))
((<= #x00200000 code #x03FFFFFF)
(wr (logior #b11111000 (ldb (byte 2 24) code)))
(wr (logior #b10000000 (ldb (byte 6 18) code)))
(wr (logior #b10000000 (ldb (byte 6 12) code)))
(wr (logior #b10000000 (ldb (byte 6 6) code)))
(wr (logior #b10000000 (ldb (byte 6 0) code))))
((<= #x04000000 code #x7FFFFFFF)
(wr (logior #b11111100 (ldb (byte 1 30) code)))
(wr (logior #b10000000 (ldb (byte 6 24) code)))
(wr (logior #b10000000 (ldb (byte 6 18) code)))
(wr (logior #b10000000 (ldb (byte 6 12) code)))
(wr (logior #b10000000 (ldb (byte 6 6) code)))
(wr (logior #b10000000 (ldb (byte 6 0) code)))))))
This diff is collapsed.
This diff is collapsed.
;;; copyright (c) 2004 knowledgeTools Int. GmbH
;;; Author of this version: David Lichteblau <david@knowledgetools.de>
;;;
;;; License: LGPL (See file COPYING for details).
;;;
;;; derived from runes.lisp, (c) copyright 1998,1999 by Gilbert Baumann
(in-package :glisp)
(deftype rune () 'base-char)
(deftype rod () 'base-string)
(deftype simple-rod () 'simple-string)
(defsubst rune (rod index)
(char rod index))
(defun (setf rune) (new rod index)
(setf (char rod index) new))
(defsubst %rune (rod index)
(aref (the simple-string rod) (the fixnum index)))
(defsubst (setf %rune) (new rod index)
(setf (aref (the simple-string rod) (the fixnum index)) new))
(defun rod-capitalize (rod)
(string-upcase rod))
(defsubst code-rune (x) (code-char x))
(defsubst rune-code (x) (char-code x))
(defsubst rune= (x y)
(char= x y))
(defun rune-downcase (rune)
(char-downcase rune))
(defsubst rune-upcase (rune)
(char-upcase rune))
(defun rune-upper-case-letter-p (rune)
(upper-case-p rune))
(defun rune-lower-case-letter-p (rune)
(lower-case-p rune))
(defun rune-equal (x y)
(char-equal x y))
(defun rod-downcase (rod)
(string-downcase rod))
(defun rod-upcase (rod)
(string-upcase rod))
(defsubst white-space-rune-p (char)
(or (char= char #\tab)
(char= char #.(code-char 10)) ;Linefeed
(char= char #.(code-char 13)) ;Carriage Return
(char= char #\space)))
(defsubst digit-rune-p (char &optional (radix 10))
(digit-char-p char radix))
(defun rod (x)
(cond
((stringp x) x)
((symbolp x) (string x))
((characterp x) (string x))
((vectorp x) (coerce x 'string))
((integerp x) (string (code-char x)))
(t (error "Cannot convert ~S to a ~S" x 'rod))))
(defun runep (x)
(characterp x))
(defun sloopy-rod-p (x)
(stringp x))
(defun rod= (x y)
(string= x y))
(defun rod-equal (x y)
(string-equal x y))
(defsubst make-rod (size)
(make-string size))
(defun char-rune (char)
char)
(defun rune-char (rune &optional default)
(declare (ignore default))
rune)
(defun rod-string (rod &optional (default-char #\?))
(declare (ignore default-char))
rod)
(defun string-rod (string)
string)
;;;;
(defun rune<= (rune &rest more-runes)
(loop
for (a b) on (cons rune more-runes)
while b
always (char<= a b)))
(defun rune>= (rune &rest more-runes)
(loop
for (a b) on (cons rune more-runes)
while b
always (char>= a b)))
(defun rodp (object)
(stringp object))
(defun really-rod-p (object)
(stringp object))
(defun rod-subseq (source start &optional (end (length source)))
(unless (stringp source)
(error "~S is not of type ~S." source 'rod))
(subseq source start end))
(defun rod-subseq* (source start &optional (end (length source)))
(rod-subseq source start end))
(defun rod< (rod1 rod2)
(string< rod1 rod2))
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: GLISP; -*-
;;; ---------------------------------------------------------------------------
;;; Title: ACL-4.3 dependent stuff + fixups
;;; Created: 1999-05-25 22:33
;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
;;; License: GPL (See file COPYING for details).
;;; ---------------------------------------------------------------------------
;;; (c) copyright 1998,1999 by Gilbert Baumann
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
(export 'glisp::read-byte-sequence :glisp)
(export 'glisp::read-char-sequence :glisp)
(export 'glisp::run-unix-shell-command :glisp)
(export 'glisp::mp/process-run-function :glisp)
(export 'glisp::mp/process-kill :glisp)
(export 'glisp::mp/seize-lock :glisp)
(export 'glisp::mp/release-lock :glisp)
(export 'glisp::mp/transfer-lock-owner :glisp)
(export 'glisp::mp/current-process :glisp)
(export 'glisp::mp/process-yield :glisp)
(export 'glisp::mp/process-wait :glisp)
(export 'glisp::getenv :glisp)
(defun glisp::read-byte-sequence (&rest ap)
(apply #'read-sequence ap))
(defun glisp::read-char-sequence (&rest ap)
(apply #'read-sequence ap))
#+ALLEGRO-V5.0
(defun glisp::open-inet-socket (hostname port)
(values
(socket:make-socket :remote-host hostname
:remote-port port
:format :binary)
:byte))
#-ALLEGRO-V5.0
(defun glisp::open-inet-socket (hostname port)
(values
(ipc:open-network-stream :host hostname
:port port
:element-type '(unsigned-byte 8)
:class 'EXCL::BIDIRECTIONAL-BINARY-SOCKET-STREAM)
:byte))
#||
(defun glisp::make-server-socket (port &key (element-type '(unsigned-byte 8)))
)
||#
(defun glisp::mp/make-lock (&key name)
(mp:make-process-lock :name name))
(defmacro glisp::mp/with-lock ((lock) &body body)
`(mp:with-process-lock (,lock)
,@body))
(defmacro glisp::with-timeout ((&rest options) &body body)
`(mp:with-timeout ,options . ,body))
(defun glisp::g/make-string (length &rest options)
(apply #'make-array length :element-type 'base-char options))
(defun glisp:run-unix-shell-command (cmd)
(excl:shell cmd))
(defun glisp:mp/process-run-function (name fn &rest args)
(apply #'mp:process-run-function name fn args))
(defun glisp:mp/process-kill (proc)
(mp:process-kill proc))
(defun glisp:mp/current-process ()
sys:*current-process*)
(defun glisp::mp/seize-lock (lock &key whostate)
whostate
(mp:process-lock lock))
(defun glisp::mp/transfer-lock-owner (lock old-process new-process)
(assert (eql (mp:process-lock-locker lock) old-process))
(setf (mp:process-lock-locker lock) new-process)
)
(defun glisp::mp/release-lock (lock)
(mp:process-unlock lock))
(defun glisp::mp/process-yield (&optional process-to-run)
(mp:process-allow-schedule process-to-run))
(defun glisp::mp/process-wait (whostate predicate)
(mp:process-wait whostate predicate))
;; ACL is incapable to define compiler macros on (setf foo)
;; Unfortunately it is also incapable to declaim such functions inline.
;; So we revoke the DEFUN hack from dep-gcl here.
(defmacro glisp::defsubst (fun args &body body)
(if (and (consp fun) (eq (car fun) 'setf))
(let ((fnam (intern (concatenate 'string "(SETF " (symbol-name (cadr fun)) ")")
(symbol-package (cadr fun)))))
`(progn
(defsetf ,(cadr fun) (&rest ap) (new-value) (list* ',fnam new-value ap))
(glisp::defsubst ,fnam ,args .,body)))
`(progn
(defun ,fun ,args .,body)
(define-compiler-macro ,fun (&rest .args.)
(cons '(lambda ,args .,body)
.args.)))))
(defun glisp::getenv (string)
(sys:getenv string))
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; Encoding: utf-8; -*-
;;; ---------------------------------------------------------------------------
;;; Title: ACL-5.0 dependent stuff + fixups
;;; Created: 1999-05-25 22:32
;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
;;; License: GPL (See file COPYING for details).
;;; ---------------------------------------------------------------------------
;;; (c) copyright 1998,1999 by Gilbert Baumann
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;; Changes
;;; =======
;;; When Who What
;;; ---------------------------------------------------------------------------
;;; 2002-01-04 GB spend BLOCK for DEFSUBST
;;; 1999-08-31 SES Stig Erik Sandø <stig@ii.uib.no>
;;;
;;; Changed #+allegro-v5.0 to
;;; #+(and allegro-version>= (version>= 5))
;;;
(export 'glisp::read-byte-sequence :glisp)
(export 'glisp::read-char-sequence :glisp)
(export 'glisp::run-unix-shell-command :glisp)
(export 'glisp::mp/process-run-function :glisp)
(export 'glisp::mp/process-kill :glisp)
(export 'glisp::mp/current-process :glisp)
(export 'glisp::mp/seize-lock :glisp)
(export 'glisp::mp/release-lock :glisp)
(export 'glisp::mp/process-yield :glisp)
(export 'glisp::mp/process-wait :glisp)
(export 'glisp::getenv :glisp)
(export 'glisp::make-server-socket :glisp)
(defun glisp::mp/seize-lock (lock &key whostate)
whostate
(mp:process-lock lock))
(defun glisp::mp/release-lock (lock)
(mp:process-unlock lock))
(defun glisp::read-byte-sequence (&rest ap)
(apply #'read-sequence ap))
(defun glisp::read-char-sequence (&rest ap)
(apply #'read-sequence ap))
#+(and allegro-version>= (version>= 5))
(defun glisp::open-inet-socket (hostname port)
(values
(socket:make-socket :remote-host hostname
:remote-port port
:format :binary)
:byte))
(defun glisp::make-server-socket (port &key (element-type '(unsigned-byte 8)))
(socket:make-socket :connect :passive
:local-port port
:format (cond ((subtypep element-type '(unsigned-byte 8))
:binary)
((subtypep element-type 'character)
:text)
(t
(error "Unknown element type: ~S." element-type)))))
(defun glisp::accept-connection/low (socket)
(values
(socket:accept-connection socket :wait t)
:byte))
#-(and allegro-version>= (version>= 5))
(defun glisp::open-inet-socket (hostname port)
(values
(ipc:open-network-stream :host hostname
:port port
:element-type '(unsigned-byte 8)
:class 'EXCL::BIDIRECTIONAL-BINARY-SOCKET-STREAM)
:byte))
(defun glisp::mp/make-lock (&key name)
(mp:make-process-lock :name name))
(defmacro glisp::mp/with-lock ((lock) &body body)
`(mp:with-process-lock (,lock)
,@body))
(defmacro glisp::with-timeout ((&rest options) &body body)
`(mp:with-timeout ,options . ,body))
(defun glisp::g/make-string (length &rest options)
(apply #'make-array length :element-type 'base-char options))
(defun glisp:run-unix-shell-command (cmd)
(excl:shell cmd))
(defparameter glisp::*inherited-vars*
'(*terminal-io* *standard-input* *standard-output* *error-output* *trace-output* *query-io* *debug-io*))
(defparameter glisp::*inherited-vars* nil)
(defun glisp:mp/process-run-function (name fn &rest args)
(mp:process-run-function
name
(lambda (vars vals fn args)
(progv vars vals
(apply fn args)))
glisp::*inherited-vars* (mapcar #'symbol-value glisp::*inherited-vars*)
fn args))
(defun glisp:mp/current-process ()
sys:*current-process*)
(defun glisp::mp/process-yield (&optional process-to-run)
(mp:process-allow-schedule process-to-run))
(defun glisp::mp/process-wait (whostate predicate)
(mp:process-wait whostate predicate))
(defun glisp::mp/process-kill (proc)
(mp:process-kill proc))
;; ACL is incapable to define compiler macros on (setf foo)
;; Unfortunately it is also incapable to declaim such functions inline.
;; So we revoke the DEFUN hack from dep-gcl here.
(defmacro glisp::defsubst (fun args &body body)
(if (and (consp fun) (eq (car fun) 'setf))
(let ((fnam (intern (concatenate 'string "(SETF " (symbol-name (cadr fun)) ")")
(symbol-package (cadr fun)))))
`(progn
(defsetf ,(cadr fun) (&rest ap) (new-value) (list* ',fnam new-value ap))
(glisp::defsubst ,fnam ,args .,body)))
(labels ((declp (x)
(and (consp x) (eq (car x) 'declare))))
`(progn
(defun ,fun ,args .,body)
(define-compiler-macro ,fun (&rest .args.)
(cons '(lambda ,args
,@(remove-if-not #'declp body)
(block ,fun
,@(remove-if #'declp body)))
.args.))))))
(defun glisp::getenv (string)
(sys:getenv string))
\ No newline at end of file
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*-
;;; ---------------------------------------------------------------------------
;;; Title: CLISP dependent stuff + fixups
;;; Created: 1999-05-25 22:32
;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
;;; License: GPL (See file COPYING for details).
;;; ---------------------------------------------------------------------------
;;; (c) copyright 1999 by Gilbert Baumann
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
(in-package :CL-USER)
(eval-when (compile load eval)
(if (fboundp 'cl::define-compiler-macro)
(pushnew 'define-compiler-macro *features*)))
(setq lisp:*load-paths* '(#P"./"))
(import 'lisp:read-byte-sequence :glisp)
(export 'lisp:read-byte-sequence :glisp)
(import 'lisp:read-char-sequence :glisp)
(export 'lisp:read-char-sequence :glisp)
(export 'glisp::compile-file :glisp)
(export 'glisp::run-unix-shell-command :glisp)
(export 'glisp::make-server-socket :glisp)
#||
(export 'glisp::read-byte-sequence :glisp)
(defun glisp::read-byte-sequence (sequence input &key (start 0) (end (length sequence)))
(let (c (i start))
(loop
(cond ((= i end) (return i)))
(setq c (read-byte input nil :eof))
(cond ((eql c :eof) (return i)))
(setf (aref sequence i) c)
(incf i) )))
||#
(defun glisp::compile-file (&rest ap)
(and (apply #'compile-file ap)
(apply #'compile-file-pathname ap)))
(defmacro glisp::with-timeout ((&rest ignore) &body body)
(declare (ignore ignore))
`(progn
,@body))
(defun glisp::open-inet-socket (hostname port)
(values
(lisp:socket-connect port hostname)
:byte))
(defun glisp:make-server-socket (port)
(lisp:socket-server port))
(defun glisp::accept-connection/low (socket)
(let ((stream (lisp:socket-accept socket)))
(setf (stream-element-type stream) '(unsigned-byte 8))
(values
stream
:byte)))
(defun glisp::g/make-string (length &rest options)
(apply #'make-array length
:element-type
'#.(cond ((stringp (make-array 1 :element-type 'string-char))
'string-char)
((stringp (make-array 1 :element-type 'base-char))
'base-char)
(t
(error "What is the string element type of the day?")))
options))
(defun glisp:run-unix-shell-command (command)
(lisp:shell command))
#+DEFINE-COMPILER-MACRO
(cl:define-compiler-macro ldb (bytespec value &whole whole)
(let (pos size)
(cond ((and (consp bytespec)
(= (length bytespec) 3)
(eq (car bytespec) 'byte)
(constantp (setq size (second bytespec)))
(constantp (setq pos (third bytespec))))
`(logand ,(if (eql pos 0) value `(ash ,value (- ,pos)))
(1- (ash 1 ,size))))
(t
whole))))
#-DEFINE-COMPILER-MACRO
(progn
(export 'glisp::define-compiler-macro :glisp)
(defmacro glisp::define-compiler-macro (name args &body body)
(declare (ignore args body))
`(progn
',name)))
#||