OSCL/CXML
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

removed files left over from "cvs import"

Browse Source
This commit is contained in:
david
2005-03-13 18:05:37 +00:00
parent d6ca7664f4
commit 3c5ada1d05
29 changed files with 0 additions and 7841 deletions
Download Patch File Download Diff File Expand all files Collapse all files

46
xml/dom-builder.lisp
View File

@ -1,46 +0,0 @@
(in-package :dom-impl)
(export 'dom-builder)
(defclass dom-builder ()
((document :initform nil :accessor document)
(element-stack :initform '() :accessor element-stack)))
(defmethod sax:start-document ((handler dom-builder))
(let ((document (make-instance 'dom-impl::document))
(doctype (make-instance 'dom-impl::document-type
:notations (make-hash-table :test #'equalp))))
(setf (slot-value document 'dom-impl::owner) document
(slot-value document 'dom-impl::doc-type) doctype)
(setf (document handler) document)
(push document (element-stack handler))))
(defmethod sax:end-document ((handler dom-builder))
(setf (slot-value (document handler) 'children )
(nreverse (slot-value (document handler) 'children)))
(document handler))
(defmethod sax:start-element ((handler dom-builder) namespace-uri local-name qname attributes)
(with-slots (document element-stack) handler
(let ((element (dom:create-element document qname))
(parent (car element-stack)))
(dolist (attr attributes)
(dom:set-attribute element (xml::attribute-qname attr) (xml::attribute-value attr)))
(setf (slot-value element 'dom-impl::parent) parent)
(push element (slot-value parent 'dom-impl::children))
(push element element-stack))))
(defmethod sax:end-element ((handler dom-builder) namespace-uri local-name qname)
(let ((element (pop (element-stack handler))))
(setf (slot-value element 'dom-impl::children)
(nreverse (slot-value element 'dom-impl::children)))))
(defmethod sax:characters ((handler dom-builder) data)
(with-slots (document element-stack) handler
(let ((node (dom:create-text-node document data)))
(push node (slot-value (car element-stack) 'dom-impl::children)))))
(defmethod sax:processing-instruction ((handler dom-builder) target data)
(with-slots (document element-stack) handler
(let ((node (dom:create-processing-instruction document target data)))
(push node (slot-value (car element-stack) 'dom-impl::children)))))

512
xml/dom-impl.lisp
View File

@ -1,512 +0,0 @@
(defpackage :dom-impl
(:use :glisp))
(in-package :dom-impl)
;; Classes
(defclass node ()
((parent :initarg :parent :initform nil)
(children :initarg :children :initform nil)
(owner :initarg :owner :initform nil)))
(defclass document (node)
((doc-type :initarg :doc-type :reader dom:doctype)))
(defclass document-fragment (node)
())
(defclass character-data (node)
((data :initarg :data :reader dom:data)))
(defclass attribute (node)
((name :initarg :name :reader dom:name)
(value :initarg :value :reader dom:value)
(specified-p :initarg :specified-p :reader dom:specified)))
(defclass element (node)
((tag-name :initarg :tag-name :reader dom:tag-name)
(attributes :initarg :attributes :reader dom:attributes
:initform (make-instance 'named-node-map))))
(defclass text (character-data)
())
(defclass comment (character-data)
())
(defclass cdata-section (text)
())
(defclass document-type (node)
((name :initarg :name :reader dom:name)
(entities :initarg :entities :reader dom:entities)
(notations :initarg :notations :reader dom:notations)))
(defclass notation (node)
((name :initarg :name :reader dom:name)
(public-id :initarg :public-id :reader dom:public-id)
(system-id :initarg :system-id :reader dom:system-id)))
(defclass entity (node)
((name :initarg :name :reader dom:name)
(public-id :initarg :public-id :reader dom:public-id)
(system-id :initarg :system-id :reader dom:system-id)
(notation-name :initarg :notation-name :reader dom:notation-name)))
(defclass entity-reference (node)
((name :initarg :name :reader dom:name)))
(defclass processing-instruction (node)
((target :initarg :target :reader dom:target)
(data :initarg :data :reader dom:data)))
(defclass named-node-map ()
((items :initarg :items :reader dom:items
:initform nil) ))
;;; Implementation
;; document-fragment protocol
;; document protocol
(defmethod dom:implementation ((document document))
'implementation)
(defmethod dom:document-element ((document document))
(dolist (k (dom:child-nodes document))
(cond ((typep k 'element)
(return k)))))
(defmethod dom:create-element ((document document) tag-name)
(setf tag-name (rod tag-name))
(make-instance 'element
:tag-name tag-name
:owner document))
(defmethod dom:create-document-fragment ((document document))
(make-instance 'document-fragment
:owner document))
(defmethod dom:create-text-node ((document document) data)
(setf data (rod data))
(make-instance 'text
:data data
:owner document))
(defmethod dom:create-comment ((document document) data)
(setf data (rod data))
(make-instance 'comment
:data data
:owner document))
(defmethod dom:create-cdata-section ((document document) data)
(setf data (rod data))
(make-instance 'cdata-section
:data data
:owner document))
(defmethod dom:create-processing-instruction ((document document) target data)
(setf target (rod target))
(setf data (rod data))
(make-instance 'processing-instruction
:owner document
:target target
:data data))
(defmethod dom:create-attribute ((document document) name)
(setf name (rod name))
(make-instance 'attribute
:name name
:specified-p nil ;???
:owner document))
(defmethod dom:create-entity-reference ((document document) name)
(setf name (rod name))
(make-instance 'entity-reference
:name name
:owner document))
(defmethod dom:get-elements-by-tag-name ((document document) tag-name)
(setf tag-name (rod tag-name))
(let ((result nil))
(setf tag-name (rod tag-name))
(let ((wild-p (rod= tag-name '#.(string-rod "*"))))
(labels ((walk (n)
(when (and (dom:element-p n)
(or wild-p (tag-name-eq tag-name (dom:node-name n))))
(push n result))
(mapc #'walk (dom:child-nodes n))))
(walk document)
(reverse result)))))
;;; Node
(defmethod dom:parent-node ((node node))
(slot-value node 'parent))
(defmethod dom:child-nodes ((node node))
(slot-value node 'children))
(defmethod dom:first-child ((node node))
(car (slot-value node 'children)))
(defmethod dom:last-child ((node node))
(car (last (slot-value node 'children))))
(defmethod dom:previous-sibling ((node node))
(with-slots (parent) node
(when parent
(with-slots (children) parent
(do ((q children (cdr q)))
((null (cdr q)) niL)
(cond ((eq (cadr q) node)
(return (car q)))))))))
(defmethod dom:next-sibling ((node node))
(with-slots (parent) node
(when parent
(with-slots (children) parent
(do ((q children (cdr q)))
((null (cdr q)) niL)
(cond ((eq (car q) node)
(return (cadr q)))))))))
(defmethod dom:owner-document ((node node))
(slot-value node 'owner))
(defun ensure-valid-insertion-request (node new-child)
(unless (can-adopt-p node new-child)
;; HIERARCHY_REQUEST_ERR
(error "~S cannot adopt ~S." node new-child))
(unless (eq (dom:owner-document node)
(dom:owner-document new-child))
;; WRONG_DOCUMENT_ERR
(error "~S cannot adopt ~S, since it was created by a different document."
node new-child))
(with-slots (children) node
(unless (null (slot-value new-child 'parent))
(cond ((eq (slot-value new-child 'parent)
node)
;; remove it first
(setf children (delete new-child children)))
(t
;; otherwise it is an error.
;; GB_INTEGRITY_ERR
(error "~S is already adopted." new-child)))) ))
(defmethod dom:insert-before ((node node) (new-child node) (ref-child t))
(ensure-valid-insertion-request node new-child)
(with-slots (children) node
(cond ((eq (car children) ref-child)
(setf (slot-value new-child 'parent) node)
(setf children (cons new-child children)))
(t
(do ((q children (cdr q)))
((null (cdr q))
(cond ((null ref-child)
(setf (slot-value new-child 'parent) node)
(setf (cdr q) (cons new-child nil)))
(t
;; NOT_FOUND_ERR
(error "~S is no child of ~S." ref-child node))))
(cond ((eq (cadr q) ref-child)
(setf (slot-value new-child 'parent) node)
(setf (cdr q) (cons new-child (cdr q)))
(return))))))
new-child))
(defmethod dom:insert-before ((node node) (fragment document-fragment) ref-child)
(dolist (child (dom:child-nodes fragment))
(dom:insert-before node child ref-child))
fragment)
(defmethod dom:replace-child ((node node) (new-child node) (old-child node))
(ensure-valid-insertion-request node new-child)
(with-slots (children) node
(do ((q children (cdr q)))
((null q)
;; NOT_FOUND_ERR
(error "~S is no child of ~S." old-child node))
(cond ((eq (car q) old-child)
(setf (car q) new-child)
(setf (slot-value new-child 'parent) node)
(setf (slot-value old-child 'parent) nil)
(return))))
old-child))
(defmethod dom:append-child ((node node) (new-child node))
(ensure-valid-insertion-request node new-child)
(with-slots (children) node
(setf children (nconc children (list new-child)))
(setf (slot-value new-child 'parent) node)
new-child))
(defmethod dom:has-child-nodes ((node node))
(not (null (slot-value node 'children))))
(defmethod dom:append-child ((node node) (new-child document-fragment))
(dolist (child (dom:child-nodes new-child))
(dom:append-child node child))
new-child)
;; was auf node noch implemetiert werden muss:
;; - node-type
;; - can-adopt-p
;; - ggf attributes
;; - node-name
;; - node-value
;; node-name
(defmethod dom:node-name ((self document))
'#.(string-rod "#document"))
(defmethod dom:node-name ((self document-fragment))
'#.(string-rod "#document-fragment"))
(defmethod dom:node-name ((self text))
'#.(string-rod "#text"))
(defmethod dom:node-name ((self cdata-section))
'#.(string-rod "#cdata-section"))
(defmethod dom:node-name ((self comment))
'#.(string-rod "#comment"))
(defmethod dom:node-name ((self attribute))
(dom:name self))
(defmethod dom:node-name ((self element))
(dom:tag-name self))
(defmethod dom:node-name ((self document-type))
(dom:name self))
(defmethod dom:node-name ((self notation))
(dom:name self))
(defmethod dom:node-name ((self entity))
(dom:name self))
(defmethod dom:node-name ((self entity-reference))
(dom:name self))
(defmethod dom:node-name ((self processing-instruction))
(dom:target self))
;; node-type
(defmethod dom:node-type ((self document)) :document)
(defmethod dom:node-type ((self document-fragment)) :document-fragment)
(defmethod dom:node-type ((self text)) :text)
(defmethod dom:node-type ((self comment)) :comment)
(defmethod dom:node-type ((self cdata-section)) :cdata-section)
(defmethod dom:node-type ((self attribute)) :attribute)
(defmethod dom:node-type ((self element)) :element)
(defmethod dom:node-type ((self document-type)) :document-type)
(defmethod dom:node-type ((self notation)) :notation)
(defmethod dom:node-type ((self entity)) :entity)
(defmethod dom:node-type ((self entity-reference)) :entity-reference)
(defmethod dom:node-type ((self processing-instruction)) :processing-instruction)
;; node-value
(defmethod dom:node-value ((self document)) nil)
(defmethod dom:node-value ((self document-fragment)) nil)
(defmethod dom:node-value ((self character-data)) (dom:data self))
(defmethod dom:node-value ((self attribute)) (dom:name self))
(defmethod dom:node-value ((self element)) nil)
(defmethod dom:node-value ((self document-type)) nil)
(defmethod dom:node-value ((self notation)) nil)
(defmethod dom:node-value ((self entity)) nil)
(defmethod dom:node-value ((self entity-reference)) nil)
(defmethod dom:node-value ((self processing-instruction)) (dom:data self))
;; attributes
;; (gibt es nur auf element)
(defmethod dom:attributes ((self node))
nil)
;; dann fehlt noch can-adopt und attribute conventions fuer adoption
;;; NAMED-NODE-MAP
(defmethod dom:get-named-item ((self named-node-map) name)
(setf name (rod name))
(with-slots (items) self
(dolist (k items nil)
(cond ((rod= name (dom:node-name k))
(return k))))))
(defmethod dom:set-named-item ((self named-node-map) arg)
(let ((name (dom:node-name arg)))
(with-slots (items) self
(dolist (k items (progn (setf items (cons arg items))nil))
(cond ((rod= name (dom:node-name k))
(setf items (cons arg (delete k items)))
(return k)))))))
(defmethod dom:remove-named-item ((self named-node-map) name)
(setf name (rod name))
(with-slots (items) self
(dolist (k items nil)
(cond ((rod= name (dom:node-name k))
(setf items (delete k items))
(return k))))))
(defmethod dom:length ((self named-node-map))
(with-slots (items) self
(length items)))
(defmethod dom:item ((self named-node-map) index)
(with-slots (items) self
(elt items index)))
;;; CHARACTER-DATA
(defmethod dom:length ((node character-data))
(length (slot-value node 'value)))
(defmethod dom:substring-data ((node character-data) offset count)
(subseq (slot-value node 'value) offset (+ offset count)))
(defmethod dom:append-data ((node character-data) arg)
(setq arg (rod arg))
(with-slots (value) node
(setf value (concatenate (type-of value) value arg)))
(values))
(defmethod dom:delete-data ((node character-data) offset count)
(with-slots (value) node
(let ((new (make-array (- (length value) count) :element-type (type-of value))))
(replace new value
:start1 0 :end1 offset
:start2 0 :end2 offset)
(replace new value
:start1 offset :end1 (length new)
:start2 (+ offset count) :end2 (length value))
(setf value new)))
(values))
(defmethod dom:replace-data ((node character-data) offset count arg)
(setf arg (rod arg))
(with-slots (value) node
(replace value arg
:start1 offset :end1 (+ offset count)
:start2 0 :end2 count))
(values))
;;; ATTR
;; hmm... value muss noch entities lesen und text-nodes in die hierarchie h<>ngen.
(defmethod (setf dom:value) (new-value (node attribute))
(setf (slot-value node 'value) (rod new-value)))
;;; ELEMENT
(defmethod dom:get-attribute-node ((element element) name)
(dom:get-named-item (dom:attributes element) name))
(defmethod dom:set-attribute-node ((element element) (new-attr attribute))
(dom:set-named-item (dom:attributes element) new-attr))
(defmethod dom:get-attribute ((element element) name)
(let ((a (dom:get-attribute-node element name)))
(if a
(dom:value a)
nil)))
(defmethod dom:set-attribute ((element element) name value)
(with-slots (owner) element
(dom:set-attribute-node
element (make-instance 'attribute
:owner owner
:name name
:value value
:specified-p t))
(values)))
(defmethod dom:remove-attribute-node ((element element) (old-attr attribute))
(let ((res (dom:remove-named-item element (dom:name old-attr))))
(if res
res
;; NOT_FOUND_ERR
(error "Attribute not found."))))
(defmethod dom:get-elements-by-tag-name ((element element) name)
name
(error "Not implemented."))
(defmethod dom:normalize ((element element))
(error "Not implemented.") )
;;; TEXT
(defmethod dom:split-text ((text text) offset)
offset
(error "Not implemented."))
;;; COMMENT -- nix
;;; CDATA-SECTION -- nix
;;; DOCUMENT-TYPE -- missing
;;; NOTATION -- nix
;;; ENTITY -- nix
;;; ENTITY-REFERENCE -- nix
;;; PROCESSING-INSTRUCTION -- nix
;; Notbehelf!
(defun can-adopt-p (x y) x y t)
;;; predicates
(defmethod dom:node-p ((object node)) t)
(defmethod dom:node-p ((object t)) nil)
(defmethod dom:document-p ((object document)) t)
(defmethod dom:document-p ((object t)) nil)
(defmethod dom:document-fragment-p ((object document-fragment)) t)
(defmethod dom:document-fragment-p ((object t)) nil)
(defmethod dom:character-data-p ((object character-data)) t)
(defmethod dom:character-data-p ((object t)) nil)
(defmethod dom:attribute-p ((object attribute)) t)
(defmethod dom:attribute-p ((object t)) nil)
(defmethod dom:element-p ((object element)) t)
(defmethod dom:element-p ((object t)) nil)
(defmethod dom:text-node-p ((object text)) t)
(defmethod dom:text-node-p ((object t)) nil)
(defmethod dom:comment-p ((object comment)) t)
(defmethod dom:comment-p ((object t)) nil)
(defmethod dom:cdata-section-p ((object cdata-section)) t)
(defmethod dom:cdata-section-p ((object t)) nil)
(defmethod dom:document-type-p ((object document-type)) t)
(defmethod dom:document-type-p ((object t)) nil)
(defmethod dom:notation-p ((object notation)) t)
(defmethod dom:notation-p ((object t)) nil)
(defmethod dom:entity-p ((object entity)) t)
(defmethod dom:entity-p ((object t)) nil)
(defmethod dom:entity-reference-p ((object entity-reference)) t)
(defmethod dom:entity-reference-p ((object t)) nil)
(defmethod dom:processing-instruction-p ((object processing-instruction)) t)
(defmethod dom:processing-instruction-p ((object t)) nil)
(defmethod dom:named-node-map-p ((object named-node-map)) t)
(defmethod dom:named-node-map-p ((object t)) nil)

102
xml/dompack.lisp
View File

@ -1,102 +0,0 @@
(defpackage :dom
(:use)
(:export
;; methods
#:has-feature
#:doctype
#:implementation
#:document-element
#:create-element
#:create-document-fragment
#:create-text-node
#:create-comment
#:create-cdata-section
#:create-processing-instruction
#:create-attribute
#:create-entity-reference
#:get-elements-by-tag-name
#:node-name
#:node-value
#:node-type
#:parent-node
#:child-nodes
#:first-child
#:last-child
#:previous-sibling
#:next-sibling
#:attributes
#:owner-document
#:insert-before
#:replace-child
#:remove-child
#:append-child
#:has-child-nodes
#:clone-node
#:item
#:length
#:get-named-item
#:set-named-item
#:remove-named-item
#:data
#:substring-data
#:append-data
#:insert-data
#:delete-data
#:replace-data
#:name
#:specified
#:value
#:tag-name
#:get-attribute
#:set-attribute
#:remove-atttribute
#:get-attribute-node
#:set-attribute-node
#:remove-attribute-node
#:normalize
#:split-text
#:entities
#:notations
#:public-id
#:system-id
#:notation-name
#:target
;; protocol classes
#:dom-implementation
#:document-fragment
#:document
#:node
#:node-list
#:named-node-map
#:character-data
#:attr
#:element
#:text
#:comment
#:cdata-section
#:document-type
#:notation
#:entity
#:entity-reference
#:processing-instruction
;;
#:items
;;
#:node-p
#:document-p
#:document-fragment-p
#:character-data-p
#:attribute-p
#:element-p
#:text-node-p
#:comment-p
#:cdata-section-p
#:document-type-p
#:notation-p
#:entity-p
#:entity-reference-p
#:processing-instruction-p
#:named-node-map-p
))

568
xml/encodings-data.lisp
View File

@ -1,568 +0,0 @@
(in-package :encoding)
(progn
(add-name :us-ascii "ANSI_X3.4-1968")
(add-name :us-ascii "iso-ir-6")
(add-name :us-ascii "ANSI_X3.4-1986")
(add-name :us-ascii "ISO_646.irv:1991")
(add-name :us-ascii "ASCII")
(add-name :us-ascii "ISO646-US")
(add-name :us-ascii "US-ASCII")
(add-name :us-ascii "us")
(add-name :us-ascii "IBM367")
(add-name :us-ascii "cp367")
(add-name :us-ascii "csASCII")
(add-name :iso-8859-1 "ISO_8859-1:1987")
(add-name :iso-8859-1 "iso-ir-100")
(add-name :iso-8859-1 "ISO_8859-1")
(add-name :iso-8859-1 "ISO-8859-1")
(add-name :iso-8859-1 "latin1")
(add-name :iso-8859-1 "l1")
(add-name :iso-8859-1 "IBM819")
(add-name :iso-8859-1 "CP819")
(add-name :iso-8859-1 "csISOLatin1")
(add-name :iso-8859-2 "ISO_8859-2:1987")
(add-name :iso-8859-2 "iso-ir-101")
(add-name :iso-8859-2 "ISO_8859-2")
(add-name :iso-8859-2 "ISO-8859-2")
(add-name :iso-8859-2 "latin2")
(add-name :iso-8859-2 "l2")
(add-name :iso-8859-2 "csISOLatin2")
(add-name :iso-8859-3 "ISO_8859-3:1988")
(add-name :iso-8859-3 "iso-ir-109")
(add-name :iso-8859-3 "ISO_8859-3")
(add-name :iso-8859-3 "ISO-8859-3")
(add-name :iso-8859-3 "latin3")
(add-name :iso-8859-3 "l3")
(add-name :iso-8859-3 "csISOLatin3")
(add-name :iso-8859-4 "ISO_8859-4:1988")
(add-name :iso-8859-4 "iso-ir-110")
(add-name :iso-8859-4 "ISO_8859-4")
(add-name :iso-8859-4 "ISO-8859-4")
(add-name :iso-8859-4 "latin4")
(add-name :iso-8859-4 "l4")
(add-name :iso-8859-4 "csISOLatin4")
(add-name :iso-8859-6 "ISO_8859-6:1987")
(add-name :iso-8859-6 "iso-ir-127")
(add-name :iso-8859-6 "ISO_8859-6")
(add-name :iso-8859-6 "ISO-8859-6")
(add-name :iso-8859-6 "ECMA-114")
(add-name :iso-8859-6 "ASMO-708")
(add-name :iso-8859-6 "arabic")
(add-name :iso-8859-6 "csISOLatinArabic")
(add-name :iso-8859-7 "ISO_8859-7:1987")
(add-name :iso-8859-7 "iso-ir-126")
(add-name :iso-8859-7 "ISO_8859-7")
(add-name :iso-8859-7 "ISO-8859-7")
(add-name :iso-8859-7 "ELOT_928")
(add-name :iso-8859-7 "ECMA-118")
(add-name :iso-8859-7 "greek")
(add-name :iso-8859-7 "greek8")
(add-name :iso-8859-7 "csISOLatinGreek")
(add-name :iso-8859-8 "ISO_8859-8:1988")
(add-name :iso-8859-8 "iso-ir-138")
(add-name :iso-8859-8 "ISO_8859-8")
(add-name :iso-8859-8 "ISO-8859-8")
(add-name :iso-8859-8 "hebrew")
(add-name :iso-8859-8 "csISOLatinHebrew")
(add-name :iso-8859-5 "ISO_8859-5:1988")
(add-name :iso-8859-5 "iso-ir-144")
(add-name :iso-8859-5 "ISO_8859-5")
(add-name :iso-8859-5 "ISO-8859-5")
(add-name :iso-8859-5 "cyrillic")
(add-name :iso-8859-5 "csISOLatinCyrillic")
(add-name :iso-8859-9 "ISO_8859-9:1989")
(add-name :iso-8859-9 "iso-ir-148")
(add-name :iso-8859-9 "ISO_8859-9")
(add-name :iso-8859-9 "ISO-8859-9")
(add-name :iso-8859-9 "latin5")
(add-name :iso-8859-9 "l5")
(add-name :iso-8859-9 "csISOLatin5")
(add-name :iso-8859-15 "ISO_8859-15")
(add-name :iso-8859-15 "ISO-8859-15")
(add-name :iso-8859-14 "ISO_8859-14")
(add-name :iso-8859-14 "ISO-8859-14")
(add-name :koi8-r "KOI8-R")
(add-name :koi8-r "csKOI8R")
(add-name :utf-8 "UTF-8")
(add-name :utf-16 "UTF-16")
(add-name :ucs-4 "ISO-10646-UCS-4")
(add-name :ucs-4 "UCS-4")
(add-name :ucs-2 "ISO-10646-UCS-2")
(add-name :ucs-2 "UCS-2") )
(progn
(define-encoding :iso-8859-1
(make-simple-8-bit-encoding
:charset (find-charset :iso-8859-1)))
(define-encoding :iso-8859-2
(make-simple-8-bit-encoding
:charset (find-charset :iso-8859-2)))
(define-encoding :iso-8859-3
(make-simple-8-bit-encoding
:charset (find-charset :iso-8859-3)))
(define-encoding :iso-8859-4
(make-simple-8-bit-encoding
:charset (find-charset :iso-8859-4)))
(define-encoding :iso-8859-5
(make-simple-8-bit-encoding
:charset (find-charset :iso-8859-5)))
(define-encoding :iso-8859-6
(make-simple-8-bit-encoding
:charset (find-charset :iso-8859-6)))
(define-encoding :iso-8859-7
(make-simple-8-bit-encoding
:charset (find-charset :iso-8859-7)))
(define-encoding :iso-8859-8
(make-simple-8-bit-encoding
:charset (find-charset :iso-8859-8)))
(define-encoding :iso-8859-14
(make-simple-8-bit-encoding
:charset (find-charset :iso-8859-14)))
(define-encoding :iso-8859-15
(make-simple-8-bit-encoding
:charset (find-charset :iso-8859-15)))
(define-encoding :koi8-r
(make-simple-8-bit-encoding
:charset (find-charset :koi8-r)))
(define-encoding :utf-8 :utf-8)
)
(progn
(define-8-bit-charset :iso-8859-1
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o24x |# #x00A0 #x00A1 #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7
#| #o25x |# #x00A8 #x00A9 #x00AA #x00AB #x00AC #x00AD #x00AE #x00AF
#| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x00B4 #x00B5 #x00B6 #x00B7
#| #o27x |# #x00B8 #x00B9 #x00BA #x00BB #x00BC #x00BD #x00BE #x00BF
#| #o30x |# #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7
#| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
#| #o32x |# #x00D0 #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x00D7
#| #o33x |# #x00D8 #x00D9 #x00DA #x00DB #x00DC #x00DD #x00DE #x00DF
#| #o34x |# #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7
#| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
#| #o36x |# #x00F0 #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7
#| #o37x |# #x00F8 #x00F9 #x00FA #x00FB #x00FC #x00FD #x00FE #x00FF)
(define-8-bit-charset :iso-8859-2
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o24x |# #x00A0 #x0104 #x02D8 #x0141 #x00A4 #x013D #x015A #x00A7
#| #o25x |# #x00A8 #x0160 #x015E #x0164 #x0179 #x00AD #x017D #x017B
#| #o26x |# #x00B0 #x0105 #x02DB #x0142 #x00B4 #x013E #x015B #x02C7
#| #o27x |# #x00B8 #x0161 #x015F #x0165 #x017A #x02DD #x017E #x017C
#| #o30x |# #x0154 #x00C1 #x00C2 #x0102 #x00C4 #x0139 #x0106 #x00C7
#| #o31x |# #x010C #x00C9 #x0118 #x00CB #x011A #x00CD #x00CE #x010E
#| #o32x |# #x0110 #x0143 #x0147 #x00D3 #x00D4 #x0150 #x00D6 #x00D7
#| #o33x |# #x0158 #x016E #x00DA #x0170 #x00DC #x00DD #x0162 #x00DF
#| #o34x |# #x0155 #x00E1 #x00E2 #x0103 #x00E4 #x013A #x0107 #x00E7
#| #o35x |# #x010D #x00E9 #x0119 #x00EB #x011B #x00ED #x00EE #x010F
#| #o36x |# #x0111 #x0144 #x0148 #x00F3 #x00F4 #x0151 #x00F6 #x00F7
#| #o37x |# #x0159 #x016F #x00FA #x0171 #x00FC #x00FD #x0163 #x02D9)
(define-8-bit-charset :iso-8859-3
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o24x |# #x00A0 #x0126 #x02D8 #x00A3 #x00A4 #xFFFF #x0124 #x00A7
#| #o25x |# #x00A8 #x0130 #x015E #x011E #x0134 #x00AD #xFFFF #x017B
#| #o26x |# #x00B0 #x0127 #x00B2 #x00B3 #x00B4 #x00B5 #x0125 #x00B7
#| #o27x |# #x00B8 #x0131 #x015F #x011F #x0135 #x00BD #xFFFF #x017C
#| #o30x |# #x00C0 #x00C1 #x00C2 #xFFFF #x00C4 #x010A #x0108 #x00C7
#| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
#| #o32x |# #xFFFF #x00D1 #x00D2 #x00D3 #x00D4 #x0120 #x00D6 #x00D7
#| #o33x |# #x011C #x00D9 #x00DA #x00DB #x00DC #x016C #x015C #x00DF
#| #o34x |# #x00E0 #x00E1 #x00E2 #xFFFF #x00E4 #x010B #x0109 #x00E7
#| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
#| #o36x |# #xFFFF #x00F1 #x00F2 #x00F3 #x00F4 #x0121 #x00F6 #x00F7
#| #o37x |# #x011D #x00F9 #x00FA #x00FB #x00FC #x016D #x015D #x02D9)
(define-8-bit-charset :iso-8859-4
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o24x |# #x00A0 #x0104 #x0138 #x0156 #x00A4 #x0128 #x013B #x00A7
#| #o25x |# #x00A8 #x0160 #x0112 #x0122 #x0166 #x00AD #x017D #x00AF
#| #o26x |# #x00B0 #x0105 #x02DB #x0157 #x00B4 #x0129 #x013C #x02C7
#| #o27x |# #x00B8 #x0161 #x0113 #x0123 #x0167 #x014A #x017E #x014B
#| #o30x |# #x0100 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x012E
#| #o31x |# #x010C #x00C9 #x0118 #x00CB #x0116 #x00CD #x00CE #x012A
#| #o32x |# #x0110 #x0145 #x014C #x0136 #x00D4 #x00D5 #x00D6 #x00D7
#| #o33x |# #x00D8 #x0172 #x00DA #x00DB #x00DC #x0168 #x016A #x00DF
#| #o34x |# #x0101 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x012F
#| #o35x |# #x010D #x00E9 #x0119 #x00EB #x0117 #x00ED #x00EE #x012B
#| #o36x |# #x0111 #x0146 #x014D #x0137 #x00F4 #x00F5 #x00F6 #x00F7
#| #o37x |# #x00F8 #x0173 #x00FA #x00FB #x00FC #x0169 #x016B #x02D9)
(define-8-bit-charset :iso-8859-5
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o24x |# #x00A0 #x0401 #x0402 #x0403 #x0404 #x0405 #x0406 #x0407
#| #o25x |# #x0408 #x0409 #x040A #x040B #x040C #x00AD #x040E #x040F
#| #o26x |# #x0410 #x0411 #x0412 #x0413 #x0414 #x0415 #x0416 #x0417
#| #o27x |# #x0418 #x0419 #x041A #x041B #x041C #x041D #x041E #x041F
#| #o30x |# #x0420 #x0421 #x0422 #x0423 #x0424 #x0425 #x0426 #x0427
#| #o31x |# #x0428 #x0429 #x042A #x042B #x042C #x042D #x042E #x042F
#| #o32x |# #x0430 #x0431 #x0432 #x0433 #x0434 #x0435 #x0436 #x0437
#| #o33x |# #x0438 #x0439 #x043A #x043B #x043C #x043D #x043E #x043F
#| #o34x |# #x0440 #x0441 #x0442 #x0443 #x0444 #x0445 #x0446 #x0447
#| #o35x |# #x0448 #x0449 #x044A #x044B #x044C #x044D #x044E #x044F
#| #o36x |# #x2116 #x0451 #x0452 #x0453 #x0454 #x0455 #x0456 #x0457
#| #o37x |# #x0458 #x0459 #x045A #x045B #x045C #x00A7 #x045E #x045F)
(define-8-bit-charset :iso-8859-6
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
#| #o06x |# #x0660 #x0661 #x0662 #x0663 #x0664 #x0665 #x0666 #x0667
#| #o07x |# #x0668 #x0669 #x003A #x003B #x003C #x003D #x003E #x003F
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o24x |# #x00A0 #xFFFF #xFFFF #xFFFF #x00A4 #xFFFF #xFFFF #xFFFF
#| #o25x |# #xFFFF #xFFFF #xFFFF #xFFFF #x060C #x00AD #xFFFF #xFFFF
#| #o26x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o27x |# #xFFFF #xFFFF #xFFFF #x061B #xFFFF #xFFFF #xFFFF #x061F
#| #o30x |# #xFFFF #x0621 #x0622 #x0623 #x0624 #x0625 #x0626 #x0627
#| #o31x |# #x0628 #x0629 #x062A #x062B #x062C #x062D #x062E #x062F
#| #o32x |# #x0630 #x0631 #x0632 #x0633 #x0634 #x0635 #x0636 #x0637
#| #o33x |# #x0638 #x0639 #x063A #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o34x |# #x0640 #x0641 #x0642 #x0643 #x0644 #x0645 #x0646 #x0647
#| #o35x |# #x0648 #x0649 #x064A #x064B #x064C #x064D #x064E #x064F
#| #o36x |# #x0650 #x0651 #x0652 #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o37x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF)
(define-8-bit-charset :iso-8859-7
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o24x |# #x00A0 #x02BD #x02BC #x00A3 #xFFFF #xFFFF #x00A6 #x00A7
#| #o25x |# #x00A8 #x00A9 #xFFFF #x00AB #x00AC #x00AD #xFFFF #x2015
#| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x0384 #x0385 #x0386 #x00B7
#| #o27x |# #x0388 #x0389 #x038A #x00BB #x038C #x00BD #x038E #x038F
#| #o30x |# #x0390 #x0391 #x0392 #x0393 #x0394 #x0395 #x0396 #x0397
#| #o31x |# #x0398 #x0399 #x039A #x039B #x039C #x039D #x039E #x039F
#| #o32x |# #x03A0 #x03A1 #xFFFF #x03A3 #x03A4 #x03A5 #x03A6 #x03A7
#| #o33x |# #x03A8 #x03A9 #x03AA #x03AB #x03AC #x03AD #x03AE #x03AF
#| #o34x |# #x03B0 #x03B1 #x03B2 #x03B3 #x03B4 #x03B5 #x03B6 #x03B7
#| #o35x |# #x03B8 #x03B9 #x03BA #x03BB #x03BC #x03BD #x03BE #x03BF
#| #o36x |# #x03C0 #x03C1 #x03C2 #x03C3 #x03C4 #x03C5 #x03C6 #x03C7
#| #o37x |# #x03C8 #x03C9 #x03CA #x03CB #x03CC #x03CD #x03CE #xFFFF)
(define-8-bit-charset :iso-8859-8
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o24x |# #x00A0 #xFFFF #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7
#| #o25x |# #x00A8 #x00A9 #x00D7 #x00AB #x00AC #x00AD #x00AE #x203E
#| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x00B4 #x00B5 #x00B6 #x00B7
#| #o27x |# #x00B8 #x00B9 #x00F7 #x00BB #x00BC #x00BD #x00BE #xFFFF
#| #o30x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o31x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o32x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o33x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #x2017
#| #o34x |# #x05D0 #x05D1 #x05D2 #x05D3 #x05D4 #x05D5 #x05D6 #x05D7
#| #o35x |# #x05D8 #x05D9 #x05DA #x05DB #x05DC #x05DD #x05DE #x05DF
#| #o36x |# #x05E0 #x05E1 #x05E2 #x05E3 #x05E4 #x05E5 #x05E6 #x05E7
#| #o37x |# #x05E8 #x05E9 #x05EA #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF)
(define-8-bit-charset :iso-8859-9
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o24x |# #x00A0 #x00A1 #x00A2 #x00A3 #x00A4 #x00A5 #x00A6 #x00A7
#| #o25x |# #x00A8 #x00A9 #x00AA #x00AB #x00AC #x00AD #x00AE #x00AF
#| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x00B4 #x00B5 #x00B6 #x00B7
#| #o27x |# #x00B8 #x00B9 #x00BA #x00BB #x00BC #x00BD #x00BE #x00BF
#| #o30x |# #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7
#| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
#| #o32x |# #x011E #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x00D7
#| #o33x |# #x00D8 #x00D9 #x00DA #x00DB #x00DC #x0130 #x015E #x00DF
#| #o34x |# #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7
#| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
#| #o36x |# #x011F #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7
#| #o37x |# #x00F8 #x00F9 #x00FA #x00FB #x00FC #x0131 #x015F #x00FF)
(define-8-bit-charset :iso-8859-14
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o24x |# #x00A0 #x1E02 #x1E03 #x00A3 #x010A #x010B #x1E0A #x00A7
#| #o25x |# #x1E80 #x00A9 #x1E82 #x1E0B #x1EF2 #x00AD #x00AE #x0178
#| #o26x |# #x1E1E #x1E1F #x0120 #x0121 #x1E40 #x1E41 #x00B6 #x1E56
#| #o27x |# #x1E81 #x1E57 #x1E83 #x1E60 #x1EF3 #x1E84 #x1E85 #x1E61
#| #o30x |# #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7
#| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
#| #o32x |# #x0174 #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x1E6A
#| #o33x |# #x00D8 #x00D9 #x00DA #x00DB #x00DC #x00DD #x0176 #x00DF
#| #o34x |# #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7
#| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
#| #o36x |# #x0175 #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x1E6B
#| #o37x |# #x00F8 #x00F9 #x00FA #x00FB #x00FC #x00FD #x0177 #x00FF)
(define-8-bit-charset :iso-8859-15
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
#| #o20x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o21x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o22x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o23x |# #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF #xFFFF
#| #o24x |# #x00A0 #x00A1 #x00A2 #x00A3 #x20AC #x00A5 #x0160 #x00A7
#| #o25x |# #x0161 #x00A9 #x00AA #x00AB #x00AC #x00AD #x00AE #x00AF
#| #o26x |# #x00B0 #x00B1 #x00B2 #x00B3 #x017D #x00B5 #x00B6 #x00B7
#| #o27x |# #x017E #x00B9 #x00BA #x00BB #x0152 #x0153 #x0178 #x00BF
#| #o30x |# #x00C0 #x00C1 #x00C2 #x00C3 #x00C4 #x00C5 #x00C6 #x00C7
#| #o31x |# #x00C8 #x00C9 #x00CA #x00CB #x00CC #x00CD #x00CE #x00CF
#| #o32x |# #x00D0 #x00D1 #x00D2 #x00D3 #x00D4 #x00D5 #x00D6 #x00D7
#| #o33x |# #x00D8 #x00D9 #x00DA #x00DB #x00DC #x00DD #x00DE #x00DF
#| #o34x |# #x00E0 #x00E1 #x00E2 #x00E3 #x00E4 #x00E5 #x00E6 #x00E7
#| #o35x |# #x00E8 #x00E9 #x00EA #x00EB #x00EC #x00ED #x00EE #x00EF
#| #o36x |# #x00F0 #x00F1 #x00F2 #x00F3 #x00F4 #x00F5 #x00F6 #x00F7
#| #o37x |# #x00F8 #x00F9 #x00FA #x00FB #x00FC #x00FD #x00FE #x00FF)
(define-8-bit-charset :koi8-r
#| #o00x |# #x0000 #x0001 #x0002 #x0003 #x0004 #x0005 #x0006 #x0007
#| #o01x |# #x0008 #x0009 #x000A #x000B #x000C #x000A #x000E #x000F
#| #o02x |# #x0010 #x0011 #x0012 #x0013 #x0014 #x0015 #x0016 #x0017
#| #o03x |# #x0018 #x0019 #x001A #x001B #x001C #x001D #x001E #x001F
#| #o04x |# #x0020 #x0021 #x0022 #x0023 #x0024 #x0025 #x0026 #x0027
#| #o05x |# #x0028 #x0029 #x002A #x002B #x002C #x002D #x002E #x002F
#| #o06x |# #x0030 #x0031 #x0032 #x0033 #x0034 #x0035 #x0036 #x0037
#| #o07x |# #x0038 #x0039 #x003A #x003B #x003C #x003D #x003E #x003F
#| #o10x |# #x0040 #x0041 #x0042 #x0043 #x0044 #x0045 #x0046 #x0047
#| #o11x |# #x0048 #x0049 #x004A #x004B #x004C #x004D #x004E #x004F
#| #o12x |# #x0050 #x0051 #x0052 #x0053 #x0054 #x0055 #x0056 #x0057
#| #o13x |# #x0058 #x0059 #x005A #x005B #x005C #x005D #x005E #x005F
#| #o14x |# #x0060 #x0061 #x0062 #x0063 #x0064 #x0065 #x0066 #x0067
#| #o15x |# #x0068 #x0069 #x006A #x006B #x006C #x006D #x006E #x006F
#| #o16x |# #x0070 #x0071 #x0072 #x0073 #x0074 #x0075 #x0076 #x0077
#| #o17x |# #x0078 #x0079 #x007A #x007B #x007C #x007D #x007E #x007F
#| #o20x |# #x2500 #x2502 #x250C #x2510 #x2514 #x2518 #x251C #x2524
#| #o21x |# #x252C #x2534 #x253C #x2580 #x2584 #x2588 #x258C #x2590
#| #o22x |# #x2591 #x2592 #x2593 #x2320 #x25A0 #x2219 #x221A #x2248
#| #o23x |# #x2264 #x2265 #x00A0 #x2321 #x00B0 #x00B2 #x00B7 #x00F7
#| #o24x |# #x2550 #x2551 #x2552 #x0451 #x2553 #x2554 #x2555 #x2556
#| #o25x |# #x2557 #x2558 #x2559 #x255A #x255B #x255C #x255D #x255E
#| #o26x |# #x255F #x2560 #x2561 #x0401 #x2562 #x2563 #x2564 #x2565
#| #o27x |# #x2566 #x2567 #x2568 #x2569 #x256A #x256B #x256C #x00A9
#| #o30x |# #x044E #x0430 #x0431 #x0446 #x0434 #x0435 #x0444 #x0433
#| #o31x |# #x0445 #x0438 #x0439 #x043A #x043B #x043C #x043D #x043E
#| #o32x |# #x043F #x044F #x0440 #x0441 #x0442 #x0443 #x0436 #x0432
#| #o33x |# #x044C #x044B #x0437 #x0448 #x044D #x0449 #x0447 #x044A
#| #o34x |# #x042E #x0410 #x0411 #x0426 #x0414 #x0415 #x0424 #x0413
#| #o35x |# #x0425 #x0418 #x0419 #x041A #x041B #x041C #x041D #x041E
#| #o36x |# #x041F #x042F #x0420 #x0421 #x0422 #x0423 #x0416 #x0412
#| #o37x |# #x042C #x042B #x0417 #x0428 #x042D #x0429 #x0427 #x042A)
)

347
xml/encodings.lisp
View File

@ -1,347 +0,0 @@
(in-package :encoding)
;;;; ---------------------------------------------------------------------------
;;;; Encoding names
;;;;
(defvar *names* (make-hash-table :test #'eq))
(defun canon-name (string)
(with-output-to-string (bag)
(map nil (lambda (ch)
(cond ((char= ch #\_) (write-char #\- bag))
(t (write-char (char-upcase ch) bag))))
string)))
(defun canon-name-2 (string)
(with-output-to-string (bag)
(map nil (lambda (ch)
(cond ((char= ch #\_))
((char= ch #\-))
(t (write-char (char-upcase ch) bag))))
string)))
(defmethod encoding-names ((encoding symbol))
(gethash encoding *names*))
(defmethod (setf encoding-names) (new-value (encoding symbol))
(setf (gethash encoding *names*) new-value))
(defun add-name (encoding name)
(pushnew (canon-name name) (encoding-names encoding) :test #'string=))
(defun resolve-name (string)
(cond ((symbolp string)
string)
(t
(setq string (canon-name string))
(or
(block nil
(maphash (lambda (x y)
(when (member string y :test #'string=)
(return x)))
*names*)
nil)
(block nil
(maphash (lambda (x y)
(when (member string y
:test #'(lambda (x y)
(string= (canon-name-2 x)
(canon-name-2 y))))
(return x)))
*names*)
nil)))))
;;;; ---------------------------------------------------------------------------
;;;; Encodings
;;;;
(defvar *encodings* (make-hash-table :test #'eq))
(defmacro define-encoding (name init-form)
`(progn
(setf (gethash ',name *encodings*)
(list nil (lambda () ,init-form)))
',name))
(defun find-encoding (name)
(let ((x (gethash (resolve-name name) *encodings*)))
(and x
(or (first x)
(setf (first x) (funcall (second x)))))))
(defclass encoding () ())
(defclass simple-8-bit-encoding (encoding)
((table :initarg :table)))
(defun make-simple-8-bit-encoding (&key charset)
(make-instance 'simple-8-bit-encoding
:table (coerce (to-unicode-table charset) '(simple-array (unsigned-byte 16) (256)))))
;;;;;;;
(defmacro fx-op (op &rest xs)
`(the fixnum (,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs))))
(defmacro fx-pred (op &rest xs)
`(,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs)))
(defmacro %+ (&rest xs) `(fx-op + ,@xs))
(defmacro %- (&rest xs) `(fx-op - ,@xs))
(defmacro %* (&rest xs) `(fx-op * ,@xs))
(defmacro %/ (&rest xs) `(fx-op floor ,@xs))
(defmacro %and (&rest xs) `(fx-op logand ,@xs))
(defmacro %ior (&rest xs) `(fx-op logior ,@xs))
(defmacro %xor (&rest xs) `(fx-op logxor ,@xs))
(defmacro %ash (&rest xs) `(fx-op ash ,@xs))
(defmacro %mod (&rest xs) `(fx-op mod ,@xs))
(defmacro %= (&rest xs) `(fx-pred = ,@xs))
(defmacro %<= (&rest xs) `(fx-pred <= ,@xs))
(defmacro %>= (&rest xs) `(fx-pred >= ,@xs))
(defmacro %< (&rest xs) `(fx-pred < ,@xs))
(defmacro %> (&rest xs) `(fx-pred > ,@xs))
(defmethod decode-sequence ((encoding (eql :utf-16-big-endian))
in in-start in-end out out-start out-end eof?)
;; -> new wptr, new rptr
(let ((wptr out-start)
(rptr in-start))
(loop
(when (%= wptr out-end)
(return))
(when (>= (%+ rptr 1) in-end)
(return))
(let ((hi (aref in rptr))
(lo (aref in (%+ 1 rptr))))
(setf rptr (%+ 2 rptr))
(setf (aref out wptr) (logior (ash hi 8) lo))
(setf wptr (%+ 1 wptr))))
(values wptr rptr)))
(defmethod decode-sequence ((encoding (eql :utf-16-little-endian))
in in-start in-end out out-start out-end eof?)
;; -> new wptr, new rptr
(let ((wptr out-start)
(rptr in-start))
(loop
(when (%= wptr out-end)
(return))
(when (>= (%+ rptr 1) in-end)
(return))
(let ((lo (aref in (%+ 0 rptr)))
(hi (aref in (%+ 1 rptr))))
(setf rptr (%+ 2 rptr))
(setf (aref out wptr) (logior (ash hi 8) lo))
(setf wptr (%+ 1 wptr))))
(values wptr rptr)))
(defmethod decode-sequence ((encoding (eql :utf-8))
in in-start in-end out out-start out-end eof?)
(declare (optimize (speed 3) (safety 0))
(type (simple-array (unsigned-byte 8) (*)) in)
(type (simple-array rune (*)) out)
(type fixnum in-start in-end out-start out-end))
(let ((wptr out-start)
(rptr in-start)
byte0)
(macrolet ((put (x)
`((lambda (x)
(cond ((or (<= #xD800 x #xDBFF)
(<= #xDC00 x #xDFFF))
(error "Encoding UTF-16 in UTF-8? : #x~x." x)))
'(unless (data-char-p x)
(error "#x~x is not a data character." x))
;;(fresh-line)
;;(prin1 x) (princ "-> ")
(cond ((%> x #xFFFF)
(setf (aref out (%+ 0 wptr)) (%+ #xD7C0 (ash x -10))
(aref out (%+ 1 wptr)) (%ior #xDC00 (%and x #x3FF)))
(setf wptr (%+ wptr 2)))
(t
(setf (aref out wptr) x)
(setf wptr (%+ wptr 1)))))
,x))
(put1 (x)
`(progn
(setf (aref out wptr) ,x)
(setf wptr (%+ wptr 1)))))
(loop
(when (%= (+ wptr 1) out-end) (return))
(when (%>= rptr in-end) (return))
(setq byte0 (aref in rptr))
(cond ((= byte0 #x0D)
;; CR handling
;; we need to know the following character
(cond ((>= (%+ rptr 1) in-end)
;; no characters in buffer
(cond (eof?
;; at EOF, pass it as NL
(put #x0A)
(setf rptr (%+ rptr 1)))
(t
;; demand more characters
(return))))
((= (aref in (%+ rptr 1)) #x0A)
;; we see CR NL, so forget this CR and the next NL will be
;; inserted literally
(setf rptr (%+ rptr 1)))
(t
;; singleton CR, pass it as NL
(put #x0A)
(setf rptr (%+ rptr 1)))))
((%<= #|#b00000000|# byte0 #b01111111)
(put1 byte0)
(setf rptr (%+ rptr 1)))
((%<= #|#b10000000|# byte0 #b10111111)
(error "Corrupted UTF-8 input (initial byte was #b~8,'0B)" byte0)
(setf rptr (%+ rptr 1)))
((%<= #|#b11000000|# byte0 #b11011111)
(cond ((< (%+ rptr 2) in-end)
(put
(dpb (ldb (byte 5 0) byte0) (byte 5 6)
(dpb (ldb (byte 6 0) (aref in (%+ rptr 1))) (byte 6 0)
0)))
(setf rptr (%+ rptr 2)))
(t
(return))))
((%<= #|#b11100000|# byte0 #b11101111)
(cond ((< (%+ rptr 3) in-end)
(put
(dpb (ldb (byte 4 0) byte0) (byte 4 12)
(dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 6)
(dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 0)
0))))
(setf rptr (%+ rptr 3)))
(t
(return))))
((%<= #|#b11110000|# byte0 #b11110111)
(cond ((< (%+ rptr 4) in-end)
(put
(dpb (ldb (byte 3 0) byte0) (byte 3 18)
(dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 12)
(dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 6)
(dpb (ldb (byte 6 0) (aref in (%+ 3 rptr))) (byte 6 0)
0)))))
(setf rptr (%+ rptr 4)))
(t
(return))))
((%<= #|#b11111000|# byte0 #b11111011)
(cond ((< (%+ rptr 5) in-end)
(put
(dpb (ldb (byte 2 0) byte0) (byte 2 24)
(dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 18)
(dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 12)
(dpb (ldb (byte 6 0) (aref in (%+ 3 rptr))) (byte 6 6)
(dpb (ldb (byte 6 0) (aref in (%+ 4 rptr))) (byte 6 0)
0))))))
(setf rptr (%+ rptr 5)))
(t
(return))))
((%<= #|#b11111100|# byte0 #b11111101)
(cond ((< (%+ rptr 6) in-end)
(put
(dpb (ldb (byte 1 0) byte0) (byte 1 30)
(dpb (ldb (byte 6 0) (aref in (%+ 1 rptr))) (byte 6 24)
(dpb (ldb (byte 6 0) (aref in (%+ 2 rptr))) (byte 6 18)
(dpb (ldb (byte 6 0) (aref in (%+ 3 rptr))) (byte 6 12)
(dpb (ldb (byte 6 0) (aref in (%+ 4 rptr))) (byte 6 6)
(dpb (ldb (byte 6 0) (aref in (%+ 5 rptr))) (byte 6 0)
0)))))))
(setf rptr (%+ rptr 6)))
(t
(return))))
(t
(error "Corrupted UTF-8 input (initial byte was #b~8,'0B)" byte0)) ) ))
(values wptr rptr)) )
(defmethod encoding-p ((object (eql :utf-16-little-endian))) t)
(defmethod encoding-p ((object (eql :utf-16-big-endian))) t)
(defmethod encoding-p ((object (eql :utf-8))) t)
(defmethod encoding-p ((object encoding)) t)
(defmethod decode-sequence ((encoding simple-8-bit-encoding)
in in-start in-end
out out-start out-end
eof?)
(declare (optimize (speed 3) (safety 0))
(type (simple-array (unsigned-byte 8) (*)) in)
(type (simple-array rune (*)) out)
(type fixnum in-start in-end out-start out-end))
(let ((wptr out-start)
(rptr in-start)
(byte 0)
(table (slot-value encoding 'table)))
(declare (type fixnum wptr rptr)
(type (unsigned-byte 8) byte)
(type (simple-array (unsigned-byte 16) (*)) table))
(loop
(when (%= wptr out-end) (return))
(when (%>= rptr in-end) (return))
(setq byte (aref in rptr))
(cond ((= byte #x0D)
;; CR handling
;; we need to know the following character
(cond ((>= (%+ rptr 1) in-end)
;; no characters in buffer
(cond (eof?
;; at EOF, pass it as NL
(setf (aref out wptr) #x0A)
(setf wptr (%+ wptr 1))
(setf rptr (%+ rptr 1)))
(t
;; demand more characters
(return))))
((= (aref in (%+ rptr 1)) #x0A)
;; we see CR NL, so forget this CR and the next NL will be
;; inserted literally
(setf rptr (%+ rptr 1)))
(t
;; singleton CR, pass it as NL
(setf (aref out wptr) #x0A)
(setf wptr (%+ wptr 1))
(setf rptr (%+ rptr 1)))))
(t
(setf (aref out wptr) (aref table byte))
(setf wptr (%+ wptr 1))
(setf rptr (%+ rptr 1))) ))
(values wptr rptr)))
;;;; ---------------------------------------------------------------------------
;;;; Character sets
;;;;
(defvar *charsets* (make-hash-table :test #'eq))
(defclass 8-bit-charset ()
((name :initarg :name)
(to-unicode-table
:initarg :to-unicode-table
:reader to-unicode-table)))
(defmacro define-8-bit-charset (name &rest codes)
(assert (= 256 (length codes)))
`(progn
(setf (gethash ',name *charsets*)
(make-instance '8-bit-charset
:name ',name
:to-unicode-table
',(make-array 256
:element-type '(unsigned-byte 16)
:initial-contents codes)))
',name))
(defun find-charset (name)
(or (gethash name *charsets*)
(error "There is no character set named ~S." name)))

35
xml/string-dom.lisp
View File

@ -1,35 +0,0 @@
(defpackage :string-dom
(:use))
(eval-when (:compile-toplevel :load-toplevel :execute)
(do-external-symbols (var :cdom)
(let* ((home-package
(if (member var '(cdom:data cdom:name cdom:value cdom:tag-name
cdom:node-name cdom:node-value
cdom:substring-data cdom:get-attribute))
:string-dom
:cdom))
(symbol (intern (symbol-name var) home-package)))
(import symbol :string-dom)
(export (list symbol) :string-dom))))
(defpackage :string-dom-impl (:use :cl))
(in-package :string-dom-impl)
(defun rod-to-string (frob)
(if (null frob)
nil
(map 'string #'code-char frob)))
(defun string-dom:data (node) (rod-to-string (cdom:data node)))
(defun string-dom:name (node) (rod-to-string (cdom:name node)))
(defun string-dom:value (node) (rod-to-string (cdom:value node)))
(defun string-dom:tag-name (node) (rod-to-string (cdom:tag-name node)))
(defun string-dom:node-name (node) (rod-to-string (cdom:node-name node)))
(defun string-dom:node-value (node) (rod-to-string (cdom:node-value node)))
(defun string-dom:substring-data (node offset count)
(rod-to-string (cdom:substring-data node offset count)))
(defun string-dom:get-attribute (elt name)
(rod-to-string (cdom:get-attribute elt name)))

172
xml/xml-canonic.lisp
View File

@ -1,172 +0,0 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XML; readtable: glisp; 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)
(mapc (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)
(dolist (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))))
(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)
(cond ((<= #xD800 rune #xDBFF)
(setf *quux* rune))
((<= #xDC00 rune #xDFFF)
(let ((q (logior (ash (- *quux* #xD7C0) 10) (- rune #xDC00))))
(write-rune-0 q sink))
(setf *quux* nil))
(t
(write-rune-0 rune sink))))
(defun write-rune-0 (rune sink)
(labels ((wr (x)
(write-char (code-char x) sink)))
(cond ((<= #x00000000 rune #x0000007F)
(wr rune))
((<= #x00000080 rune #x000007FF)
(wr (logior #b11000000 (ldb (byte 5 6) rune)))
(wr (logior #b10000000 (ldb (byte 6 0) rune))))
((<= #x00000800 rune #x0000FFFF)
(wr (logior #b11100000 (ldb (byte 4 12) rune)))
(wr (logior #b10000000 (ldb (byte 6 6) rune)))
(wr (logior #b10000000 (ldb (byte 6 0) rune))))
((<= #x00010000 rune #x001FFFFF)
(wr (logior #b11110000 (ldb (byte 3 18) rune)))
(wr (logior #b10000000 (ldb (byte 6 12) rune)))
(wr (logior #b10000000 (ldb (byte 6 6) rune)))
(wr (logior #b10000000 (ldb (byte 6 0) rune))))
((<= #x00200000 rune #x03FFFFFF)
(wr (logior #b11111000 (ldb (byte 2 24) rune)))
(wr (logior #b10000000 (ldb (byte 6 18) rune)))
(wr (logior #b10000000 (ldb (byte 6 12) rune)))
(wr (logior #b10000000 (ldb (byte 6 6) rune)))
(wr (logior #b10000000 (ldb (byte 6 0) rune))))
((<= #x04000000 rune #x7FFFFFFF)
(wr (logior #b11111100 (ldb (byte 1 30) rune)))
(wr (logior #b10000000 (ldb (byte 6 24) rune)))
(wr (logior #b10000000 (ldb (byte 6 18) rune)))
(wr (logior #b10000000 (ldb (byte 6 12) rune)))
(wr (logior #b10000000 (ldb (byte 6 6) rune)))
(wr (logior #b10000000 (ldb (byte 6 0) rune)))))))
(defun rod< (rod1 rod2)
(do ((i 0 (+ i 1)))
(nil)
(cond ((= i (length rod1))
(return t))
((= i (length rod2))
(return nil))
((< (aref rod1 i) (aref rod2 i))
(return t))
((> (aref rod1 i) (aref rod2 i))
(return nil)))))

370
xml/xml-stream.lisp
View File

@ -1,370 +0,0 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XML; readtable: glisp; Encoding: utf-8; -*-
;;; ---------------------------------------------------------------------------
;;; Title: Fast streams
;;; Created: 1999-07-17
;;; 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)
;;; API
;;
;; MAKE-XSTREAM cl-stream &key name speed initial-speed [function]
;; MAKE-ROD-XSTREAM rod &key name [function]
;; CLOSE-XSTREAM xstream [function]
;; READ-RUNE xstream [macro]
;; PEEK-RUNE xstream [macro]
;; FREAD-RUNE xstream [function]
;; FPEEK-RUNE xstream [function]
;; XSTREAM-POSITION xstream [function]
;; XSTREAM-LINE-NUMBER xstream [function]
;; XSTREAM-COLUMN-NUMBER xstream [function]
;; XSTREAM-PLIST xstream [accessor]
;; XSTREAM-ENCODING xstream [accessor] <-- be careful here. [*]
;; [*] swichting the encoding on the fly is only possible when the
;; stream's buffer is empty; therefore to be able to switch the
;; encoding, while some runes are already read, set the stream's speed
;; to 1 initially (via the initial-speed argument for MAKE-XSTREAM)
;; and later set it to full speed. (The encoding of the runes
;; sequence, you fetch off with READ-RUNE is always UTF-16 though).
;; An encoding is simply something, which provides the DECODE-SEQUENCE
;; method.
;;; Controller protocol
;;
;; READ-OCTECTS sequence os-stream start end -> first-non-written
;; XSTREAM/CLOSE os-stream
;;
(eval-when (eval compile load)
(defparameter *fast* '(optimize (speed 3) (safety 0)))
;;(defparameter *fast* '(optimize (speed 2) (safety 3)))
)
;; Let us first define fast fixnum arithmetric get rid of type
;; checks. (After all we know what we do here).
(defmacro fx-op (op &rest xs)
`(the fixnum (,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs))))
(defmacro fx-pred (op &rest xs)
`(,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs)))
(defmacro %+ (&rest xs) `(fx-op + ,@xs))
(defmacro %- (&rest xs) `(fx-op - ,@xs))
(defmacro %* (&rest xs) `(fx-op * ,@xs))
(defmacro %/ (&rest xs) `(fx-op floor ,@xs))
(defmacro %and (&rest xs) `(fx-op logand ,@xs))
(defmacro %ior (&rest xs) `(fx-op logior ,@xs))
(defmacro %xor (&rest xs) `(fx-op logxor ,@xs))
(defmacro %ash (&rest xs) `(fx-op ash ,@xs))
(defmacro %mod (&rest xs) `(fx-op mod ,@xs))
(defmacro %= (&rest xs) `(fx-pred = ,@xs))
(defmacro %<= (&rest xs) `(fx-pred <= ,@xs))
(defmacro %>= (&rest xs) `(fx-pred >= ,@xs))
(defmacro %< (&rest xs) `(fx-pred < ,@xs))
(defmacro %> (&rest xs) `(fx-pred > ,@xs))
(deftype buffer-index ()
`(unsigned-byte ,(integer-length array-total-size-limit)))
(deftype buffer-byte ()
`(unsigned-byte 16))
(deftype octet ()
`(unsigned-byte 8))
;; The usage of a special marker for EOF is experimental and
;; considered unhygenic.
(defconstant +end+ #xFFFF
"Special marker inserted into stream buffers to indicate end of buffered data.")
(defvar +null-buffer+ (make-array 0 :element-type 'buffer-byte))
(defvar +null-octet-buffer+ (make-array 0 :element-type 'octet))
(defstruct (xstream
(:constructor make-xstream/low)
(:copier nil)
(:print-function print-xstream))
;;; Read buffer
;; the buffer itself
(buffer +null-buffer+
:type (simple-array buffer-byte (*)))
;; points to the next element of `buffer' containing the next rune
;; about to be read.
(read-ptr 0 :type buffer-index)
;; points to the first element of `buffer' not containing a rune to
;; be read.
(fill-ptr 0 :type buffer-index)
;;; OS buffer
;; a scratch pad for READ-SEQUENCE
(os-buffer +null-octet-buffer+
:type (simple-array octet (*)))
;; `os-left-start', `os-left-end' designate a region of os-buffer,
;; which still contains some undecoded data. This is needed because
;; of the DECODE-SEQUENCE protocol
(os-left-start 0 :type buffer-index)
(os-left-end 0 :type buffer-index)
;; How much to read each time
(speed 0 :type buffer-index)
;; Some stream object obeying to a certain protcol
os-stream
;; The external format
;; (some object offering the ENCODING protocol)
(encoding :utf-8)
;;A STREAM-NAME object
(name nil)
;; a plist a struct keeps the hack away
(plist nil)
;; Stream Position
(line-number 1 :type integer) ;current line number
(line-start 0 :type integer) ;stream position the current line starts at
(buffer-start 0 :type integer) ;stream position the current buffer starts at
;; There is no need to maintain a column counter for each character
;; read, since we can easily compute it from `line-start' and
;; `buffer-start'.
)
(defmacro read-rune (input)
"Read a single rune off the xstream `input'. In case of end of file :EOF
is returned."
`((lambda (input)
(declare (type xstream input)
#.*fast*)
(let ((rp (xstream-read-ptr input)))
(declare (type buffer-index rp))
(let ((ch (aref (the (simple-array buffer-byte (*)) (xstream-buffer input))
rp)))
(declare (type buffer-byte ch))
(setf (xstream-read-ptr input) (%+ rp 1))
(cond ((%= ch +end+)
(the (or (member :eof) rune)
(xstream-underflow input)))
((%= ch #x000A) ;line break
(account-for-line-break input)
(code-rune ch))
(t
(code-rune ch))))))
,input))
(defmacro peek-rune (input)
"Peek a single rune off the xstream `input'. In case of end of file :EOF
is returned."
`((lambda (input)
(declare (type xstream input)
#.*fast*)
(let ((rp (xstream-read-ptr input)))
(declare (type buffer-index rp))
(let ((ch (aref (the (simple-array buffer-byte (*)) (xstream-buffer input))
rp)))
(declare (type buffer-byte ch))
(cond ((%= ch +end+)
(prog1
(the (or (member :eof) rune) (xstream-underflow input))
(setf (xstream-read-ptr input) 0)))
(t
(code-rune ch))))))
,input))
(defmacro consume-rune (input)
"Like READ-RUNE, but does not actually return the read rune."
`((lambda (input)
(declare (type xstream input)
#.*fast*)
(let ((rp (xstream-read-ptr input)))
(declare (type buffer-index rp))
(let ((ch (aref (the (simple-array buffer-byte (*)) (xstream-buffer input))
rp)))
(declare (type buffer-byte ch))
(setf (xstream-read-ptr input) (%+ rp 1))
(when (%= ch +end+)
(xstream-underflow input))
(when (%= ch #x000A) ;line break
(account-for-line-break input) )))
nil)
,input))
(defsubst unread-rune (rune input)
"Unread the last recently read rune; if there wasn't such a rune, you
deserve to loose."
(declare (ignore rune))
(decf (xstream-read-ptr input))
(when (%= (peek-rune input) #x000A) ;was it a line break?
(unaccount-for-line-break input)))
(defun fread-rune (input)
(read-rune input))
(defun fpeek-rune (input)
(peek-rune input))
;;; Line counting
(defun account-for-line-break (input)
(declare (type xstream input))
(incf (xstream-line-number input))
(setf (xstream-line-start input)
(+ (xstream-buffer-start input) (xstream-read-ptr input))))
(defun unaccount-for-line-break (input)
;; incomplete!
;; We better use a traditional lookahead technique or forbid unread-rune.
(decf (xstream-line-number input)))
;; User API:
(defun xstream-position (input)
(+ (xstream-buffer-start input) (xstream-read-ptr input)))
;; xstream-line-number is structure accessor
(defun xstream-column-number (input)
(+ (- (xstream-position input)
(xstream-line-start input))
1))
;;; Underflow
;;(defun read-runes (sequence input))
(defun xstream-underflow (input)
(declare (type xstream input))
;; we are about to fill new data into the buffer, so we need to
;; adjust buffer-start.
(incf (xstream-buffer-start input)
(- (xstream-fill-ptr input) 0))
(let (n m)
;; when there is something left in the os-buffer, we move it to
;; the start of the buffer.
(setf m (- (xstream-os-left-end input) (xstream-os-left-start input)))
(unless (zerop m)
(replace (xstream-os-buffer input) (xstream-os-buffer input)
:start1 0 :end1 m
:start2 (xstream-os-left-start input)
:end2 (xstream-os-left-end input))
;; then we take care that the buffer is large enough to carry at
;; least 100 bytes (a random number)
(unless (>= (length (xstream-os-buffer input)) 100)
(error "You lost")
;; todo: enlarge buffer
))
(setf n
(read-octets (xstream-os-buffer input) (xstream-os-stream input)
m (min (1- (length (xstream-os-buffer input)))
(+ m (xstream-speed input)))))
(cond ((%= n 0)
(setf (xstream-read-ptr input) 0
(xstream-fill-ptr input) n)
(setf (aref (xstream-buffer input) (xstream-fill-ptr input)) +end+)
:eof)
(t
(multiple-value-bind (fnw fnr)
(decode-sequence (xstream-encoding input)
(xstream-os-buffer input) 0 n
(xstream-buffer input) 0 (1- (length (xstream-buffer input)))
(= n m))
(setf (xstream-os-left-start input) fnr
(xstream-os-left-end input) n
(xstream-read-ptr input) 0
(xstream-fill-ptr input) fnw)
(setf (aref (xstream-buffer input) (xstream-fill-ptr input)) +end+)
(read-rune input))))))
;;; constructor
(defun make-xstream (os-stream &key name (speed 8192) (initial-speed speed))
(let ()
(multiple-value-bind (encoding preread) (figure-encoding os-stream)
(let ((osbuf (make-array speed :element-type '(unsigned-byte 8))))
(replace osbuf preread)
(make-xstream/low
:buffer (let ((r (make-array speed :element-type 'buffer-byte)))
(setf (%rune r 0) #xFFFF)
r)
:read-ptr 0
:fill-ptr 0
:os-buffer osbuf
:speed initial-speed
:os-stream os-stream
:os-left-start 0
:os-left-end (length preread)
:encoding encoding
:name name)))))
(defmethod figure-encoding ((stream glisp:gstream))
;; For HTML iso-8859-1 is the default
(values (xml::find-encoding :iso-8859-1) nil))
(defun make-rod-xstream (string &key name)
(let ((n (length string)))
(let ((buffer (make-array (1+ n) :element-type 'buffer-byte)))
(declare (type (simple-array buffer-byte (*)) buffer))
;; copy the rod
(do ((i (1- n) (- i 1)))
((< i 0))
(declare (type fixnum i))
(setf (aref buffer i) (rune-code (%rune string i))))
(setf (aref buffer n) +end+)
;;
(make-xstream/low :buffer buffer
:read-ptr 0
:fill-ptr n
;; :os-buffer nil
:speed 1
:os-stream nil
:name name))))
;;; misc
(defun close-xstream (input)
(xstream/close (xstream-os-stream input)))
;;; controller implementations
(defmethod read-octets (sequence (stream stream) start end)
(#+CLISP lisp:read-byte-sequence
#-CLISP read-sequence
sequence stream :start start :end end))
(defmethod read-octets (sequence (stream null) start end)
(declare (ignore sequence start end))
0)
(defmethod xstream/close ((stream stream))
(close stream))
(defmethod xstream/close ((stream null))
nil)