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

LispWorks port (thanks to Edi Weitz)

Browse Source
This commit is contained in:
dlichteblau
2005-04-20 19:57:59 +00:00
parent 475ee0db12
commit c7610a4a3a
8 changed files with 256 additions and 117 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
README.html
View File

@ -114,6 +114,8 @@ $ cvs co cxml</pre>
to <tt>parse-dtd-stream</tt>; SAX proxy class</li>
<li>Minor bugfixes: Workaround for CMUCL problem
with <tt>fd-streams</tt> (can read from cmucl sockets now)</li>
<li>Port to OpenMCL (thanks to Rudi Schlatte).</li>
<li>Port to LispWorks (thanks to Edi Weitz).</li>
</ul>
<p class="nomargin"><tt>patch-357</tt> (2004-10-10)</p>
<ul class="nomargin">
@ -191,6 +193,9 @@ $ cvs co cxml</pre>
CLISP needs to be run with an option like <tt>-E iso-8869-1</tt>
teaching it to accept cxml's non-ASCII source files.
</li>
<li>
LispWorks
</li>
</ul>
<p>
Incomplete port:

4
cxml.asd
View File

@ -53,7 +53,9 @@
#+(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!")
#+lispworks "dep-lw"
#-(or sbcl CLISP CMU allegro openmcl lispworks)
#.(error "unsupported lisp implementation!")
:depends-on ("package"))
(:file runes
:pathname

8
runes/characters.lisp
View File

@ -24,9 +24,9 @@
(in-package :runes)
(deftype rune () 'character)
(deftype rod () '(vector character))
(deftype simple-rod () '(simple-array character))
(deftype rune () #-lispworks 'character #+lispworks 'lw:simple-char)
(deftype rod () '(vector rune))
(deftype simple-rod () '(simple-array rune))
(definline rune (rod index)
(char rod index))
@ -101,7 +101,7 @@
(string-equal x y))
(definline make-rod (size)
(make-string size))
(make-string size :element-type 'rune))
(defun char-rune (char)
char)

30
runes/dep-lw.lisp Normal file
View File

@ -0,0 +1,30 @@
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CL-USER; -*-
;;; ---------------------------------------------------------------------------
;;; Title: LispWorks dependent stuff + fixups
;;; Created: 2005-01-28 09:43
;;; Author: Edi Weitz <edi@agharta.de> (Copied from dep-cmucl.lisp)
;;; License: LLGPL (See file COPYING for details).
;;; ---------------------------------------------------------------------------
;;; (c) copyright 1999 by Gilbert Baumann
;;; This code is free software; you can redistribute it and/or modify it
;;; under the terms of the version 2.1 of the GNU Lesser General Public
;;; License as published by the Free Software Foundation, as clarified
;;; by the "Preamble to the Gnu Lesser General Public License" found in
;;; the file COPYING.
;;;
;;; This code 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
;;; Lesser General Public License for more details.
;;;
;;; Version 2.1 of the GNU Lesser General Public License is in the file
;;; COPYING that was distributed with this file. If it is not present,
;;; you can access it from http://www.gnu.org/copyleft/lesser.txt (until
;;; 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::definline (name args &body body)
`(progn
(declaim (inline ,name))
(defun ,name ,args .,body)))

117
test/xmlconf.lisp
View File

@ -6,9 +6,16 @@
(defun get-attribute (element name)
(rod-string (dom:get-attribute element name)))
(defun relevant-test-p (test)
(and (equal (get-attribute test "TYPE") "valid")
(let ((version (get-attribute test "RECOMMENDATION")))
(defparameter *bad-tests*
'(;; TS14
;; http://lists.w3.org/Archives/Public/public-xml-testsuite/2002Mar/0001.html
"ibm-valid-P28-ibm28v02.xml"
"ibm-valid-P29-ibm29v01.xml"
"ibm-valid-P29-ibm29v02.xml"))
(defun test-class (test)
(cond
((not (and (let ((version (get-attribute test "RECOMMENDATION")))
(cond
((or (equal version "") ;XXX
(equal version "XML1.0"))
@ -24,7 +31,12 @@
nil)
(t
(warn "unrecognized RECOMMENDATION value: ~S" version)
nil)))))
nil)))
(not (member (get-attribute test "ID") *bad-tests* :test 'equal))))
nil)
((equal (get-attribute test "TYPE") "valid") :valid)
((equal (get-attribute test "TYPE") "invalid") :invalid)
(t nil)))
(defun test-pathnames (directory test)
(let* ((sub-directory
@ -42,10 +54,10 @@
(defun serialize-document (document)
(map 'vector #'char-code
(with-output-to-string (s)
(xml:unparse-document document s))))
(cxml:unparse-document document s :canonical 2))))
(defun file-contents (pathname)
(with-open-file (s pathname)
(with-open-file (s pathname :element-type '(unsigned-byte 8))
(let ((result
(make-array (file-length s) :element-type '(unsigned-byte 8))))
(read-sequence result s )
@ -54,13 +66,19 @@
(defun run-all-tests (directory)
(let* ((pathname (merge-pathnames "xmlconf.xml" directory))
(builder (dom:make-dom-builder))
(xmlconf (xml:parse-file pathname builder))
(xmlconf (cxml:parse-file pathname builder))
(ntried 0)
(nfailed 0)
(nskipped 0))
(nskipped 0)
;; XXX someone found it funny to include invalid URIs in the
;; test suite. And no, in "invalid" not "not-wf".
(puri:*strict-parse* nil))
(dom:do-node-list (test (dom:get-elements-by-tag-name xmlconf "TEST"))
(let ((description
(rod-string (dom:data (dom:item (dom:child-nodes test) 0))))
(class (test-class test)))
(cond
((relevant-test-p test)
(class
(incf ntried)
(multiple-value-bind (pathname output)
(test-pathnames directory test)
@ -68,37 +86,74 @@
(unless (probe-file pathname)
(error "file not found: ~A" pathname))
(with-simple-restart (skip-test "Skip this test")
(unless (run-test class pathname output description)
(incf nfailed))
(fresh-line))))
(t
(incf nskipped)))))
(format t "~&~D/~D tests failed; ~D test~:P were skipped"
nfailed ntried nskipped)))
(defmethod run-test :around (class pathname output description &rest args)
(declare (ignore class pathname output args))
(handler-case
(progn
(mp:with-timeout (60)
(let ((document
(xml:parse-file pathname (dom:make-dom-builder))))
(call-next-method)
(serious-condition (c)
(format t " FAILED:~% ~A~%[~A]~%" c description)
nil)))
(defmethod run-test ((class null) pathname output description &rest args)
(declare (ignore description))
(let ((document (apply #'cxml:parse-file
pathname
(dom:make-dom-builder)
args)))
(cond
((null output)
(format t " ok (output not checked)~%"))
((equalp (file-contents output)
(serialize-document document))
(format t " ok~%"))
(format t " input"))
((equalp (file-contents output) (serialize-document document))
(format t " input/output"))
(t
(let ((error-output
(make-pathname :type "error" :defaults output)))
(let ((error-output (make-pathname :type "error" :defaults output)))
(with-open-file (s error-output
:element-type '(unsigned-byte 8)
:direction :output
:if-exists :supersede)
(write-sequence (serialize-document document) s))
(error "well-formed, but output ~S not the expected ~S~%"
error-output output)))))))
((and serious-condition (not excl:interrupt-signal)) (c)
(incf nfailed)
(format t " FAILED:~% ~A~%[~A]~%"
c
(rod-string
(dom:data
(dom:item (dom:child-nodes test) 0)))))))))
(t
(incf nskipped))))
(format t "~&~D/~D tests failed; ~D test~:P were skipped"
nfailed ntried nskipped)))
error-output output))))
t))
(defmethod run-test
((class (eql :valid)) pathname output description &rest args)
(assert (null args))
(and (progn
(format t " [not validating:]")
(run-test nil pathname output description :validate nil))
(progn
(format t " [validating:]")
(run-test nil pathname output description :validate t))))
(defmethod run-test
((class (eql :invalid)) pathname output description &rest args)
(assert (null args))
(and (progn
(format t " [not validating:]")
(run-test nil pathname output description :validate nil))
(handler-case
(progn
(format t " [validating:]")
(cxml:parse-file pathname (dom:make-dom-builder) :validate t)
(error "validity error not detected")
nil)
(cxml:validity-error ()
(format t " invalid")
t))))
#+(or)
(xmlconf::run-all-tests "/mnt/debian/space/xmlconf/")
#+(or)
(progn
(#+allegro mp:with-timeout #+allegro (60) #-allegro progn
))

67
xml/package.lisp
View File

@ -1,17 +1,23 @@
;;;; package.lisp -- Paketdefinition
;;;;
;;;; This file is part of the CXML parser, released under (L)LGPL.
;;;; See file COPYING for details.
(in-package :cl-user)
(defpackage :Encoding
(:use :glisp)
(defpackage :cxml
(:use :cl :runes :encoding)
(:import-from #+sbcl :sb-gray
#+allegro :excl
#+cmu :ext
#+clisp :gray
#+openmcl :ccl
#+lispworks :stream
#-(or sbcl allegro cmu clisp openmcl lispworks) ...
#:fundamental-binary-input-stream
#-(or clisp openmcl) #:stream-read-sequence
stream-read-byte)
(:export
#:find-encoding
#:decode-sequence))
(defpackage :XML
(:use
:glisp
:encoding)
(:Export
;; xstreams
#:make-xstream
#:make-rod-xstream
@ -38,4 +44,41 @@
#:parse-file
#:parse-stream
#:parse-string) )
;; XXX encoding is mis-handled by parse-string, don't export it
;; #:parse-string
#:parse-octets
#:make-character-stream-sink
#:make-octet-vector-sink
#:make-octet-stream-sink
#:unparse-document
#:unparse-document-to-octets
#:with-xml-output
#:with-element
#:attribute
#:cdata
#:text
#:parse-dtd-file
#:parse-dtd-stream
#:validity-error
#:make-validator
#:*cache-all-dtds*
#:*dtd-cache*
#:getdtd
#:remdtd
#:make-dtd-cache
#:clear-dtd-cache
#:make-extid
#:*catalog*
#:*prefer*
#:make-catalog
#:resolve-uri
#:resolve-extid
#:make-recoder
#:sax-proxy
#:proxy-chained-handler))

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

@ -162,8 +162,9 @@
(<= 12540 rune 12542)))
(base-rune-p (rune)
;; split into two ORs for LispWorks...
(or
(<= 65 rune 90) (<= 97 rune 122) (<= 192 rune 214) (<= 216 rune 246) (<= 248 rune 255) (<= 256 rune 305)
(or (<= 65 rune 90) (<= 97 rune 122) (<= 192 rune 214) (<= 216 rune 246) (<= 248 rune 255) (<= 256 rune 305)
(<= 308 rune 318) (<= 321 rune 328) (<= 330 rune 382) (<= 384 rune 451) (<= 461 rune 496) (<= 500 rune 501)
(<= 506 rune 535) (<= 592 rune 680) (<= 699 rune 705) (= 902 rune) (<= 904 rune 906) (= 908 rune)
(<= 910 rune 929) (<= 931 rune 974) (<= 976 rune 982) (= 986 rune) (= 988 rune) (= 990 rune) (= 992 rune)
@ -180,7 +181,8 @@
(<= 2738 rune 2739) (<= 2741 rune 2745) (= 2749 rune) (= 2784 rune) (<= 2821 rune 2828) (<= 2831 rune 2832)
(<= 2835 rune 2856) (<= 2858 rune 2864) (<= 2866 rune 2867) (<= 2870 rune 2873) (= 2877 rune)
(<= 2908 rune 2909) (<= 2911 rune 2913) (<= 2949 rune 2954) (<= 2958 rune 2960) (<= 2962 rune 2965)
(<= 2969 rune 2970) (= 2972 rune) (<= 2974 rune 2975) (<= 2979 rune 2980) (<= 2984 rune 2986)
(<= 2969 rune 2970) (= 2972 rune))
(or (<= 2974 rune 2975) (<= 2979 rune 2980) (<= 2984 rune 2986)
(<= 2990 rune 2997) (<= 2999 rune 3001) (<= 3077 rune 3084) (<= 3086 rune 3088) (<= 3090 rune 3112)
(<= 3114 rune 3123) (<= 3125 rune 3129) (<= 3168 rune 3169) (<= 3205 rune 3212) (<= 3214 rune 3216)
(<= 3218 rune 3240) (<= 3242 rune 3251) (<= 3253 rune 3257) (= 3294 rune) (<= 3296 rune 3297)
@ -198,7 +200,7 @@
(= 8025 rune) (= 8027 rune) (= 8029 rune) (<= 8031 rune 8061) (<= 8064 rune 8116) (<= 8118 rune 8124) (= 8126 rune)
(<= 8130 rune 8132) (<= 8134 rune 8140) (<= 8144 rune 8147) (<= 8150 rune 8155) (<= 8160 rune 8172)
(<= 8178 rune 8180) (<= 8182 rune 8188) (= 8486 rune) (<= 8490 rune 8491) (= 8494 rune) (<= 8576 rune 8578)
(<= 12353 rune 12436) (<= 12449 rune 12538) (<= 12549 rune 12588) (<= 44032 rune 55203)))
(<= 12353 rune 12436) (<= 12449 rune 12538) (<= 12549 rune 12588) (<= 44032 rune 55203))))
(ideographic-rune-p (rune)
(or (<= 19968 rune 40869) (= 12295 rune) (<= 12321 rune 12329)))

4
xml/xml-parse.lisp
View File

@ -3004,8 +3004,10 @@
(elt octets pos)
(incf pos)))))
(defmethod stream-read-sequence ((stream octet-input-stream) sequence
(defmethod stream-read-sequence
#-lispworks ((stream octet-input-stream) sequence
&optional (start 0) (end (length sequence)))
#+lispworks ((stream octet-input-stream) sequence start end)
(with-slots (octets pos) stream
(let* ((length (min (- end start) (- (length octets) pos)))
(end1 (+ start length))