- cxml-cvs@common-lisp.net - mailman3.common-lisp.net

[cxml-cvs] CVS update: cxml/xml/xml-parse.lisp
by dlichteblau＠common-lisp.net 26 Nov '05

26 Nov '05

Update of /project/cxml/cvsroot/cxml/xml In directory common-lisp.net:/tmp/cvs-serv15327/xml Modified Files: xml-parse.lisp Log Message: trailing whitespace weg Date: Sat Nov 26 23:15:10 2005 Author: dlichteblau Index: cxml/xml/xml-parse.lisp diff -u cxml/xml/xml-parse.lisp:1.7 cxml/xml/xml-parse.lisp:1.8 --- cxml/xml/xml-parse.lisp:1.7 Sat Nov 26 22:48:25 2005 +++ cxml/xml/xml-parse.lisp Sat Nov 26 23:15:10 2005 @@ -23,8 +23,8 @@ ;;; 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, +;;; License along with this library; if not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Streams @@ -83,7 +83,7 @@ ;; :#fixed ;; :#pcdata ;; :s -;; :\[ :\] :\( :\) :|\ :\> :\" :\' :\, :\? :\* :\+ +;; :\[ :\] :\( :\) :|\ :\> :\" :\' :\, :\? :\* :\+ ;; *data-behaviour* = :DOC ;; @@ -96,7 +96,7 @@ ;;; NOTES ;; ;; Stream buffers as well as RODs are supposed to be encoded in -;; UTF-16. +;; UTF-16. ;; where does the time go? ;; DATA-RUNE-P @@ -105,7 +105,7 @@ ;; CLOSy DOM ;; UTF-8 decoder (13%) ;; READ-ATTVAL (10%) -;; +;; ;;; TODO ;; @@ -153,7 +153,7 @@ ;; ;; o merge node representation with SGML module ;; [???] -;; +;; ;; o line/column number recording ;; ;; o better error messages @@ -294,7 +294,7 @@ ;; respectively. If there are not enough bytes in `input' to decode a ;; full character, decoding shold be abandomed; the caller has to ;; ensure that the remaining bytes of `input' are passed to the -;; decoder again with more bytes appended. +;; decoder again with more bytes appended. ;; ;; `eof-p' now in turn indicates, if the given input sequence, is all ;; the producer does have and might be used to produce error messages @@ -319,9 +319,9 @@ ;; 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) +(defmacro fx-op (op &rest xs) `(the fixnum (,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs)))) -(defmacro fx-pred (op &rest xs) +(defmacro fx-pred (op &rest xs) `(,op ,@(mapcar (lambda (x) `(the fixnum ,x)) xs))) (defmacro %+ (&rest xs) `(fx-op + ,@xs)) @@ -342,9 +342,9 @@ ;;; XXX Geschwindigkeit dieser Definitionen untersuchen! -(defmacro rune-op (op &rest xs) +(defmacro rune-op (op &rest xs) `(code-rune (,op ,@(mapcar (lambda (x) `(rune-code ,x)) xs)))) -(defmacro rune-pred (op &rest xs) +(defmacro rune-pred (op &rest xs) `(,op ,@(mapcar (lambda (x) `(rune-code ,x)) xs))) (defmacro %rune+ (&rest xs) `(rune-op + ,@xs)) @@ -370,7 +370,7 @@ ;;; make-rod-hashtable ;;; rod-hash-get hashtable rod &optional start end -> value ; successp ;;; (setf (rod-hash-get hashtable rod &optional start end) new-value -;;; +;;; (defstruct (rod-hashtable (:constructor make-rod-hashtable/low)) size ;size of table @@ -554,8 +554,8 @@ (,i 0) (,b ,scratch)) (declare (type fixnum ,n ,i)) - (macrolet - ((,collect (x) + (macrolet + ((,collect (x) `((lambda (x) (locally (declare #.*fast*) @@ -575,7 +575,7 @@ `(let ((,rod (make-rod ,i))) (while (not (%= ,i 0)) (setf ,i (%- ,i 1)) - (setf (%rune ,rod ,i) + (setf (%rune ,rod ,i) (aref (the (simple-array rune (*)) ,b) ,i))) ,rod)) (:raw @@ -590,8 +590,8 @@ `(let ((,n (length ,scratch)) (,i 0)) (declare (type fixnum ,n ,i)) - (macrolet - ((,collect (x) + (macrolet + ((,collect (x) `((lambda (x) (locally (declare #.*fast*) @@ -611,7 +611,7 @@ `(let ((,rod (make-rod ,i))) (while (%> ,i 0) (setf ,i (%- ,i 1)) - (setf (%rune ,rod ,i) + (setf (%rune ,rod ,i) (aref (the (simple-array rune (*)) ,scratch) ,i))) ,rod)) (:raw @@ -670,14 +670,21 @@ ;;;; DTD ;;;; -(define-condition parser-error (simple-error) ()) -(define-condition validity-error (parser-error) ()) +(define-condition parse-error (simple-error) ()) +(define-condition well-formedness-violation (parse-error) ()) +(define-condition end-of-xstream (well-formedness-violation) ()) +(define-condition validity-error (parse-error) ()) (defun validity-error (x &rest args) (error 'validity-error :format-control "Validity constraint violated: ~@?" :format-arguments (list x args))) +(defun wf-error (x &rest args) + (error 'well-formedness-violation + :format-control "Validity constraint violated: ~@?" + :format-arguments (list x args))) + (defvar *validate* t) (defvar *markup-declaration-external-p* nil) @@ -768,7 +775,7 @@ (defun validate-attribute* (ctx adef value) (let ((type (attdef-type adef)) - (default (attdef-default adef))) + (default (attdef-default adef))) (when (and (listp default) (eq (car default) :FIXED) (not (rod= value (cadr default)))) @@ -921,7 +928,7 @@ ;; `zstream' is for error messages (let ((def (get-entity-definition entity-name kind (dtd *ctx*)))) (unless def - (if zstream + (if zstream (perror zstream "Entity '~A' is not defined." (rod-string entity-name)) (error "Entity '~A' is not defined." (rod-string entity-name)))) (let (r) @@ -1145,7 +1152,7 @@ (defun peek-token (input) (cond ((zstream-token-category input) - (values + (values (zstream-token-category input) (zstream-token-semantic input))) (t @@ -1224,7 +1231,7 @@ (t (error "Unexpected character ~S." c)))) (:DOC - (cond + (cond ((rune= c #/&) (multiple-value-bind (kind data) (read-entity-ref input) (cond ((eq kind :NAMED) @@ -1450,7 +1457,7 @@ (assert (rune= c #/\;)) (ecase mode (:ATT - (recurse-on-entity + (recurse-on-entity zinput name :general (lambda (zinput) (muffle (car (zstream-input-stack zinput)) @@ -1471,7 +1478,7 @@ (setf c (read-rune input)) (assert (rune= c #/\;)) (cond (*expand-pe-p* - (recurse-on-entity + (recurse-on-entity zinput name :parameter (lambda (zinput) (muffle (car (zstream-input-stack zinput)) @@ -1560,8 +1567,8 @@ (unless (data-rune-p d) (error "Illegal char: ~S." d)) (when (rune= d #/>) (return)) - (when (rune= d #/?) - (collect #/?) + (when (rune= d #/?) + (collect #/?) (go state-2)) (collect #/?) (collect d) @@ -1659,7 +1666,7 @@ (when (rune= d #/\]) (go state-2)) (collect d) (go state-1) - + state-2 ;; #/\] seen (setf d (peek-rune input)) (when (or (eq d :eof) (rune= d #/<) (rune= d #/&)) @@ -1672,7 +1679,7 @@ (collect #/\]) (collect d) (go state-1) - + state-3 ;; #/\] #/\] seen (setf d (peek-rune input)) (when (or (eq d :eof) (rune= d #/<) (rune= d #/&)) @@ -1682,7 +1689,7 @@ (read-rune input) (unless (data-rune-p d) (error "Illegal char: ~S." d)) - (when (rune= d #/>) + (when (rune= d #/>) (error "For no apparent reason ']]>' in not allowed in a CharData token -- you lost.")) (when (rune= d #/\]) (collect #/\]) @@ -1848,14 +1855,14 @@ (defun p/default-decl (input) ;; [60] DefaultDecl ::= '#REQUIRED' | '#IMPLIED' ;; | (('#FIXED' S)? AttValue) /* VC: Required Attribute */ - ;; + ;; ;; /* VC: Attribute Default Legal */ ;; /* WFC: No < in Attribute Values */ ;; /* VC: Fixed Attribute Default */ (multiple-value-bind (cat sem) (peek-token input) - (cond ((eq cat :|#REQUIRED|) + (cond ((eq cat :|#REQUIRED|) (consume-token input) :REQUIRED) - ((eq cat :|#IMPLIED|) + ((eq cat :|#IMPLIED|) (consume-token input) :IMPLIED) ((eq cat :|#FIXED|) (consume-token input) @@ -2173,10 +2180,10 @@ ((and (walk (car x)) (walk (cdr x))))))) (walk cspec)))) - + ;; wir fahren besser, wenn wir machen: -;; cspec ::= 'EMPTY' | 'ANY' | '#PCDATA' +;; cspec ::= 'EMPTY' | 'ANY' | '#PCDATA' ;; | Name ;; | cs ;; cs ::= '(' S? cspec ( S? '|' S? cspec)* S? ')' ('?' | '*' | '+')? @@ -2186,8 +2193,8 @@ (let ((term (let ((names nil) op-cat op res stream) (multiple-value-bind (cat sem) (peek-token input) - (cond ((eq cat :name) - (consume-token input) + (cond ((eq cat :name) + (consume-token input) (cond ((rod= sem '#.(string-rod "EMPTY")) :EMPTY) ((rod= sem '#.(string-rod "ANY")) @@ -2247,14 +2254,14 @@ (trivialp (cadr cspec))))) :PCDATA cspec))) - + ;; [52] AttlistDecl ::= '<!ATTLIST' S Name AttDef* S? '>' - + ;; [52] AttlistDecl ::= '<!ATTLIST' S Name AttDefs S? '>' ;; [52] AttlistDecl ::= '<!ATTLIST' S Name S? '>' ;; [53] AttDefs ::= S Name S AttType S DefaultDecl AttDefs -;; [53] AttDefs ::= +;; [53] AttDefs ::= (defun p/notation-decl (input) (let (name id) @@ -2381,7 +2388,7 @@ (defun p/markup-decl-unsafe (input) ;; markupdecl ::= elementdecl | AttlistDecl /* VC: Proper Declaration/PE Nesting */ - ;; | EntityDecl | NotationDecl + ;; | EntityDecl | NotationDecl ;; | PI | Comment /* WFC: PEs in Internal Subset */ (case (peek-token input) (:|<!ELEMENT| (p/element-decl input)) @@ -2530,7 +2537,7 @@ (:COMMENT (sax:comment (handler *ctx*) (nth-value 1 (peek-token input)))) (:PI - (sax:processing-instruction + (sax:processing-instruction (handler *ctx*) (car (nth-value 1 (peek-token input))) (cdr (nth-value 1 (peek-token input)))))) @@ -2598,10 +2605,10 @@ (unless v (validity-error "(11) IDREF: ~S not defined" (rod-string k)))) (id-table *ctx*)) - - (dolist (name (referenced-notations *ctx*)) + + (dolist (name (referenced-notations *ctx*)) (unless (find-notation name (dtd *ctx*)) - (validity-error "(23) Notation Declared: ~S" (rod-string name))))) + (validity-error "(23) Notation Declared: ~S" (rod-string name))))) (sax:end-document handler)))) (defun p/element (input) @@ -2698,7 +2705,7 @@ (p/content input)))) ((:<!\[) (consume-token input) - (cons + (cons (let ((input (car (zstream-input-stack input)))) (unless (and (rune= #/C (read-rune input)) (rune= #/D (read-rune input)) @@ -2749,7 +2756,7 @@ (unless (eq (peek-rune i) :eof) (error "Garbage at end of XML PI.")) ;; versioninfo muss da sein - ;; dann ? encodingdecl + ;; dann ? encodingdecl ;; dann ? sddecl ;; dann ende (when (and (not (eq (caar atts) (intern-name '#.(string-rod "version")))) @@ -2793,7 +2800,7 @@ (error "Hypersensitivity pitfall: ~ XML PI's 'standalone' attribute must be exactly \"yes\" or \"no\" and not ~S." (rod-string (cdar atts)))) - (setf (xml-header-standalone-p res) + (setf (xml-header-standalone-p res) (if (rod-equal '#.(string-rod "yes") (cdar atts)) :yes :no)) @@ -2802,7 +2809,7 @@ (error "XML designers decided to disallow future extensions to the set ~ of allowed XML PI's attributes -- you might have lost big on ~S (~S)" (rod-string content) sd-ok-p - )) + )) res)) ;;;; --------------------------------------------------------------------------- @@ -2847,7 +2854,7 @@ (dolist (pair pairs) (if first (setf first nil) - (write-char #\& s)) + (write-char #\& s)) (write-string (escape (car pair)) s) (write-char #\= s) (write-string (escape (cdr pair)) s)))))) @@ -2949,7 +2956,7 @@ (defun parse-stream (stream handler &rest args) (let ((xstream - (make-xstream + (make-xstream stream :name (make-stream-name :entity-name "main document" @@ -3062,7 +3069,7 @@ (defparameter *test-files* '(;;"jclark:xmltest;not-wf;*;*.xml" - "jclark:xmltest;valid;*;*.xml" + "jclark:xmltest;valid;*;*.xml" ;;"jclark:xmltest;invalid;*.xml" )) @@ -3089,7 +3096,7 @@ (negative-test-file filename)))) (defun positive-test-file (filename out-filename) - (multiple-value-bind (nodes condition) + (multiple-value-bind (nodes condition) (ignore-errors (parse-file filename)) (cond (condition (warn "**** Error in ~S: ~A." filename condition) @@ -3122,7 +3129,7 @@ t))))))) (defun negative-test-file (filename) - (multiple-value-bind (nodes condition) + (multiple-value-bind (nodes condition) (ignore-errors (parse-file filename)) (declare (ignore nodes)) (cond (condition @@ -3214,17 +3221,17 @@ (t we continue (sf rptr (%+ rptr 1))) )) - ,@body )) + ,@body )) ||# ;(defun read-data-until (predicate input continuation) ; ) (defmacro read-data-until* ((predicate input res res-start res-end) &body body) - "Read data from `input' until `predicate' applied to the read char + "Read data from `input' until `predicate' applied to the read char turns true. Then execute `body' with `res', `res-start', `res-end' bound to denote a subsequence (of RUNEs) containing the read portion. - The rune upon which `predicate' turned true is neither consumed from + The rune upon which `predicate' turned true is neither consumed from the stream, nor included in `res'. Keep the predicate short, this it may be included more than once into @@ -3234,11 +3241,11 @@ (collect (gensym)) (c (gensym))) `(LET ((,input-var ,input)) - (MULTIPLE-VALUE-BIND (,res ,res-start ,res-end) + (MULTIPLE-VALUE-BIND (,res ,res-start ,res-end) (WITH-RUNE-COLLECTOR/RAW (,collect) (LOOP (LET ((,c (PEEK-RUNE ,input-var))) - (COND ((EQ ,c :EOF) + (COND ((EQ ,c :EOF) ;; xxx error message (RETURN)) ((FUNCALL ,predicate ,c) @@ -3248,11 +3255,11 @@ (CONSUME-RUNE ,input-var)))))) (LOCALLY ,@body))))) - + (defun read-name-token (input) (read-data-until* ((lambda (rune) (declare (type rune rune)) - (not (name-rune-p rune))) + (not (name-rune-p rune))) input r rs re) (intern-name r rs re))) @@ -3308,7 +3315,7 @@ (let ((name (read-name-token input))) (setf c (read-rune input)) (assert (rune= c #/\;)) - (recurse-on-entity + (recurse-on-entity zinput name :general (lambda (zinput) (muffle (car (zstream-input-stack zinput))))))))) @@ -3325,7 +3332,7 @@ (t (collect c))))))) (declare (dynamic-extent #'muffle)) - (recurse-on-entity + (recurse-on-entity zinput name :general (lambda (zinput) (muffle (car (zstream-input-stack zinput))))) )))) @@ -3385,7 +3392,7 @@ '((#"" . nil) (#"xmlns" . #"http://www.w3.org/2000/xmlns/") (#"xml" . #"http://www.w3.org/XML/1998/namespace"))) - + ;; We already know that name is part of a valid XML name, so all we ;; have to check is that the first rune is a name-start-rune and that ;; there is not colon in it. @@ -3403,7 +3410,7 @@ (values prefix local-name) (error "~S is not a valid NcName." local-name))) (values () qname)))) - + (defun decode-qname (qname) "decode-qname name => namespace-uri, prefix, local-name" (declare (type runes:simple-rod qname)) @@ -3509,7 +3516,7 @@ (let (attributes) (dolist (pair attr-alist) (push (build-attribute (car pair) (cdr pair) t) attributes)) - + ;; 5.3 Uniqueness of Attributes ;; In XML documents conforming to [the xmlns] specification, no ;; tag may contain two attributes which: @@ -3532,7 +3539,7 @@ (error "Multiple definitions of attribute ~S in namespace ~S." (mu (sax:attribute-local-name attr-1)) (mu (sax:attribute-namespace-uri attr-1)))))))) - + (defun build-attribute (name value specified-p) (multiple-value-bind (prefix local-name) (split-qname name) (declare (ignorable local-name)) @@ -3549,25 +3556,6 @@ :namespace-uri uri :local-name local-name :specified-p specified-p))))) - -;;; Faster constructors - -;; Since using the general DOM interface to construct the parsed trees -;; may turn out to be quite expensive (That depends on the underlying -;; DOM implementation). A particular DOM implementation may choose to -;; implement an XML:FAST-CONSTRUCTORS method: - -;; XML:FAST-CONSTRUCTORS document [method] -;; -;; Return an alist of constructors suitable for the document `document'. -;; -;; (:MAKE-TEXT document parent data) -;; (:MAKE-PROCESSING-INSTRUCTION document parent target content) -;; (:MAKE-NODE document parent attributes content) -;; [`attributes' now in turn is an alist] -;; (:MAKE-CDATA document parent data) -;; (:MAKE-COMMENT document parent data) -;; ;;;;;;;;;;;;;;;;; @@ -3592,18 +3580,8 @@ ;; `base' yielding an absolute system identifier suitable for ;; OPEN-SYS-ID. -;; xstream Controller Protocol -;; -;; - - -#|| -(defun xml-parse (system-id &key document standalone-p) - ) -||# ;;;;;;;;;;;;;;;;; - ;;; SAX validation handler (defclass validator ()

