2 ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
4 ;; This code is free software; you can redistribute it and/or
5 ;; modify it under the terms of the version 2.1 of
6 ;; the GNU Lesser General Public License as published by
7 ;; the Free Software Foundation, as clarified by the AllegroServe
8 ;; prequel found in license-allegroserve.txt.
10 ;; This code is distributed in the hope that it will be useful,
11 ;; but without any warranty; without even the implied warranty of
12 ;; merchantability or fitness for a particular purpose. See the GNU
13 ;; Lesser General Public License for more details.
15 ;; Version 2.1 of the GNU Lesser General Public License is in the file
16 ;; license-lgpl.txt that was distributed with this file.
17 ;; If it is not present, you can access it from
18 ;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
19 ;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
20 ;; Suite 330, Boston, MA 02111-1307 USA
23 (in-package :net.xml.parser)
25 (pxml-dribble-bug-hook "$Id: pxml3.cl,v 1.2 2003/06/20 02:21:23 kevin Exp $")
27 (defvar *debug-dtd* nil)
29 (defun parse-dtd (tokenbuf
30 external external-callback)
31 (declare (optimize (speed 3) (safety 1)))
35 (multiple-value-bind (val kind)
36 (next-dtd-token tokenbuf
37 external include-count external-callback)
38 (if* (eq kind :end-dtd) then
39 (return (nreverse guts))
40 elseif (eq kind :include) then
42 elseif (eq kind :ignore) then nil
43 elseif (eq kind :include-end) then
44 (if* (> include-count 0) then (decf include-count)
45 else (xml-error "unexpected ']]>' token"))
46 else (when (iostruct-do-entity tokenbuf) (push val guts)))))))
48 (defparameter dtd-parser-states ())
50 (macrolet ((def-dtd-parser-state (var val)
51 `(progn (eval-when (compile load eval) (defconstant ,var ,val))
52 (pushnew '(,val . ,var) dtd-parser-states :key #'car))))
53 (def-dtd-parser-state state-dtdstart 0)
54 (def-dtd-parser-state state-tokenstart 1)
55 (def-dtd-parser-state state-dtd-? 2)
56 (def-dtd-parser-state state-dtd-! 3)
57 (def-dtd-parser-state state-dtd-comment 4)
58 (def-dtd-parser-state state-dtd-!-token 5)
59 (def-dtd-parser-state state-dtd-!-element 6)
60 (def-dtd-parser-state state-dtd-!-element-name 7)
61 (def-dtd-parser-state state-dtd-!-element-content 8)
62 (def-dtd-parser-state state-dtd-!-element-type 9)
63 (def-dtd-parser-state state-dtd-!-element-type-paren 10)
64 (def-dtd-parser-state state-dtd-!-element-type-token 11)
65 (def-dtd-parser-state state-dtd-!-element-type-end 12)
66 (def-dtd-parser-state state-dtd-!-element-type-paren-name 13)
67 (def-dtd-parser-state state-dtd-!-element-type-paren-pcd 14)
68 (def-dtd-parser-state state-dtd-!-element-type-paren-pcd2 15)
69 (def-dtd-parser-state state-dtd-!-element-type-paren-pcd3 16)
70 (def-dtd-parser-state state-dtd-!-element-type-paren-pcd4 17)
71 (def-dtd-parser-state state-dtd-!-element-type-paren-pcd5 18)
72 (def-dtd-parser-state state-dtd-!-element-type-paren-pcd6 19)
73 (def-dtd-parser-state state-dtd-!-element-type-paren-pcd7 20)
74 (def-dtd-parser-state state-dtd-!-element-type-paren-pcd8 21)
75 (def-dtd-parser-state state-dtd-!-element-type-paren-pcd9 22)
76 (def-dtd-parser-state state-dtd-!-element-type-paren-name2 23)
77 ;;(def-dtd-parser-state state-dtd-!-element-type-paren-seq 24) folded into choice
78 (def-dtd-parser-state state-dtd-!-element-type-paren-choice 25)
79 (def-dtd-parser-state state-dtd-!-element-type-paren2 26)
80 (def-dtd-parser-state state-dtd-!-element-type-paren-choice-name 27)
81 (def-dtd-parser-state state-dtd-!-element-type-paren-choice-paren 28)
82 (def-dtd-parser-state state-dtd-!-element-type-paren-choice-name2 29)
83 (def-dtd-parser-state state-dtd-!-element-type-paren3 30)
84 (def-dtd-parser-state state-dtd-!-element-type-paren-choice-name3 31)
85 (def-dtd-parser-state state-dtd-!-attlist 32)
86 (def-dtd-parser-state state-dtd-!-attlist-name 33)
87 (def-dtd-parser-state state-dtd-!-attdef 34)
88 (def-dtd-parser-state state-dtd-!-attdef-name 35)
89 (def-dtd-parser-state state-dtd-!-attdef-type 36)
90 ;;(def-dtd-parser-state state-dtd-!-attdef-enumeration 37)
91 (def-dtd-parser-state state-dtd-!-attdef-decl 38)
92 (def-dtd-parser-state state-dtd-!-attdef-decl-type 39)
93 (def-dtd-parser-state state-dtd-!-attdef-decl-value 40)
94 (def-dtd-parser-state state-dtd-!-attdef-decl-value2 41)
95 (def-dtd-parser-state state-dtd-!-attdef-decl-value3 42)
96 (def-dtd-parser-state state-dtd-!-attdef-decl-value4 43)
97 (def-dtd-parser-state state-dtd-!-attdef-decl-value5 44)
98 (def-dtd-parser-state state-dtd-!-attdef-decl-value6 45)
99 (def-dtd-parser-state state-dtd-!-attdef-decl-value7 46)
100 (def-dtd-parser-state state-dtd-!-attdef-notation 47)
101 (def-dtd-parser-state state-dtd-!-attdef-notation2 48)
102 (def-dtd-parser-state state-dtd-!-attdef-notation3 49)
103 (def-dtd-parser-state state-dtd-!-attdef-notation4 50)
104 (def-dtd-parser-state state-dtd-!-attdef-type2 51)
105 (def-dtd-parser-state state-dtd-!-entity 52)
106 (def-dtd-parser-state state-dtd-!-entity2 53)
107 (def-dtd-parser-state state-dtd-!-entity3 54)
108 (def-dtd-parser-state state-dtd-!-entity4 55)
109 (def-dtd-parser-state state-dtd-!-entity-value 56)
110 (def-dtd-parser-state state-dtd-!-entity5 57)
111 (def-dtd-parser-state state-dtd-!-entity6 58)
112 (def-dtd-parser-state state-!-dtd-system 59)
113 (def-dtd-parser-state state-!-dtd-public 60)
114 (def-dtd-parser-state state-!-dtd-system2 61)
115 (def-dtd-parser-state state-!-dtd-system3 62)
116 (def-dtd-parser-state state-!-dtd-system4 63)
117 (def-dtd-parser-state state-!-dtd-system5 64)
118 (def-dtd-parser-state state-!-dtd-system6 65)
119 (def-dtd-parser-state state-!-dtd-system7 66)
120 (def-dtd-parser-state state-!-dtd-public2 67)
121 (def-dtd-parser-state state-dtd-!-notation 68)
122 (def-dtd-parser-state state-dtd-!-notation2 69)
123 (def-dtd-parser-state state-dtd-!-notation3 70)
124 (def-dtd-parser-state state-dtd-?-2 71)
125 (def-dtd-parser-state state-dtd-?-3 72)
126 (def-dtd-parser-state state-dtd-?-4 73)
127 (def-dtd-parser-state state-dtd-comment2 74)
128 (def-dtd-parser-state state-dtd-comment3 75)
129 (def-dtd-parser-state state-dtd-comment4 76)
130 (def-dtd-parser-state state-dtd-!-entity7 77)
131 (def-dtd-parser-state state-dtd-!-attdef-notation5 78)
132 (def-dtd-parser-state state-!-dtd-public3 79)
133 (def-dtd-parser-state state-dtd-!-cond 80)
134 (def-dtd-parser-state state-dtd-!-cond2 81)
135 (def-dtd-parser-state state-dtd-!-include 82)
136 (def-dtd-parser-state state-dtd-!-ignore 83)
137 (def-dtd-parser-state state-dtd-!-include2 84)
138 (def-dtd-parser-state state-dtd-!-include3 85)
139 (def-dtd-parser-state state-dtd-!-include4 86)
140 (def-dtd-parser-state state-dtd-!-ignore2 87)
141 (def-dtd-parser-state state-dtd-!-ignore3 88)
142 (def-dtd-parser-state state-dtd-!-ignore4 89)
143 (def-dtd-parser-state state-dtd-!-ignore5 90)
144 (def-dtd-parser-state state-dtd-!-ignore6 91)
145 (def-dtd-parser-state state-dtd-!-ignore7 92)
148 (defun next-dtd-token (tokenbuf
149 external include-count external-callback)
150 (declare (:fbound parse-default-value) (optimize (speed 3) (safety 1)))
151 (macrolet ((add-to-entity-buf (entity-symbol p-value)
153 (push (make-tokenbuf :cur 0 :max (length ,p-value) :data ,p-value)
154 (iostruct-entity-bufs tokenbuf))))
157 `(push ,ch (iostruct-unget-char tokenbuf)))
160 `(setf (collector-next ,coll) 0))
162 (add-to-coll (coll ch)
163 `(let ((.next. (collector-next ,coll)))
164 (if* (>= .next. (collector-max ,coll))
165 then (grow-and-add ,coll ,ch)
166 else (setf (schar (collector-data ,coll) .next.)
168 (setf (collector-next ,coll) (1+ .next.)))))
170 (to-preferred-case (ch)
171 ;; should check the case mode
172 `(char-downcase ,ch))
175 (let ((state state-dtdstart)
176 (coll (get-collector))
177 (entity (get-collector))
187 (reference-save-state)
194 (setq ch (get-next-char tokenbuf))
196 (format t "~@<dtd ~:Ichar: ~s ~:_state: ~s ~:_contents: ~s ~:_pending: ~s ~:_pending-type: ~s ~:_entity-names ~s~:>~%"
197 ch (or (cdr (assoc state dtd-parser-states)) state)
198 contents-to-return pending pending-type
199 (iostruct-entity-names tokenbuf)))
201 then (setf prev-state state)
203 (return) ;; eof -- exit loop
208 (if* (and (eq #\] ch)
209 external (> include-count 0)) then
210 (setf state state-dtd-!-include3)
211 elseif (and (eq #\] ch) (not external)) then (return)
212 elseif (eq #\< ch) then (setf state state-tokenstart)
213 elseif (xml-space-p ch) then nil
214 elseif (eq #\% ch) then (external-param-reference tokenbuf coll external-callback)
216 (add-to-coll coll ch)
217 (setq ch (get-next-char tokenbuf))
220 (xml-error (concatenate 'string
221 "illegal DTD characters, starting at: '"
222 (compute-coll-string coll)
225 (#.state-dtd-!-include3
226 (if* (eq #\] ch) then (setf state state-dtd-!-include4)
229 (add-to-coll coll ch)
230 (setq ch (get-next-char tokenbuf))
233 (xml-error (concatenate 'string
234 "illegal DTD token, starting at: ']"
235 (compute-coll-string coll)
237 (#.state-dtd-!-include4
238 (if* (eq #\> ch) then (return)
241 (add-to-coll coll ch)
242 (setq ch (get-next-char tokenbuf))
245 (xml-error (concatenate 'string
246 "illegal DTD token, starting at: ']]"
247 (compute-coll-string coll)
251 (if* (xml-name-start-char-p ch) then
252 (add-to-coll coll ch)
253 (setf state state-dtd-pref2)
255 (add-to-coll coll ch)
256 (setq ch (get-next-char tokenbuf))
259 (xml-error (concatenate 'string
260 "illegal DTD parameter reference name, starting at: '"
261 (compute-coll-string coll)
265 (if* (eq #\? ch) then (setf state state-dtd-?)
266 elseif (eq #\! ch) then (setf state state-dtd-!)
268 (add-to-coll coll ch)
269 (setq ch (get-next-char tokenbuf))
272 (xml-error (concatenate 'string
273 "illegal DTD characters, starting at: '<"
274 (compute-coll-string coll)
278 (if* (xml-name-char-p ch)
280 (add-to-coll coll ch)
281 elseif (and external (eq #\% ch)) then
282 (external-param-reference tokenbuf coll external-callback)
284 (when (not (xml-space-p ch))
285 (xml-error (concatenate 'string
286 "expecting name following: '<?"
287 (compute-coll-string coll)
288 "' ; got: '" (string ch) "'"))
290 (when (= (collector-next coll) 0)
291 (xml-error "null <? token"))
292 (if* (and (= (collector-next coll) 3)
293 (or (eq (elt (collector-data coll) 0) #\X)
294 (eq (elt (collector-data coll) 0) #\x))
295 (or (eq (elt (collector-data coll) 1) #\M)
296 (eq (elt (collector-data coll) 1) #\m))
297 (or (eq (elt (collector-data coll) 2) #\L)
298 (eq (elt (collector-data coll) 2) #\l)))
300 (xml-error "<?xml not allowed in dtd")
302 (setq tag-to-return (compute-tag coll))
303 (setf state state-dtd-?-2))
306 (if* (xml-space-p ch)
308 elseif (and external (eq #\% ch)) then
309 (external-param-reference tokenbuf coll external-callback)
310 elseif (not (xml-char-p ch))
311 then (xml-error "XML is not well formed") ;; no test
312 else (add-to-coll coll ch)
313 (setf state state-dtd-?-3)))
316 then (setf state state-dtd-?-4)
317 elseif (not (xml-char-p ch))
318 then (xml-error "XML is not well formed") ;; no test
319 else (add-to-coll coll ch)))
323 (push (compute-coll-string coll) contents-to-return)
326 else (setf state state-dtd-?-3)
327 (add-to-coll coll #\?)
328 (add-to-coll coll ch)))
330 (if* (eq #\- ch) then (setf state state-dtd-comment)
331 elseif (xml-name-start-char-p ch) then (setf state state-dtd-!-token)
333 elseif (and (eq #\[ ch) external) then
334 (setf state state-dtd-!-cond)
336 (add-to-coll coll ch)
337 (setq ch (get-next-char tokenbuf))
340 (xml-error (concatenate 'string
341 "illegal DTD characters, starting at: '<!"
342 (compute-coll-string coll)
346 (if* (xml-space-p ch) then nil
347 elseif (and external (eq #\% ch)) then
348 (external-param-reference tokenbuf coll external-callback)
349 elseif (eq #\I ch) then (setf state state-dtd-!-cond2)
350 else (error "this should not happen")
353 (if* (eq #\N ch) then (setf state state-dtd-!-include)
355 elseif (eq #\G ch) then (setf state state-dtd-!-ignore)
357 else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
359 (#.state-dtd-!-ignore
360 (if* (and (eq check-count 5) (eq ch #\E)) then
361 (setf state state-dtd-!-ignore2)
362 elseif (eq ch (elt "IGNORE" check-count)) then
364 else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
366 (#.state-dtd-!-ignore2
367 (if* (xml-space-p ch) then nil
368 elseif (and external (eq #\% ch)) then
369 (external-param-reference tokenbuf coll external-callback)
370 elseif (eq #\[ ch) then (setf state state-dtd-!-ignore3)
372 else (xml-error "'[' missing after '<![Ignore'")))
373 (#.state-dtd-!-ignore3
374 (if* (eq #\< ch) then (setf state state-dtd-!-ignore4)
375 elseif (eq #\] ch) then (setf state state-dtd-!-ignore5)))
376 (#.state-dtd-!-ignore4
377 (if* (eq #\! ch) then (setf state state-dtd-!-ignore6)
378 else (un-next-char ch)
379 (setf state state-dtd-!-ignore3)))
380 (#.state-dtd-!-ignore5
381 (if* (eq #\] ch) then (setf state state-dtd-!-ignore7)
382 else (un-next-char ch)
383 (setf state state-dtd-!-ignore3)))
384 (#.state-dtd-!-ignore6
385 (if* (eq #\[ ch) then (incf ignore-count)
386 (setf state state-dtd-!-ignore3)
387 else (un-next-char ch)
388 (setf state state-dtd-!-ignore3)))
389 (#.state-dtd-!-ignore7
390 (if* (eq #\> ch) then (decf ignore-count)
391 (when (= ignore-count 0) (return))
392 else (un-next-char ch)
393 (setf state state-dtd-!-ignore3)))
394 (#.state-dtd-!-include
395 (if* (and (eq check-count 6) (eq ch #\E)) then
396 (setf state state-dtd-!-include2)
397 elseif (eq ch (elt "INCLUD" check-count)) then
399 else (xml-error "<![ external DTD token not INCLUDE or IGNORE")
401 (#.state-dtd-!-include2
402 (if* (xml-space-p ch) then nil
403 elseif (and external (eq #\% ch)) then
404 (external-param-reference tokenbuf coll external-callback)
405 elseif (eq #\[ ch) then (return)
406 else (xml-error "'[' missing after '<![INCLUDE'")))
409 then (setf state state-dtd-comment2)
410 (setf tag-to-return :comment)
411 else (clear-coll coll)
413 (add-to-coll coll ch)
414 (setq ch (get-next-char tokenbuf))
417 (xml-error (concatenate 'string
418 "illegal token following '<![-', starting at '<!-"
419 (compute-coll-string coll)
422 (#.state-dtd-comment2
424 then (setf state state-dtd-comment3)
425 else (add-to-coll coll ch)))
426 (#.state-dtd-comment3
428 then (setf state state-dtd-comment4)
429 else (setf state state-dtd-comment2)
430 (add-to-coll coll #\-) (add-to-coll coll ch)))
431 (#.state-dtd-comment4
433 then (push (compute-coll-string coll) contents-to-return)
436 else (clear-coll coll)
438 (add-to-coll coll ch)
439 (setq ch (get-next-char tokenbuf))
442 (xml-error (concatenate 'string
443 "illegal token following '--' comment terminator, starting at '--"
444 (compute-coll-string coll)
448 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
449 elseif (and external (eq #\% ch)) then
450 (external-param-reference tokenbuf coll external-callback)
451 elseif (xml-space-p ch) then
452 (setf tag-to-return (compute-tag coll))
454 (if* (eq tag-to-return :ELEMENT) then (setf state state-dtd-!-element)
455 elseif (eq tag-to-return :ATTLIST) then
456 (setf state state-dtd-!-attlist)
457 elseif (eq tag-to-return :ENTITY) then
459 (setf state state-dtd-!-entity)
460 elseif (eq tag-to-return :NOTATION) then
461 (setf state state-dtd-!-notation)
463 (xml-error (concatenate 'string
464 "illegal DTD characters, starting at: '<!"
465 (string tag-to-return)
468 (add-to-coll coll ch)
469 (setq ch (get-next-char tokenbuf))
472 (xml-error (concatenate 'string
473 "illegal DTD characters, starting at: '<!"
474 (compute-coll-string coll)
477 (#.state-dtd-!-notation
478 (if* (xml-space-p ch) then nil
479 elseif (and external (eq #\% ch)) then
480 (external-param-reference tokenbuf coll external-callback)
481 elseif (xml-name-start-char-p ch) then
482 (add-to-coll coll ch)
483 (setf state state-dtd-!-notation2)
485 (add-to-coll coll ch)
486 (setq ch (get-next-char tokenbuf))
489 (xml-error (concatenate 'string
490 "illegal DTD characters, starting at: '<!NOTATION "
491 (compute-coll-string coll)
494 (#.state-dtd-!-notation2
495 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
496 elseif (and external (eq #\% ch)) then
497 (external-param-reference tokenbuf coll external-callback)
498 elseif (xml-space-p ch) then
499 (push (compute-tag coll) contents-to-return)
501 (setf state state-dtd-!-notation3)
503 (add-to-coll coll ch)
504 (setq ch (get-next-char tokenbuf))
507 (xml-error (concatenate 'string
508 "illegal DTD <!NOTATION name: "
509 (compute-coll-string coll)
512 (#.state-dtd-!-notation3
513 (if* (xml-space-p ch) then nil
514 elseif (and external (eq #\% ch)) then
515 (external-param-reference tokenbuf coll external-callback)
516 elseif (xml-name-char-p ch) then
517 (add-to-coll coll ch)
518 (setf state state-dtd-!-entity6)
520 (add-to-coll coll ch)
521 (setq ch (get-next-char tokenbuf))
524 (xml-error (concatenate 'string
525 "illegal DTD <!NOTATION spec for "
526 (string (first contents-to-return))
528 (compute-coll-string coll)
531 (#.state-dtd-!-entity
532 (if* (eq #\% ch) then (push :param contents-to-return)
534 (setf state state-dtd-!-entity2)
535 elseif (xml-name-start-char-p ch) then
536 (add-to-coll coll ch)
538 (setf state state-dtd-!-entity3)
539 elseif (xml-space-p ch) then nil
540 elseif (and external (eq #\% ch)) then
541 (external-param-reference tokenbuf coll external-callback)
543 (add-to-coll coll ch)
544 (setq ch (get-next-char tokenbuf))
547 (xml-error (concatenate 'string
548 "illegal DTD characters, starting at: '<!ENTITY "
549 (compute-coll-string coll)
552 (#.state-dtd-!-entity2
553 (if* (xml-space-p ch) then (setf state state-dtd-!-entity7)
554 elseif (and external (eq #\% ch)) then
555 (external-param-reference tokenbuf coll external-callback)
557 (add-to-coll coll ch)
558 (setq ch (get-next-char tokenbuf))
561 (xml-error (concatenate 'string
562 "illegal DTD <!ENTITY spec for "
563 (string (first contents-to-return))
565 (compute-coll-string coll)
568 (#.state-dtd-!-entity3
569 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
570 elseif (and external (eq #\% ch)) then
571 (external-param-reference tokenbuf coll external-callback)
572 elseif (xml-space-p ch) then
573 (push (compute-tag coll) contents-to-return)
574 (setf contents-to-return
575 (nreverse contents-to-return))
577 (setf state state-dtd-!-entity4)
579 (add-to-coll coll ch)
580 (setq ch (get-next-char tokenbuf))
583 (xml-error (concatenate 'string
584 "illegal DTD <!ENTITY name: "
585 (compute-coll-string coll)
588 (#.state-dtd-!-entity4
589 (if* (xml-space-p ch) then nil
590 elseif (and external (eq #\% ch)) then
591 (external-param-reference tokenbuf coll external-callback)
592 elseif (or (eq #\' ch) (eq #\" ch)) then
593 (setf value-delim ch)
594 (setf state state-dtd-!-entity-value)
595 elseif (xml-name-start-char-p ch) then
596 (add-to-coll coll ch)
597 (setf state state-dtd-!-entity6)
599 (add-to-coll coll ch)
600 (setq ch (get-next-char tokenbuf))
603 (xml-error (concatenate 'string
604 "illegal DTD <!ENTITY spec: '"
605 (compute-coll-string coll)
608 (#.state-dtd-!-entity6
609 (if* (xml-name-char-p ch) ;; starting char already passed more restrictive test
611 (add-to-coll coll ch)
612 elseif (and external (eq #\% ch)) then
613 (external-param-reference tokenbuf coll external-callback)
615 (when (not (xml-space-p ch))
617 (add-to-coll coll ch)
618 (setq ch (get-next-char tokenbuf))
623 "illegal character in '"
624 (compute-coll-string coll)
625 "' in <! tag: " (string tag-to-return) " "
626 (string (first contents-to-return))
629 (let ((token (compute-tag coll)))
630 (push token contents-to-return)
632 (if* (eq :SYSTEM token) then (setf state state-!-dtd-system)
633 elseif (eq :PUBLIC token) then (setf state state-!-dtd-public)
636 "expected 'SYSTEM' or 'PUBLIC' got '"
637 (string (first contents-to-return))
638 "' in <! tag: " (string tag-to-return) " "
639 (string (second contents-to-return))))
642 (#.state-dtd-!-entity7
643 (if* (xml-space-p ch) then nil
644 elseif (and external (eq #\% ch)) then
645 (external-param-reference tokenbuf coll external-callback)
646 elseif (xml-name-start-char-p ch) then
647 (add-to-coll coll ch)
648 (setf state state-dtd-!-entity3)
650 (add-to-coll coll ch)
651 (setq ch (get-next-char tokenbuf))
654 (xml-error (concatenate 'string
655 "illegal DTD <!ENTITY % name: "
656 (compute-coll-string coll)
659 (#.state-!-dtd-public
660 (if* (xml-space-p ch) then nil
661 elseif (and external (eq #\% ch)) then
662 (external-param-reference tokenbuf coll external-callback)
663 elseif (or (eq #\" ch) (eq #\' ch)) then
664 (setf state state-!-dtd-public2)
665 (setf value-delim ch)
668 "expected quote or double-quote got: '"
670 "' in <! tag: " (string tag-to-return) " "
671 (string (second contents-to-return)) " "
672 (string (first contents-to-return))
674 (#.state-!-dtd-public2
675 (if* (eq value-delim ch) then
676 (push (setf public-string
677 (normalize-public-value
678 (compute-coll-string coll))) contents-to-return)
680 (setf state state-!-dtd-public3)
681 elseif (pub-id-char-p ch) then (add-to-coll coll ch)
683 (add-to-coll coll ch)
684 (setq ch (get-next-char tokenbuf))
689 "illegal character in string: '"
690 (compute-coll-string coll) "'"))
692 (#.state-!-dtd-public3
693 (if* (xml-space-p ch) then (setf state state-!-dtd-system)
694 elseif (and external (eq #\% ch)) then
695 (external-param-reference tokenbuf coll external-callback)
696 elseif (and (not entityp)
698 (setf state state-!-dtd-system)
702 (add-to-coll coll ch)
703 (setq ch (get-next-char tokenbuf))
708 "Expected space before: '"
709 (compute-coll-string coll) "'"))
711 (#.state-!-dtd-system
712 (if* (xml-space-p ch) then nil
713 elseif (and external (eq #\% ch)) then
714 (external-param-reference tokenbuf coll external-callback)
715 elseif (or (eq #\" ch) (eq #\' ch)) then
716 (setf state state-!-dtd-system2)
717 (setf value-delim ch)
718 elseif (and (not entityp)
719 (eq #\> ch)) then (return)
722 "expected quote or double-quote got: '"
724 "' in <! tag: " (string tag-to-return) " "
725 (string (second contents-to-return)) " "
726 (string (first contents-to-return))
728 (#.state-!-dtd-system2
729 (when (not (xml-char-p ch))
730 (xml-error "XML is not well formed")) ;; not tested
731 (if* (eq value-delim ch) then
732 (let ((entity-symbol (first (last contents-to-return)))
733 (system-string (compute-coll-string coll)))
735 (when (not (assoc entity-symbol (iostruct-parameter-entities tokenbuf)))
736 (setf (iostruct-parameter-entities tokenbuf)
737 (acons entity-symbol (list (parse-uri system-string)
740 (iostruct-parameter-entities tokenbuf)))
743 (when (not (assoc entity-symbol (iostruct-general-entities tokenbuf)))
744 (setf (iostruct-general-entities tokenbuf)
745 (acons entity-symbol (list (parse-uri system-string)
749 (iostruct-general-entities tokenbuf)))
750 (when (not (assoc entity-symbol (iostruct-general-entities tokenbuf)))
751 (setf (iostruct-general-entities tokenbuf)
752 (acons entity-symbol (list (parse-uri system-string)
756 (iostruct-general-entities tokenbuf))))
759 (push system-string contents-to-return))
761 (setf state state-!-dtd-system3)
762 else (add-to-coll coll ch)))
763 (#.state-!-dtd-system3
764 (if* (xml-space-p ch) then (setf state state-!-dtd-system4)
765 elseif (and external (eq #\% ch)) then
766 (external-param-reference tokenbuf coll external-callback)
767 elseif (eq #\> ch) then (return)
770 (add-to-coll coll ch)
771 (setq ch (get-next-char tokenbuf))
774 (xml-error (concatenate 'string
775 "illegal DTD <!ENTITY value for "
776 (string (first (nreverse contents-to-return)))
778 (compute-coll-string coll)
781 (#.state-!-dtd-system4
782 (if* (xml-space-p ch) then nil
783 elseif (and external (eq #\% ch)) then
784 (external-param-reference tokenbuf coll external-callback)
785 elseif (and (not pentityp) (xml-name-start-char-p ch)) then
786 (add-to-coll coll ch)
787 (setf state state-!-dtd-system5)
788 elseif (eq #\> ch) then (return)
790 (add-to-coll coll ch)
791 (setq ch (get-next-char tokenbuf))
794 (xml-error (concatenate 'string
795 "illegal DTD <!ENTITY value for "
796 (string (first (nreverse contents-to-return)))
798 (compute-coll-string coll)
801 (#.state-!-dtd-system5
802 (if* (xml-name-char-p ch) then
803 (add-to-coll coll ch)
804 elseif (and external (eq #\% ch)) then
805 (external-param-reference tokenbuf coll external-callback)
806 elseif (xml-space-p ch) then
807 (let ((token (compute-tag coll)))
808 (when (not (eq :NDATA token))
810 (add-to-coll coll ch)
811 (setq ch (get-next-char tokenbuf))
814 (xml-error (concatenate 'string
815 "illegal DTD <!ENTITY value for "
816 (string (first (nreverse contents-to-return)))
818 (compute-coll-string coll)
822 (push token contents-to-return)
823 (setf state state-!-dtd-system6))
825 (add-to-coll coll ch)
826 (setq ch (get-next-char tokenbuf))
829 (xml-error (concatenate 'string
830 "illegal DTD <!ENTITY value for "
831 (string (first (nreverse contents-to-return)))
833 (compute-coll-string coll)
836 (#.state-!-dtd-system6
837 (if* (xml-space-p ch) then nil
838 elseif (and external (eq #\% ch)) then
839 (external-param-reference tokenbuf coll external-callback)
840 elseif (xml-name-start-char-p ch) then
841 (add-to-coll coll ch)
842 (setf state state-!-dtd-system7)
844 (add-to-coll coll ch)
845 (setq ch (get-next-char tokenbuf))
848 (xml-error (concatenate 'string
849 "illegal DTD <!ENTITY value for "
850 (string (first (nreverse contents-to-return)))
852 (compute-coll-string coll)
855 (#.state-!-dtd-system7
856 (if* (xml-name-char-p ch) then
857 (add-to-coll coll ch)
858 elseif (and external (eq #\% ch)) then
859 (external-param-reference tokenbuf coll external-callback)
860 elseif (xml-space-p ch) then
861 (push (compute-tag coll) contents-to-return)
863 (setf state state-dtd-!-entity5) ;; just looking for space, >
864 elseif (eq #\> ch) then
865 (push (compute-tag coll) contents-to-return)
869 (add-to-coll coll ch)
870 (setq ch (get-next-char tokenbuf))
873 (xml-error (concatenate 'string
874 "illegal DTD <!ENTITY value for "
875 (string (first (nreverse contents-to-return)))
877 (compute-coll-string coll)
880 (#.state-dtd-!-entity-value
881 (if* (eq ch value-delim) then
882 (let ((tmp (compute-coll-string coll)))
883 (when (> (length tmp) 0)
884 (when (null (first pending)) (setf pending (rest pending)))
886 (if* (> (length pending) 1) then
887 (push (nreverse pending) contents-to-return)
888 else (push (first pending) contents-to-return))
889 (setf pending (list nil))
890 (setf state state-dtd-!-entity5)
893 (when (not (assoc (third contents-to-return)
894 (iostruct-parameter-entities tokenbuf)))
895 (setf (iostruct-parameter-entities tokenbuf)
896 (acons (third contents-to-return)
897 (first contents-to-return)
898 (iostruct-parameter-entities tokenbuf))))
900 (when (not (assoc (second contents-to-return)
901 (iostruct-general-entities tokenbuf)))
902 (setf (iostruct-general-entities tokenbuf)
903 (acons (second contents-to-return)
904 (first contents-to-return)
905 (iostruct-general-entities tokenbuf)))))
906 elseif (eq #\& ch) then
907 (setf reference-save-state state-dtd-!-entity-value)
908 (setf state state-dtd-!-attdef-decl-value3)
909 elseif (eq #\% ch) then
911 (setf reference-save-state state-dtd-!-entity-value)
912 (setf state state-dtd-!-attdef-decl-value3)
913 elseif (xml-char-p ch)
914 then (add-to-coll coll ch)
916 (add-to-coll coll ch)
917 (setq ch (get-next-char tokenbuf))
920 (xml-error (concatenate 'string
921 "illegal DTD <!ENTITY value for "
922 (string (first contents-to-return))
924 (compute-coll-string coll)
927 (#.state-dtd-!-entity5
928 (if* (xml-space-p ch) then nil
929 elseif (and external (eq #\% ch)) then
930 (external-param-reference tokenbuf coll external-callback)
931 elseif (eq #\> ch) then (return)
932 else (clear-coll coll)
934 (add-to-coll coll ch)
935 (setq ch (get-next-char tokenbuf))
938 (xml-error (concatenate 'string
939 "illegal DTD contents following <!ENTITY spec for "
940 (string (first contents-to-return))
942 (compute-coll-string coll)
945 (#.state-dtd-!-attlist
946 (if* (xml-name-start-char-p ch) then (setf state state-dtd-!-attlist-name)
948 elseif (xml-space-p ch) then nil
949 elseif (and external (eq #\% ch)) then
950 (external-param-reference tokenbuf coll external-callback)
952 (add-to-coll coll ch)
953 (setq ch (get-next-char tokenbuf))
956 (xml-error (concatenate 'string
957 "illegal DTD characters, starting at: '<!ATTLIST "
958 (compute-coll-string coll)
960 (#.state-dtd-!-attlist-name
961 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
962 elseif (and external (eq #\% ch)) then
963 (external-param-reference tokenbuf coll external-callback)
964 elseif (xml-space-p ch) then
965 (push (compute-tag coll *package*)
968 (setf state state-dtd-!-attdef)
969 elseif (eq #\> ch) then
970 (push (compute-tag coll *package*)
974 else (push (compute-tag coll)
978 (add-to-coll coll ch)
979 (setq ch (get-next-char tokenbuf))
982 (xml-error (concatenate 'string
983 "illegal DTD <!ATTLIST content spec for "
984 (string (first contents-to-return))
986 (compute-coll-string coll)
989 (#.state-dtd-!-attdef
990 (if* (xml-space-p ch) then nil
991 elseif (and external (eq #\% ch)) then
992 (external-param-reference tokenbuf coll external-callback)
993 elseif (xml-name-start-char-p ch) then
995 (setf state state-dtd-!-attdef-name)
996 elseif (eq #\> ch) then (return)
998 (add-to-coll coll ch)
999 (setq ch (get-next-char tokenbuf))
1002 (xml-error (concatenate 'string
1003 "illegal DTD <!ATTLIST content spec for "
1004 (string (first contents-to-return))
1006 (compute-coll-string coll)
1009 (#.state-dtd-!-attdef-name
1010 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1011 elseif (and external (eq #\% ch)) then
1012 (external-param-reference tokenbuf coll external-callback)
1013 elseif (xml-space-p ch) then
1014 (setf (first pending) (compute-tag coll *package*))
1016 (setf state state-dtd-!-attdef-type)
1017 else (dotimes (i 15)
1018 (add-to-coll coll ch)
1019 (setq ch (get-next-char tokenbuf))
1022 (xml-error (concatenate 'string
1023 "illegal DTD <!ATTLIST type spec for "
1024 (string (first contents-to-return))
1026 (compute-coll-string coll)
1029 (#.state-dtd-!-attdef-type
1030 (if* (xml-space-p ch) then nil
1031 elseif (and external (eq #\% ch)) then
1032 (external-param-reference tokenbuf coll external-callback)
1033 else (un-next-char ch)
1034 ;; let next state do all other checking
1035 (setf state state-dtd-!-attdef-type2)))
1036 (#.state-dtd-!-attdef-type2
1037 ;; can only be one of a few tokens, but wait until token built to check
1038 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1039 elseif (and (eq #\( ch) (= 0 (length (compute-coll-string coll)))) then
1040 (push (list :enumeration) pending)
1041 (setf state state-dtd-!-attdef-notation2)
1042 elseif (and external (eq #\% ch)) then
1043 (external-param-reference tokenbuf coll external-callback)
1044 elseif (xml-space-p ch) then
1045 (let ((token (compute-tag coll)))
1046 (when (and (not (eq :CDATA token))
1047 (not (eq :ID token))
1048 (not (eq :IDREF token))
1049 (not (eq :IDREFS token))
1050 (not (eq :ENTITY token))
1051 (not (eq :ENTITIES token))
1052 (not (eq :NMTOKEN token))
1053 (not (eq :NMTOKENS token))
1054 (not (eq :NOTATION token)))
1056 (add-to-coll coll ch)
1057 (setq ch (get-next-char tokenbuf))
1060 (xml-error (concatenate 'string
1061 "illegal DTD <!ATTLIST type spec for "
1062 (string (first contents-to-return))
1064 (compute-coll-string coll)
1066 (if* (eq token :NOTATION) then
1067 (push (list token) pending)
1068 (setf state state-dtd-!-attdef-notation)
1070 (push token pending)
1071 (setf state state-dtd-!-attdef-decl))
1074 else (dotimes (i 15)
1075 (add-to-coll coll ch)
1076 (setq ch (get-next-char tokenbuf))
1079 (xml-error (concatenate 'string
1080 "illegal DTD <!ATTLIST type spec for "
1081 (string (first contents-to-return))
1083 (compute-coll-string coll)
1086 (#.state-dtd-!-attdef-notation
1087 (if* (xml-space-p ch) then nil
1088 elseif (and external (eq #\% ch)) then
1089 (external-param-reference tokenbuf coll external-callback)
1090 elseif (eq #\( ch) then (setf state state-dtd-!-attdef-notation2)
1091 else (dotimes (i 15)
1092 (add-to-coll coll ch)
1093 (setq ch (get-next-char tokenbuf))
1096 (xml-error (concatenate 'string
1097 "illegal DTD <!ATTLIST type spec for "
1098 (string (first contents-to-return))
1100 (compute-coll-string coll)
1103 (#.state-dtd-!-attdef-notation2
1104 (if* (xml-space-p ch) then nil
1105 elseif (and external (eq #\% ch)) then
1106 (external-param-reference tokenbuf coll external-callback)
1107 elseif (xml-name-start-char-p ch) then
1108 (setf state state-dtd-!-attdef-notation3)
1109 (add-to-coll coll ch)
1110 elseif (and (xml-name-char-p ch) (listp (first pending))
1111 (eq :enumeration (first (reverse (first pending))))) then
1112 (setf state state-dtd-!-attdef-notation3)
1113 (add-to-coll coll ch)
1114 else (dotimes (i 15)
1115 (add-to-coll coll ch)
1116 (setq ch (get-next-char tokenbuf))
1119 (xml-error (concatenate 'string
1120 "illegal DTD <!ATTLIST type spec for "
1121 (string (first contents-to-return))
1123 (compute-coll-string coll)
1126 (#.state-dtd-!-attdef-notation3
1127 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1128 elseif (and external (eq #\% ch)) then
1129 (external-param-reference tokenbuf coll external-callback)
1130 elseif (and external (eq #\% ch)) then
1131 (external-param-reference tokenbuf coll external-callback)
1132 elseif (xml-space-p ch) then
1133 (push (compute-tag coll) (first pending))
1135 (setf state state-dtd-!-attdef-notation4)
1136 elseif (eq #\| ch) then
1137 (push (compute-tag coll) (first pending))
1139 (setf state state-dtd-!-attdef-notation2)
1140 elseif (eq #\) ch) then
1141 (push (compute-tag coll) (first pending))
1143 (setf (first pending) (nreverse (first pending)))
1144 ;;(setf state state-dtd-!-attdef-decl)
1145 (setf state state-dtd-!-attdef-notation5)
1146 else (dotimes (i 15)
1147 (add-to-coll coll ch)
1148 (setq ch (get-next-char tokenbuf))
1151 (xml-error (concatenate 'string
1152 "illegal DTD <!ATTLIST type spec for "
1153 (string (first contents-to-return))
1155 (compute-coll-string coll)
1158 (#.state-dtd-!-attdef-notation5
1159 (if* (xml-space-p ch) then (setf state state-dtd-!-attdef-decl)
1160 elseif (and external (eq #\% ch)) then
1161 (external-param-reference tokenbuf coll external-callback)
1164 (add-to-coll coll ch)
1165 (setq ch (get-next-char tokenbuf))
1169 (concatenate 'string
1170 "Expected space before: '"
1171 (compute-coll-string coll) "'"))))
1172 (#.state-dtd-!-attdef-notation4
1173 (if* (xml-space-p ch) then nil
1174 elseif (and external (eq #\% ch)) then
1175 (external-param-reference tokenbuf coll external-callback)
1176 elseif (xml-name-char-p ch) then (add-to-coll coll ch)
1177 (setf state state-dtd-!-attdef-notation3)
1178 elseif (eq #\| ch) then (setf state state-dtd-!-attdef-notation2)
1179 elseif (eq #\) ch) then (setf state state-dtd-!-attdef-decl)
1180 (setf (first pending) (nreverse (first pending)))
1181 else (dotimes (i 15)
1182 (add-to-coll coll ch)
1183 (setq ch (get-next-char tokenbuf))
1186 (xml-error (concatenate 'string
1187 "illegal DTD <!ATTLIST type spec for "
1188 (string (first contents-to-return))
1190 (compute-coll-string coll)
1193 (#.state-dtd-!-attdef-decl
1194 (if* (eq #\# ch) then
1195 (setf state state-dtd-!-attdef-decl-type)
1196 elseif (or (eq #\' ch) (eq #\" ch)) then
1197 (setf value-delim ch)
1198 (setf state state-dtd-!-attdef-decl-value)
1199 elseif (xml-space-p ch) then nil
1200 elseif (and external (eq #\% ch)) then
1201 (external-param-reference tokenbuf coll external-callback)
1202 else (dotimes (i 15)
1203 (add-to-coll coll ch)
1204 (setq ch (get-next-char tokenbuf))
1207 (xml-error (concatenate 'string
1208 "illegal DTD <!ATTLIST type spec for "
1209 (string (first contents-to-return))
1211 (compute-coll-string coll)
1214 (#.state-dtd-!-attdef-decl-value
1215 (if* (eq ch value-delim) then
1217 (push (first (parse-default-value (list (compute-coll-string coll))
1218 tokenbuf external-callback))
1221 (push (compute-coll-string coll) pending)
1222 (setf contents-to-return
1223 (append contents-to-return
1226 else (list (nreverse pending)))))
1227 (setf pending (list nil))
1228 (setf state state-dtd-!-attdef)
1230 elseif (eq #\& ch) then (setf state state-dtd-!-attdef-decl-value3)
1231 (setf reference-save-state state-dtd-!-attdef-decl-value)
1232 elseif (and (xml-char-p ch) (not (eq #\< ch)))
1233 then (add-to-coll coll ch)
1234 else (dotimes (i 15)
1235 (add-to-coll coll ch)
1236 (setq ch (get-next-char tokenbuf))
1239 (xml-error (concatenate 'string
1240 "illegal DTD <!ATTLIST type spec for "
1241 (string (first contents-to-return))
1243 (compute-coll-string coll)
1246 (#.state-dtd-!-attdef-decl-value3
1247 (if* (and (not prefp) (eq #\# ch))
1248 then (setf state state-dtd-!-attdef-decl-value4)
1249 elseif (xml-name-start-char-p ch)
1250 then (setf state state-dtd-!-attdef-decl-value5)
1251 (when (not prefp) (add-to-coll coll #\&))
1253 else (clear-coll coll)
1255 (add-to-coll coll ch)
1256 (setq ch (get-next-char tokenbuf))
1259 (xml-error (concatenate 'string
1260 "illegal reference name, starting at: '&"
1261 (compute-coll-string coll)
1263 (#.state-dtd-!-attdef-decl-value4
1265 then (setf state state-dtd-!-attdef-decl-value6)
1266 elseif (<= (char-code #\0) (char-code ch) (char-code #\9))
1267 then (setf state state-dtd-!-attdef-decl-value7)
1269 else (clear-coll coll)
1271 (add-to-coll coll ch)
1272 (setq ch (get-next-char tokenbuf))
1275 (xml-error (concatenate 'string
1276 "illegal character reference code, starting at: '&#"
1277 (compute-coll-string coll)
1280 (#.state-dtd-!-attdef-decl-value5
1281 (if* (xml-name-char-p ch)
1282 then (add-to-coll entity ch)
1283 (when (not prefp) (add-to-coll coll ch))
1286 (if* (not prefp) then (add-to-coll coll ch)
1287 elseif (not external) then
1289 (concatenate 'string
1290 "internal dtd subset cannot reference parameter entity within a token; entity: "
1291 (compute-coll-string entity)))
1293 (let* ((entity-symbol (compute-tag entity))
1295 (assoc entity-symbol (iostruct-parameter-entities tokenbuf))))
1297 (if* (and (iostruct-do-entity tokenbuf)
1299 (assoc entity-symbol
1300 (iostruct-parameter-entities tokenbuf)))) then
1301 (setf p-value (rest p-value))
1302 (when (member entity-symbol (iostruct-entity-names tokenbuf))
1303 (xml-error (concatenate 'string
1305 (string entity-symbol)
1306 " in recursive reference")))
1307 (push entity-symbol (iostruct-entity-names tokenbuf))
1308 (if* (stringp p-value) then
1309 (dotimes (i (length p-value))
1310 (add-to-coll coll (schar p-value i)))
1312 (if* (null external-callback) then
1313 (setf (iostruct-do-entity tokenbuf) nil)
1315 (let ((count 0) (string "<?xml ") last-ch
1319 (apply external-callback p-value)))
1321 (let ((tmp-buf (get-tokenbuf)))
1322 (setf (tokenbuf-stream tmp-buf)
1325 (iostruct-unget-char tokenbuf))
1326 (setf (iostruct-unget-char tokenbuf) nil)
1327 (unicode-check entity-stream tokenbuf)
1328 (when (iostruct-unget-char tokenbuf)
1329 (setf save-ch (first (iostruct-unget-char tokenbuf))))
1330 (setf (iostruct-unget-char tokenbuf) save-unget)
1341 (iostruct-read-sequence-func
1343 (when (null cch) (return))
1345 (format t "dtd-char: ~s~%" cch))
1346 (if* (< count 0) then
1347 (if* (and (eq last-ch #\?)
1350 else (setf last-ch cch))
1351 elseif (< count 6) then
1352 (when (and (= count 5)
1356 (schar string count)
1359 (when (= tmp-count count)
1365 (add-to-coll coll cch)
1368 elseif (= count 6) then
1370 (add-to-coll coll (schar string i)))
1372 else (add-to-coll coll cch))))
1373 (setf (iostruct-entity-names tokenbuf)
1374 (rest (iostruct-entity-names tokenbuf)))
1375 (close entity-stream)
1376 (put-back-tokenbuf tmp-buf)))))
1378 (setf state state-dtdstart)
1381 (setf state reference-save-state)
1382 else (let ((tmp (compute-coll-string entity)))
1385 (add-to-coll coll ch)
1386 (setq ch (get-next-char tokenbuf))
1389 (xml-error (concatenate 'string
1390 "reference not terminated by ';', starting at: '&"
1392 (compute-coll-string coll)
1395 (#.state-dtd-!-attdef-decl-value6
1396 (let ((code (char-code ch)))
1398 then (add-to-coll coll (code-char char-code))
1400 (setq state state-dtd-!-attdef-decl-value)
1401 elseif (<= (char-code #\0) code (char-code #\9))
1402 then (setf char-code (+ (* char-code 16) (- code (char-code #\0))))
1403 elseif (<= (char-code #\A) code (char-code #\F))
1404 then (setf char-code (+ 10 (* char-code 16) (- code (char-code #\A))))
1405 elseif (<= (char-code #\a) code (char-code #\f))
1406 then (setf char-code (+ 10 (* char-code 16) (- code (char-code #\a))))
1407 else (clear-coll coll)
1409 (add-to-coll coll ch)
1410 (setq ch (get-next-char tokenbuf))
1413 (xml-error (concatenate 'string
1414 "illegal hexidecimal character reference code, starting at: '"
1415 (compute-coll-string coll)
1416 "', calculated char code: "
1417 (format nil "~s" char-code)))
1419 (#.state-dtd-!-attdef-decl-value7
1420 (let ((code (char-code ch)))
1422 then (add-to-coll coll (code-char char-code))
1424 (setq state reference-save-state)
1425 elseif (<= (char-code #\0) code (char-code #\9))
1426 then (setf char-code (+ (* char-code 10) (- code (char-code #\0))))
1427 else (clear-coll coll)
1429 (add-to-coll coll ch)
1430 (setq ch (get-next-char tokenbuf))
1433 (xml-error (concatenate 'string
1434 "illegal decimal character reference code, starting at: '"
1435 (compute-coll-string coll)
1436 "', calculated char code: "
1437 (format nil "~s" char-code)))
1439 (#.state-dtd-!-attdef-decl-type
1440 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1441 elseif (and external (eq #\% ch)) then
1442 (external-param-reference tokenbuf coll external-callback)
1443 elseif (or (xml-space-p ch) (eq #\> ch)) then
1444 (let ((token (compute-tag coll)))
1445 (when (and (not (eq :REQUIRED token))
1446 (not (eq :IMPLIED token))
1447 (not (eq :FIXED token)))
1449 (add-to-coll coll ch)
1450 (setq ch (get-next-char tokenbuf))
1453 (xml-error (concatenate 'string
1454 "illegal DTD <!ATTLIST type spec for "
1455 (string (first contents-to-return))
1457 (compute-coll-string coll)
1459 (push token pending)
1460 (if* (eq :FIXED token) then
1463 (add-to-coll coll ch)
1464 (setq ch (get-next-char tokenbuf))
1467 (xml-error (concatenate 'string
1468 "illegal DTD <!ATTLIST type spec for "
1469 (string (first contents-to-return))
1471 (compute-coll-string coll)
1473 (setf state state-dtd-!-attdef-decl-value2)
1474 elseif (eq #\> ch) then
1475 (setf contents-to-return
1476 (append contents-to-return (list (nreverse pending))))
1478 else (setf contents-to-return
1479 (append contents-to-return (list (nreverse pending))))
1480 (setf pending (list nil))
1481 (setf state state-dtd-!-attdef)))
1483 else (dotimes (i 15)
1484 (add-to-coll coll ch)
1485 (setq ch (get-next-char tokenbuf))
1488 (xml-error (concatenate 'string
1489 "illegal DTD <!ATTLIST type spec for "
1490 (string (first contents-to-return))
1492 (compute-coll-string coll)
1495 (#. state-dtd-!-attdef-decl-value2
1496 (if* (xml-space-p ch) then nil
1497 elseif (and external (eq #\% ch)) then
1498 (external-param-reference tokenbuf coll external-callback)
1499 elseif (or (eq #\' ch) (eq #\" ch)) then
1500 (setf value-delim ch)
1501 (setf state state-dtd-!-attdef-decl-value)
1502 else (dotimes (i 15)
1503 (add-to-coll coll ch)
1504 (setq ch (get-next-char tokenbuf))
1507 (xml-error (concatenate 'string
1508 "illegal DTD <!ATTLIST type spec for "
1509 (string (first contents-to-return))
1511 (compute-coll-string coll)
1514 (#.state-dtd-!-element
1515 (if* (xml-space-p ch) then nil
1516 elseif (and external (eq #\% ch)) then
1517 (external-param-reference tokenbuf coll external-callback)
1518 elseif (xml-name-start-char-p ch) then (setf state state-dtd-!-element-name)
1520 else (dotimes (i 15)
1521 (add-to-coll coll ch)
1522 (setq ch (get-next-char tokenbuf))
1525 (xml-error (concatenate 'string
1526 "illegal DTD characters, starting at: '<!ELEMENT "
1527 (compute-coll-string coll)
1529 (#.state-dtd-!-element-name
1530 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1531 elseif (and external (eq #\% ch)) then
1532 (external-param-reference tokenbuf coll external-callback)
1533 elseif (xml-space-p ch) then
1534 (push (compute-tag coll)
1537 (setf state state-dtd-!-element-type)
1538 else (dotimes (i 15)
1539 (add-to-coll coll ch)
1540 (setq ch (get-next-char tokenbuf))
1543 (xml-error (concatenate 'string
1544 "illegal DTD <!ELEMENT name: '"
1545 (compute-coll-string coll)
1548 (#.state-dtd-!-element-type
1549 (if* (eq #\( ch) then (setf state state-dtd-!-element-type-paren)
1550 elseif (xml-space-p ch) then nil
1551 elseif (and external (eq #\% ch)) then
1552 (external-param-reference tokenbuf coll external-callback)
1553 elseif (xml-name-start-char-p ch) then
1555 (setf state state-dtd-!-element-type-token)
1556 else (dotimes (i 15)
1557 (add-to-coll coll ch)
1558 (setq ch (get-next-char tokenbuf))
1561 (xml-error (concatenate 'string
1562 "illegal DTD <!ELEMENT content spec for "
1563 (string (first contents-to-return))
1565 (compute-coll-string coll)
1568 (#.state-dtd-!-element-type-paren
1569 (if* (xml-space-p ch) then nil
1570 elseif (and external (eq #\% ch)) then
1571 (external-param-reference tokenbuf coll external-callback)
1572 elseif (xml-name-start-char-p ch) then
1574 (setf state state-dtd-!-element-type-paren-name)
1575 elseif (eq #\# ch) then
1576 (setf state state-dtd-!-element-type-paren-pcd)
1577 elseif (eq #\( ch) then
1579 (setf state state-dtd-!-element-type-paren-choice-paren)
1580 else (dotimes (i 15)
1581 (add-to-coll coll ch)
1582 (setq ch (get-next-char tokenbuf))
1585 (xml-error (concatenate 'string
1586 "illegal DTD <!ELEMENT content spec for "
1587 (string (first contents-to-return))
1589 (compute-coll-string coll)
1591 (#.state-dtd-!-element-type-paren2
1592 (if* (eq #\> ch) then
1593 ;; there only one name...
1594 (setf (first contents-to-return) (first (first contents-to-return)))
1596 elseif (eq #\* ch) then
1597 (setf state state-dtd-!-element-type-paren-pcd5)
1598 (setf (first contents-to-return) (nreverse (first contents-to-return)))
1599 (if* (> (length (first contents-to-return)) 1) then
1600 (setf (first contents-to-return)
1601 (list (append (list :choice)
1602 (first contents-to-return))))
1603 elseif (listp (first (first contents-to-return))) then
1604 (setf (first contents-to-return)
1605 (first (first contents-to-return))))
1606 (push :* (first contents-to-return))
1607 elseif (eq #\? ch) then
1608 (setf state state-dtd-!-element-type-paren-pcd5)
1609 (setf (first contents-to-return) (nreverse (first contents-to-return)))
1610 (if* (> (length (first contents-to-return)) 1) then
1611 (setf (first contents-to-return)
1612 (list (append (list :choice)
1613 (first contents-to-return))))
1614 elseif (listp (first (first contents-to-return))) then
1615 (setf (first contents-to-return)
1616 (first (first contents-to-return))))
1617 (push :? (first contents-to-return))
1618 elseif (eq #\+ ch) then
1619 (setf state state-dtd-!-element-type-paren-pcd5)
1620 (setf (first contents-to-return) (nreverse (first contents-to-return)))
1621 (if* (> (length (first contents-to-return)) 1) then
1622 (setf (first contents-to-return)
1623 (list (append (list :choice)
1624 (first contents-to-return))))
1625 elseif (listp (first (first contents-to-return))) then
1626 (setf (first contents-to-return)
1627 (first (first contents-to-return))))
1628 (push :+ (first contents-to-return))
1629 elseif (and external (eq #\% ch)) then
1630 (external-param-reference tokenbuf coll external-callback)
1631 elseif (xml-space-p ch) then
1632 (setf state state-dtd-!-element-type-paren-pcd5)
1633 (setf (first contents-to-return) (nreverse (first contents-to-return)))
1634 (when (> (length (first contents-to-return)) 1)
1635 (setf (first contents-to-return)
1636 (list (append (list :\choice)
1637 (first contents-to-return)))))
1638 else (dotimes (i 15)
1639 (add-to-coll coll ch)
1640 (setq ch (get-next-char tokenbuf))
1643 (xml-error (concatenate 'string
1644 "illegal DTD <!ELEMENT content spec for "
1645 (string (first (reverse contents-to-return)))
1647 (compute-coll-string coll)
1650 (#.state-dtd-!-element-type-paren-name
1651 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1652 elseif (and external (eq #\% ch)) then
1653 (external-param-reference tokenbuf coll external-callback)
1654 elseif (xml-space-p ch) then
1655 (push (compute-tag coll) (first pending))
1657 (setf state state-dtd-!-element-type-paren-name2)
1658 elseif (eq #\? ch) then
1659 (push (compute-tag coll) (first pending))
1660 (setf (first pending)
1661 (list (push :? (first pending))))
1663 (setf state state-dtd-!-element-type-paren-name2)
1664 elseif (eq #\* ch) then
1665 (push (compute-tag coll) (first pending))
1666 (setf (first pending)
1667 (list (push :* (first pending))))
1669 (setf state state-dtd-!-element-type-paren-name2)
1670 elseif (eq #\+ ch) then
1671 (push (compute-tag coll) (first pending))
1672 (setf (first pending)
1673 (list (push :+ (first pending))))
1675 (setf state state-dtd-!-element-type-paren-name2)
1676 elseif (eq #\) ch) then
1677 (push (compute-tag coll) (first pending))
1679 (if* (= (length pending) 1) then
1680 (push (first pending) contents-to-return)
1681 (setf state state-dtd-!-element-type-paren2)
1682 else ;; this is (xxx)
1683 (if* (second pending) then
1684 (push (first pending) (second pending))
1685 else (setf (second pending) (first pending)))
1686 (setf pending (rest pending))
1687 (setf state state-dtd-!-element-type-paren-choice-name3)
1689 elseif (eq #\, ch) then
1690 (when (and (first pending) (not (eq :seq (first pending-type))))
1693 (add-to-coll coll ch)
1694 (setq ch (get-next-char tokenbuf))
1697 (xml-error (concatenate 'string
1698 "illegal '|' and ',' mix starting at '"
1699 (compute-coll-string coll)
1701 (push (compute-tag coll) (first pending))
1702 (push :seq pending-type)
1704 (setf state state-dtd-!-element-type-paren-choice)
1705 elseif (eq #\| ch) then
1706 (when (and (first pending) (not (eq :choice (first pending-type))))
1709 (add-to-coll coll ch)
1710 (setq ch (get-next-char tokenbuf))
1713 (xml-error (concatenate 'string
1714 "illegal '|' and ',' mix starting at '"
1715 (compute-coll-string coll)
1717 (push (compute-tag coll) (first pending))
1718 (push :choice pending-type)
1720 (setf state state-dtd-!-element-type-paren-choice)
1721 else (dotimes (i 15)
1722 (add-to-coll coll ch)
1723 (setq ch (get-next-char tokenbuf))
1726 (xml-error (concatenate 'string
1727 "illegal DTD <!ELEMENT content spec for "
1728 (string (first contents-to-return))
1730 (compute-coll-string coll)
1733 (#.state-dtd-!-element-type-paren-name2
1734 (if* (xml-space-p ch) then nil
1735 elseif (and external (eq #\% ch)) then
1736 (external-param-reference tokenbuf coll external-callback)
1737 elseif (eq #\| ch) then
1738 (when (and (rest (first pending)) (not (eq :choice (first pending-type))))
1741 (add-to-coll coll ch)
1742 (setq ch (get-next-char tokenbuf))
1745 (xml-error (concatenate 'string
1746 "illegal '|' and ',' mix starting at '"
1747 (compute-coll-string coll)
1749 (push :choice pending-type)
1750 (setf state state-dtd-!-element-type-paren-choice)
1751 elseif (eq #\, ch) then
1752 (when (and (rest (first pending)) (not (eq :seq (first pending-type))))
1755 (add-to-coll coll ch)
1756 (setq ch (get-next-char tokenbuf))
1759 (xml-error (concatenate 'string
1760 "illegal '|' and ',' mix starting at '"
1761 (compute-coll-string coll)
1763 (push :seq pending-type)
1764 (setf state state-dtd-!-element-type-paren-choice)
1765 elseif (eq #\) ch) then
1766 (if* (= (length pending) 1) then
1767 (push (list (first pending)) contents-to-return)
1768 (setf state state-dtd-!-element-type-paren2)
1769 else (setf pending (reverse (rest (reverse pending))))
1771 else (dotimes (i 15)
1772 (add-to-coll coll ch)
1773 (setq ch (get-next-char tokenbuf))
1776 (xml-error (concatenate 'string
1777 "illegal DTD <!ELEMENT content spec for "
1778 (string (first (reverse contents-to-return)))
1780 (compute-coll-string coll)
1784 (#.state-dtd-!-element-type-paren-choice
1785 (if* (xml-name-start-char-p ch) then
1787 (setf state state-dtd-!-element-type-paren-choice-name)
1788 elseif (xml-space-p ch) then nil
1789 elseif (and external (eq #\% ch)) then
1790 (external-param-reference tokenbuf coll external-callback)
1791 elseif (eq #\( ch) then
1793 (setf state state-dtd-!-element-type-paren-choice-paren)
1794 elseif (eq #\) ch) then
1795 (if* (= (length pending) 1) then
1796 (setf (first pending) (nreverse (first pending)))
1797 (if* (> (length (first pending)) 1) then
1798 (push (first pending-type) (first pending))
1799 (setf pending-type (rest pending-type))
1800 else (setf (first pending) (first (first pending))))
1801 (push (first pending) contents-to-return)
1802 (setf state state-dtd-!-element-type-paren3)
1803 else (setf (first pending) (nreverse (first pending)))
1804 (if* (> (length (first pending)) 1) then
1805 (push (first pending-type) (first pending))
1806 (setf pending-type (rest pending-type))
1807 else (setf (first pending) (first (first pending))))
1808 (if* (second pending) then
1809 (push (first pending) (second pending))
1810 else (setf (second pending) (list (first pending))))
1811 (setf pending (rest pending))
1812 (setf state state-dtd-!-element-type-paren-choice-name3)
1814 else (dotimes (i 15)
1815 (add-to-coll coll ch)
1816 (setq ch (get-next-char tokenbuf))
1819 (xml-error (concatenate 'string
1820 "illegal DTD <!ELEMENT content spec for "
1821 (string (first (reverse contents-to-return)))
1823 (compute-coll-string coll)
1827 (#.state-dtd-!-element-type-paren-choice-paren
1828 (if* (xml-name-start-char-p ch) then
1829 (setf state state-dtd-!-element-type-paren-name)
1831 elseif (eq #\( ch) then (push nil pending)
1832 elseif (xml-space-p ch) then nil
1833 elseif (and external (eq #\% ch)) then
1834 (external-param-reference tokenbuf coll external-callback)
1835 else (dotimes (i 15)
1836 (add-to-coll coll ch)
1837 (setq ch (get-next-char tokenbuf))
1840 (xml-error (concatenate 'string
1841 "illegal DTD <!ELEMENT content spec for "
1842 (string (first contents-to-return))
1844 (compute-coll-string coll)
1847 (#.state-dtd-!-element-type-paren-choice-name
1848 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
1849 elseif (and external (eq #\% ch)) then
1850 (external-param-reference tokenbuf coll external-callback)
1851 elseif (xml-space-p ch) then
1852 (push (compute-tag coll) (first pending))
1854 (setf state state-dtd-!-element-type-paren-choice-name2)
1855 elseif (eq #\? ch) then
1856 (push (list :? (compute-tag coll)) (first pending))
1858 (setf state state-dtd-!-element-type-paren-choice-name2)
1859 elseif (eq #\* ch) then
1860 (push (list :* (compute-tag coll)) (first pending))
1862 (setf state state-dtd-!-element-type-paren-choice-name2)
1863 elseif (eq #\+ ch) then
1864 (push (list :+ (compute-tag coll)) (first pending))
1866 (setf state state-dtd-!-element-type-paren-choice-name2)
1867 elseif (eq #\) ch) then
1868 (push (compute-tag coll) (first pending))
1870 (if* (= (length pending) 1) then
1871 (setf (first pending) (nreverse (first pending)))
1872 (if* (> (length (first pending)) 1) then
1873 (push (first pending-type) (first pending))
1874 (setf pending-type (rest pending-type))
1875 else (setf (first pending) (first (first pending))))
1876 (push (first pending) contents-to-return)
1877 (setf state state-dtd-!-element-type-paren3)
1878 else (setf (first pending) (nreverse (first pending)))
1879 (push (first pending-type) (first pending))
1880 (setf pending-type (rest pending-type))
1881 (if* (second pending) then
1882 (push (first pending) (second pending))
1883 else (setf (second pending)
1884 ;; (list (first pending)) ;2001-03-22
1885 (first pending) ;2001-03-22
1887 (setf pending (rest pending))
1888 (setf state state-dtd-!-element-type-paren-choice-name3)
1890 elseif (eq #\, ch) then
1891 (when (and (first pending) (not (eq :seq (first pending-type))))
1894 (add-to-coll coll ch)
1895 (setq ch (get-next-char tokenbuf))
1898 (xml-error (concatenate 'string
1899 "illegal '|' and ',' mix starting at '"
1900 (compute-coll-string coll)
1902 (push (compute-tag coll) (first pending))
1904 (push :seq pending-type)
1905 (setf state state-dtd-!-element-type-paren-choice)
1906 elseif (eq #\| ch) then
1907 (when (and (first pending) (not (eq :choice (first pending-type))))
1910 (add-to-coll coll ch)
1911 (setq ch (get-next-char tokenbuf))
1914 (xml-error (concatenate 'string
1915 "illegal '|' and ',' mix starting at '"
1916 (compute-coll-string coll)
1918 (push (compute-tag coll) (first pending))
1920 (push :choice pending-type)
1921 (setf state state-dtd-!-element-type-paren-choice)
1922 else (dotimes (i 15)
1923 (add-to-coll coll ch)
1924 (setq ch (get-next-char tokenbuf))
1927 (xml-error (concatenate 'string
1928 "illegal DTD <!ELEMENT content spec for "
1929 (string (first contents-to-return))
1931 (compute-coll-string coll)
1934 (#.state-dtd-!-element-type-paren-choice-name2
1936 ;; begin changes 2001-03-22
1937 then (setf state state-dtd-!-element-type-paren-choice)
1938 (push :choice pending-type)
1940 then (setf state state-dtd-!-element-type-paren-choice)
1941 (push :seq pending-type)
1942 ;; end changes 2001-03-22
1943 elseif (xml-space-p ch) then nil
1944 elseif (and external (eq #\% ch)) then
1945 (external-param-reference tokenbuf coll external-callback)
1946 elseif (eq #\) ch) then
1947 (if* (= (length pending) 1) then
1948 (setf (first pending) (nreverse (first pending)))
1949 (if* (> (length (first pending)) 1) then
1950 (push (first pending-type) (first pending))
1951 (setf pending-type (rest pending-type))
1952 else (setf (first pending) (first (first pending))))
1953 (push (first pending) contents-to-return)
1954 (setf state state-dtd-!-element-type-paren3)
1955 else (setf (first pending) (nreverse (first pending)))
1956 (push (first pending-type) (first pending))
1957 (setf pending-type (rest pending-type))
1958 (if* (second pending) then
1959 (push (first pending) (second pending))
1960 else (setf (second pending) (list (first pending))))
1961 (setf state state-dtd-!-element-type-paren-choice-name3)
1963 (setf pending (rest pending))
1964 else (dotimes (i 15)
1965 (add-to-coll coll ch)
1966 (setq ch (get-next-char tokenbuf))
1969 (xml-error (concatenate 'string
1970 "illegal DTD <!ELEMENT content spec for "
1971 (string (first contents-to-return))
1973 (compute-coll-string coll)
1976 (#.state-dtd-!-element-type-paren-choice-name3
1977 (if* (xml-space-p ch) then nil
1978 elseif (and external (eq #\% ch)) then
1979 (external-param-reference tokenbuf coll external-callback)
1980 elseif (eq #\? ch) then
1981 (setf (first pending) (list :? (first pending)))
1982 (setf state state-dtd-!-element-type-paren-choice-name2)
1983 elseif (eq #\* ch) then
1984 (setf (first pending) (list :* (first pending)))
1985 (setf state state-dtd-!-element-type-paren-choice-name2)
1986 elseif (eq #\+ ch) then
1987 (setf (first pending) (list :+ (first pending)))
1988 (setf state state-dtd-!-element-type-paren-choice-name2)
1989 elseif (eq #\) ch) then
1990 (if* (= (length pending) 1) then
1991 (setf (first pending) (nreverse (first pending)))
1992 (if* (> (length (first pending)) 1) then
1993 (push (first pending-type) (first pending))
1994 (setf pending-type (rest pending-type))
1995 else (setf (first pending) (first (first pending))))
1996 (push (first pending) contents-to-return)
1997 (setf pending (rest pending))
1998 (setf state state-dtd-!-element-type-paren3)
1999 else (setf (first pending) (nreverse (first pending)))
2000 (if* (> (length (first pending)) 1) then
2001 (push (first pending-type) (first pending))
2002 (setf pending-type (rest pending-type))
2003 else (setf (first pending) (first (first pending))))
2004 (if* (second pending) then
2005 (push (first pending) (second pending))
2006 else (setf (second pending) (list (first pending))))
2007 (setf pending (rest pending))
2008 (setf state state-dtd-!-element-type-paren-choice)
2010 elseif (eq #\, ch) then
2011 (when (and (rest (first pending)) (not (eq :seq (first pending-type))))
2014 (add-to-coll coll ch)
2015 (setq ch (get-next-char tokenbuf))
2018 (xml-error (concatenate 'string
2019 "illegal '|' and ',' mix starting at '"
2020 (compute-coll-string coll)
2022 (push :seq pending-type)
2023 (setf state state-dtd-!-element-type-paren-choice)
2024 elseif (eq #\| ch) then
2025 (when (and (rest (first pending)) (not (eq :choice (first pending-type))))
2028 (add-to-coll coll ch)
2029 (setq ch (get-next-char tokenbuf))
2032 (xml-error (concatenate 'string
2033 "illegal '|' and ',' mix starting at '"
2034 (compute-coll-string coll)
2036 (push :choice pending-type)
2037 (setf state state-dtd-!-element-type-paren-choice)
2038 else (dotimes (i 15)
2039 (add-to-coll coll ch)
2040 (setq ch (get-next-char tokenbuf))
2043 (xml-error (concatenate 'string
2044 "illegal DTD <!ELEMENT content spec for "
2045 (string (first contents-to-return))
2047 (compute-coll-string coll)
2050 (#.state-dtd-!-element-type-paren3
2051 (if* (eq #\+ ch) then
2052 (setf (first contents-to-return)
2053 (append (list :+) (list (first contents-to-return))))
2054 (setf state state-dtd-!-element-type-paren-pcd5)
2055 elseif (eq #\? ch) then
2056 (setf (first contents-to-return)
2057 (append (list :?) (list (first contents-to-return))))
2058 (setf state state-dtd-!-element-type-paren-pcd5)
2059 elseif (eq #\* ch) then
2060 (setf (first contents-to-return)
2061 (append (list :*) (list (first contents-to-return))))
2062 (setf state state-dtd-!-element-type-paren-pcd5)
2063 elseif (and external (eq #\% ch)) then
2064 (external-param-reference tokenbuf coll external-callback)
2065 elseif (xml-space-p ch) then
2066 (setf state state-dtd-!-element-type-paren-pcd5)
2067 elseif (eq #\> ch) then (return)
2068 else (dotimes (i 15)
2069 (add-to-coll coll ch)
2070 (setq ch (get-next-char tokenbuf))
2073 (xml-error (concatenate 'string
2074 "illegal DTD <!ELEMENT content spec for "
2075 (string (first (reverse contents-to-return)))
2077 (compute-coll-string coll)
2080 (#.state-dtd-!-element-type-paren-pcd
2081 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
2082 elseif (and external (eq #\% ch)) then
2083 (external-param-reference tokenbuf coll external-callback)
2084 elseif (xml-space-p ch) then
2085 (let ((token (compute-tag coll)))
2086 (when (not (eq token :PCDATA))
2087 (xml-error (concatenate 'string
2088 "illegal DTD <!ELEMENT content spec for "
2089 (string (first contents-to-return))
2091 (compute-coll-string coll)
2094 (push token contents-to-return))
2095 (setf state state-dtd-!-element-type-paren-pcd2)
2096 elseif (eq #\| ch) then
2097 (let ((token (compute-tag coll)))
2098 (when (not (eq token :PCDATA))
2099 (xml-error (concatenate 'string
2100 "illegal DTD <!ELEMENT content spec for "
2101 (string (first contents-to-return))
2103 (compute-coll-string coll)
2105 (push token contents-to-return))
2107 (setf state state-dtd-!-element-type-paren-pcd3)
2108 elseif (eq #\) ch) then
2109 (let ((token (compute-tag coll)))
2110 (when (not (eq token :PCDATA))
2111 (xml-error (concatenate 'string
2112 "illegal DTD <!ELEMENT content spec for "
2113 (string (first contents-to-return))
2115 (compute-coll-string coll)
2117 (push token contents-to-return))
2118 (setf state state-dtd-!-element-type-paren-pcd4)
2119 else (dotimes (i 15)
2120 (add-to-coll coll ch)
2121 (setq ch (get-next-char tokenbuf))
2124 (xml-error (concatenate 'string
2125 "illegal DTD <!ELEMENT content spec for "
2126 (string (first contents-to-return))
2128 (compute-coll-string coll)
2131 (#.state-dtd-!-element-type-paren-pcd2
2132 (if* (xml-space-p ch) then nil
2133 elseif (and external (eq #\% ch)) then
2134 (external-param-reference tokenbuf coll external-callback)
2135 elseif (eq #\) ch) then
2136 (setf state state-dtd-!-element-type-paren-pcd4)
2137 elseif (eq #\| ch) then (setf state state-dtd-!-element-type-paren-pcd3)
2138 else (dotimes (i 15)
2139 (add-to-coll coll ch)
2140 (setq ch (get-next-char tokenbuf))
2143 (xml-error (concatenate 'string
2144 "illegal DTD <!ELEMENT content spec for "
2145 (string (first (reverse contents-to-return)))
2147 (compute-coll-string coll)
2150 (#.state-dtd-!-element-type-paren-pcd3
2151 (if* (xml-space-p ch) then nil
2152 elseif (and external (eq #\% ch)) then
2153 (external-param-reference tokenbuf coll external-callback)
2154 elseif (xml-name-start-char-p ch) then
2156 (setf state state-dtd-!-element-type-paren-pcd7)
2157 else (dotimes (i 15)
2158 (add-to-coll coll ch)
2159 (setq ch (get-next-char tokenbuf))
2162 (xml-error (concatenate 'string
2163 "illegal DTD <!ELEMENT content spec for "
2164 (string (first (reverse contents-to-return)))
2166 (compute-coll-string coll)
2169 (#.state-dtd-!-element-type-paren-pcd4
2170 (if* (xml-space-p ch) then
2171 (setf state state-dtd-!-element-type-paren-pcd6)
2172 elseif (and external (eq #\% ch)) then
2173 (external-param-reference tokenbuf coll external-callback)
2174 elseif (eq #\* ch) then
2175 (setf (first contents-to-return) '(:* :PCDATA))
2176 (setf state state-dtd-!-element-type-paren-pcd5)
2177 elseif (eq #\> ch) then (return)
2178 else (clear-coll coll)
2180 (add-to-coll coll ch)
2181 (setq ch (get-next-char tokenbuf))
2184 (xml-error (concatenate 'string
2185 "illegal DTD contents following <!ELEMENT content spec for "
2186 (string (first (reverse contents-to-return)))
2188 (compute-coll-string coll)
2191 (#.state-dtd-!-element-type-paren-pcd5
2192 (if* (xml-space-p ch) then nil
2193 elseif (and external (eq #\% ch)) then
2194 (external-param-reference tokenbuf coll external-callback)
2195 elseif (eq #\> ch) then (return)
2196 else (clear-coll coll)
2198 (add-to-coll coll ch)
2199 (setq ch (get-next-char tokenbuf))
2202 (xml-error (concatenate 'string
2203 "illegal DTD contents following <!ELEMENT content spec for "
2204 (string (first (reverse contents-to-return)))
2206 (compute-coll-string coll)
2209 (#.state-dtd-!-element-type-paren-pcd6
2210 (if* (xml-space-p ch) then nil
2211 elseif (and external (eq #\% ch)) then
2212 (external-param-reference tokenbuf coll external-callback)
2213 elseif (eq #\> ch) then (return)
2214 else (clear-coll coll)
2216 (add-to-coll coll ch)
2217 (setq ch (get-next-char tokenbuf))
2220 (xml-error (concatenate 'string
2221 "illegal DTD contents following <!ELEMENT content spec for "
2222 (string (first (reverse contents-to-return)))
2224 (compute-coll-string coll)
2227 (#.state-dtd-!-element-type-paren-pcd7
2228 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
2229 elseif (and external (eq #\% ch)) then
2230 (external-param-reference tokenbuf coll external-callback)
2231 elseif (xml-space-p ch) then
2232 (setf state state-dtd-!-element-type-paren-pcd8)
2233 (let ((token (compute-tag coll)))
2235 (if* (listp (first contents-to-return)) then
2236 (push token (first contents-to-return))
2237 else (setf (first contents-to-return)
2238 (list token (first contents-to-return)))))
2239 elseif (eq #\) ch) then
2240 (setf state state-dtd-!-element-type-paren-pcd9)
2241 (let ((token (compute-tag coll)))
2243 (if* (listp (first contents-to-return)) then
2244 (push token (first contents-to-return))
2245 else (setf (first contents-to-return)
2246 (list token (first contents-to-return)))))
2247 else (clear-coll coll)
2249 (add-to-coll coll ch)
2250 (setq ch (get-next-char tokenbuf))
2253 (xml-error (concatenate 'string
2254 "illegal DTD contents in <!ELEMENT content spec for "
2255 (string (first (reverse contents-to-return)))
2257 (compute-coll-string coll)
2260 (#.state-dtd-!-element-type-paren-pcd8
2261 (if* (xml-space-p ch) then nil
2262 elseif (and external (eq #\% ch)) then
2263 (external-param-reference tokenbuf coll external-callback)
2264 elseif (eq #\| ch) then (setf state state-dtd-!-element-type-paren-pcd3)
2265 elseif (eq #\) ch) then (setf state state-dtd-!-element-type-paren-pcd9)
2266 else (clear-coll coll)
2268 (add-to-coll coll ch)
2269 (setq ch (get-next-char tokenbuf))
2272 (xml-error (concatenate 'string
2273 "illegal DTD contents in <!ELEMENT content spec for "
2274 (string (first (reverse contents-to-return)))
2276 (compute-coll-string coll)
2279 (#.state-dtd-!-element-type-paren-pcd9
2280 (if* (eq #\* ch) then (setf state state-dtd-!-element-type-paren-pcd5)
2281 (setf (first contents-to-return) (nreverse (first contents-to-return)))
2282 (when (> (length (first contents-to-return)) 1)
2283 (setf (first contents-to-return)
2284 (list (append (list :choice)
2285 (first contents-to-return)))))
2286 (push :* (first contents-to-return))
2287 else (clear-coll coll)
2289 (add-to-coll coll ch)
2290 (setq ch (get-next-char tokenbuf))
2293 (xml-error (concatenate 'string
2294 "illegal DTD contents in <!ELEMENT content spec for "
2295 (string (first (reverse contents-to-return)))
2297 (compute-coll-string coll)
2300 (#.state-dtd-!-element-type-token
2301 (if* (xml-name-char-p ch) then (add-to-coll coll ch)
2302 elseif (and external (eq #\% ch)) then
2303 (external-param-reference tokenbuf coll external-callback)
2304 elseif (xml-space-p ch) then
2305 (let ((token (compute-tag coll)))
2306 (when (not (or (eq token :EMPTY) (eq token :ANY)))
2307 (xml-error (concatenate 'string
2308 "illegal DTD <!ELEMENT content spec for "
2309 (string (first contents-to-return))
2311 (compute-coll-string coll)
2313 (push token contents-to-return)
2314 (setf state state-dtd-!-element-type-end))
2315 elseif (eq #\> ch) then
2316 (let ((token (compute-tag coll)))
2317 (when (not (or (eq token :EMPTY) (eq token :ANY)))
2318 (xml-error (concatenate 'string
2319 "illegal DTD <!ELEMENT content spec for "
2320 (string (first contents-to-return))
2322 (compute-coll-string coll)
2324 (push token contents-to-return)
2326 else (add-to-coll coll ch)
2327 (xml-error (concatenate 'string
2328 "illegal DTD <!ELEMENT content spec for "
2329 (string (first contents-to-return))
2331 (compute-coll-string coll)
2335 (#.state-dtd-!-element-type-end
2336 (if* (xml-space-p ch) then nil
2337 elseif (and external (eq #\% ch)) then
2338 (external-param-reference tokenbuf coll external-callback)
2339 elseif (eq #\> ch) then (return)
2340 else (xml-error (concatenate 'string
2341 "expected '>', got '"
2343 "' in DTD <! ELEMENT "
2344 (string (first contents-to-return))
2346 (string (second contents-to-return))))
2349 (error "need to support dtd state:~s" state))))
2350 (put-back-collector entity)
2351 (put-back-collector coll)
2354 (when (and (null ch) (not external))
2355 (xml-error "unexpected end of input while parsing DTD"))
2356 (if* (null tag-to-return) then (values nil :end-dtd)
2357 else (error "process other return state")))
2358 ((#.state-dtd-!-element-type-end #.state-dtd-!-element-type-token
2359 #.state-dtd-!-element-type-paren-pcd4 #.state-dtd-!-element-type-paren-pcd6
2360 #.state-dtd-!-element-type-paren-pcd5 #.state-dtd-!-element-type-paren2
2361 #.state-dtd-!-element-type-paren3)
2362 (values (append (list tag-to-return) (nreverse contents-to-return))
2364 ((#.state-dtd-!-attdef-decl-type #.state-dtd-!-attlist-name
2365 #.state-dtd-!-attdef)
2366 (values (append (list tag-to-return) contents-to-return)
2368 ((#.state-dtd-!-entity5 #.state-!-dtd-system3
2369 #.state-!-dtd-system7 #.state-!-dtd-system4
2370 #.state-!-dtd-system ;; this is actually a !NOTATION
2371 #.state-dtd-?-4 ;; PI
2372 #.state-dtd-comment4 ;; comment
2374 (let ((ret (append (list tag-to-return) (nreverse contents-to-return))))
2379 (values (nreverse contents-to-return) nil))
2380 (#.state-dtd-!-include2
2381 (values nil :include))
2382 (#.state-dtd-!-include4
2383 (values nil :include-end))
2384 (#.state-dtd-!-ignore7
2385 (values nil :ignore))
2387 (if* (not external) then
2388 (xml-error "unexpected end of input while processing DTD internal subset")
2389 elseif (or (> include-count 0) (not (eq prev-state state-dtdstart))) then
2390 (xml-error "unexpected end of input while processing external DTD"))
2391 (values nil :end-dtd))
2393 (print (list tag-to-return contents-to-return))
2394 (error "need to support dtd <post> state:~s" state)))
2398 (defun external-param-reference (tokenbuf old-coll external-callback)
2399 (declare (:fbound next-token) (ignorable old-coll) (optimize (speed 3) (safety 1)))
2400 (setf (iostruct-seen-parameter-reference tokenbuf) t)
2401 (macrolet ((add-to-entity-buf (entity-symbol p-value)
2403 (push (make-tokenbuf :cur 0 :max (length ,p-value) :data ,p-value)
2404 (iostruct-entity-bufs tokenbuf))))
2406 `(setf (collector-next ,coll) 0))
2408 `(push ,ch (iostruct-unget-char tokenbuf)))
2409 (add-to-coll (coll ch)
2410 `(let ((.next. (collector-next ,coll)))
2411 (if* (>= .next. (collector-max ,coll))
2412 then (grow-and-add ,coll ,ch)
2413 else (setf (schar (collector-data ,coll) .next.)
2415 (setf (collector-next ,coll) (1+ .next.))))))
2416 (let ((ch (get-next-char tokenbuf))
2417 (coll (get-collector))
2418 p-value entity-symbol)
2419 (add-to-coll coll ch)
2420 (when (not (xml-name-start-char-p ch))
2422 (add-to-coll coll ch)
2423 (setq ch (get-next-char tokenbuf))
2426 (xml-error (concatenate 'string
2427 "Illegal DTD parameter entity name starting at: "
2428 (compute-coll-string coll))))
2430 (setf ch (get-next-char tokenbuf))
2431 (if* (eq #\; ch) then
2432 (setf entity-symbol (compute-tag coll))
2434 #+ignore (format t "entity symbol: ~s entities: ~s match: ~s~%"
2435 entity-symbol (iostruct-parameter-entities tokenbuf)
2436 (assoc entity-symbol
2437 (iostruct-parameter-entities tokenbuf)))
2438 (if* (and (iostruct-do-entity tokenbuf)
2440 (assoc entity-symbol
2441 (iostruct-parameter-entities tokenbuf)))) then
2442 (setf p-value (rest p-value))
2443 (when (member entity-symbol (iostruct-entity-names tokenbuf))
2444 (xml-error (concatenate 'string
2446 (string entity-symbol)
2447 " in recursive reference")))
2448 (push entity-symbol (iostruct-entity-names tokenbuf))
2449 (if* (stringp p-value) then
2450 (setf p-value (concatenate 'string " " p-value " "))
2451 (add-to-entity-buf entity-symbol p-value)
2452 elseif (null external-callback) then
2453 (setf (iostruct-do-entity tokenbuf) nil)
2455 (let ((entity-stream (apply external-callback p-value)))
2457 (let ((entity-buf (get-tokenbuf)))
2458 (setf (tokenbuf-stream entity-buf) entity-stream)
2459 (unicode-check entity-stream tokenbuf)
2460 (add-to-entity-buf entity-symbol " ")
2462 (iostruct-entity-bufs tokenbuf))
2465 (if* (dotimes (i (length string) t)
2466 (setf cch (get-next-char tokenbuf))
2471 (schar string count)))
2476 (when (< count 0) (return))
2477 (un-next-char (schar string count))
2479 ;; swallow <?xml token
2480 (next-token tokenbuf external-callback nil)
2485 (when (< count 0) (return))
2486 (un-next-char (schar string count))
2488 (push #\space (iostruct-unget-char tokenbuf))
2492 (concatenate 'string
2493 (string entity-symbol)
2494 " parameter entity referenced but not declared"))
2496 (put-back-collector coll)
2498 elseif (xml-name-char-p ch) then (add-to-coll coll ch)
2501 (add-to-coll coll ch)
2502 (setq ch (get-next-char tokenbuf))
2505 (xml-error (concatenate 'string
2506 "Illegal DTD parameter entity name stating at: "
2507 (compute-coll-string coll))))))))