- Moved utility functions from the "runes" package to the "cxml" package to
avoid name conflicts with functions from "glisp" of the same name. - Renamed defsubst to definline for the same reason. (This is a commit to the cxml repository, not the main closure repository. If you don't want cxml commit messages on the closure list, please complain to me and I'll change it.)
This commit is contained in:
dlichteblau
110
cxml.asd
110
cxml.asd
@ -1,58 +1,112 @@
|
||||
;;; 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))))
|
||||
|
||||
(unless (find-package :glisp)
|
||||
(defpackage :glisp))
|
||||
#-(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*))
|
||||
|
||||
(defsystem glisp
|
||||
#-rune-is-character
|
||||
(format t "~&;;; Building cxml with (UNSIGNED-BYTE 16) RUNES~%")
|
||||
|
||||
#+rune-is-character
|
||||
(format t "~&;;; Building cxml with CHARACTER RUNES~%")
|
||||
|
||||
(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 "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 "util" :depends-on ("package"))
|
||||
(: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" "util" "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))
|
||||
|
||||
@ -1,3 +1,12 @@
|
||||
;;;; 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)
|
||||
@ -680,7 +698,7 @@
|
||||
(with-slots (children owner) node
|
||||
;; remove children, add new TEXT-NODE child
|
||||
;; (alas, we must not reuse an old TEXT-NODE)
|
||||
(while (plusp (length children))
|
||||
(cxml::while (plusp (length children))
|
||||
(dom:remove-child node (dom:last-child node)))
|
||||
(dom:append-child node (dom:create-text-node owner rod))))
|
||||
new-value)
|
||||
@ -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))
|
||||
@ -771,7 +819,7 @@
|
||||
(i 0)
|
||||
(previous nil))
|
||||
;; careful here, we're modifying the array we are iterating over
|
||||
(while (< i (length children))
|
||||
(cxml::while (< i (length children))
|
||||
(let ((child (elt children i)))
|
||||
(cond
|
||||
((not (eq (dom:node-type child) :text))
|
||||
@ -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))
|
||||
|
||||
@ -24,35 +24,35 @@
|
||||
|
||||
(in-package :runes)
|
||||
|
||||
(deftype rune () 'base-char)
|
||||
(deftype rod () 'base-string)
|
||||
(deftype simple-rod () 'simple-string)
|
||||
(deftype rune () 'character)
|
||||
(deftype rod () '(vector character))
|
||||
(deftype simple-rod () '(simple-array character))
|
||||
|
||||
(defsubst rune (rod index)
|
||||
(definline rune (rod index)
|
||||
(char rod index))
|
||||
|
||||
(defun (setf rune) (new rod index)
|
||||
(setf (char rod index) new))
|
||||
|
||||
(defsubst %rune (rod index)
|
||||
(definline %rune (rod index)
|
||||
(aref (the simple-string rod) (the fixnum index)))
|
||||
|
||||
(defsubst (setf %rune) (new rod index)
|
||||
(definline (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))
|
||||
(definline code-rune (x) (code-char x))
|
||||
(definline rune-code (x) (char-code x))
|
||||
|
||||
(defsubst rune= (x y)
|
||||
(definline rune= (x y)
|
||||
(char= x y))
|
||||
|
||||
(defun rune-downcase (rune)
|
||||
(char-downcase rune))
|
||||
|
||||
(defsubst rune-upcase (rune)
|
||||
(definline rune-upcase (rune)
|
||||
(char-upcase rune))
|
||||
|
||||
(defun rune-upper-case-letter-p (rune)
|
||||
@ -70,13 +70,13 @@
|
||||
(defun rod-upcase (rod)
|
||||
(string-upcase rod))
|
||||
|
||||
(defsubst white-space-rune-p (char)
|
||||
(definline 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))
|
||||
(definline digit-rune-p (char &optional (radix 10))
|
||||
(digit-char-p char radix))
|
||||
|
||||
(defun rod (x)
|
||||
@ -100,7 +100,7 @@
|
||||
(defun rod-equal (x y)
|
||||
(string-equal x y))
|
||||
|
||||
(defsubst make-rod (size)
|
||||
(definline make-rod (size)
|
||||
(make-string size))
|
||||
|
||||
(defun char-rune (char)
|
||||
@ -134,9 +134,6 @@
|
||||
(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))
|
||||
|
||||
@ -28,13 +28,13 @@
|
||||
;; Unfortunately it is also incapable to declaim such functions inline.
|
||||
;; So we revoke the DEFUN hack from dep-gcl here.
|
||||
|
||||
(defmacro runes::defsubst (fun args &body body)
|
||||
(defmacro runes::definline (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))
|
||||
(runes::defsubst ,fnam ,args .,body)))
|
||||
(runes::definline ,fnam ,args .,body)))
|
||||
`(progn
|
||||
(defun ,fun ,args .,body)
|
||||
(define-compiler-macro ,fun (&rest .args.)
|
||||
|
||||
@ -40,13 +40,13 @@
|
||||
;; Unfortunately it is also incapable to declaim such functions inline.
|
||||
;; So we revoke the DEFUN hack from dep-gcl here.
|
||||
|
||||
(defmacro runes::defsubst (fun args &body body)
|
||||
(defmacro runes::definline (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))
|
||||
(runes::defsubst ,fnam ,args .,body)))
|
||||
(runes::definline ,fnam ,args .,body)))
|
||||
(labels ((declp (x)
|
||||
(and (consp x) (eq (car x) 'declare))))
|
||||
`(progn
|
||||
|
||||
@ -30,30 +30,30 @@
|
||||
(if (fboundp 'cl::define-compiler-macro)
|
||||
(pushnew 'define-compiler-macro *features*)))
|
||||
|
||||
(setq lisp:*load-paths* '(#P"./"))
|
||||
;;;(setq lisp:*load-paths* '(#P"./"))
|
||||
;;;
|
||||
;;;#+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 'runes::define-compiler-macro :runes)
|
||||
;;; (defmacro runes::define-compiler-macro (name args &body body)
|
||||
;;; (declare (ignore args body))
|
||||
;;; `(progn
|
||||
;;; ',name)))
|
||||
|
||||
#+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 'runes::define-compiler-macro :runes)
|
||||
(defmacro runes::define-compiler-macro (name args &body body)
|
||||
(declare (ignore args body))
|
||||
`(progn
|
||||
',name)))
|
||||
|
||||
(defmacro runes::defsubst (name args &body body)
|
||||
(defmacro runes::definline (name args &body body)
|
||||
`(progn
|
||||
(declaim (inline ,name))
|
||||
(defun ,name ,args .,body)))
|
||||
|
||||
@ -24,7 +24,7 @@
|
||||
;;; superseded by a newer version) or write to the Free Software
|
||||
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
(defmacro runes::defsubst (name args &body body)
|
||||
(defmacro runes::definline (name args &body body)
|
||||
`(progn
|
||||
(declaim (inline ,name))
|
||||
(defun ,name ,args .,body)))
|
||||
|
||||
@ -24,7 +24,7 @@
|
||||
;;; superseded by a newer version) or write to the Free Software
|
||||
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
(defmacro runes::defsubst (name args &body body)
|
||||
(defmacro runes::definline (name args &body body)
|
||||
`(progn
|
||||
(declaim (inline ,name))
|
||||
(defun ,name ,args .,body)))
|
||||
|
||||
@ -5,7 +5,7 @@
|
||||
;;;;
|
||||
;;;; (c) copyright 1999 by Gilbert Baumann
|
||||
|
||||
(defmacro runes::defsubst (fun args &body body)
|
||||
(defmacro runes::definline (fun args &body body)
|
||||
(if (consp fun)
|
||||
`(defun ,fun ,args
|
||||
,@body)
|
||||
|
||||
@ -24,7 +24,7 @@
|
||||
;;; superseded by a newer version) or write to the Free Software
|
||||
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||||
|
||||
(defmacro runes::defsubst (name args &body body)
|
||||
(defmacro runes::definline (name args &body body)
|
||||
`(progn
|
||||
(declaim (inline ,name))
|
||||
(defun ,name ,args .,body)))
|
||||
|
||||
@ -10,15 +10,8 @@
|
||||
|
||||
(defpackage :runes
|
||||
(:use :cl)
|
||||
(:export #:defsubst
|
||||
(:export #:definline
|
||||
|
||||
;; util.lisp :
|
||||
#:compose
|
||||
#:curry
|
||||
#:rcurry
|
||||
#:until
|
||||
#:while
|
||||
|
||||
;; runes.lisp
|
||||
#:rune
|
||||
#:rod
|
||||
@ -47,4 +40,29 @@
|
||||
#:rod-string
|
||||
#:string-rod
|
||||
#:rod-subseq
|
||||
#:rod<))
|
||||
#:rod<
|
||||
|
||||
;; xstream.lisp
|
||||
#:make-xstream
|
||||
#:make-rod-xstream
|
||||
#:close-xstream
|
||||
#:xstream-p
|
||||
#:read-rune
|
||||
#:peek-rune
|
||||
#:fread-rune
|
||||
#:fpeek-rune
|
||||
#:consume-rune
|
||||
#:unread-rune
|
||||
#:xstream-position
|
||||
#:xstream-line-number
|
||||
#:xstream-column-number
|
||||
#:xstream-plist
|
||||
#:xstream-encoding
|
||||
#:set-to-full-speed
|
||||
#:xstream-name))
|
||||
|
||||
(defpackage :encoding
|
||||
(:use :cl :runes)
|
||||
(:export
|
||||
#:find-encoding
|
||||
#:decode-sequence))
|
||||
|
||||
@ -42,26 +42,26 @@
|
||||
(deftype rod () '(array rune (*)))
|
||||
(deftype simple-rod () '(simple-array rune (*)))
|
||||
|
||||
(defsubst rune (rod index)
|
||||
(definline rune (rod index)
|
||||
(aref rod index))
|
||||
|
||||
(defun (setf rune) (new rod index)
|
||||
(setf (aref rod index) new))
|
||||
|
||||
(defsubst %rune (rod index)
|
||||
(definline %rune (rod index)
|
||||
(aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum index)))
|
||||
|
||||
(defsubst (setf %rune) (new rod index)
|
||||
(definline (setf %rune) (new rod index)
|
||||
(setf (aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum index)) new))
|
||||
|
||||
(defun rod-capitalize (rod)
|
||||
(warn "~S is not implemented." 'rod-capitalize)
|
||||
rod)
|
||||
|
||||
(defsubst code-rune (x) x)
|
||||
(defsubst rune-code (x) x)
|
||||
(definline code-rune (x) x)
|
||||
(definline rune-code (x) x)
|
||||
|
||||
(defsubst rune= (x y)
|
||||
(definline rune= (x y)
|
||||
(= x y))
|
||||
|
||||
(defun rune-downcase (rune)
|
||||
@ -70,7 +70,7 @@
|
||||
((<= #x00c0 rune #x00de) (+ rune #x20))
|
||||
(t rune)))
|
||||
|
||||
(defsubst rune-upcase (rune)
|
||||
(definline rune-upcase (rune)
|
||||
(cond ((<= #x0061 rune #x007a) (- rune #x20))
|
||||
((= rune #x00f7) rune)
|
||||
((<= #x00e0 rune #x00fe) (- rune #x20))
|
||||
@ -89,21 +89,19 @@
|
||||
|
||||
(defun rod-downcase (rod)
|
||||
;; FIXME
|
||||
(register-rod
|
||||
(map '(simple-array (unsigned-byte 16) (*)) #'rune-downcase rod)))
|
||||
(map '(simple-array (unsigned-byte 16) (*)) #'rune-downcase rod))
|
||||
|
||||
(defun rod-upcase (rod)
|
||||
;; FIXME
|
||||
(register-rod
|
||||
(map '(simple-array (unsigned-byte 16) (*)) #'rune-upcase rod)))
|
||||
(map '(simple-array (unsigned-byte 16) (*)) #'rune-upcase rod))
|
||||
|
||||
(defsubst white-space-rune-p (char)
|
||||
(definline white-space-rune-p (char)
|
||||
(or (= char 9) ;TAB
|
||||
(= char 10) ;Linefeed
|
||||
(= char 13) ;Carriage Return
|
||||
(= char 32))) ;Space
|
||||
|
||||
(defsubst digit-rune-p (char &optional (radix 10))
|
||||
(definline digit-rune-p (char &optional (radix 10))
|
||||
(cond ((<= #.(char-code #\0) char #.(char-code #\9))
|
||||
(and (< (- char #.(char-code #\0)) radix)
|
||||
(- char #.(char-code #\0))))
|
||||
@ -115,11 +113,11 @@
|
||||
(- char #.(char-code #\a) -10))) ))
|
||||
|
||||
(defun rod (x)
|
||||
(cond ((stringp x) (register-rod (map 'rod #'char-code x)))
|
||||
(cond ((stringp x) (map 'rod #'char-code x))
|
||||
((symbolp x) (rod (string x)))
|
||||
((characterp x) (rod (string x)))
|
||||
((vectorp x) (register-rod (coerce x 'rod)))
|
||||
((integerp x) (register-rod (map 'rod #'identity (list x))))
|
||||
((vectorp x) (coerce x 'rod))
|
||||
((integerp x) (map 'rod #'identity (list x)))
|
||||
(t (error "Cannot convert ~S to a ~S" x 'rod))))
|
||||
|
||||
(defun runep (x)
|
||||
@ -143,19 +141,16 @@
|
||||
(unless (rune-equal (rune x i) (rune y i))
|
||||
(return nil)))))
|
||||
|
||||
(defsubst make-rod (size)
|
||||
(let ((res (make-array size :element-type 'rune)))
|
||||
(register-rod res)
|
||||
res))
|
||||
(definline make-rod (size)
|
||||
(make-array size :element-type 'rune))
|
||||
|
||||
(defun char-rune (char)
|
||||
(code-rune (char-code char)))
|
||||
|
||||
(defun rune-char (rune &optional (default #\?))
|
||||
#+CMU
|
||||
(if (< rune 256) (code-char rune) default)
|
||||
#-CMU
|
||||
(or (code-char rune) default))
|
||||
(if (>= rune char-code-limit)
|
||||
default
|
||||
(or (code-char rune) default)))
|
||||
|
||||
(defun rod-string (rod &optional (default-char #\?))
|
||||
(map 'string (lambda (x) (rune-char x default-char)) rod))
|
||||
@ -178,10 +173,6 @@
|
||||
(defun rodp (object)
|
||||
(typep object 'rod))
|
||||
|
||||
(defun really-rod-p (object)
|
||||
(and (typep object 'rod)
|
||||
(really-really-rod-p object)))
|
||||
|
||||
(defun rod-subseq (source start &optional (end (length source)))
|
||||
(unless (rodp source)
|
||||
(error "~S is not of type ~S." source 'rod))
|
||||
@ -221,45 +212,6 @@
|
||||
(declare (type fixnum i))
|
||||
(setf (%rune res i) (aref source (the fixnum (+ i start))))))))
|
||||
|
||||
;;; Support for telling ROD and arrays apart:
|
||||
|
||||
#+CMU
|
||||
(progn
|
||||
(defvar *rod-hash-table*
|
||||
(make-array 5003 :initial-element nil)))
|
||||
|
||||
(defun register-rod (rod)
|
||||
#+CMU
|
||||
(unless (really-really-rod-p rod)
|
||||
(push (ext:make-weak-pointer rod)
|
||||
(aref *rod-hash-table* (mod (cl::pointer-hash rod)
|
||||
(length *rod-hash-table*)))))
|
||||
rod)
|
||||
|
||||
(defun really-really-rod-p (rod)
|
||||
#+CMU
|
||||
(find rod (aref *rod-hash-table* (mod (cl::pointer-hash rod)
|
||||
(length *rod-hash-table*)))
|
||||
:key #'ext:weak-pointer-value))
|
||||
|
||||
#+CMU
|
||||
(progn
|
||||
(defun rod-hash-table-rehash ()
|
||||
(let* ((n 5003)
|
||||
(new (make-array n :initial-element nil)))
|
||||
(loop for bucket across *rod-hash-table* do
|
||||
(loop for item in bucket do
|
||||
(let ((v (ext:weak-pointer-value item)))
|
||||
(when v
|
||||
(push item (aref new (mod (cl::pointer-hash v) n)))))))
|
||||
(setf *rod-hash-table* new)))
|
||||
|
||||
(defun rod-hash-after-gc-hook ()
|
||||
;; hmm interesting question: should we rehash?
|
||||
(rod-hash-table-rehash))
|
||||
|
||||
(pushnew 'rod-hash-after-gc-hook extensions:*after-gc-hooks*) )
|
||||
|
||||
(defun rod< (rod1 rod2)
|
||||
(do ((i 0 (+ i 1)))
|
||||
(nil)
|
||||
|
||||
@ -65,7 +65,7 @@
|
||||
;; XSTREAM/CLOSE os-stream
|
||||
;;
|
||||
|
||||
(eval-when (eval compile load)
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defparameter *fast* '(optimize (speed 3) (safety 0)))
|
||||
;;(defparameter *fast* '(optimize (speed 2) (safety 3)))
|
||||
)
|
||||
@ -154,6 +154,10 @@
|
||||
;; `buffer-start'.
|
||||
)
|
||||
|
||||
(defun print-xstream (self sink depth)
|
||||
(declare (ignore depth))
|
||||
(format sink "#<~S ~S>" (type-of self) (xstream-name self)))
|
||||
|
||||
(defmacro read-rune (input)
|
||||
"Read a single rune off the xstream `input'. In case of end of file :EOF
|
||||
is returned."
|
||||
@ -213,7 +217,7 @@
|
||||
nil)
|
||||
,input))
|
||||
|
||||
(defsubst unread-rune (rune input)
|
||||
(definline unread-rune (rune input)
|
||||
"Unread the last recently read rune; if there wasn't such a rune, you
|
||||
deserve to lose."
|
||||
(declare (ignore rune))
|
||||
@ -376,10 +380,20 @@
|
||||
;;; controller implementations
|
||||
|
||||
(defmethod read-octets (sequence (stream stream) start end)
|
||||
(#+CLISP lisp:read-byte-sequence
|
||||
(#+CLISP ext:read-byte-sequence
|
||||
#-CLISP read-sequence
|
||||
sequence stream :start start :end end))
|
||||
|
||||
#+cmu
|
||||
(defmethod read-octets :around (sequence (stream stream) start end)
|
||||
;; CMUCL <= 19a on non-SunOS accidentally triggers EFAULT in read(2)
|
||||
;; if SEQUENCE has been write protected by GC. Workaround: Touch all pages
|
||||
;; in SEQUENCE and make sure no GC happens between that and the read(2).
|
||||
(ext::without-gcing
|
||||
(loop for i from start below end
|
||||
do (setf (elt sequence i) (elt sequence i)))
|
||||
(call-next-method)))
|
||||
|
||||
(defmethod read-octets (sequence (stream null) start end)
|
||||
(declare (ignore sequence start end))
|
||||
0)
|
||||
|
||||
@ -32,7 +32,7 @@
|
||||
;; subforms
|
||||
;;
|
||||
|
||||
(in-package :runes)
|
||||
(in-package :cxml)
|
||||
|
||||
;;; --------------------------------------------------------------------------------
|
||||
;;; Meta functions
|
||||
@ -1,6 +1,11 @@
|
||||
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: XML; readtable: glisp; Encoding: utf-8; -*-
|
||||
;;;; xml-name-rune-p -- character class definitions
|
||||
;;;;
|
||||
;;;; 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>
|
||||
|
||||
(in-package :xml)
|
||||
(in-package :cxml)
|
||||
|
||||
#.(funcall
|
||||
(compile
|
||||
@ -206,13 +211,15 @@
|
||||
(setf (aref r i) 1))))) )
|
||||
|
||||
`(progn
|
||||
(DEFSUBST NAME-RUNE-P (RUNE)
|
||||
(DEFINLINE NAME-RUNE-P (RUNE)
|
||||
(SETF RUNE (RUNE-CODE RUNE))
|
||||
(AND (<= 0 RUNE ,*max*)
|
||||
(LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3)))
|
||||
(= 1 (SBIT ',(predicate-to-bv #'name-rune-p)
|
||||
(THE FIXNUM RUNE))))))
|
||||
(DEFSUBST NAME-START-RUNE-P (RUNE)
|
||||
(DEFINLINE NAME-START-RUNE-P (RUNE)
|
||||
(SETF RUNE (RUNE-CODE RUNE))
|
||||
(AND (<= 0 RUNE ,*MAX*)
|
||||
(LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3)))
|
||||
(= 1 (SBIT ',(predicate-to-bv #'name-start-rune-p)
|
||||
(THE FIXNUM RUNE)))))))) ))))
|
||||
(THE FIXNUM RUNE)))))))) ))))
|
||||
|
||||
2031
xml/xml-parse.lisp
2031
xml/xml-parse.lisp
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user