1 0

[cxml-cvs] CVS update: cxml/xml/package.lisp cxml/xml/xml-name-rune-p.lisp cxml/xml/xml-parse.lisp
by dlichteblau＠common-lisp.net 26 Nov '05

26 Nov '05

Update of /project/cxml/cvsroot/cxml/xml In directory common-lisp.net:/tmp/cvs-serv14107/xml Modified Files: package.lisp xml-name-rune-p.lisp xml-parse.lisp Log Message: - use trivial-gray-streams - replaced dep-* files, since most of them were identical Date: Sat Nov 26 22:48:25 2005 Author: dlichteblau Index: cxml/xml/package.lisp diff -u cxml/xml/package.lisp:1.2 cxml/xml/package.lisp:1.3 --- cxml/xml/package.lisp:1.2 Wed Apr 20 21:58:07 2005 +++ cxml/xml/package.lisp Sat Nov 26 22:48:25 2005 @@ -6,17 +6,7 @@ (in-package :cl-user) (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) + (:use :cl :runes :encoding :trivial-gray-streams) (:export ;; xstreams #:make-xstream Index: cxml/xml/xml-name-rune-p.lisp diff -u cxml/xml/xml-name-rune-p.lisp:1.3 cxml/xml/xml-name-rune-p.lisp:1.4 --- cxml/xml/xml-name-rune-p.lisp:1.3 Wed Apr 20 21:58:07 2005 +++ cxml/xml/xml-name-rune-p.lisp Sat Nov 26 22:48:25 2005 @@ -11,7 +11,7 @@ (compile nil '(lambda () - (let ((*max* #xD800)) + (let ((.max. #xD800)) (labels ((name-start-rune-p (rune) (or (letter-rune-p rune) @@ -207,7 +207,7 @@ (predicate-to-bv (p) - (let ((r (make-array *max* :element-type 'bit :initial-element 0))) + (let ((r (make-array .max. :element-type 'bit :initial-element 0))) (dotimes (i #x10000 r) (when (funcall p i) (setf (aref r i) 1))))) ) @@ -215,13 +215,13 @@ `(progn (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))) (= 1 (SBIT ',(predicate-to-bv #'name-rune-p) (THE FIXNUM 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))) (= 1 (SBIT ',(predicate-to-bv #'name-start-rune-p) (THE FIXNUM RUNE)))))))) )))) Index: cxml/xml/xml-parse.lisp diff -u cxml/xml/xml-parse.lisp:1.6 cxml/xml/xml-parse.lisp:1.7 --- cxml/xml/xml-parse.lisp:1.6 Tue Aug 16 17:03:05 2005 +++ cxml/xml/xml-parse.lisp Sat Nov 26 22:48:25 2005 @@ -2608,7 +2608,7 @@ (if sax:*namespace-processing* (p/element-ns input) (p/element-no-ns input))) - + (defun p/element-no-ns (input) ;; [39] element ::= EmptyElemTag | STag content ETag (error "sorry, bitrot") @@ -2660,14 +2660,16 @@ (error "Expecting element, got ~S." cat))))) (undeclare-namespaces ns-decls)) (validate-end-element *ctx* name))) - + (defun perror (stream format-string &rest format-args) (when (zstream-p stream) (setf stream (car (zstream-input-stack stream)))) - (error "Parse error at line ~D column ~D: ~A" - (xstream-line-number stream) - (xstream-column-number stream) - (apply #'format nil format-string format-args))) + (if stream + (error "Parse error at line ~D column ~D: ~?" + (xstream-line-number stream) + (xstream-column-number stream) + format-string format-args) + (apply #'error format-string format-args))) (defun p/content (input) ;; [43] content ::= (element | CharData | Reference | CDSect | PI | Comment)* @@ -2988,7 +2990,8 @@ ;; XXX encoding is mis-handled by this kind of stream (make-rod-xstream (string-rod string))) -(defclass octet-input-stream (fundamental-binary-input-stream) +(defclass octet-input-stream + (trivial-gray-stream fundamental-binary-input-stream) ((octets :initarg :octets) (pos :initform 0))) @@ -3005,9 +3008,7 @@ (incf pos))))) (defmethod stream-read-sequence - #-lispworks ((stream octet-input-stream) sequence - &optional (start 0) (end (length sequence))) - #+lispworks ((stream octet-input-stream) sequence start end) + ((stream octet-input-stream) sequence start end &key &allow-other-keys) (with-slots (octets pos) stream (let* ((length (min (- end start) (- (length octets) pos))) (end1 (+ start length)) @@ -3021,20 +3022,6 @@ (defun parse-octets (octets handler &rest args) (apply #'parse-stream (make-octet-input-stream octets) handler args)) - -;;;; - -#+allegro -(defmacro sp (&body body) - `(progn - (prof:with-profiling (:type :space) .,body) - (prof:show-flat-profile))) - -#+allegro -(defmacro tm (&body body) - `(progn - (prof:with-profiling (:type :time) .,body) - (prof:show-flat-profile))) ;;;;

1 0

[cxml-cvs] CVS update: cxml/runes/definline.lisp cxml/runes/dep-acl.lisp cxml/runes/dep-acl5.lisp cxml/runes/dep-clisp.lisp cxml/runes/dep-cmucl-dtc.lisp cxml/runes/dep-cmucl.lisp cxml/runes/dep-lw.lisp cxml/runes/dep-openmcl.lisp cxml/runes/dep-sbcl.lisp
by dlichteblau＠common-lisp.net 26 Nov '05

26 Nov '05

Update of /project/cxml/cvsroot/cxml/runes In directory common-lisp.net:/tmp/cvs-serv14107/runes Added Files: definline.lisp Removed Files: dep-acl.lisp dep-acl5.lisp dep-clisp.lisp dep-cmucl-dtc.lisp dep-cmucl.lisp dep-lw.lisp dep-openmcl.lisp dep-sbcl.lisp Log Message: - use trivial-gray-streams - replaced dep-* files, since most of them were identical Date: Sat Nov 26 22:48:18 2005 Author: dlichteblau

1 0

[cxml-cvs] CVS update: cxml/dom/dom-builder.lisp
by dlichteblau＠common-lisp.net 26 Nov '05

26 Nov '05

Update of /project/cxml/cvsroot/cxml/dom In directory common-lisp.net:/tmp/cvs-serv14107/dom Modified Files: dom-builder.lisp Log Message: - use trivial-gray-streams - replaced dep-* files, since most of them were identical Date: Sat Nov 26 22:48:17 2005 Author: dlichteblau Index: cxml/dom/dom-builder.lisp diff -u cxml/dom/dom-builder.lisp:1.1.1.13 cxml/dom/dom-builder.lisp:1.2 --- cxml/dom/dom-builder.lisp:1.1.1.13 Sun Mar 13 19:02:51 2005 +++ cxml/dom/dom-builder.lisp Sat Nov 26 22:48:17 2005 @@ -8,10 +8,6 @@ ;;;; Author: David Lichteblau <david(a)lichteblau.com> ;;;; Author: knowledgeTools Int. GmbH -;;; XXX this DOM builder knows too much about the specifics of the DOM -;;; implementation for my taste. We need a sensible protocol for fast DOM -;;; building. - (in-package :dom-impl) (defclass dom-builder ()

1 0

[cxml-cvs] CVS update: cxml/doc/installation.html
by dlichteblau＠common-lisp.net 26 Nov '05

26 Nov '05

Update of /project/cxml/cvsroot/cxml/doc In directory common-lisp.net:/tmp/cvs-serv14107/doc Modified Files: installation.html Log Message: - use trivial-gray-streams - replaced dep-* files, since most of them were identical Date: Sat Nov 26 22:48:17 2005 Author: dlichteblau Index: cxml/doc/installation.html diff -u cxml/doc/installation.html:1.1 cxml/doc/installation.html:1.2 --- cxml/doc/installation.html:1.1 Sat Jun 25 15:56:54 2005 +++ cxml/doc/installation.html Sat Nov 26 22:48:16 2005 @@ -88,11 +88,8 @@ implemented as an array of character codes. CXML will auto-detect at compile-time which string representation to use. To override the auto-detection, you can set one of the features - <tt>:rune-is-character</tt> and <tt>:rune-is-octet</tt> before - loading <tt>cxml.asd</tt>. (<tt>fixme</tt>: feature - <tt>:rune-is-octet</tt> is of course misnamed, since it uses 16bit - runes, not 8bit runes. It will probably be renamed - to <tt>:rune-is-integer</tt> at some point.) + <tt>:rune-is-character</tt> and <tt>:rune-is-integer</tt> before + loading <tt>cxml.asd</tt>. </p> -->

1 0

[cxml-cvs] CVS update: cxml/README.html cxml/cxml.asd
by dlichteblau＠common-lisp.net 26 Nov '05

26 Nov '05

Update of /project/cxml/cvsroot/cxml In directory common-lisp.net:/tmp/cvs-serv14107 Modified Files: README.html cxml.asd Log Message: - use trivial-gray-streams - replaced dep-* files, since most of them were identical Date: Sat Nov 26 22:48:16 2005 Author: dlichteblau Index: cxml/README.html diff -u cxml/README.html:1.5 cxml/README.html:1.6 --- cxml/README.html:1.5 Sat Jun 25 15:56:50 2005 +++ cxml/README.html Sat Nov 26 22:48:15 2005 @@ -86,6 +86,10 @@ <a name="changes"/> <h2>Recent Changes</h2> + <p class="nomargin"><tt>rel-2005-xx-yy</tt></p> + <ul class="nomargin"> + <li>Use trivial-gray-streams.</li> + </ul> <p class="nomargin"><tt>rel-2005-06-25</tt></p> <ul class="nomargin"> <li>Port to OpenMCL (thanks to Rudi Schlatte).</li> Index: cxml/cxml.asd diff -u cxml/cxml.asd:1.5 cxml/cxml.asd:1.6 --- cxml/cxml.asd:1.5 Sat Jun 25 15:56:50 2005 +++ cxml/cxml.asd Sat Nov 26 22:48:16 2005 @@ -5,10 +5,6 @@ (: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 @@ -18,7 +14,7 @@ (let (#+sbcl (*compile-print* nil)) (call-next-method)))) -#-(or rune-is-character rune-is-octet) +#-(or rune-is-character rune-is-integer) (progn (format t "~&;;; Checking for wide character support...") (force-output) @@ -28,7 +24,7 @@ :rune-is-character)) (unless (and (< x char-code-limit) (code-char x)) (format t " no, reverting to octet strings.~%") - (return :rune-is-octet))) + (return :rune-is-integer))) *features*)) #-rune-is-character @@ -37,38 +33,26 @@ #+rune-is-character (format t "~&;;; Building cxml with CHARACTER RUNES~%") -(defsystem runes +(defsystem :cxml-runes :default-component-class closure-source-file :pathname (merge-pathnames "runes/" (make-pathname :name nil :type nil :defaults *load-truename*)) :components ((: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-version>= (version>= 5.0)) "dep-acl5" - #+(and allegro-version>= (not (version>= 5.0))) "dep-acl" - #+openmcl "dep-openmcl" - #+lispworks "dep-lw" - #-(or sbcl CLISP CMU allegro openmcl lispworks) - #.(error "unsupported lisp implementation!") - :depends-on ("package")) + (:file "definline" :depends-on ("package")) (:file runes :pathname #-rune-is-character "runes" #+rune-is-character "characters" - :depends-on ("package" dependent)) - (:file "syntax" :depends-on ("package" dependent runes)) + :depends-on ("package" "definline")) + (:file "syntax" :depends-on ("package" "definline" runes)) (:file "encodings" :depends-on ("package")) (:file "encodings-data" :depends-on ("package" "encodings")) (:file "xstream" - :depends-on ("package" dependent "syntax" "encodings-data")))) + :depends-on ("package" "definline" "syntax" "encodings-data")))) -(asdf:defsystem :xml +(asdf:defsystem :cxml-xml :default-component-class closure-source-file :pathname (merge-pathnames "xml/" @@ -86,9 +70,9 @@ (:file "recoder" :depends-on ("xml-parse")) (:file "catalog" :depends-on ("xml-parse")) (:file "sax-proxy" :depends-on ("xml-parse"))) - :depends-on (:runes :puri)) + :depends-on (:cxml-runes :puri :trivial-gray-streams)) -(asdf:defsystem :dom +(asdf:defsystem :cxml-dom :default-component-class closure-source-file :pathname (merge-pathnames "dom/" @@ -99,7 +83,7 @@ (:file "dom-builder" :depends-on ("dom-impl")) (:file "unparse" :depends-on ("package")) (:file "dom-sax" :depends-on ("package"))) - :depends-on (:xml)) + :depends-on (:cxml-xml)) (asdf:defsystem :cxml-test :default-component-class closure-source-file @@ -107,6 +91,6 @@ "test/" (make-pathname :name nil :type nil :defaults *load-truename*)) :components ((:file "domtest") (:file "xmlconf")) - :depends-on (:xml :dom)) + :depends-on (:cxml-xml :cxml-dom)) -(asdf:defsystem :cxml :components () :depends-on (:dom :cxml-test)) +(asdf:defsystem :cxml :components () :depends-on (:cxml-dom :cxml-test))

1 0

[cxml-cvs] CVS update: cxml/xml/xml-parse.lisp
by dlichteblau＠common-lisp.net 16 Aug '05

16 Aug '05

Update of /project/cxml/cvsroot/cxml/xml In directory common-lisp.net:/tmp/cvs-serv4658 Modified Files: xml-parse.lisp Log Message: oops, revert Date: Tue Aug 16 17:03:05 2005 Author: dlichteblau Index: cxml/xml/xml-parse.lisp diff -u cxml/xml/xml-parse.lisp:1.5 cxml/xml/xml-parse.lisp:1.6 --- cxml/xml/xml-parse.lisp:1.5 Tue Aug 16 17:01:24 2005 +++ cxml/xml/xml-parse.lisp Tue Aug 16 17:03:05 2005 @@ -1270,13 +1270,11 @@ ((rune= #// d) (let ((c (peek-rune input))) (cond ((name-start-rune-p c) - (ensure-dtd) ;fixme (read-tag-2 zinput input :etag)) (t (error "Expecting name start rune after \"</\"."))))) ((name-start-rune-p d) (unread-rune d input) - (ensure-dtd) ;fixme (read-tag-2 zinput input :stag)) (t (error "Expected '!' or '?' after '<' in DTD."))))) @@ -2437,7 +2435,6 @@ (defun p/doctype-decl (input &optional dtd-extid) (let () (let ((*expand-pe-p* nil) - (fresh-dtd-p t) name extid) (expect input :|<!DOCTYPE|) (p/S input) @@ -2460,7 +2457,6 @@ (when (disallow-internal-subset *ctx*) (error "document includes an internal subset")) (ensure-dtd) - (setf fresh-dtd-p nil) (consume-token input) (while (progn (p/S? input) (not (eq (peek-token input) :\] ))) @@ -2484,6 +2480,7 @@ (let* ((effective-extid (extid-using-catalog (absolute-extid input extid))) (sysid (extid-system effective-extid)) + (fresh-dtd-p (null (dtd *ctx*))) (cached-dtd (and fresh-dtd-p (not (standalone-p *ctx*)) @@ -2899,31 +2896,28 @@ (values nil nil))) (defun uri-to-pathname (uri) - (flet ((unescape (str) - (puri::decode-escaped-encoding str t puri::*reserved-characters*))) - (let ((scheme (puri:uri-scheme uri)) - (path (puri:uri-parsed-path uri))) - (setf path (cons (car path) (mapcar #'unescape (cdr path)))) - (unless (member scheme '(nil :file)) - (error 'parser-error - :format-control "URI scheme ~S not supported" - :format-arguments (list scheme))) - (if (eq (car path) :relative) - (multiple-value-bind (name type) - (parse-name.type (car (last path))) - (make-pathname :directory (butlast path) + (let ((scheme (puri:uri-scheme uri)) + (path (puri:uri-parsed-path uri))) + (unless (member scheme '(nil :file)) + (error 'parser-error + :format-control "URI scheme ~S not supported" + :format-arguments (list scheme))) + (if (eq (car path) :relative) + (multiple-value-bind (name type) + (parse-name.type (car (last path))) + (make-pathname :directory (butlast path) + :name name + :type type)) + (multiple-value-bind (name type) + (parse-name.type (car (last (cdr path)))) + (destructuring-bind (host device) + (split-sequence-if (lambda (x) (eql x #\+)) + (or (puri:uri-host uri) "+")) + (make-pathname :host (string-or host) + :device (string-or device) + :directory (cons :absolute (butlast (cdr path))) :name name - :type type)) - (multiple-value-bind (name type) - (parse-name.type (car (last (cdr path)))) - (destructuring-bind (host device) - (split-sequence-if (lambda (x) (eql x #\+)) - (or (puri:uri-host uri) "+")) - (make-pathname :host (string-or host) - :device (string-or device) - :directory (cons :absolute (butlast (cdr path))) - :name name - :type type))))))) + :type type)))))) (defun parse-xstream (xstream handler &rest args) (let ((zstream (make-zstream :input-stack (list xstream)))) @@ -3252,20 +3246,20 @@ (let ((input-var (gensym)) (collect (gensym)) (c (gensym))) - `(let ((,input-var ,input)) - (multiple-value-bind (,res ,res-start ,res-end) - (with-rune-collector/raw (,collect) - (loop - (let ((,c (peek-rune ,input-var))) - (cond ((eq ,c :eof) + `(LET ((,input-var ,input)) + (MULTIPLE-VALUE-BIND (,res ,res-start ,res-end) + (WITH-RUNE-COLLECTOR/RAW (,collect) + (LOOP + (LET ((,c (PEEK-RUNE ,input-var))) + (COND ((EQ ,c :EOF) ;; xxx error message - (return)) - ((funcall ,predicate ,c) - (return)) + (RETURN)) + ((FUNCALL ,predicate ,c) + (RETURN)) (t (,collect ,c) - (consume-rune ,input-var)))))) - (locally + (CONSUME-RUNE ,input-var)))))) + (LOCALLY ,@body))))) (defun read-name-token (input)

1 0

[cxml-cvs] CVS update: cxml/xml/xml-parse.lisp
by dlichteblau＠common-lisp.net 16 Aug '05

16 Aug '05

Update of /project/cxml/cvsroot/cxml/xml In directory common-lisp.net:/tmp/cvs-serv4527 Modified Files: xml-parse.lisp Log Message: pfade decodieren? Date: Tue Aug 16 17:01:25 2005 Author: dlichteblau Index: cxml/xml/xml-parse.lisp diff -u cxml/xml/xml-parse.lisp:1.4 cxml/xml/xml-parse.lisp:1.5 --- cxml/xml/xml-parse.lisp:1.4 Wed Apr 20 21:58:07 2005 +++ cxml/xml/xml-parse.lisp Tue Aug 16 17:01:24 2005 @@ -1270,11 +1270,13 @@ ((rune= #// d) (let ((c (peek-rune input))) (cond ((name-start-rune-p c) + (ensure-dtd) ;fixme (read-tag-2 zinput input :etag)) (t (error "Expecting name start rune after \"</\"."))))) ((name-start-rune-p d) (unread-rune d input) + (ensure-dtd) ;fixme (read-tag-2 zinput input :stag)) (t (error "Expected '!' or '?' after '<' in DTD."))))) @@ -2435,6 +2437,7 @@ (defun p/doctype-decl (input &optional dtd-extid) (let () (let ((*expand-pe-p* nil) + (fresh-dtd-p t) name extid) (expect input :|<!DOCTYPE|) (p/S input) @@ -2457,6 +2460,7 @@ (when (disallow-internal-subset *ctx*) (error "document includes an internal subset")) (ensure-dtd) + (setf fresh-dtd-p nil) (consume-token input) (while (progn (p/S? input) (not (eq (peek-token input) :\] ))) @@ -2480,7 +2484,6 @@ (let* ((effective-extid (extid-using-catalog (absolute-extid input extid))) (sysid (extid-system effective-extid)) - (fresh-dtd-p (null (dtd *ctx*))) (cached-dtd (and fresh-dtd-p (not (standalone-p *ctx*)) @@ -2896,28 +2899,31 @@ (values nil nil))) (defun uri-to-pathname (uri) - (let ((scheme (puri:uri-scheme uri)) - (path (puri:uri-parsed-path uri))) - (unless (member scheme '(nil :file)) - (error 'parser-error - :format-control "URI scheme ~S not supported" - :format-arguments (list scheme))) - (if (eq (car path) :relative) - (multiple-value-bind (name type) - (parse-name.type (car (last path))) - (make-pathname :directory (butlast path) - :name name - :type type)) - (multiple-value-bind (name type) - (parse-name.type (car (last (cdr path)))) - (destructuring-bind (host device) - (split-sequence-if (lambda (x) (eql x #\+)) - (or (puri:uri-host uri) "+")) - (make-pathname :host (string-or host) - :device (string-or device) - :directory (cons :absolute (butlast (cdr path))) + (flet ((unescape (str) + (puri::decode-escaped-encoding str t puri::*reserved-characters*))) + (let ((scheme (puri:uri-scheme uri)) + (path (puri:uri-parsed-path uri))) + (setf path (cons (car path) (mapcar #'unescape (cdr path)))) + (unless (member scheme '(nil :file)) + (error 'parser-error + :format-control "URI scheme ~S not supported" + :format-arguments (list scheme))) + (if (eq (car path) :relative) + (multiple-value-bind (name type) + (parse-name.type (car (last path))) + (make-pathname :directory (butlast path) :name name - :type type)))))) + :type type)) + (multiple-value-bind (name type) + (parse-name.type (car (last (cdr path)))) + (destructuring-bind (host device) + (split-sequence-if (lambda (x) (eql x #\+)) + (or (puri:uri-host uri) "+")) + (make-pathname :host (string-or host) + :device (string-or device) + :directory (cons :absolute (butlast (cdr path))) + :name name + :type type))))))) (defun parse-xstream (xstream handler &rest args) (let ((zstream (make-zstream :input-stack (list xstream)))) @@ -3246,20 +3252,20 @@ (let ((input-var (gensym)) (collect (gensym)) (c (gensym))) - `(LET ((,input-var ,input)) - (MULTIPLE-VALUE-BIND (,res ,res-start ,res-end) - (WITH-RUNE-COLLECTOR/RAW (,collect) - (LOOP - (LET ((,c (PEEK-RUNE ,input-var))) - (COND ((EQ ,c :EOF) + `(let ((,input-var ,input)) + (multiple-value-bind (,res ,res-start ,res-end) + (with-rune-collector/raw (,collect) + (loop + (let ((,c (peek-rune ,input-var))) + (cond ((eq ,c :eof) ;; xxx error message - (RETURN)) - ((FUNCALL ,predicate ,c) - (RETURN)) + (return)) + ((funcall ,predicate ,c) + (return)) (t (,collect ,c) - (CONSUME-RUNE ,input-var)))))) - (LOCALLY + (consume-rune ,input-var)))))) + (locally ,@body))))) (defun read-name-token (input)

1 0

[cxml-cvs] CVS update: cxml/test/domtest.lisp
by dlichteblau＠common-lisp.net 25 Jun '05

25 Jun '05

Update of /project/cxml/cvsroot/cxml/test In directory common-lisp.net:/tmp/cvs-serv10721/test Modified Files: domtest.lisp Log Message: new release Date: Sat Jun 25 15:56:57 2005 Author: dlichteblau Index: cxml/test/domtest.lisp diff -u cxml/test/domtest.lisp:1.2 cxml/test/domtest.lisp:1.3 --- cxml/test/domtest.lisp:1.2 Wed Apr 6 23:14:41 2005 +++ cxml/test/domtest.lisp Sat Jun 25 15:56:57 2005 @@ -126,28 +126,29 @@ (map-child-elements 'list #'identity element)) (defun parse-java-literal (str) - (unless (stringp str) - (setf str (runes:rod-string str))) + (when (stringp str) + (setf str (runes:string-rod str))) (cond ((zerop (length str)) nil) - ((equal str "true") + ((runes:rod= str #"true") t) - ((equal str "false") + ((runes:rod= str #"false") nil) - ((digit-char-p (char str 0)) - (parse-integer str)) - ((char= (char str 0) #\") - (runes:rod - (with-output-to-string (out) - (with-input-from-string (in str) - (read-char in) - (for ((c = (read-char in)) - :until (char= c #\")) - (if (char= c #\\) - (ecase (read-char in) - ;; ... - (#\n (write-char #\newline out))) - (write-char c out))))))) + ((digit-char-p (runes:rune-char (elt str 0))) + (parse-integer (runes:rod-string str))) + ((runes:rune= (elt str 0) #.(runes:char-rune #\")) + (let ((v (make-array 1 :fill-pointer 0 :adjustable t))) + (for* ((i = 1 :then (1+ i)) + (c = (elt str i)) + :until (runes:rune= c #.(runes:char-rune #\"))) + (if (runes:rune= c #.(runes:char-rune #\\)) + (ecase (progn + (incf i) + (elt str i)) + ;; ... + (#/n (vector-push-extend #/newline v (length v)))) + (vector-push-extend c v (length v)))) + (coerce v 'runes::simple-rod))) (t (%intern str)))) @@ -613,7 +614,8 @@ document)) (defparameter *bad-tests* - '("hc_nodereplacechildnewchildexists.xml" + '("hc_elementnormalize2.xml" + "hc_nodereplacechildnewchildexists.xml" "characterdatadeletedatanomodificationallowederr.xml")) (defun run-all-tests (*directory* &optional verbose) @@ -635,7 +637,7 @@ (incf n))) (do-child-elements (member suite) (let ((href (runes:rod-string (dom:get-attribute member "href")))) - (unless (or (equal (dom:tag-name member) "metadata") + (unless (or (runes:rod= (dom:tag-name member) #"metadata") (member href *bad-tests* :test 'equal)) (format t "~&~D/~D ~A~%" i n href) (let ((lisp (slurp-test (merge-pathnames href test-directory))))

1 0

[cxml-cvs] CVS update: cxml/runes/runes.lisp
by dlichteblau＠common-lisp.net 25 Jun '05

25 Jun '05

Update of /project/cxml/cvsroot/cxml/runes In directory common-lisp.net:/tmp/cvs-serv10721/runes Modified Files: runes.lisp Log Message: new release Date: Sat Jun 25 15:56:56 2005 Author: dlichteblau Index: cxml/runes/runes.lisp diff -u cxml/runes/runes.lisp:1.2 cxml/runes/runes.lisp:1.3 --- cxml/runes/runes.lisp:1.2 Fri Mar 25 19:16:56 2005 +++ cxml/runes/runes.lisp Sat Jun 25 15:56:55 2005 @@ -147,12 +147,17 @@ (defun char-rune (char) (code-rune (char-code char))) -(defun rune-char (rune &optional (default #\?)) - (if (>= rune char-code-limit) - default - (or (code-char rune) default))) +(defparameter *invalid-rune* nil ;;#\? + "Rune to use as a replacement in RUNE-CHAR and ROD-STRING for runes not + representable as characters. If NIL, an error is signalled instead.") -(defun rod-string (rod &optional (default-char #\?)) +(defun rune-char (rune &optional (default *invalid-rune*)) + (or (if (>= rune char-code-limit) + default + (or (code-char rune) default)) + (error "rune cannot be represented as a character: ~A" rune))) + +(defun rod-string (rod &optional (default-char *invalid-rune*)) (map 'string (lambda (x) (rune-char x default-char)) rod)) (defun string-rod (string)

1 0