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

- Moved utility functions from the "runes" package to the "cxml" package to

Browse Source 
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
2005-03-25 18:16:29 +00:00
parent 3c5ada1d05
commit 2691084809
16 changed files with 1721 additions and 791 deletions
Download Patch File Download Diff File Expand all files Collapse all files

110
cxml.asd
View File

@ -1,58 +1,112 @@
;;; XXX Die vielen verschiedenen Systeme hier sollten vielleicht
;;; Module eines grossen Systems CXML werden?
(defpackage :cxml-system (defpackage :cxml-system
(:use :asdf :cl)) (:use :asdf :cl))
(in-package :cxml-system) (in-package :cxml-system)
;; XXX das sollte natuerlich erst beim laden stattfinden
#+cmu
(require :gray-streams)
(defclass closure-source-file (cl-source-file) ()) (defclass closure-source-file (cl-source-file) ())
#+sbcl #+sbcl
(defmethod perform :around ((o compile-op) (s closure-source-file)) (defmethod perform :around ((o compile-op) (s closure-source-file))
;; shut up already. Correctness first. ;; shut up already. Correctness first.
(handler-bind ((sb-ext:compiler-note #'muffle-warning)) (handler-bind ((sb-ext:compiler-note #'muffle-warning))
(call-next-method))) (let (#+sbcl (*compile-print* nil))
(call-next-method))))
(unless (find-package :glisp) #-(or rune-is-character rune-is-octet)
(defpackage :glisp)) (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 :default-component-class closure-source-file
:pathname (merge-pathnames :pathname (merge-pathnames
"glisp/" "runes/"
(make-pathname :name nil :type nil :defaults *load-truename*)) (make-pathname :name nil :type nil :defaults *load-truename*))
:components :components
((:file dependent ((:file "package")
(:file dependent
:pathname :pathname
#+CLISP "dep-clisp" #+CLISP "dep-clisp"
#+(AND :CMU (NOT :PTHREAD)) "dep-cmucl" #+(AND :CMU (NOT :PTHREAD)) "dep-cmucl"
#+sbcl "dep-sbcl" #+sbcl "dep-sbcl"
#+(AND :CMU :PTHREAD) "dep-cmucl-dtc" #+(AND :CMU :PTHREAD) "dep-cmucl-dtc"
#+(and allegro allegro-v5.0) "dep-acl5" #+(and allegro-version>= (version>= 5.0)) "dep-acl5"
#+(and allegro (not allegro-v5.0)) "dep-acl" #+(and allegro-version>= (not (version>= 5.0))) "dep-acl"
#+GCL "dep-gcl" #+openmcl "dep-openmcl"
#-(or sbcl CLISP CMU allegro GCL) #.(error "Configure!")) #-(or sbcl CLISP CMU allegro openmcl) #.(error "Configure!")
(:file "package" :depends-on ("package"))
:depends-on (dependent)) (:file runes
(:file "runes" :pathname
#-rune-is-character "runes"
#+rune-is-character "characters"
:depends-on ("package" dependent)) :depends-on ("package" dependent))
(:file "util" (:file "syntax" :depends-on ("package" dependent runes))
:depends-on ("package" dependent "runes")) (:file "encodings" :depends-on ("package"))
(:file "match" (:file "encodings-data" :depends-on ("package" "encodings"))
:depends-on ("package" dependent "runes" "util")))) (:file "xstream"
:depends-on ("package" dependent "syntax" "encodings-data"))))
(asdf:defsystem :cxml (asdf:defsystem :xml
:default-component-class closure-source-file :default-component-class closure-source-file
:pathname (merge-pathnames :pathname (merge-pathnames
"cxml/" "xml/"
(make-pathname :name nil :type nil :defaults *load-truename*)) (make-pathname :name nil :type nil :defaults *load-truename*))
:components :components
((:file "package") ((:file "package")
(:file "encodings" :depends-on ("package")) (:file "util" :depends-on ("package"))
(:file "encodings-data" :depends-on ("package" "encodings"))
(:file "sax-handler") (:file "sax-handler")
(:file "dompack") (:file "characters" :depends-on ("package"))
(:file "dom-impl" :depends-on ("dompack"))
(:file "dom-builder" :depends-on ("dom-impl" "sax-handler"))
(:file "xml-stream" :depends-on ("package"))
(:file "xml-name-rune-p" :depends-on ("package")) (:file "xml-name-rune-p" :depends-on ("package"))
(:file "xml-parse" :depends-on ("package" "dompack" "sax-handler")) (:file "split-sequence" :depends-on ("package"))
(:file "xml-canonic" :depends-on ("package" "dompack" "xml-parse"))) (:file "xml-parse" :depends-on ("package" "util" "sax-handler" "split-sequence" "xml-name-rune-p" "characters"))
:depends-on (:glisp)) (: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))

117
dom/dom-impl.lisp
View File

@ -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 (defpackage :dom-impl
(:use :cl :runes)) (:use :cl :runes))
@ -26,7 +35,8 @@
(defclass document (node) (defclass document (node)
((doc-type :initarg :doc-type :reader dom:doctype) ((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) (defclass document-fragment (node)
()) ())
@ -91,6 +101,9 @@
(read-only-p :initform nil :reader read-only-p) (read-only-p :initform nil :reader read-only-p)
(element-type :initarg :element-type))) (element-type :initarg :element-type)))
(defclass attribute-node-map (named-node-map)
((element :initarg :element)))
;;; Implementation ;;; Implementation
@ -115,18 +128,19 @@
(defun move (from to from-start to-start length) (defun move (from to from-start to-start length)
;; like (setf (subseq to to-start (+ to-start length)) ;; like (setf (subseq to to-start (+ to-start length))
;; (subseq from from-start (+ from-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) (if (< to-start from-start)
(loop (loop
repeat length repeat length
for i from from-start for i from from-start
for j from to-start for j from to-start
do (setf (elt to j) (elt from i))) do (setf (aref to j) (aref from i)))
(loop (loop
repeat length repeat length
for i from (+ from-start length -1) by -1 for i downfrom (+ from-start length -1)
for j from (+ to-start length -1) by -1 for j downfrom (+ to-start length -1)
do (setf (elt to j) (elt from i))))) do (setf (aref to j) (aref from i)))))
(defun adjust-vector-exponentially (vector new-dimension set-fill-pointer-p) (defun adjust-vector-exponentially (vector new-dimension set-fill-pointer-p)
(let ((d (array-dimension vector 0))) (let ((d (array-dimension vector 0)))
@ -175,14 +189,18 @@
(defmethod dom:create-element ((document document) tag-name) (defmethod dom:create-element ((document document) tag-name)
(setf tag-name (rod 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))) (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string tag-name)))
(make-instance 'element (let ((result (make-instance 'element
:tag-name tag-name :tag-name tag-name
:owner document
:attributes (make-instance 'named-node-map
:element-type :attribute
:owner document))) :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)) (defmethod dom:create-document-fragment ((document document))
(make-instance 'document-fragment (make-instance 'document-fragment
@ -209,7 +227,7 @@
(defmethod dom:create-processing-instruction ((document document) target data) (defmethod dom:create-processing-instruction ((document document) target data)
(setf target (rod target)) (setf target (rod target))
(setf data (rod data)) (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))) (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string target)))
(make-instance 'processing-instruction (make-instance 'processing-instruction
:owner document :owner document
@ -218,7 +236,7 @@
(defmethod dom:create-attribute ((document document) name) (defmethod dom:create-attribute ((document document) name)
(setf name (rod 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))) (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string name)))
(make-instance 'attribute (make-instance 'attribute
:name name :name name
@ -227,7 +245,7 @@
(defmethod dom:create-entity-reference ((document document) name) (defmethod dom:create-entity-reference ((document document) name)
(setf name (rod 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))) (dom-error :INVALID_CHARACTER_ERR "not a name: ~A" (rod-string name)))
(make-instance 'entity-reference (make-instance 'entity-reference
:name name :name name
@ -590,7 +608,7 @@
(assert-writeable node) (assert-writeable node)
(setq arg (rod arg)) (setq arg (rod arg))
(with-slots (value) node (with-slots (value) node
(setf value (concatenate (type-of value) value arg))) (setf value (concatenate 'rod value arg)))
(values)) (values))
(defmethod dom:delete-data ((node character-data) offset count) (defmethod dom:delete-data ((node character-data) offset count)
@ -680,7 +698,7 @@
(with-slots (children owner) node (with-slots (children owner) node
;; remove children, add new TEXT-NODE child ;; remove children, add new TEXT-NODE child
;; (alas, we must not reuse an old TEXT-NODE) ;; (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:remove-child node (dom:last-child node)))
(dom:append-child node (dom:create-text-node owner rod)))) (dom:append-child node (dom:create-text-node owner rod))))
new-value) new-value)
@ -756,8 +774,38 @@
(unless (find old-attr items) (unless (find old-attr items)
(dom-error :NOT_FOUND_ERR "Attribute not found.")) (dom-error :NOT_FOUND_ERR "Attribute not found."))
(setf items (remove old-attr items)) (setf items (remove old-attr items))
(maybe-add-default-attribute element (dom:name old-attr))
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) (defmethod dom:get-elements-by-tag-name ((element element) name)
(assert-writeable element) (assert-writeable element)
(get-elements-by-tag-name-internal element name)) (get-elements-by-tag-name-internal element name))
@ -771,7 +819,7 @@
(i 0) (i 0)
(previous nil)) (previous nil))
;; careful here, we're modifying the array we are iterating over ;; 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))) (let ((child (elt children i)))
(cond (cond
((not (eq (dom:node-type child) :text)) ((not (eq (dom:node-type child) :text))
@ -779,7 +827,7 @@
(incf i)) (incf i))
((and previous (eq (dom:node-type previous) :text)) ((and previous (eq (dom:node-type previous) :text))
(setf (slot-value previous 'value) (setf (slot-value previous 'value)
(concatenate 'vector (concatenate 'rod
(dom:data previous) (dom:data previous)
(dom:data child))) (dom:data child)))
(dom:remove-child n child) (dom:remove-child n child)
@ -816,13 +864,13 @@
(defmethod initialize-instance :after ((instance entity-reference) &key) (defmethod initialize-instance :after ((instance entity-reference) &key)
(let* ((owner (dom:owner-document instance)) (let* ((owner (dom:owner-document instance))
(entities (or (entities owner) xml::*entities*)) (handler (dom:make-dom-builder))
(children (xml::resolve-entity (dom:name instance) entities))) (resolver (slot-value owner 'entity-resolver)))
(setf (slot-value instance 'children) (unless resolver
(make-node-list (dom-error :NOT_SUPPORTED_ERR "No entity resolver registered."))
(map 'vector (setf (document handler) owner)
(lambda (node) (dom:import-node owner node t)) (push instance (element-stack handler))
children)))) (funcall resolver (dom:name instance) handler))
(labels ((walk (n) (labels ((walk (n)
(setf (slot-value n 'read-only-p) t) (setf (slot-value n 'read-only-p) t)
(when (dom:element-p n) (when (dom:element-p n)
@ -925,12 +973,13 @@
(import-node-internal 'document-fragment document node deep)) (import-node-internal 'document-fragment document node deep))
(defmethod dom:import-node ((document document) (node element) 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 :element-type :attribute
:owner document)) :owner document))
(result (import-node-internal 'element document node deep (result (import-node-internal 'element document node deep
:attributes attributes :attributes attributes
:tag-name (dom:tag-name node)))) :tag-name (dom:tag-name node))))
(setf (slot-value attributes 'element) result)
(dolist (attribute (dom:items (dom:attributes node))) (dolist (attribute (dom:items (dom:attributes node)))
(when (or (dom:specified attribute) *clone-not-import*) (when (or (dom:specified attribute) *clone-not-import*)
(dom:set-attribute result (dom:name attribute) (dom:value attribute)))) (dom:set-attribute result (dom:name attribute) (dom:value attribute))))
@ -981,3 +1030,19 @@
(defmethod dom:clone-node ((node node) deep) (defmethod dom:clone-node ((node node) deep)
(let ((*clone-not-import* t)) (let ((*clone-not-import* t))
(dom:import-node (dom:owner-document node) node deep))) (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))

29
runes/characters.lisp
View File

@ -24,35 +24,35 @@
(in-package :runes) (in-package :runes)
(deftype rune () 'base-char) (deftype rune () 'character)
(deftype rod () 'base-string) (deftype rod () '(vector character))
(deftype simple-rod () 'simple-string) (deftype simple-rod () '(simple-array character))
(defsubst rune (rod index) (definline rune (rod index)
(char rod index)) (char rod index))
(defun (setf rune) (new rod index) (defun (setf rune) (new rod index)
(setf (char rod index) new)) (setf (char rod index) new))
(defsubst %rune (rod index) (definline %rune (rod index)
(aref (the simple-string rod) (the fixnum 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)) (setf (aref (the simple-string rod) (the fixnum index)) new))
(defun rod-capitalize (rod) (defun rod-capitalize (rod)
(string-upcase rod)) (string-upcase rod))
(defsubst code-rune (x) (code-char x)) (definline code-rune (x) (code-char x))
(defsubst rune-code (x) (char-code x)) (definline rune-code (x) (char-code x))
(defsubst rune= (x y) (definline rune= (x y)
(char= x y)) (char= x y))
(defun rune-downcase (rune) (defun rune-downcase (rune)
(char-downcase rune)) (char-downcase rune))
(defsubst rune-upcase (rune) (definline rune-upcase (rune)
(char-upcase rune)) (char-upcase rune))
(defun rune-upper-case-letter-p (rune) (defun rune-upper-case-letter-p (rune)
@ -70,13 +70,13 @@
(defun rod-upcase (rod) (defun rod-upcase (rod)
(string-upcase rod)) (string-upcase rod))
(defsubst white-space-rune-p (char) (definline white-space-rune-p (char)
(or (char= char #\tab) (or (char= char #\tab)
(char= char #.(code-char 10)) ;Linefeed (char= char #.(code-char 10)) ;Linefeed
(char= char #.(code-char 13)) ;Carriage Return (char= char #.(code-char 13)) ;Carriage Return
(char= char #\space))) (char= char #\space)))
(defsubst digit-rune-p (char &optional (radix 10)) (definline digit-rune-p (char &optional (radix 10))
(digit-char-p char radix)) (digit-char-p char radix))
(defun rod (x) (defun rod (x)
@ -100,7 +100,7 @@
(defun rod-equal (x y) (defun rod-equal (x y)
(string-equal x y)) (string-equal x y))
(defsubst make-rod (size) (definline make-rod (size)
(make-string size)) (make-string size))
(defun char-rune (char) (defun char-rune (char)
@ -134,9 +134,6 @@
(defun rodp (object) (defun rodp (object)
(stringp object)) (stringp object))
(defun really-rod-p (object)
(stringp object))
(defun rod-subseq (source start &optional (end (length source))) (defun rod-subseq (source start &optional (end (length source)))
(unless (stringp source) (unless (stringp source)
(error "~S is not of type ~S." source 'rod)) (error "~S is not of type ~S." source 'rod))

4
runes/dep-acl.lisp
View File

@ -28,13 +28,13 @@
;; Unfortunately it is also incapable to declaim such functions inline. ;; Unfortunately it is also incapable to declaim such functions inline.
;; So we revoke the DEFUN hack from dep-gcl here. ;; 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)) (if (and (consp fun) (eq (car fun) 'setf))
(let ((fnam (intern (concatenate 'string "(SETF " (symbol-name (cadr fun)) ")") (let ((fnam (intern (concatenate 'string "(SETF " (symbol-name (cadr fun)) ")")
(symbol-package (cadr fun))))) (symbol-package (cadr fun)))))
`(progn `(progn
(defsetf ,(cadr fun) (&rest ap) (new-value) (list* ',fnam new-value ap)) (defsetf ,(cadr fun) (&rest ap) (new-value) (list* ',fnam new-value ap))
(runes::defsubst ,fnam ,args .,body))) (runes::definline ,fnam ,args .,body)))
`(progn `(progn
(defun ,fun ,args .,body) (defun ,fun ,args .,body)
(define-compiler-macro ,fun (&rest .args.) (define-compiler-macro ,fun (&rest .args.)

4
runes/dep-acl5.lisp
View File

@ -40,13 +40,13 @@
;; Unfortunately it is also incapable to declaim such functions inline. ;; Unfortunately it is also incapable to declaim such functions inline.
;; So we revoke the DEFUN hack from dep-gcl here. ;; 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)) (if (and (consp fun) (eq (car fun) 'setf))
(let ((fnam (intern (concatenate 'string "(SETF " (symbol-name (cadr fun)) ")") (let ((fnam (intern (concatenate 'string "(SETF " (symbol-name (cadr fun)) ")")
(symbol-package (cadr fun))))) (symbol-package (cadr fun)))))
`(progn `(progn
(defsetf ,(cadr fun) (&rest ap) (new-value) (list* ',fnam new-value ap)) (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) (labels ((declp (x)
(and (consp x) (eq (car x) 'declare)))) (and (consp x) (eq (car x) 'declare))))
`(progn `(progn

46
runes/dep-clisp.lisp
View File

@ -30,30 +30,30 @@
(if (fboundp 'cl::define-compiler-macro) (if (fboundp 'cl::define-compiler-macro)
(pushnew 'define-compiler-macro *features*))) (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 (defmacro runes::definline (name args &body body)
(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)
`(progn `(progn
(declaim (inline ,name)) (declaim (inline ,name))
(defun ,name ,args .,body))) (defun ,name ,args .,body)))

2
runes/dep-cmucl-dtc.lisp
View File

@ -24,7 +24,7 @@
;;; superseded by a newer version) or write to the Free Software ;;; superseded by a newer version) or write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;; 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 `(progn
(declaim (inline ,name)) (declaim (inline ,name))
(defun ,name ,args .,body))) (defun ,name ,args .,body)))

2
runes/dep-cmucl.lisp
View File

@ -24,7 +24,7 @@
;;; superseded by a newer version) or write to the Free Software ;;; superseded by a newer version) or write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;; 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 `(progn
(declaim (inline ,name)) (declaim (inline ,name))
(defun ,name ,args .,body))) (defun ,name ,args .,body)))

2
runes/dep-openmcl.lisp
View File

@ -5,7 +5,7 @@
;;;; ;;;;
;;;; (c) copyright 1999 by Gilbert Baumann ;;;; (c) copyright 1999 by Gilbert Baumann
(defmacro runes::defsubst (fun args &body body) (defmacro runes::definline (fun args &body body)
(if (consp fun) (if (consp fun)
`(defun ,fun ,args `(defun ,fun ,args
,@body) ,@body)

2
runes/dep-sbcl.lisp
View File

@ -24,7 +24,7 @@
;;; superseded by a newer version) or write to the Free Software ;;; superseded by a newer version) or write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;; 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 `(progn
(declaim (inline ,name)) (declaim (inline ,name))
(defun ,name ,args .,body))) (defun ,name ,args .,body)))

36
runes/package.lisp
View File

@ -10,14 +10,7 @@
(defpackage :runes (defpackage :runes
(:use :cl) (:use :cl)
(:export #:defsubst (:export #:definline
;; util.lisp :
#:compose
#:curry
#:rcurry
#:until
#:while
;; runes.lisp ;; runes.lisp
#:rune #:rune
@ -47,4 +40,29 @@
#:rod-string #:rod-string
#:string-rod #:string-rod
#:rod-subseq #: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))

86
runes/runes.lisp
View File

@ -42,26 +42,26 @@
(deftype rod () '(array rune (*))) (deftype rod () '(array rune (*)))
(deftype simple-rod () '(simple-array rune (*))) (deftype simple-rod () '(simple-array rune (*)))
(defsubst rune (rod index) (definline rune (rod index)
(aref rod index)) (aref rod index))
(defun (setf rune) (new rod index) (defun (setf rune) (new rod index)
(setf (aref rod index) new)) (setf (aref rod index) new))
(defsubst %rune (rod index) (definline %rune (rod index)
(aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum 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)) (setf (aref (the (simple-array (unsigned-byte 16) (*)) rod) (the fixnum index)) new))
(defun rod-capitalize (rod) (defun rod-capitalize (rod)
(warn "~S is not implemented." 'rod-capitalize) (warn "~S is not implemented." 'rod-capitalize)
rod) rod)
(defsubst code-rune (x) x) (definline code-rune (x) x)
(defsubst rune-code (x) x) (definline rune-code (x) x)
(defsubst rune= (x y) (definline rune= (x y)
(= x y)) (= x y))
(defun rune-downcase (rune) (defun rune-downcase (rune)
@ -70,7 +70,7 @@
((<= #x00c0 rune #x00de) (+ rune #x20)) ((<= #x00c0 rune #x00de) (+ rune #x20))
(t rune))) (t rune)))
(defsubst rune-upcase (rune) (definline rune-upcase (rune)
(cond ((<= #x0061 rune #x007a) (- rune #x20)) (cond ((<= #x0061 rune #x007a) (- rune #x20))
((= rune #x00f7) rune) ((= rune #x00f7) rune)
((<= #x00e0 rune #x00fe) (- rune #x20)) ((<= #x00e0 rune #x00fe) (- rune #x20))
@ -89,21 +89,19 @@
(defun rod-downcase (rod) (defun rod-downcase (rod)
;; FIXME ;; 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) (defun rod-upcase (rod)
;; FIXME ;; 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 (or (= char 9) ;TAB
(= char 10) ;Linefeed (= char 10) ;Linefeed
(= char 13) ;Carriage Return (= char 13) ;Carriage Return
(= char 32))) ;Space (= 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)) (cond ((<= #.(char-code #\0) char #.(char-code #\9))
(and (< (- char #.(char-code #\0)) radix) (and (< (- char #.(char-code #\0)) radix)
(- char #.(char-code #\0)))) (- char #.(char-code #\0))))
@ -115,11 +113,11 @@
(- char #.(char-code #\a) -10))) )) (- char #.(char-code #\a) -10))) ))
(defun rod (x) (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))) ((symbolp x) (rod (string x)))
((characterp x) (rod (string x))) ((characterp x) (rod (string x)))
((vectorp x) (register-rod (coerce x 'rod))) ((vectorp x) (coerce x 'rod))
((integerp x) (register-rod (map 'rod #'identity (list x)))) ((integerp x) (map 'rod #'identity (list x)))
(t (error "Cannot convert ~S to a ~S" x 'rod)))) (t (error "Cannot convert ~S to a ~S" x 'rod))))
(defun runep (x) (defun runep (x)
@ -143,19 +141,16 @@
(unless (rune-equal (rune x i) (rune y i)) (unless (rune-equal (rune x i) (rune y i))
(return nil))))) (return nil)))))
(defsubst make-rod (size) (definline make-rod (size)
(let ((res (make-array size :element-type 'rune))) (make-array size :element-type 'rune))
(register-rod res)
res))
(defun char-rune (char) (defun char-rune (char)
(code-rune (char-code char))) (code-rune (char-code char)))
(defun rune-char (rune &optional (default #\?)) (defun rune-char (rune &optional (default #\?))
#+CMU (if (>= rune char-code-limit)
(if (< rune 256) (code-char rune) default) default
#-CMU (or (code-char rune) default)))
(or (code-char rune) default))
(defun rod-string (rod &optional (default-char #\?)) (defun rod-string (rod &optional (default-char #\?))
(map 'string (lambda (x) (rune-char x default-char)) rod)) (map 'string (lambda (x) (rune-char x default-char)) rod))
@ -178,10 +173,6 @@
(defun rodp (object) (defun rodp (object)
(typep object 'rod)) (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))) (defun rod-subseq (source start &optional (end (length source)))
(unless (rodp source) (unless (rodp source)
(error "~S is not of type ~S." source 'rod)) (error "~S is not of type ~S." source 'rod))
@ -221,45 +212,6 @@
(declare (type fixnum i)) (declare (type fixnum i))
(setf (%rune res i) (aref source (the fixnum (+ i start)))))))) (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) (defun rod< (rod1 rod2)
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
(nil) (nil)

20
runes/xstream.lisp
View File

@ -65,7 +65,7 @@
;; XSTREAM/CLOSE os-stream ;; 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 3) (safety 0)))
;;(defparameter *fast* '(optimize (speed 2) (safety 3))) ;;(defparameter *fast* '(optimize (speed 2) (safety 3)))
) )
@ -154,6 +154,10 @@
;; `buffer-start'. ;; `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) (defmacro read-rune (input)
"Read a single rune off the xstream `input'. In case of end of file :EOF "Read a single rune off the xstream `input'. In case of end of file :EOF
is returned." is returned."
@ -213,7 +217,7 @@
nil) nil)
,input)) ,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 "Unread the last recently read rune; if there wasn't such a rune, you
deserve to lose." deserve to lose."
(declare (ignore rune)) (declare (ignore rune))
@ -376,10 +380,20 @@
;;; controller implementations ;;; controller implementations
(defmethod read-octets (sequence (stream stream) start end) (defmethod read-octets (sequence (stream stream) start end)
(#+CLISP lisp:read-byte-sequence (#+CLISP ext:read-byte-sequence
#-CLISP read-sequence #-CLISP read-sequence
sequence stream :start start :end end)) 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) (defmethod read-octets (sequence (stream null) start end)
(declare (ignore sequence start end)) (declare (ignore sequence start end))
0) 0)

2
runes/util.lisp → xml/util.lisp
View File

@ -32,7 +32,7 @@
;; subforms ;; subforms
;; ;;
(in-package :runes) (in-package :cxml)
;;; -------------------------------------------------------------------------------- ;;; --------------------------------------------------------------------------------
;;; Meta functions ;;; Meta functions

15
xml/xml-name-rune-p.lisp
View File

@ -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 #.(funcall
(compile (compile
@ -206,12 +211,14 @@
(setf (aref r i) 1))))) ) (setf (aref r i) 1))))) )
`(progn `(progn
(DEFSUBST NAME-RUNE-P (RUNE) (DEFINLINE NAME-RUNE-P (RUNE)
(SETF RUNE (RUNE-CODE RUNE))
(AND (<= 0 RUNE ,*max*) (AND (<= 0 RUNE ,*max*)
(LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))) (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3)))
(= 1 (SBIT ',(predicate-to-bv #'name-rune-p) (= 1 (SBIT ',(predicate-to-bv #'name-rune-p)
(THE FIXNUM RUNE)))))) (THE FIXNUM RUNE))))))
(DEFSUBST NAME-START-RUNE-P (RUNE) (DEFINLINE NAME-START-RUNE-P (RUNE)
(SETF RUNE (RUNE-CODE RUNE))
(AND (<= 0 RUNE ,*MAX*) (AND (<= 0 RUNE ,*MAX*)
(LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3))) (LOCALLY (DECLARE (OPTIMIZE (SAFETY 0) (SPEED 3)))
(= 1 (SBIT ',(predicate-to-bv #'name-start-rune-p) (= 1 (SBIT ',(predicate-to-bv #'name-start-rune-p)

1937
xml/xml-parse.lisp
View File

File diff suppressed because it is too large Load Diff