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

fast durchweg s/error/wf-error/

Browse Source
This commit is contained in:
dlichteblau
2005-11-27 11:55:54 +00:00
parent 0a33e9cce5
commit 36c951241c
2 changed files with 958 additions and 4795 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5498
XMLCONF
View File

File diff suppressed because it is too large Load Diff

255
xml/xml-parse.lisp
View File

@ -132,7 +132,7 @@
;; ;;
;; o max depth together with circle detection ;; o max depth together with circle detection
;; (or proof, that our circle detection is enough). ;; (or proof, that our circle detection is enough).
;; [was fuer circle detection?--david] ;; [gemeint ist wohl zstream-push--david]
;; ;;
;; o better extensibility wrt character representation, one may want to ;; o better extensibility wrt character representation, one may want to
;; have ;; have
@ -900,7 +900,7 @@
(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)))) (wf-error "Entity '~A' is not defined." (rod-string entity-name))))
(let (r) (let (r)
(etypecase def (etypecase def
(internal-entdef (internal-entdef
@ -918,7 +918,7 @@
(defun checked-get-entdef (name type) (defun checked-get-entdef (name type)
(let ((def (get-entity-definition name type (dtd *ctx*)))) (let ((def (get-entity-definition name type (dtd *ctx*))))
(unless def (unless def
(error "Entity '~A' is not defined." (rod-string name))) (wf-error "Entity '~A' is not defined." (rod-string name)))
def)) def))
(defun xstream-open-extid (extid) (defun xstream-open-extid (extid)
@ -1186,7 +1186,7 @@
((equalp q '#.(string-rod "FIXED")) :|#FIXED|) ((equalp q '#.(string-rod "FIXED")) :|#FIXED|)
((equalp q '#.(string-rod "PCDATA")) :|#PCDATA|) ((equalp q '#.(string-rod "PCDATA")) :|#PCDATA|)
(t (t
(error "Unknown token: ~S." q))))) (wf-error "Unknown token: ~S." q)))))
((or (rune= c #/U+0020) ((or (rune= c #/U+0020)
(rune= c #/U+0009) (rune= c #/U+0009)
(rune= c #/U+000D) (rune= c #/U+000D)
@ -1199,7 +1199,7 @@
(t (t
(values :%)))) (values :%))))
(t (t
(error "Unexpected character ~S." c)))) (wf-error "Unexpected character ~S." c))))
(:DOC (:DOC
(cond (cond
((rune= c #/&) ((rune= c #/&)
@ -1230,7 +1230,7 @@
(defun read-token-after-|<| (zinput input) (defun read-token-after-|<| (zinput input)
(let ((d (read-rune input))) (let ((d (read-rune input)))
(cond ((eq d :eof) (cond ((eq d :eof)
(error "EOF after '<'")) (wf-error "EOF after '<'"))
((rune= #/! d) ((rune= #/! d)
(read-token-after-|<!| input)) (read-token-after-|<!| input))
((rune= #/? d) ((rune= #/? d)
@ -1238,10 +1238,10 @@
(cond ((rod= target '#.(string-rod "xml")) (cond ((rod= target '#.(string-rod "xml"))
(values :xml-pi (cons target content))) (values :xml-pi (cons target content)))
((rod-equal target '#.(string-rod "XML")) ((rod-equal target '#.(string-rod "XML"))
(error "You lost -- no XML processing instructions.")) (wf-error "You lost -- no XML processing instructions."))
((and sax:*namespace-processing* (position #/: target)) ((and sax:*namespace-processing* (position #/: target))
(error "Processing instruction target ~S is not a valid NcName." (wf-error "Processing instruction target ~S is not a valid NcName."
(mu target))) (mu target)))
(t (t
(values :PI (cons target content)))))) (values :PI (cons target content))))))
((rune= #// d) ((rune= #// d)
@ -1249,17 +1249,17 @@
(cond ((name-start-rune-p c) (cond ((name-start-rune-p c)
(read-tag-2 zinput input :etag)) (read-tag-2 zinput input :etag))
(t (t
(error "Expecting name start rune after \"</\"."))))) (wf-error "Expecting name start rune after \"</\".")))))
((name-start-rune-p d) ((name-start-rune-p d)
(unread-rune d input) (unread-rune d input)
(read-tag-2 zinput input :stag)) (read-tag-2 zinput input :stag))
(t (t
(error "Expected '!' or '?' after '<' in DTD."))))) (wf-error "Expected '!' or '?' after '<' in DTD.")))))
(defun read-token-after-|<!| (input) (defun read-token-after-|<!| (input)
(let ((d (read-rune input))) (let ((d (read-rune input)))
(cond ((eq d :eof) (cond ((eq d :eof)
(error "EOF after \"<!\".")) (wf-error "EOF after \"<!\"."))
((name-start-rune-p d) ((name-start-rune-p d)
(unread-rune d input) (unread-rune d input)
(let ((name (read-name-token input))) (let ((name (read-name-token input)))
@ -1269,7 +1269,7 @@
((rod= name '#.(string-rod "NOTATION")) :|<!NOTATION|) ((rod= name '#.(string-rod "NOTATION")) :|<!NOTATION|)
((rod= name '#.(string-rod "DOCTYPE")) :|<!DOCTYPE|) ((rod= name '#.(string-rod "DOCTYPE")) :|<!DOCTYPE|)
(t (t
(error "`<!~A' unknown." (rod-string name)))))) (wf-error "`<!~A' unknown." (rod-string name))))))
((rune= #/\[ d) ((rune= #/\[ d)
(values :|<![| nil)) (values :|<![| nil))
((rune= #/- d) ((rune= #/- d)
@ -1279,9 +1279,9 @@
:COMMENT :COMMENT
(read-comment-content input))) (read-comment-content input)))
(t (t
(error "Bad character ~S after \"<!-\"" d)))) (wf-error "Bad character ~S after \"<!-\"" d))))
(t (t
(error "Bad character ~S after \"<!\"" d))))) (wf-error "Bad character ~S after \"<!\"" d)))))
(definline read-S? (input) (definline read-S? (input)
(while (member (peek-rune input) '(#/U+0020 #/U+0009 #/U+000A #/U+000D) (while (member (peek-rune input) '(#/U+0020 #/U+0009 #/U+000A #/U+000D)
@ -1311,12 +1311,12 @@
The initial #\\& is considered to be consumed already." The initial #\\& is considered to be consumed already."
(let ((c (peek-rune input))) (let ((c (peek-rune input)))
(cond ((eq c :eof) (cond ((eq c :eof)
(error "EOF after '&'")) (wf-error "EOF after '&'"))
((rune= c #/#) ((rune= c #/#)
(values :NUMERIC (read-numeric-entity input))) (values :NUMERIC (read-numeric-entity input)))
(t (t
(unless (name-start-rune-p (peek-rune input)) (unless (name-start-rune-p (peek-rune input))
(error "Expecting name after &.")) (wf-error "Expecting name after &."))
(let ((name (read-name-token input))) (let ((name (read-name-token input)))
(setf c (read-rune input)) (setf c (read-rune input))
(unless (rune= c #/\;) (unless (rune= c #/\;)
@ -1332,9 +1332,9 @@
(do ((q atts (cdr q))) (do ((q atts (cdr q)))
((null q)) ((null q))
(cond ((find (caar q) (cdr q) :key #'car) (cond ((find (caar q) (cdr q) :key #'car)
(error "Attribute ~S has two definitions in element ~S." (wf-error "Attribute ~S has two definitions in element ~S."
(rod-string (caar q)) (rod-string (caar q))
(rod-string name))))) (rod-string name)))))
(cond ((eq (peek-rune input) #/>) (cond ((eq (peek-rune input) #/>)
(consume-rune input) (consume-rune input)
@ -1344,11 +1344,11 @@
(assert (rune= #/> (read-rune input))) (assert (rune= #/> (read-rune input)))
(values :ztag (cons name atts))) (values :ztag (cons name atts)))
(t (t
(error "syntax error in read-tag-2.")) ))) (wf-error "syntax error in read-tag-2.")) )))
(defun read-attribute (zinput input) (defun read-attribute (zinput input)
(unless (name-start-rune-p (peek-rune input)) (unless (name-start-rune-p (peek-rune input))
(error "Expected name.")) (wf-error "Expected name."))
;; arg thanks to the post mortem nature of name space declarations, ;; arg thanks to the post mortem nature of name space declarations,
;; we could only process the attribute values post mortem. ;; we could only process the attribute values post mortem.
(let ((name (read-name-token input))) (let ((name (read-name-token input)))
@ -1411,7 +1411,7 @@
(cond ((eql delim c) (cond ((eql delim c)
(return)) (return))
((eq c :eof) ((eq c :eof)
(error "EOF")) (wf-error "EOF"))
((rune= c #/&) ((rune= c #/&)
(setf c (peek-rune input)) (setf c (peek-rune input))
(cond ((rune= c #/#) (cond ((rune= c #/#)
@ -1419,7 +1419,7 @@
(%put-unicode-char c collect))) (%put-unicode-char c collect)))
(t (t
(unless (name-start-rune-p (peek-rune input)) (unless (name-start-rune-p (peek-rune input))
(error "Expecting name after &.")) (wf-error "Expecting name after &."))
(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 #/\;))
@ -1441,7 +1441,7 @@
(collect #/\; ))))))) (collect #/\; )))))))
((and (eq mode :ENT) (rune= c #/%)) ((and (eq mode :ENT) (rune= c #/%))
(unless (name-start-rune-p (peek-rune input)) (unless (name-start-rune-p (peek-rune input))
(error "Expecting name after %.")) (wf-error "Expecting name after %."))
(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 #/\;))
@ -1452,7 +1452,7 @@
(muffle (car (zstream-input-stack zinput)) (muffle (car (zstream-input-stack zinput))
:eof)))) :eof))))
(t (t
(error "No PE here."))))) (wf-error "No PE here.")))))
((and (eq mode :ATT) (rune= c #/<)) ((and (eq mode :ATT) (rune= c #/<))
;; xxx fix error message ;; xxx fix error message
(cerror "Eat them in spite of this." (cerror "Eat them in spite of this."
@ -1462,7 +1462,7 @@
((and canon-space-p (space-rune-p c)) ((and canon-space-p (space-rune-p c))
(collect #/space)) (collect #/space))
((not (data-rune-p c)) ((not (data-rune-p c))
(error "illegal char: ~S." c)) (wf-error "illegal char: ~S." c))
(t (t
(collect c))))))) (collect c)))))))
(declare (dynamic-extent #'muffle)) (declare (dynamic-extent #'muffle))
@ -1502,10 +1502,11 @@
:radix 10) :radix 10)
(assert (rune= c #/\;))) ) (assert (rune= c #/\;))) )
(t (t
(error "Bad char in numeric character entity.") ))))) (wf-error "Bad char in numeric character entity.") )))))
(unless (code-data-char-p res) (unless (code-data-char-p res)
(error "expansion of numeric character reference (#x~X) is no data char." (wf-error
res)) "expansion of numeric character reference (#x~X) is no data char."
res))
res)) res))
(defun read-pi (input) (defun read-pi (input)
@ -1513,7 +1514,7 @@
(let (name) (let (name)
(let ((c (peek-rune input))) (let ((c (peek-rune input)))
(unless (name-start-rune-p c) (unless (name-start-rune-p c)
(error "Expecting name after '<?'")) (wf-error "Expecting name after '<?'"))
(setf name (read-name-token input))) (setf name (read-name-token input)))
(cond (cond
((member (peek-rune input) '(#/U+0020 #/U+0009 #/U+000A #/U+000D) ((member (peek-rune input) '(#/U+0020 #/U+0009 #/U+000A #/U+000D)
@ -1535,7 +1536,7 @@
(unless d (unless d
(error 'end-of-xstream)) (error 'end-of-xstream))
(unless (data-rune-p d) (unless (data-rune-p d)
(error "Illegal char: ~S." d)) (wf-error "Illegal char: ~S." d))
(when (rune= d #/?) (go state-2)) (when (rune= d #/?) (go state-2))
(collect d) (collect d)
(go state-1) (go state-1)
@ -1544,7 +1545,7 @@
(unless d (unless d
(error 'end-of-xstream)) (error 'end-of-xstream))
(unless (data-rune-p d) (unless (data-rune-p d)
(error "Illegal char: ~S." d)) (wf-error "Illegal char: ~S." d))
(when (rune= d #/>) (return)) (when (rune= d #/>) (return))
(when (rune= d #/?) (when (rune= d #/?)
(collect #/?) (collect #/?)
@ -1595,14 +1596,14 @@
state-1 state-1
(setf d (read-rune input)) (setf d (read-rune input))
(unless (data-rune-p d) (unless (data-rune-p d)
(error "Illegal char: ~S." d)) (wf-error "Illegal char: ~S." d))
(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 (read-rune input)) (setf d (read-rune input))
(unless (data-rune-p d) (unless (data-rune-p d)
(error "Illegal char: ~S." d)) (wf-error "Illegal char: ~S." d))
(when (rune= d #/\]) (go state-3)) (when (rune= d #/\]) (go state-3))
(collect #/\]) (collect #/\])
(collect d) (collect d)
@ -1610,7 +1611,7 @@
state-3 ;; #/\] #/\] seen state-3 ;; #/\] #/\] seen
(setf d (read-rune input)) (setf d (read-rune input))
(unless (data-rune-p d) (unless (data-rune-p d)
(error "Illegal char: ~S." d)) (wf-error "Illegal char: ~S." d))
(when (rune= d #/>) (when (rune= d #/>)
(return)) (return))
(when (rune= d #/\]) (when (rune= d #/\])
@ -1621,61 +1622,6 @@
(collect d) (collect d)
(go state-1))))) (go state-1)))))
#+(or) ;; FIXME: There is another definition below that looks more reasonable.
(defun read-cdata (input initial-char &aux d)
(cond ((not (data-rune-p initial-char))
(error "Illegal char: ~S." initial-char)))
(with-rune-collector (collect)
(block nil
(tagbody
(cond ((rune= initial-char #/\])
(go state-2))
(t
(collect initial-char)))
state-1
(setf d (peek-rune input))
(when (or (eq d :eof) (rune= d #/<) (rune= d #/&))
(return))
(read-rune input)
(unless (data-rune-p d)
(error "Illegal char: ~S." d))
(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 #/&))
(collect #/\])
(return))
(read-rune input)
(unless (data-rune-p d)
(error "Illegal char: ~S." d))
(when (rune= d #/\]) (go state-3))
(collect #/\])
(collect d)
(go state-1)
state-3 ;; #/\] #/\] seen
(setf d (peek-rune input))
(when (or (eq d :eof) (rune= d #/<) (rune= d #/&))
(collect #/\])
(collect #/\])
(return))
(read-rune input)
(unless (data-rune-p d)
(error "Illegal char: ~S." d))
(when (rune= d #/>)
(error "For no apparent reason ']]>' in not allowed in a CharData token -- you lost."))
(when (rune= d #/\])
(collect #/\])
(go state-3))
(collect #/\])
(collect #/\])
(collect d)
(go state-1)))))
;; some character categories ;; some character categories
(defun space-rune-p (rune) (defun space-rune-p (rune)
@ -1705,7 +1651,7 @@
(defun expect (input category) (defun expect (input category)
(multiple-value-bind (cat sem) (read-token input) (multiple-value-bind (cat sem) (read-token input)
(unless (eq cat category) (unless (eq cat category)
(error "Expected ~S saw ~S [~S]" category cat sem)) (wf-error "Expected ~S saw ~S [~S]" category cat sem))
(values cat sem))) (values cat sem)))
(defun consume-token (input) (defun consume-token (input)
@ -1755,8 +1701,8 @@
(:> (:>
(return)) (return))
(otherwise (otherwise
(error "Expected either another AttDef or end of \"<!ATTLIST\". -- saw ~S." (wf-error "Expected either another AttDef or end of \"<!ATTLIST\". -- saw ~S."
tok)) )) ))) tok)))))))
(defun p/attdef (input) (defun p/attdef (input)
;; [53] AttDef ::= Name S AttType S DefaultDecl ;; [53] AttDef ::= Name S AttType S DefaultDecl
@ -1823,7 +1769,7 @@
(append names (referenced-notations *ctx*)))) (append names (referenced-notations *ctx*))))
(cons :NOTATION names))) (cons :NOTATION names)))
(t (t
(error "In p/att-type: ~S ~S." cat sem)))) (wf-error "In p/att-type: ~S ~S." cat sem))))
((eq cat :\() ((eq cat :\()
;; XXX Die Nmtoken-Syntax pruefen wir derzeit nur beim Validieren. ;; XXX Die Nmtoken-Syntax pruefen wir derzeit nur beim Validieren.
(let (names) (let (names)
@ -1832,7 +1778,7 @@
(expect input :\)) (expect input :\))
(cons :ENUMERATION names))) (cons :ENUMERATION names)))
(t (t
(error "In p/att-type: ~S ~S." cat sem)) ))) (wf-error "In p/att-type: ~S ~S." cat sem)) )))
(defun p/default-decl (input) (defun p/default-decl (input)
;; [60] DefaultDecl ::= '#REQUIRED' | '#IMPLIED' ;; [60] DefaultDecl ::= '#REQUIRED' | '#IMPLIED'
@ -1853,7 +1799,7 @@
((or (eq cat :\') (eq cat :\")) ((or (eq cat :\') (eq cat :\"))
(list :DEFAULT (p/att-value input))) (list :DEFAULT (p/att-value input)))
(t (t
(error "p/default-decl: ~S ~S." cat sem)) ))) (wf-error "p/default-decl: ~S ~S." cat sem)) )))
;;;; ;;;;
;; [70] EntityDecl ::= GEDecl | PEDecl ;; [70] EntityDecl ::= GEDecl | PEDecl
@ -1923,7 +1869,7 @@
(push ndata (referenced-notations *ctx*))))))) (push ndata (referenced-notations *ctx*)))))))
(make-external-entdef extid ndata))) (make-external-entdef extid ndata)))
(t (t
(error "p/entity-def: ~S / ~S." cat sem)) ))) (wf-error "p/entity-def: ~S / ~S." cat sem)) )))
(defun p/entity-value (input) (defun p/entity-value (input)
(let ((delim (if (eq (read-token input) :\") #/\" #/\'))) (let ((delim (if (eq (read-token input) :\") #/\" #/\')))
@ -1957,10 +1903,10 @@
(setf sys (p/system-literal input)))) (setf sys (p/system-literal input))))
(when (and (not public-only-ok-p) (when (and (not public-only-ok-p)
(null sys)) (null sys))
(error "System identifier needed for this PUBLIC external identifier.")) (wf-error "System identifier needed for this PUBLIC external identifier."))
(make-extid pub sys))) (make-extid pub sys)))
(t (t
(error "Expected external-id: ~S / ~S." cat sem))))) (wf-error "Expected external-id: ~S / ~S." cat sem)))))
;; [11] SystemLiteral ::= ('"' [^"]* '"') | ("'" [^']* "'") ;; [11] SystemLiteral ::= ('"' [^"]* '"') | ("'" [^']* "'")
@ -1976,13 +1922,13 @@
(loop (loop
(let ((c (read-rune (car (zstream-input-stack input))))) (let ((c (read-rune (car (zstream-input-stack input)))))
(cond ((eq c :eof) (cond ((eq c :eof)
(error "EOF in system literal.")) (wf-error "EOF in system literal."))
((rune= c delim) ((rune= c delim)
(return)) (return))
(t (t
(collect c)))))))) (collect c))))))))
(t (t
(error "Expect either \" or \'."))))) (wf-error "Expect either \" or \'.")))))
;; it is important to cache the orginal URI rod, since the re-serialized ;; it is important to cache the orginal URI rod, since the re-serialized
;; uri-string can be different from the one parsed originally. ;; uri-string can be different from the one parsed originally.
@ -2009,7 +1955,7 @@
(defun p/pubid-literal (input) (defun p/pubid-literal (input)
(let ((result (p/id input))) (let ((result (p/id input)))
(unless (every #'pubid-char-p result) (unless (every #'pubid-char-p result)
(error "Illegal pubid: ~S." (rod-string result))) (wf-error "Illegal pubid: ~S." (rod-string result)))
result)) result))
@ -2023,7 +1969,7 @@
(p/S input) (p/S input)
(setf content (normalize-mixed-cspec (p/cspec input))) (setf content (normalize-mixed-cspec (p/cspec input)))
(unless (legal-content-model-p content *validate*) (unless (legal-content-model-p content *validate*)
(error "Malformed or invalid content model: ~S." (mu content))) (wf-error "Malformed or invalid content model: ~S." (mu content)))
(p/S? input) (p/S? input)
(expect input :\>) (expect input :\>)
(when *validate* (when *validate*
@ -2212,7 +2158,7 @@
(validity-error "(06) Proper Group/PE Nesting"))) (validity-error "(06) Proper Group/PE Nesting")))
res) res)
(t (t
(error "p/cspec - ~s / ~s" cat sem))))))) (wf-error "p/cspec - ~s / ~s" cat sem)))))))
(cond ((eq (peek-token input) :?) (consume-token input) (list '? term)) (cond ((eq (peek-token input) :?) (consume-token input) (list '? term))
((eq (peek-token input) :+) (consume-token input) (list '+ term)) ((eq (peek-token input) :+) (consume-token input) (list '+ term))
((eq (peek-token input) :*) (consume-token input) (list '* term)) ((eq (peek-token input) :*) (consume-token input) (list '* term))
@ -2299,7 +2245,7 @@
(rod= sem '#.(string-rod "IGNORE"))) (rod= sem '#.(string-rod "IGNORE")))
(p/ignore-sect input stream)) (p/ignore-sect input stream))
(t (t
(error "Expected INCLUDE or IGNORE after \"<![\".")))))) (wf-error "Expected INCLUDE or IGNORE after \"<![\"."))))))
(defun p/cond-expect (input cat initial-stream) (defun p/cond-expect (input cat initial-stream)
(expect input cat) (expect input cat)
@ -2329,7 +2275,7 @@
((= level -1)) ((= level -1))
(declare (type fixnum level)) (declare (type fixnum level))
(cond ((eq c1 :eof) (cond ((eq c1 :eof)
(error "EOF in <![IGNORE ... >"))) (wf-error "EOF in <![IGNORE ... >")))
(cond ((and (rune= c3 #/<) (rune= c2 #/!) (rune= c1 #/\[)) (cond ((and (rune= c3 #/<) (rune= c2 #/!) (rune= c1 #/\[))
(incf level))) (incf level)))
(cond ((and (rune= c3 #/\]) (rune= c2 #/\]) (rune= c1 #/>)) (cond ((and (rune= c3 #/\]) (rune= c2 #/\]) (rune= c1 #/>))
@ -2358,7 +2304,7 @@
(internal-entdef (internal-entdef
(p/ext-subset-decl input))) (p/ext-subset-decl input)))
(unless (eq :eof (peek-token input)) (unless (eq :eof (peek-token input))
(error "Trailing garbage.")))))) (wf-error "Trailing garbage."))))))
(otherwise (return)))) ) (otherwise (return)))) )
(defun p/markup-decl (input) (defun p/markup-decl (input)
@ -2386,7 +2332,7 @@
(sax:processing-instruction (handler *ctx*) (car sem) (cdr sem)))) (sax:processing-instruction (handler *ctx*) (car sem) (cdr sem))))
(:COMMENT (consume-token input)) (:COMMENT (consume-token input))
(otherwise (otherwise
(error "p/markup-decl ~S" (peek-token input)))))) (wf-error "p/markup-decl ~S" (peek-token input))))))
(defun setup-encoding (input xml-header) (defun setup-encoding (input xml-header)
(when (xml-header-encoding xml-header) (when (xml-header-encoding xml-header)
@ -2410,7 +2356,7 @@
(set-full-speed input) (set-full-speed input)
(p/ext-subset-decl input) (p/ext-subset-decl input)
(unless (eq (peek-token input) :eof) (unless (eq (peek-token input) :eof)
(error "Trailing garbage - ~S." (peek-token input)))) (wf-error "Trailing garbage - ~S." (peek-token input))))
(defvar *catalog* nil) (defvar *catalog* nil)
@ -2448,7 +2394,7 @@
(and extid (uri-rod (extid-system extid)))) (and extid (uri-rod (extid-system extid))))
(when (eq (peek-token input) :\[ ) (when (eq (peek-token input) :\[ )
(when (disallow-internal-subset *ctx*) (when (disallow-internal-subset *ctx*)
(error "document includes an internal subset")) (wf-error "document includes an internal subset"))
(ensure-dtd) (ensure-dtd)
(consume-token input) (consume-token input)
(while (progn (p/S? input) (while (progn (p/S? input)
@ -2463,7 +2409,7 @@
(internal-entdef (internal-entdef
(p/ext-subset-decl input))) (p/ext-subset-decl input)))
(unless (eq :eof (peek-token input)) (unless (eq :eof (peek-token input))
(error "Trailing garbage."))))) (wf-error "Trailing garbage.")))))
(let ((*expand-pe-p* t)) (let ((*expand-pe-p* t))
(p/markup-decl input)))) (p/markup-decl input))))
(consume-token input) (consume-token input)
@ -2585,7 +2531,7 @@
;; optional Misc* ;; optional Misc*
(p/misc*-2 input) (p/misc*-2 input)
(unless (eq (peek-token input) :eof) (unless (eq (peek-token input) :eof)
(error "Garbage at end of document.")) (wf-error "Garbage at end of document."))
(when *validate* (when *validate*
(maphash (lambda (k v) (maphash (lambda (k v)
(unless v (unless v
@ -2620,7 +2566,7 @@
(sax:end-element (handler *ctx*) nil nil (car sem))) (sax:end-element (handler *ctx*) nil nil (car sem)))
(t (t
(error "Expecting element."))))) (wf-error "Expecting element.")))))
(defun p/element-ns (input) (defun p/element-ns (input)
@ -2652,7 +2598,7 @@
(sax:end-element (handler *ctx*) ns-uri local-name name)) (sax:end-element (handler *ctx*) ns-uri local-name name))
(t (t
(error "Expecting element, got ~S." cat))))) (wf-error "Expecting element, got ~S." cat)))))
(undeclare-namespaces ns-decls)) (undeclare-namespaces ns-decls))
(validate-end-element *ctx* name))) (validate-end-element *ctx* name)))
@ -2660,11 +2606,11 @@
(when (zstream-p stream) (when (zstream-p stream)
(setf stream (car (zstream-input-stack stream)))) (setf stream (car (zstream-input-stack stream))))
(if stream (if stream
(error "Parse error at line ~D column ~D: ~?" (wf-error "Parse error at line ~D column ~D: ~?"
(xstream-line-number stream) (xstream-line-number stream)
(xstream-column-number stream) (xstream-column-number stream)
format-string format-args) format-string format-args)
(apply #'error format-string format-args))) (apply #'wf-error format-string format-args)))
(defun p/content (input) (defun p/content (input)
;; [43] content ::= (element | CharData | Reference | CDSect | PI | Comment)* ;; [43] content ::= (element | CharData | Reference | CDSect | PI | Comment)*
@ -2691,7 +2637,8 @@
(internal-entdef (p/content input)) (internal-entdef (p/content input))
(external-entdef (p/ext-parsed-ent input))) (external-entdef (p/ext-parsed-ent input)))
(unless (eq (peek-token input) :eof) (unless (eq (peek-token input) :eof)
(error "Trailing garbage. - ~S" (peek-token input)))))) (wf-error "Trailing garbage. - ~S"
(peek-token input))))))
(p/content input)))) (p/content input))))
((:<!\[) ((:<!\[)
(consume-token input) (consume-token input)
@ -2703,7 +2650,7 @@
(rune= #/T (read-rune input)) (rune= #/T (read-rune input))
(rune= #/A (read-rune input)) (rune= #/A (read-rune input))
(rune= #/\[ (read-rune input))) (rune= #/\[ (read-rune input)))
(error "After '<![', 'CDATA[' is expected.")) (wf-error "After '<![', 'CDATA[' is expected."))
(validate-characters *ctx* #"hack") ;anything other than whitespace (validate-characters *ctx* #"hack") ;anything other than whitespace
(sax:start-cdata (handler *ctx*)) (sax:start-cdata (handler *ctx*))
(sax:characters (handler *ctx*) (read-cdata-sect input)) (sax:characters (handler *ctx*) (read-cdata-sect input))
@ -2742,7 +2689,7 @@
(i (make-rod-xstream content)) (i (make-rod-xstream content))
(atts (read-attribute-list 'foo i t))) ;xxx on 'foo (atts (read-attribute-list 'foo i t))) ;xxx on 'foo
(unless (eq (peek-rune i) :eof) (unless (eq (peek-rune i) :eof)
(error "Garbage at end of XMLDecl.")) (wf-error "Garbage at end of XMLDecl."))
;; versioninfo muss da sein ;; versioninfo muss da sein
;; dann ? encodingdecl ;; dann ? encodingdecl
;; dann ? sddecl ;; dann ? sddecl
@ -2798,7 +2745,7 @@
(i (make-rod-xstream content)) (i (make-rod-xstream content))
(atts (read-attribute-list 'foo i t))) ;xxx on 'foo (atts (read-attribute-list 'foo i t))) ;xxx on 'foo
(unless (eq (peek-rune i) :eof) (unless (eq (peek-rune i) :eof)
(error "Garbage at end of TextDecl")) (wf-error "Garbage at end of TextDecl"))
;; versioninfo optional ;; versioninfo optional
;; encodingdecl muss da sein ;; encodingdecl muss da sein
;; dann ende ;; dann ende
@ -2935,7 +2882,7 @@
(let ((scheme (puri:uri-scheme uri)) (let ((scheme (puri:uri-scheme uri))
(path (puri:uri-parsed-path uri))) (path (puri:uri-parsed-path uri)))
(unless (member scheme '(nil :file)) (unless (member scheme '(nil :file))
(error 'parser-error (error 'xml-parse-error
:format-control "URI scheme ~S not supported" :format-control "URI scheme ~S not supported"
:format-arguments (list scheme))) :format-arguments (list scheme)))
(if (eq (car path) :relative) (if (eq (car path) :relative)
@ -3069,7 +3016,7 @@
(eql (stream-name-entity-kind (xstream-name x)) (eql (stream-name-entity-kind (xstream-name x))
(stream-name-entity-kind (xstream-name new-xstream))))) (stream-name-entity-kind (xstream-name new-xstream)))))
(zstream-input-stack zstream)) (zstream-input-stack zstream))
(error "Infinite recursion."))) (wf-error "Infinite recursion.")))
(push new-xstream (zstream-input-stack zstream)) (push new-xstream (zstream-input-stack zstream))
zstream) zstream)
@ -3208,9 +3155,9 @@
(defun internal-entity-expansion (name) (defun internal-entity-expansion (name)
(let ((def (get-entity-definition name :general (dtd *ctx*)))) (let ((def (get-entity-definition name :general (dtd *ctx*))))
(unless def (unless def
(error "Entity '~A' is not defined." (rod-string name))) (wf-error "Entity '~A' is not defined." (rod-string name)))
(unless (typep def 'internal-entdef) (unless (typep def 'internal-entdef)
(error "Entity '~A' is not an internal entity." name)) (wf-error "Entity '~A' is not an internal entity." name))
(or (entdef-expansion def) (or (entdef-expansion def)
(setf (entdef-expansion def) (find-internal-entity-expansion name))))) (setf (entdef-expansion def) (find-internal-entity-expansion name)))))
@ -3230,7 +3177,7 @@
(%put-unicode-char c collect))) (%put-unicode-char c collect)))
(t (t
(unless (name-start-rune-p (peek-rune input)) (unless (name-start-rune-p (peek-rune input))
(error "Expecting name after &.")) (wf-error "Expecting name after &."))
(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 #/\;))
@ -3247,7 +3194,7 @@
((space-rune-p c) ((space-rune-p c)
(collect #/space)) (collect #/space))
((not (data-rune-p c)) ((not (data-rune-p c))
(error "illegal char: ~S." c)) (wf-error "illegal char: ~S." c))
(t (t
(collect c))))))) (collect c)))))))
(declare (dynamic-extent #'muffle)) (declare (dynamic-extent #'muffle))
@ -3271,19 +3218,19 @@
(internal-entdef (p/content input)) (internal-entdef (p/content input))
(external-entdef (p/ext-parsed-ent input))) (external-entdef (p/ext-parsed-ent input)))
(unless (eq (peek-token input) :eof) (unless (eq (peek-token input) :eof)
(error "Trailing garbage. - ~S" (peek-token input)))))))) (wf-error "Trailing garbage. - ~S" (peek-token input))))))))
nil))) nil)))
(defun read-att-value-2 (input) (defun read-att-value-2 (input)
(let ((delim (read-rune input))) (let ((delim (read-rune input)))
(unless (member delim '(#/\" #/\') :test #'eql) (unless (member delim '(#/\" #/\') :test #'eql)
(error "Bad attribute value delimiter ~S, must be either #\\\" or #\\\'." (wf-error "Bad attribute value delimiter ~S, must be either #\\\" or #\\\'."
(rune-char delim delim))) (rune-char delim delim)))
(with-rune-collector-4 (collect) (with-rune-collector-4 (collect)
(loop (loop
(let ((c (read-rune input))) (let ((c (read-rune input)))
(cond ((eq c :eof) (cond ((eq c :eof)
(error "EOF")) (wf-error "EOF"))
((rune= c delim) ((rune= c delim)
(return)) (return))
((rune= c #/<) ((rune= c #/<)
@ -3329,7 +3276,7 @@
(local-name (subseq qname (1+ pos)))) (local-name (subseq qname (1+ pos))))
(if (nc-name-p local-name) (if (nc-name-p local-name)
(values prefix local-name) (values prefix local-name)
(error "~S is not a valid NcName." local-name))) (wf-error "~S is not a valid NcName." local-name)))
(values () qname)))) (values () qname))))
(defun decode-qname (qname) (defun decode-qname (qname)
@ -3344,7 +3291,7 @@
(defun find-namespace-binding (prefix) (defun find-namespace-binding (prefix)
(cdr (or (assoc (or prefix #"") (namespace-bindings *ctx*) :test #'rod=) (cdr (or (assoc (or prefix #"") (namespace-bindings *ctx*) :test #'rod=)
(error "Undeclared namespace prefix: ~A" (rod-string prefix))))) (wf-error "Undeclared namespace prefix: ~A" (rod-string prefix)))))
;; FIXME: Should probably be refactored by adding :start and :end to rod=/rod-equal ;; FIXME: Should probably be refactored by adding :start and :end to rod=/rod-equal
(defun rod-starts-with (prefix rod) (defun rod-starts-with (prefix rod)
@ -3395,29 +3342,33 @@
(cond (cond
((and (rod= prefix #"xml") ((and (rod= prefix #"xml")
(not (rod= uri #"http://www.w3.org/XML/1998/namespace"))) (not (rod= uri #"http://www.w3.org/XML/1998/namespace")))
(error "Attempt to rebind the prefix \"xml\" to ~S." (mu uri))) (wf-error "Attempt to rebind the prefix \"xml\" to ~S." (mu uri)))
((and (rod= uri #"http://www.w3.org/XML/1998/namespace") ((and (rod= uri #"http://www.w3.org/XML/1998/namespace")
(not (rod= prefix #"xml"))) (not (rod= prefix #"xml")))
(error "The namespace URI \"http://www.w3.org/XML/1998/namespace\" ~ (wf-error "The namespace ~
may not be bound to the prefix ~S, only \"xml\" is legal." URI \"http://www.w3.org/XML/1998/namespace\" may not ~
(mu prefix))) be bound to the prefix ~S, only \"xml\" is legal."
(mu prefix)))
((and (rod= prefix #"xmlns") ((and (rod= prefix #"xmlns")
(rod= uri #"http://www.w3.org/2000/xmlns/")) (rod= uri #"http://www.w3.org/2000/xmlns/"))
(error "Attempt to bind the prefix \"xmlns\" to its predefined ~ (wf-error "Attempt to bind the prefix \"xmlns\" to its predefined ~
URI \"http://www.w3.org/2000/xmlns/\", which is ~ URI \"http://www.w3.org/2000/xmlns/\", which is ~
forbidden for no good reason.")) forbidden for no good reason."))
((rod= prefix #"xmlns") ((rod= prefix #"xmlns")
(error "Attempt to bind the prefix \"xmlns\" to the URI ~S, ~ (wf-error "Attempt to bind the prefix \"xmlns\" to the URI ~S, ~
but it may not be declared." (mu uri))) but it may not be declared." (mu uri)))
((rod= uri #"http://www.w3.org/2000/xmlns/") ((rod= uri #"http://www.w3.org/2000/xmlns/")
(error "The namespace URI \"http://www.w3.org/2000/xmlns/\" may ~ (wf-error "The namespace URI \"http://www.w3.org/2000/xmlns/\" may ~
not be bound to prefix ~S (or any other)." (mu prefix))) not be bound to prefix ~S (or any other)." (mu prefix)))
((and (rod= uri #"") prefix) ((and (rod= uri #"") prefix)
(error "Only the default namespace (the one without a prefix) may ~ (wf-error "Only the default namespace (the one without a prefix) ~
be bound to an empty namespace URI, thus undeclaring it.")) may be bound to an empty namespace URI, thus ~
undeclaring it."))
(t (t
(push (cons prefix uri) (namespace-bindings *ctx*)) (push (cons prefix uri) (namespace-bindings *ctx*))
(sax:start-prefix-mapping (handler *ctx*) (car ns-decl) (cdr ns-decl)))))) (sax:start-prefix-mapping (handler *ctx*)
(car ns-decl)
(cdr ns-decl))))))
ns-decls)) ns-decls))
(defun undeclare-namespaces (ns-decls) (defun undeclare-namespaces (ns-decls)
@ -3457,9 +3408,9 @@
(rod= (sax:attribute-local-name attr-1) (rod= (sax:attribute-local-name attr-1)
(sax:attribute-local-name attr-2)))) (sax:attribute-local-name attr-2))))
(cdr sublist))) (cdr sublist)))
(error "Multiple definitions of attribute ~S in namespace ~S." (wf-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)