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

trailing whitespace weg

Browse Source
This commit is contained in:
dlichteblau
2005-11-26 22:15:10 +00:00
parent 241b24ac25
commit 55af866ae9
1 changed files with 75 additions and 97 deletions
Download Patch File Download Diff File Expand all files Collapse all files

172
xml/xml-parse.lisp
View File

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